Factor the domain effects out of evaluate completely.

src/Semantic/Analysis.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE TypeFamilies, TypeOperators #-}
 module Semantic.Analysis
 ( evaluate
+, runDomainEffects
 , evalTerm
 ) where
 
@@ -11,6 +12,7 @@ import Data.Abstract.Evaluatable
 import Data.Abstract.Module
 import Data.Abstract.ModuleTable as ModuleTable
 import Data.Function
+import Data.Language (Language)
 import Prologue
 import qualified Data.Map.Strict as Map
 
@@ -32,54 +34,25 @@ type DomainC term address value m
     m)))))))
 
 -- | Evaluate a list of modules with the prelude for the passed language available, and applying the passed function to every module.
-evaluate :: ( AbstractValue term address value (DomainC term address value inner)
+evaluate :: ( Carrier outerSig outer
-            , Carrier innerSig inner
-            , Carrier outerSig outer
             , derefSig ~ (Deref value :+: allocatorSig)
             , derefC ~ (DerefC address value (Eff allocatorC))
             , Carrier derefSig derefC
             , allocatorSig ~ (Allocator address :+: Reader ModuleInfo :+: outerSig)
             , allocatorC ~ (AllocatorC address (Eff (ReaderC ModuleInfo (Eff outer))))
             , Carrier allocatorSig allocatorC
-            , booleanC ~ BooleanC value (Eff (InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff inner)))
-            , booleanSig ~ (Boolean value :+: Interpose (Resumable (BaseError (UnspecializedError address value))) :+: innerSig)
-            , Carrier booleanSig booleanC
-            , whileC ~ WhileC value (Eff booleanC)
-            , whileSig ~ (While value :+: booleanSig)
-            , Carrier whileSig whileC
-            , functionC ~ FunctionC term address value (Eff whileC)
-            , functionSig ~ (Function term address value :+: whileSig)
-            , Carrier functionSig functionC
             , Effect outerSig
-            , HasPrelude lang
             , Member Fresh outerSig
-            , Member (Allocator address) innerSig
-            , Member (Deref value) innerSig
-            , Member Fresh innerSig
-            , Member (Reader ModuleInfo) innerSig
             , Member (Reader (ModuleTable (Module (ModuleResult address value)))) outerSig
-            , Member (Reader Span) innerSig
-            , Member (Resumable (BaseError (AddressError address value))) innerSig
-            , Member (Resumable (BaseError (UnspecializedError address value))) innerSig
-            , Member (State (Heap address address value)) innerSig
-            , Member (State (ScopeGraph address)) innerSig
             , Member (State (Heap address address value)) outerSig
             , Member (State (ScopeGraph address)) outerSig
-            , Member (Reader (CurrentFrame address)) innerSig
-            , Member (Reader (CurrentScope address)) innerSig
-            , Member (Resumable (BaseError (HeapError address))) innerSig
-            , Member (Resumable (BaseError (ScopeError address))) innerSig
-            , Member Trace innerSig
             , Ord address
-            , Show address
             )
-         => proxy lang
+         => proxy (lang :: Language)
-         -> (  (Module (Either (proxy lang) term) -> Evaluator term address value inner value)
+         -> (Module (Either (proxy lang) term) -> Evaluator term address value (ModuleC address value outer) value)
-            -> (Module (Either (proxy lang) term) -> Evaluator term address value (ModuleC address value outer) value))
-         -> (term -> Evaluator term address value (DomainC term address value inner) value)
          -> [Module term]
          -> Evaluator term address value outer (ModuleTable (Module (ModuleResult address value)))
-evaluate lang perModule runTerm modules = do
+evaluate lang runModule modules = do
   let prelude = Module moduleInfoFromCallStack (Left lang)
   ((preludeScopeAddress, preludeFrameAddress), _) <- evalModule Nothing Nothing prelude
   foldr (run preludeScopeAddress preludeFrameAddress . fmap Right) ask modules
@@ -103,7 +76,7 @@ evaluate lang perModule runTerm modules = do
                   . raiseHandler (runReader (CurrentScope scopeAddress))
                   . runReturn
                   . runLoopControl
-                  . perModule (runDomainEffects runTerm)
+                  . runModule
 
 runDomainEffects :: ( AbstractValue term address value (DomainC term address value m)
                     , Carrier sig m

src/Semantic/Graph.hs

@@ -133,9 +133,9 @@ runCallGraph lang includePackages modules package
   . providingLiveSet
   . runModuleTable
   . runModules (ModuleTable.modulePaths (packageModules package))
-  $ evaluate lang perModule perTerm modules
+  $ evaluate lang perModule modules
   where perTerm = evalTerm (withTermSpans . graphingTerms . cachingTerms)
-        perModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules
+        perModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules $ runDomainEffects perTerm
 
 
 runModuleTable :: Carrier sig m
@@ -210,7 +210,7 @@ runImportGraph lang (package :: Package term) f
   . raiseHandler (runReader (lowerBound @Span))
   . raiseHandler (runState (lowerBound @(ScopeGraph (Hole (Maybe Name) Precise))))
   . runAllocator
-  $ evaluate lang graphingModuleInfo (evalTerm id) (ModuleTable.toPairs (packageModules package) >>= toList . snd)
+  $ evaluate lang (graphingModuleInfo (runDomainEffects (evalTerm id))) (ModuleTable.toPairs ( packageModules package) >>= toList . snd)
 
 runHeap :: (Carrier sig m, Effect sig)
         => Evaluator term address value (StateC (Heap address address value) (Eff m)) a
@@ -284,7 +284,7 @@ parsePythonPackage parser project = do
   strat <- case find ((== (projectRootDir project </> "setup.py")) . filePath) (projectFiles project) of
     Just setupFile -> do
       setupModule <- fmap snd <$> parseModule project parser setupFile
-      fst <$> runAnalysis (evaluate (Proxy @'Language.Python) id (runPythonPackaging . evalTerm id) [ setupModule ])
+      fst <$> runAnalysis (evaluate (Proxy @'Language.Python) (runDomainEffects (runPythonPackaging . evalTerm id)) [ setupModule ])
     Nothing -> pure PythonPackage.Unknown
   case strat of
     PythonPackage.Unknown -> do

src/Semantic/REPL.hs

@@ -92,7 +92,7 @@ repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runD
     . raiseHandler (runReader (packageInfo package))
     . raiseHandler (runState (lowerBound @Span))
     . raiseHandler (runReader (lowerBound @Span))
-    $ evaluate proxy id (evalTerm (withTermSpans . step (fmap (\ (x:|_) -> moduleBody x) <$> ModuleTable.toPairs (packageModules (fst <$> package))))) modules
+    $ evaluate proxy (runDomainEffects (evalTerm (withTermSpans . step (fmap (\ (x:|_) -> moduleBody x) <$> ModuleTable.toPairs (packageModules (fst <$> package)))))) modules
 
 -- TODO: REPL for typechecking/abstract semantics
 -- TODO: drive the flow from within the REPL instead of from without

src/Semantic/Util.hs

@@ -111,7 +111,7 @@ evaluateProject' (TaskConfig config logger statter) proxy parser paths = either
        (raiseHandler (runReader (packageInfo package))
        (raiseHandler (evalState (lowerBound @Span))
        (raiseHandler (runReader (lowerBound @Span))
-       (evaluate proxy id (evalTerm withTermSpans) modules)))))))
+       (evaluate proxy (runDomainEffects (evalTerm withTermSpans)) modules)))))))
 
 evaluatePythonProjects proxy parser lang path = runTaskWithOptions debugOptions $ do
   project <- readProject Nothing path lang []
@@ -124,7 +124,7 @@ evaluatePythonProjects proxy parser lang path = runTaskWithOptions debugOptions
        (raiseHandler (runReader (packageInfo package))
        (raiseHandler (evalState (lowerBound @Span))
        (raiseHandler (runReader (lowerBound @Span))
-       (evaluate proxy id (evalTerm withTermSpans) modules)))))))
+       (evaluate proxy (runDomainEffects (evalTerm withTermSpans)) modules)))))))
 
 
 evaluateProjectWithCaching proxy parser path = runTaskWithOptions debugOptions $ do
@@ -137,7 +137,7 @@ evaluateProjectWithCaching proxy parser path = runTaskWithOptions debugOptions $
        (raiseHandler (runReader (lowerBound @Span))
        (runModuleTable
        (runModules (ModuleTable.modulePaths (packageModules package))
-       (evaluate proxy id (evalTerm withTermSpans) modules)))))))
+       (evaluate proxy (runDomainEffects (evalTerm withTermSpans)) modules)))))))
 
 
 parseFile :: Parser term -> FilePath -> IO term