From 1e83574cf074a4f3e06167b16f3cc730e374c4b3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 25 Oct 2018 11:47:21 -0400 Subject: [PATCH 01/51] :fire: the use of postludes. --- src/Data/Abstract/Evaluatable.hs | 7 +------ src/Semantic/Graph.hs | 4 ---- 2 files changed, 1 insertion(+), 10 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index babe1966f..48ce55c2b 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -119,7 +119,6 @@ evaluate :: ( AbstractValue term address value valueC , Effect sig , Evaluatable (Base term) , FreeVariables term - , HasPostlude lang , HasPrelude lang , Member Fresh sig , Member (Modules address) sig @@ -151,15 +150,11 @@ evaluate lang analyzeModule analyzeTerm modules = do foldr (run preludeBinds) ask modules where run preludeBinds m rest = do evaluated <- runInModule preludeBinds (moduleInfo m) - (analyzeModule (evalModuleBody . moduleBody) + (analyzeModule (runValue . evalTerm . moduleBody) m) -- 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 - evalModuleBody term = runValue (do - result <- evalTerm term - result <$ postlude lang) - evalTerm = fix (analyzeTerm ((. project) . eval)) >=> address runValue = runBoolean . runWhile . runFunction evalTerm diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 923089446..c30ffbe82 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -93,7 +93,6 @@ runCallGraph :: ( VertexDeclarationWithStrategy (VertexDeclarationStrategy synta , FreeVariables term , Recursive term , HasPrelude lang - , HasPostlude lang , Member Trace sig , Carrier sig m , Effect sig @@ -136,7 +135,6 @@ runImportGraphToModuleInfos :: ( Declarations term , Evaluatable (Base term) , FreeVariables term , HasPrelude lang - , HasPostlude lang , Member Trace sig , Recursive term , Carrier sig m @@ -153,7 +151,6 @@ runImportGraphToModules :: ( Declarations term , Evaluatable (Base term) , FreeVariables term , HasPrelude lang - , HasPostlude lang , Member Trace sig , Recursive term , Carrier sig m @@ -170,7 +167,6 @@ runImportGraph :: ( Declarations term , Evaluatable (Base term) , FreeVariables term , HasPrelude lang - , HasPostlude lang , Member Trace sig , Recursive term , Carrier sig m From 91e747db8dc538bc8ca5c84cf769ed293e83c2fc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 25 Oct 2018 11:49:45 -0400 Subject: [PATCH 02/51] :fire: the HasPostlude constraints on SomeAnalysisParser. --- src/Parsing/Parser.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index 50ee11e60..4c93043c8 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -31,7 +31,7 @@ module Parsing.Parser import Assigning.Assignment import qualified Assigning.Assignment.Deterministic as Deterministic import qualified CMarkGFM -import Data.Abstract.Evaluatable (HasPostlude, HasPrelude) +import Data.Abstract.Evaluatable (HasPrelude) import Data.AST import Data.Graph.ControlFlowVertex (VertexDeclaration') import Data.Kind @@ -73,7 +73,6 @@ data SomeAnalysisParser typeclasses ann where , Apply (VertexDeclaration' (Sum fs)) fs , Element Syntax.Identifier fs , HasPrelude lang - , HasPostlude lang ) => Parser (Term (Sum fs) ann) -> Proxy lang From 996a2ab79cb79cca60030102353dd03926c86a62 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 25 Oct 2018 11:49:50 -0400 Subject: [PATCH 03/51] :fire: HasPostlude. --- src/Data/Abstract/Evaluatable.hs | 32 -------------------------------- 1 file changed, 32 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 48ce55c2b..cd8ce9185 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -8,8 +8,6 @@ module Data.Abstract.Evaluatable , traceResolve -- * Preludes , HasPrelude(..) --- * Postludes -, HasPostlude(..) -- * Effects , EvalError(..) , throwEvalError @@ -224,36 +222,6 @@ instance HasPrelude 'JavaScript where defineNamespace (name "console") $ do define (name "log") (builtIn Print) --- Postludes - -class HasPostlude (language :: Language) where - postlude :: ( AbstractValue term address value m - , Carrier sig m - , HasCallStack - , 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 (EnvironmentError address))) sig - , Member Trace sig - ) - => proxy language - -> Evaluator term address value m () - postlude _ = pure () - -instance HasPostlude 'Go -instance HasPostlude 'Haskell -instance HasPostlude 'Java -instance HasPostlude 'PHP -instance HasPostlude 'Python -instance HasPostlude 'Ruby -instance HasPostlude 'TypeScript - -instance HasPostlude 'JavaScript where - postlude _ = trace "JS postlude" - -- Effects From df10f93bcdddc82fdc43af6f57243fde7f25ec09 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 25 Oct 2018 13:44:28 -0400 Subject: [PATCH 04/51] Extract runInModule to the top level. --- src/Data/Abstract/Evaluatable.hs | 36 +++++++++++++++++++++++--------- 1 file changed, 26 insertions(+), 10 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index cd8ce9185..30d0fd259 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -157,16 +157,32 @@ evaluate lang analyzeModule analyzeTerm modules = do runValue = runBoolean . runWhile . runFunction evalTerm - runInModule preludeBinds info - = raiseHandler (runReader info) - . runAllocator - . runDeref - . runScopeEnv - . runEnv (EvalContext Nothing (X.push (newEnv preludeBinds))) - . runReturn - . runLoopControl - . raiseHandler runInterpose - . raiseHandler runEavesdrop +runInModule :: ( Carrier sig m + , allocatorC ~ (AllocatorC address (Eff (ReaderC ModuleInfo (Eff m)))) + , allocatorSig ~ (Allocator address :+: Reader ModuleInfo :+: sig) + , Carrier allocatorSig allocatorC + , Carrier (Deref value :+: allocatorSig) (DerefC address value (Eff allocatorC)) + , Effect sig + , Member Fresh sig + , Member (Modules address) sig + , Member (Resumable (BaseError (UnspecializedError value))) sig + , Ord address + ) + => Bindings address + -> ModuleInfo + -> Evaluator term address value (ModuleC address value m) address + -> Evaluator term address value m (ModuleResult address) +runInModule prelude info + = raiseHandler (runReader info) + . runAllocator + . runDeref + . runScopeEnv + . runEnv (EvalContext Nothing (X.push (newEnv prelude))) + . runReturn + . runLoopControl + . raiseHandler runInterpose + . raiseHandler runEavesdrop + traceResolve :: (Show a, Show b, Member Trace sig, Carrier sig m) => a -> b -> Evaluator term address value m () From c625efd9c53b97be780f9ac709e4653bbe705975 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 25 Oct 2018 13:47:07 -0400 Subject: [PATCH 05/51] Extract the fold over modules to the top level. --- src/Data/Abstract/Evaluatable.hs | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 30d0fd259..f7eb1e206 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -145,13 +145,8 @@ evaluate lang analyzeModule analyzeTerm modules = do (_, (preludeBinds, _)) <- runInModule lowerBound moduleInfoFromCallStack . runValue $ do definePrelude lang box unit - foldr (run preludeBinds) ask modules - where run preludeBinds m rest = do - evaluated <- runInModule preludeBinds (moduleInfo m) - (analyzeModule (runValue . evalTerm . moduleBody) - m) - -- 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 + evaluateModules (run preludeBinds <$> modules) + where run preludeBinds m = (<$ m) <$> runInModule preludeBinds (moduleInfo m) (analyzeModule (runValue . evalTerm . moduleBody) m) evalTerm = fix (analyzeTerm ((. project) . eval)) >=> address @@ -183,6 +178,16 @@ runInModule prelude info . raiseHandler runInterpose . raiseHandler runEavesdrop +evaluateModules :: ( Carrier sig m + , Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) sig + ) + => [Evaluator term address value m (Module (ModuleResult address))] + -> Evaluator term address value m (ModuleTable (NonEmpty (Module (ModuleResult address)))) +evaluateModules = foldr run ask + where run evaluator rest = do + evaluated <- evaluator + -- 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 evaluated)) (evaluated :| [])) rest traceResolve :: (Show a, Show b, Member Trace sig, Carrier sig m) => a -> b -> Evaluator term address value m () From 8a3d7ba927ad5fa6f9ea5123a08fc7a71ccd9f22 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 25 Oct 2018 13:48:47 -0400 Subject: [PATCH 06/51] =?UTF-8?q?Don=E2=80=99t=20be=20clever.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Data/Abstract/Evaluatable.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index f7eb1e206..fa250b19e 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -148,7 +148,7 @@ evaluate lang analyzeModule analyzeTerm modules = do evaluateModules (run preludeBinds <$> modules) where run preludeBinds m = (<$ m) <$> runInModule preludeBinds (moduleInfo m) (analyzeModule (runValue . evalTerm . moduleBody) m) - evalTerm = fix (analyzeTerm ((. project) . eval)) >=> address + evalTerm = fix (analyzeTerm (\ ev -> eval ev . project)) >=> address runValue = runBoolean . runWhile . runFunction evalTerm From 4cad9bc45e6eaf66e94ba38657c01e9213aaa9a4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 25 Oct 2018 16:42:53 -0400 Subject: [PATCH 07/51] Re-export Control.Abstract.ScopeGraph from Control.Abstract. --- src/Control/Abstract.hs | 1 + src/Data/Abstract/Evaluatable.hs | 1 - 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract.hs b/src/Control/Abstract.hs index f0039ce19..58a9c0b64 100644 --- a/src/Control/Abstract.hs +++ b/src/Control/Abstract.hs @@ -10,4 +10,5 @@ import Control.Abstract.Hole as X import Control.Abstract.Modules as X import Control.Abstract.Primitive as X import Control.Abstract.Roots as X +import Control.Abstract.ScopeGraph as X import Control.Abstract.Value as X diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index fa250b19e..07ded92ba 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -26,7 +26,6 @@ import Control.Abstract.Evaluator as X hiding (LoopControl(..), Return(..), catc import Control.Abstract.Heap as X hiding (runAddressError, runAddressErrorWith) import Control.Abstract.Modules as X (Modules, ModuleResult, ResolutionError(..), load, lookupModule, listModulesInDir, require, resolve, throwResolutionError) import Control.Abstract.Value as X hiding (Boolean(..), Function(..), While(..)) -import Control.Abstract.ScopeGraph import Control.Effect.Eavesdrop import Control.Effect.Interpose import Data.Abstract.Declarations as X From 097af57735133be914c377204c5a9508c3e11eed Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 25 Oct 2018 17:34:04 -0400 Subject: [PATCH 08/51] Factor the interposes into a runInTerm helper. --- src/Data/Abstract/Evaluatable.hs | 61 ++++++++++++++++++++------------ 1 file changed, 38 insertions(+), 23 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 07ded92ba..59dfd48b9 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -5,6 +5,9 @@ module Data.Abstract.Evaluatable , ModuleC , ValueC , evaluate +, runInModule +, runInTerm +, evaluateModules , traceResolve -- * Preludes , HasPrelude(..) @@ -84,29 +87,29 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where type ModuleC address value m - = EavesdropC (Modules address) (Eff - ( InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff - ( ErrorC (LoopControl address) (Eff - ( ErrorC (Return address) (Eff - ( EnvC address (Eff - ( ScopeEnvC address (Eff - ( DerefC address value (Eff - ( AllocatorC address (Eff - ( ReaderC ModuleInfo (Eff - m))))))))))))))))) + = ErrorC (LoopControl address) (Eff + ( ErrorC (Return address) (Eff + ( EnvC address (Eff + ( ScopeEnvC address (Eff + ( DerefC address value (Eff + ( AllocatorC address (Eff + ( ReaderC ModuleInfo (Eff + m))))))))))))) type ValueC term address value m - = FunctionC term address value (Eff - ( WhileC value (Eff - ( BooleanC value (Eff - m))))) + = FunctionC term address value (Eff + ( WhileC value (Eff + ( BooleanC value (Eff + ( EavesdropC (Modules address) (Eff + ( InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff + m))))))))) evaluate :: ( AbstractValue term address value valueC , Carrier sig c , allocatorC ~ AllocatorC address (Eff (ReaderC ModuleInfo (Eff c))) , Carrier (Allocator address :+: Reader ModuleInfo :+: sig) allocatorC , Carrier (Deref value :+: Allocator address :+: Reader ModuleInfo :+: sig) (DerefC address value (Eff allocatorC)) - , booleanC ~ BooleanC value (Eff moduleC) + , booleanC ~ BooleanC value (Eff (EavesdropC (Modules address) (Eff (InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff moduleC))))) , Carrier (Boolean value :+: moduleSig) booleanC , whileC ~ WhileC value (Eff booleanC) , moduleSig ~ (Eavesdrop (Modules address) :+: Interpose (Resumable (BaseError (UnspecializedError value))) :+: Error (LoopControl address) :+: Error (Return address) :+: Env address :+: ScopeEnv address :+: Deref value :+: Allocator address :+: Reader ModuleInfo :+: sig) @@ -141,16 +144,14 @@ evaluate :: ( AbstractValue term address value valueC -> [Module term] -> Evaluator term address value c (ModuleTable (NonEmpty (Module (ModuleResult address)))) evaluate lang analyzeModule analyzeTerm modules = do - (_, (preludeBinds, _)) <- runInModule lowerBound moduleInfoFromCallStack . runValue $ do + (_, (preludeBinds, _)) <- runInModule lowerBound moduleInfoFromCallStack . runInTerm evalTerm $ do definePrelude lang box unit evaluateModules (run preludeBinds <$> modules) - where run preludeBinds m = (<$ m) <$> runInModule preludeBinds (moduleInfo m) (analyzeModule (runValue . evalTerm . moduleBody) m) + where run preludeBinds m = (<$ m) <$> runInModule preludeBinds (moduleInfo m) (analyzeModule (runInTerm evalTerm . evalTerm . moduleBody) m) evalTerm = fix (analyzeTerm (\ ev -> eval ev . project)) >=> address - runValue = runBoolean . runWhile . runFunction evalTerm - runInModule :: ( Carrier sig m , allocatorC ~ (AllocatorC address (Eff (ReaderC ModuleInfo (Eff m)))) , allocatorSig ~ (Allocator address :+: Reader ModuleInfo :+: sig) @@ -158,8 +159,6 @@ runInModule :: ( Carrier sig m , Carrier (Deref value :+: allocatorSig) (DerefC address value (Eff allocatorC)) , Effect sig , Member Fresh sig - , Member (Modules address) sig - , Member (Resumable (BaseError (UnspecializedError value))) sig , Ord address ) => Bindings address @@ -174,8 +173,24 @@ runInModule prelude info . runEnv (EvalContext Nothing (X.push (newEnv prelude))) . runReturn . runLoopControl - . raiseHandler runInterpose - . raiseHandler runEavesdrop + +runInTerm :: ( Carrier sig m + , booleanC ~ BooleanC value (Eff (EavesdropC (Modules address) (Eff (InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff m))))) + , booleanSig ~ (Boolean value :+: Eavesdrop (Modules address) :+: 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 + , Member (Modules address) sig + , Member (Resumable (BaseError (UnspecializedError value))) sig + ) + => (term -> Evaluator term address value (ValueC term address value m) address) + -> Evaluator term address value (ValueC term address value m) a + -> Evaluator term address value m a +runInTerm evalTerm = raiseHandler runInterpose . raiseHandler runEavesdrop . runBoolean . runWhile . runFunction evalTerm evaluateModules :: ( Carrier sig m , Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) sig From 64df59c4bf19c1a4f90cfcf04b2129e1207de654 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 25 Oct 2018 20:55:07 -0400 Subject: [PATCH 09/51] Extract evalTerm. --- src/Data/Abstract/Evaluatable.hs | 37 +++++++++++++++++++++++++++++--- 1 file changed, 34 insertions(+), 3 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 59dfd48b9..a7b34d7cc 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -5,6 +5,7 @@ module Data.Abstract.Evaluatable , ModuleC , ValueC , evaluate +, evalTerm , runInModule , runInTerm , evaluateModules @@ -144,13 +145,43 @@ evaluate :: ( AbstractValue term address value valueC -> [Module term] -> Evaluator term address value c (ModuleTable (NonEmpty (Module (ModuleResult address)))) evaluate lang analyzeModule analyzeTerm modules = do - (_, (preludeBinds, _)) <- runInModule lowerBound moduleInfoFromCallStack . runInTerm evalTerm $ do + (_, (preludeBinds, _)) <- runInModule lowerBound moduleInfoFromCallStack . runInTerm (evalTerm analyzeTerm) $ do definePrelude lang box unit evaluateModules (run preludeBinds <$> modules) - where run preludeBinds m = (<$ m) <$> runInModule preludeBinds (moduleInfo m) (analyzeModule (runInTerm evalTerm . evalTerm . moduleBody) m) + where run preludeBinds m = (<$ m) <$> runInModule preludeBinds (moduleInfo m) (analyzeModule (runInTerm (evalTerm analyzeTerm) . evalTerm analyzeTerm . moduleBody) m) - evalTerm = fix (analyzeTerm (\ ev -> eval ev . project)) >=> address +evalTerm :: ( Carrier sig m + , Declarations term + , Evaluatable (Base term) + , FreeVariables term, Ord address, Recursive term + , AbstractValue term address value m + , Member (Allocator address) sig + , Member (Boolean value) sig + , Member (Deref value) sig + , Member (Env address) sig + , Member (Error (LoopControl address)) sig + , Member (Error (Return address)) sig + , Member Fresh sig + , Member (Function term address value) sig + , Member (Modules address) sig + , Member (Reader ModuleInfo) sig + , Member (Reader PackageInfo) sig + , Member (Reader Span) sig + , Member (Resumable (BaseError (AddressError address value))) sig + , Member (Resumable (BaseError (EnvironmentError address))) sig + , Member (Resumable (BaseError EvalError)) sig + , Member (Resumable (BaseError ResolutionError)) sig + , Member (Resumable (BaseError (UnspecializedError value))) sig + , Member (ScopeEnv address) sig + , Member (State (Heap address value)) sig + , Member (State Span) sig + , Member Trace sig + , Member (While value) sig + ) + => Open (Open (term -> Evaluator term address value m (ValueRef address))) + -> term -> Evaluator term address value m address +evalTerm analyzeTerm = fix (analyzeTerm (\ ev -> eval ev . project)) >=> address runInModule :: ( Carrier sig m , allocatorC ~ (AllocatorC address (Eff (ReaderC ModuleInfo (Eff m)))) From b738dcc12b3394549753074605b04ccfc326258a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 25 Oct 2018 21:03:51 -0400 Subject: [PATCH 10/51] Run effects in module analysis. --- .../Abstract/Caching/FlowInsensitive.hs | 7 +- src/Analysis/Abstract/Graph.hs | 39 ++++++-- src/Semantic/Graph.hs | 96 ++++++++++--------- 3 files changed, 85 insertions(+), 57 deletions(-) diff --git a/src/Analysis/Abstract/Caching/FlowInsensitive.hs b/src/Analysis/Abstract/Caching/FlowInsensitive.hs index 76f84cdf3..8c99c79f7 100644 --- a/src/Analysis/Abstract/Caching/FlowInsensitive.hs +++ b/src/Analysis/Abstract/Caching/FlowInsensitive.hs @@ -91,8 +91,10 @@ convergingModules :: ( AbstractValue term address value m , Ord address , Ord term , Carrier sig m + , Effect sig ) - => Open (Module term -> Evaluator term address value m address) + => (Module term -> Evaluator term address value (AltC Maybe (Eff m)) address) + -> (Module term -> Evaluator term address value m address) convergingModules recur m = do c <- getConfiguration (moduleBody m) heap <- getHeap @@ -106,8 +108,7 @@ convergingModules recur m = do -- that it doesn't "leak" to the calling context and diverge (otherwise this -- would never complete). We don’t need to use the values, so we 'gather' the -- nondeterministic values into @()@. - -- FIXME: do we actually need to gather here after all?? - withOracle prevCache (recur m)) + withOracle prevCache (raiseHandler runNonDet (recur m))) address =<< maybe empty scatter (cacheLookup c cache) -- | Iterate a monadic action starting from some initial seed until the results converge. diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index b3ca4e1fa..22a2c595c 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -17,8 +17,9 @@ module Analysis.Abstract.Graph ) where import Algebra.Graph.Export.Dot hiding (vertexName) -import Control.Abstract hiding (Function(..)) -import Control.Effect.Eavesdrop +import Control.Abstract hiding (Function(..), EavesdropC) +import Control.Effect.Carrier +import Control.Effect.Sum import Data.Abstract.Address.Hole import Data.Abstract.Address.Located import Data.Abstract.BaseError @@ -117,19 +118,19 @@ graphingPackages recur m = let v = moduleVertex (moduleInfo m) in packageInclusion v *> local (const v) (recur m) -- | Add vertices to the graph for imported modules. -graphingModules :: forall term address value m sig a - . ( Member (Eavesdrop (Modules address)) sig +graphingModules :: ( Member (Modules address) sig , Member (Reader ModuleInfo) sig , Member (State (Graph ControlFlowVertex)) sig , Member (Reader ControlFlowVertex) sig , Carrier sig m ) - => Open (Module term -> Evaluator term address value m a) + => (Module term -> Evaluator term address value (EavesdropC address (Eff m)) a) + -> (Module term -> Evaluator term address value m a) graphingModules recur m = do let v = moduleVertex (moduleInfo m) appendGraph (vertex v) local (const v) $ - eavesdrop @(Modules address) (recur m) $ \case + eavesdrop (recur m) $ \case Load path _ -> includeModule path Lookup path _ -> includeModule path _ -> pure () @@ -140,17 +141,35 @@ graphingModules recur m = do {-# ANN graphingModules ("HLint: ignore Use ." :: String) #-} +eavesdrop :: (Carrier sig m, Member (Modules address) sig) + => Evaluator term address value (EavesdropC address (Eff m)) a + -> (forall x . Modules address (Eff m) (Eff m x) -> Evaluator term address value m ()) + -> Evaluator term address value m a +eavesdrop m f = raiseHandler (runEavesdropC (runEvaluator . f) . interpret) m + +newtype EavesdropC address m a = EavesdropC ((forall x . Modules address m (m x) -> m ()) -> m a) + +runEavesdropC :: (forall x . Modules address m (m x) -> m ()) -> EavesdropC address m a -> m a +runEavesdropC f (EavesdropC m) = m f + +instance (Carrier sig m, Member (Modules address) sig, Applicative m) => Carrier sig (EavesdropC address m) where + ret a = EavesdropC (const (ret a)) + eff op + | Just eff <- prj op = EavesdropC (\ handler -> let eff' = handlePure (runEavesdropC handler) eff in handler eff' *> send eff') + | otherwise = EavesdropC (\ handler -> eff (handlePure (runEavesdropC handler) op)) + + -- | Add vertices to the graph for imported modules. -graphingModuleInfo :: forall term address value m sig a - . ( Member (Eavesdrop (Modules address)) sig +graphingModuleInfo :: ( Member (Modules address) sig , Member (Reader ModuleInfo) sig , Member (State (Graph ModuleInfo)) sig , Carrier sig m ) - => Open (Module term -> Evaluator term address value m a) + => (Module term -> Evaluator term address value (EavesdropC address (Eff m)) a) + -> (Module term -> Evaluator term address value m a) graphingModuleInfo recur m = do appendGraph (vertex (moduleInfo m)) - eavesdrop @(Modules address) (recur m) $ \case + eavesdrop (recur m) $ \case Load path _ -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex Lookup path _ -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex _ -> pure () diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index c30ffbe82..89644feef 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -37,7 +37,7 @@ import Data.Abstract.Address.Located as Located 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.Evaluatable as Eval import Data.Abstract.Module import qualified Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Package as Package @@ -102,29 +102,34 @@ runCallGraph :: ( VertexDeclarationWithStrategy (VertexDeclarationStrategy synta -> [Module term] -> Package term -> Eff m (Graph ControlFlowVertex) -runCallGraph lang includePackages modules package = do - let analyzeTerm = withTermSpans . graphingTerms . cachingTerms - analyzeModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules - extractGraph (graph, _) = simplify graph - runGraphAnalysis - = graphing @_ @_ @_ @(Hole (Maybe Name) (Located Monovariant)) @Abstract - . runHeap - . caching - . raiseHandler runFresh - . resumingLoadError - . resumingUnspecialized - . resumingEnvironmentError - . resumingEvalError - . resumingResolutionError - . resumingAddressError - . raiseHandler (runReader (packageInfo package)) - . raiseHandler (runReader (lowerBound @Span)) - . raiseHandler (runState (lowerBound @Span)) - . raiseHandler (runReader (lowerBound @ControlFlowVertex)) - . providingLiveSet - . runModuleTable - . runModules (ModuleTable.modulePaths (packageModules package)) - extractGraph <$> runEvaluator (runGraphAnalysis (evaluate lang analyzeModule analyzeTerm modules)) +runCallGraph lang includePackages modules package + = fmap (simplify . fst) + . runEvaluator + . graphing @_ @_ @_ @(Hole (Maybe Name) (Located Monovariant)) @Abstract + . runHeap + . caching + . raiseHandler runFresh + . resumingLoadError + . resumingUnspecialized + . resumingEnvironmentError + . resumingEvalError + . resumingResolutionError + . resumingAddressError + . raiseHandler (runReader (packageInfo package)) + . raiseHandler (runReader (lowerBound @Span)) + . raiseHandler (runState (lowerBound @Span)) + . raiseHandler (runReader (lowerBound @ControlFlowVertex)) + . providingLiveSet + . runModuleTable + . runModules (ModuleTable.modulePaths (packageModules package)) $ do + -- (_, (prelude, _)) <- runInModule lowerBound moduleInfoFromCallStack . runInTerm (evalTerm perTerm) $ do + -- definePrelude lang + -- box unit + let run m = (<$ m) <$> runInModule lowerBound (moduleInfo m) (perModule (runInTerm (evalTerm perTerm) . evalTerm perTerm . moduleBody) m) + evaluateModules (map run modules) + where perTerm = withTermSpans . graphingTerms . cachingTerms + perModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules + runModuleTable :: Carrier sig m => Evaluator term address value (ReaderC (ModuleTable (NonEmpty (Module (ModuleResult address)))) (Eff m)) a @@ -177,26 +182,29 @@ runImportGraph :: ( Declarations term -> Package term -> (ModuleInfo -> Graph vertex) -> Eff m (Graph vertex) -runImportGraph lang (package :: Package term) f = - let analyzeModule = graphingModuleInfo - extractGraph (graph, _) = graph >>= f - runImportGraphAnalysis - = raiseHandler (runState lowerBound) - . runHeap - . raiseHandler runFresh - . resumingLoadError - . resumingUnspecialized - . resumingEnvironmentError - . resumingEvalError - . resumingResolutionError - . resumingAddressError - . resumingValueError - . runModuleTable - . runModules (ModuleTable.modulePaths (packageModules package)) - . raiseHandler (runReader (packageInfo package)) - . raiseHandler (runState (lowerBound @Span)) - . raiseHandler (runReader (lowerBound @Span)) - in extractGraph <$> runEvaluator @_ @_ @(Value _ (Hole (Maybe Name) Precise)) (runImportGraphAnalysis (evaluate lang analyzeModule id (ModuleTable.toPairs (packageModules package) >>= toList . snd))) +runImportGraph lang (package :: Package term) f + = fmap (fst >=> f) + . runEvaluator @_ @_ @(Value _ (Hole (Maybe Name) Precise)) + . raiseHandler (runState lowerBound) + . runHeap + . raiseHandler runFresh + . resumingLoadError + . resumingUnspecialized + . resumingEnvironmentError + . resumingEvalError + . resumingResolutionError + . resumingAddressError + . resumingValueError + . runModuleTable + . runModules (ModuleTable.modulePaths (packageModules package)) + . raiseHandler (runReader (packageInfo package)) + . raiseHandler (runState (lowerBound @Span)) + . raiseHandler (runReader (lowerBound @Span)) $ do + -- (_, (prelude, _)) <- runInModule lowerBound moduleInfoFromCallStack . runInTerm (evalTerm id) $ do + -- definePrelude lang + -- box unit + let run m = (<$ m) <$> runInModule lowerBound (moduleInfo m) (graphingModuleInfo (runInTerm (evalTerm id) . evalTerm id . moduleBody) m) + evaluateModules (map run (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) From 428d92788bf8dcfe0f54d3f832f309cff60faf5e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 25 Oct 2018 21:13:28 -0400 Subject: [PATCH 11/51] Sort a couple of constraints down. --- src/Data/Abstract/Evaluatable.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index a7b34d7cc..a29f80399 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -154,7 +154,7 @@ evaluate lang analyzeModule analyzeTerm modules = do evalTerm :: ( Carrier sig m , Declarations term , Evaluatable (Base term) - , FreeVariables term, Ord address, Recursive term + , FreeVariables term , AbstractValue term address value m , Member (Allocator address) sig , Member (Boolean value) sig @@ -178,6 +178,8 @@ evalTerm :: ( Carrier sig m , Member (State Span) sig , Member Trace sig , Member (While value) sig + , Ord address + , Recursive term ) => Open (Open (term -> Evaluator term address value m (ValueRef address))) -> term -> Evaluator term address value m address From 830fde2104f8ee13a42d3003741f9108bafab7b6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 25 Oct 2018 21:22:22 -0400 Subject: [PATCH 12/51] Simplify evaluate to take the term evaluator. --- src/Data/Abstract/Evaluatable.hs | 16 ++++------------ src/Semantic/Graph.hs | 2 +- src/Semantic/REPL.hs | 2 +- src/Semantic/Util.hs | 6 +++--- 4 files changed, 9 insertions(+), 17 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index a29f80399..a262ea169 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -116,40 +116,32 @@ evaluate :: ( AbstractValue term address value valueC , moduleSig ~ (Eavesdrop (Modules address) :+: Interpose (Resumable (BaseError (UnspecializedError value))) :+: Error (LoopControl address) :+: Error (Return address) :+: Env address :+: ScopeEnv address :+: Deref value :+: Allocator address :+: Reader ModuleInfo :+: sig) , Carrier (While value :+: Boolean value :+: moduleSig) whileC , Carrier (Function term address value :+: While value :+: Boolean value :+: moduleSig) valueC - , Declarations term , Effect sig - , Evaluatable (Base term) - , FreeVariables term , HasPrelude lang , Member Fresh sig , Member (Modules address) sig , Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) sig - , Member (Reader PackageInfo) sig , Member (Reader Span) sig - , Member (State Span) sig , Member (Resumable (BaseError (AddressError address value))) sig , Member (Resumable (BaseError (EnvironmentError address))) sig - , Member (Resumable (BaseError EvalError)) sig - , Member (Resumable (BaseError ResolutionError)) sig , Member (Resumable (BaseError (UnspecializedError value))) sig , Member (State (Heap address value)) sig , Member Trace sig , Ord address - , Recursive term , moduleC ~ ModuleC address value c , valueC ~ ValueC term address value moduleC ) => proxy lang -> Open (Module term -> Evaluator term address value moduleC address) - -> Open (Open (term -> Evaluator term address value valueC (ValueRef address))) + -> (term -> Evaluator term address value valueC address) -> [Module term] -> Evaluator term address value c (ModuleTable (NonEmpty (Module (ModuleResult address)))) -evaluate lang analyzeModule analyzeTerm modules = do - (_, (preludeBinds, _)) <- runInModule lowerBound moduleInfoFromCallStack . runInTerm (evalTerm analyzeTerm) $ do +evaluate lang analyzeModule evalTerm modules = do + (_, (preludeBinds, _)) <- runInModule lowerBound moduleInfoFromCallStack . runInTerm evalTerm $ do definePrelude lang box unit evaluateModules (run preludeBinds <$> modules) - where run preludeBinds m = (<$ m) <$> runInModule preludeBinds (moduleInfo m) (analyzeModule (runInTerm (evalTerm analyzeTerm) . evalTerm analyzeTerm . moduleBody) m) + where run preludeBinds m = (<$ m) <$> runInModule preludeBinds (moduleInfo m) (analyzeModule (runInTerm evalTerm . evalTerm . moduleBody) m) evalTerm :: ( Carrier sig m , Declarations term diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 89644feef..9e07b7c63 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -268,7 +268,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 id [ setupModule ]) + fst <$> runAnalysis (evaluate (Proxy @'Language.Python) id (evalTerm id) [ setupModule ]) -- FIXME: what are we gonna do about runPythonPackaging Nothing -> pure PythonPackage.Unknown case strat of diff --git a/src/Semantic/REPL.hs b/src/Semantic/REPL.hs index ca9fbbf96..4d6e5257d 100644 --- a/src/Semantic/REPL.hs +++ b/src/Semantic/REPL.hs @@ -120,7 +120,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 (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 b314daf2b..4522b7bb4 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -104,7 +104,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 withTermSpans modules))))))) + (evaluate proxy id (evalTerm withTermSpans) modules))))))) evaluatePythonProjects proxy parser lang path = runTaskWithOptions debugOptions $ do project <- readProject Nothing path lang [] @@ -117,7 +117,7 @@ evaluatePythonProjects proxy parser lang path = runTaskWithOptions debugOptions (raiseHandler (runReader (packageInfo package)) (raiseHandler (runState (lowerBound @Span)) (raiseHandler (runReader (lowerBound @Span)) - (evaluate proxy id withTermSpans modules))))))) + (evaluate proxy id (evalTerm withTermSpans) modules))))))) evaluateProjectWithCaching proxy parser path = runTaskWithOptions debugOptions $ do @@ -130,7 +130,7 @@ evaluateProjectWithCaching proxy parser path = runTaskWithOptions debugOptions $ (raiseHandler (runReader (lowerBound @Span)) (runModuleTable (runModules (ModuleTable.modulePaths (packageModules package)) - (evaluate proxy id withTermSpans modules))))))) + (evaluate proxy id (evalTerm withTermSpans) modules))))))) parseFile :: Parser term -> FilePath -> IO term From 1414df368d6fc1f8e55ceca13acc5e51df28045b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 25 Oct 2018 21:31:38 -0400 Subject: [PATCH 13/51] Define a high-level Semantic.Analysis module. --- semantic.cabal | 1 + src/Semantic/Analysis.hs | 1 + 2 files changed, 2 insertions(+) create mode 100644 src/Semantic/Analysis.hs diff --git a/semantic.cabal b/semantic.cabal index 0d0d5dfef..595333684 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -186,6 +186,7 @@ library , Reprinting.Typeset , Reprinting.Pipeline -- High-level flow & operational functionality (logging, stats, etc.) + , Semantic.Analysis , Semantic.AST , Semantic.CLI , Semantic.Config diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs new file mode 100644 index 000000000..c1ea6e628 --- /dev/null +++ b/src/Semantic/Analysis.hs @@ -0,0 +1 @@ +module Semantic.Analysis where From ce407d1c9eceefecd20ff93f7afbfc654be206ef Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 25 Oct 2018 21:40:37 -0400 Subject: [PATCH 14/51] Move a bunch of the evaluation machinery to Semantic.Analysis. --- src/Data/Abstract/Evaluatable.hs | 153 ----------------------------- src/Semantic/Analysis.hs | 162 ++++++++++++++++++++++++++++++- src/Semantic/Graph.hs | 3 +- src/Semantic/REPL.hs | 1 + src/Semantic/Util.hs | 1 + 5 files changed, 165 insertions(+), 155 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index a262ea169..337b3461e 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -2,13 +2,6 @@ module Data.Abstract.Evaluatable ( module X , Evaluatable(..) -, ModuleC -, ValueC -, evaluate -, evalTerm -, runInModule -, runInTerm -, evaluateModules , traceResolve -- * Preludes , HasPrelude(..) @@ -30,18 +23,14 @@ import Control.Abstract.Evaluator as X hiding (LoopControl(..), Return(..), catc import Control.Abstract.Heap as X hiding (runAddressError, runAddressErrorWith) import Control.Abstract.Modules as X (Modules, ModuleResult, ResolutionError(..), load, lookupModule, listModulesInDir, require, resolve, throwResolutionError) import Control.Abstract.Value as X hiding (Boolean(..), Function(..), While(..)) -import Control.Effect.Eavesdrop -import Control.Effect.Interpose import Data.Abstract.Declarations as X import Data.Abstract.Environment as X import Data.Abstract.BaseError as X import Data.Abstract.FreeVariables as X import Data.Abstract.Module -import Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Name as X import Data.Abstract.Ref as X import Data.Language -import Data.Function import Data.Scientific (Scientific) import Data.Semigroup.App import Data.Semigroup.Foldable @@ -87,148 +76,6 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where rvalBox v -type ModuleC address value m - = ErrorC (LoopControl address) (Eff - ( ErrorC (Return address) (Eff - ( EnvC address (Eff - ( ScopeEnvC address (Eff - ( DerefC address value (Eff - ( AllocatorC address (Eff - ( ReaderC ModuleInfo (Eff - m))))))))))))) - -type ValueC term address value m - = FunctionC term address value (Eff - ( WhileC value (Eff - ( BooleanC value (Eff - ( EavesdropC (Modules address) (Eff - ( InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff - m))))))))) - -evaluate :: ( AbstractValue term address value valueC - , Carrier sig c - , allocatorC ~ AllocatorC address (Eff (ReaderC ModuleInfo (Eff c))) - , Carrier (Allocator address :+: Reader ModuleInfo :+: sig) allocatorC - , Carrier (Deref value :+: Allocator address :+: Reader ModuleInfo :+: sig) (DerefC address value (Eff allocatorC)) - , booleanC ~ BooleanC value (Eff (EavesdropC (Modules address) (Eff (InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff moduleC))))) - , Carrier (Boolean value :+: moduleSig) booleanC - , whileC ~ WhileC value (Eff booleanC) - , moduleSig ~ (Eavesdrop (Modules address) :+: Interpose (Resumable (BaseError (UnspecializedError value))) :+: Error (LoopControl address) :+: Error (Return address) :+: Env address :+: ScopeEnv address :+: Deref value :+: Allocator address :+: Reader ModuleInfo :+: sig) - , Carrier (While value :+: Boolean value :+: moduleSig) whileC - , Carrier (Function term address value :+: While value :+: Boolean value :+: moduleSig) valueC - , Effect sig - , HasPrelude lang - , Member Fresh sig - , Member (Modules address) sig - , Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) 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 - , moduleC ~ ModuleC address value c - , valueC ~ ValueC term address value moduleC - ) - => proxy lang - -> Open (Module term -> Evaluator term address value moduleC address) - -> (term -> Evaluator term address value valueC address) - -> [Module term] - -> Evaluator term address value c (ModuleTable (NonEmpty (Module (ModuleResult address)))) -evaluate lang analyzeModule evalTerm modules = do - (_, (preludeBinds, _)) <- runInModule lowerBound moduleInfoFromCallStack . runInTerm evalTerm $ do - definePrelude lang - box unit - evaluateModules (run preludeBinds <$> modules) - where run preludeBinds m = (<$ m) <$> runInModule preludeBinds (moduleInfo m) (analyzeModule (runInTerm evalTerm . evalTerm . moduleBody) m) - -evalTerm :: ( Carrier sig m - , Declarations term - , Evaluatable (Base term) - , FreeVariables term - , AbstractValue term address value m - , Member (Allocator address) sig - , Member (Boolean value) sig - , Member (Deref value) sig - , Member (Env address) sig - , Member (Error (LoopControl address)) sig - , Member (Error (Return address)) sig - , Member Fresh sig - , Member (Function term address value) sig - , Member (Modules address) sig - , Member (Reader ModuleInfo) sig - , Member (Reader PackageInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (AddressError address value))) sig - , Member (Resumable (BaseError (EnvironmentError address))) sig - , Member (Resumable (BaseError EvalError)) sig - , Member (Resumable (BaseError ResolutionError)) sig - , Member (Resumable (BaseError (UnspecializedError value))) sig - , Member (ScopeEnv address) sig - , Member (State (Heap address value)) sig - , Member (State Span) sig - , Member Trace sig - , Member (While value) sig - , Ord address - , Recursive term - ) - => Open (Open (term -> Evaluator term address value m (ValueRef address))) - -> term -> Evaluator term address value m address -evalTerm analyzeTerm = fix (analyzeTerm (\ ev -> eval ev . project)) >=> address - -runInModule :: ( Carrier sig m - , allocatorC ~ (AllocatorC address (Eff (ReaderC ModuleInfo (Eff m)))) - , allocatorSig ~ (Allocator address :+: Reader ModuleInfo :+: sig) - , Carrier allocatorSig allocatorC - , Carrier (Deref value :+: allocatorSig) (DerefC address value (Eff allocatorC)) - , Effect sig - , Member Fresh sig - , Ord address - ) - => Bindings address - -> ModuleInfo - -> Evaluator term address value (ModuleC address value m) address - -> Evaluator term address value m (ModuleResult address) -runInModule prelude info - = raiseHandler (runReader info) - . runAllocator - . runDeref - . runScopeEnv - . runEnv (EvalContext Nothing (X.push (newEnv prelude))) - . runReturn - . runLoopControl - -runInTerm :: ( Carrier sig m - , booleanC ~ BooleanC value (Eff (EavesdropC (Modules address) (Eff (InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff m))))) - , booleanSig ~ (Boolean value :+: Eavesdrop (Modules address) :+: 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 - , Member (Modules address) sig - , Member (Resumable (BaseError (UnspecializedError value))) sig - ) - => (term -> Evaluator term address value (ValueC term address value m) address) - -> Evaluator term address value (ValueC term address value m) a - -> Evaluator term address value m a -runInTerm evalTerm = raiseHandler runInterpose . raiseHandler runEavesdrop . runBoolean . runWhile . runFunction evalTerm - -evaluateModules :: ( Carrier sig m - , Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) sig - ) - => [Evaluator term address value m (Module (ModuleResult address))] - -> Evaluator term address value m (ModuleTable (NonEmpty (Module (ModuleResult address)))) -evaluateModules = foldr run ask - where run evaluator rest = do - evaluated <- evaluator - -- 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 evaluated)) (evaluated :| [])) rest - - traceResolve :: (Show a, Show b, Member Trace sig, Carrier sig m) => a -> b -> Evaluator term address value m () traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index c1ea6e628..39a9f5b44 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -1 +1,161 @@ -module Semantic.Analysis where +{-# LANGUAGE TypeFamilies, TypeOperators #-} +module Semantic.Analysis +( ModuleC +, ValueC +, evaluate +, evalTerm +, runInModule +, runInTerm +, evaluateModules +) where + +import Control.Abstract +import Control.Effect.Eavesdrop +import Control.Effect.Interpose +import Data.Abstract.Environment as Env +import Data.Abstract.Evaluatable +import Data.Abstract.Module +import Data.Abstract.ModuleTable as ModuleTable +import Data.Function +import Prologue + +type ModuleC address value m + = ErrorC (LoopControl address) (Eff + ( ErrorC (Return address) (Eff + ( EnvC address (Eff + ( ScopeEnvC address (Eff + ( DerefC address value (Eff + ( AllocatorC address (Eff + ( ReaderC ModuleInfo (Eff + m))))))))))))) + +type ValueC term address value m + = FunctionC term address value (Eff + ( WhileC value (Eff + ( BooleanC value (Eff + ( EavesdropC (Modules address) (Eff + ( InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff + m))))))))) + +evaluate :: ( AbstractValue term address value valueC + , Carrier sig c + , allocatorC ~ AllocatorC address (Eff (ReaderC ModuleInfo (Eff c))) + , Carrier (Allocator address :+: Reader ModuleInfo :+: sig) allocatorC + , Carrier (Deref value :+: Allocator address :+: Reader ModuleInfo :+: sig) (DerefC address value (Eff allocatorC)) + , booleanC ~ BooleanC value (Eff (EavesdropC (Modules address) (Eff (InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff moduleC))))) + , Carrier (Boolean value :+: moduleSig) booleanC + , whileC ~ WhileC value (Eff booleanC) + , moduleSig ~ (Eavesdrop (Modules address) :+: Interpose (Resumable (BaseError (UnspecializedError value))) :+: Error (LoopControl address) :+: Error (Return address) :+: Env address :+: ScopeEnv address :+: Deref value :+: Allocator address :+: Reader ModuleInfo :+: sig) + , Carrier (While value :+: Boolean value :+: moduleSig) whileC + , Carrier (Function term address value :+: While value :+: Boolean value :+: moduleSig) valueC + , Effect sig + , HasPrelude lang + , Member Fresh sig + , Member (Modules address) sig + , Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) 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 + , moduleC ~ ModuleC address value c + , valueC ~ ValueC term address value moduleC + ) + => proxy lang + -> Open (Module term -> Evaluator term address value moduleC address) + -> (term -> Evaluator term address value valueC address) + -> [Module term] + -> Evaluator term address value c (ModuleTable (NonEmpty (Module (ModuleResult address)))) +evaluate lang analyzeModule evalTerm modules = do + (_, (preludeBinds, _)) <- runInModule lowerBound moduleInfoFromCallStack . runInTerm evalTerm $ do + definePrelude lang + box unit + evaluateModules (run preludeBinds <$> modules) + where run preludeBinds m = (<$ m) <$> runInModule preludeBinds (moduleInfo m) (analyzeModule (runInTerm evalTerm . evalTerm . moduleBody) m) + +evalTerm :: ( Carrier sig m + , Declarations term + , Evaluatable (Base term) + , FreeVariables term + , AbstractValue term address value m + , Member (Allocator address) sig + , Member (Boolean value) sig + , Member (Deref value) sig + , Member (Env address) sig + , Member (Error (LoopControl address)) sig + , Member (Error (Return address)) sig + , Member Fresh sig + , Member (Function term address value) sig + , Member (Modules address) sig + , Member (Reader ModuleInfo) sig + , Member (Reader PackageInfo) sig + , Member (Reader Span) sig + , Member (Resumable (BaseError (AddressError address value))) sig + , Member (Resumable (BaseError (EnvironmentError address))) sig + , Member (Resumable (BaseError EvalError)) sig + , Member (Resumable (BaseError ResolutionError)) sig + , Member (Resumable (BaseError (UnspecializedError value))) sig + , Member (ScopeEnv address) sig + , Member (State (Heap address value)) sig + , Member (State Span) sig + , Member Trace sig + , Member (While value) sig + , Ord address + , Recursive term + ) + => Open (Open (term -> Evaluator term address value m (ValueRef address))) + -> term -> Evaluator term address value m address +evalTerm analyzeTerm = fix (analyzeTerm (\ ev -> eval ev . project)) >=> address + +runInModule :: ( Carrier sig m + , allocatorC ~ (AllocatorC address (Eff (ReaderC ModuleInfo (Eff m)))) + , allocatorSig ~ (Allocator address :+: Reader ModuleInfo :+: sig) + , Carrier allocatorSig allocatorC + , Carrier (Deref value :+: allocatorSig) (DerefC address value (Eff allocatorC)) + , Effect sig + , Member Fresh sig + , Ord address + ) + => Bindings address + -> ModuleInfo + -> Evaluator term address value (ModuleC address value m) address + -> Evaluator term address value m (ModuleResult address) +runInModule prelude info + = raiseHandler (runReader info) + . runAllocator + . runDeref + . runScopeEnv + . runEnv (EvalContext Nothing (Env.push (newEnv prelude))) + . runReturn + . runLoopControl + +runInTerm :: ( Carrier sig m + , booleanC ~ BooleanC value (Eff (EavesdropC (Modules address) (Eff (InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff m))))) + , booleanSig ~ (Boolean value :+: Eavesdrop (Modules address) :+: 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 + , Member (Modules address) sig + , Member (Resumable (BaseError (UnspecializedError value))) sig + ) + => (term -> Evaluator term address value (ValueC term address value m) address) + -> Evaluator term address value (ValueC term address value m) a + -> Evaluator term address value m a +runInTerm evalTerm = raiseHandler runInterpose . raiseHandler runEavesdrop . runBoolean . runWhile . runFunction evalTerm + +evaluateModules :: ( Carrier sig m + , Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) sig + ) + => [Evaluator term address value m (Module (ModuleResult address))] + -> Evaluator term address value m (ModuleTable (NonEmpty (Module (ModuleResult address)))) +evaluateModules = foldr run ask + where run evaluator rest = do + evaluated <- evaluator + -- 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 evaluated)) (evaluated :| [])) rest diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 9e07b7c63..f4c5206b1 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -37,7 +37,7 @@ import Data.Abstract.Address.Located as Located import Data.Abstract.Address.Monovariant as Monovariant import Data.Abstract.Address.Precise as Precise import Data.Abstract.BaseError (BaseError (..)) -import Data.Abstract.Evaluatable as Eval +import Data.Abstract.Evaluatable import Data.Abstract.Module import qualified Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Package as Package @@ -59,6 +59,7 @@ import Language.Haskell.HsColour import Language.Haskell.HsColour.Colourise import Parsing.Parser import Prologue hiding (TypeError (..)) +import Semantic.Analysis import Semantic.Task as Task import System.FilePath.Posix (takeDirectory, ()) import Text.Show.Pretty (ppShow) diff --git a/src/Semantic/REPL.hs b/src/Semantic/REPL.hs index 4d6e5257d..7e37521a0 100644 --- a/src/Semantic/REPL.hs +++ b/src/Semantic/REPL.hs @@ -30,6 +30,7 @@ import qualified Data.Time.LocalTime as LocalTime import Numeric (readDec) import Parsing.Parser (rubyParser) import Prologue +import Semantic.Analysis import Semantic.Config (logOptionsFromConfig) import Semantic.Distribute import Semantic.Graph diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 4522b7bb4..6c8f6881a 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -27,6 +27,7 @@ import Data.Quieterm (quieterm) import Data.Sum (weaken) import Parsing.Parser import Prologue +import Semantic.Analysis import Semantic.Config import Semantic.Graph import Semantic.Task From 52ed317fe65b8bc5208779b5c0fc19a18bc1eb84 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 25 Oct 2018 21:52:37 -0400 Subject: [PATCH 15/51] Treat the prelude as a sort of a module. --- src/Semantic/Analysis.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 39a9f5b44..06d02caef 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -64,16 +64,15 @@ evaluate :: ( AbstractValue term address value valueC , valueC ~ ValueC term address value moduleC ) => proxy lang - -> Open (Module term -> Evaluator term address value moduleC address) + -> Open (Module (Either (proxy lang) term) -> Evaluator term address value moduleC address) -> (term -> Evaluator term address value valueC address) -> [Module term] -> Evaluator term address value c (ModuleTable (NonEmpty (Module (ModuleResult address)))) evaluate lang analyzeModule evalTerm modules = do - (_, (preludeBinds, _)) <- runInModule lowerBound moduleInfoFromCallStack . runInTerm evalTerm $ do - definePrelude lang - box unit - evaluateModules (run preludeBinds <$> modules) - where run preludeBinds m = (<$ m) <$> runInModule preludeBinds (moduleInfo m) (analyzeModule (runInTerm evalTerm . evalTerm . moduleBody) m) + let prelude = Module moduleInfoFromCallStack (Left lang) + Module _ (_, (preludeBinds, _)) <- run lowerBound prelude + evaluateModules (run preludeBinds . fmap Right <$> modules) + where run preludeBinds m = (<$ m) <$> runInModule preludeBinds (moduleInfo m) (analyzeModule (runInTerm evalTerm . either ((*> box unit) . definePrelude) evalTerm . moduleBody) m) evalTerm :: ( Carrier sig m , Declarations term From 5c6801a272cdc6e40c6c033b4905db04c0f84fe4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 25 Oct 2018 22:23:47 -0400 Subject: [PATCH 16/51] Parameterize evaluate by a function running all the effects. --- .../Abstract/Caching/FlowInsensitive.hs | 9 +++-- src/Analysis/Abstract/Graph.hs | 8 ++-- src/Semantic/Analysis.hs | 39 +++++-------------- src/Semantic/Graph.hs | 24 ++++-------- src/Semantic/REPL.hs | 2 +- src/Semantic/Util.hs | 6 +-- 6 files changed, 30 insertions(+), 58 deletions(-) diff --git a/src/Analysis/Abstract/Caching/FlowInsensitive.hs b/src/Analysis/Abstract/Caching/FlowInsensitive.hs index 8c99c79f7..5a71c26e4 100644 --- a/src/Analysis/Abstract/Caching/FlowInsensitive.hs +++ b/src/Analysis/Abstract/Caching/FlowInsensitive.hs @@ -93,10 +93,11 @@ convergingModules :: ( AbstractValue term address value m , Carrier sig m , Effect sig ) - => (Module term -> Evaluator term address value (AltC Maybe (Eff m)) address) - -> (Module term -> Evaluator term address value m address) -convergingModules recur m = do - c <- getConfiguration (moduleBody m) + => (Module (Either prelude term) -> Evaluator term address value (AltC Maybe (Eff m)) address) + -> (Module (Either prelude term) -> Evaluator term address value m address) +convergingModules recur m@(Module _ (Left _)) = raiseHandler runNonDet (recur m) >>= maybeM empty +convergingModules recur m@(Module _ (Right term)) = do + c <- getConfiguration term heap <- getHeap -- Convergence here is predicated upon an Eq instance, not α-equivalence (cache, _) <- converge (lowerBound, heap) (\ (prevCache, _) -> isolateCache $ do diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index 22a2c595c..a6a48c8ae 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -124,8 +124,8 @@ graphingModules :: ( Member (Modules address) sig , Member (Reader ControlFlowVertex) sig , Carrier sig m ) - => (Module term -> Evaluator term address value (EavesdropC address (Eff m)) a) - -> (Module term -> Evaluator term address value m a) + => (Module body -> Evaluator term address value (EavesdropC address (Eff m)) a) + -> (Module body -> Evaluator term address value m a) graphingModules recur m = do let v = moduleVertex (moduleInfo m) appendGraph (vertex v) @@ -165,8 +165,8 @@ graphingModuleInfo :: ( Member (Modules address) sig , Member (State (Graph ModuleInfo)) sig , Carrier sig m ) - => (Module term -> Evaluator term address value (EavesdropC address (Eff m)) a) - -> (Module term -> Evaluator term address value m a) + => (Module body -> Evaluator term address value (EavesdropC address (Eff m)) a) + -> (Module body -> Evaluator term address value m a) graphingModuleInfo recur m = do appendGraph (vertex (moduleInfo m)) eavesdrop (recur m) $ \case diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 06d02caef..07209ceca 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -3,6 +3,7 @@ module Semantic.Analysis ( ModuleC , ValueC , evaluate +, evalModule , evalTerm , runInModule , runInTerm @@ -37,42 +38,20 @@ type ValueC term address value m ( InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff m))))))))) -evaluate :: ( AbstractValue term address value valueC - , Carrier sig c - , allocatorC ~ AllocatorC address (Eff (ReaderC ModuleInfo (Eff c))) - , Carrier (Allocator address :+: Reader ModuleInfo :+: sig) allocatorC - , Carrier (Deref value :+: Allocator address :+: Reader ModuleInfo :+: sig) (DerefC address value (Eff allocatorC)) - , booleanC ~ BooleanC value (Eff (EavesdropC (Modules address) (Eff (InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff moduleC))))) - , Carrier (Boolean value :+: moduleSig) booleanC - , whileC ~ WhileC value (Eff booleanC) - , moduleSig ~ (Eavesdrop (Modules address) :+: Interpose (Resumable (BaseError (UnspecializedError value))) :+: Error (LoopControl address) :+: Error (Return address) :+: Env address :+: ScopeEnv address :+: Deref value :+: Allocator address :+: Reader ModuleInfo :+: sig) - , Carrier (While value :+: Boolean value :+: moduleSig) whileC - , Carrier (Function term address value :+: While value :+: Boolean value :+: moduleSig) valueC - , Effect sig - , HasPrelude lang - , Member Fresh sig - , Member (Modules address) sig +evaluate :: ( Carrier sig m , Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) 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 - , moduleC ~ ModuleC address value c - , valueC ~ ValueC term address value moduleC ) - => proxy lang - -> Open (Module (Either (proxy lang) term) -> Evaluator term address value moduleC address) - -> (term -> Evaluator term address value valueC address) + => lang + -> (Bindings address -> Module (Either lang term) -> Evaluator term address value m (ModuleResult address)) -> [Module term] - -> Evaluator term address value c (ModuleTable (NonEmpty (Module (ModuleResult address)))) -evaluate lang analyzeModule evalTerm modules = do + -> Evaluator term address value m (ModuleTable (NonEmpty (Module (ModuleResult address)))) +evaluate lang evalModule modules = do let prelude = Module moduleInfoFromCallStack (Left lang) Module _ (_, (preludeBinds, _)) <- run lowerBound prelude evaluateModules (run preludeBinds . fmap Right <$> modules) - where run preludeBinds m = (<$ m) <$> runInModule preludeBinds (moduleInfo m) (analyzeModule (runInTerm evalTerm . either ((*> box unit) . definePrelude) evalTerm . moduleBody) m) + where run prelude m = (<$ m) <$> evalModule prelude m + +evalModule perModule perTerm prelude m = runInModule prelude (moduleInfo m) (perModule (runInTerm perTerm . either ((*> box unit) . definePrelude) perTerm . moduleBody) m) evalTerm :: ( Carrier sig m , Declarations term diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index f4c5206b1..a7bbda921 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -91,8 +91,7 @@ runCallGraph :: ( VertexDeclarationWithStrategy (VertexDeclarationStrategy synta , Functor syntax , Evaluatable syntax , term ~ Term syntax Location - , FreeVariables term - , Recursive term + , FreeVariables1 syntax , HasPrelude lang , Member Trace sig , Carrier sig m @@ -122,13 +121,10 @@ runCallGraph lang includePackages modules package . raiseHandler (runReader (lowerBound @ControlFlowVertex)) . providingLiveSet . runModuleTable - . runModules (ModuleTable.modulePaths (packageModules package)) $ do - -- (_, (prelude, _)) <- runInModule lowerBound moduleInfoFromCallStack . runInTerm (evalTerm perTerm) $ do - -- definePrelude lang - -- box unit - let run m = (<$ m) <$> runInModule lowerBound (moduleInfo m) (perModule (runInTerm (evalTerm perTerm) . evalTerm perTerm . moduleBody) m) - evaluateModules (map run modules) - where perTerm = withTermSpans . graphingTerms . cachingTerms + . runModules (ModuleTable.modulePaths (packageModules package)) + $ evaluate lang (evalModule perModule perTerm) modules + + where perTerm = evalTerm (withTermSpans . graphingTerms . cachingTerms) perModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules @@ -200,12 +196,8 @@ runImportGraph lang (package :: Package term) f . runModules (ModuleTable.modulePaths (packageModules package)) . raiseHandler (runReader (packageInfo package)) . raiseHandler (runState (lowerBound @Span)) - . raiseHandler (runReader (lowerBound @Span)) $ do - -- (_, (prelude, _)) <- runInModule lowerBound moduleInfoFromCallStack . runInTerm (evalTerm id) $ do - -- definePrelude lang - -- box unit - let run m = (<$ m) <$> runInModule lowerBound (moduleInfo m) (graphingModuleInfo (runInTerm (evalTerm id) . evalTerm id . moduleBody) m) - evaluateModules (map run (ModuleTable.toPairs (packageModules package) >>= toList . snd)) + . raiseHandler (runReader (lowerBound @Span)) + $ evaluate lang (evalModule 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) @@ -269,7 +261,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 (evalTerm id) [ setupModule ]) + fst <$> runAnalysis (evaluate (Proxy @'Language.Python) (evalModule id (evalTerm id)) [ setupModule ]) -- FIXME: what are we gonna do about runPythonPackaging Nothing -> pure PythonPackage.Unknown case strat of diff --git a/src/Semantic/REPL.hs b/src/Semantic/REPL.hs index 7e37521a0..0e73a8e5e 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 (evalTerm (withTermSpans . step (fmap (\ (x:|_) -> moduleBody x) <$> ModuleTable.toPairs (packageModules (fst <$> package))))) modules + $ evaluate proxy (evalModule 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 6c8f6881a..e96d0e063 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 (evalTerm withTermSpans) modules))))))) + (evaluate proxy (evalModule 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 (evalTerm withTermSpans) modules))))))) + (evaluate proxy (evalModule 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 (evalTerm withTermSpans) modules))))))) + (evaluate proxy (evalModule id (evalTerm withTermSpans)) modules))))))) parseFile :: Parser term -> FilePath -> IO term From bc08525229d4a4407e45b6b9401dc47c54365101 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 25 Oct 2018 22:50:16 -0400 Subject: [PATCH 17/51] =?UTF-8?q?Don=E2=80=99t=20specialize=20disjunction.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Control/Abstract/Value.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index ed1546d92..623c1de9c 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -125,8 +125,8 @@ ifthenelse :: (Member (Boolean value) sig, Carrier sig m, Monad m) => value -> m ifthenelse v t e = asBool v >>= \ c -> if c then t else e -- | Compute the disjunction (boolean or) of two computed values. This should have short-circuiting semantics where applicable. -disjunction :: (Member (Boolean value) sig, Carrier sig m) => m value -> m value -> m value -disjunction a b = send (Disjunction a b ret) +disjunction :: (Member (Boolean value) sig, Carrier sig m, Monad m) => m value -> m value -> m value +disjunction a b = a >>= \ a' -> ifthenelse a' (pure a') b data Boolean value m k = Boolean Bool (value -> k) From d4c6edb156bc1cbd099cfaa21e2c3dbbcb0d1893 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 25 Oct 2018 22:54:00 -0400 Subject: [PATCH 18/51] :fire: Disjunction. --- src/Control/Abstract/Value.hs | 15 +++++++++------ src/Data/Abstract/Value/Abstract.hs | 3 +-- src/Data/Abstract/Value/Concrete.hs | 9 --------- src/Data/Abstract/Value/Type.hs | 1 - 4 files changed, 10 insertions(+), 18 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 623c1de9c..070292fe9 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveAnyClass, GADTs, KindSignatures, Rank2Types, TypeOperators #-} +{-# LANGUAGE DeriveAnyClass, GADTs, KindSignatures, LambdaCase, Rank2Types, TypeOperators #-} module Control.Abstract.Value ( AbstractValue(..) , AbstractIntro(..) @@ -128,16 +128,19 @@ ifthenelse v t e = asBool v >>= \ c -> if c then t else e disjunction :: (Member (Boolean value) sig, Carrier sig m, Monad m) => m value -> m value -> m value disjunction a b = a >>= \ a' -> ifthenelse a' (pure a') b -data Boolean value m k +data Boolean value (m :: * -> *) k = Boolean Bool (value -> k) | AsBool value (Bool -> k) - | Disjunction (m value) (m value) (value -> k) deriving (Functor) instance HFunctor (Boolean value) where - hmap _ (Boolean b k) = Boolean b k - hmap _ (AsBool v k) = AsBool v k - hmap f (Disjunction a b k) = Disjunction (f a) (f b) k + hmap _ = coerce + {-# INLINE hmap #-} + +instance Effect (Boolean value) where + handle state handler = \case + Boolean b k -> Boolean b (handler . (<$ state) . k) + AsBool v k -> AsBool v (handler . (<$ state) . k) runBoolean :: Carrier (Boolean value :+: sig) (BooleanC value (Eff m)) => Evaluator term address value (BooleanC value (Eff m)) a diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index 8284a908d..074dad5fe 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -46,12 +46,11 @@ instance ( Member (Allocator address) sig box Abstract >>= Evaluator . flip runFunctionC eval . k -instance (Carrier sig m, Alternative m, Monad m) => Carrier (Boolean Abstract :+: sig) (BooleanC Abstract m) where +instance (Carrier sig m, Alternative m) => Carrier (Boolean Abstract :+: sig) (BooleanC Abstract m) where ret = BooleanC . ret eff = BooleanC . (alg \/ eff . handleCoercible) where alg (Boolean _ k) = runBooleanC (k Abstract) alg (AsBool _ k) = runBooleanC (k True) <|> runBooleanC (k False) - alg (Disjunction a b k) = (runBooleanC a <|> runBooleanC b) >>= runBooleanC . k instance ( Member (Abstract.Boolean Abstract) sig diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 43558458f..6c5ab79ad 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -114,15 +114,6 @@ instance ( Member (Reader ModuleInfo) sig Abstract.Boolean b k -> runBooleanC . k $! Boolean b Abstract.AsBool (Boolean b) k -> runBooleanC (k b) Abstract.AsBool other k -> throwBaseError (BoolError other) >>= runBooleanC . k - Abstract.Disjunction a b k -> do - a' <- runBooleanC a - a'' <- case a' of - Boolean b -> pure b - other -> throwBaseError (BoolError other) - if a'' then - runBooleanC (k a') - else - runBooleanC b >>= runBooleanC . k instance ( Carrier sig m diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index af36c3aa5..6222b7c61 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -288,7 +288,6 @@ instance ( Member (Reader ModuleInfo) sig eff = BooleanC . (alg \/ eff . handleCoercible) where alg (Abstract.Boolean _ k) = runBooleanC (k Bool) alg (Abstract.AsBool t k) = unify t Bool *> (runBooleanC (k True) <|> runBooleanC (k False)) - alg (Abstract.Disjunction t1 t2 k) = (runBooleanC t1 >>= unify Bool) <|> (runBooleanC t2 >>= unify Bool) >>= runBooleanC . k instance ( Member (Abstract.Boolean Type) sig From 3979ea4e86ceffbd23d7867592485250c6797edf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 25 Oct 2018 22:56:08 -0400 Subject: [PATCH 19/51] :fire: disjunction. --- src/Control/Abstract/Value.hs | 5 ----- src/Data/Syntax/Expression.hs | 4 +++- 2 files changed, 3 insertions(+), 6 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 070292fe9..61389ca80 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -15,7 +15,6 @@ module Control.Abstract.Value , boolean , asBool , ifthenelse -, disjunction , Boolean(..) , runBoolean , BooleanC(..) @@ -124,10 +123,6 @@ asBool = send . flip AsBool ret ifthenelse :: (Member (Boolean value) sig, Carrier sig m, Monad m) => value -> m a -> m a -> m a ifthenelse v t e = asBool v >>= \ c -> if c then t else e --- | Compute the disjunction (boolean or) of two computed values. This should have short-circuiting semantics where applicable. -disjunction :: (Member (Boolean value) sig, Carrier sig m, Monad m) => m value -> m value -> m value -disjunction a b = a >>= \ a' -> ifthenelse a' (pure a') b - data Boolean value (m :: * -> *) k = Boolean Bool (value -> k) | AsBool value (Bool -> k) diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index 7f80bca79..ff10c4685 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -249,7 +249,9 @@ instance Ord1 Or where liftCompare = genericLiftCompare instance Show1 Or where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Or where - eval eval (Or a b) = disjunction (eval a >>= Abstract.value) (eval b >>= Abstract.value) >>= rvalBox + eval eval (Or a b) = do + a' <- eval a >>= Abstract.value + ifthenelse a' (rvalBox a') (eval b) data And a = And { lhs :: a, rhs :: a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) From 2a600ee28a56495b26c3f9894a111c62a841146c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 25 Oct 2018 23:10:37 -0400 Subject: [PATCH 20/51] Give a type signature for evalModule. --- src/Semantic/Analysis.hs | 41 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 41 insertions(+) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 07209ceca..dfcdb8ad9 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -51,6 +51,47 @@ evaluate lang evalModule modules = do evaluateModules (run preludeBinds . fmap Right <$> modules) where run prelude m = (<$ m) <$> evalModule prelude m +evalModule :: ( AbstractValue term address value (ValueC term address value inner) + , Carrier sig m + , Carrier innerSig inner + , functionSig ~ (Function term address value :+: whileSig) + , functionC ~ FunctionC term address value (Eff whileC) + , Carrier functionSig functionC + , whileSig ~ (While value :+: booleanSig) + , whileC ~ WhileC value (Eff booleanC) + , Carrier whileSig whileC + , booleanSig ~ (Boolean value :+: Eavesdrop (Modules address) :+: Interpose (Resumable (BaseError (UnspecializedError value))) :+: innerSig) + , booleanC ~ BooleanC value (Eff (EavesdropC (Modules address) (Eff (InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff inner))))) + , Carrier booleanSig booleanC + , derefSig ~ (Deref value :+: allocatorSig) + , derefC ~ (DerefC address value (Eff allocatorC)) + , Carrier derefSig derefC + , allocatorSig ~ (Allocator address :+: Reader ModuleInfo :+: sig) + , allocatorC ~ (AllocatorC address (Eff (ReaderC ModuleInfo (Eff m)))) + , Carrier allocatorSig allocatorC + , Effect sig + , HasPrelude language + , Member Fresh sig + , Member (Allocator address) innerSig + , Member (Deref value) innerSig + , Member (Modules address) innerSig + , Member (Env address) innerSig + , Member Fresh innerSig + , Member (Reader ModuleInfo) innerSig + , Member (Reader Span) innerSig + , Member (Resumable (BaseError (AddressError address value))) innerSig + , Member (Resumable (BaseError (UnspecializedError value))) innerSig + , Member (Resumable (BaseError (EnvironmentError address))) innerSig + , Member (State (Heap address value)) innerSig + , Member Trace innerSig + , Ord address + ) + => ( (Module (Either (proxy language) term) -> Evaluator term address value inner address) + -> (Module body -> Evaluator term address value (ModuleC address value m) address)) + -> (term -> Evaluator term address value (ValueC term address value inner) address) + -> Bindings address + -> Module body + -> Evaluator term address value m (ModuleResult address) evalModule perModule perTerm prelude m = runInModule prelude (moduleInfo m) (perModule (runInTerm perTerm . either ((*> box unit) . definePrelude) perTerm . moduleBody) m) evalTerm :: ( Carrier sig m From 915c7f5c61ba571da214c989f018984432391fcb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 25 Oct 2018 23:13:47 -0400 Subject: [PATCH 21/51] :fire: the Eavesdrop effect. --- src/Semantic/Analysis.hs | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index dfcdb8ad9..15ae2f8f3 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -11,7 +11,6 @@ module Semantic.Analysis ) where import Control.Abstract -import Control.Effect.Eavesdrop import Control.Effect.Interpose import Data.Abstract.Environment as Env import Data.Abstract.Evaluatable @@ -34,9 +33,8 @@ type ValueC term address value m = FunctionC term address value (Eff ( WhileC value (Eff ( BooleanC value (Eff - ( EavesdropC (Modules address) (Eff ( InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff - m))))))))) + m))))))) evaluate :: ( Carrier sig m , Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) sig @@ -60,8 +58,8 @@ evalModule :: ( AbstractValue term address value (ValueC term address value inne , whileSig ~ (While value :+: booleanSig) , whileC ~ WhileC value (Eff booleanC) , Carrier whileSig whileC - , booleanSig ~ (Boolean value :+: Eavesdrop (Modules address) :+: Interpose (Resumable (BaseError (UnspecializedError value))) :+: innerSig) - , booleanC ~ BooleanC value (Eff (EavesdropC (Modules address) (Eff (InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff inner))))) + , booleanSig ~ (Boolean value :+: Interpose (Resumable (BaseError (UnspecializedError value))) :+: innerSig) + , booleanC ~ BooleanC value (Eff (InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff inner))) , Carrier booleanSig booleanC , derefSig ~ (Deref value :+: allocatorSig) , derefC ~ (DerefC address value (Eff allocatorC)) @@ -74,7 +72,6 @@ evalModule :: ( AbstractValue term address value (ValueC term address value inne , Member Fresh sig , Member (Allocator address) innerSig , Member (Deref value) innerSig - , Member (Modules address) innerSig , Member (Env address) innerSig , Member Fresh innerSig , Member (Reader ModuleInfo) innerSig @@ -151,8 +148,8 @@ runInModule prelude info . runLoopControl runInTerm :: ( Carrier sig m - , booleanC ~ BooleanC value (Eff (EavesdropC (Modules address) (Eff (InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff m))))) - , booleanSig ~ (Boolean value :+: Eavesdrop (Modules address) :+: Interpose (Resumable (BaseError (UnspecializedError value))) :+: sig) + , 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) @@ -160,13 +157,12 @@ runInTerm :: ( Carrier sig m , functionC ~ FunctionC term address value (Eff whileC) , functionSig ~ (Function term address value :+: whileSig) , Carrier functionSig functionC - , Member (Modules address) sig , Member (Resumable (BaseError (UnspecializedError value))) sig ) => (term -> Evaluator term address value (ValueC term address value m) address) -> Evaluator term address value (ValueC term address value m) a -> Evaluator term address value m a -runInTerm evalTerm = raiseHandler runInterpose . raiseHandler runEavesdrop . runBoolean . runWhile . runFunction evalTerm +runInTerm evalTerm = raiseHandler runInterpose . runBoolean . runWhile . runFunction evalTerm evaluateModules :: ( Carrier sig m , Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) sig From 2b9d751aadbce5a6f8a8128c8aec9701662d80ae Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 26 Oct 2018 10:17:19 -0400 Subject: [PATCH 22/51] Factor the prelude definition into runInTerm. --- src/Semantic/Analysis.hs | 23 ++++++++++++++++++----- 1 file changed, 18 insertions(+), 5 deletions(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 15ae2f8f3..35b909639 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -89,7 +89,7 @@ evalModule :: ( AbstractValue term address value (ValueC term address value inne -> Bindings address -> Module body -> Evaluator term address value m (ModuleResult address) -evalModule perModule perTerm prelude m = runInModule prelude (moduleInfo m) (perModule (runInTerm perTerm . either ((*> box unit) . definePrelude) perTerm . moduleBody) m) +evalModule perModule perTerm prelude m = runInModule prelude (moduleInfo m) (perModule (runInTerm perTerm . moduleBody) m) evalTerm :: ( Carrier sig m , Declarations term @@ -147,7 +147,8 @@ runInModule prelude info . runReturn . runLoopControl -runInTerm :: ( Carrier sig m +runInTerm :: ( 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 @@ -157,12 +158,24 @@ runInTerm :: ( Carrier sig m , 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) - -> Evaluator term address value (ValueC term address value m) a - -> Evaluator term address value m a -runInTerm evalTerm = raiseHandler runInterpose . runBoolean . runWhile . runFunction evalTerm + -> Either (proxy lang) term + -> Evaluator term address value m address +runInTerm evalTerm = raiseHandler runInterpose . runBoolean . runWhile . runFunction evalTerm . either ((*> box unit) . definePrelude) evalTerm evaluateModules :: ( Carrier sig m , Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) sig From bfb3b8a352a9a8297218b9f6c62b24b1b5d8475c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 26 Oct 2018 10:18:25 -0400 Subject: [PATCH 23/51] Rename the type parameters relating to the outer context. --- src/Semantic/Analysis.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 35b909639..da96949b2 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -50,7 +50,7 @@ evaluate lang evalModule modules = do where run prelude m = (<$ m) <$> evalModule prelude m evalModule :: ( AbstractValue term address value (ValueC term address value inner) - , Carrier sig m + , Carrier outerSig outer , Carrier innerSig inner , functionSig ~ (Function term address value :+: whileSig) , functionC ~ FunctionC term address value (Eff whileC) @@ -64,12 +64,12 @@ evalModule :: ( AbstractValue term address value (ValueC term address value inne , derefSig ~ (Deref value :+: allocatorSig) , derefC ~ (DerefC address value (Eff allocatorC)) , Carrier derefSig derefC - , allocatorSig ~ (Allocator address :+: Reader ModuleInfo :+: sig) - , allocatorC ~ (AllocatorC address (Eff (ReaderC ModuleInfo (Eff m)))) + , allocatorSig ~ (Allocator address :+: Reader ModuleInfo :+: outerSig) + , allocatorC ~ (AllocatorC address (Eff (ReaderC ModuleInfo (Eff outer)))) , Carrier allocatorSig allocatorC - , Effect sig + , Effect outerSig , HasPrelude language - , Member Fresh sig + , Member Fresh outerSig , Member (Allocator address) innerSig , Member (Deref value) innerSig , Member (Env address) innerSig @@ -84,11 +84,11 @@ evalModule :: ( AbstractValue term address value (ValueC term address value inne , Ord address ) => ( (Module (Either (proxy language) term) -> Evaluator term address value inner address) - -> (Module body -> Evaluator term address value (ModuleC address value m) address)) + -> (Module body -> Evaluator term address value (ModuleC address value outer) address)) -> (term -> Evaluator term address value (ValueC term address value inner) address) -> Bindings address -> Module body - -> Evaluator term address value m (ModuleResult address) + -> Evaluator term address value outer (ModuleResult address) evalModule perModule perTerm prelude m = runInModule prelude (moduleInfo m) (perModule (runInTerm perTerm . moduleBody) m) evalTerm :: ( Carrier sig m From cc09615b7b764b4d57a648365b793bc30fa6c28b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 26 Oct 2018 10:27:05 -0400 Subject: [PATCH 24/51] Inline the definition of evaluateModules into evaluate. --- src/Semantic/Analysis.hs | 21 ++++++--------------- 1 file changed, 6 insertions(+), 15 deletions(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index da96949b2..2c7dca920 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -7,7 +7,6 @@ module Semantic.Analysis , evalTerm , runInModule , runInTerm -, evaluateModules ) where import Control.Abstract @@ -45,9 +44,12 @@ evaluate :: ( Carrier sig m -> Evaluator term address value m (ModuleTable (NonEmpty (Module (ModuleResult address)))) evaluate lang evalModule modules = do let prelude = Module moduleInfoFromCallStack (Left lang) - Module _ (_, (preludeBinds, _)) <- run lowerBound prelude - evaluateModules (run preludeBinds . fmap Right <$> modules) - where run prelude m = (<$ m) <$> evalModule prelude m + (_, (preludeBinds, _)) <- evalModule lowerBound prelude + foldr (run preludeBinds . fmap Right) ask modules + where run prelude m rest = do + evaluated <- evalModule prelude m + -- 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 :: ( AbstractValue term address value (ValueC term address value inner) , Carrier outerSig outer @@ -176,14 +178,3 @@ runInTerm :: ( AbstractValue term address value (ValueC term address value m) -> Either (proxy lang) term -> Evaluator term address value m address runInTerm evalTerm = raiseHandler runInterpose . runBoolean . runWhile . runFunction evalTerm . either ((*> box unit) . definePrelude) evalTerm - -evaluateModules :: ( Carrier sig m - , Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) sig - ) - => [Evaluator term address value m (Module (ModuleResult address))] - -> Evaluator term address value m (ModuleTable (NonEmpty (Module (ModuleResult address)))) -evaluateModules = foldr run ask - where run evaluator rest = do - evaluated <- evaluator - -- 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 evaluated)) (evaluated :| [])) rest From 6cf82efb50b72ff8f1cab54a2584f9cefb52e0cb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 26 Oct 2018 11:39:47 -0400 Subject: [PATCH 25/51] Factor runInTerm out of evalModule. --- src/Semantic/Analysis.hs | 33 +++++---------------------------- src/Semantic/Graph.hs | 7 +++---- src/Semantic/REPL.hs | 2 +- src/Semantic/Util.hs | 6 +++--- 4 files changed, 12 insertions(+), 36 deletions(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 2c7dca920..fd58dbdf9 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -51,18 +51,7 @@ evaluate lang evalModule 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 :: ( AbstractValue term address value (ValueC term address value inner) - , Carrier outerSig outer - , Carrier innerSig inner - , functionSig ~ (Function term address value :+: whileSig) - , functionC ~ FunctionC term address value (Eff whileC) - , Carrier functionSig functionC - , whileSig ~ (While value :+: booleanSig) - , whileC ~ WhileC value (Eff booleanC) - , Carrier whileSig whileC - , booleanSig ~ (Boolean value :+: Interpose (Resumable (BaseError (UnspecializedError value))) :+: innerSig) - , booleanC ~ BooleanC value (Eff (InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff inner))) - , Carrier booleanSig booleanC +evalModule :: ( Carrier outerSig outer , derefSig ~ (Deref value :+: allocatorSig) , derefC ~ (DerefC address value (Eff allocatorC)) , Carrier derefSig derefC @@ -70,28 +59,16 @@ evalModule :: ( AbstractValue term address value (ValueC term address value inne , allocatorC ~ (AllocatorC address (Eff (ReaderC ModuleInfo (Eff outer)))) , Carrier allocatorSig allocatorC , Effect outerSig - , HasPrelude language , Member Fresh outerSig - , Member (Allocator address) innerSig - , Member (Deref value) innerSig - , Member (Env address) innerSig - , Member Fresh innerSig - , Member (Reader ModuleInfo) innerSig - , Member (Reader Span) innerSig - , Member (Resumable (BaseError (AddressError address value))) innerSig - , Member (Resumable (BaseError (UnspecializedError value))) innerSig - , Member (Resumable (BaseError (EnvironmentError address))) innerSig - , Member (State (Heap address value)) innerSig - , Member Trace innerSig , Ord address ) - => ( (Module (Either (proxy language) term) -> Evaluator term address value inner address) - -> (Module body -> Evaluator term address value (ModuleC address value outer) address)) - -> (term -> Evaluator term address value (ValueC term address value inner) address) + => ( (Module body -> Evaluator term address value inner address) + -> (Module body -> Evaluator term address value (ModuleC address value outer) address)) + -> (body -> Evaluator term address value inner address) -> Bindings address -> Module body -> Evaluator term address value outer (ModuleResult address) -evalModule perModule perTerm prelude m = runInModule prelude (moduleInfo m) (perModule (runInTerm perTerm . moduleBody) m) +evalModule perModule runTerm prelude m = runInModule prelude (moduleInfo m) (perModule (runTerm . moduleBody) m) evalTerm :: ( Carrier sig m , Declarations term diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index a7bbda921..042f02498 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -122,8 +122,7 @@ runCallGraph lang includePackages modules package . providingLiveSet . runModuleTable . runModules (ModuleTable.modulePaths (packageModules package)) - $ evaluate lang (evalModule perModule perTerm) modules - + $ evaluate lang (evalModule perModule (runInTerm perTerm)) modules where perTerm = evalTerm (withTermSpans . graphingTerms . cachingTerms) perModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules @@ -197,7 +196,7 @@ runImportGraph lang (package :: Package term) f . raiseHandler (runReader (packageInfo package)) . raiseHandler (runState (lowerBound @Span)) . raiseHandler (runReader (lowerBound @Span)) - $ evaluate lang (evalModule graphingModuleInfo (evalTerm id)) (ModuleTable.toPairs (packageModules package) >>= toList . snd) + $ evaluate lang (evalModule graphingModuleInfo (runInTerm (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) @@ -261,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) (evalModule id (evalTerm id)) [ setupModule ]) + fst <$> runAnalysis (evaluate (Proxy @'Language.Python) (evalModule id (runInTerm (evalTerm id))) [ setupModule ]) -- FIXME: what are we gonna do about runPythonPackaging Nothing -> pure PythonPackage.Unknown case strat of diff --git a/src/Semantic/REPL.hs b/src/Semantic/REPL.hs index 0e73a8e5e..000bae201 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 (evalModule id (evalTerm (withTermSpans . step (fmap (\ (x:|_) -> moduleBody x) <$> ModuleTable.toPairs (packageModules (fst <$> package)))))) modules + $ evaluate proxy (evalModule id (runInTerm (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 e96d0e063..1e6b12e2b 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 (evalModule id (evalTerm withTermSpans)) modules))))))) + (evaluate proxy (evalModule id (runInTerm (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 (evalModule id (evalTerm withTermSpans)) modules))))))) + (evaluate proxy (evalModule id (runInTerm (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 (evalModule id (evalTerm withTermSpans)) modules))))))) + (evaluate proxy (evalModule id (runInTerm (evalTerm withTermSpans))) modules))))))) parseFile :: Parser term -> FilePath -> IO term From 24660fca31158cfff922778e8a3ccfd1efd62ebb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 26 Oct 2018 12:24:37 -0400 Subject: [PATCH 26/51] Rename runInTerm to runValueEffects. --- src/Semantic/Analysis.hs | 60 ++++++++++++++++++++-------------------- src/Semantic/Graph.hs | 6 ++-- src/Semantic/REPL.hs | 2 +- src/Semantic/Util.hs | 6 ++-- 4 files changed, 37 insertions(+), 37 deletions(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index fd58dbdf9..fb40d31d4 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -6,7 +6,7 @@ module Semantic.Analysis , evalModule , evalTerm , runInModule -, runInTerm +, runValueEffects ) where import Control.Abstract @@ -126,32 +126,32 @@ runInModule prelude info . runReturn . runLoopControl -runInTerm :: ( 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 -runInTerm evalTerm = raiseHandler runInterpose . runBoolean . runWhile . runFunction evalTerm . either ((*> box unit) . definePrelude) evalTerm +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 042f02498..4dd5c4dcf 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 (evalModule perModule (runInTerm perTerm)) modules + $ evaluate lang (evalModule perModule (runValueEffects 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 (evalModule graphingModuleInfo (runInTerm (evalTerm id))) (ModuleTable.toPairs (packageModules package) >>= toList . snd) + $ evaluate lang (evalModule graphingModuleInfo (runValueEffects (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) (evalModule id (runInTerm (evalTerm id))) [ setupModule ]) + fst <$> runAnalysis (evaluate (Proxy @'Language.Python) (evalModule id (runValueEffects (evalTerm id))) [ setupModule ]) -- FIXME: what are we gonna do about runPythonPackaging Nothing -> pure PythonPackage.Unknown case strat of diff --git a/src/Semantic/REPL.hs b/src/Semantic/REPL.hs index 000bae201..dbc0acdd1 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 (evalModule id (runInTerm (evalTerm (withTermSpans . step (fmap (\ (x:|_) -> moduleBody x) <$> ModuleTable.toPairs (packageModules (fst <$> package))))))) modules + $ evaluate proxy (evalModule id (runValueEffects (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 1e6b12e2b..1768d99df 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 (evalModule id (runInTerm (evalTerm withTermSpans))) modules))))))) + (evaluate proxy (evalModule id (runValueEffects (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 (evalModule id (runInTerm (evalTerm withTermSpans))) modules))))))) + (evaluate proxy (evalModule id (runValueEffects (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 (evalModule id (runInTerm (evalTerm withTermSpans))) modules))))))) + (evaluate proxy (evalModule id (runValueEffects (evalTerm withTermSpans))) modules))))))) parseFile :: Parser term -> FilePath -> IO term From 37d4fea7b26feff735297c40697d06ea8a3d6ee5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 26 Oct 2018 12:30:06 -0400 Subject: [PATCH 27/51] Simplify the carrier for runPythonPackaging. --- src/Control/Abstract/PythonPackage.hs | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/src/Control/Abstract/PythonPackage.hs b/src/Control/Abstract/PythonPackage.hs index ffcbf99e9..83df99c08 100644 --- a/src/Control/Abstract/PythonPackage.hs +++ b/src/Control/Abstract/PythonPackage.hs @@ -38,11 +38,10 @@ runPythonPackaging :: ( Carrier sig m , Member (Reader Span) sig , Member (Function term address (Value term address)) sig ) - => Evaluator term address (Value term address) (InterposeC (Function term address (Value term address)) - (Evaluator term address (Value term address) m)) a + => Evaluator term address (Value term address) (InterposeC (Function term address (Value term address)) (Eff m)) a -> Evaluator term address (Value term address) m a -runPythonPackaging = interpose (\case - Call callName super params k -> k =<< do +runPythonPackaging = raiseHandler $ interpose (runEvaluator . \case + Call callName super params k -> Evaluator . k =<< do case callName of Closure _ _ name' paramNames _ _ -> do let bindings = foldr (uncurry Map.insert) lowerBound (zip paramNames params) @@ -63,9 +62,8 @@ runPythonPackaging = interpose (\case _ -> pure () _ -> pure () call callName super params - Function name params body k -> function name params body >>= k - BuiltIn b k -> builtIn b >>= k) - . runEvaluator + Function name params body k -> function name params body >>= Evaluator . k + BuiltIn b k -> builtIn b >>= Evaluator . k) interpose :: (Member eff sig, HFunctor eff, Carrier sig m) => (forall v. eff m (m v) -> m v) From 197ef613864755cccbe0718ea43a580b757502dd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 26 Oct 2018 12:30:49 -0400 Subject: [PATCH 28/51] Rename the carrier to PythonPackagingC. --- src/Control/Abstract/PythonPackage.hs | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/Control/Abstract/PythonPackage.hs b/src/Control/Abstract/PythonPackage.hs index 83df99c08..144416036 100644 --- a/src/Control/Abstract/PythonPackage.hs +++ b/src/Control/Abstract/PythonPackage.hs @@ -7,7 +7,7 @@ import Control.Abstract.Heap (Allocator, Deref, deref) import Control.Abstract.Value import Control.Effect.Carrier import Control.Effect.Sum -import Data.Abstract.Evaluatable hiding (InterposeC) +import Data.Abstract.Evaluatable import Data.Abstract.Name (name) import Data.Abstract.Path (stripQuotes) import Data.Abstract.Value.Concrete (Value (..), ValueError (..)) @@ -38,7 +38,7 @@ runPythonPackaging :: ( Carrier sig m , Member (Reader Span) sig , Member (Function term address (Value term address)) sig ) - => Evaluator term address (Value term address) (InterposeC (Function term address (Value term address)) (Eff m)) a + => Evaluator term address (Value term address) (PythonPackagingC (Function term address (Value term address)) (Eff m)) a -> Evaluator term address (Value term address) m a runPythonPackaging = raiseHandler $ interpose (runEvaluator . \case Call callName super params k -> Evaluator . k =<< do @@ -67,17 +67,17 @@ runPythonPackaging = raiseHandler $ interpose (runEvaluator . \case interpose :: (Member eff sig, HFunctor eff, Carrier sig m) => (forall v. eff m (m v) -> m v) - -> Eff (InterposeC eff m) a + -> Eff (PythonPackagingC eff m) a -> m a -interpose handler = runInterposeC handler . interpret +interpose handler = runPythonPackagingC handler . interpret -newtype InterposeC eff m a = InterposeC ((forall x . eff m (m x) -> m x) -> m a) +newtype PythonPackagingC eff m a = PythonPackagingC ((forall x . eff m (m x) -> m x) -> m a) -runInterposeC :: (forall x . eff m (m x) -> m x) -> InterposeC eff m a -> m a -runInterposeC f (InterposeC m) = m f +runPythonPackagingC :: (forall x . eff m (m x) -> m x) -> PythonPackagingC eff m a -> m a +runPythonPackagingC f (PythonPackagingC m) = m f -instance (Member eff sig, HFunctor eff, Carrier sig m) => Carrier sig (InterposeC eff m) where - ret a = InterposeC (const (ret a)) +instance (Member eff sig, HFunctor eff, Carrier sig m) => Carrier sig (PythonPackagingC eff m) where + ret a = PythonPackagingC (const (ret a)) eff op - | Just e <- prj op = InterposeC (\ handler -> handler (handlePure (runInterposeC handler) e)) - | otherwise = InterposeC (\ handler -> eff (handlePure (runInterposeC handler) op)) + | Just e <- prj op = PythonPackagingC (\ handler -> handler (handlePure (runPythonPackagingC handler) e)) + | otherwise = PythonPackagingC (\ handler -> eff (handlePure (runPythonPackagingC handler) op)) From 4aae4db57d4a1b860fb8255ce4902a46ec95628b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 26 Oct 2018 12:37:26 -0400 Subject: [PATCH 29/51] Implement python packaging directly in the carrier. --- src/Control/Abstract/PythonPackage.hs | 91 ++++++++++++++++----------- 1 file changed, 53 insertions(+), 38 deletions(-) diff --git a/src/Control/Abstract/PythonPackage.hs b/src/Control/Abstract/PythonPackage.hs index 144416036..218803a80 100644 --- a/src/Control/Abstract/PythonPackage.hs +++ b/src/Control/Abstract/PythonPackage.hs @@ -38,46 +38,61 @@ runPythonPackaging :: ( Carrier sig m , Member (Reader Span) sig , Member (Function term address (Value term address)) sig ) - => Evaluator term address (Value term address) (PythonPackagingC (Function term address (Value term address)) (Eff m)) a + => Evaluator term address (Value term address) (PythonPackagingC term address (Eff m)) a -> Evaluator term address (Value term address) m a -runPythonPackaging = raiseHandler $ interpose (runEvaluator . \case - Call callName super params k -> Evaluator . k =<< do - case callName of - Closure _ _ name' paramNames _ _ -> do - let bindings = foldr (uncurry Map.insert) lowerBound (zip paramNames params) - let asStrings = deref >=> asArray >=> traverse (deref >=> asString) +runPythonPackaging = raiseHandler (runPythonPackagingC . interpret) - case name' of - Just n - | name "find_packages" == n -> do - as <- maybe (pure mempty) (fmap (fmap stripQuotes) . asStrings) (Map.lookup (name "exclude") bindings) - put (FindPackages as) - | name "setup" == n -> do - packageState <- get - if packageState == Unknown then do - as <- maybe (pure mempty) (fmap (fmap stripQuotes) . asStrings) (Map.lookup (name "packages") bindings) - put (Packages as) - else - pure () - _ -> pure () - _ -> pure () - call callName super params - Function name params body k -> function name params body >>= Evaluator . k - BuiltIn b k -> builtIn b >>= Evaluator . k) +newtype PythonPackagingC term address m a = PythonPackagingC { runPythonPackagingC :: m a } -interpose :: (Member eff sig, HFunctor eff, Carrier sig m) - => (forall v. eff m (m v) -> m v) - -> Eff (PythonPackagingC eff m) a - -> m a -interpose handler = runPythonPackagingC handler . interpret +wrap :: Evaluator term address (Value term address) m a -> PythonPackagingC term address (Eff m) a +wrap = PythonPackagingC . runEvaluator -newtype PythonPackagingC eff m a = PythonPackagingC ((forall x . eff m (m x) -> m x) -> m a) - -runPythonPackagingC :: (forall x . eff m (m x) -> m x) -> PythonPackagingC eff m a -> m a -runPythonPackagingC f (PythonPackagingC m) = m f - -instance (Member eff sig, HFunctor eff, Carrier sig m) => Carrier sig (PythonPackagingC eff m) where - ret a = PythonPackagingC (const (ret a)) +instance ( Carrier sig m + , Member (Allocator address) sig + , Member (Boolean (Value term address)) sig + , Member (Deref (Value term address)) sig + , Member (Env address) sig + , Member (Error (LoopControl address)) sig + , Member (Error (Return address)) sig + , Member Fresh sig + , Member (Function term address (Value term address)) sig + , Member (Reader ModuleInfo) sig + , Member (Reader PackageInfo) sig + , Member (Reader Span) sig + , Member (Resumable (BaseError (AddressError address (Value term address)))) sig + , Member (Resumable (BaseError (ValueError term address))) sig + , Member (State (Heap address (Value term address))) sig + , Member (State Strategy) sig + , Member Trace sig + , Ord address + , Show address + , Show term + ) + => Carrier sig (PythonPackagingC term address (Eff m)) where + ret = PythonPackagingC . ret eff op - | Just e <- prj op = PythonPackagingC (\ handler -> handler (handlePure (runPythonPackagingC handler) e)) - | otherwise = PythonPackagingC (\ handler -> eff (handlePure (runPythonPackagingC handler) op)) + | Just e <- prj op = wrap $ case handleCoercible e of + Call callName super params k -> Evaluator . k =<< do + case callName of + Closure _ _ name' paramNames _ _ -> do + let bindings = foldr (uncurry Map.insert) lowerBound (zip paramNames params) + let asStrings = deref >=> asArray >=> traverse (deref >=> asString) + + case name' of + Just n + | name "find_packages" == n -> do + as <- maybe (pure mempty) (fmap (fmap stripQuotes) . asStrings) (Map.lookup (name "exclude") bindings) + put (FindPackages as) + | name "setup" == n -> do + packageState <- get + if packageState == Unknown then do + as <- maybe (pure mempty) (fmap (fmap stripQuotes) . asStrings) (Map.lookup (name "packages") bindings) + put (Packages as) + else + pure () + _ -> pure () + _ -> pure () + call callName super params + Function name params body k -> function name params body >>= Evaluator . k + BuiltIn b k -> builtIn b >>= Evaluator . k + | otherwise = PythonPackagingC (eff (handleCoercible op)) From cb19a79fad5127890d038a39c181f540b4e89ae5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 26 Oct 2018 12:40:26 -0400 Subject: [PATCH 30/51] Run python packaging. --- src/Semantic/Graph.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 4dd5c4dcf..533ce9898 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -260,8 +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) (evalModule id (runValueEffects (evalTerm id))) [ setupModule ]) - -- FIXME: what are we gonna do about runPythonPackaging + fst <$> runAnalysis (evaluate (Proxy @'Language.Python) (evalModule id (runValueEffects (runPythonPackaging . evalTerm id))) [ setupModule ]) Nothing -> pure PythonPackage.Unknown case strat of PythonPackage.Unknown -> do From 485cbfdcfe5d785844890415f85581b66ed9acc6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 26 Oct 2018 12:47:23 -0400 Subject: [PATCH 31/51] Inline the definition of runInModule into evalModule. --- src/Semantic/Analysis.hs | 33 +++++++++------------------------ 1 file changed, 9 insertions(+), 24 deletions(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index fb40d31d4..d25adae51 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -5,7 +5,6 @@ module Semantic.Analysis , evaluate , evalModule , evalTerm -, runInModule , runValueEffects ) where @@ -68,7 +67,15 @@ evalModule :: ( Carrier outerSig outer -> Bindings address -> Module body -> Evaluator term address value outer (ModuleResult address) -evalModule perModule runTerm prelude m = runInModule prelude (moduleInfo m) (perModule (runTerm . moduleBody) m) +evalModule perModule runTerm prelude m = runInModule (perModule (runTerm . moduleBody) m) + where runInModule + = raiseHandler (runReader (moduleInfo m)) + . runAllocator + . runDeref + . runScopeEnv + . runEnv (EvalContext Nothing (Env.push (newEnv prelude))) + . runReturn + . runLoopControl evalTerm :: ( Carrier sig m , Declarations term @@ -104,28 +111,6 @@ evalTerm :: ( Carrier sig m -> term -> Evaluator term address value m address evalTerm analyzeTerm = fix (analyzeTerm (\ ev -> eval ev . project)) >=> address -runInModule :: ( Carrier sig m - , allocatorC ~ (AllocatorC address (Eff (ReaderC ModuleInfo (Eff m)))) - , allocatorSig ~ (Allocator address :+: Reader ModuleInfo :+: sig) - , Carrier allocatorSig allocatorC - , Carrier (Deref value :+: allocatorSig) (DerefC address value (Eff allocatorC)) - , Effect sig - , Member Fresh sig - , Ord address - ) - => Bindings address - -> ModuleInfo - -> Evaluator term address value (ModuleC address value m) address - -> Evaluator term address value m (ModuleResult address) -runInModule prelude info - = raiseHandler (runReader info) - . runAllocator - . runDeref - . runScopeEnv - . runEnv (EvalContext Nothing (Env.push (newEnv prelude))) - . runReturn - . runLoopControl - runValueEffects :: ( AbstractValue term address value (ValueC term address value m) , Carrier sig m , booleanC ~ BooleanC value (Eff (InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff m))) From b5ae015260285158210347073daf6f33085e94bf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 26 Oct 2018 12:51:59 -0400 Subject: [PATCH 32/51] Inline the definition of evalModule into evaluate. --- src/Semantic/Analysis.hs | 57 ++++++++++++++++++---------------------- src/Semantic/Graph.hs | 6 ++--- src/Semantic/REPL.hs | 2 +- src/Semantic/Util.hs | 6 ++--- 4 files changed, 32 insertions(+), 39 deletions(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index d25adae51..bae22b08c 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -3,7 +3,6 @@ module Semantic.Analysis ( ModuleC , ValueC , evaluate -, evalModule , evalTerm , runValueEffects ) where @@ -34,14 +33,25 @@ type ValueC term address value m ( InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff m))))))) -evaluate :: ( Carrier sig m - , Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) sig +evaluate :: ( 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 + , Effect outerSig + , Member Fresh outerSig + , Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) outerSig + , Ord address ) => lang - -> (Bindings address -> Module (Either lang term) -> Evaluator term address value m (ModuleResult address)) + -> ( (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) -> [Module term] - -> Evaluator term address value m (ModuleTable (NonEmpty (Module (ModuleResult address)))) -evaluate lang evalModule modules = do + -> Evaluator term address value outer (ModuleTable (NonEmpty (Module (ModuleResult address)))) +evaluate lang perModule runTerm modules = do let prelude = Module moduleInfoFromCallStack (Left lang) (_, (preludeBinds, _)) <- evalModule lowerBound prelude foldr (run preludeBinds . fmap Right) ask modules @@ -50,32 +60,15 @@ evaluate lang evalModule 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 :: ( 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 - , Effect outerSig - , Member Fresh outerSig - , Ord address - ) - => ( (Module body -> Evaluator term address value inner address) - -> (Module body -> Evaluator term address value (ModuleC address value outer) address)) - -> (body -> Evaluator term address value inner address) - -> Bindings address - -> Module body - -> Evaluator term address value outer (ModuleResult address) -evalModule perModule runTerm prelude m = runInModule (perModule (runTerm . moduleBody) m) - where runInModule - = raiseHandler (runReader (moduleInfo m)) - . runAllocator - . runDeref - . runScopeEnv - . runEnv (EvalContext Nothing (Env.push (newEnv prelude))) - . runReturn - . runLoopControl + evalModule prelude m = runInModule (perModule (runTerm . moduleBody) m) + where runInModule + = raiseHandler (runReader (moduleInfo m)) + . runAllocator + . runDeref + . runScopeEnv + . runEnv (EvalContext Nothing (Env.push (newEnv prelude))) + . runReturn + . runLoopControl evalTerm :: ( Carrier sig m , Declarations term diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 533ce9898..119ca1242 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 (evalModule perModule (runValueEffects perTerm)) modules + $ evaluate lang perModule (runValueEffects 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 (evalModule graphingModuleInfo (runValueEffects (evalTerm id))) (ModuleTable.toPairs (packageModules package) >>= toList . snd) + $ evaluate lang graphingModuleInfo (runValueEffects (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) (evalModule id (runValueEffects (runPythonPackaging . evalTerm id))) [ setupModule ]) + fst <$> runAnalysis (evaluate (Proxy @'Language.Python) id (runValueEffects (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 dbc0acdd1..1bfbd4e57 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 (evalModule id (runValueEffects (evalTerm (withTermSpans . step (fmap (\ (x:|_) -> moduleBody x) <$> ModuleTable.toPairs (packageModules (fst <$> package))))))) modules + $ evaluate proxy id (runValueEffects (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 1768d99df..27dcbeb77 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 (evalModule id (runValueEffects (evalTerm withTermSpans))) modules))))))) + (evaluate proxy id (runValueEffects (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 (evalModule id (runValueEffects (evalTerm withTermSpans))) modules))))))) + (evaluate proxy id (runValueEffects (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 (evalModule id (runValueEffects (evalTerm withTermSpans))) modules))))))) + (evaluate proxy id (runValueEffects (evalTerm withTermSpans)) modules))))))) parseFile :: Parser term -> FilePath -> IO term From 77675e1b80cfaa126a86c5af13ec93df35cf865e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 26 Oct 2018 12:52:30 -0400 Subject: [PATCH 33/51] Rename analyzeTerm to perTerm. --- src/Semantic/Analysis.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index bae22b08c..92e5901c1 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -102,7 +102,7 @@ evalTerm :: ( Carrier sig m ) => Open (Open (term -> Evaluator term address value m (ValueRef address))) -> term -> Evaluator term address value m address -evalTerm analyzeTerm = fix (analyzeTerm (\ ev -> eval ev . project)) >=> address +evalTerm perTerm = fix (perTerm (\ ev -> eval ev . project)) >=> address runValueEffects :: ( AbstractValue term address value (ValueC term address value m) , Carrier sig m From 141ed75d40cfa4133f468ea443c784ad2d42ea7a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 26 Oct 2018 12:54:35 -0400 Subject: [PATCH 34/51] =?UTF-8?q?Don=E2=80=99t=20export=20ModuleC/ValueC.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Semantic/Analysis.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 92e5901c1..bab1596e0 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -1,8 +1,6 @@ {-# LANGUAGE TypeFamilies, TypeOperators #-} module Semantic.Analysis -( ModuleC -, ValueC -, evaluate +( evaluate , evalTerm , runValueEffects ) where From 33f20e0cf5224d2e5e4e5b1e6b67292bd57026c9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 26 Oct 2018 12:56:13 -0400 Subject: [PATCH 35/51] :memo: runValueEffects. --- src/Semantic/Analysis.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index bab1596e0..6e8390964 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -102,6 +102,7 @@ evalTerm :: ( Carrier sig m -> 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))) From 55df272a2a396be404bbcc881209f7bb5b1468d1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 26 Oct 2018 12:58:30 -0400 Subject: [PATCH 36/51] :memo: evalTerm. --- src/Semantic/Analysis.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 6e8390964..566923200 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -68,6 +68,9 @@ evaluate lang perModule runTerm modules = do . runReturn . runLoopControl +-- | 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. evalTerm :: ( Carrier sig m , Declarations term , Evaluatable (Base term) From f0925ad0cfb564cae022510a56e3cdbd800db576 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 26 Oct 2018 13:00:37 -0400 Subject: [PATCH 37/51] :memo: evaluate. --- src/Semantic/Analysis.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 566923200..4fa722c2f 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -31,6 +31,7 @@ type ValueC term address value m ( InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff 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 , derefSig ~ (Deref value :+: allocatorSig) , derefC ~ (DerefC address value (Eff allocatorC)) From 66d5a1dfe8bc83203d40aa9d4603438d533bc7bb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 26 Oct 2018 13:03:14 -0400 Subject: [PATCH 38/51] Run nondeterminism locally in flow-sensitive analysis. --- src/Analysis/Abstract/Caching/FlowSensitive.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/src/Analysis/Abstract/Caching/FlowSensitive.hs b/src/Analysis/Abstract/Caching/FlowSensitive.hs index 23120d1f9..63de56b6c 100644 --- a/src/Analysis/Abstract/Caching/FlowSensitive.hs +++ b/src/Analysis/Abstract/Caching/FlowSensitive.hs @@ -89,10 +89,13 @@ convergingModules :: ( AbstractValue term address value m , Member (Env address) sig , Member (State (Heap address value)) sig , Carrier sig m + , Effect sig ) - => Open (Module term -> Evaluator term address value m address) -convergingModules recur m = do - c <- getConfiguration (moduleBody m) + => (Module (Either prelude term) -> Evaluator term address value (AltC Maybe (Eff m)) address) + -> (Module (Either prelude term) -> Evaluator term address value m address) +convergingModules recur m@(Module _ (Left _)) = raiseHandler runNonDet (recur m) >>= maybeM empty +convergingModules recur m@(Module _ (Right term)) = do + c <- getConfiguration term -- Convergence here is predicated upon an Eq instance, not α-equivalence cache <- converge lowerBound (\ prevCache -> isolateCache $ do putHeap (configurationHeap c) @@ -104,8 +107,7 @@ convergingModules recur m = do -- that it doesn't "leak" to the calling context and diverge (otherwise this -- would never complete). We don’t need to use the values, so we 'gather' the -- nondeterministic values into @()@. - -- FIXME: do we actually need to gather here? - withOracle prevCache (recur m)) + withOracle prevCache (raiseHandler runNonDet (recur m))) address =<< maybe empty scatter (cacheLookup c cache) -- | Iterate a monadic action starting from some initial seed until the results converge. From 2fd8bcad929be35b7ab50d56cec91c819780a4d5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 26 Oct 2018 13:11:20 -0400 Subject: [PATCH 39/51] :fire: some unused language extensions. --- src/Control/Abstract/PythonPackage.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/PythonPackage.hs b/src/Control/Abstract/PythonPackage.hs index 218803a80..8b5bb8ae1 100644 --- a/src/Control/Abstract/PythonPackage.hs +++ b/src/Control/Abstract/PythonPackage.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, LambdaCase, RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances #-} module Control.Abstract.PythonPackage ( runPythonPackaging, Strategy(..) ) where From 2734b380fcbd4db173c4b800a5c1f87de7cda177 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 26 Oct 2018 13:12:51 -0400 Subject: [PATCH 40/51] Move graphingModuleInfo above eavesdrop. --- src/Analysis/Abstract/Graph.hs | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index a6a48c8ae..6bdfcfebd 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -141,6 +141,21 @@ graphingModules recur m = do {-# ANN graphingModules ("HLint: ignore Use ." :: String) #-} +-- | Add vertices to the graph for imported modules. +graphingModuleInfo :: ( Member (Modules address) sig + , Member (Reader ModuleInfo) sig + , Member (State (Graph ModuleInfo)) sig + , Carrier sig m + ) + => (Module body -> Evaluator term address value (EavesdropC address (Eff m)) a) + -> (Module body -> Evaluator term address value m a) +graphingModuleInfo recur m = do + appendGraph (vertex (moduleInfo m)) + eavesdrop (recur m) $ \case + Load path _ -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex + Lookup path _ -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex + _ -> pure () + eavesdrop :: (Carrier sig m, Member (Modules address) sig) => Evaluator term address value (EavesdropC address (Eff m)) a -> (forall x . Modules address (Eff m) (Eff m x) -> Evaluator term address value m ()) @@ -159,21 +174,6 @@ instance (Carrier sig m, Member (Modules address) sig, Applicative m) => Carrier | otherwise = EavesdropC (\ handler -> eff (handlePure (runEavesdropC handler) op)) --- | Add vertices to the graph for imported modules. -graphingModuleInfo :: ( Member (Modules address) sig - , Member (Reader ModuleInfo) sig - , Member (State (Graph ModuleInfo)) sig - , Carrier sig m - ) - => (Module body -> Evaluator term address value (EavesdropC address (Eff m)) a) - -> (Module body -> Evaluator term address value m a) -graphingModuleInfo recur m = do - appendGraph (vertex (moduleInfo m)) - eavesdrop (recur m) $ \case - Load path _ -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex - Lookup path _ -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex - _ -> pure () - -- | Add an edge from the current package to the passed vertex. packageInclusion :: ( Member (Reader PackageInfo) sig , Member (State (Graph ControlFlowVertex)) sig From 1b507fc5c0f9c70f45804c1b54432dadaa13f7ee Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 26 Oct 2018 13:38:20 -0400 Subject: [PATCH 41/51] 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 From 636eec364e7922c34762bf218f6fe006c88ec0b9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 29 Oct 2018 09:52:48 -0400 Subject: [PATCH 42/51] Update to fused-effects, replace \/ with handleSum and bundle Interpose. --- .gitmodules | 6 +- semantic.cabal | 8 ++- src/Control/Abstract/Environment.hs | 25 ++++--- src/Control/Abstract/Modules.hs | 11 ++- src/Control/Abstract/ScopeGraph.hs | 39 +++++----- src/Control/Effect/Interpose.hs | 49 +++++++++++++ src/Data/Abstract/Address/Hole.hs | 13 ++-- src/Data/Abstract/Address/Located.hs | 13 ++-- src/Data/Abstract/Address/Monovariant.hs | 13 ++-- src/Data/Abstract/Address/Precise.hs | 13 ++-- src/Data/Abstract/Value/Abstract.hs | 42 +++++------ src/Data/Abstract/Value/Concrete.hs | 90 +++++++++++------------- src/Data/Abstract/Value/Type.hs | 56 +++++++-------- src/Semantic/Distribute.hs | 4 +- src/Semantic/REPL.hs | 21 +++--- src/Semantic/Resolution.hs | 8 +-- src/Semantic/Task.hs | 23 +++--- src/Semantic/Task/Files.hs | 19 +++-- src/Semantic/Telemetry.hs | 14 ++-- src/Semantic/Timeout.hs | 7 +- vendor/fused-effects | 1 + vendor/higher-order-effects | 1 - 22 files changed, 262 insertions(+), 214 deletions(-) create mode 100644 src/Control/Effect/Interpose.hs create mode 160000 vendor/fused-effects delete mode 160000 vendor/higher-order-effects diff --git a/.gitmodules b/.gitmodules index ff15c8731..ec2d6059a 100644 --- a/.gitmodules +++ b/.gitmodules @@ -13,6 +13,6 @@ [submodule "vendor/semilattices"] path = vendor/semilattices url = https://github.com/robrix/semilattices.git -[submodule "vendor/higher-order-effects"] - path = vendor/higher-order-effects - url = https://github.com/robrix/higher-order-effects.git +[submodule "vendor/fused-effects"] + path = vendor/fused-effects + url = https://github.com/robrix/fused-effects.git diff --git a/semantic.cabal b/semantic.cabal index 595333684..2e2df1108 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -48,6 +48,8 @@ library , Control.Abstract.Roots , Control.Abstract.ScopeGraph , Control.Abstract.Value + -- Effects + , Control.Effect.Interpose -- Rewriting , Control.Rewriting -- Datatypes for abstract interpretation @@ -235,12 +237,12 @@ library , filepath , free , freer-cofreer + , fused-effects , ghc-prim , gitrev , Glob , hashable , haskeline - , higher-order-effects , hscolour , http-client , http-client-tls @@ -363,10 +365,10 @@ test-suite test , fastsum , filepath , free + , fused-effects , Glob , hashable , haskell-tree-sitter - , higher-order-effects , hspec >= 2.4.1 , hspec-core , hspec-expectations-pretty-diff @@ -416,8 +418,8 @@ test-suite parse-examples , directory , fastsum , filepath + , fused-effects , Glob - , higher-order-effects , hspec >= 2.4.1 , hspec-core , hspec-expectations-pretty-diff diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 3d6a531f8..f15979cdc 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -187,19 +187,18 @@ newtype EnvC address m a = EnvC { runEnvC :: Eff (StateC (EvalContext address) ( instance (Carrier sig m, Effect sig) => Carrier (Env address :+: sig) (EnvC address m) where ret = EnvC . ret - eff = EnvC . (alg \/ eff . R . R . handleCoercible) - where alg = \case - Lookup name k -> gets (Env.lookupEnv' name . ctxEnvironment) >>= runEnvC . k - Bind name addr k -> modify (\EvalContext{..} -> EvalContext ctxSelf (Env.insertEnv name addr ctxEnvironment)) >> runEnvC k - Close names k -> gets (Env.intersect names . ctxEnvironment) >>= runEnvC . k - Locally action k -> do - modify (\EvalContext{..} -> EvalContext ctxSelf (Env.push @address ctxEnvironment)) - a <- runEnvC action - modify (\EvalContext{..} -> EvalContext ctxSelf (Env.pop @address ctxEnvironment)) - runEnvC (k a) - GetCtx k -> get >>= runEnvC . k - PutCtx e k -> put e >> runEnvC k - Export name alias addr k -> modify (Exports.insert name alias addr) >> runEnvC k + eff = EnvC . handleSum (eff . R . R . handleCoercible) (\case + Lookup name k -> gets (Env.lookupEnv' name . ctxEnvironment) >>= runEnvC . k + Bind name addr k -> modify (\EvalContext{..} -> EvalContext ctxSelf (Env.insertEnv name addr ctxEnvironment)) >> runEnvC k + Close names k -> gets (Env.intersect names . ctxEnvironment) >>= runEnvC . k + Locally action k -> do + modify (\EvalContext{..} -> EvalContext ctxSelf (Env.push @address ctxEnvironment)) + a <- runEnvC action + modify (\EvalContext{..} -> EvalContext ctxSelf (Env.pop @address ctxEnvironment)) + runEnvC (k a) + GetCtx k -> get >>= runEnvC . k + PutCtx e k -> put e >> runEnvC k + Export name alias addr k -> modify (Exports.insert name alias addr) >> runEnvC k) freeVariableError :: ( Member (Reader ModuleInfo) sig , Member (Reader Span) sig diff --git a/src/Control/Abstract/Modules.hs b/src/Control/Abstract/Modules.hs index a1ae6595a..e1daa7e74 100644 --- a/src/Control/Abstract/Modules.hs +++ b/src/Control/Abstract/Modules.hs @@ -99,12 +99,11 @@ instance ( Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address)) ) => Carrier (Modules address :+: sig) (ModulesC address m) where ret = ModulesC . const . ret - eff op = ModulesC (\ paths -> (alg paths \/ eff . handleReader paths runModulesC) op) - where alg paths = \case - Load name k -> askModuleTable >>= maybeM (throwLoadError (ModuleNotFoundError name)) . fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup name >>= flip runModulesC paths . k - Lookup path k -> askModuleTable >>= flip runModulesC paths . k . fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup path - Resolve names k -> runModulesC (k (find (`Set.member` paths) names)) paths - List dir k -> runModulesC (k (filter ((dir ==) . takeDirectory) (toList paths))) paths + eff op = ModulesC (\ paths -> handleSum (eff . handleReader paths runModulesC) (\case + Load name k -> askModuleTable >>= maybeM (throwLoadError (ModuleNotFoundError name)) . fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup name >>= flip runModulesC paths . k + Lookup path k -> askModuleTable >>= flip runModulesC paths . k . fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup path + Resolve names k -> runModulesC (k (find (`Set.member` paths) names)) paths + List dir k -> runModulesC (k (filter ((dir ==) . takeDirectory) (toList paths))) paths) op) askModuleTable :: (Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) sig, Carrier sig m) => m (ModuleTable (NonEmpty (Module (ModuleResult address)))) askModuleTable = ask diff --git a/src/Control/Abstract/ScopeGraph.hs b/src/Control/Abstract/ScopeGraph.hs index 10d5b2c40..aa416a3f8 100644 --- a/src/Control/Abstract/ScopeGraph.hs +++ b/src/Control/Abstract/ScopeGraph.hs @@ -98,23 +98,22 @@ newtype ScopeEnvC address m a = ScopeEnvC { runScopeEnvC :: Eff (StateC (ScopeGr instance (Ord address, Member Fresh sig, Member (Allocator address) sig, Carrier sig m, Effect sig) => Carrier (ScopeEnv address :+: sig) (ScopeEnvC address m) where ret = ScopeEnvC . ret - eff = ScopeEnvC . (alg \/ eff . R . handleCoercible) - where alg = \case - Lookup ref k -> gets (ScopeGraph.scopeOfRef ref) >>= runScopeEnvC . k - Declare decl span scope k -> modify @(ScopeGraph address) (ScopeGraph.declare decl span scope) *> runScopeEnvC k - PutDeclarationScope decl scope k -> modify @(ScopeGraph address) (ScopeGraph.insertDeclarationScope decl scope) *> runScopeEnvC k - Reference ref decl k -> modify @(ScopeGraph address) (ScopeGraph.reference ref decl) *> runScopeEnvC k - NewScope edges k -> do - -- Take the edges and construct a new scope, update the current scope to the new scope - name <- gensym - address <- runEvaluator (alloc name) - modify @(ScopeGraph address) (ScopeGraph.newScope address edges) - runScopeEnvC (k address) - CurrentScope k -> gets ScopeGraph.currentScope >>= runScopeEnvC . k - AssociatedScope decl k -> gets (ScopeGraph.associatedScope decl) >>= runScopeEnvC . k - Local scope action k -> do - prevScope <- gets ScopeGraph.currentScope - modify @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = Just scope }) - value <- runScopeEnvC action - modify @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = prevScope }) - runScopeEnvC (k value) + eff = ScopeEnvC . handleSum (eff . R . handleCoercible) (\case + Lookup ref k -> gets (ScopeGraph.scopeOfRef ref) >>= runScopeEnvC . k + Declare decl span scope k -> modify @(ScopeGraph address) (ScopeGraph.declare decl span scope) *> runScopeEnvC k + PutDeclarationScope decl scope k -> modify @(ScopeGraph address) (ScopeGraph.insertDeclarationScope decl scope) *> runScopeEnvC k + Reference ref decl k -> modify @(ScopeGraph address) (ScopeGraph.reference ref decl) *> runScopeEnvC k + NewScope edges k -> do + -- Take the edges and construct a new scope, update the current scope to the new scope + name <- gensym + address <- runEvaluator (alloc name) + modify @(ScopeGraph address) (ScopeGraph.newScope address edges) + runScopeEnvC (k address) + CurrentScope k -> gets ScopeGraph.currentScope >>= runScopeEnvC . k + AssociatedScope decl k -> gets (ScopeGraph.associatedScope decl) >>= runScopeEnvC . k + Local scope action k -> do + prevScope <- gets ScopeGraph.currentScope + modify @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = Just scope }) + value <- runScopeEnvC action + modify @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = prevScope }) + runScopeEnvC (k value)) diff --git a/src/Control/Effect/Interpose.hs b/src/Control/Effect/Interpose.hs new file mode 100644 index 000000000..553f9cf26 --- /dev/null +++ b/src/Control/Effect/Interpose.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE ExistentialQuantification, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-} +module Control.Effect.Interpose +( Interpose(..) +, interpose +, runInterpose +, InterposeC(..) +, Listener(..) +) where + +import Control.Effect.Carrier +import Control.Effect.Internal +import Control.Effect.Sum + +data Interpose eff m k + = forall a . Interpose (m a) (forall n x . eff n (n x) -> m x) (a -> k) + +deriving instance Functor (Interpose eff m) + +instance HFunctor (Interpose eff) where + hmap f (Interpose m h k) = Interpose (f m) (f . h) k + +-- | Respond to requests for some specific effect with a handler. +-- +-- The intercepted effects are not re-sent in the surrounding context; thus, the innermost nested 'interpose' listening for an effect will win, and the effect’s own handler will not get the chance to service the request. +-- +-- Note that since 'Interpose' lacks an 'Effect' instance, only “pure” effects, i.e. effects which can be handled inside other effects using 'hmap' alone, can be run within the 'runInterpose' scope. This includes @Reader@, but not e.g. @State@ or @Error@. +interpose :: (Member (Interpose eff) sig, Carrier sig m) + => m a + -> (forall n x . eff n (n x) -> m x) + -> m a +interpose m f = send (Interpose m f ret) + + +-- | Run an 'Interpose' effect. +runInterpose :: (Member eff sig, Carrier sig m, Monad m) => Eff (InterposeC eff m) a -> m a +runInterpose = flip runInterposeC Nothing . interpret + +newtype InterposeC eff m a = InterposeC { runInterposeC :: Maybe (Listener eff m) -> m a } + +newtype Listener eff m = Listener { runListener :: forall n x . eff n (n x) -> m x } + +instance (Carrier sig m, Member eff sig, Monad m) => Carrier (Interpose eff :+: sig) (InterposeC eff m) where + ret a = InterposeC (const (ret a)) + eff op = InterposeC (\ listener -> handleSum (algOther listener) (alg listener) op) + where alg listener (Interpose m h k) = runInterposeC m (Just (Listener (flip runInterposeC listener . h))) >>= flip runInterposeC listener . k + algOther listener op + | Just listener <- listener + , Just eff <- prj op = runListener listener eff + | otherwise = eff (handleReader listener runInterposeC op) diff --git a/src/Data/Abstract/Address/Hole.hs b/src/Data/Abstract/Address/Hole.hs index eb991be08..85a6dfa1b 100644 --- a/src/Data/Abstract/Address/Hole.hs +++ b/src/Data/Abstract/Address/Hole.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeOperators, UndecidableInstances #-} +{-# LANGUAGE LambdaCase, TypeOperators, UndecidableInstances #-} module Data.Abstract.Address.Hole ( Hole(..) , toMaybe @@ -29,8 +29,9 @@ instance ( Carrier (Allocator address :+: sig) (AllocatorC address m) ) => Carrier (Allocator (Hole context address) :+: sig) (AllocatorC (Hole context address) m) where ret = promoteA . ret - eff = alg \/ AllocatorC . eff . handleCoercible - where alg (Alloc name k) = Total <$> promoteA (eff (L (Alloc name ret))) >>= k + eff = handleSum + (AllocatorC . eff . handleCoercible) + (\ (Alloc name k) -> Total <$> promoteA (eff (L (Alloc name ret))) >>= k) promoteD :: DerefC address value m a -> DerefC (Hole context address) value m a @@ -39,6 +40,6 @@ promoteD = DerefC . runDerefC instance (Carrier (Deref value :+: sig) (DerefC address value m), Carrier sig m, Monad m) => Carrier (Deref value :+: sig) (DerefC (Hole context address) value m) where ret = promoteD . ret - eff = alg \/ DerefC . eff . handleCoercible - where alg (DerefCell cell k) = promoteD (eff (L (DerefCell cell ret))) >>= k - alg (AssignCell value cell k) = promoteD (eff (L (AssignCell value cell ret))) >>= k + eff = handleSum (DerefC . eff . handleCoercible) (\case + DerefCell cell k -> promoteD (eff (L (DerefCell cell ret))) >>= k + AssignCell value cell k -> promoteD (eff (L (AssignCell value cell ret))) >>= k) diff --git a/src/Data/Abstract/Address/Located.hs b/src/Data/Abstract/Address/Located.hs index 94c9ed14d..4604c77e1 100644 --- a/src/Data/Abstract/Address/Located.hs +++ b/src/Data/Abstract/Address/Located.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeOperators, UndecidableInstances #-} +{-# LANGUAGE LambdaCase, TypeOperators, UndecidableInstances #-} module Data.Abstract.Address.Located ( Located(..) ) where @@ -32,8 +32,9 @@ instance ( Carrier (Allocator address :+: sig) (AllocatorC address m) ) => Carrier (Allocator (Located address) :+: sig) (AllocatorC (Located address) m) where ret = promoteA . ret - eff = alg \/ AllocatorC . eff . handleCoercible - where alg (Alloc name k) = Located <$> promoteA (eff (L (Alloc name ret))) <*> currentPackage <*> currentModule <*> pure name <*> ask >>= k + eff = handleSum + (AllocatorC . eff . handleCoercible) + (\ (Alloc name k) -> Located <$> promoteA (eff (L (Alloc name ret))) <*> currentPackage <*> currentModule <*> pure name <*> ask >>= k) promoteD :: DerefC address value m a -> DerefC (Located address) value m a @@ -42,6 +43,6 @@ promoteD = DerefC . runDerefC instance (Carrier (Deref value :+: sig) (DerefC address value m), Carrier sig m, Monad m) => Carrier (Deref value :+: sig) (DerefC (Located address) value m) where ret = promoteD . ret - eff = alg \/ DerefC . eff . handleCoercible - where alg (DerefCell cell k) = promoteD (eff (L (DerefCell cell ret))) >>= k - alg (AssignCell value cell k) = promoteD (eff (L (AssignCell value cell ret))) >>= k + eff = handleSum (DerefC . eff . handleCoercible) (\case + DerefCell cell k -> promoteD (eff (L (DerefCell cell ret))) >>= k + AssignCell value cell k -> promoteD (eff (L (AssignCell value cell ret))) >>= k) diff --git a/src/Data/Abstract/Address/Monovariant.hs b/src/Data/Abstract/Address/Monovariant.hs index 0a4dbd741..bb2a430fa 100644 --- a/src/Data/Abstract/Address/Monovariant.hs +++ b/src/Data/Abstract/Address/Monovariant.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE LambdaCase, TypeOperators, UndecidableInstances #-} module Data.Abstract.Address.Monovariant ( Monovariant(..) ) where @@ -20,12 +20,13 @@ instance Show Monovariant where instance Carrier sig m => Carrier (Allocator Monovariant :+: sig) (AllocatorC Monovariant m) where ret = AllocatorC . ret - eff = AllocatorC . (alg \/ eff . handleCoercible) - where alg (Alloc name k) = runAllocatorC (k (Monovariant name)) + eff = AllocatorC . handleSum + (eff . handleCoercible) + (\ (Alloc name k) -> runAllocatorC (k (Monovariant name))) instance (Ord value, Carrier sig m, Alternative m, Monad m) => Carrier (Deref value :+: sig) (DerefC Monovariant value m) where ret = DerefC . ret - eff = DerefC . (alg \/ eff . handleCoercible) - where alg (DerefCell cell k) = traverse (foldMapA pure) (nonEmpty (toList cell)) >>= runDerefC . k - alg (AssignCell value cell k) = runDerefC (k (Set.insert value cell)) + eff = DerefC . handleSum (eff . handleCoercible) (\case + DerefCell cell k -> traverse (foldMapA pure) (nonEmpty (toList cell)) >>= runDerefC . k + AssignCell value cell k -> runDerefC (k (Set.insert value cell))) diff --git a/src/Data/Abstract/Address/Precise.hs b/src/Data/Abstract/Address/Precise.hs index 50326dc55..1b1611429 100644 --- a/src/Data/Abstract/Address/Precise.hs +++ b/src/Data/Abstract/Address/Precise.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, LambdaCase, TypeOperators, UndecidableInstances #-} module Data.Abstract.Address.Precise ( Precise(..) ) where @@ -19,12 +19,13 @@ instance Show Precise where instance (Member Fresh sig, Carrier sig m, Monad m) => Carrier (Allocator Precise :+: sig) (AllocatorC Precise m) where ret = AllocatorC . ret - eff = AllocatorC . (alg \/ eff . handleCoercible) - where alg (Alloc _ k) = Precise <$> fresh >>= runAllocatorC . k + eff = AllocatorC . handleSum + (eff . handleCoercible) + (\ (Alloc _ k) -> Precise <$> fresh >>= runAllocatorC . k) instance Carrier sig m => Carrier (Deref value :+: sig) (DerefC Precise value m) where ret = DerefC . ret - eff = DerefC . (alg \/ eff . handleCoercible) - where alg (DerefCell cell k) = runDerefC (k (fst <$> Set.minView cell)) - alg (AssignCell value _ k) = runDerefC (k (Set.singleton value)) + eff = DerefC . handleSum (eff . handleCoercible) (\case + DerefCell cell k -> runDerefC (k (fst <$> Set.minView cell)) + AssignCell value _ k -> runDerefC (k (Set.singleton value))) diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index 074dad5fe..c547a3f48 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, LambdaCase, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE LambdaCase, TypeOperators, UndecidableInstances #-} module Data.Abstract.Value.Abstract ( Abstract (..) , runFunction @@ -31,26 +31,25 @@ instance ( Member (Allocator address) sig ) => Carrier (Abstract.Function term address Abstract :+: sig) (FunctionC term address Abstract (Eff m)) where ret = FunctionC . const . ret - eff op = FunctionC (\ eval -> (alg eval \/ eff . handleReader eval runFunctionC) op) - where alg eval = \case - Function _ params body k -> runEvaluator $ do - env <- foldr (\ name rest -> do - addr <- alloc name - assign addr Abstract - Env.insert name addr <$> rest) (pure lowerBound) params - addr <- locally (bindAll env *> catchReturn (runFunction (Evaluator . eval) (Evaluator (eval body)))) - deref addr >>= Evaluator . flip runFunctionC eval . k - BuiltIn _ k -> runFunctionC (k Abstract) eval - Call _ _ params k -> runEvaluator $ do - traverse_ deref params - box Abstract >>= Evaluator . flip runFunctionC eval . k + eff op = FunctionC (\ eval -> handleSum (eff . handleReader eval runFunctionC) (\case + Function _ params body k -> runEvaluator $ do + env <- foldr (\ name rest -> do + addr <- alloc name + assign addr Abstract + Env.insert name addr <$> rest) (pure lowerBound) params + addr <- locally (bindAll env *> catchReturn (runFunction (Evaluator . eval) (Evaluator (eval body)))) + deref addr >>= Evaluator . flip runFunctionC eval . k + BuiltIn _ k -> runFunctionC (k Abstract) eval + Call _ _ params k -> runEvaluator $ do + traverse_ deref params + box Abstract >>= Evaluator . flip runFunctionC eval . k) op) instance (Carrier sig m, Alternative m) => Carrier (Boolean Abstract :+: sig) (BooleanC Abstract m) where ret = BooleanC . ret - eff = BooleanC . (alg \/ eff . handleCoercible) - where alg (Boolean _ k) = runBooleanC (k Abstract) - alg (AsBool _ k) = runBooleanC (k True) <|> runBooleanC (k False) + eff = BooleanC . handleSum (eff . handleCoercible) (\case + Boolean _ k -> runBooleanC (k Abstract) + AsBool _ k -> runBooleanC (k True) <|> runBooleanC (k False)) instance ( Member (Abstract.Boolean Abstract) sig @@ -60,10 +59,11 @@ instance ( Member (Abstract.Boolean Abstract) sig ) => Carrier (While Abstract :+: sig) (WhileC Abstract m) where ret = WhileC . ret - eff = WhileC . (alg \/ eff . handleCoercible) - where alg (Abstract.While cond body k) = do - cond' <- runWhileC cond - ifthenelse cond' (runWhileC body *> empty) (runWhileC (k unit)) + eff = WhileC . handleSum + (eff . handleCoercible) + (\ (Abstract.While cond body k) -> do + cond' <- runWhileC cond + ifthenelse cond' (runWhileC body *> empty) (runWhileC (k unit))) instance Ord address => ValueRoots address Abstract where diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 6c5ab79ad..b0dc9a35d 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -75,29 +75,28 @@ instance ( FreeVariables term ) => Carrier (Abstract.Function term address (Value term address) :+: sig) (Abstract.FunctionC term address (Value term address) (Eff m)) where ret = FunctionC . const . ret - eff op = FunctionC (\ eval -> (alg eval \/ eff . handleReader eval runFunctionC) op) - where alg eval = \case - Abstract.Function name params body k -> runEvaluator $ do - packageInfo <- currentPackage - moduleInfo <- currentModule - Closure packageInfo moduleInfo name params (Right body) <$> close (foldr Set.delete (freeVariables body) params) >>= Evaluator . flip runFunctionC eval . k - Abstract.BuiltIn builtIn k -> do - packageInfo <- currentPackage - moduleInfo <- currentModule - runFunctionC (k (Closure packageInfo moduleInfo Nothing [] (Left builtIn) lowerBound)) eval - Abstract.Call op self params k -> runEvaluator $ do - boxed <- case op of - Closure _ _ _ _ (Left Print) _ -> traverse (deref >=> trace . show) params *> box Unit - Closure _ _ _ _ (Left Show) _ -> deref self >>= box . String . pack . show - Closure packageInfo moduleInfo _ names (Right body) env -> do - -- Evaluate the bindings and body with the closure’s package/module info in scope in order to - -- charge them to the closure's origin. - withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do - bindings <- foldr (\ (name, addr) rest -> Env.insert name addr <$> rest) (pure lowerBound) (zip names params) - let fnCtx = EvalContext (Just self) (Env.push env) - withEvalContext fnCtx (catchReturn (bindAll bindings *> runFunction (Evaluator . eval) (Evaluator (eval body)))) - _ -> throwValueError (CallError op) >>= box - Evaluator $ runFunctionC (k boxed) eval + eff op = FunctionC (\ eval -> handleSum (eff . handleReader eval runFunctionC) (\case + Abstract.Function name params body k -> runEvaluator $ do + packageInfo <- currentPackage + moduleInfo <- currentModule + Closure packageInfo moduleInfo name params (Right body) <$> close (foldr Set.delete (freeVariables body) params) >>= Evaluator . flip runFunctionC eval . k + Abstract.BuiltIn builtIn k -> do + packageInfo <- currentPackage + moduleInfo <- currentModule + runFunctionC (k (Closure packageInfo moduleInfo Nothing [] (Left builtIn) lowerBound)) eval + Abstract.Call op self params k -> runEvaluator $ do + boxed <- case op of + Closure _ _ _ _ (Left Print) _ -> traverse (deref >=> trace . show) params *> box Unit + Closure _ _ _ _ (Left Show) _ -> deref self >>= box . String . pack . show + Closure packageInfo moduleInfo _ names (Right body) env -> do + -- Evaluate the bindings and body with the closure’s package/module info in scope in order to + -- charge them to the closure's origin. + withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do + bindings <- foldr (\ (name, addr) rest -> Env.insert name addr <$> rest) (pure lowerBound) (zip names params) + let fnCtx = EvalContext (Just self) (Env.push env) + withEvalContext fnCtx (catchReturn (bindAll bindings *> runFunction (Evaluator . eval) (Evaluator (eval body)))) + _ -> throwValueError (CallError op) >>= box + Evaluator $ runFunctionC (k boxed) eval) op) instance ( Member (Reader ModuleInfo) sig @@ -108,12 +107,10 @@ instance ( Member (Reader ModuleInfo) sig ) => Carrier (Abstract.Boolean (Value term address) :+: sig) (BooleanC (Value term address) m) where ret = BooleanC . ret - eff = BooleanC . (alg \/ eff . handleCoercible) - where alg :: Abstract.Boolean (Value term address) (BooleanC (Value term address) m) (BooleanC (Value term address) m a) -> m a - alg = \case - Abstract.Boolean b k -> runBooleanC . k $! Boolean b - Abstract.AsBool (Boolean b) k -> runBooleanC (k b) - Abstract.AsBool other k -> throwBaseError (BoolError other) >>= runBooleanC . k + eff = BooleanC . handleSum (eff . handleCoercible) (\case + Abstract.Boolean b k -> runBooleanC . k $! Boolean b + Abstract.AsBool (Boolean b) k -> runBooleanC (k b) + Abstract.AsBool other k -> throwBaseError (BoolError other) >>= runBooleanC . k) instance ( Carrier sig m @@ -131,26 +128,25 @@ instance ( Carrier sig m ) => Carrier (Abstract.While (Value term address) :+: sig) (WhileC (Value term address) (Eff m)) where ret = WhileC . ret - eff = WhileC . (alg \/ eff . handleCoercible) - where alg = \case - Abstract.While cond body k -> interpose @(Resumable (BaseError (UnspecializedError (Value term address)))) (runEvaluator (loop (\continue -> do - cond' <- Evaluator (runWhileC cond) + eff = WhileC . handleSum (eff . handleCoercible) (\case + Abstract.While cond body k -> interpose @(Resumable (BaseError (UnspecializedError (Value term address)))) (runEvaluator (loop (\continue -> do + cond' <- Evaluator (runWhileC cond) - -- `interpose` is used to handle 'UnspecializedError's and abort out of the - -- loop, otherwise under concrete semantics we run the risk of the - -- conditional always being true and getting stuck in an infinite loop. + -- `interpose` is used to handle 'UnspecializedError's and abort out of the + -- loop, otherwise under concrete semantics we run the risk of the + -- conditional always being true and getting stuck in an infinite loop. - ifthenelse cond' (Evaluator (runWhileC body) *> continue) (pure Unit)))) - (\(Resumable (BaseError _ _ (UnspecializedError _)) _) -> throwError (Abort @address)) - >>= runWhileC . k - where - loop x = catchLoopControl @address (fix x) $ \case - Break value -> deref value - Abort -> pure unit - -- FIXME: Figure out how to deal with this. Ruby treats this as the result - -- of the current block iteration, while PHP specifies a breakout level - -- and TypeScript appears to take a label. - Continue _ -> loop x + ifthenelse cond' (Evaluator (runWhileC body) *> continue) (pure Unit)))) + (\(Resumable (BaseError _ _ (UnspecializedError _)) _) -> throwError (Abort @address)) + >>= runWhileC . k) + where + loop x = catchLoopControl @address (fix x) $ \case + Break value -> deref value + Abort -> pure unit + -- FIXME: Figure out how to deal with this. Ruby treats this as the result + -- of the current block iteration, while PHP specifies a breakout level + -- and TypeScript appears to take a label. + Continue _ -> loop x instance AbstractHole (Value term address) where diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index 6222b7c61..d0cfb94eb 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances, LambdaCase #-} +{-# LANGUAGE GADTs, LambdaCase, RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances, LambdaCase #-} module Data.Abstract.Value.Type ( Type (..) , TypeError (..) @@ -253,26 +253,25 @@ instance ( Member (Allocator address) sig ) => Carrier (Abstract.Function term address Type :+: sig) (FunctionC term address Type (Eff m)) where ret = FunctionC . const . ret - eff op = FunctionC (\ eval -> (alg eval \/ eff . handleReader eval runFunctionC) op) - where alg eval = \case - Abstract.Function _ params body k -> runEvaluator $ do - (env, tvars) <- foldr (\ name rest -> do - addr <- alloc name - tvar <- Var <$> fresh - assign addr tvar - bimap (Env.insert name addr) (tvar :) <$> rest) (pure (lowerBound, [])) params - locally (catchReturn (bindAll env *> runFunction (Evaluator . eval) (Evaluator (eval body)))) >>= deref >>= Evaluator . flip runFunctionC eval . k . (zeroOrMoreProduct tvars :->) - Abstract.BuiltIn Print k -> runFunctionC (k (String :-> Unit)) eval - Abstract.BuiltIn Show k -> runFunctionC (k (Object :-> String)) eval - Abstract.Call op _ params k -> runEvaluator $ do - tvar <- fresh - paramTypes <- traverse deref params - let needed = zeroOrMoreProduct paramTypes :-> Var tvar - unified <- op `unify` needed - boxed <- case unified of - _ :-> ret -> box ret - actual -> throwTypeError (UnificationError needed actual) >>= box - Evaluator $ runFunctionC (k boxed) eval + eff op = FunctionC (\ eval -> handleSum (eff . handleReader eval runFunctionC) (\case + Abstract.Function _ params body k -> runEvaluator $ do + (env, tvars) <- foldr (\ name rest -> do + addr <- alloc name + tvar <- Var <$> fresh + assign addr tvar + bimap (Env.insert name addr) (tvar :) <$> rest) (pure (lowerBound, [])) params + locally (catchReturn (bindAll env *> runFunction (Evaluator . eval) (Evaluator (eval body)))) >>= deref >>= Evaluator . flip runFunctionC eval . k . (zeroOrMoreProduct tvars :->) + Abstract.BuiltIn Print k -> runFunctionC (k (String :-> Unit)) eval + Abstract.BuiltIn Show k -> runFunctionC (k (Object :-> String)) eval + Abstract.Call op _ params k -> runEvaluator $ do + tvar <- fresh + paramTypes <- traverse deref params + let needed = zeroOrMoreProduct paramTypes :-> Var tvar + unified <- op `unify` needed + boxed <- case unified of + _ :-> ret -> box ret + actual -> throwTypeError (UnificationError needed actual) >>= box + Evaluator $ runFunctionC (k boxed) eval) op) instance ( Member (Reader ModuleInfo) sig @@ -285,9 +284,9 @@ instance ( Member (Reader ModuleInfo) sig ) => Carrier (Abstract.Boolean Type :+: sig) (BooleanC Type m) where ret = BooleanC . ret - eff = BooleanC . (alg \/ eff . handleCoercible) - where alg (Abstract.Boolean _ k) = runBooleanC (k Bool) - alg (Abstract.AsBool t k) = unify t Bool *> (runBooleanC (k True) <|> runBooleanC (k False)) + eff = BooleanC . handleSum (eff . handleCoercible) (\case + Abstract.Boolean _ k -> runBooleanC (k Bool) + Abstract.AsBool t k -> unify t Bool *> (runBooleanC (k True) <|> runBooleanC (k False))) instance ( Member (Abstract.Boolean Type) sig @@ -297,10 +296,11 @@ instance ( Member (Abstract.Boolean Type) sig ) => Carrier (Abstract.While Type :+: sig) (WhileC Type m) where ret = WhileC . ret - eff = WhileC . (alg \/ eff . handleCoercible) - where alg (Abstract.While cond body k) = do - cond' <- runWhileC cond - ifthenelse cond' (runWhileC body *> empty) (runWhileC (k unit)) + eff = WhileC . handleSum + (eff . handleCoercible) + (\ (Abstract.While cond body k) -> do + cond' <- runWhileC cond + ifthenelse cond' (runWhileC body *> empty) (runWhileC (k unit))) instance AbstractHole Type where diff --git a/src/Semantic/Distribute.hs b/src/Semantic/Distribute.hs index 639089e90..34c789a41 100644 --- a/src/Semantic/Distribute.hs +++ b/src/Semantic/Distribute.hs @@ -55,4 +55,6 @@ newtype DistributeC m a = DistributeC { runDistributeC :: m a } instance Carrier (Distribute :+: Lift IO) (DistributeC (Eff (LiftC IO))) where ret = DistributeC . ret - eff = DistributeC . ((\ (Distribute task k) -> liftIO (Async.runConcurrently (Async.Concurrently (runM (runDistributeC task)))) >>= runDistributeC . k) \/ eff . handleCoercible) + eff = DistributeC . handleSum + (eff . handleCoercible) + (\ (Distribute task k) -> liftIO (Async.runConcurrently (Async.Concurrently (runM (runDistributeC task)))) >>= runDistributeC . k) diff --git a/src/Semantic/REPL.hs b/src/Semantic/REPL.hs index 7e37521a0..3934a15e0 100644 --- a/src/Semantic/REPL.hs +++ b/src/Semantic/REPL.hs @@ -78,10 +78,9 @@ newtype REPLC m a = REPLC { runREPLC :: (Prefs, Settings IO) -> m a } instance (Carrier sig m, MonadIO m) => Carrier (REPL :+: sig) (REPLC m) where ret = REPLC . const . ret - eff op = REPLC (\ args -> (alg args \/ eff . handleReader args runREPLC) op) - where alg args = \case - Prompt k -> liftIO (uncurry runInputTWithPrefs args (getInputLine (cyan <> "repl: " <> plain))) >>= flip runREPLC args . k - Output s k -> liftIO (uncurry runInputTWithPrefs args (outputStrLn s)) *> runREPLC k args + eff op = REPLC (\ args -> handleSum (eff . handleReader args runREPLC) (\case + Prompt k -> liftIO (uncurry runInputTWithPrefs args (getInputLine (cyan <> "repl: " <> plain))) >>= flip runREPLC args . k + Output s k -> liftIO (uncurry runInputTWithPrefs args (outputStrLn s)) *> runREPLC k args) op) rubyREPL = repl (Proxy @'Language.Ruby) rubyParser @@ -133,13 +132,13 @@ newtype TelemetryIgnoringStatC m a = TelemetryIgnoringStatC { runTelemetryIgnori instance (Carrier sig m, MonadIO m) => Carrier (Telemetry :+: sig) (TelemetryIgnoringStatC m) where ret = TelemetryIgnoringStatC . const . ret - eff op = TelemetryIgnoringStatC (\ logOptions -> (algT logOptions \/ eff . handleReader logOptions runTelemetryIgnoringStatC) op) - where algT logOptions (WriteStat _ k) = runTelemetryIgnoringStatC k logOptions - algT logOptions (WriteLog level message pairs k) = do - time <- liftIO Time.getCurrentTime - zonedTime <- liftIO (LocalTime.utcToLocalZonedTime time) - writeLogMessage logOptions (Message level message pairs zonedTime) - runTelemetryIgnoringStatC k logOptions + eff op = TelemetryIgnoringStatC (\ logOptions -> handleSum (eff . handleReader logOptions runTelemetryIgnoringStatC) (\case + WriteStat _ k -> runTelemetryIgnoringStatC k logOptions + WriteLog level message pairs k -> do + time <- liftIO Time.getCurrentTime + zonedTime <- liftIO (LocalTime.utcToLocalZonedTime time) + writeLogMessage logOptions (Message level message pairs zonedTime) + runTelemetryIgnoringStatC k logOptions) op) step :: ( Member (Env address) sig , Member (Error SomeException) sig diff --git a/src/Semantic/Resolution.hs b/src/Semantic/Resolution.hs index ba8ddb6e0..ce8bfda59 100644 --- a/src/Semantic/Resolution.hs +++ b/src/Semantic/Resolution.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstraintKinds, GADTs, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds, GADTs, KindSignatures, LambdaCase, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} module Semantic.Resolution ( Resolution (..) , nodeJSResolutionMap @@ -64,6 +64,6 @@ newtype ResolutionC m a = ResolutionC { runResolutionC :: m a } instance (Member Files sig, Carrier sig m, Monad m) => Carrier (Resolution :+: sig) (ResolutionC m) where ret = ResolutionC . ret - eff = ResolutionC . (alg \/ eff . handleCoercible) - where alg (NodeJSResolution dir prop excludeDirs k) = nodeJSResolutionMap dir prop excludeDirs >>= runResolutionC . k - alg (NoResolution k) = runResolutionC (k Map.empty) + eff = ResolutionC . handleSum (eff . handleCoercible) (\case + NodeJSResolution dir prop excludeDirs k -> nodeJSResolutionMap dir prop excludeDirs >>= runResolutionC . k + NoResolution k -> runResolutionC (k Map.empty)) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 6a26cb5ad..96f8b26a8 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -206,7 +206,9 @@ newtype TraceInTelemetryC m a = TraceInTelemetryC { runTraceInTelemetryC :: m a instance (Member Telemetry sig, Carrier sig m, Monad m) => Carrier (Trace :+: sig) (TraceInTelemetryC m) where ret = TraceInTelemetryC . ret - eff = TraceInTelemetryC . ((\ (Trace str k) -> writeLog Debug str [] >> runTraceInTelemetryC k) \/ eff . handleCoercible) + eff = TraceInTelemetryC . handleSum + (eff . handleCoercible) + (\ (Trace str k) -> writeLog Debug str [] >> runTraceInTelemetryC k) -- | An effect describing high-level tasks to be performed. @@ -250,16 +252,15 @@ newtype TaskC m a = TaskC { runTaskC :: m a } instance (Member (Error SomeException) sig, Member (Lift IO) sig, Member (Reader Config) sig, Member Resource sig, Member Telemetry sig, Member Timeout sig, Member Trace sig, Carrier sig m, MonadIO m) => Carrier (Task :+: sig) (TaskC m) where ret = TaskC . ret - eff = TaskC . (alg \/ eff . handleCoercible) - where alg = \case - Parse parser blob k -> runParser blob parser >>= runTaskC . k - Analyze interpret analysis k -> runTaskC (k (interpret analysis)) - Decorate algebra term k -> runTaskC (k (decoratorWithAlgebra algebra term)) - Semantic.Task.Diff terms k -> runTaskC (k (diffTermPair terms)) - Render renderer input k -> runTaskC (k (renderer input)) - Serialize format input k -> do - formatStyle <- asks (bool Plain Colourful . configIsTerminal) - runTaskC (k (runSerialize formatStyle format input)) + eff = TaskC . handleSum (eff . handleCoercible) (\case + Parse parser blob k -> runParser blob parser >>= runTaskC . k + Analyze interpret analysis k -> runTaskC (k (interpret analysis)) + Decorate algebra term k -> runTaskC (k (decoratorWithAlgebra algebra term)) + Semantic.Task.Diff terms k -> runTaskC (k (diffTermPair terms)) + Render renderer input k -> runTaskC (k (renderer input)) + Serialize format input k -> do + formatStyle <- asks (bool Plain Colourful . configIsTerminal) + runTaskC (k (runSerialize formatStyle format input))) -- | Log an 'Error.Error' at the specified 'Level'. diff --git a/src/Semantic/Task/Files.hs b/src/Semantic/Task/Files.hs index 1018d8afa..a2e6e9a42 100644 --- a/src/Semantic/Task/Files.hs +++ b/src/Semantic/Task/Files.hs @@ -66,16 +66,15 @@ newtype FilesC m a = FilesC { runFilesC :: m a } instance (Member (Error SomeException) sig, MonadIO m, Carrier sig m) => Carrier (Files :+: sig) (FilesC m) where ret = FilesC . ret - eff = FilesC . (alg \/ eff . handleCoercible) - where alg = \case - Read (FromPath path) k -> (readBlobFromFile' path `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k - Read (FromHandle handle) k -> (readBlobsFromHandle handle `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k - Read (FromPathPair paths) k -> (runBothWith readFilePair paths `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k - Read (FromPairHandle handle) k -> (readBlobPairsFromHandle handle `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k - ReadProject rootDir dir language excludeDirs k -> (readProjectFromPaths rootDir dir language excludeDirs `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k - FindFiles dir exts excludeDirs k -> (findFilesInDir dir exts excludeDirs `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k - Write (ToPath path) builder k -> liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder)) >> runFilesC k - Write (ToHandle (WriteHandle handle)) builder k -> liftIO (B.hPutBuilder handle builder) >> runFilesC k + eff = FilesC . handleSum (eff . handleCoercible) (\case + Read (FromPath path) k -> (readBlobFromFile' path `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k + Read (FromHandle handle) k -> (readBlobsFromHandle handle `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k + Read (FromPathPair paths) k -> (runBothWith readFilePair paths `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k + Read (FromPairHandle handle) k -> (readBlobPairsFromHandle handle `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k + ReadProject rootDir dir language excludeDirs k -> (readProjectFromPaths rootDir dir language excludeDirs `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k + FindFiles dir exts excludeDirs k -> (findFilesInDir dir exts excludeDirs `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k + Write (ToPath path) builder k -> liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder)) >> runFilesC k + Write (ToHandle (WriteHandle handle)) builder k -> liftIO (B.hPutBuilder handle builder) >> runFilesC k) readBlob :: (Member Files sig, Carrier sig m) => File -> m Blob diff --git a/src/Semantic/Telemetry.hs b/src/Semantic/Telemetry.hs index a1ebcb2f4..c4515beb7 100644 --- a/src/Semantic/Telemetry.hs +++ b/src/Semantic/Telemetry.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, KindSignatures, RankNTypes, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, KindSignatures, LambdaCase, RankNTypes, TypeOperators, UndecidableInstances #-} module Semantic.Telemetry ( -- Async telemetry interface @@ -158,9 +158,9 @@ newtype TelemetryC m a = TelemetryC { runTelemetryC :: (LogQueue, StatQueue) -> instance (Carrier sig m, MonadIO m) => Carrier (Telemetry :+: sig) (TelemetryC m) where ret = TelemetryC . const . ret - eff op = TelemetryC (\ queues -> (alg queues \/ eff . handleReader queues runTelemetryC) op) - where alg queues (WriteStat stat k) = queueStat (snd queues) stat *> runTelemetryC k queues - alg queues (WriteLog level message pairs k) = queueLogMessage (fst queues) level message pairs *> runTelemetryC k queues + eff op = TelemetryC (\ queues -> handleSum (eff . handleReader queues runTelemetryC) (\case + WriteStat stat k -> queueStat (snd queues) stat *> runTelemetryC k queues + WriteLog level message pairs k -> queueLogMessage (fst queues) level message pairs *> runTelemetryC k queues) op) -- | Run a 'Telemetry' effect by ignoring statting/logging. @@ -171,6 +171,6 @@ newtype IgnoreTelemetryC m a = IgnoreTelemetryC { runIgnoreTelemetryC :: m a } instance Carrier sig m => Carrier (Telemetry :+: sig) (IgnoreTelemetryC m) where ret = IgnoreTelemetryC . ret - eff = alg \/ (IgnoreTelemetryC . eff . handlePure runIgnoreTelemetryC) - where alg (WriteStat _ k) = k - alg (WriteLog _ _ _ k) = k + eff = handleSum (IgnoreTelemetryC . eff . handlePure runIgnoreTelemetryC) (\case + WriteStat _ k -> k + WriteLog _ _ _ k -> k) diff --git a/src/Semantic/Timeout.hs b/src/Semantic/Timeout.hs index 4540234d5..3af68f870 100644 --- a/src/Semantic/Timeout.hs +++ b/src/Semantic/Timeout.hs @@ -47,7 +47,6 @@ runTimeoutC f (TimeoutC m) = m f instance (Carrier sig m, MonadIO m) => Carrier (Timeout :+: sig) (TimeoutC m) where ret a = TimeoutC (const (ret a)) - eff op = TimeoutC (\ handler -> - ((\ (Timeout n task k) -> liftIO (System.timeout (toMicroseconds n) (handler (runTimeoutC handler task))) >>= runTimeoutC handler . k) - \/ (eff . handlePure (runTimeoutC handler))) - op) + eff op = TimeoutC (\ handler -> handleSum + (eff . handlePure (runTimeoutC handler)) + (\ (Timeout n task k) -> liftIO (System.timeout (toMicroseconds n) (handler (runTimeoutC handler task))) >>= runTimeoutC handler . k) op) diff --git a/vendor/fused-effects b/vendor/fused-effects new file mode 160000 index 000000000..5f11d009d --- /dev/null +++ b/vendor/fused-effects @@ -0,0 +1 @@ +Subproject commit 5f11d009d486b4e7e1741d0d031f8818818856ea diff --git a/vendor/higher-order-effects b/vendor/higher-order-effects deleted file mode 160000 index 9678e1d53..000000000 --- a/vendor/higher-order-effects +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 9678e1d5325392a23b57a47ddc7a52a5250fb304 From f8001765e02a21c3c49b7c3e9f0bcebbc024356a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 29 Oct 2018 09:59:29 -0400 Subject: [PATCH 43/51] Fix a dodgy import. --- src/Analysis/Abstract/Graph.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index 6bdfcfebd..5f33a733b 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -17,7 +17,7 @@ module Analysis.Abstract.Graph ) where import Algebra.Graph.Export.Dot hiding (vertexName) -import Control.Abstract hiding (Function(..), EavesdropC) +import Control.Abstract hiding (Function(..)) import Control.Effect.Carrier import Control.Effect.Sum import Data.Abstract.Address.Hole From 5bf447959707bbb7a6f4484c318f60d780c3dbf2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 29 Oct 2018 10:26:56 -0400 Subject: [PATCH 44/51] :fire: a stray LambdaCase. --- src/Data/Abstract/Value/Type.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index d0cfb94eb..b08b7cd1a 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, LambdaCase, RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances, LambdaCase #-} +{-# LANGUAGE GADTs, LambdaCase, RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-} module Data.Abstract.Value.Type ( Type (..) , TypeError (..) From a7cfa8d1a8bdb7a70f3e25843386d2ebd60162e1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 29 Oct 2018 15:05:44 -0400 Subject: [PATCH 45/51] Rename the higher-order-effects licenses. --- .../cabal/{higher-order-effects.txt => fused-effects.txt} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename .licenses/semantic/cabal/{higher-order-effects.txt => fused-effects.txt} (100%) diff --git a/.licenses/semantic/cabal/higher-order-effects.txt b/.licenses/semantic/cabal/fused-effects.txt similarity index 100% rename from .licenses/semantic/cabal/higher-order-effects.txt rename to .licenses/semantic/cabal/fused-effects.txt From ca81d70c5dccfd3e73061f072777164df3bea982 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 29 Oct 2018 15:07:06 -0400 Subject: [PATCH 46/51] Correct the package name and URL. --- .licenses/semantic/cabal/fused-effects.txt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.licenses/semantic/cabal/fused-effects.txt b/.licenses/semantic/cabal/fused-effects.txt index 185ce3de6..1bfe7d6c8 100644 --- a/.licenses/semantic/cabal/fused-effects.txt +++ b/.licenses/semantic/cabal/fused-effects.txt @@ -1,9 +1,9 @@ --- type: cabal -name: higher-order-effects +name: fused-effects version: 0.1.0.0 summary: Semilattices -homepage: https://github.com/robrix/higher-order-effects +homepage: https://github.com/robrix/fused-effects license: bsd-3-clause --- Copyright (c) 2018, Rob Rix From a14e0d60beacdd27420b971615e9a8a43ea7d343 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 29 Oct 2018 15:08:39 -0400 Subject: [PATCH 47/51] Correct the summaries. --- .licenses/semantic/cabal/fused-effects.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.licenses/semantic/cabal/fused-effects.txt b/.licenses/semantic/cabal/fused-effects.txt index 1bfe7d6c8..498f35e3c 100644 --- a/.licenses/semantic/cabal/fused-effects.txt +++ b/.licenses/semantic/cabal/fused-effects.txt @@ -2,7 +2,7 @@ type: cabal name: fused-effects version: 0.1.0.0 -summary: Semilattices +summary: A fast, flexible, fused effect system, à la Effect Handlers in Scope, Monad Transformers and Modular Algebraic Effects: What Binds Them Together, and Fusion for Free—Efficient Algebraic Effect Handlers. homepage: https://github.com/robrix/fused-effects license: bsd-3-clause --- From 88e9948188233640d8be8c9430c9f72daa829acd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 30 Oct 2018 10:09:58 -0400 Subject: [PATCH 48/51] Quote the summaries. --- .licenses/semantic/cabal/fused-effects.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.licenses/semantic/cabal/fused-effects.txt b/.licenses/semantic/cabal/fused-effects.txt index 498f35e3c..e7370ef7e 100644 --- a/.licenses/semantic/cabal/fused-effects.txt +++ b/.licenses/semantic/cabal/fused-effects.txt @@ -2,7 +2,7 @@ type: cabal name: fused-effects version: 0.1.0.0 -summary: A fast, flexible, fused effect system, à la Effect Handlers in Scope, Monad Transformers and Modular Algebraic Effects: What Binds Them Together, and Fusion for Free—Efficient Algebraic Effect Handlers. +summary: 'A fast, flexible, fused effect system, à la Effect Handlers in Scope, Monad Transformers and Modular Algebraic Effects: What Binds Them Together, and Fusion for Free—Efficient Algebraic Effect Handlers.' homepage: https://github.com/robrix/fused-effects license: bsd-3-clause --- From f29a532615f23ea668ed737a44c21af25e8304f9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 30 Oct 2018 10:12:01 -0400 Subject: [PATCH 49/51] Add the MonadRandom licenses. --- .licenses/semantic/cabal/MonadRandom.txt | 42 ++++++++++++++++++++++++ 1 file changed, 42 insertions(+) create mode 100644 .licenses/semantic/cabal/MonadRandom.txt diff --git a/.licenses/semantic/cabal/MonadRandom.txt b/.licenses/semantic/cabal/MonadRandom.txt new file mode 100644 index 000000000..f617bd3c3 --- /dev/null +++ b/.licenses/semantic/cabal/MonadRandom.txt @@ -0,0 +1,42 @@ +--- +type: cabal +name: MonadRandom +version: 0.5.1.1 +summary: Random-number generation monad. +homepage: +license: other +--- +Copyright (c) 2016, Brent Yorgey + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Brent Yorgey nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +Previous versions of this package were distributed under the simple +permissive license used on the Haskell Wiki; see OLD-LICENSE for +details. \ No newline at end of file From 69918d915320bb70822c6605a238f9d0de41631a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 30 Oct 2018 10:12:53 -0400 Subject: [PATCH 50/51] =?UTF-8?q?Add=20@patrickt=20per=20the=20lib?= =?UTF-8?q?=E2=80=99s=20license.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .licenses/semantic/cabal/fused-effects.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.licenses/semantic/cabal/fused-effects.txt b/.licenses/semantic/cabal/fused-effects.txt index e7370ef7e..f9130ee89 100644 --- a/.licenses/semantic/cabal/fused-effects.txt +++ b/.licenses/semantic/cabal/fused-effects.txt @@ -6,7 +6,7 @@ summary: 'A fast, flexible, fused effect system, à la Effect Handlers in Scope, homepage: https://github.com/robrix/fused-effects license: bsd-3-clause --- -Copyright (c) 2018, Rob Rix +Copyright (c) 2018, Rob Rix and Patrick Thomson All rights reserved. From 93dd5c40b52021925442b96dbb8abb32e5061cbb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 30 Oct 2018 11:52:11 -0400 Subject: [PATCH 51/51] Specify the bsd-3-clause license for MonadRandom. --- .licenses/semantic/cabal/MonadRandom.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.licenses/semantic/cabal/MonadRandom.txt b/.licenses/semantic/cabal/MonadRandom.txt index f617bd3c3..1942db1cb 100644 --- a/.licenses/semantic/cabal/MonadRandom.txt +++ b/.licenses/semantic/cabal/MonadRandom.txt @@ -4,7 +4,7 @@ name: MonadRandom version: 0.5.1.1 summary: Random-number generation monad. homepage: -license: other +license: bsd-3-clause --- Copyright (c) 2016, Brent Yorgey