From 1b507fc5c0f9c70f45804c1b54432dadaa13f7ee Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 26 Oct 2018 13:38:20 -0400 Subject: [PATCH] Inline runValueEffects into evaluate. --- src/Semantic/Analysis.hs | 69 ++++++++++++++++++---------------------- src/Semantic/Graph.hs | 6 ++-- src/Semantic/REPL.hs | 2 +- src/Semantic/Util.hs | 6 ++-- 4 files changed, 38 insertions(+), 45 deletions(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 4fa722c2f..00328a41f 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -2,7 +2,6 @@ module Semantic.Analysis ( evaluate , evalTerm -, runValueEffects ) where import Control.Abstract @@ -32,22 +31,45 @@ type ValueC 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 :: ( Carrier outerSig outer +evaluate :: ( AbstractValue term address value (ValueC term address value inner) + , 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 value))) (Eff inner))) + , booleanSig ~ (Boolean value :+: Interpose (Resumable (BaseError (UnspecializedError 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 (Env address) innerSig + , Member Fresh innerSig + , Member (Reader ModuleInfo) innerSig , Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) outerSig + , Member (Reader Span) innerSig + , Member (Resumable (BaseError (AddressError address value))) innerSig + , Member (Resumable (BaseError (EnvironmentError address))) innerSig + , Member (Resumable (BaseError (UnspecializedError value))) innerSig + , Member (State (Heap address value)) innerSig + , Member Trace innerSig , Ord address ) - => lang - -> ( (Module (Either lang term) -> Evaluator term address value inner address) - -> (Module (Either lang term) -> Evaluator term address value (ModuleC address value outer) address)) - -> (Either lang term -> Evaluator term address value inner address) + => proxy lang + -> ( (Module (Either (proxy lang) term) -> Evaluator term address value inner address) + -> (Module (Either (proxy lang) term) -> Evaluator term address value (ModuleC address value outer) address)) + -> (term -> Evaluator term address value (ValueC term address value inner) address) -> [Module term] -> Evaluator term address value outer (ModuleTable (NonEmpty (Module (ModuleResult address)))) evaluate lang perModule runTerm modules = do @@ -59,7 +81,7 @@ evaluate lang perModule runTerm modules = do -- FIXME: this should be some sort of Monoidal insert à la the Heap to accommodate multiple Go files being part of the same module. local (ModuleTable.insert (modulePath (moduleInfo m)) ((evaluated <$ m) :| [])) rest - evalModule prelude m = runInModule (perModule (runTerm . moduleBody) m) + evalModule prelude m = runInModule (perModule (runValueEffects . moduleBody) m) where runInModule = raiseHandler (runReader (moduleInfo m)) . runAllocator @@ -69,6 +91,8 @@ evaluate lang perModule runTerm modules = do . runReturn . runLoopControl + runValueEffects = raiseHandler runInterpose . runBoolean . runWhile . runFunction runTerm . either ((*> box unit) . definePrelude) runTerm + -- | Evaluate a term recursively, applying the passed function at every recursive position. -- -- This calls out to the 'Evaluatable' instances, will be passed to 'runValueEffects', and can have other functions composed after it to e.g. intercept effects arising in the evaluation of the term. @@ -105,34 +129,3 @@ evalTerm :: ( Carrier sig m => Open (Open (term -> Evaluator term address value m (ValueRef address))) -> term -> Evaluator term address value m address evalTerm perTerm = fix (perTerm (\ ev -> eval ev . project)) >=> address - --- | Run a set of value effects, for which a 'Carrier' is assumed to exist. -runValueEffects :: ( AbstractValue term address value (ValueC term address value m) - , Carrier sig m - , booleanC ~ BooleanC value (Eff (InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff m))) - , booleanSig ~ (Boolean value :+: Interpose (Resumable (BaseError (UnspecializedError value))) :+: sig) - , 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 - , HasPrelude lang - , Member (Allocator address) sig - , Member (Deref value) sig - , Member (Env address) sig - , Member Fresh sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (AddressError address value))) sig - , Member (Resumable (BaseError (EnvironmentError address))) sig - , Member (Resumable (BaseError (UnspecializedError value))) sig - , Member (State (Heap address value)) sig - , Member Trace sig - , Ord address - ) - => (term -> Evaluator term address value (ValueC term address value m) address) - -> Either (proxy lang) term - -> Evaluator term address value m address -runValueEffects evalTerm = raiseHandler runInterpose . runBoolean . runWhile . runFunction evalTerm . either ((*> box unit) . definePrelude) evalTerm diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 119ca1242..19dcf7e3b 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -122,7 +122,7 @@ runCallGraph lang includePackages modules package . providingLiveSet . runModuleTable . runModules (ModuleTable.modulePaths (packageModules package)) - $ evaluate lang perModule (runValueEffects perTerm) modules + $ evaluate lang perModule perTerm modules where perTerm = evalTerm (withTermSpans . graphingTerms . cachingTerms) perModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules @@ -196,7 +196,7 @@ runImportGraph lang (package :: Package term) f . raiseHandler (runReader (packageInfo package)) . raiseHandler (runState (lowerBound @Span)) . raiseHandler (runReader (lowerBound @Span)) - $ evaluate lang graphingModuleInfo (runValueEffects (evalTerm id)) (ModuleTable.toPairs (packageModules package) >>= toList . snd) + $ evaluate lang graphingModuleInfo (evalTerm id) (ModuleTable.toPairs (packageModules package) >>= toList . snd) runHeap :: (Carrier sig m, Effect sig) => Evaluator term address value (StateC (Heap address value) (Eff m)) a -> Evaluator term address value m (Heap address value, a) @@ -260,7 +260,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 (runValueEffects (runPythonPackaging . evalTerm id)) [ setupModule ]) + fst <$> runAnalysis (evaluate (Proxy @'Language.Python) id (runPythonPackaging . evalTerm id) [ setupModule ]) Nothing -> pure PythonPackage.Unknown case strat of PythonPackage.Unknown -> do diff --git a/src/Semantic/REPL.hs b/src/Semantic/REPL.hs index 1bfbd4e57..7e37521a0 100644 --- a/src/Semantic/REPL.hs +++ b/src/Semantic/REPL.hs @@ -121,7 +121,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 (runValueEffects (evalTerm (withTermSpans . step (fmap (\ (x:|_) -> moduleBody x) <$> ModuleTable.toPairs (packageModules (fst <$> package)))))) modules + $ evaluate proxy id (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 diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 27dcbeb77..6c8f6881a 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -105,7 +105,7 @@ evaluateProject' (TaskConfig config logger statter) proxy parser paths = either (raiseHandler (runReader (packageInfo package)) (raiseHandler (runState (lowerBound @Span)) (raiseHandler (runReader (lowerBound @Span)) - (evaluate proxy id (runValueEffects (evalTerm withTermSpans)) modules))))))) + (evaluate proxy id (evalTerm withTermSpans) modules))))))) evaluatePythonProjects proxy parser lang path = runTaskWithOptions debugOptions $ do project <- readProject Nothing path lang [] @@ -118,7 +118,7 @@ evaluatePythonProjects proxy parser lang path = runTaskWithOptions debugOptions (raiseHandler (runReader (packageInfo package)) (raiseHandler (runState (lowerBound @Span)) (raiseHandler (runReader (lowerBound @Span)) - (evaluate proxy id (runValueEffects (evalTerm withTermSpans)) modules))))))) + (evaluate proxy id (evalTerm withTermSpans) modules))))))) evaluateProjectWithCaching proxy parser path = runTaskWithOptions debugOptions $ do @@ -131,7 +131,7 @@ evaluateProjectWithCaching proxy parser path = runTaskWithOptions debugOptions $ (raiseHandler (runReader (lowerBound @Span)) (runModuleTable (runModules (ModuleTable.modulePaths (packageModules package)) - (evaluate proxy id (runValueEffects (evalTerm withTermSpans)) modules))))))) + (evaluate proxy id (evalTerm withTermSpans) modules))))))) parseFile :: Parser term -> FilePath -> IO term