{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}  -- Reconcile.HasIdentity v (Id v), Ord (Id v) in signatures
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-- | Graph transformation operations over 'GraphView'.
--
-- This module provides bulk transformation, filtering, folding, and
-- iterative shape-aware algorithms for graphs represented as 'GraphView'.
--
-- == Overview
--
-- Transformations operate lazily over 'GraphView' and are composed by
-- function composition. Finalize a pipeline by calling 'Pattern.PatternGraph.materialize'.
--
-- Elements are classified by shape (via 'classifyByShape') into five buckets:
-- @GNode@, @GRelationship@, @GWalk@, @GAnnotation@, and @GOther@. The
-- 'topoShapeSort' function orders elements within a 'GraphView' so that
-- each element is processed after all elements it structurally depends on.
--
-- == Example
--
-- > pipeline :: PatternGraph Subject -> PatternGraph Subject
-- > pipeline graph =
-- >   Pattern.PatternGraph.materialize canonicalClassifier LastWriteWins
-- >   . mapWithContext canonicalClassifier enrich
-- >   . filterGraph canonicalClassifier isRelevant dissolve
-- >   . mapAllGraph updateTimestamp
-- >   . Pattern.PatternGraph.toGraphView canonicalClassifier
-- >   $ graph
module Pattern.Graph.Transform
  ( -- * Graph construction from seeds
    unfoldGraph
    -- * Bulk transformations
  , mapGraph
  , mapAllGraph
  , filterGraph
  , foldGraph
    -- * Context-aware enrichment
  , mapWithContext
    -- * Iterative topology-aware algorithms
  , scopeDictFromGraphView
  , paraGraph
  , paraGraphFixed
  ) where

import Data.List (foldl')
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (mapMaybe)
import qualified Data.Set as Set
import Pattern.Core (Pattern(..), ScopeDict, ScopeQuery(..), toScopeDict)
import Pattern.Graph.Types (GraphView(..))
import Pattern.Graph.GraphClassifier
  ( GraphClass(..), GraphClassifier(..), GraphValue(..) )
import Pattern.Graph.GraphQuery (GraphQuery(..))
import Pattern.Graph.Types (Substitution(..))
import Pattern.PatternGraph (PatternGraph, mergeWithPolicy, empty)
import qualified Pattern.Reconcile as Reconcile

-- ============================================================================
-- unfoldGraph
-- ============================================================================

-- | Build a 'PatternGraph' by expanding seed values into patterns and merging.
--
-- Each seed is expanded into a list of 'Pattern v' via the provided function.
-- All resulting patterns are merged into a single 'PatternGraph' using the
-- given reconciliation policy.
--
-- == Example
--
-- > rowToPatterns :: Row -> [Pattern Subject]
-- > rowToPatterns row = [ personNode row, departmentNode row, worksInRel row ]
-- >
-- > etlGraph = unfoldGraph canonicalClassifier LastWriteWins rowToPatterns rows
unfoldGraph
  :: ( GraphValue v, Eq v
     , Reconcile.Mergeable v, Reconcile.HasIdentity v (Id v), Reconcile.Refinable v )
  => GraphClassifier extra v
  -> Reconcile.ReconciliationPolicy (Reconcile.MergeStrategy v)
  -> (a -> [Pattern v])
  -> [a]
  -> PatternGraph extra v
unfoldGraph :: forall v extra a.
(GraphValue v, Eq v, Mergeable v, HasIdentity v (Id v),
 Refinable v) =>
GraphClassifier extra v
-> ReconciliationPolicy (MergeStrategy v)
-> (a -> [Pattern v])
-> [a]
-> PatternGraph extra v
unfoldGraph GraphClassifier extra v
classifier ReconciliationPolicy (MergeStrategy v)
policy a -> [Pattern v]
expand [a]
seeds =
  (PatternGraph extra v -> a -> PatternGraph extra v)
-> PatternGraph extra v -> [a] -> PatternGraph extra v
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\PatternGraph extra v
g a
seed -> (PatternGraph extra v -> Pattern v -> PatternGraph extra v)
-> PatternGraph extra v -> [Pattern v] -> PatternGraph extra v
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\PatternGraph extra v
g' Pattern v
p -> GraphClassifier extra v
-> ReconciliationPolicy (MergeStrategy v)
-> Pattern v
-> PatternGraph extra v
-> PatternGraph extra v
forall v extra.
(GraphValue v, Eq v, Mergeable v, HasIdentity v (Id v),
 Refinable v) =>
GraphClassifier extra v
-> ReconciliationPolicy (MergeStrategy v)
-> Pattern v
-> PatternGraph extra v
-> PatternGraph extra v
mergeWithPolicy GraphClassifier extra v
classifier ReconciliationPolicy (MergeStrategy v)
policy Pattern v
p PatternGraph extra v
g') PatternGraph extra v
g (a -> [Pattern v]
expand a
seed))
         PatternGraph extra v
forall v extra. GraphValue v => PatternGraph extra v
empty
         [a]
seeds

-- ============================================================================
-- mapGraph
-- ============================================================================

-- | Map over view elements, applying a different function per 'GraphClass'.
--
-- Each element in 'viewElements' is transformed by the function corresponding
-- to its category. The 'viewQuery' is passed through unchanged.
{-# INLINE mapGraph #-}
mapGraph
  :: GraphClassifier extra v
  -> (Pattern v -> Pattern v)  -- ^ nodes
  -> (Pattern v -> Pattern v)  -- ^ relationships
  -> (Pattern v -> Pattern v)  -- ^ walks
  -> (Pattern v -> Pattern v)  -- ^ annotations
  -> (Pattern v -> Pattern v)  -- ^ other / unrecognized
  -> GraphView extra v
  -> GraphView extra v
mapGraph :: forall extra v.
GraphClassifier extra v
-> (Pattern v -> Pattern v)
-> (Pattern v -> Pattern v)
-> (Pattern v -> Pattern v)
-> (Pattern v -> Pattern v)
-> (Pattern v -> Pattern v)
-> GraphView extra v
-> GraphView extra v
mapGraph GraphClassifier extra v
_classifier Pattern v -> Pattern v
fNode Pattern v -> Pattern v
fRel Pattern v -> Pattern v
fWalk Pattern v -> Pattern v
fAnnot Pattern v -> Pattern v
fOther (GraphView GraphQuery v
q [(GraphClass extra, Pattern v)]
elems) =
  GraphQuery v
-> [(GraphClass extra, Pattern v)] -> GraphView extra v
forall extra v.
GraphQuery v
-> [(GraphClass extra, Pattern v)] -> GraphView extra v
GraphView GraphQuery v
q (((GraphClass extra, Pattern v) -> (GraphClass extra, Pattern v))
-> [(GraphClass extra, Pattern v)]
-> [(GraphClass extra, Pattern v)]
forall a b. (a -> b) -> [a] -> [b]
map (GraphClass extra, Pattern v) -> (GraphClass extra, Pattern v)
applyF [(GraphClass extra, Pattern v)]
elems)
  where
    applyF :: (GraphClass extra, Pattern v) -> (GraphClass extra, Pattern v)
applyF (GraphClass extra
cls, Pattern v
p) = case GraphClass extra
cls of
      GraphClass extra
GNode         -> (GraphClass extra
cls, Pattern v -> Pattern v
fNode Pattern v
p)
      GraphClass extra
GRelationship -> (GraphClass extra
cls, Pattern v -> Pattern v
fRel Pattern v
p)
      GraphClass extra
GWalk         -> (GraphClass extra
cls, Pattern v -> Pattern v
fWalk Pattern v
p)
      GraphClass extra
GAnnotation   -> (GraphClass extra
cls, Pattern v -> Pattern v
fAnnot Pattern v
p)
      GOther extra
_      -> (GraphClass extra
cls, Pattern v -> Pattern v
fOther Pattern v
p)

-- ============================================================================
-- mapAllGraph
-- ============================================================================

-- | Apply a single function uniformly to every element in the view.
mapAllGraph :: (Pattern v -> Pattern v) -> GraphView extra v -> GraphView extra v
mapAllGraph :: forall v extra.
(Pattern v -> Pattern v) -> GraphView extra v -> GraphView extra v
mapAllGraph Pattern v -> Pattern v
f (GraphView GraphQuery v
q [(GraphClass extra, Pattern v)]
elems) = GraphQuery v
-> [(GraphClass extra, Pattern v)] -> GraphView extra v
forall extra v.
GraphQuery v
-> [(GraphClass extra, Pattern v)] -> GraphView extra v
GraphView GraphQuery v
q (((GraphClass extra, Pattern v) -> (GraphClass extra, Pattern v))
-> [(GraphClass extra, Pattern v)]
-> [(GraphClass extra, Pattern v)]
forall a b. (a -> b) -> [a] -> [b]
map (\(GraphClass extra
cls, Pattern v
p) -> (GraphClass extra
cls, Pattern v -> Pattern v
f Pattern v
p)) [(GraphClass extra, Pattern v)]
elems)

-- ============================================================================
-- filterGraph
-- ============================================================================

-- | Filter elements from a 'GraphView', repairing container gaps via 'Substitution'.
--
-- Elements that do not satisfy the predicate are removed. Container structures
-- (walks, annotations) whose internal elements are removed are repaired
-- according to the 'Substitution' strategy.
filterGraph
  :: GraphClassifier extra v
  -> (GraphClass extra -> Pattern v -> Bool)
  -> Substitution v
  -> GraphView extra v
  -> GraphView extra v
filterGraph :: forall extra v.
GraphClassifier extra v
-> (GraphClass extra -> Pattern v -> Bool)
-> Substitution v
-> GraphView extra v
-> GraphView extra v
filterGraph GraphClassifier extra v
classifier GraphClass extra -> Pattern v -> Bool
keep Substitution v
subst (GraphView GraphQuery v
q [(GraphClass extra, Pattern v)]
elems) =
  GraphQuery v
-> [(GraphClass extra, Pattern v)] -> GraphView extra v
forall extra v.
GraphQuery v
-> [(GraphClass extra, Pattern v)] -> GraphView extra v
GraphView GraphQuery v
q (((GraphClass extra, Pattern v) -> [(GraphClass extra, Pattern v)])
-> [(GraphClass extra, Pattern v)]
-> [(GraphClass extra, Pattern v)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (GraphClass extra, Pattern v) -> [(GraphClass extra, Pattern v)]
applyFilter [(GraphClass extra, Pattern v)]
elems)
  where
    applyFilter :: (GraphClass extra, Pattern v) -> [(GraphClass extra, Pattern v)]
applyFilter entry :: (GraphClass extra, Pattern v)
entry@(GraphClass extra
cls, Pattern v
p)
      | GraphClass extra -> Pattern v -> Bool
keep GraphClass extra
cls Pattern v
p = case GraphClass extra
cls of
          GraphClass extra
GWalk -> case Substitution v
subst of
            Substitution v
DeleteContainer ->
              -- Drop the whole walk if any internal relationship is removed.
              let allKept :: Bool
allKept = (Pattern v -> Bool) -> [Pattern v] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Pattern v
e -> GraphClass extra -> Pattern v -> Bool
keep (GraphClassifier extra v -> Pattern v -> GraphClass extra
forall extra v.
GraphClassifier extra v -> Pattern v -> GraphClass extra
classify GraphClassifier extra v
classifier Pattern v
e) Pattern v
e) (Pattern v -> [Pattern v]
forall v. Pattern v -> [Pattern v]
elements Pattern v
p)
              in if Bool
allKept then [(GraphClass extra, Pattern v)
entry] else []
            Substitution v
_ -> [(GraphClass extra
cls, GraphClassifier extra v
-> Substitution v
-> (GraphClass extra -> Pattern v -> Bool)
-> Pattern v
-> Pattern v
forall extra v.
GraphClassifier extra v
-> Substitution v
-> (GraphClass extra -> Pattern v -> Bool)
-> Pattern v
-> Pattern v
repairWalk GraphClassifier extra v
classifier Substitution v
subst GraphClass extra -> Pattern v -> Bool
keep Pattern v
p)]
          GraphClass extra
GAnnotation -> case Substitution v
subst of
            Substitution v
DeleteContainer ->
              let allKept :: Bool
allKept = (Pattern v -> Bool) -> [Pattern v] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Pattern v
e -> GraphClass extra -> Pattern v -> Bool
keep (GraphClassifier extra v -> Pattern v -> GraphClass extra
forall extra v.
GraphClassifier extra v -> Pattern v -> GraphClass extra
classify GraphClassifier extra v
classifier Pattern v
e) Pattern v
e) (Pattern v -> [Pattern v]
forall v. Pattern v -> [Pattern v]
elements Pattern v
p)
              in if Bool
allKept then [(GraphClass extra, Pattern v)
entry] else []
            Substitution v
_ -> [(GraphClass extra
cls, GraphClassifier extra v
-> Substitution v
-> (GraphClass extra -> Pattern v -> Bool)
-> Pattern v
-> Pattern v
forall extra v.
GraphClassifier extra v
-> Substitution v
-> (GraphClass extra -> Pattern v -> Bool)
-> Pattern v
-> Pattern v
repairAnnotation GraphClassifier extra v
classifier Substitution v
subst GraphClass extra -> Pattern v -> Bool
keep Pattern v
p)]
          GraphClass extra
_ -> [(GraphClass extra, Pattern v)
entry]
      | Bool
otherwise = []

-- Repair a walk's internal relationships using SpliceGap or ReplaceWithSurrogate.
repairWalk
  :: GraphClassifier extra v
  -> Substitution v
  -> (GraphClass extra -> Pattern v -> Bool)
  -> Pattern v
  -> Pattern v
repairWalk :: forall extra v.
GraphClassifier extra v
-> Substitution v
-> (GraphClass extra -> Pattern v -> Bool)
-> Pattern v
-> Pattern v
repairWalk GraphClassifier extra v
classifier Substitution v
subst GraphClass extra -> Pattern v -> Bool
keep (Pattern v
v [Pattern v]
rels) =
  v -> [Pattern v] -> Pattern v
forall v. v -> [Pattern v] -> Pattern v
Pattern v
v ((Pattern v -> [Pattern v]) -> [Pattern v] -> [Pattern v]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (GraphClassifier extra v
-> Substitution v
-> (GraphClass extra -> Pattern v -> Bool)
-> Pattern v
-> [Pattern v]
forall extra v.
GraphClassifier extra v
-> Substitution v
-> (GraphClass extra -> Pattern v -> Bool)
-> Pattern v
-> [Pattern v]
repairRel GraphClassifier extra v
classifier Substitution v
subst GraphClass extra -> Pattern v -> Bool
keep) [Pattern v]
rels)

repairRel
  :: GraphClassifier extra v
  -> Substitution v
  -> (GraphClass extra -> Pattern v -> Bool)
  -> Pattern v
  -> [Pattern v]
repairRel :: forall extra v.
GraphClassifier extra v
-> Substitution v
-> (GraphClass extra -> Pattern v -> Bool)
-> Pattern v
-> [Pattern v]
repairRel GraphClassifier extra v
classifier Substitution v
subst GraphClass extra -> Pattern v -> Bool
keep Pattern v
rel
  | GraphClass extra -> Pattern v -> Bool
keep (GraphClassifier extra v -> Pattern v -> GraphClass extra
forall extra v.
GraphClassifier extra v -> Pattern v -> GraphClass extra
classify GraphClassifier extra v
classifier Pattern v
rel) Pattern v
rel = [Pattern v
rel]
  | Bool
otherwise = case Substitution v
subst of
      Substitution v
DeleteContainer        -> []  -- handled at walk level; shouldn't reach here
      Substitution v
SpliceGap              -> []  -- drop this rel, shorten walk
      ReplaceWithSurrogate Pattern v
s -> [Pattern v
s] -- insert surrogate in place

repairAnnotation
  :: GraphClassifier extra v
  -> Substitution v
  -> (GraphClass extra -> Pattern v -> Bool)
  -> Pattern v
  -> Pattern v
repairAnnotation :: forall extra v.
GraphClassifier extra v
-> Substitution v
-> (GraphClass extra -> Pattern v -> Bool)
-> Pattern v
-> Pattern v
repairAnnotation GraphClassifier extra v
classifier Substitution v
subst GraphClass extra -> Pattern v -> Bool
keep (Pattern v
v [Pattern v]
els) =
  v -> [Pattern v] -> Pattern v
forall v. v -> [Pattern v] -> Pattern v
Pattern v
v ((Pattern v -> [Pattern v]) -> [Pattern v] -> [Pattern v]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (GraphClassifier extra v
-> Substitution v
-> (GraphClass extra -> Pattern v -> Bool)
-> Pattern v
-> [Pattern v]
forall extra v.
GraphClassifier extra v
-> Substitution v
-> (GraphClass extra -> Pattern v -> Bool)
-> Pattern v
-> [Pattern v]
repairSub GraphClassifier extra v
classifier Substitution v
subst GraphClass extra -> Pattern v -> Bool
keep) [Pattern v]
els)
  where
    repairSub :: GraphClassifier extra v
-> Substitution v
-> (GraphClass extra -> Pattern v -> Bool)
-> Pattern v
-> [Pattern v]
repairSub GraphClassifier extra v
c Substitution v
s GraphClass extra -> Pattern v -> Bool
k Pattern v
e
      | GraphClass extra -> Pattern v -> Bool
k (GraphClassifier extra v -> Pattern v -> GraphClass extra
forall extra v.
GraphClassifier extra v -> Pattern v -> GraphClass extra
classify GraphClassifier extra v
c Pattern v
e) Pattern v
e = [Pattern v
e]
      | Bool
otherwise = case Substitution v
s of
          Substitution v
DeleteContainer -> []
          Substitution v
SpliceGap -> []
          ReplaceWithSurrogate Pattern v
surr -> [Pattern v
surr]

-- ============================================================================
-- foldGraph
-- ============================================================================

-- | Reduce all view elements into a single 'Monoid' accumulation.
foldGraph
  :: Monoid m
  => (GraphClass extra -> Pattern v -> m)
  -> GraphView extra v
  -> m
foldGraph :: forall m extra v.
Monoid m =>
(GraphClass extra -> Pattern v -> m) -> GraphView extra v -> m
foldGraph GraphClass extra -> Pattern v -> m
f (GraphView GraphQuery v
_ [(GraphClass extra, Pattern v)]
elems) = ((GraphClass extra, Pattern v) -> m)
-> [(GraphClass extra, Pattern v)] -> m
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(GraphClass extra
cls, Pattern v
p) -> GraphClass extra -> Pattern v -> m
f GraphClass extra
cls Pattern v
p) [(GraphClass extra, Pattern v)]
elems

-- ============================================================================
-- mapWithContext
-- ============================================================================

-- | Map over view elements with access to the original snapshot 'GraphQuery'.
--
-- The mapping function receives the unmodified query from the original view,
-- ensuring deterministic snapshot semantics: later elements do not see
-- mutations applied to earlier elements.
mapWithContext
  :: GraphClassifier extra v
  -> (GraphQuery v -> Pattern v -> Pattern v)
  -> GraphView extra v
  -> GraphView extra v
mapWithContext :: forall extra v.
GraphClassifier extra v
-> (GraphQuery v -> Pattern v -> Pattern v)
-> GraphView extra v
-> GraphView extra v
mapWithContext GraphClassifier extra v
_classifier GraphQuery v -> Pattern v -> Pattern v
f view :: GraphView extra v
view@(GraphView GraphQuery v
q [(GraphClass extra, Pattern v)]
elems) =
  GraphView extra v
view { viewElements = map (\(GraphClass extra
cls, Pattern v
p) -> (GraphClass extra
cls, GraphQuery v -> Pattern v -> Pattern v
f GraphQuery v
q Pattern v
p)) elems }

-- | Reify the generic scope answers for a 'GraphView' snapshot.
--
-- This exposes the unified scope model without exporting the internal adapter
-- type used to compute it.
--
-- Invariants:
--
-- * 'allElements' covers every classified element in the 'GraphView'.
-- * 'byIdentity' is bounded to that snapshot.
-- * 'containers' and 'siblings' are derived from direct containment only.
-- * Duplicate graph identities are rejected when reifying generic scope
--   answers, because 'ScopeQuery' lookup is keyed only by 'Id v'.
--
-- Example:
--
-- > let scope = scopeDictFromGraphView view
-- > length (allElements scope)
scopeDictFromGraphView :: GraphValue v => GraphView extra v -> ScopeDict (Id v) v
scopeDictFromGraphView :: forall v extra.
GraphValue v =>
GraphView extra v -> ScopeDict (Id v) v
scopeDictFromGraphView = GraphViewScope v -> ScopeDict (ScopeId GraphViewScope v) v
GraphViewScope v -> ScopeDict (Id v) v
forall (q :: * -> *) v.
ScopeQuery q v =>
q v -> ScopeDict (ScopeId q v) v
toScopeDict (GraphViewScope v -> ScopeDict (Id v) v)
-> (GraphView extra v -> GraphViewScope v)
-> GraphView extra v
-> ScopeDict (Id v) v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GraphView extra v -> GraphViewScope v
forall v extra.
GraphValue v =>
GraphView extra v -> GraphViewScope v
graphViewScope

-- ============================================================================
-- paraGraph
-- ============================================================================

-- | Single-pass structure-aware fold over a 'GraphView'.
--
-- Elements are processed in containment order via 'topoShapeSort':
-- each element receives already-computed results for its direct sub-elements.
--
-- == Processing Order
--
-- Determined by 'topoShapeSort':
--
-- 1. Nodes (atomic — no sub-elements)
-- 2. Relationships (contain nodes)
-- 3. Walks (contain relationships)
-- 4. Annotations (contain any element type, including other annotations)
-- 5. Other (GOther — unconstrained sub-elements)
--
-- Within the Annotation and Other buckets, elements are additionally sorted
-- so that referenced elements appear before the elements that reference them.
--
-- == The @subResults@ Contract
--
-- The @[r]@ argument received by @f@ contains the results of all direct
-- sub-elements of the current element that have already been processed.
--
-- If a sub-element has not yet been processed — which can occur when a
-- dependency cycle exists within a bucket — its result is /omitted/ from
-- @subResults@. The list will be shorter than @elements p@. Callers
-- should treat @subResults@ as a best-effort list, not a guaranteed
-- complete list.
--
-- == Example
--
-- > -- Count the number of sub-results (i.e., direct dependencies) for each element
-- > countDeps :: GraphValue v => GraphView extra v -> Map (Id v) Int
-- > countDeps = paraGraph (\_ _ subResults -> length subResults)
paraGraph
  :: GraphValue v
  => (GraphQuery v -> Pattern v -> [r] -> r)
  -> GraphView extra v
  -> Map (Id v) r
paraGraph :: forall v r extra.
GraphValue v =>
(GraphQuery v -> Pattern v -> [r] -> r)
-> GraphView extra v -> Map (Id v) r
paraGraph GraphQuery v -> Pattern v -> [r] -> r
f GraphView extra v
view = (GraphQuery v -> Pattern v -> [r] -> r)
-> GraphView extra v -> Map (Id v) r -> Map (Id v) r
forall v r extra.
GraphValue v =>
(GraphQuery v -> Pattern v -> [r] -> r)
-> GraphView extra v -> Map (Id v) r -> Map (Id v) r
paraGraphWithSeed GraphQuery v -> Pattern v -> [r] -> r
f GraphView extra v
view Map (Id v) r
forall k a. Map k a
Map.empty

-- Internal adapter that exposes full GraphView scope to the generic scope layer
-- without changing the public GraphQuery record shape.
data GraphViewScope v = GraphViewScope
  { forall v. GraphViewScope v -> GraphQuery v
gvsQuery      :: GraphQuery v
  , forall v. GraphViewScope v -> [Pattern v]
gvsElements   :: [Pattern v]
  , forall v. GraphViewScope v -> Map (Id v) (Pattern v)
gvsIndex      :: Map (Id v) (Pattern v)
  , forall v. GraphViewScope v -> Map (Id v) [Pattern v]
gvsContainers :: Map (Id v) [Pattern v]
  }

instance GraphValue v => ScopeQuery GraphViewScope v where
  type ScopeId GraphViewScope v = Id v

  containers :: GraphViewScope v -> Pattern v -> [Pattern v]
containers GraphViewScope v
scope Pattern v
p =
    [Pattern v] -> Id v -> Map (Id v) [Pattern v] -> [Pattern v]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] (v -> Id v
forall v. GraphValue v => v -> Id v
identify (Pattern v -> v
forall v. Pattern v -> v
value Pattern v
p)) (GraphViewScope v -> Map (Id v) [Pattern v]
forall v. GraphViewScope v -> Map (Id v) [Pattern v]
gvsContainers GraphViewScope v
scope)

  siblings :: GraphViewScope v -> Pattern v -> [Pattern v]
siblings GraphViewScope v
scope Pattern v
p =
    [Pattern v] -> [Pattern v]
forall v. GraphValue v => [Pattern v] -> [Pattern v]
dedupeById
      [ Pattern v
sibling
      | Pattern v
container <- GraphViewScope v -> Pattern v -> [Pattern v]
forall (q :: * -> *) v.
ScopeQuery q v =>
q v -> Pattern v -> [Pattern v]
containers GraphViewScope v
scope Pattern v
p
      , Pattern v
child <- Pattern v -> [Pattern v]
forall v. Pattern v -> [Pattern v]
elements Pattern v
container
      , let childId :: Id v
childId = v -> Id v
forall v. GraphValue v => v -> Id v
identify (Pattern v -> v
forall v. Pattern v -> v
value Pattern v
child)
      , Id v
childId Id v -> Id v -> Bool
forall a. Eq a => a -> a -> Bool
/= v -> Id v
forall v. GraphValue v => v -> Id v
identify (Pattern v -> v
forall v. Pattern v -> v
value Pattern v
p)
      , Just Pattern v
sibling <- [Id v -> Map (Id v) (Pattern v) -> Maybe (Pattern v)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Id v
childId (GraphViewScope v -> Map (Id v) (Pattern v)
forall v. GraphViewScope v -> Map (Id v) (Pattern v)
gvsIndex GraphViewScope v
scope)]
      ]

  byIdentity :: GraphViewScope v -> ScopeId GraphViewScope v -> Maybe (Pattern v)
byIdentity GraphViewScope v
scope ScopeId GraphViewScope v
i = Id v -> Map (Id v) (Pattern v) -> Maybe (Pattern v)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScopeId GraphViewScope v
Id v
i (GraphViewScope v -> Map (Id v) (Pattern v)
forall v. GraphViewScope v -> Map (Id v) (Pattern v)
gvsIndex GraphViewScope v
scope)
  allElements :: GraphViewScope v -> [Pattern v]
allElements = GraphViewScope v -> [Pattern v]
forall v. GraphViewScope v -> [Pattern v]
gvsElements

dedupeById :: GraphValue v => [Pattern v] -> [Pattern v]
dedupeById :: forall v. GraphValue v => [Pattern v] -> [Pattern v]
dedupeById = [Pattern v] -> [Pattern v]
forall a. [a] -> [a]
reverse ([Pattern v] -> [Pattern v])
-> ([Pattern v] -> [Pattern v]) -> [Pattern v] -> [Pattern v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Pattern v], Set (Id v)) -> [Pattern v]
forall a b. (a, b) -> a
fst (([Pattern v], Set (Id v)) -> [Pattern v])
-> ([Pattern v] -> ([Pattern v], Set (Id v)))
-> [Pattern v]
-> [Pattern v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Pattern v], Set (Id v))
 -> Pattern v -> ([Pattern v], Set (Id v)))
-> ([Pattern v], Set (Id v))
-> [Pattern v]
-> ([Pattern v], Set (Id v))
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([Pattern v], Set (Id v)) -> Pattern v -> ([Pattern v], Set (Id v))
forall {v}.
GraphValue v =>
([Pattern v], Set (Id v)) -> Pattern v -> ([Pattern v], Set (Id v))
step ([], Set (Id v)
forall a. Set a
Set.empty)
  where
    step :: ([Pattern v], Set (Id v)) -> Pattern v -> ([Pattern v], Set (Id v))
step ([Pattern v]
acc, Set (Id v)
seen) Pattern v
p =
      let pid :: Id v
pid = v -> Id v
forall v. GraphValue v => v -> Id v
identify (Pattern v -> v
forall v. Pattern v -> v
value Pattern v
p)
      in if Id v -> Set (Id v) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Id v
pid Set (Id v)
seen
           then ([Pattern v]
acc, Set (Id v)
seen)
           else (Pattern v
p Pattern v -> [Pattern v] -> [Pattern v]
forall a. a -> [a] -> [a]
: [Pattern v]
acc, Id v -> Set (Id v) -> Set (Id v)
forall a. Ord a => a -> Set a -> Set a
Set.insert Id v
pid Set (Id v)
seen)

graphViewScope :: GraphValue v => GraphView extra v -> GraphViewScope v
graphViewScope :: forall v extra.
GraphValue v =>
GraphView extra v -> GraphViewScope v
graphViewScope (GraphView GraphQuery v
q [(GraphClass extra, Pattern v)]
taggedElems) = GraphViewScope
  { gvsQuery :: GraphQuery v
gvsQuery = GraphQuery v
q
  , gvsElements :: [Pattern v]
gvsElements = [Pattern v]
elems
  , gvsIndex :: Map (Id v) (Pattern v)
gvsIndex = Map (Id v) (Pattern v)
index
  , gvsContainers :: Map (Id v) [Pattern v]
gvsContainers = Map (Id v) [Pattern v]
containerIndex
  }
  where
    elems :: [Pattern v]
elems = ((GraphClass extra, Pattern v) -> Pattern v)
-> [(GraphClass extra, Pattern v)] -> [Pattern v]
forall a b. (a -> b) -> [a] -> [b]
map (GraphClass extra, Pattern v) -> Pattern v
forall a b. (a, b) -> b
snd [(GraphClass extra, Pattern v)]
taggedElems
    index :: Map (Id v) (Pattern v)
index = (Map (Id v) (Pattern v) -> Pattern v -> Map (Id v) (Pattern v))
-> Map (Id v) (Pattern v) -> [Pattern v] -> Map (Id v) (Pattern v)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map (Id v) (Pattern v) -> Pattern v -> Map (Id v) (Pattern v)
forall {v}.
GraphValue v =>
Map (Id v) (Pattern v) -> Pattern v -> Map (Id v) (Pattern v)
insertUniqueElement Map (Id v) (Pattern v)
forall k a. Map k a
Map.empty [Pattern v]
elems
    containerIndex :: Map (Id v) [Pattern v]
containerIndex = (Map (Id v) [Pattern v] -> Pattern v -> Map (Id v) [Pattern v])
-> Map (Id v) [Pattern v] -> [Pattern v] -> Map (Id v) [Pattern v]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map (Id v) [Pattern v] -> Pattern v -> Map (Id v) [Pattern v]
indexContainer Map (Id v) [Pattern v]
forall k a. Map k a
Map.empty [Pattern v]
elems

    insertUniqueElement :: Map (Id v) (Pattern v) -> Pattern v -> Map (Id v) (Pattern v)
insertUniqueElement Map (Id v) (Pattern v)
acc Pattern v
p =
      let pid :: Id v
pid = v -> Id v
forall v. GraphValue v => v -> Id v
identify (Pattern v -> v
forall v. Pattern v -> v
value Pattern v
p)
      in case Id v -> Map (Id v) (Pattern v) -> Maybe (Pattern v)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Id v
pid Map (Id v) (Pattern v)
acc of
           Maybe (Pattern v)
Nothing -> Id v
-> Pattern v -> Map (Id v) (Pattern v) -> Map (Id v) (Pattern v)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Id v
pid Pattern v
p Map (Id v) (Pattern v)
acc
           Just Pattern v
_ ->
             [Char] -> Map (Id v) (Pattern v)
forall a. HasCallStack => [Char] -> a
error [Char]
"scopeDictFromGraphView: duplicate element identity in GraphView"

    indexContainer :: Map (Id v) [Pattern v] -> Pattern v -> Map (Id v) [Pattern v]
indexContainer Map (Id v) [Pattern v]
acc Pattern v
container =
      (Map (Id v) [Pattern v] -> Pattern v -> Map (Id v) [Pattern v])
-> Map (Id v) [Pattern v] -> [Pattern v] -> Map (Id v) [Pattern v]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Pattern v
-> Map (Id v) [Pattern v] -> Pattern v -> Map (Id v) [Pattern v]
insertContainer Pattern v
container) Map (Id v) [Pattern v]
acc (Pattern v -> [Pattern v]
forall v. Pattern v -> [Pattern v]
elements Pattern v
container)

    insertContainer :: Pattern v
-> Map (Id v) [Pattern v] -> Pattern v -> Map (Id v) [Pattern v]
insertContainer Pattern v
container Map (Id v) [Pattern v]
acc Pattern v
child =
      let childId :: Id v
childId = v -> Id v
forall v. GraphValue v => v -> Id v
identify (Pattern v -> v
forall v. Pattern v -> v
value Pattern v
child)
      in if Id v -> Map (Id v) (Pattern v) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Id v
childId Map (Id v) (Pattern v)
index
           then ([Pattern v] -> [Pattern v] -> [Pattern v])
-> Id v
-> [Pattern v]
-> Map (Id v) [Pattern v]
-> Map (Id v) [Pattern v]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [Pattern v] -> [Pattern v] -> [Pattern v]
forall a. [a] -> [a] -> [a]
(++) Id v
childId [Pattern v
container] Map (Id v) [Pattern v]
acc
           else Map (Id v) [Pattern v]
acc

-- | Order graph elements for correct bottom-up processing in 'paraGraph'.
--
-- Elements are sorted in two passes:
--
-- __Pass 1 — Inter-bucket ordering__ (shape class priority):
--
-- > GNode < GRelationship < GWalk < GAnnotation < GOther
--
-- This ensures cross-class containment dependencies are satisfied:
-- nodes (atomic) before relationships (contain nodes), relationships before
-- walks (contain relationships), walks before annotations (annotations can
-- reference any class below them), and annotations before other (GOther is
-- unconstrained).
--
-- __Pass 2 — Within-bucket ordering__ (Kahn's algorithm):
--
-- Applied to the 'GAnnotation' and 'GOther' buckets only.
-- For each element @p@, its direct sub-elements (@elements p@) that belong
-- to the same bucket are treated as dependencies — they must appear before @p@.
--
-- 'GNode', 'GRelationship', and 'GWalk' require no within-bucket sort:
-- by the definition of 'classifyByShape', their sub-elements always belong
-- to a lower-priority bucket.
--
-- __Cycle handling:__
--
-- If a dependency cycle is detected within a bucket (e.g., annotation A
-- references annotation B which references A), the cycle members are appended
-- after all non-cycle elements in the bucket, in the order they appeared in
-- the input. No error is raised. See 'paraGraph' for the consequence of this
-- in fold results.
--
-- Requires 'GraphValue v' to extract element identities for dependency tracking.
topoShapeSort :: GraphValue v
              => [(GraphClass extra, Pattern v)]
              -> [(GraphClass extra, Pattern v)]
topoShapeSort :: forall v extra.
GraphValue v =>
[(GraphClass extra, Pattern v)] -> [(GraphClass extra, Pattern v)]
topoShapeSort [(GraphClass extra, Pattern v)]
elems =
  let isNode' :: (GraphClass extra, b) -> Bool
isNode'  (GraphClass extra
GNode, b
_)         = Bool
True; isNode'  (GraphClass extra, b)
_ = Bool
False
      isRel' :: (GraphClass extra, b) -> Bool
isRel'   (GraphClass extra
GRelationship, b
_) = Bool
True; isRel'   (GraphClass extra, b)
_ = Bool
False
      isWalk' :: (GraphClass extra, b) -> Bool
isWalk'  (GraphClass extra
GWalk, b
_)         = Bool
True; isWalk'  (GraphClass extra, b)
_ = Bool
False
      isAnnot' :: (GraphClass extra, b) -> Bool
isAnnot' (GraphClass extra
GAnnotation, b
_)   = Bool
True; isAnnot' (GraphClass extra, b)
_ = Bool
False
      isOther' :: (GraphClass extra, b) -> Bool
isOther' (GOther extra
_, b
_)      = Bool
True; isOther' (GraphClass extra, b)
_ = Bool
False
  in ((GraphClass extra, Pattern v) -> Bool)
-> [(GraphClass extra, Pattern v)]
-> [(GraphClass extra, Pattern v)]
forall a. (a -> Bool) -> [a] -> [a]
filter (GraphClass extra, Pattern v) -> Bool
forall {extra} {b}. (GraphClass extra, b) -> Bool
isNode' [(GraphClass extra, Pattern v)]
elems
     [(GraphClass extra, Pattern v)]
-> [(GraphClass extra, Pattern v)]
-> [(GraphClass extra, Pattern v)]
forall a. [a] -> [a] -> [a]
++ ((GraphClass extra, Pattern v) -> Bool)
-> [(GraphClass extra, Pattern v)]
-> [(GraphClass extra, Pattern v)]
forall a. (a -> Bool) -> [a] -> [a]
filter (GraphClass extra, Pattern v) -> Bool
forall {extra} {b}. (GraphClass extra, b) -> Bool
isRel' [(GraphClass extra, Pattern v)]
elems
     [(GraphClass extra, Pattern v)]
-> [(GraphClass extra, Pattern v)]
-> [(GraphClass extra, Pattern v)]
forall a. [a] -> [a] -> [a]
++ ((GraphClass extra, Pattern v) -> Bool)
-> [(GraphClass extra, Pattern v)]
-> [(GraphClass extra, Pattern v)]
forall a. (a -> Bool) -> [a] -> [a]
filter (GraphClass extra, Pattern v) -> Bool
forall {extra} {b}. (GraphClass extra, b) -> Bool
isWalk' [(GraphClass extra, Pattern v)]
elems
     [(GraphClass extra, Pattern v)]
-> [(GraphClass extra, Pattern v)]
-> [(GraphClass extra, Pattern v)]
forall a. [a] -> [a] -> [a]
++ [(GraphClass extra, Pattern v)] -> [(GraphClass extra, Pattern v)]
forall v extra.
GraphValue v =>
[(GraphClass extra, Pattern v)] -> [(GraphClass extra, Pattern v)]
withinBucketTopoSort (((GraphClass extra, Pattern v) -> Bool)
-> [(GraphClass extra, Pattern v)]
-> [(GraphClass extra, Pattern v)]
forall a. (a -> Bool) -> [a] -> [a]
filter (GraphClass extra, Pattern v) -> Bool
forall {extra} {b}. (GraphClass extra, b) -> Bool
isAnnot' [(GraphClass extra, Pattern v)]
elems)
     [(GraphClass extra, Pattern v)]
-> [(GraphClass extra, Pattern v)]
-> [(GraphClass extra, Pattern v)]
forall a. [a] -> [a] -> [a]
++ [(GraphClass extra, Pattern v)] -> [(GraphClass extra, Pattern v)]
forall v extra.
GraphValue v =>
[(GraphClass extra, Pattern v)] -> [(GraphClass extra, Pattern v)]
withinBucketTopoSort (((GraphClass extra, Pattern v) -> Bool)
-> [(GraphClass extra, Pattern v)]
-> [(GraphClass extra, Pattern v)]
forall a. (a -> Bool) -> [a] -> [a]
filter (GraphClass extra, Pattern v) -> Bool
forall {extra} {b}. (GraphClass extra, b) -> Bool
isOther' [(GraphClass extra, Pattern v)]
elems)

-- Topological sort within a single bucket using Kahn's algorithm.
-- Elements are ordered so that each element appears after all elements
-- it structurally depends on (i.e., contains as sub-elements of the same bucket).
-- Cycle members are appended after all non-cycle elements in input order.
withinBucketTopoSort :: GraphValue v
                     => [(GraphClass extra, Pattern v)]
                     -> [(GraphClass extra, Pattern v)]
withinBucketTopoSort :: forall v extra.
GraphValue v =>
[(GraphClass extra, Pattern v)] -> [(GraphClass extra, Pattern v)]
withinBucketTopoSort [] = []
withinBucketTopoSort [(GraphClass extra, Pattern v)]
elems =
  let idMap :: Map (Id v) (GraphClass extra, Pattern v)
idMap = [(Id v, (GraphClass extra, Pattern v))]
-> Map (Id v) (GraphClass extra, Pattern v)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (v -> Id v
forall v. GraphValue v => v -> Id v
identify (Pattern v -> v
forall v. Pattern v -> v
value Pattern v
p), (GraphClass extra, Pattern v)
entry) | entry :: (GraphClass extra, Pattern v)
entry@(GraphClass extra
_, Pattern v
p) <- [(GraphClass extra, Pattern v)]
elems ]

      inBucketDeps :: Map (Id v) [Id v]
inBucketDeps = [(Id v, [Id v])] -> Map (Id v) [Id v]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ ( v -> Id v
forall v. GraphValue v => v -> Id v
identify (Pattern v -> v
forall v. Pattern v -> v
value Pattern v
p)
          , [ v -> Id v
forall v. GraphValue v => v -> Id v
identify (Pattern v -> v
forall v. Pattern v -> v
value Pattern v
e) | Pattern v
e <- Pattern v -> [Pattern v]
forall v. Pattern v -> [Pattern v]
elements Pattern v
p, Id v -> Map (Id v) (GraphClass extra, Pattern v) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member (v -> Id v
forall v. GraphValue v => v -> Id v
identify (Pattern v -> v
forall v. Pattern v -> v
value Pattern v
e)) Map (Id v) (GraphClass extra, Pattern v)
idMap ]
          )
        | (GraphClass extra
_, Pattern v
p) <- [(GraphClass extra, Pattern v)]
elems
        ]

      dependents :: Map (Id v) [Id v]
dependents = (Map (Id v) [Id v] -> (Id v, [Id v]) -> Map (Id v) [Id v])
-> Map (Id v) [Id v] -> [(Id v, [Id v])] -> Map (Id v) [Id v]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
        (\Map (Id v) [Id v]
acc (Id v
pid, [Id v]
deps) -> (Map (Id v) [Id v] -> Id v -> Map (Id v) [Id v])
-> Map (Id v) [Id v] -> [Id v] -> Map (Id v) [Id v]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map (Id v) [Id v]
m Id v
dep -> ([Id v] -> [Id v] -> [Id v])
-> Id v -> [Id v] -> Map (Id v) [Id v] -> Map (Id v) [Id v]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [Id v] -> [Id v] -> [Id v]
forall a. [a] -> [a] -> [a]
(++) Id v
dep [Id v
pid] Map (Id v) [Id v]
m) Map (Id v) [Id v]
acc [Id v]
deps)
        (((GraphClass extra, Pattern v) -> [Id v])
-> Map (Id v) (GraphClass extra, Pattern v) -> Map (Id v) [Id v]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ([Id v] -> (GraphClass extra, Pattern v) -> [Id v]
forall a b. a -> b -> a
const []) Map (Id v) (GraphClass extra, Pattern v)
idMap)
        (Map (Id v) [Id v] -> [(Id v, [Id v])]
forall k a. Map k a -> [(k, a)]
Map.toList Map (Id v) [Id v]
inBucketDeps)

      inDegree0 :: Map (Id v) Int
inDegree0 = ([Id v] -> Int) -> Map (Id v) [Id v] -> Map (Id v) Int
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map [Id v] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Map (Id v) [Id v]
inBucketDeps

      initQueue :: [Id v]
initQueue = [ v -> Id v
forall v. GraphValue v => v -> Id v
identify (Pattern v -> v
forall v. Pattern v -> v
value Pattern v
p) | (GraphClass extra
_, Pattern v
p) <- [(GraphClass extra, Pattern v)]
elems
                  , Int -> Id v -> Map (Id v) Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Int
0 (v -> Id v
forall v. GraphValue v => v -> Id v
identify (Pattern v -> v
forall v. Pattern v -> v
value Pattern v
p)) Map (Id v) Int
inDegree0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 ]

      go :: [Id v]
-> Map (Id v) Int
-> [(GraphClass extra, Pattern v)]
-> [(GraphClass extra, Pattern v)]
go [] Map (Id v) Int
_ [(GraphClass extra, Pattern v)]
sortedRev = [(GraphClass extra, Pattern v)]
sortedRev
      go (Id v
pid:[Id v]
queue) Map (Id v) Int
deg [(GraphClass extra, Pattern v)]
sortedRev =
        let entry :: (GraphClass extra, Pattern v)
entry   = Map (Id v) (GraphClass extra, Pattern v)
idMap Map (Id v) (GraphClass extra, Pattern v)
-> Id v -> (GraphClass extra, Pattern v)
forall k a. Ord k => Map k a -> k -> a
Map.! Id v
pid
            newDeps :: [Id v]
newDeps = [Id v] -> Id v -> Map (Id v) [Id v] -> [Id v]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] Id v
pid Map (Id v) [Id v]
dependents
            ([Id v]
queue', Map (Id v) Int
deg') = (([Id v], Map (Id v) Int) -> Id v -> ([Id v], Map (Id v) Int))
-> ([Id v], Map (Id v) Int) -> [Id v] -> ([Id v], Map (Id v) Int)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
              (\([Id v]
q, Map (Id v) Int
d) Id v
dep ->
                let newD :: Int
newD = Int -> Id v -> Map (Id v) Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Int
0 Id v
dep Map (Id v) Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                in if Int
newD Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                   then (Id v
dep Id v -> [Id v] -> [Id v]
forall a. a -> [a] -> [a]
: [Id v]
q, Id v -> Int -> Map (Id v) Int -> Map (Id v) Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Id v
dep Int
newD Map (Id v) Int
d)
                   else ([Id v]
q,       Id v -> Int -> Map (Id v) Int -> Map (Id v) Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Id v
dep Int
newD Map (Id v) Int
d))
              ([Id v]
queue, Map (Id v) Int
deg)
              [Id v]
newDeps
        in [Id v]
-> Map (Id v) Int
-> [(GraphClass extra, Pattern v)]
-> [(GraphClass extra, Pattern v)]
go [Id v]
queue' Map (Id v) Int
deg' ((GraphClass extra, Pattern v)
entry (GraphClass extra, Pattern v)
-> [(GraphClass extra, Pattern v)]
-> [(GraphClass extra, Pattern v)]
forall a. a -> [a] -> [a]
: [(GraphClass extra, Pattern v)]
sortedRev)

      sorted :: [(GraphClass extra, Pattern v)]
sorted       = [(GraphClass extra, Pattern v)] -> [(GraphClass extra, Pattern v)]
forall a. [a] -> [a]
reverse ([Id v]
-> Map (Id v) Int
-> [(GraphClass extra, Pattern v)]
-> [(GraphClass extra, Pattern v)]
go [Id v]
initQueue Map (Id v) Int
inDegree0 [])
      sortedSet :: Map (Id v) ()
sortedSet    = [(Id v, ())] -> Map (Id v) ()
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (v -> Id v
forall v. GraphValue v => v -> Id v
identify (Pattern v -> v
forall v. Pattern v -> v
value Pattern v
p), ()) | (GraphClass extra
_, Pattern v
p) <- [(GraphClass extra, Pattern v)]
sorted ]
      cycleMembers :: [(GraphClass extra, Pattern v)]
cycleMembers = ((GraphClass extra, Pattern v) -> Bool)
-> [(GraphClass extra, Pattern v)]
-> [(GraphClass extra, Pattern v)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(GraphClass extra
_, Pattern v
p) -> Bool -> Bool
not (Id v -> Map (Id v) () -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member (v -> Id v
forall v. GraphValue v => v -> Id v
identify (Pattern v -> v
forall v. Pattern v -> v
value Pattern v
p)) Map (Id v) ()
sortedSet)) [(GraphClass extra, Pattern v)]
elems
  in [(GraphClass extra, Pattern v)]
sorted [(GraphClass extra, Pattern v)]
-> [(GraphClass extra, Pattern v)]
-> [(GraphClass extra, Pattern v)]
forall a. [a] -> [a] -> [a]
++ [(GraphClass extra, Pattern v)]
cycleMembers

-- ============================================================================
-- paraGraphFixed
-- ============================================================================

-- | Iterate 'paraGraph' rounds until the convergence predicate is satisfied.
--
-- Each round applies 'topoShapeSort' to ensure correct within-bucket
-- dependency ordering. The ordering is recomputed identically every round
-- (the 'GraphView' is immutable).
--
-- See 'paraGraph' for the @subResults@ contract, including cycle behaviour.
--
-- The convergence predicate @conv old new@ should return 'True' when the
-- result is considered stable. A common example for floating-point algorithms:
--
-- > \old new -> abs (old - new) < 0.0001
--
-- The initial value @r0@ is used for all elements in the first round.
paraGraphFixed
  :: (GraphValue v, Ord (Id v))
  => (r -> r -> Bool)
  -> (GraphQuery v -> Pattern v -> [r] -> r)
  -> r
  -> GraphView extra v
  -> Map (Id v) r
paraGraphFixed :: forall v r extra.
(GraphValue v, Ord (Id v)) =>
(r -> r -> Bool)
-> (GraphQuery v -> Pattern v -> [r] -> r)
-> r
-> GraphView extra v
-> Map (Id v) r
paraGraphFixed r -> r -> Bool
conv GraphQuery v -> Pattern v -> [r] -> r
f r
r0 GraphView extra v
view =
  let initial :: Map (Id v) r
initial = [(Id v, r)] -> Map (Id v) r
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (v -> Id v
forall v. GraphValue v => v -> Id v
identify (Pattern v -> v
forall v. Pattern v -> v
value Pattern v
p), r
r0)
        | (GraphClass extra
_, Pattern v
p) <- GraphView extra v -> [(GraphClass extra, Pattern v)]
forall extra v.
GraphView extra v -> [(GraphClass extra, Pattern v)]
viewElements GraphView extra v
view
        ]
  in Map (Id v) r -> Map (Id v) r
go Map (Id v) r
initial
  where
    go :: Map (Id v) r -> Map (Id v) r
go Map (Id v) r
prev =
      let next :: Map (Id v) r
next = (GraphQuery v -> Pattern v -> [r] -> r)
-> GraphView extra v -> Map (Id v) r -> Map (Id v) r
forall v r extra.
GraphValue v =>
(GraphQuery v -> Pattern v -> [r] -> r)
-> GraphView extra v -> Map (Id v) r -> Map (Id v) r
paraGraphWithSeed GraphQuery v -> Pattern v -> [r] -> r
f GraphView extra v
view Map (Id v) r
prev
      in if Map (Id v) r -> Map (Id v) r -> Bool
converged Map (Id v) r
prev Map (Id v) r
next
           then Map (Id v) r
next
           else Map (Id v) r -> Map (Id v) r
go Map (Id v) r
next

    converged :: Map (Id v) r -> Map (Id v) r -> Bool
converged Map (Id v) r
prev Map (Id v) r
next =
      (Id v -> r -> Bool -> Bool) -> Bool -> Map (Id v) r -> Bool
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey
        (\Id v
k r
newVal Bool
acc ->
          Bool
acc Bool -> Bool -> Bool
&& case Id v -> Map (Id v) r -> Maybe r
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Id v
k Map (Id v) r
prev of
            Maybe r
Nothing  -> Bool
False
            Just r
old -> r -> r -> Bool
conv r
old r
newVal)
        Bool
True
        Map (Id v) r
next

-- Run one paraGraph round, seeding sub-element results from an existing map.
paraGraphWithSeed
  :: GraphValue v
  => (GraphQuery v -> Pattern v -> [r] -> r)
  -> GraphView extra v
  -> Map (Id v) r
  -> Map (Id v) r
paraGraphWithSeed :: forall v r extra.
GraphValue v =>
(GraphQuery v -> Pattern v -> [r] -> r)
-> GraphView extra v -> Map (Id v) r -> Map (Id v) r
paraGraphWithSeed GraphQuery v -> Pattern v -> [r] -> r
f GraphView extra v
view Map (Id v) r
seed =
  (Map (Id v) r -> (GraphClass extra, Pattern v) -> Map (Id v) r)
-> Map (Id v) r -> [(GraphClass extra, Pattern v)] -> Map (Id v) r
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map (Id v) r -> (GraphClass extra, Pattern v) -> Map (Id v) r
processElem Map (Id v) r
seed ([(GraphClass extra, Pattern v)] -> [(GraphClass extra, Pattern v)]
forall v extra.
GraphValue v =>
[(GraphClass extra, Pattern v)] -> [(GraphClass extra, Pattern v)]
topoShapeSort [(GraphClass extra, Pattern v)]
taggedElems)
  where
    q :: GraphQuery v
q = GraphView extra v -> GraphQuery v
forall extra v. GraphView extra v -> GraphQuery v
viewQuery GraphView extra v
view
    taggedElems :: [(GraphClass extra, Pattern v)]
taggedElems = GraphView extra v -> [(GraphClass extra, Pattern v)]
forall extra v.
GraphView extra v -> [(GraphClass extra, Pattern v)]
viewElements GraphView extra v
view

    processElem :: Map (Id v) r -> (GraphClass extra, Pattern v) -> Map (Id v) r
processElem Map (Id v) r
acc (GraphClass extra
_, Pattern v
p) =
      let subResults :: [r]
subResults = (Pattern v -> Maybe r) -> [Pattern v] -> [r]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Pattern v
e -> Id v -> Map (Id v) r -> Maybe r
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (v -> Id v
forall v. GraphValue v => v -> Id v
identify (Pattern v -> v
forall v. Pattern v -> v
value Pattern v
e)) Map (Id v) r
acc) (Pattern v -> [Pattern v]
forall v. Pattern v -> [Pattern v]
elements Pattern v
p)
          r :: r
r = GraphQuery v -> Pattern v -> [r] -> r
f GraphQuery v
q Pattern v
p [r]
subResults
      in Id v -> r -> Map (Id v) r -> Map (Id v) r
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (v -> Id v
forall v. GraphValue v => v -> Id v
identify (Pattern v -> v
forall v. Pattern v -> v
value Pattern v
p)) r
r Map (Id v) r
acc