diff --git a/src/Control/Abstract/ScopeGraph.hs b/src/Control/Abstract/ScopeGraph.hs index d9cdda224..cefa984e2 100644 --- a/src/Control/Abstract/ScopeGraph.hs +++ b/src/Control/Abstract/ScopeGraph.hs @@ -1,28 +1,31 @@ -{-# LANGUAGE LambdaCase, TypeOperators, GADTs, KindSignatures, ScopedTypeVariables, RankNTypes #-} -module Control.Abstract.ScopeGraph where +{-# LANGUAGE GADTs, KindSignatures, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators #-} +module Control.Abstract.ScopeGraph (runScopeEnv, ScopeEnv) where -import Data.Abstract.ScopeGraph as ScopeGraph -import Control.Monad.Effect import Control.Abstract.Evaluator +import Data.Abstract.Name +import Data.Abstract.ScopeGraph as ScopeGraph +import Prologue data ScopeEnv address ddata (m :: * -> *) a where Lookup :: Reference -> ScopeEnv address ddata m (Maybe address) Declare :: Declaration -> ddata -> ScopeEnv address ddata m () Reference :: Reference -> Declaration -> ScopeEnv address ddata m () + Create :: Map EdgeLabel [Name] -> ScopeEnv Name ddata m () instance PureEffect (ScopeEnv address ddata) instance Effect (ScopeEnv address ddata) where - handleState c dist (Request (Lookup ref) k) = Request (Lookup ref) (dist . (<$ c) . k) + handleState c dist (Request (Lookup ref) k) = Request (Lookup ref) (dist . (<$ c) . k) handleState c dist (Request (Declare decl ddata) k) = Request (Declare decl ddata) (dist . (<$ c) . k) handleState c dist (Request (Reference ref decl) k) = Request (Reference ref decl) (dist . (<$ c) . k) + handleState c dist (Request (Create edges) k) = Request (Create edges) (dist . (<$ c) . k) -runScopeEnv :: (Ord scope, Effects effects) +runScopeEnv :: (Ord scope, Effects effects, Member Fresh effects) => scope -> Evaluator address value (ScopeEnv scope ddata ': effects) a -> Evaluator address value effects (ScopeGraph scope ddata, a) runScopeEnv scope = runState (ScopeGraph.emptyGraph scope) . reinterpret handleScopeEnv -handleScopeEnv :: forall scope address ddata value effects a. (Ord scope) +handleScopeEnv :: forall scope address ddata value effects a. (Ord scope, Member Fresh effects) => ScopeEnv scope ddata (Eff (ScopeEnv scope ddata ': effects)) a -> Evaluator address value (State (ScopeGraph scope ddata) ': effects) a handleScopeEnv = \case @@ -37,3 +40,8 @@ handleScopeEnv = \case graph <- get put @(ScopeGraph scope ddata) (ScopeGraph.reference ref decl graph) pure () + Create edges -> do + graph <- get @(ScopeGraph scope ddata) + scope <- gensym + put (ScopeGraph.create scope edges graph) + pure () diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs index 86d3a13b3..cbb44f07d 100644 --- a/src/Data/Abstract/ScopeGraph.hs +++ b/src/Data/Abstract/ScopeGraph.hs @@ -17,6 +17,7 @@ module Data.Abstract.ScopeGraph , declare , emptyGraph , reference + , create ) where import Data.Abstract.Live @@ -94,13 +95,18 @@ reference ref declaration graph = let traverseEdges edge = do linkMap <- linksOfScope address graph scopes <- Map.lookup edge linkMap - getFirst (flip foldMap scopes . First $ \nextAddress -> - go currentScope nextAddress (path . EPath edge nextAddress)) + -- Return the first path to the declaration through the scopes. + getFirst (foldMap (First . ap (go currentScope) ((path .) . EPath edge)) scopes) in traverseEdges P <|> traverseEdges I in case lookupScope currentAddress graph of Just currentScope -> fromMaybe graph (go currentScope currentAddress id) Nothing -> graph +create :: Ord address => address -> Map EdgeLabel [address] -> ScopeGraph address ddata -> ScopeGraph address ddata +create address edges graph = graph { unScopeGraph = (Map.insert address newScope (scopeGraph graph), address) } + where + newScope = Scope edges mempty mempty + scopeOfRef :: Ord scope => Reference -> ScopeGraph scope ddata -> Maybe scope scopeOfRef ref graph = go . Map.keys . fst $ unScopeGraph graph where