Allow creating scopes

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 (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 ()

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