Merge pull request #2139 from github/there-can-only-be-one-concrete-evaluator-newtype

Combine the concrete evaluator newtypes

src/Data/Abstract/Evaluatable.hs

@@ -2,6 +2,8 @@
 module Data.Abstract.Evaluatable
 ( module X
 , Evaluatable(..)
+, ModuleEffects
+, ValueEffects
 , evaluate
 , traceResolve
 -- * Preludes
@@ -75,6 +77,19 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where
     rvalBox v
 
 
+type ModuleEffects address value rest
+  =  Exc (LoopControl address)
+  ': Exc (Return address)
+  ': Env address
+  ': Deref value
+  ': Allocator address
+  ': Reader ModuleInfo
+  ': rest
+
+type ValueEffects address value rest
+  =  Function address value
+  ': rest
+
 evaluate :: ( AbstractValue address value valueEffects
             , Declarations term
             , Effects effects
@@ -96,8 +111,8 @@ evaluate :: ( AbstractValue address value valueEffects
             , Member Trace effects
             , Ord address
             , Recursive term
-            , moduleEffects ~ (Exc (LoopControl address) ': Exc (Return address) ': Env address ': Deref value ': Allocator address ': Reader ModuleInfo ': effects)
-            , valueEffects ~ (Function address value ': moduleEffects)
+            , moduleEffects ~ ModuleEffects address value effects
+            , valueEffects ~ ValueEffects address value moduleEffects
             )
          => proxy lang
          -> (SubtermAlgebra Module      term (TermEvaluator term address value moduleEffects address)           -> SubtermAlgebra Module      term (TermEvaluator term address value moduleEffects address))

src/Semantic/Graph.hs

@@ -8,7 +8,7 @@ module Semantic.Graph
 , GraphType(..)
 , Graph
 , Vertex
-, ImportGraphEff(..)
+, ConcreteEff(..)
 , style
 , parsePackage
 , withTermSpans
@@ -123,40 +123,37 @@ runCallGraph lang includePackages modules package = do
         . Hole.runDeref (Located.handleDeref Monovariant.handleDeref)
   extractGraph <$> runEvaluator (runGraphAnalysis (evaluate lang analyzeModule analyzeTerm runAddressEffects Abstract.runFunction modules))
 
-runImportGraphToModuleInfos :: forall effs lang term.
-                  ( Declarations term
-                  , Evaluatable (Base term)
-                  , FreeVariables term
-                  , HasPrelude lang
-                  , HasPostlude lang
-                  , Member Trace effs
-                  , Recursive term
-                  , Effects effs
-                  )
-               => Proxy lang
-               -> Package term
-               -> Eff effs (Graph Vertex)
+runImportGraphToModuleInfos :: ( Declarations term
+                               , Evaluatable (Base term)
+                               , FreeVariables term
+                               , HasPrelude lang
+                               , HasPostlude lang
+                               , Member Trace effs
+                               , Recursive term
+                               , Effects effs
+                               )
+                            => Proxy lang
+                            -> Package term
+                            -> Eff effs (Graph Vertex)
 runImportGraphToModuleInfos lang (package :: Package term) = runImportGraph lang package allModuleInfos
   where allModuleInfos info = maybe (vertex (unknownModuleVertex info)) (foldMap (vertex . moduleVertex . moduleInfo)) (ModuleTable.lookup (modulePath info) (packageModules package))
 
-runImportGraphToModules :: forall effs lang term.
-                  ( Declarations term
-                  , Evaluatable (Base term)
-                  , FreeVariables term
-                  , HasPrelude lang
-                  , HasPostlude lang
-                  , Member Trace effs
-                  , Recursive term
-                  , Effects effs
-                  )
-               => Proxy lang
-               -> Package term
-               -> Eff effs (Graph (Module term))
+runImportGraphToModules :: ( Declarations term
+                           , Evaluatable (Base term)
+                           , FreeVariables term
+                           , HasPrelude lang
+                           , HasPostlude lang
+                           , Member Trace effs
+                           , Recursive term
+                           , Effects effs
+                           )
+                        => Proxy lang
+                        -> Package term
+                        -> Eff effs (Graph (Module term))
 runImportGraphToModules lang (package :: Package term) = runImportGraph lang package resolveOrLowerBound
   where resolveOrLowerBound info = maybe lowerBound (foldMap vertex) (ModuleTable.lookup (modulePath info) (packageModules package))
 
-runImportGraph :: forall effs lang term vertex.
-                  ( Declarations term
+runImportGraph :: ( Declarations term
                   , Evaluatable (Base term)
                   , FreeVariables term
                   , HasPrelude lang
@@ -171,9 +168,10 @@ runImportGraph :: forall effs lang term vertex.
                -> Eff effs (Graph vertex)
 runImportGraph lang (package :: Package term) f =
   let analyzeModule = graphingModuleInfo
-      extractGraph (_, (graph, _)) = graph >>= f
+      extractGraph (graph, _) = graph >>= f
       runImportGraphAnalysis
         = runState lowerBound
+        . runState lowerBound
         . runFresh 0
         . resumingLoadError
         . resumingUnspecialized
@@ -182,10 +180,9 @@ runImportGraph lang (package :: Package term) f =
         . resumingResolutionError
         . resumingAddressError
         . resumingValueError
-        . runState lowerBound
         . runReader lowerBound
         . runModules (ModuleTable.modulePaths (packageModules package))
-        . runTermEvaluator @_ @_ @(Value (Hole (Maybe Name) Precise) (ImportGraphEff (Hole (Maybe Name) Precise) effs))
+        . runTermEvaluator @_ @_ @(Value (Hole (Maybe Name) Precise) (ConcreteEff (Hole (Maybe Name) Precise) _))
         . runReader (packageInfo package)
         . runReader lowerBound
       runAddressEffects
@@ -193,30 +190,26 @@ runImportGraph lang (package :: Package term) f =
         . Hole.runDeref Precise.handleDeref
   in extractGraph <$> runEvaluator (runImportGraphAnalysis (evaluate lang analyzeModule id runAddressEffects (Concrete.runFunction coerce coerce) (ModuleTable.toPairs (packageModules package) >>= toList . snd)))
 
-newtype ImportGraphEff address outerEffects a = ImportGraphEff
-  { runImportGraphEff :: Eff (  Function address (Value address (ImportGraphEff address outerEffects))
-                             ': Exc (LoopControl address)
-                             ': Exc (Return address)
-                             ': Env address
-                             ': Deref (Value address (ImportGraphEff address outerEffects))
-                             ': Allocator address
-                             ': Reader ModuleInfo
-                             ': Reader Span
-                             ': Reader PackageInfo
-                             ': Modules address
-                             ': Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))
-                             ': State (Graph ModuleInfo)
-                             ': Resumable (BaseError (ValueError address (ImportGraphEff address outerEffects)))
-                             ': Resumable (BaseError (AddressError address (Value address (ImportGraphEff address outerEffects))))
-                             ': Resumable (BaseError ResolutionError)
-                             ': Resumable (BaseError EvalError)
-                             ': Resumable (BaseError (EnvironmentError address))
-                             ': Resumable (BaseError (UnspecializedError (Value address (ImportGraphEff address outerEffects))))
-                             ': Resumable (BaseError (LoadError address))
-                             ': Fresh
-                             ': State (Heap address (Value address (ImportGraphEff address outerEffects)))
-                             ': outerEffects
-                             ) a
+type ConcreteEffects address rest
+  =  Reader Span
+  ': Reader PackageInfo
+  ': Modules address
+  ': Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))
+  ': Resumable (BaseError (ValueError address (ConcreteEff address rest)))
+  ': Resumable (BaseError (AddressError address (Value address (ConcreteEff address rest))))
+  ': Resumable (BaseError ResolutionError)
+  ': Resumable (BaseError EvalError)
+  ': Resumable (BaseError (EnvironmentError address))
+  ': Resumable (BaseError (UnspecializedError (Value address (ConcreteEff address rest))))
+  ': Resumable (BaseError (LoadError address))
+  ': Fresh
+  ': State (Heap address (Value address (ConcreteEff address rest)))
+  ': rest
+
+newtype ConcreteEff address outerEffects a = ConcreteEff
+  { runConcreteEff :: Eff (ValueEffects  address (Value address (ConcreteEff address outerEffects))
+                          (ModuleEffects address (Value address (ConcreteEff address outerEffects))
+                          (ConcreteEffects address outerEffects))) a
   }
 
 

src/Semantic/REPL.hs

@@ -88,7 +88,7 @@ repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runD
     . fmap snd
     . runState ([] @Breakpoint)
     . runReader Step
-    . runTermEvaluator @_ @_ @(Value Precise (UtilEff Precise _))
+    . runTermEvaluator @_ @_ @(Value Precise (ConcreteEff Precise _))
     . runPrintingTrace
     . runState lowerBound
     . runFresh 0
@@ -100,10 +100,10 @@ repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runD
     . runResolutionError
     . runAddressError
     . runValueError
-    . runReader (packageInfo package)
-    . runReader (lowerBound @Span)
     . runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Precise)))))
     . raiseHandler (runModules (ModuleTable.modulePaths (packageModules (snd <$> package))))
+    . runReader (packageInfo package)
+    . runReader (lowerBound @Span)
     $ evaluate proxy id (withTermSpans . step (fmap (\ (x:|_) -> moduleBody x) <$> ModuleTable.toPairs (packageModules (fst <$> package)))) (Precise.runAllocator . Precise.runDeref) (Concrete.runFunction coerce coerce) modules
 
 -- TODO: REPL for typechecking/abstract semantics

src/Semantic/Util.hs

@@ -11,7 +11,6 @@ import           Control.Exception (displayException)
 import           Control.Monad.Effect.Trace (runPrintingTrace)
 import           Data.Abstract.Address.Monovariant as Monovariant
 import           Data.Abstract.Address.Precise as Precise
-import           Data.Abstract.BaseError (BaseError(..))
 import           Data.Abstract.Evaluatable
 import           Data.Abstract.Module
 import qualified Data.Abstract.ModuleTable as ModuleTable
@@ -53,31 +52,6 @@ justEvaluating
   . runAddressError
   . runValueError
 
-newtype UtilEff address rest a = UtilEff
-  { runUtilEff :: Eff (  Function address (Value address (UtilEff address rest))
-                      ': Exc (LoopControl address)
-                      ': Exc (Return address)
-                      ': Env address
-                      ': Deref (Value address (UtilEff address rest))
-                      ': Allocator address
-                      ': Reader ModuleInfo
-                      ': Modules address
-                      ': Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))
-                      ': Reader Span
-                      ': Reader PackageInfo
-                      ': Resumable (BaseError (ValueError address (UtilEff address rest)))
-                      ': Resumable (BaseError (AddressError address (Value address (UtilEff address rest))))
-                      ': Resumable (BaseError ResolutionError)
-                      ': Resumable (BaseError EvalError)
-                      ': Resumable (BaseError (EnvironmentError address))
-                      ': Resumable (BaseError (UnspecializedError (Value address (UtilEff address rest))))
-                      ': Resumable (BaseError (LoadError address))
-                      ': Fresh
-                      ': State (Heap address (Value address (UtilEff address rest)))
-                      ': rest
-                      ) a
-  }
-
 checking
   = runM @_ @IO
   . runPrintingTrace
@@ -125,11 +99,11 @@ evaluateProject' (TaskConfig config logger statter) proxy parser paths = either
   package <- fmap (quieterm . snd) <$> parsePackage parser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs (Language.reflect proxy) [])
   modules <- topologicalSort <$> runImportGraphToModules proxy package
   trace $ "evaluating with load order: " <> show (map (modulePath . moduleInfo) modules)
-  pure (runTermEvaluator @_ @_ @(Value Precise (UtilEff Precise _))
-       (runReader (packageInfo package)
-       (runReader (lowerBound @Span)
+  pure (runTermEvaluator @_ @_ @(Value Precise (ConcreteEff Precise _))
        (runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Precise)))))
        (raiseHandler (runModules (ModuleTable.modulePaths (packageModules package)))
+       (runReader (packageInfo package)
+       (runReader (lowerBound @Span)
        (evaluate proxy id withTermSpans (Precise.runAllocator . Precise.runDeref) (Concrete.runFunction coerce coerce) modules))))))
 
 

test/SpecHelpers.hs

@@ -73,6 +73,7 @@ import qualified Data.ByteString as B
 import qualified Data.Set as Set
 import qualified Semantic.IO as IO
 import Semantic.Config (Config)
+import Semantic.Graph (ConcreteEff)
 import Semantic.Telemetry (LogQueue, StatQueue)
 import System.Exit (die)
 import Control.Exception (displayException)
@@ -97,7 +98,7 @@ readFilePair :: Both FilePath -> IO BlobPair
 readFilePair paths = let paths' = fmap file paths in
                      runBothWith IO.readFilePair paths'
 
-type TestEvaluatingEffects = '[ Resumable (BaseError (ValueError Precise (UtilEff Precise '[Trace, Lift IO])))
+type TestEvaluatingEffects = '[ Resumable (BaseError (ValueError Precise (ConcreteEff Precise '[Trace, Lift IO])))
                               , Resumable (BaseError (AddressError Precise Val))
                               , Resumable (BaseError ResolutionError)
                               , Resumable (BaseError EvalError)
@@ -109,7 +110,7 @@ type TestEvaluatingEffects = '[ Resumable (BaseError (ValueError Precise (UtilEf
                               , Trace
                               , Lift IO
                               ]
-type TestEvaluatingErrors = '[ BaseError (ValueError Precise (UtilEff Precise '[Trace, Lift IO]))
+type TestEvaluatingErrors = '[ BaseError (ValueError Precise (ConcreteEff Precise '[Trace, Lift IO]))
                              , BaseError (AddressError Precise Val)
                              , BaseError ResolutionError
                              , BaseError EvalError
@@ -137,9 +138,9 @@ testEvaluating
   . runEvalError
   . runResolutionError
   . runAddressError
-  . runValueError @_ @Precise @(UtilEff Precise _)
+  . runValueError @_ @Precise @(ConcreteEff Precise _)
 
-type Val = Value Precise (UtilEff Precise '[Trace, Lift IO])
+type Val = Value Precise (ConcreteEff Precise '[Trace, Lift IO])
 
 
 deNamespace :: Heap Precise (Value Precise term)