From 45c3f828d377af6559dde429a271a983a11ef7bc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 11 Dec 2018 13:38:21 -0500 Subject: [PATCH 001/127] :fire: a redundant comment. --- 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 6ae4ae2db..733491b22 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -108,7 +108,7 @@ evaluate lang perModule runTerm modules = do -- | 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. +-- This calls out to the 'Evaluatable' instances, 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 63a5bf4b2588fe58dbc9ec9f3ed336cfc9f9e261 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 11 Dec 2018 13:41:52 -0500 Subject: [PATCH 002/127] Factor perModule into runInModule. --- src/Semantic/Analysis.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 733491b22..569376e64 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -95,7 +95,7 @@ evaluate lang perModule runTerm modules = do _ -> mempty scopeAddress <- newScope scopeEdges frameAddress <- newFrame scopeAddress frameLinks - val <- runInModule scopeAddress frameAddress (perModule (runValueEffects . moduleBody) m) + val <- runInModule scopeAddress frameAddress m pure ((scopeAddress, frameAddress), val) where runInModule scopeAddress frameAddress = runDeref @@ -103,6 +103,7 @@ evaluate lang perModule runTerm modules = do . raiseHandler (runReader (CurrentScope scopeAddress)) . runReturn . runLoopControl + . perModule (runValueEffects . moduleBody) runValueEffects = raiseHandler runInterpose . runBoolean . runWhile . runFunction runTerm . either ((unit <$) . definePrelude) runTerm From 0d7625d9ab476cba9af22a7b80c506d7f98818f4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 11 Dec 2018 13:44:47 -0500 Subject: [PATCH 003/127] Rename runValueEffects to runDomainEffects. --- src/Semantic/Analysis.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 569376e64..3d99102de 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -103,9 +103,9 @@ evaluate lang perModule runTerm modules = do . raiseHandler (runReader (CurrentScope scopeAddress)) . runReturn . runLoopControl - . perModule (runValueEffects . moduleBody) + . perModule (runDomainEffects . moduleBody) - runValueEffects = raiseHandler runInterpose . runBoolean . runWhile . runFunction runTerm . either ((unit <$) . definePrelude) runTerm + runDomainEffects = raiseHandler runInterpose . runBoolean . runWhile . runFunction runTerm . either ((unit <$) . definePrelude) runTerm -- | Evaluate a term recursively, applying the passed function at every recursive position. -- From 40cd003fd3f6d5b06a6ba1c9c7d71d43a4e3816d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 11 Dec 2018 13:53:09 -0500 Subject: [PATCH 004/127] Factor runDomainEffects out of evaluate. --- src/Semantic/Analysis.hs | 36 ++++++++++++++++++++++++++++++++++-- 1 file changed, 34 insertions(+), 2 deletions(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 3d99102de..7ecc934f0 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -103,9 +103,41 @@ evaluate lang perModule runTerm modules = do . raiseHandler (runReader (CurrentScope scopeAddress)) . runReturn . runLoopControl - . perModule (runDomainEffects . moduleBody) + . perModule (runDomainEffects runTerm . moduleBody) - runDomainEffects = raiseHandler runInterpose . runBoolean . runWhile . runFunction runTerm . either ((unit <$) . definePrelude) runTerm +runDomainEffects :: ( AbstractValue term address value (ValueC term address value m) + , Carrier sig m + , booleanC ~ BooleanC value (Eff (InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff m))) + , booleanSig ~ (Boolean value :+: Interpose (Resumable (BaseError (UnspecializedError address 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 Fresh sig + , Member (Reader (CurrentFrame address)) sig + , Member (Reader (CurrentScope address)) sig + , Member (Reader ModuleInfo) sig + , Member (Reader Span) sig + , Member (Resumable (BaseError (AddressError address value))) sig + , Member (Resumable (BaseError (HeapError address))) sig + , Member (Resumable (BaseError (ScopeError address))) sig + , Member (Resumable (BaseError (UnspecializedError address value))) sig + , Member (State (Heap address address value)) sig + , Member (State (ScopeGraph address)) sig + , Member Trace sig + , Ord address + , Show address + ) + => (term -> Evaluator term address value (ValueC term address value m) value) + -> Either (proxy lang) term + -> Evaluator term address value m value +runDomainEffects runTerm = raiseHandler runInterpose . runBoolean . runWhile . runFunction runTerm . either ((unit <$) . definePrelude) runTerm -- | Evaluate a term recursively, applying the passed function at every recursive position. -- From dda1beb2b9bc7768855f696abe0693c291ce355a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 11 Dec 2018 13:53:29 -0500 Subject: [PATCH 005/127] Rename VaueC to DomainC. --- src/Semantic/Analysis.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 7ecc934f0..6ef0290cb 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -24,7 +24,7 @@ type ModuleC address value m ( ReaderC ModuleInfo (Eff m))))))))))))) -type ValueC term address value m +type DomainC term address value m = FunctionC term address value (Eff ( WhileC value (Eff ( BooleanC value (Eff @@ -32,7 +32,7 @@ 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 :: ( AbstractValue term address value (ValueC term address value inner) +evaluate :: ( AbstractValue term address value (DomainC term address value inner) , Carrier innerSig inner , Carrier outerSig outer , derefSig ~ (Deref value :+: allocatorSig) @@ -76,7 +76,7 @@ evaluate :: ( AbstractValue term address value (ValueC term address value inner) => proxy lang -> ( (Module (Either (proxy lang) term) -> Evaluator term address value inner value) -> (Module (Either (proxy lang) term) -> Evaluator term address value (ModuleC address value outer) value)) - -> (term -> Evaluator term address value (ValueC term address value inner) value) + -> (term -> Evaluator term address value (DomainC term address value inner) value) -> [Module term] -> Evaluator term address value outer (ModuleTable (Module (ModuleResult address value))) evaluate lang perModule runTerm modules = do @@ -105,7 +105,7 @@ evaluate lang perModule runTerm modules = do . runLoopControl . perModule (runDomainEffects runTerm . moduleBody) -runDomainEffects :: ( AbstractValue term address value (ValueC term address value m) +runDomainEffects :: ( AbstractValue term address value (DomainC term address value m) , Carrier sig m , booleanC ~ BooleanC value (Eff (InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff m))) , booleanSig ~ (Boolean value :+: Interpose (Resumable (BaseError (UnspecializedError address value))) :+: sig) @@ -134,7 +134,7 @@ runDomainEffects :: ( AbstractValue term address value (ValueC term address valu , Ord address , Show address ) - => (term -> Evaluator term address value (ValueC term address value m) value) + => (term -> Evaluator term address value (DomainC term address value m) value) -> Either (proxy lang) term -> Evaluator term address value m value runDomainEffects runTerm = raiseHandler runInterpose . runBoolean . runWhile . runFunction runTerm . either ((unit <$) . definePrelude) runTerm From 79c04560779adaafa6417011954956dbc7cc7ba2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 11 Dec 2018 13:54:30 -0500 Subject: [PATCH 006/127] Factor the call to moduleBody into runDomainEffects. --- src/Semantic/Analysis.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 6ef0290cb..a822a2867 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -103,7 +103,7 @@ evaluate lang perModule runTerm modules = do . raiseHandler (runReader (CurrentScope scopeAddress)) . runReturn . runLoopControl - . perModule (runDomainEffects runTerm . moduleBody) + . perModule (runDomainEffects runTerm) runDomainEffects :: ( AbstractValue term address value (DomainC term address value m) , Carrier sig m @@ -135,9 +135,9 @@ runDomainEffects :: ( AbstractValue term address value (DomainC term address val , Show address ) => (term -> Evaluator term address value (DomainC term address value m) value) - -> Either (proxy lang) term + -> Module (Either (proxy lang) term) -> Evaluator term address value m value -runDomainEffects runTerm = raiseHandler runInterpose . runBoolean . runWhile . runFunction runTerm . either ((unit <$) . definePrelude) runTerm +runDomainEffects runTerm = raiseHandler runInterpose . runBoolean . runWhile . runFunction runTerm . either ((unit <$) . definePrelude) runTerm . moduleBody -- | Evaluate a term recursively, applying the passed function at every recursive position. -- From 40737635f0063ff2e3a95fae0c22f8b953c75873 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 11 Dec 2018 14:03:09 -0500 Subject: [PATCH 007/127] Factor the domain effects out of evaluate completely. --- src/Semantic/Analysis.hs | 41 +++++++--------------------------------- src/Semantic/Graph.hs | 8 ++++---- src/Semantic/REPL.hs | 2 +- src/Semantic/Util.hs | 6 +++--- 4 files changed, 15 insertions(+), 42 deletions(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index a822a2867..a5bda25db 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TypeFamilies, TypeOperators #-} module Semantic.Analysis ( evaluate +, runDomainEffects , evalTerm ) where @@ -11,6 +12,7 @@ import Data.Abstract.Evaluatable import Data.Abstract.Module import Data.Abstract.ModuleTable as ModuleTable import Data.Function +import Data.Language (Language) import Prologue import qualified Data.Map.Strict as Map @@ -32,54 +34,25 @@ type DomainC term address value m m))))))) -- | Evaluate a list of modules with the prelude for the passed language available, and applying the passed function to every module. -evaluate :: ( AbstractValue term address value (DomainC term address value inner) - , Carrier innerSig inner - , Carrier outerSig outer +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 - , booleanC ~ BooleanC value (Eff (InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff inner))) - , booleanSig ~ (Boolean value :+: Interpose (Resumable (BaseError (UnspecializedError address value))) :+: innerSig) - , Carrier booleanSig booleanC - , whileC ~ WhileC value (Eff booleanC) - , whileSig ~ (While value :+: booleanSig) - , Carrier whileSig whileC - , functionC ~ FunctionC term address value (Eff whileC) - , functionSig ~ (Function term address value :+: whileSig) - , Carrier functionSig functionC , Effect outerSig - , HasPrelude lang , Member Fresh outerSig - , Member (Allocator address) innerSig - , Member (Deref value) innerSig - , Member Fresh innerSig - , Member (Reader ModuleInfo) innerSig , Member (Reader (ModuleTable (Module (ModuleResult address value)))) outerSig - , Member (Reader Span) innerSig - , Member (Resumable (BaseError (AddressError address value))) innerSig - , Member (Resumable (BaseError (UnspecializedError address value))) innerSig - , Member (State (Heap address address value)) innerSig - , Member (State (ScopeGraph address)) innerSig , Member (State (Heap address address value)) outerSig , Member (State (ScopeGraph address)) outerSig - , Member (Reader (CurrentFrame address)) innerSig - , Member (Reader (CurrentScope address)) innerSig - , Member (Resumable (BaseError (HeapError address))) innerSig - , Member (Resumable (BaseError (ScopeError address))) innerSig - , Member Trace innerSig , Ord address - , Show address ) - => proxy lang - -> ( (Module (Either (proxy lang) term) -> Evaluator term address value inner value) - -> (Module (Either (proxy lang) term) -> Evaluator term address value (ModuleC address value outer) value)) - -> (term -> Evaluator term address value (DomainC term address value inner) value) + => proxy (lang :: Language) + -> (Module (Either (proxy lang) term) -> Evaluator term address value (ModuleC address value outer) value) -> [Module term] -> Evaluator term address value outer (ModuleTable (Module (ModuleResult address value))) -evaluate lang perModule runTerm modules = do +evaluate lang runModule modules = do let prelude = Module moduleInfoFromCallStack (Left lang) ((preludeScopeAddress, preludeFrameAddress), _) <- evalModule Nothing Nothing prelude foldr (run preludeScopeAddress preludeFrameAddress . fmap Right) ask modules @@ -103,7 +76,7 @@ evaluate lang perModule runTerm modules = do . raiseHandler (runReader (CurrentScope scopeAddress)) . runReturn . runLoopControl - . perModule (runDomainEffects runTerm) + . runModule runDomainEffects :: ( AbstractValue term address value (DomainC term address value m) , Carrier sig m diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index ef42f3e11..1cff4515b 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -133,9 +133,9 @@ runCallGraph lang includePackages modules package . providingLiveSet . runModuleTable . runModules (ModuleTable.modulePaths (packageModules package)) - $ evaluate lang perModule perTerm modules + $ evaluate lang perModule modules where perTerm = evalTerm (withTermSpans . graphingTerms . cachingTerms) - perModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules + perModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules $ runDomainEffects perTerm runModuleTable :: Carrier sig m @@ -210,7 +210,7 @@ runImportGraph lang (package :: Package term) f . raiseHandler (runReader (lowerBound @Span)) . raiseHandler (runState (lowerBound @(ScopeGraph (Hole (Maybe Name) Precise)))) . runAllocator - $ evaluate lang graphingModuleInfo (evalTerm id) (ModuleTable.toPairs (packageModules package) >>= toList . snd) + $ evaluate lang (graphingModuleInfo (runDomainEffects (evalTerm id))) (ModuleTable.toPairs ( packageModules package) >>= toList . snd) runHeap :: (Carrier sig m, Effect sig) => Evaluator term address value (StateC (Heap address address value) (Eff m)) a @@ -284,7 +284,7 @@ parsePythonPackage parser project = do strat <- case find ((== (projectRootDir project "setup.py")) . filePath) (projectFiles project) of Just setupFile -> do setupModule <- fmap snd <$> parseModule project parser setupFile - fst <$> runAnalysis (evaluate (Proxy @'Language.Python) id (runPythonPackaging . evalTerm id) [ setupModule ]) + fst <$> runAnalysis (evaluate (Proxy @'Language.Python) (runDomainEffects (runPythonPackaging . evalTerm id)) [ setupModule ]) Nothing -> pure PythonPackage.Unknown case strat of PythonPackage.Unknown -> do diff --git a/src/Semantic/REPL.hs b/src/Semantic/REPL.hs index 0f8d11003..808996cb1 100644 --- a/src/Semantic/REPL.hs +++ b/src/Semantic/REPL.hs @@ -92,7 +92,7 @@ repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runD . raiseHandler (runReader (packageInfo package)) . raiseHandler (runState (lowerBound @Span)) . raiseHandler (runReader (lowerBound @Span)) - $ evaluate proxy id (evalTerm (withTermSpans . step (fmap (\ (x:|_) -> moduleBody x) <$> ModuleTable.toPairs (packageModules (fst <$> package))))) modules + $ evaluate proxy (runDomainEffects (evalTerm (withTermSpans . step (fmap (\ (x:|_) -> moduleBody x) <$> ModuleTable.toPairs (packageModules (fst <$> package)))))) modules -- TODO: REPL for typechecking/abstract semantics -- TODO: drive the flow from within the REPL instead of from without diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index dafa1e92a..7901777df 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -111,7 +111,7 @@ evaluateProject' (TaskConfig config logger statter) proxy parser paths = either (raiseHandler (runReader (packageInfo package)) (raiseHandler (evalState (lowerBound @Span)) (raiseHandler (runReader (lowerBound @Span)) - (evaluate proxy id (evalTerm withTermSpans) modules))))))) + (evaluate proxy (runDomainEffects (evalTerm withTermSpans)) modules))))))) evaluatePythonProjects proxy parser lang path = runTaskWithOptions debugOptions $ do project <- readProject Nothing path lang [] @@ -124,7 +124,7 @@ evaluatePythonProjects proxy parser lang path = runTaskWithOptions debugOptions (raiseHandler (runReader (packageInfo package)) (raiseHandler (evalState (lowerBound @Span)) (raiseHandler (runReader (lowerBound @Span)) - (evaluate proxy id (evalTerm withTermSpans) modules))))))) + (evaluate proxy (runDomainEffects (evalTerm withTermSpans)) modules))))))) evaluateProjectWithCaching proxy parser path = runTaskWithOptions debugOptions $ do @@ -137,7 +137,7 @@ evaluateProjectWithCaching proxy parser path = runTaskWithOptions debugOptions $ (raiseHandler (runReader (lowerBound @Span)) (runModuleTable (runModules (ModuleTable.modulePaths (packageModules package)) - (evaluate proxy id (evalTerm withTermSpans) modules))))))) + (evaluate proxy (runDomainEffects (evalTerm withTermSpans)) modules))))))) parseFile :: Parser term -> FilePath -> IO term From f2da4ed031bc1a9f419e796497af2d7839117e99 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 11 Dec 2018 14:09:51 -0500 Subject: [PATCH 008/127] Clean up some remaining vestiges of non-empty module tables. --- src/Data/Abstract/ModuleTable.hs | 6 +++--- src/Data/Abstract/Package.hs | 2 +- src/Semantic/Graph.hs | 6 +++--- src/Semantic/REPL.hs | 2 +- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Data/Abstract/ModuleTable.hs b/src/Data/Abstract/ModuleTable.hs index 773efad03..a79843c43 100644 --- a/src/Data/Abstract/ModuleTable.hs +++ b/src/Data/Abstract/ModuleTable.hs @@ -47,9 +47,9 @@ keys :: ModuleTable a -> [ModulePath] keys = Map.keys . unModuleTable -- | Construct a 'ModuleTable' from a non-empty list of 'Module's. -fromModules :: [Module term] -> ModuleTable (NonEmpty (Module term)) -fromModules modules = ModuleTable (Map.fromListWith (<>) (map toEntry modules)) - where toEntry m = (modulePath (moduleInfo m), m:|[]) +fromModules :: [Module term] -> ModuleTable (Module term) +fromModules = ModuleTable . Map.fromList . map toEntry + where toEntry m = (modulePath (moduleInfo m), m) toPairs :: ModuleTable a -> [(ModulePath, a)] toPairs = Map.toList . unModuleTable diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index d5cfd349b..6a7093130 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -25,7 +25,7 @@ data PackageInfo = PackageInfo -- | A package represents the unit of dependency, i.e. something which can depend upon, or be depended upon by, other packages. Packages have modules and may have entry points from which evaluation can proceed. data Package term = Package { packageInfo :: PackageInfo - , packageModules :: ModuleTable (NonEmpty (Module term)) + , packageModules :: ModuleTable (Module term) } deriving (Eq, Functor, Ord, Show) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 1cff4515b..8dbd65ffc 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -157,7 +157,7 @@ runImportGraphToModuleInfos :: ( Declarations term -> Package term -> Eff m (Graph ControlFlowVertex) runImportGraphToModuleInfos lang (package :: Package term) = runImportGraph lang package allModuleInfos - where allModuleInfos info = maybe (vertex (unknownModuleVertex info)) (foldMap (vertex . moduleVertex . moduleInfo)) (ModuleTable.lookup (modulePath info) (packageModules package)) + where allModuleInfos info = vertex (maybe (unknownModuleVertex info) (moduleVertex . moduleInfo) (ModuleTable.lookup (modulePath info) (packageModules package))) runImportGraphToModules :: ( Declarations term , Evaluatable (Base term) @@ -173,7 +173,7 @@ runImportGraphToModules :: ( Declarations term -> Package term -> Eff m (Graph (Module term)) runImportGraphToModules lang (package :: Package term) = runImportGraph lang package resolveOrLowerBound - where resolveOrLowerBound info = maybe lowerBound (foldMap vertex) (ModuleTable.lookup (modulePath info) (packageModules package)) + where resolveOrLowerBound info = maybe lowerBound vertex (ModuleTable.lookup (modulePath info) (packageModules package)) runImportGraph :: ( Declarations term , Evaluatable (Base term) @@ -210,7 +210,7 @@ runImportGraph lang (package :: Package term) f . raiseHandler (runReader (lowerBound @Span)) . raiseHandler (runState (lowerBound @(ScopeGraph (Hole (Maybe Name) Precise)))) . runAllocator - $ evaluate lang (graphingModuleInfo (runDomainEffects (evalTerm id))) (ModuleTable.toPairs ( packageModules package) >>= toList . snd) + $ evaluate lang (graphingModuleInfo (runDomainEffects (evalTerm id))) (snd <$> ModuleTable.toPairs (packageModules package)) runHeap :: (Carrier sig m, Effect sig) => Evaluator term address value (StateC (Heap address address value) (Eff m)) a diff --git a/src/Semantic/REPL.hs b/src/Semantic/REPL.hs index 808996cb1..ab0447650 100644 --- a/src/Semantic/REPL.hs +++ b/src/Semantic/REPL.hs @@ -92,7 +92,7 @@ repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runD . raiseHandler (runReader (packageInfo package)) . raiseHandler (runState (lowerBound @Span)) . raiseHandler (runReader (lowerBound @Span)) - $ evaluate proxy (runDomainEffects (evalTerm (withTermSpans . step (fmap (\ (x:|_) -> moduleBody x) <$> ModuleTable.toPairs (packageModules (fst <$> package)))))) modules + $ evaluate proxy (runDomainEffects (evalTerm (withTermSpans . step (fmap moduleBody <$> ModuleTable.toPairs (packageModules (fst <$> package)))))) modules -- TODO: REPL for typechecking/abstract semantics -- TODO: drive the flow from within the REPL instead of from without From d4d3aa90ca790c40194258af4373c1a4b683f985 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 11 Dec 2018 15:01:46 -0500 Subject: [PATCH 009/127] Stub in a unit effect. Co-Authored-By: Ayman Nadeem --- src/Control/Abstract/Value.hs | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 73b65f479..e7c24cdfc 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -186,6 +186,18 @@ runWhile = raiseHandler $ runWhileC . interpret newtype WhileC value m a = WhileC { runWhileC :: m a } +data Unit value (m :: * -> *) k + = Unit (value -> k) + deriving (Functor) + +instance HFunctor (Unit value) where + hmap _ = coerce + {-# INLINE hmap #-} + +instance Effect (Unit value) where + handle state handler (Unit k) = Unit (handler . (<$ state) . k) + + class Show value => AbstractIntro value where -- | Construct an abstract unit value. -- TODO: This might be the same as the empty tuple for some value types From bbad0f54ed110443fe6921d24dfa6733c19ed05e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 11 Dec 2018 15:39:03 -0500 Subject: [PATCH 010/127] Export the unit effect. Co-Authored-By: Ayman Nadeem --- src/Control/Abstract/Value.hs | 1 + src/Data/Abstract/Evaluatable.hs | 2 +- src/Data/Abstract/Value/Concrete.hs | 2 +- src/Data/Abstract/Value/Type.hs | 2 +- 4 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index e7c24cdfc..8103d21c5 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -24,6 +24,7 @@ module Control.Abstract.Value , While(..) , runWhile , WhileC(..) +, Unit(..) ) where import Control.Abstract.Evaluator diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 27bee4e32..31cfb0956 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -20,7 +20,7 @@ import Control.Abstract hiding (Load) import Control.Abstract.Context as X import Control.Abstract.Evaluator as X hiding (LoopControl(..), Return(..), catchLoopControl, runLoopControl, catchReturn, runReturn) 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.Value as X hiding (Boolean(..), Function(..), Unit(..), While(..)) import Data.Abstract.BaseError as X import Data.Abstract.Declarations as X import Data.Abstract.FreeVariables as X diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 2b6b38875..69a2d411e 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -9,7 +9,7 @@ module Data.Abstract.Value.Concrete import Control.Abstract.ScopeGraph (Allocator, ScopeError) import Control.Abstract.Heap (scopeLookup) import qualified Control.Abstract as Abstract -import Control.Abstract hiding (Boolean(..), Function(..), While(..)) +import Control.Abstract hiding (Boolean(..), Function(..), Unit(..), While(..)) import Control.Effect.Carrier import Control.Effect.Interpose import Control.Effect.Sum diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index 715563921..72b5af324 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -13,7 +13,7 @@ module Data.Abstract.Value.Type import Control.Abstract.ScopeGraph import qualified Control.Abstract as Abstract -import Control.Abstract hiding (Boolean(..), Function(..), While(..)) +import Control.Abstract hiding (Boolean(..), Function(..), Unit(..), While(..)) import Control.Effect.Carrier import Control.Effect.Sum import Data.Abstract.BaseError From d7550e5b656fc98412ebba85d3c207c5d4bb5047 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 11 Dec 2018 15:39:20 -0500 Subject: [PATCH 011/127] Define a carrier type for Unit. Co-Authored-By: Ayman Nadeem --- src/Control/Abstract/Value.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 8103d21c5..1af4ee011 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -25,6 +25,7 @@ module Control.Abstract.Value , runWhile , WhileC(..) , Unit(..) +, UnitC(..) ) where import Control.Abstract.Evaluator @@ -198,6 +199,7 @@ instance HFunctor (Unit value) where instance Effect (Unit value) where handle state handler (Unit k) = Unit (handler . (<$ state) . k) +newtype UnitC value m a = UnitC { runUnitC :: m a } class Show value => AbstractIntro value where -- | Construct an abstract unit value. From dd50b1f533dc3de6c15b6b9128732c5dc7dde420 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 11 Dec 2018 15:40:11 -0500 Subject: [PATCH 012/127] Define a generic handler for the Unit effect. Co-Authored-By: Ayman Nadeem --- src/Control/Abstract/Value.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 1af4ee011..9596045b9 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -25,6 +25,7 @@ module Control.Abstract.Value , runWhile , WhileC(..) , Unit(..) +, runUnit , UnitC(..) ) where @@ -201,6 +202,11 @@ instance Effect (Unit value) where newtype UnitC value m a = UnitC { runUnitC :: m a } +runUnit :: Carrier (Unit value :+: sig) (UnitC value (Eff m)) + => Evaluator term address value (UnitC value (Eff m)) a + -> Evaluator term address value m a +runUnit = raiseHandler $ runUnitC . interpret + class Show value => AbstractIntro value where -- | Construct an abstract unit value. -- TODO: This might be the same as the empty tuple for some value types From 937728d8582c3091f30bcd3e00281ec007cad352 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 11 Dec 2018 15:40:32 -0500 Subject: [PATCH 013/127] Replace the unit method with the unit effect. Co-Authored-By: Ayman Nadeem --- src/Control/Abstract/Primitive.hs | 6 ++--- src/Control/Abstract/Value.hs | 10 +++++---- src/Data/Abstract/Evaluatable.hs | 4 +++- src/Data/Abstract/Value/Abstract.hs | 11 ++++++++-- src/Data/Abstract/Value/Concrete.hs | 15 ++++++++----- src/Data/Abstract/Value/Type.hs | 11 ++++++++-- src/Data/Syntax.hs | 2 +- src/Data/Syntax/Comment.hs | 2 +- src/Data/Syntax/Declaration.hs | 10 ++++----- src/Data/Syntax/Expression.hs | 4 ++-- src/Data/Syntax/Statement.hs | 8 +++---- src/Language/Go/Syntax.hs | 8 +++---- src/Language/PHP/Syntax.hs | 2 +- src/Language/Python/Syntax.hs | 8 +++---- src/Language/Ruby/Syntax.hs | 6 ++--- src/Language/TypeScript/Syntax/JavaScript.hs | 2 +- src/Language/TypeScript/Syntax/TypeScript.hs | 23 ++++++++++---------- src/Semantic/Analysis.hs | 13 +++++++---- 18 files changed, 87 insertions(+), 58 deletions(-) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 9ac35c5a6..369ad8e54 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -50,8 +50,7 @@ defineBuiltIn declaration value = withCurrentCallStack callStack $ do value <- builtIn associatedScope value assign slot value -defineClass :: ( AbstractValue term address value m - , Carrier sig m +defineClass :: ( Carrier sig m , HasCallStack , Member (Allocator address) sig , Member (Deref value) sig @@ -64,6 +63,7 @@ defineClass :: ( AbstractValue term address value m , Member (Resumable (BaseError (ScopeError address))) sig , Member (State (Heap address address value)) sig , Member (State (ScopeGraph address)) sig + , Member (Unit value) sig , Ord address ) => Declaration @@ -84,7 +84,7 @@ defineClass declaration superclasses body = void . define declaration $ do withScope childScope $ do void body - pure unit + unit defineNamespace :: ( AbstractValue term address value m , Carrier sig m diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 9596045b9..98ca0dfd6 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -24,6 +24,7 @@ module Control.Abstract.Value , While(..) , runWhile , WhileC(..) +, unit , Unit(..) , runUnit , UnitC(..) @@ -189,6 +190,10 @@ runWhile = raiseHandler $ runWhileC . interpret newtype WhileC value m a = WhileC { runWhileC :: m a } +-- | Construct an abstract unit value. +unit :: (Carrier sig m, Member (Unit value) sig) => Evaluator term address value m value +unit = send (Unit ret) + data Unit value (m :: * -> *) k = Unit (value -> k) deriving (Functor) @@ -207,11 +212,8 @@ runUnit :: Carrier (Unit value :+: sig) (UnitC value (Eff m)) -> Evaluator term address value m a runUnit = raiseHandler $ runUnitC . interpret -class Show value => AbstractIntro value where - -- | Construct an abstract unit value. - -- TODO: This might be the same as the empty tuple for some value types - unit :: value +class Show value => AbstractIntro value where -- | Construct an abstract string value. string :: Text -> value diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 31cfb0956..29713a98a 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -65,6 +65,7 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where , Member (Resumable (BaseError ResolutionError)) sig , Member (State (Heap address address value)) sig , Member Trace sig + , Member (Unit value) sig , Ord address , Show address ) @@ -121,6 +122,7 @@ class HasPrelude (language :: Language) where , Member (Reader (CurrentFrame address)) sig , Member (Reader (CurrentScope address)) sig , Member Trace sig + , Member (Unit value) sig , Ord address , Show address ) @@ -305,4 +307,4 @@ instance (Evaluatable s, Show a) => Evaluatable (TermF s a) where -- 3. Only the last statement’s return value is returned. instance Evaluatable [] where -- 'nonEmpty' and 'foldMap1' enable us to return the last statement’s result instead of 'unit' for non-empty lists. - eval eval _ = maybe (pure unit) (runApp . foldMap1 (App . eval)) . nonEmpty + eval eval _ = maybe unit (runApp . foldMap1 (App . eval)) . nonEmpty diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index 4404f50be..5c515f9f2 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -74,7 +74,15 @@ instance ( Member (Abstract.Boolean Abstract) sig (eff . handleCoercible) (\ (Abstract.While cond body k) -> do cond' <- runWhileC cond - ifthenelse cond' (runWhileC body *> empty) (runWhileC (k unit))) + ifthenelse cond' (runWhileC body *> empty) (runWhileC (k Abstract))) + + +instance Carrier sig m + => Carrier (Unit Abstract :+: sig) (UnitC Abstract m) where + ret = UnitC . ret + eff = UnitC . handleSum + (eff . handleCoercible) + (\ (Abstract.Unit k) -> runUnitC (k Abstract)) instance Ord address => ValueRoots address Abstract where @@ -84,7 +92,6 @@ instance AbstractHole Abstract where hole = Abstract instance AbstractIntro Abstract where - unit = Abstract integer _ = Abstract string _ = Abstract float _ = Abstract diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 69a2d411e..071dff090 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -127,12 +127,10 @@ instance ( Member (Reader ModuleInfo) sig Abstract.AsBool other k -> throwBaseError (BoolError other) >>= runBooleanC . k) -instance forall sig m term address. ( Carrier sig m +instance ( Carrier sig m , Member (Abstract.Boolean (Value term address)) sig , Member (Error (LoopControl (Value term address))) sig , Member (Interpose (Resumable (BaseError (UnspecializedError address (Value term address))))) sig - , Show address - , Show term ) => Carrier (Abstract.While (Value term address) :+: sig) (WhileC (Value term address) (Eff m)) where ret = WhileC . ret @@ -152,18 +150,25 @@ instance forall sig m term address. ( Carrier sig m where loop x = catchLoopControl (fix x) $ \case Break value -> pure value - Abort -> pure unit + 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 Carrier sig m + => Carrier (Abstract.Unit (Value term address) :+: sig) (UnitC (Value term address) m) where + ret = UnitC . ret + eff = UnitC . handleSum + (eff . handleCoercible) + (\ (Abstract.Unit k) -> runUnitC (k Unit)) + + instance AbstractHole (Value term address) where hole = Hole instance (Show address, Show term) => AbstractIntro (Value term address) where - unit = Unit integer = Integer . Number.Integer string = String float = Float . Number.Decimal diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index 72b5af324..22f58a2eb 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -316,14 +316,21 @@ instance ( Member (Abstract.Boolean Type) sig (eff . handleCoercible) (\ (Abstract.While cond body k) -> do cond' <- runWhileC cond - ifthenelse cond' (runWhileC body *> empty) (runWhileC (k unit))) + ifthenelse cond' (runWhileC body *> empty) (runWhileC (k Unit))) + + +instance Carrier sig m + => Carrier (Abstract.Unit Type :+: sig) (UnitC Type m) where + ret = UnitC . ret + eff = UnitC . handleSum + (eff . handleCoercible) + (\ (Abstract.Unit k) -> runUnitC (k Unit)) instance AbstractHole Type where hole = Hole instance AbstractIntro Type where - unit = Unit integer _ = Int string _ = String float _ = Float diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index 19ccf18f0..5699a19cb 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -205,7 +205,7 @@ instance Ord1 Empty where liftCompare _ _ _ = EQ instance Show1 Empty where liftShowsPrec _ _ _ _ = showString "Empty" instance Evaluatable Empty where - eval _ _ _ = pure unit + eval _ _ _ = unit instance Tokenize Empty where tokenize = ignore diff --git a/src/Data/Syntax/Comment.hs b/src/Data/Syntax/Comment.hs index e5f1314b8..ce73b44fd 100644 --- a/src/Data/Syntax/Comment.hs +++ b/src/Data/Syntax/Comment.hs @@ -18,7 +18,7 @@ instance Ord1 Comment where liftCompare = genericLiftCompare instance Show1 Comment where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Comment where - eval _ _ _ = pure unit + eval _ _ _ = unit instance Tokenize Comment where tokenize = yield . Run . commentContent diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 127d7eb6e..504868e45 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -160,7 +160,7 @@ instance Ord1 VariableDeclaration where liftCompare = genericLiftCompare instance Show1 VariableDeclaration where liftShowsPrec = genericLiftShowsPrec instance Evaluatable VariableDeclaration where - eval _ _ (VariableDeclaration []) = pure unit + eval _ _ (VariableDeclaration []) = unit eval eval _ (VariableDeclaration decs) = do for_ decs $ \declaration -> do name <- maybeM (throwEvalError NoNameError) (declaredName declaration) @@ -171,7 +171,7 @@ instance Evaluatable VariableDeclaration where pure (subtermSpan, ref) putDeclarationSpan (Declaration name) span - pure unit + unit instance Declarations a => Declarations (VariableDeclaration a) where declaredName (VariableDeclaration vars) = case vars of @@ -209,7 +209,7 @@ instance Evaluatable PublicFieldDefinition where span <- ask @Span propertyName <- maybeM (throwEvalError NoNameError) (declaredName publicFieldPropertyName) declare (Declaration propertyName) span Nothing - pure unit + unit @@ -266,7 +266,7 @@ instance Evaluatable Class where classSlot <- lookupDeclaration (Declaration name) assign classSlot =<< klass (Declaration name) childFrame - pure unit + unit instance Declarations1 Class where liftDeclaredName declaredName = declaredName . classIdentifier @@ -354,7 +354,7 @@ instance Evaluatable TypeAlias where kindSlot <- lookupDeclaration (Declaration kindName) assign slot =<< deref kindSlot - pure unit + unit instance Declarations a => Declarations (TypeAlias a) where declaredName TypeAlias{..} = declaredName typeAliasIdentifier diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index 6064387de..1e119b80d 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -343,7 +343,7 @@ instance Ord1 Delete where liftCompare = genericLiftCompare instance Show1 Delete where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Delete where - eval _ ref (Delete a) = ref a >>= dealloc >> pure unit + eval _ ref (Delete a) = ref a >>= dealloc >> unit -- | A sequence expression such as Javascript or C's comma operator. data SequenceExpression a = SequenceExpression { firstExpression :: !a, secondExpression :: !a } @@ -637,7 +637,7 @@ instance Evaluatable New where name <- maybeM (throwEvalError NoNameError) (declaredName subject) reference (Reference name) (Declaration name) -- TODO: Traverse subterms and instantiate frames from the corresponding scope - pure unit + unit -- | A cast expression to a specified type. data Cast a = Cast { castSubject :: !a, castType :: !a } diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index 87f948fbe..7e30822d5 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -34,7 +34,7 @@ instance ToJSON1 Statements instance Evaluatable Statements where eval eval _ (Statements xs) = - maybe (pure unit) (runApp . foldMap1 (App . eval)) (nonEmpty xs) + maybe unit (runApp . foldMap1 (App . eval)) (nonEmpty xs) instance Tokenize Statements where tokenize = imperative @@ -49,7 +49,7 @@ instance ToJSON1 StatementBlock instance Evaluatable StatementBlock where eval eval _ (StatementBlock xs) = - maybe (pure unit) (runApp . foldMap1 (App . eval)) (nonEmpty xs) + maybe unit (runApp . foldMap1 (App . eval)) (nonEmpty xs) instance Tokenize StatementBlock where tokenize = imperative @@ -156,7 +156,7 @@ instance Evaluatable Let where slot <- lookupDeclaration (Declaration name) assign slot letVal eval letBody - pure unit + unit -- Assignment @@ -318,7 +318,7 @@ instance Ord1 NoOp where liftCompare = genericLiftCompare instance Show1 NoOp where liftShowsPrec = genericLiftShowsPrec instance Evaluatable NoOp where - eval _ _ _ = pure unit + eval _ _ _ = unit -- Loops diff --git a/src/Language/Go/Syntax.hs b/src/Language/Go/Syntax.hs index 2815acfa2..10371d475 100644 --- a/src/Language/Go/Syntax.hs +++ b/src/Language/Go/Syntax.hs @@ -66,7 +66,7 @@ instance Evaluatable Import where ((moduleScope, moduleFrame), _) <- require path insertImportEdge moduleScope insertFrameLink ScopeGraph.Import (Map.singleton moduleScope moduleFrame) - pure unit + unit -- | Qualified Import declarations (symbols are qualified in calling environment). @@ -103,7 +103,7 @@ instance Evaluatable QualifiedImport where insertImportEdge moduleScope fun (Map.singleton moduleScope moduleFrame) go paths - pure unit + unit -- | Side effect only imports (no symbols made available to the calling environment). data SideEffectImport a = SideEffectImport { sideEffectImportFrom :: !ImportPath, sideEffectImportToken :: !a } @@ -119,7 +119,7 @@ instance Evaluatable SideEffectImport where paths <- resolveGoImport importPath traceResolve (unPath importPath) paths for_ paths $ \path -> require path -- Do we need to construct any scope / frames for these side-effect imports? - pure unit + unit -- A composite literal in Go data Composite a = Composite { compositeType :: !a, compositeElement :: !a } @@ -284,7 +284,7 @@ instance Ord1 Package where liftCompare = genericLiftCompare instance Show1 Package where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Package where - eval eval _ (Package _ xs) = maybe (pure unit) (runApp . foldMap1 (App . eval)) (nonEmpty xs) + eval eval _ (Package _ xs) = maybe unit (runApp . foldMap1 (App . eval)) (nonEmpty xs) -- | A type assertion in Go (e.g. `x.(T)` where the value of `x` is not nil and is of type `T`). diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 746040152..fcb8e5501 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -234,7 +234,7 @@ instance Evaluatable QualifiedName where deref address Nothing -> -- TODO: Throw an ReferenceError because we can't find the associated child scope for `obj`. - pure unit + unit newtype NamespaceName a = NamespaceName { names :: NonEmpty a } deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Diffable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1, NFData1) diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index 660e88618..508460e69 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -153,7 +153,7 @@ instance Evaluatable Import where aliasSlot <- lookupDeclaration (Declaration aliasName) assign aliasSlot =<< object aliasFrame - pure unit + unit -- from a import b -- from a import b as c @@ -184,7 +184,7 @@ instance Evaluatable Import where insertImportEdge scopeAddress insertFrameLink ScopeGraph.Import (Map.singleton scopeAddress frameAddress) - pure unit + unit newtype QualifiedImport a = QualifiedImport { qualifiedImportFrom :: NonEmpty String } @@ -213,7 +213,7 @@ instance Evaluatable QualifiedImport where let namesAndPaths = toList (NonEmpty.zip (Data.Abstract.Evaluatable.name . T.pack <$> qualifiedName) modulePaths) go namesAndPaths - pure unit + unit where go [] = pure () go ((name, modulePath) : namesAndPaths) = do @@ -267,7 +267,7 @@ instance Evaluatable QualifiedAliasedImport where insertImportEdge moduleScope insertFrameLink ScopeGraph.Import (Map.singleton moduleScope moduleFrame) - pure unit + unit -- | Ellipsis (used in splice expressions and alternatively can be used as a fill in expression, like `undefined` in Haskell) data Ellipsis a = Ellipsis diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index d6766e9b5..eef0e6438 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -234,7 +234,7 @@ instance Evaluatable Class where classSlot <- lookupDeclaration (Declaration name) assign classSlot =<< klass (Declaration name) childFrame - pure unit + unit instance Declarations1 Class where liftDeclaredName declaredName = declaredName . classIdentifier @@ -262,7 +262,7 @@ instance Evaluatable Module where currentScope' <- currentScope let declaration = Declaration name - moduleBody = maybe (pure unit) (runApp . foldMap1 (App . eval)) (nonEmpty moduleStatements) + moduleBody = maybe unit (runApp . foldMap1 (App . eval)) (nonEmpty moduleStatements) maybeSlot <- maybeLookupDeclaration declaration case maybeSlot of @@ -287,7 +287,7 @@ instance Evaluatable Module where moduleSlot <- lookupDeclaration (Declaration name) assign moduleSlot =<< klass (Declaration name) childFrame - pure unit + unit instance Declarations1 Module where liftDeclaredName declaredName = declaredName . moduleIdentifier diff --git a/src/Language/TypeScript/Syntax/JavaScript.hs b/src/Language/TypeScript/Syntax/JavaScript.hs index 3ec487828..63b627947 100644 --- a/src/Language/TypeScript/Syntax/JavaScript.hs +++ b/src/Language/TypeScript/Syntax/JavaScript.hs @@ -39,7 +39,7 @@ instance Evaluatable JavaScriptRequire where Nothing -> do insertImportEdge moduleScope insertFrameLink ScopeGraph.Import (Map.singleton moduleScope moduleFrame) - pure unit + unit data Debugger a = Debugger deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) diff --git a/src/Language/TypeScript/Syntax/TypeScript.hs b/src/Language/TypeScript/Syntax/TypeScript.hs index d4218a1a3..51241ef4c 100644 --- a/src/Language/TypeScript/Syntax/TypeScript.hs +++ b/src/Language/TypeScript/Syntax/TypeScript.hs @@ -48,7 +48,7 @@ instance Evaluatable Import where -- Create edges from the current scope/frame to the import scope/frame. insertImportEdge scopeAddress insertFrameLink ScopeGraph.Import (Map.singleton scopeAddress frameAddress) - pure unit + unit data QualifiedAliasedImport a = QualifiedAliasedImport { qualifiedAliasedImportAlias :: !a, qualifiedAliasedImportFrom :: ImportPath } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) @@ -72,7 +72,7 @@ instance Evaluatable QualifiedAliasedImport where aliasSlot <- lookupDeclaration (Declaration alias) assign aliasSlot =<< object aliasFrame - pure unit + unit newtype SideEffectImport a = SideEffectImport { sideEffectImportFrom :: ImportPath } @@ -86,7 +86,7 @@ instance Evaluatable SideEffectImport where eval _ _ (SideEffectImport importPath) = do modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions void $ require modulePath - pure unit + unit -- | Qualified Export declarations @@ -109,7 +109,7 @@ instance Evaluatable QualifiedExport where reference (Reference aliasName) (Declaration aliasValue) -- Create an export edge from a new scope to the qualifed export's scope. - pure unit + unit data Alias = Alias { aliasValue :: Name, aliasName :: Name } deriving (Eq, Generic, Hashable, Ord, Show, Message, Named, ToJSON, NFData) @@ -140,7 +140,7 @@ instance Evaluatable QualifiedExportFrom where insertExportEdge exportScope insertFrameLink ScopeGraph.Export (Map.singleton exportScope exportFrame) - pure unit + unit newtype DefaultExport a = DefaultExport { defaultExport :: a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) @@ -166,7 +166,7 @@ instance Evaluatable DefaultExport where insertExportEdge exportScope insertFrameLink ScopeGraph.Export (Map.singleton exportScope exportFrame) Nothing -> throwEvalError DefaultExportError - pure unit + unit -- | Lookup type for a type-level key in a typescript map. @@ -340,7 +340,7 @@ instance Evaluatable TypeIdentifier where eval _ _ TypeIdentifier{..} = do -- Add a reference to the type identifier in the current scope. reference (Reference (Evaluatable.name contents)) (Declaration (Evaluatable.name contents)) - pure unit + unit data NestedIdentifier a = NestedIdentifier { left :: !a, right :: !a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) @@ -418,7 +418,7 @@ instance Evaluatable ExtendsClause where eval eval _ ExtendsClause{..} = do -- Evaluate subterms traverse_ eval extendsClauses - pure unit + unit newtype ArrayType a = ArrayType { arrayType :: a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) @@ -572,6 +572,7 @@ declareModule :: ( AbstractValue term address value m , Member (Resumable (BaseError (AddressError address value))) sig , Member (Resumable (BaseError (HeapError address))) sig , Member (Resumable (BaseError (ScopeError address))) sig + , Member (Unit value) sig , Ord address ) => (term -> Evaluator term address value m value) @@ -584,7 +585,7 @@ declareModule eval identifier statements = do currentScope' <- currentScope let declaration = Declaration name - moduleBody = maybe (pure unit) (runApp . foldMap1 (App . eval)) (nonEmpty statements) + moduleBody = maybe unit (runApp . foldMap1 (App . eval)) (nonEmpty statements) maybeSlot <- maybeLookupDeclaration declaration case maybeSlot of @@ -609,7 +610,7 @@ declareModule eval identifier statements = do moduleSlot <- lookupDeclaration (Declaration name) assign moduleSlot =<< klass (Declaration name) childFrame - pure unit + unit instance Evaluatable Module where eval eval _ Module{..} = declareModule eval moduleIdentifier moduleStatements @@ -687,4 +688,4 @@ instance Evaluatable AbstractClass where classSlot <- lookupDeclaration (Declaration name) assign classSlot =<< klass (Declaration name) childFrame - pure unit + unit diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index a5bda25db..b110586f3 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -30,8 +30,9 @@ type DomainC term address value m = FunctionC term address value (Eff ( WhileC value (Eff ( BooleanC value (Eff + ( UnitC value (Eff ( InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff - 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 @@ -80,8 +81,11 @@ evaluate lang runModule modules = do runDomainEffects :: ( AbstractValue term address value (DomainC term address value m) , Carrier sig m - , booleanC ~ BooleanC value (Eff (InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff m))) - , booleanSig ~ (Boolean value :+: Interpose (Resumable (BaseError (UnspecializedError address value))) :+: sig) + , unitC ~ UnitC value (Eff (InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff m))) + , unitSig ~ (Unit value :+: Interpose (Resumable (BaseError (UnspecializedError address value))) :+: sig) + , Carrier unitSig unitC + , booleanC ~ BooleanC value (Eff unitC) + , booleanSig ~ (Boolean value :+: unitSig) , Carrier booleanSig booleanC , whileC ~ WhileC value (Eff booleanC) , whileSig ~ (While value :+: booleanSig) @@ -110,7 +114,7 @@ runDomainEffects :: ( AbstractValue term address value (DomainC term address val => (term -> Evaluator term address value (DomainC term address value m) value) -> Module (Either (proxy lang) term) -> Evaluator term address value m value -runDomainEffects runTerm = raiseHandler runInterpose . runBoolean . runWhile . runFunction runTerm . either ((unit <$) . definePrelude) runTerm . moduleBody +runDomainEffects runTerm = raiseHandler runInterpose . runUnit . runBoolean . runWhile . runFunction runTerm . either ((unit <*) . definePrelude) runTerm . moduleBody -- | Evaluate a term recursively, applying the passed function at every recursive position. -- @@ -141,6 +145,7 @@ evalTerm :: ( Carrier sig m , Member (Reader (CurrentFrame address)) sig , Member (Reader (CurrentScope address)) sig , Member (State Span) sig + , Member (Unit value) sig , Member (While value) sig , Member Fresh sig , Member Trace sig From 88d77a9843bfb15055b2226b4ee1354c2f3a0010 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 11 Dec 2018 15:50:46 -0500 Subject: [PATCH 014/127] Define a String effect. Co-Authored-By: Ayman Nadeem --- src/Control/Abstract/Value.hs | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 98ca0dfd6..c381b7ad7 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -28,6 +28,7 @@ module Control.Abstract.Value , Unit(..) , runUnit , UnitC(..) +, String(..) ) where import Control.Abstract.Evaluator @@ -40,6 +41,7 @@ import Data.Abstract.Name import Data.Abstract.Number as Number import Data.Scientific (Scientific) import Data.Span +import Prelude hiding (String) import Prologue hiding (TypeError) -- | This datum is passed into liftComparison to handle the fact that Ruby and PHP @@ -212,6 +214,19 @@ runUnit :: Carrier (Unit value :+: sig) (UnitC value (Eff m)) -> Evaluator term address value m a runUnit = raiseHandler $ runUnitC . interpret +data String value (m :: * -> *) k + = String Text (value -> k) + | AsString value (Text -> k) + deriving (Functor) + +instance HFunctor (String value) where + hmap _ = coerce + {-# INLINE hmap #-} + +instance Effect (String value) where + handle state handler (String text k) = String text (handler . (<$ state) . k) + handle state handler (AsString v k) = AsString v (handler . (<$ state) . k) + class Show value => AbstractIntro value where -- | Construct an abstract string value. From 2c5ba75d07e3177c30089abe0583ceec205f51d7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 11 Dec 2018 15:53:59 -0500 Subject: [PATCH 015/127] Avoid importing/re-exporting the String effect. Co-Authored-By: Ayman Nadeem --- src/Data/Abstract/Evaluatable.hs | 2 +- src/Data/Abstract/Value/Concrete.hs | 2 +- src/Data/Abstract/Value/Type.hs | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 29713a98a..0ceb4d1a6 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -20,7 +20,7 @@ import Control.Abstract hiding (Load) import Control.Abstract.Context as X import Control.Abstract.Evaluator as X hiding (LoopControl(..), Return(..), catchLoopControl, runLoopControl, catchReturn, runReturn) import Control.Abstract.Modules as X (Modules, ModuleResult, ResolutionError(..), load, lookupModule, listModulesInDir, require, resolve, throwResolutionError) -import Control.Abstract.Value as X hiding (Boolean(..), Function(..), Unit(..), While(..)) +import Control.Abstract.Value as X hiding (Boolean(..), Function(..), String(..), Unit(..), While(..)) import Data.Abstract.BaseError as X import Data.Abstract.Declarations as X import Data.Abstract.FreeVariables as X diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 071dff090..e7b93135f 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -9,7 +9,7 @@ module Data.Abstract.Value.Concrete import Control.Abstract.ScopeGraph (Allocator, ScopeError) import Control.Abstract.Heap (scopeLookup) import qualified Control.Abstract as Abstract -import Control.Abstract hiding (Boolean(..), Function(..), Unit(..), While(..)) +import Control.Abstract hiding (Boolean(..), Function(..), String(..), Unit(..), While(..)) import Control.Effect.Carrier import Control.Effect.Interpose import Control.Effect.Sum diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index 22f58a2eb..c3fb011e9 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -13,7 +13,7 @@ module Data.Abstract.Value.Type import Control.Abstract.ScopeGraph import qualified Control.Abstract as Abstract -import Control.Abstract hiding (Boolean(..), Function(..), Unit(..), While(..)) +import Control.Abstract hiding (Boolean(..), Function(..), String(..), Unit(..), While(..)) import Control.Effect.Carrier import Control.Effect.Sum import Data.Abstract.BaseError From e4ab7de03399dd75236805ae35cb76ec10e50b55 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 11 Dec 2018 15:55:25 -0500 Subject: [PATCH 016/127] Be even more careful about imports of String. Co-Authored-By: Ayman Nadeem --- 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 0ceb4d1a6..d4a70d814 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -16,7 +16,7 @@ module Data.Abstract.Evaluatable , throwUnspecializedError ) where -import Control.Abstract hiding (Load) +import Control.Abstract hiding (Load, String) import Control.Abstract.Context as X import Control.Abstract.Evaluator as X hiding (LoopControl(..), Return(..), catchLoopControl, runLoopControl, catchReturn, runReturn) import Control.Abstract.Modules as X (Modules, ModuleResult, ResolutionError(..), load, lookupModule, listModulesInDir, require, resolve, throwResolutionError) From b94d42680355b9c109ceea99ccdf4197334ee6c0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 11 Dec 2018 15:57:05 -0500 Subject: [PATCH 017/127] Avoid an import of String. Co-Authored-By: Ayman Nadeem --- src/Language/Ruby/Syntax.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index eef0e6438..077499412 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -7,7 +7,7 @@ import qualified Data.Text as T import Prologue import System.FilePath.Posix -import Control.Abstract as Abstract hiding (Load) +import Control.Abstract as Abstract hiding (Load, String) import Control.Abstract.Heap (Heap, HeapError, insertFrameLink) import Control.Abstract.ScopeGraph (insertImportEdge) import Control.Abstract.Value (Boolean) From 52781c6cd67639eec00ca613f8de5cde3121ecd6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 11 Dec 2018 15:58:33 -0500 Subject: [PATCH 018/127] Class of the symbols Co-Authored-By: Ayman Nadeem --- src/Semantic/Graph.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 8dbd65ffc..246d289b2 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -31,7 +31,7 @@ import Prelude hiding (readFile) import Analysis.Abstract.Caching.FlowInsensitive import Analysis.Abstract.Collecting import Analysis.Abstract.Graph as Graph -import Control.Abstract +import Control.Abstract hiding (String) import Control.Abstract.PythonPackage as PythonPackage import Data.Abstract.Address.Hole as Hole import Data.Abstract.Address.Located as Located From 9c0ca729c93b20f9da19e31e078614b1a33d6789 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 11 Dec 2018 16:01:37 -0500 Subject: [PATCH 019/127] Define a carrier for String. Co-Authored-By: Ayman Nadeem --- src/Control/Abstract/Value.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index c381b7ad7..76f70f1aa 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -29,6 +29,7 @@ module Control.Abstract.Value , runUnit , UnitC(..) , String(..) +, StringC(..) ) where import Control.Abstract.Evaluator @@ -227,6 +228,8 @@ instance Effect (String value) where handle state handler (String text k) = String text (handler . (<$ state) . k) handle state handler (AsString v k) = AsString v (handler . (<$ state) . k) +newtype StringC value m a = StringC { runStringC :: m a } + class Show value => AbstractIntro value where -- | Construct an abstract string value. From e2750c7ffe731bc81575cfb64d17a7a2ec8b1372 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 11 Dec 2018 16:17:12 -0500 Subject: [PATCH 020/127] Liiiiiiint --- src/Control/Abstract/Value.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 76f70f1aa..d61c8ec03 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -197,7 +197,7 @@ newtype WhileC value m a = WhileC { runWhileC :: m a } unit :: (Carrier sig m, Member (Unit value) sig) => Evaluator term address value m value unit = send (Unit ret) -data Unit value (m :: * -> *) k +newtype Unit value (m :: * -> *) k = Unit (value -> k) deriving (Functor) From 89793d2cf5dfba3a97d769a12d359cf0a98a0853 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 11 Dec 2018 17:21:57 -0500 Subject: [PATCH 021/127] Fix the specs. --- test/Analysis/PHP/Spec.hs | 5 +++-- test/Analysis/TypeScript/Spec.hs | 2 +- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/test/Analysis/PHP/Spec.hs b/test/Analysis/PHP/Spec.hs index 3bc7b498b..0ec2a272d 100644 --- a/test/Analysis/PHP/Spec.hs +++ b/test/Analysis/PHP/Spec.hs @@ -3,6 +3,7 @@ module Analysis.PHP.Spec (spec) where import Control.Abstract import Data.Abstract.Evaluatable (EvalError (..)) import qualified Data.Abstract.ModuleTable as ModuleTable +import qualified Data.Abstract.Value.Concrete as Value import qualified Data.Language as Language import qualified Language.PHP.Assignment as PHP import SpecHelpers @@ -15,7 +16,7 @@ spec config = parallel $ do (scopeGraph, (heap, res)) <- evaluate ["main.php", "foo.php", "bar.php"] case ModuleTable.lookup "main.php" <$> res of Right (Just (Module _ (scopeAndFrame, value))) -> do - value `shouldBe` unit + value `shouldBe` Value.Unit const () <$> SpecHelpers.lookupDeclaration "bar" scopeAndFrame heap scopeGraph `shouldBe` Just () const () <$> SpecHelpers.lookupDeclaration "foo" scopeAndFrame heap scopeGraph `shouldBe` Just () other -> expectationFailure (show other) @@ -24,7 +25,7 @@ spec config = parallel $ do (scopeGraph, (heap, res)) <- evaluate ["main_once.php", "foo.php", "bar.php"] case ModuleTable.lookup "main_once.php" <$> res of Right (Just (Module _ (scopeAndFrame, value))) -> do - value `shouldBe` unit + value `shouldBe` Value.Unit const () <$> SpecHelpers.lookupDeclaration "bar" scopeAndFrame heap scopeGraph `shouldBe` Just () const () <$> SpecHelpers.lookupDeclaration "foo" scopeAndFrame heap scopeGraph `shouldBe` Just () other -> expectationFailure (show other) diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index 37ee75308..77d6bf0c2 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -1,7 +1,7 @@ module Analysis.TypeScript.Spec (spec) where import Control.Abstract.ScopeGraph -import Control.Abstract.Value as Value +import Control.Abstract.Value as Value hiding (String, Unit) import Control.Arrow ((&&&)) import Data.Abstract.Evaluatable import qualified Data.Abstract.Heap as Heap From e7bc7e0e31a97c332d515cbb8f4240d3e4c612a7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 12 Dec 2018 09:46:11 -0500 Subject: [PATCH 022/127] Spacing. --- src/Control/Abstract/Value.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index d61c8ec03..3a7645c70 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -215,6 +215,7 @@ runUnit :: Carrier (Unit value :+: sig) (UnitC value (Eff m)) -> Evaluator term address value m a runUnit = raiseHandler $ runUnitC . interpret + data String value (m :: * -> *) k = String Text (value -> k) | AsString value (Text -> k) From 1d4421e5122dd407075e28d30db531e60b2cddad Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 12 Dec 2018 09:47:00 -0500 Subject: [PATCH 023/127] Sort the Unit carrier after its handler. --- 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 3a7645c70..7827a2d26 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -208,13 +208,13 @@ instance HFunctor (Unit value) where instance Effect (Unit value) where handle state handler (Unit k) = Unit (handler . (<$ state) . k) -newtype UnitC value m a = UnitC { runUnitC :: m a } - runUnit :: Carrier (Unit value :+: sig) (UnitC value (Eff m)) => Evaluator term address value (UnitC value (Eff m)) a -> Evaluator term address value m a runUnit = raiseHandler $ runUnitC . interpret +newtype UnitC value m a = UnitC { runUnitC :: m a } + data String value (m :: * -> *) k = String Text (value -> k) From 49785f1718f8434b1d30f7a3f82a5f8136947e0f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 12 Dec 2018 09:47:17 -0500 Subject: [PATCH 024/127] Spacing. --- src/Control/Abstract/Value.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 7827a2d26..d905a321d 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -184,7 +184,6 @@ data While value m k instance HFunctor (While value) where hmap f (While cond body k) = While (f cond) (f body) k - runWhile :: Carrier (While value :+: sig) (WhileC value (Eff m)) => Evaluator term address value (WhileC value (Eff m)) a -> Evaluator term address value m a From 2c0f8b355beacabc81b8821ada6e134d9ad24b27 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 12 Dec 2018 09:48:08 -0500 Subject: [PATCH 025/127] Rename the value effects section to domain effects. --- src/Control/Abstract/Value.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index d905a321d..86b88ca7e 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -3,8 +3,8 @@ module Control.Abstract.Value ( AbstractValue(..) , AbstractIntro(..) , Comparator(..) --- * Value effects --- $valueEffects +-- * Domain effects +-- $domainEffects , function , BuiltIn(..) , builtIn @@ -55,9 +55,9 @@ data Comparator = Concrete (forall a . Ord a => a -> a -> Bool) | Generalized --- Value effects +-- Domain effects --- $valueEffects +-- $domainEffects -- Value effects are effects modelling the /introduction/ & /elimination/ of some specific kind of value. -- -- Modelling each of these as effects has several advantages∷ From 85e9f211449d71c1d1ab2beef742d19bedcf20e3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 12 Dec 2018 09:48:42 -0500 Subject: [PATCH 026/127] Alignment. --- src/Control/Abstract/Value.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 86b88ca7e..c4b3bcebb 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -87,9 +87,9 @@ sendFunction :: (Member (Function term address value) sig, Carrier sig m) => Fun sendFunction = send data Function term address value (m :: * -> *) k - = Function Name [Name] term address (value -> k) -- ^ A function is parameterized by its name, parameter names, body, parent scope, and returns a ValueRef. - | BuiltIn address BuiltIn (value -> k) -- ^ A built-in is parameterized by its parent scope, BuiltIn type, and returns a value. - | Call value [value] (value -> k) -- ^ A Call takes a set of values as parameters and returns a ValueRef. + = Function Name [Name] term address (value -> k) -- ^ A function is parameterized by its name, parameter names, body, parent scope, and returns a ValueRef. + | BuiltIn address BuiltIn (value -> k) -- ^ A built-in is parameterized by its parent scope, BuiltIn type, and returns a value. + | Call value [value] (value -> k) -- ^ A Call takes a set of values as parameters and returns a ValueRef. deriving (Functor) instance HFunctor (Function term address value) where From c0ad2987b52557f0f0f343b1f20e8ec3c2605f8c Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Wed, 12 Dec 2018 11:57:11 -0500 Subject: [PATCH 027/127] add runString --- src/Control/Abstract/Value.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index c4b3bcebb..731e0409d 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -30,6 +30,7 @@ module Control.Abstract.Value , UnitC(..) , String(..) , StringC(..) +, runString ) where import Control.Abstract.Evaluator @@ -230,6 +231,14 @@ instance Effect (String value) where newtype StringC value m a = StringC { runStringC :: m a } +runString :: Carrier (String value :+: sig) (StringC value (Eff m)) + -- Have to mention String because we don't know what the value type is + -- Enables single effect handler function across abstract, concret, type + -- Allows us to define something once in evaluate in Semantic.Analysis + -- instead of crazy composition + => Evaluator term address value (StringC value (Eff m)) a + -> Evaluator term address value m a +runString = raiseHandler $ runStringC . interpret class Show value => AbstractIntro value where -- | Construct an abstract string value. From 191723db94dd7c0e37a379d8b7f9338d2ee8b504 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Wed, 12 Dec 2018 12:15:14 -0500 Subject: [PATCH 028/127] create string carrier instance for abstract domain --- src/Data/Abstract/Value/Abstract.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index 5c515f9f2..a8115019b 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -84,6 +84,13 @@ instance Carrier sig m (eff . handleCoercible) (\ (Abstract.Unit k) -> runUnitC (k Abstract)) +instance Carrier sig m + => Carrier (Abstract.String Abstract :+: sig) (StringC Abstract m) where + ret = StringC . ret + eff = StringC . handleSum + (eff . handleCoercible) (\case + Abstract.String _ k -> runStringC (k Abstract) + AsString _ k -> runStringC (k "")) instance Ord address => ValueRoots address Abstract where valueRoots = mempty From ca687a66a73dcfd9b9205545bd335cc97d074709 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Wed, 12 Dec 2018 12:27:34 -0500 Subject: [PATCH 029/127] create string carrier instance for type-checking domain --- src/Data/Abstract/Value/Type.hs | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index c3fb011e9..bcbf6a1c3 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -326,6 +326,19 @@ instance Carrier sig m (eff . handleCoercible) (\ (Abstract.Unit k) -> runUnitC (k Unit)) +instance ( Member (Reader ModuleInfo) sig + , Member (Reader Span) sig + , Member (Resumable (BaseError TypeError)) sig + , Member (State TypeMap) sig + , Carrier sig m + , Alternative m + , Monad m + ) + => Carrier (Abstract.String Type :+: sig) (StringC Type m) where + ret = StringC . ret + eff = StringC . handleSum (eff . handleCoercible) (\case + Abstract.String _ k -> runStringC (k String) + Abstract.AsString t k -> unify t String *> runStringC (k "")) instance AbstractHole Type where hole = Hole From 53924d1a156246e6f98ffdc32562f439505606ef Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Wed, 12 Dec 2018 12:28:18 -0500 Subject: [PATCH 030/127] clean up formatting --- src/Data/Abstract/Value/Abstract.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index a8115019b..e09299f2a 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -87,10 +87,9 @@ instance Carrier sig m instance Carrier sig m => Carrier (Abstract.String Abstract :+: sig) (StringC Abstract m) where ret = StringC . ret - eff = StringC . handleSum - (eff . handleCoercible) (\case - Abstract.String _ k -> runStringC (k Abstract) - AsString _ k -> runStringC (k "")) + eff = StringC . handleSum (eff . handleCoercible) (\case + Abstract.String _ k -> runStringC (k Abstract) + AsString _ k -> runStringC (k "")) instance Ord address => ValueRoots address Abstract where valueRoots = mempty From 9f54d28253face84765feaa10256eb4f1b5e9f27 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Wed, 12 Dec 2018 12:40:56 -0500 Subject: [PATCH 031/127] create string carrier instance for concrete domain --- src/Data/Abstract/Value/Concrete.hs | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index e7b93135f..b2928aab3 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -164,6 +164,18 @@ instance Carrier sig m (eff . handleCoercible) (\ (Abstract.Unit k) -> runUnitC (k Unit)) +instance ( Member (Reader ModuleInfo) sig + , Member (Reader Span) sig + , Member (Resumable (BaseError (ValueError term address))) sig + , Carrier sig m + , Monad m + ) + => Carrier (Abstract.String (Value term address) :+: sig) (StringC (Value term address) m) where + ret = StringC . ret + eff = StringC . handleSum (eff . handleCoercible) (\case + Abstract.String t k -> runStringC (k (String t)) + Abstract.AsString (String t) k -> runStringC (k t) + Abstract.AsString other k -> throwBaseError (StringError other) >>= runStringC . k) instance AbstractHole (Value term address) where hole = Hole From bfd755fbda25bfc9d2d2052fa52e256fb33efecb Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Wed, 12 Dec 2018 12:52:56 -0500 Subject: [PATCH 032/127] provide string effect --- src/Semantic/Analysis.hs | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index b110586f3..d268eddfd 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -5,7 +5,7 @@ module Semantic.Analysis , evalTerm ) where -import Control.Abstract +import Control.Abstract as Abstract import Control.Abstract.ScopeGraph (runAllocator) import Control.Effect.Interpose import Data.Abstract.Evaluatable @@ -30,9 +30,10 @@ type DomainC term address value m = FunctionC term address value (Eff ( WhileC value (Eff ( BooleanC value (Eff + ( StringC value (Eff ( UnitC value (Eff ( InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff - 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 @@ -84,8 +85,11 @@ runDomainEffects :: ( AbstractValue term address value (DomainC term address val , unitC ~ UnitC value (Eff (InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff m))) , unitSig ~ (Unit value :+: Interpose (Resumable (BaseError (UnspecializedError address value))) :+: sig) , Carrier unitSig unitC - , booleanC ~ BooleanC value (Eff unitC) - , booleanSig ~ (Boolean value :+: unitSig) + , stringC ~ StringC value (Eff unitC) + , stringSig ~ (Abstract.String value :+: unitSig) + , Carrier stringSig stringC + , booleanC ~ BooleanC value (Eff stringC) + , booleanSig ~ (Boolean value :+: stringSig) , Carrier booleanSig booleanC , whileC ~ WhileC value (Eff booleanC) , whileSig ~ (While value :+: booleanSig) @@ -114,7 +118,7 @@ runDomainEffects :: ( AbstractValue term address value (DomainC term address val => (term -> Evaluator term address value (DomainC term address value m) value) -> Module (Either (proxy lang) term) -> Evaluator term address value m value -runDomainEffects runTerm = raiseHandler runInterpose . runUnit . runBoolean . runWhile . runFunction runTerm . either ((unit <*) . definePrelude) runTerm . moduleBody +runDomainEffects runTerm = raiseHandler runInterpose . runUnit . runString . runBoolean . runWhile . runFunction runTerm . either ((unit <*) . definePrelude) runTerm . moduleBody -- | Evaluate a term recursively, applying the passed function at every recursive position. -- From 1764aeb492ee97d2f5728ac715c272d3226a25a3 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Wed, 12 Dec 2018 13:51:59 -0500 Subject: [PATCH 033/127] defined string and asString using the effect --- src/Control/Abstract/PythonPackage.hs | 4 +++- src/Control/Abstract/Value.hs | 16 ++++++++++------ src/Data/Abstract/Evaluatable.hs | 2 ++ src/Data/Abstract/Value/Abstract.hs | 2 -- src/Data/Abstract/Value/Concrete.hs | 5 ----- src/Data/Abstract/Value/Type.hs | 2 -- src/Data/Syntax/Directive.hs | 2 +- src/Data/Syntax/Literal.hs | 2 +- src/Language/PHP/Syntax.hs | 6 +++--- src/Semantic/Analysis.hs | 1 + 10 files changed, 21 insertions(+), 21 deletions(-) diff --git a/src/Control/Abstract/PythonPackage.hs b/src/Control/Abstract/PythonPackage.hs index 228a28ba8..c7d2d94ff 100644 --- a/src/Control/Abstract/PythonPackage.hs +++ b/src/Control/Abstract/PythonPackage.hs @@ -2,7 +2,7 @@ module Control.Abstract.PythonPackage ( runPythonPackaging, Strategy(..) ) where -import Control.Abstract +import Control.Abstract as Abstract import Control.Effect.Carrier import Control.Effect.Sum import Data.Abstract.Evaluatable @@ -21,6 +21,7 @@ runPythonPackaging :: ( Carrier sig m , Show term , Member Trace sig , Member (Boolean (Value term address)) sig + , Member (Abstract.String (Value term address)) sig , Member (State (Heap address address (Value term address))) sig , Member (Resumable (BaseError (AddressError address (Value term address)))) sig , Member (Resumable (BaseError (ValueError term address))) sig @@ -59,6 +60,7 @@ instance ( Carrier sig m , Member (Resumable (BaseError (ValueError term address))) sig , Member (State (Heap address address (Value term address))) sig , Member (State Strategy) sig + , Member (Abstract.String (Value term address)) sig , Member Trace sig , Ord address , Show address diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 731e0409d..aceb41ee0 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -28,6 +28,8 @@ module Control.Abstract.Value , Unit(..) , runUnit , UnitC(..) +, string +, asString , String(..) , StringC(..) , runString @@ -216,6 +218,14 @@ runUnit = raiseHandler $ runUnitC . interpret newtype UnitC value m a = UnitC { runUnitC :: m a } +-- | Construct a String value in the abstract domain. +string :: (Member (String value) sig, Carrier sig m) => Text -> m value +string t = send (String t ret) + +-- | Extract 'Text' from a given value. +asString :: (Member (String value) sig, Carrier sig m) => value -> m Text +asString v = send (AsString v ret) + data String value (m :: * -> *) k = String Text (value -> k) | AsString value (Text -> k) @@ -241,9 +251,6 @@ runString :: Carrier (String value :+: sig) (StringC value (Eff m)) runString = raiseHandler $ runStringC . interpret class Show value => AbstractIntro value where - -- | Construct an abstract string value. - string :: Text -> value - -- | Construct a self-evaluating symbol value. -- TODO: Should these be interned in some table to provide stronger uniqueness guarantees? symbol :: Text -> value @@ -314,9 +321,6 @@ class AbstractIntro value => AbstractValue term address value carrier where -- | Extract the contents of a key-value pair as a tuple. asPair :: value -> Evaluator term address value carrier (value, value) - -- | Extract a 'Text' from a given value. - asString :: value -> Evaluator term address value carrier Text - -- | @index x i@ computes @x[i]@, with zero-indexing. index :: value -> value -> Evaluator term address value carrier value diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index d4a70d814..4a1bdf0d2 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -17,6 +17,7 @@ module Data.Abstract.Evaluatable ) where import Control.Abstract hiding (Load, String) +import qualified Control.Abstract as Abstract import Control.Abstract.Context as X import Control.Abstract.Evaluator as X hiding (LoopControl(..), Return(..), catchLoopControl, runLoopControl, catchReturn, runReturn) import Control.Abstract.Modules as X (Modules, ModuleResult, ResolutionError(..), load, lookupModule, listModulesInDir, require, resolve, throwResolutionError) @@ -55,6 +56,7 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where , Member (Reader PackageInfo) sig , Member (Reader Span) sig , Member (State Span) sig + , Member (Abstract.String value) sig , Member (Reader (CurrentFrame address)) sig , Member (Reader (CurrentScope address)) sig , Member (Resumable (BaseError (ScopeError address))) sig diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index e09299f2a..3ae9ec482 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -99,7 +99,6 @@ instance AbstractHole Abstract where instance AbstractIntro Abstract where integer _ = Abstract - string _ = Abstract float _ = Abstract symbol _ = Abstract regex _ = Abstract @@ -118,7 +117,6 @@ instance AbstractValue term address Abstract m where scopedEnvironment _ = pure Nothing - asString _ = pure "" asPair _ = pure (Abstract, Abstract) asArray _ = pure mempty diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index b2928aab3..542fef645 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -182,7 +182,6 @@ instance AbstractHole (Value term address) where instance (Show address, Show term) => AbstractIntro (Value term address) where integer = Integer . Number.Integer - string = String float = Float . Number.Decimal symbol = Symbol rational = Rational . Number.Ratio @@ -235,10 +234,6 @@ instance ( Member (Allocator address) sig | Namespace _ address <- v = pure (Just address) | otherwise = pure Nothing - asString v - | String n <- v = pure n - | otherwise = throwValueError $ StringError v - index = go where tryIdx list ii diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index bcbf6a1c3..017101457 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -345,7 +345,6 @@ instance AbstractHole Type where instance AbstractIntro Type where integer _ = Int - string _ = String float _ = Float symbol _ = Symbol regex _ = Regex @@ -377,7 +376,6 @@ instance ( Member Fresh sig object _ = pure Object - asString t = unify t String $> "" asPair t = do t1 <- fresh t2 <- fresh diff --git a/src/Data/Syntax/Directive.hs b/src/Data/Syntax/Directive.hs index 94f7d9784..f6fcb819e 100644 --- a/src/Data/Syntax/Directive.hs +++ b/src/Data/Syntax/Directive.hs @@ -23,7 +23,7 @@ instance Ord1 File where liftCompare = genericLiftCompare instance Show1 File where liftShowsPrec = genericLiftShowsPrec instance Evaluatable File where - eval _ _ File = string . T.pack . modulePath <$> currentModule + eval _ _ File = currentModule >>= string . T.pack . modulePath -- We may need a separate token class for these given additional languages instance Tokenize File where diff --git a/src/Data/Syntax/Literal.hs b/src/Data/Syntax/Literal.hs index 6b0cb76e2..5d24f6ddc 100644 --- a/src/Data/Syntax/Literal.hs +++ b/src/Data/Syntax/Literal.hs @@ -155,7 +155,7 @@ instance Ord1 TextElement where liftCompare = genericLiftCompare instance Show1 TextElement where liftShowsPrec = genericLiftShowsPrec instance Evaluatable TextElement where - eval _ _ (TextElement x) = pure (string x) + eval _ _ (TextElement x) = string x instance Tokenize TextElement where tokenize = yield . Run . textElementContent diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index fcb8e5501..3aad15796 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -2,6 +2,7 @@ {-# OPTIONS_GHC -Wno-missing-export-lists #-} module Language.PHP.Syntax where +import Control.Abstract as Abstract import Data.Abstract.BaseError import Data.Abstract.Evaluatable as Abstract import Data.Abstract.Module @@ -12,7 +13,6 @@ import qualified Data.Text as T import Diffing.Algorithm import Prologue hiding (Text) import Proto3.Suite.Class -import Control.Abstract import qualified Data.Abstract.ScopeGraph as ScopeGraph import qualified Data.Map.Strict as Map @@ -55,8 +55,7 @@ resolvePHPName n = do where name = toName n toName = T.unpack . dropRelativePrefix . stripQuotes -include :: ( AbstractValue term address value m - , Carrier sig m +include :: ( Carrier sig m , Member (Modules address value) sig , Member (Reader (CurrentFrame address)) sig , Member (Reader (CurrentScope address)) sig @@ -66,6 +65,7 @@ include :: ( AbstractValue term address value m , Member (State (ScopeGraph address)) sig , Member (Resumable (BaseError ResolutionError)) sig , Member (State (Heap address address value)) sig + , Member (Abstract.String value) sig , Member Trace sig , Ord address ) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index d268eddfd..ea569982b 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -146,6 +146,7 @@ evalTerm :: ( Carrier sig m , Member (Resumable (BaseError ResolutionError)) sig , Member (State (Heap address address value)) sig , Member (State (ScopeGraph address)) sig + , Member (Abstract.String value) sig , Member (Reader (CurrentFrame address)) sig , Member (Reader (CurrentScope address)) sig , Member (State Span) sig From 062ad8b0831c16dcd8fa7a0686fa93dabf89a43c Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Wed, 12 Dec 2018 15:55:56 -0500 Subject: [PATCH 034/127] remove symbol --- src/Control/Abstract/Value.hs | 2 -- src/Data/Abstract/Value/Abstract.hs | 1 - src/Data/Abstract/Value/Concrete.hs | 1 - src/Data/Abstract/Value/Type.hs | 1 - src/Data/Syntax/Literal.hs | 2 +- 5 files changed, 1 insertion(+), 6 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index aceb41ee0..ec967796e 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -253,8 +253,6 @@ runString = raiseHandler $ runStringC . interpret class Show value => AbstractIntro value where -- | Construct a self-evaluating symbol value. -- TODO: Should these be interned in some table to provide stronger uniqueness guarantees? - symbol :: Text -> value - -- | Construct an abstract regex value. regex :: Text -> value diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index 3ae9ec482..8b7640f4b 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -100,7 +100,6 @@ instance AbstractHole Abstract where instance AbstractIntro Abstract where integer _ = Abstract float _ = Abstract - symbol _ = Abstract regex _ = Abstract rational _ = Abstract hash _ = Abstract diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 542fef645..750eaf1f9 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -183,7 +183,6 @@ instance AbstractHole (Value term address) where instance (Show address, Show term) => AbstractIntro (Value term address) where integer = Integer . Number.Integer float = Float . Number.Decimal - symbol = Symbol rational = Rational . Number.Ratio regex = Regex diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index 017101457..0f7e044c3 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -346,7 +346,6 @@ instance AbstractHole Type where instance AbstractIntro Type where integer _ = Int float _ = Float - symbol _ = Symbol regex _ = Regex rational _ = Rational hash = Hash diff --git a/src/Data/Syntax/Literal.hs b/src/Data/Syntax/Literal.hs index 5d24f6ddc..73991a932 100644 --- a/src/Data/Syntax/Literal.hs +++ b/src/Data/Syntax/Literal.hs @@ -215,7 +215,7 @@ instance Ord1 SymbolElement where liftCompare = genericLiftCompare instance Show1 SymbolElement where liftShowsPrec = genericLiftShowsPrec instance Evaluatable SymbolElement where - eval _ _ (SymbolElement s) = pure (symbol s) + eval _ _ (SymbolElement s) = string s instance Tokenize SymbolElement where tokenize = yield . Run . symbolContent From 1676dbd99903699e629a3c0c49efde50a8b2a711 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Wed, 12 Dec 2018 15:59:32 -0500 Subject: [PATCH 035/127] remove regex --- src/Control/Abstract/Value.hs | 5 ----- src/Data/Abstract/Value/Abstract.hs | 1 - src/Data/Abstract/Value/Concrete.hs | 1 - src/Data/Abstract/Value/Type.hs | 1 - src/Data/Syntax/Literal.hs | 2 +- 5 files changed, 1 insertion(+), 9 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index ec967796e..64ac9884e 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -251,11 +251,6 @@ runString :: Carrier (String value :+: sig) (StringC value (Eff m)) runString = raiseHandler $ runStringC . interpret class Show value => AbstractIntro value where - -- | Construct a self-evaluating symbol value. - -- TODO: Should these be interned in some table to provide stronger uniqueness guarantees? - -- | Construct an abstract regex value. - regex :: Text -> value - -- | Construct an abstract integral value. integer :: Integer -> value diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index 8b7640f4b..59dedde82 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -100,7 +100,6 @@ instance AbstractHole Abstract where instance AbstractIntro Abstract where integer _ = Abstract float _ = Abstract - regex _ = Abstract rational _ = Abstract hash _ = Abstract kvPair _ _ = Abstract diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 750eaf1f9..9f1d05682 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -184,7 +184,6 @@ instance (Show address, Show term) => AbstractIntro (Value term address) where integer = Integer . Number.Integer float = Float . Number.Decimal rational = Rational . Number.Ratio - regex = Regex kvPair = KVPair hash = Hash . map (uncurry KVPair) diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index 0f7e044c3..e44f36cf7 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -346,7 +346,6 @@ instance AbstractHole Type where instance AbstractIntro Type where integer _ = Int float _ = Float - regex _ = Regex rational _ = Rational hash = Hash kvPair k v = k :* v diff --git a/src/Data/Syntax/Literal.hs b/src/Data/Syntax/Literal.hs index 73991a932..8e739007c 100644 --- a/src/Data/Syntax/Literal.hs +++ b/src/Data/Syntax/Literal.hs @@ -231,7 +231,7 @@ instance Show1 Regex where liftShowsPrec = genericLiftShowsPrec -- TODO: Implement Eval instance for Regex instance Evaluatable Regex where - eval _ _ (Regex x) = pure (regex x) + eval _ _ (Regex x) = string x instance Tokenize Regex where tokenize = yield . Run . regexContent From 7260da9e7ddfb7a7f903a6bb277822bbe77040a0 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Wed, 12 Dec 2018 16:03:45 -0500 Subject: [PATCH 036/127] remove symbol and regex constructors --- src/Data/Abstract/Value/Concrete.hs | 2 -- src/Data/Abstract/Value/Type.hs | 4 ---- 2 files changed, 6 deletions(-) diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 9f1d05682..37303de03 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -36,8 +36,6 @@ data Value term address | Rational (Number.Number Rational) | Float (Number.Number Scientific) | String Text - | Symbol Text - | Regex Text | Tuple [Value term address] | Array [Value term address] | Class Declaration [Value term address] address diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index e44f36cf7..92a545139 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -29,8 +29,6 @@ data Type = Int -- ^ Primitive int type. | Bool -- ^ Primitive boolean type. | String -- ^ Primitive string type. - | Symbol -- ^ Type of unique symbols. - | Regex -- ^ Primitive regex type. | Unit -- ^ The unit type. | Float -- ^ Floating-point type. | Rational -- ^ Rational type. @@ -168,8 +166,6 @@ occur id = prune >=> \case Int -> pure False Bool -> pure False String -> pure False - Symbol -> pure False - Regex -> pure False Unit -> pure False Float -> pure False Rational -> pure False From d46e7e13b5527eb919de8c263c0a3c63581d112f Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Wed, 12 Dec 2018 16:24:17 -0500 Subject: [PATCH 037/127] add Numeric effect --- src/Control/Abstract/Value.hs | 25 +++++++++++++++++++++++++ src/Data/Abstract/Evaluatable.hs | 2 +- src/Data/Abstract/Value/Concrete.hs | 2 +- src/Data/Abstract/Value/Type.hs | 2 +- 4 files changed, 28 insertions(+), 3 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 64ac9884e..d4dfa3ba4 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -33,6 +33,9 @@ module Control.Abstract.Value , String(..) , StringC(..) , runString +, Numeric(..) +, NumericC(..) +, runNumeric ) where import Control.Abstract.Evaluator @@ -250,6 +253,28 @@ runString :: Carrier (String value :+: sig) (StringC value (Eff m)) -> Evaluator term address value m a runString = raiseHandler $ runStringC . interpret +data Numeric value (m :: * -> *) k + = Integer Integer (value -> k) + | Float Scientific (value -> k) + | Rational Rational (value -> k) + | LiftNumeric (forall a . Num a => a -> a) value (value -> k) + | LiftNumeric2 (forall a b. Number a -> Number b -> SomeNumber) value value (value -> k) + deriving (Functor) + +instance HFunctor (Numeric value) where + hmap _ = coerce + {-# INLINE hmap #-} + +instance Effect (Numeric value) where + handle state handler = coerce . fmap (handler . (<$ state)) + +newtype NumericC value m a = NumericC { runNumericC :: m a } + +runNumeric :: Carrier (Numeric value :+: sig) (NumericC value (Eff m)) + => Evaluator term address value (NumericC value (Eff m)) a + -> Evaluator term address value m a +runNumeric = raiseHandler $ runNumericC . interpret + class Show value => AbstractIntro value where -- | Construct an abstract integral value. integer :: Integer -> value diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 4a1bdf0d2..b90741998 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -21,7 +21,7 @@ import qualified Control.Abstract as Abstract import Control.Abstract.Context as X import Control.Abstract.Evaluator as X hiding (LoopControl(..), Return(..), catchLoopControl, runLoopControl, catchReturn, runReturn) import Control.Abstract.Modules as X (Modules, ModuleResult, ResolutionError(..), load, lookupModule, listModulesInDir, require, resolve, throwResolutionError) -import Control.Abstract.Value as X hiding (Boolean(..), Function(..), String(..), Unit(..), While(..)) +import Control.Abstract.Value as X hiding (Boolean(..), Function(..), Numeric(..), String(..), Unit(..), While(..)) import Data.Abstract.BaseError as X import Data.Abstract.Declarations as X import Data.Abstract.FreeVariables as X diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 37303de03..43a2af8ba 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -9,7 +9,7 @@ module Data.Abstract.Value.Concrete import Control.Abstract.ScopeGraph (Allocator, ScopeError) import Control.Abstract.Heap (scopeLookup) import qualified Control.Abstract as Abstract -import Control.Abstract hiding (Boolean(..), Function(..), String(..), Unit(..), While(..)) +import Control.Abstract hiding (Boolean(..), Function(..), Numeric(..), String(..), Unit(..), While(..)) import Control.Effect.Carrier import Control.Effect.Interpose import Control.Effect.Sum diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index 92a545139..70a14b4e3 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -13,7 +13,7 @@ module Data.Abstract.Value.Type import Control.Abstract.ScopeGraph import qualified Control.Abstract as Abstract -import Control.Abstract hiding (Boolean(..), Function(..), String(..), Unit(..), While(..)) +import Control.Abstract hiding (Boolean(..), Function(..), Numeric(..), String(..), Unit(..), While(..)) import Control.Effect.Carrier import Control.Effect.Sum import Data.Abstract.BaseError From e953380aaf7baa47f294368e531168fc005cb9bb Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Wed, 12 Dec 2018 16:59:46 -0500 Subject: [PATCH 038/127] add numeric carrier instance to abstract domain --- src/Data/Abstract/Value/Abstract.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index 59dedde82..aa60bd21f 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -91,6 +91,16 @@ instance Carrier sig m Abstract.String _ k -> runStringC (k Abstract) AsString _ k -> runStringC (k "")) +instance Carrier sig m + => Carrier (Numeric Abstract :+: sig) (NumericC Abstract m) where + ret = NumericC . ret + eff = NumericC . handleSum (eff . handleCoercible) (\case + Integer _ k -> runNumericC (k Abstract) + Float _ k -> runNumericC (k Abstract) + Rational _ k -> runNumericC (k Abstract) + LiftNumeric _ _ k -> runNumericC (k Abstract) + LiftNumeric2 _ _ _ k -> runNumericC (k Abstract)) + instance Ord address => ValueRoots address Abstract where valueRoots = mempty From 1ccc6c08958b0ae11320d322851ad861e89dfc13 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Wed, 12 Dec 2018 17:01:11 -0500 Subject: [PATCH 039/127] add numeric carrier instance to type --- src/Data/Abstract/Value/Type.hs | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index 70a14b4e3..08f8da95e 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -336,6 +336,25 @@ instance ( Member (Reader ModuleInfo) sig Abstract.String _ k -> runStringC (k String) Abstract.AsString t k -> unify t String *> runStringC (k "")) +instance ( Member (Reader ModuleInfo) sig + , Member (Reader Span) sig + , Member (Resumable (BaseError TypeError)) sig + , Member (State TypeMap) sig + , Carrier sig m + , Monad m + ) + => Carrier (Abstract.Numeric Type :+: sig) (NumericC Type m) where + ret = NumericC . ret + eff = NumericC . handleSum (eff . handleCoercible) (\case + Abstract.Integer _ k -> runNumericC (k Int) + Abstract.Float _ k -> runNumericC (k Float) + Abstract.Rational _ k -> runNumericC (k Rational) + Abstract.LiftNumeric _ t k -> unify (Int :+ Float :+ Rational) t >>= runNumericC . k + Abstract.LiftNumeric2 _ left right k -> case (left, right) of + (Float, Int) -> runNumericC (k Float) + (Int, Float) -> runNumericC (k Float) + _ -> unify left right >>= runNumericC . k) + instance AbstractHole Type where hole = Hole From 5611368f64308b6eeb61e54947dcd63743bcae87 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Wed, 12 Dec 2018 17:47:39 -0500 Subject: [PATCH 040/127] add numeric carrier instance to concrete domain --- src/Data/Abstract/Value/Concrete.hs | 49 +++++++++++++++++++++++++++-- 1 file changed, 46 insertions(+), 3 deletions(-) diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 43a2af8ba..f087cfb09 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -175,13 +175,56 @@ instance ( Member (Reader ModuleInfo) sig Abstract.AsString (String t) k -> runStringC (k t) Abstract.AsString other k -> throwBaseError (StringError other) >>= runStringC . k) +instance ( Member (Reader ModuleInfo) sig + , Member (Reader Span) sig + , Member (Resumable (BaseError (ValueError term address))) sig + , Carrier sig m + , Monad m + ) + => Carrier (Abstract.Numeric (Value term address) :+: sig) (NumericC (Value term address) m) where + ret = NumericC . ret + eff = NumericC . handleSum (eff . handleCoercible) (\case + Abstract.Integer t k -> runNumericC (k (Integer (Number.Integer t))) + Abstract.Float t k -> runNumericC (k (Float (Number.Decimal t))) + Abstract.Rational t k -> runNumericC (k (Rational (Number.Ratio t))) + Abstract.LiftNumeric f arg k -> runNumericC . k =<< case arg of + Integer (Number.Integer i) -> pure $ Integer (Number.Integer (f i)) + Float (Number.Decimal d) -> pure $ Float (Number.Decimal (f d)) + Rational (Number.Ratio r) -> pure $ Rational (Number.Ratio (f r)) + other -> throwBaseError (NumericError other) + Abstract.LiftNumeric2 f left right k -> runNumericC . k =<< case (left, right) of + (Integer i, Integer j) -> attemptUnsafeArithmetic (f i j) & specialize + (Integer i, Rational j) -> attemptUnsafeArithmetic (f i j) & specialize + (Integer i, Float j) -> attemptUnsafeArithmetic (f i j) & specialize + (Rational i, Integer j) -> attemptUnsafeArithmetic (f i j) & specialize + (Rational i, Rational j) -> attemptUnsafeArithmetic (f i j) & specialize + (Rational i, Float j) -> attemptUnsafeArithmetic (f i j) & specialize + (Float i, Integer j) -> attemptUnsafeArithmetic (f i j) & specialize + (Float i, Rational j) -> attemptUnsafeArithmetic (f i j) & specialize + (Float i, Float j) -> attemptUnsafeArithmetic (f i j) & specialize + _ -> throwBaseError (Numeric2Error left right)) + +-- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor +specialize :: ( Member (Reader ModuleInfo) sig + , Member (Reader Span) sig + , Member (Resumable (BaseError (ValueError term address))) sig + , Carrier sig m + , Monad m + ) + => Either ArithException Number.SomeNumber + -> m (Value term address) +specialize (Left exc) = throwBaseError (ArithmeticError exc) +specialize (Right (Number.SomeNumber (Number.Integer t))) = pure (Integer (Number.Integer t)) +specialize (Right (Number.SomeNumber (Number.Decimal t))) = pure (Float (Number.Decimal t)) +specialize (Right (Number.SomeNumber (Number.Ratio t))) = pure (Rational (Number.Ratio t)) + instance AbstractHole (Value term address) where hole = Hole instance (Show address, Show term) => AbstractIntro (Value term address) where - integer = Integer . Number.Integer - float = Float . Number.Decimal - rational = Rational . Number.Ratio + integer t = Integer (Number.Integer t) + float t = Float (Number.Decimal t) + rational t = Rational (Number.Ratio t) kvPair = KVPair hash = Hash . map (uncurry KVPair) From 6f25df9080cacf3a71376e3909e5934cf5985028 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 13 Dec 2018 11:07:18 -0500 Subject: [PATCH 041/127] :fire: reference to the Symbol constructor. --- test/Control/Abstract/Evaluator/Spec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Control/Abstract/Evaluator/Spec.hs b/test/Control/Abstract/Evaluator/Spec.hs index 896b0f329..1addf7109 100644 --- a/test/Control/Abstract/Evaluator/Spec.hs +++ b/test/Control/Abstract/Evaluator/Spec.hs @@ -116,5 +116,5 @@ instance FreeVariables SpecEff where freeVariables _ = lowerBound instance Declarations SpecEff where declaredName eff = case unsafePerformIO (evaluate (runSpecEff eff)) of - (_, (_, (_, Right (Value.Symbol text)))) -> Just (SpecHelpers.name text) + (_, (_, (_, Right (Value.String text)))) -> Just (SpecHelpers.name text) _ -> error "declaredName for SpecEff should return an RVal" From 52863de0e315e0a729c747350343e1cf30668234 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 13 Dec 2018 11:10:08 -0500 Subject: [PATCH 042/127] Fix alignment. --- test/Analysis/TypeScript/Spec.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index 77d6bf0c2..8865c2516 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -101,7 +101,7 @@ spec config = parallel $ do (_, (_, res)) <- evaluate ["void.ts"] case ModuleTable.lookup "void.ts" <$> res of Right (Just (Module _ (_, value))) -> value `shouldBe` Null - other -> expectationFailure (show other) + other -> expectationFailure (show other) it "evaluates delete" $ do (scopeGraph, (heap, res)) <- evaluate ["delete.ts"] @@ -132,31 +132,31 @@ spec config = parallel $ do (_, (_, res)) <- evaluate ["band.ts"] case ModuleTable.lookup "band.ts" <$> res of Right (Just (Module _ (_, value))) -> value `shouldBe` Value.Integer (Number.Integer 0) - other -> expectationFailure (show other) + other -> expectationFailure (show other) it "evaluates BXOr statements" $ do (_, (_, res)) <- evaluate ["bxor.ts"] case ModuleTable.lookup "bxor.ts" <$> res of Right (Just (Module _ (_, value))) -> value `shouldBe` Value.Integer (Number.Integer 3) - other -> expectationFailure (show other) + other -> expectationFailure (show other) it "evaluates LShift statements" $ do (_, (_, res)) <- evaluate ["lshift.ts"] case ModuleTable.lookup "lshift.ts" <$> res of Right (Just (Module _ (_, value))) -> value `shouldBe` Value.Integer (Number.Integer 4) - other -> expectationFailure (show other) + other -> expectationFailure (show other) it "evaluates RShift statements" $ do (_, (_, res)) <- evaluate ["rshift.ts"] case ModuleTable.lookup "rshift.ts" <$> res of Right (Just (Module _ (_, value))) -> value `shouldBe` Value.Integer (Number.Integer 0) - other -> expectationFailure (show other) + other -> expectationFailure (show other) it "evaluates Complement statements" $ do (_, (_, res)) <- evaluate ["complement.ts"] case ModuleTable.lookup "complement.ts" <$> res of Right (Just (Module _ (_, value))) -> value `shouldBe` Value.Integer (Number.Integer (-2)) - other -> expectationFailure (show other) + other -> expectationFailure (show other) where From 916e0acf260dc9c9d1dda4e4d1fbb616184ec075 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 13 Dec 2018 11:11:08 -0500 Subject: [PATCH 043/127] Fix ambiguous references to the Integer constructor. --- test/Analysis/TypeScript/Spec.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index 8865c2516..7ac072cc9 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -10,7 +10,7 @@ import qualified Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Number as Number import Data.Abstract.Package (PackageInfo (..)) import qualified Data.Abstract.ScopeGraph as ScopeGraph -import Data.Abstract.Value.Concrete as Value +import Data.Abstract.Value.Concrete as Concrete import qualified Data.Language as Language import qualified Data.List.NonEmpty as NonEmpty import Data.Location @@ -94,7 +94,7 @@ spec config = parallel $ do (scopeGraph, (heap, res)) <- evaluate ["sequence-expression.ts"] case ModuleTable.lookup "sequence-expression.ts" <$> res of Right (Just (Module _ (scopeAndFrame, value))) -> - SpecHelpers.lookupDeclaration "x" scopeAndFrame heap scopeGraph `shouldBe` Just [ Value.float (scientific 3 0) ] + SpecHelpers.lookupDeclaration "x" scopeAndFrame heap scopeGraph `shouldBe` Just [ Concrete.float (Number.Decimal (scientific 3 0)) ] other -> expectationFailure (show other) it "evaluates void expressions" $ do @@ -125,37 +125,37 @@ spec config = parallel $ do (_, (_, res)) <- evaluate ["bor.ts"] case ModuleTable.lookup "bor.ts" <$> res of Right (Just (Module _ (_, value))) -> - value `shouldBe` Value.Integer (Number.Integer 3) + value `shouldBe` Concrete.Integer (Number.Integer 3) other -> expectationFailure (show other) it "evaluates BAnd statements" $ do (_, (_, res)) <- evaluate ["band.ts"] case ModuleTable.lookup "band.ts" <$> res of - Right (Just (Module _ (_, value))) -> value `shouldBe` Value.Integer (Number.Integer 0) + Right (Just (Module _ (_, value))) -> value `shouldBe` Concrete.Integer (Number.Integer 0) other -> expectationFailure (show other) it "evaluates BXOr statements" $ do (_, (_, res)) <- evaluate ["bxor.ts"] case ModuleTable.lookup "bxor.ts" <$> res of - Right (Just (Module _ (_, value))) -> value `shouldBe` Value.Integer (Number.Integer 3) + Right (Just (Module _ (_, value))) -> value `shouldBe` Concrete.Integer (Number.Integer 3) other -> expectationFailure (show other) it "evaluates LShift statements" $ do (_, (_, res)) <- evaluate ["lshift.ts"] case ModuleTable.lookup "lshift.ts" <$> res of - Right (Just (Module _ (_, value))) -> value `shouldBe` Value.Integer (Number.Integer 4) + Right (Just (Module _ (_, value))) -> value `shouldBe` Concrete.Integer (Number.Integer 4) other -> expectationFailure (show other) it "evaluates RShift statements" $ do (_, (_, res)) <- evaluate ["rshift.ts"] case ModuleTable.lookup "rshift.ts" <$> res of - Right (Just (Module _ (_, value))) -> value `shouldBe` Value.Integer (Number.Integer 0) + Right (Just (Module _ (_, value))) -> value `shouldBe` Concrete.Integer (Number.Integer 0) other -> expectationFailure (show other) it "evaluates Complement statements" $ do (_, (_, res)) <- evaluate ["complement.ts"] case ModuleTable.lookup "complement.ts" <$> res of - Right (Just (Module _ (_, value))) -> value `shouldBe` Value.Integer (Number.Integer (-2)) + Right (Just (Module _ (_, value))) -> value `shouldBe` Concrete.Integer (Number.Integer (-2)) other -> expectationFailure (show other) From ace844a00494d296bf65966faa4dddec2793fa77 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 13 Dec 2018 11:34:56 -0500 Subject: [PATCH 044/127] Use the Float constructor. --- test/Analysis/TypeScript/Spec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index 7ac072cc9..a1898ced6 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -94,7 +94,7 @@ spec config = parallel $ do (scopeGraph, (heap, res)) <- evaluate ["sequence-expression.ts"] case ModuleTable.lookup "sequence-expression.ts" <$> res of Right (Just (Module _ (scopeAndFrame, value))) -> - SpecHelpers.lookupDeclaration "x" scopeAndFrame heap scopeGraph `shouldBe` Just [ Concrete.float (Number.Decimal (scientific 3 0)) ] + SpecHelpers.lookupDeclaration "x" scopeAndFrame heap scopeGraph `shouldBe` Just [ Concrete.Float (Number.Decimal (scientific 3 0)) ] other -> expectationFailure (show other) it "evaluates void expressions" $ do From cf4afae2a3ba695628a760890fd10c8e38e80b8d Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 14 Dec 2018 11:12:56 -0500 Subject: [PATCH 045/127] provide numeric effect --- src/Semantic/Analysis.hs | 12 ++++++++---- vendor/haskell-tree-sitter | 2 +- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index ea569982b..6edb11e12 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -31,9 +31,10 @@ type DomainC term address value m ( WhileC value (Eff ( BooleanC value (Eff ( StringC value (Eff + ( NumericC value (Eff ( UnitC value (Eff ( InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff - 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 @@ -85,8 +86,11 @@ runDomainEffects :: ( AbstractValue term address value (DomainC term address val , unitC ~ UnitC value (Eff (InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff m))) , unitSig ~ (Unit value :+: Interpose (Resumable (BaseError (UnspecializedError address value))) :+: sig) , Carrier unitSig unitC - , stringC ~ StringC value (Eff unitC) - , stringSig ~ (Abstract.String value :+: unitSig) + , numericC ~ NumericC value (Eff unitC) + , numericSig ~ (Abstract.Numeric value :+: unitSig) + , Carrier numericSig numericC + , stringC ~ StringC value (Eff numericC) + , stringSig ~ (Abstract.String value :+: numericSig) , Carrier stringSig stringC , booleanC ~ BooleanC value (Eff stringC) , booleanSig ~ (Boolean value :+: stringSig) @@ -118,7 +122,7 @@ runDomainEffects :: ( AbstractValue term address value (DomainC term address val => (term -> Evaluator term address value (DomainC term address value m) value) -> Module (Either (proxy lang) term) -> Evaluator term address value m value -runDomainEffects runTerm = raiseHandler runInterpose . runUnit . runString . runBoolean . runWhile . runFunction runTerm . either ((unit <*) . definePrelude) runTerm . moduleBody +runDomainEffects runTerm = raiseHandler runInterpose . runUnit . runNumeric . runString . runBoolean . runWhile . runFunction runTerm . either ((unit <*) . definePrelude) runTerm . moduleBody -- | Evaluate a term recursively, applying the passed function at every recursive position. -- diff --git a/vendor/haskell-tree-sitter b/vendor/haskell-tree-sitter index 8cf6eebf8..bc73f2fb6 160000 --- a/vendor/haskell-tree-sitter +++ b/vendor/haskell-tree-sitter @@ -1 +1 @@ -Subproject commit 8cf6eebf82fc5052a737682667d7983d71659516 +Subproject commit bc73f2fb67dbbeba41d3a4b1a5a12be29fad3789 From b24c5d5ebb2ac39aad072034b1e183609aad2fcc Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 14 Dec 2018 11:23:49 -0500 Subject: [PATCH 046/127] eval can use Numeric --- src/Data/Abstract/Evaluatable.hs | 1 + src/Semantic/Analysis.hs | 1 + 2 files changed, 2 insertions(+) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index b90741998..616775b79 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -52,6 +52,7 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where , Member Fresh sig , Member (Function term address value) sig , Member (Modules address value) sig + , Member (Numeric value) sig , Member (Reader ModuleInfo) sig , Member (Reader PackageInfo) sig , Member (Reader Span) sig diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 6edb11e12..e2198bf4d 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -139,6 +139,7 @@ evalTerm :: ( Carrier sig m , Member (Error (Return value)) sig , Member (Function term address value) sig , Member (Modules address value) sig + , Member (Numeric value) sig , Member (Reader ModuleInfo) sig , Member (Reader PackageInfo) sig , Member (Reader Span) sig From 6849fd86100f23002bda1a3886af5a5ecfb16b8c Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 14 Dec 2018 13:17:38 -0500 Subject: [PATCH 047/127] use the Numeric effect --- src/Control/Abstract/Value.hs | 59 ++++++++++++++++++----------- src/Data/Abstract/Value/Abstract.hs | 6 --- src/Data/Abstract/Value/Concrete.hs | 56 +++------------------------ src/Data/Abstract/Value/Type.hs | 9 ----- src/Data/Syntax/Directive.hs | 2 +- src/Data/Syntax/Literal.hs | 6 +-- 6 files changed, 47 insertions(+), 91 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index d4dfa3ba4..88ea1946c 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -33,6 +33,11 @@ module Control.Abstract.Value , String(..) , StringC(..) , runString +, integer +, float +, rational +, liftNumeric +, liftNumeric2 , Numeric(..) , NumericC(..) , runNumeric @@ -45,7 +50,7 @@ import Control.Effect.Carrier import Data.Abstract.BaseError import Data.Abstract.Module import Data.Abstract.Name -import Data.Abstract.Number as Number +import Data.Abstract.Number (Number, SomeNumber) import Data.Scientific (Scientific) import Data.Span import Prelude hiding (String) @@ -253,6 +258,37 @@ runString :: Carrier (String value :+: sig) (StringC value (Eff m)) -> Evaluator term address value m a runString = raiseHandler $ runStringC . interpret + +-- | Construct an abstract integral value. +integer :: (Member (Numeric value) sig, Carrier sig m) => Integer -> m value +integer t = send (Integer t ret) + +-- | Construct a floating-point value. +float :: (Member (Numeric value) sig, Carrier sig m) => Scientific -> m value +float t = send (Float t ret) + +-- | Construct a rational value. +rational :: (Member (Numeric value) sig, Carrier sig m) => Rational -> m value +rational t = send (Rational t ret) + +-- | Lift a unary operator over a 'Num' to a function on 'value's. +liftNumeric :: (Member (Numeric value) sig, Carrier sig m) + => (forall a . Num a => a -> a) + -> value + -> m value +liftNumeric t v = send (LiftNumeric t v ret) + +-- | Lift a pair of binary operators to a function on 'value's. +-- You usually pass the same operator as both arguments, except in the cases where +-- Haskell provides different functions for integral and fractional operations, such +-- as division, exponentiation, and modulus. +liftNumeric2 :: (Member (Numeric value) sig, Carrier sig m) + => (forall a b. Number a -> Number b -> SomeNumber) + -> value + -> value + -> m value +liftNumeric2 t v1 v2 = send (LiftNumeric2 t v1 v2 ret) + data Numeric value (m :: * -> *) k = Integer Integer (value -> k) | Float Scientific (value -> k) @@ -276,15 +312,6 @@ runNumeric :: Carrier (Numeric value :+: sig) (NumericC value (Eff m)) runNumeric = raiseHandler $ runNumericC . interpret class Show value => AbstractIntro value where - -- | Construct an abstract integral value. - integer :: Integer -> value - - -- | Construct a floating-point value. - float :: Scientific -> value - - -- | Construct a rational value. - rational :: Rational -> value - -- | Construct a key-value pair for use in a hash. kvPair :: value -> value -> value @@ -301,18 +328,6 @@ class AbstractIntro value => AbstractValue term address value carrier where -- | Cast numbers to integers castToInteger :: value -> Evaluator term address value carrier value - - -- | Lift a unary operator over a 'Num' to a function on 'value's. - liftNumeric :: (forall a . Num a => a -> a) - -> (value -> Evaluator term address value carrier value) - - -- | Lift a pair of binary operators to a function on 'value's. - -- You usually pass the same operator as both arguments, except in the cases where - -- Haskell provides different functions for integral and fractional operations, such - -- as division, exponentiation, and modulus. - liftNumeric2 :: (forall a b. Number a -> Number b -> SomeNumber) - -> (value -> value -> Evaluator term address value carrier value) - -- | Lift a Comparator (usually wrapping a function like == or <=) to a function on values. liftComparison :: Comparator -> (value -> value -> Evaluator term address value carrier value) diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index aa60bd21f..68fbf6617 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -108,9 +108,6 @@ instance AbstractHole Abstract where hole = Abstract instance AbstractIntro Abstract where - integer _ = Abstract - float _ = Abstract - rational _ = Abstract hash _ = Abstract kvPair _ _ = Abstract null = Abstract @@ -130,9 +127,6 @@ instance AbstractValue term address Abstract m where index _ _ = pure Abstract - liftNumeric _ _ = pure Abstract - liftNumeric2 _ _ _ = pure Abstract - liftBitwise _ _ = pure Abstract liftBitwise2 _ _ _ = pure Abstract diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index f087cfb09..6f84b1878 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -222,30 +222,16 @@ instance AbstractHole (Value term address) where hole = Hole instance (Show address, Show term) => AbstractIntro (Value term address) where - integer t = Integer (Number.Integer t) - float t = Float (Number.Decimal t) - rational t = Rational (Number.Ratio t) - kvPair = KVPair hash = Hash . map (uncurry KVPair) null = Null -- | Construct a 'Value' wrapping the value arguments (if any). -instance ( Member (Allocator address) sig - , Member (Abstract.Boolean (Value term address)) sig - , Member (Deref (Value term address)) sig - , Member (Error (LoopControl (Value term address))) sig - , Member (Error (Return (Value term address))) sig - , Member Fresh sig +instance ( Member (Abstract.Boolean (Value term address)) sig , Member (Reader ModuleInfo) sig - , Member (Reader PackageInfo) sig , Member (Reader Span) sig , Member (Resumable (BaseError (ValueError term address))) sig - , Member (Resumable (BaseError (AddressError address (Value term address)))) sig - , Member (State (Heap address address (Value term address))) sig - , Member Trace sig - , Ord address , Show address , Show term , Carrier sig m @@ -283,36 +269,6 @@ instance ( Member (Allocator address) sig | (Tuple tup, Integer (Number.Integer i)) <- (arr, idx) = tryIdx tup i | otherwise = throwValueError (IndexError arr idx) - liftNumeric f arg - | Integer (Number.Integer i) <- arg = pure . integer $ f i - | Float (Number.Decimal d) <- arg = pure . float $ f d - | Rational (Number.Ratio r) <- arg = pure . rational $ f r - | otherwise = throwValueError (NumericError arg) - - liftNumeric2 f left right - | (Integer i, Integer j) <- pair = tentative f i j & specialize - | (Integer i, Rational j) <- pair = tentative f i j & specialize - | (Integer i, Float j) <- pair = tentative f i j & specialize - | (Rational i, Integer j) <- pair = tentative f i j & specialize - | (Rational i, Rational j) <- pair = tentative f i j & specialize - | (Rational i, Float j) <- pair = tentative f i j & specialize - | (Float i, Integer j) <- pair = tentative f i j & specialize - | (Float i, Rational j) <- pair = tentative f i j & specialize - | (Float i, Float j) <- pair = tentative f i j & specialize - | otherwise = throwValueError (Numeric2Error left right) - where - tentative x i j = attemptUnsafeArithmetic (x i j) - - -- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor - specialize :: AbstractValue term address (Value term address) m - => Either ArithException Number.SomeNumber - -> Evaluator term address (Value term address) m (Value term address) - specialize (Left exc) = throwValueError (ArithmeticError exc) - specialize (Right (Number.SomeNumber (Number.Integer i))) = pure $ integer i - specialize (Right (Number.SomeNumber (Number.Ratio r))) = pure $ rational r - specialize (Right (Number.SomeNumber (Number.Decimal d))) = pure $ float d - pair = (left, right) - liftComparison comparator left right | (Integer (Number.Integer i), Integer (Number.Integer j)) <- pair = go i j | (Integer (Number.Integer i), Float (Number.Decimal j)) <- pair = go (fromIntegral i) j @@ -325,10 +281,10 @@ instance ( Member (Allocator address) sig where -- Explicit type signature is necessary here because we're passing all sorts of things -- to these comparison functions. - go :: (AbstractValue term address (Value term address) m, Ord a) => a -> a -> Evaluator term address (Value term address) m (Value term address) + go :: Ord a => a -> a -> Evaluator term address (Value term address) m (Value term address) go l r = case comparator of Concrete f -> boolean (f l r) - Generalized -> pure $ integer (orderingToInt (compare l r)) + Generalized -> pure $ Integer (Number.Integer (orderingToInt (compare l r))) -- Map from [LT, EQ, GT] to [-1, 0, 1] orderingToInt :: Ordering -> Prelude.Integer @@ -337,17 +293,17 @@ instance ( Member (Allocator address) sig pair = (left, right) liftBitwise operator target - | Integer (Number.Integer i) <- target = pure . integer $ operator i + | Integer (Number.Integer i) <- target = pure . Integer . Number.Integer $ operator i | otherwise = throwValueError (BitwiseError target) liftBitwise2 operator left right - | (Integer (Number.Integer i), Integer (Number.Integer j)) <- pair = pure . integer $ operator i j + | (Integer (Number.Integer i), Integer (Number.Integer j)) <- pair = pure . Integer . Number.Integer $ operator i j | otherwise = throwValueError (Bitwise2Error left right) where pair = (left, right) unsignedRShift left right | (Integer (Number.Integer i), Integer (Number.Integer j)) <- pair = - if i >= 0 then pure . integer $ ourShift (fromIntegral i) (fromIntegral j) + if i >= 0 then pure . Integer . Number.Integer $ ourShift (fromIntegral i) (fromIntegral j) else throwValueError (Bitwise2Error left right) | otherwise = throwValueError (Bitwise2Error left right) where diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index 08f8da95e..fde9326f7 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -359,9 +359,6 @@ instance AbstractHole Type where hole = Hole instance AbstractIntro Type where - integer _ = Int - float _ = Float - rational _ = Rational hash = Hash kvPair k v = k :* v @@ -403,12 +400,6 @@ instance ( Member Fresh sig _ <- unify (Array (Var field)) arr pure (Var field) - liftNumeric _ = unify (Int :+ Float :+ Rational) - liftNumeric2 _ left right = case (left, right) of - (Float, Int) -> pure Float - (Int, Float) -> pure Float - _ -> unify left right - liftBitwise _ = unify Int liftBitwise2 _ t1 t2 = unify Int t1 >>= flip unify t2 diff --git a/src/Data/Syntax/Directive.hs b/src/Data/Syntax/Directive.hs index f6fcb819e..d4887bd61 100644 --- a/src/Data/Syntax/Directive.hs +++ b/src/Data/Syntax/Directive.hs @@ -39,7 +39,7 @@ instance Ord1 Line where liftCompare = genericLiftCompare instance Show1 Line where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Line where - eval _ _ Line = integer . fromIntegral . posLine . spanStart <$> currentSpan + eval _ _ Line = currentSpan >>= integer . fromIntegral . posLine . spanStart -- PT TODO: proper token for this instance Tokenize Line where diff --git a/src/Data/Syntax/Literal.hs b/src/Data/Syntax/Literal.hs index 8e739007c..b23c719b7 100644 --- a/src/Data/Syntax/Literal.hs +++ b/src/Data/Syntax/Literal.hs @@ -50,7 +50,7 @@ instance Show1 Data.Syntax.Literal.Integer where liftShowsPrec = genericLiftShow instance Evaluatable Data.Syntax.Literal.Integer where -- TODO: We should use something more robust than shelling out to readMaybe. eval _ _ (Data.Syntax.Literal.Integer x) = - integer <$> either (const (throwEvalError (IntegerFormatError x))) pure (parseInteger x) + either (const (throwEvalError (IntegerFormatError x))) pure (parseInteger x) >>= integer instance Tokenize Data.Syntax.Literal.Integer where tokenize = yield . Run . integerContent @@ -66,7 +66,7 @@ instance Show1 Data.Syntax.Literal.Float where liftShowsPrec = genericLiftShowsP instance Evaluatable Data.Syntax.Literal.Float where eval _ _ (Float s) = - float <$> either (const (throwEvalError (FloatFormatError s))) pure (parseScientific s) + either (const (throwEvalError (FloatFormatError s))) pure (parseScientific s) >>= float instance Tokenize Data.Syntax.Literal.Float where tokenize = yield . Run . floatContent @@ -84,7 +84,7 @@ instance Evaluatable Data.Syntax.Literal.Rational where let trimmed = T.takeWhile (/= 'r') r parsed = readMaybe @Prelude.Integer (T.unpack trimmed) - in rational <$> maybe (throwEvalError (RationalFormatError r)) (pure . toRational) parsed + in maybe (throwEvalError (RationalFormatError r)) (pure . toRational) parsed >>= rational instance Tokenize Data.Syntax.Literal.Rational where tokenize (Rational t) = yield . Run $ t From 99bbdfa9aed3c87a12de505631092be982dff518 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 14 Dec 2018 15:14:02 -0500 Subject: [PATCH 048/127] add bitwise effect, carrier newtype and handler --- src/Control/Abstract/Value.hs | 26 ++++++++++++++++++++++++++ src/Data/Abstract/Evaluatable.hs | 2 +- src/Data/Syntax/Expression.hs | 2 +- 3 files changed, 28 insertions(+), 2 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 88ea1946c..d5c8b3017 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -41,6 +41,9 @@ module Control.Abstract.Value , Numeric(..) , NumericC(..) , runNumeric +, Bitwise(..) +, BitwiseC(..) +, runBitwise ) where import Control.Abstract.Evaluator @@ -311,6 +314,29 @@ runNumeric :: Carrier (Numeric value :+: sig) (NumericC value (Eff m)) -> Evaluator term address value m a runNumeric = raiseHandler $ runNumericC . interpret + +data Bitwise value (m :: * -> *) k + = CastToInteger value (value -> k) + | LiftBitwise (forall a . Bits a => a -> a) value (value -> k) + | LiftBitwise2 (forall a . (Integral a, Bits a) => a -> a -> a) value value (value -> k) + | UnsignedRShift value value (value -> k) + deriving (Functor) + +instance HFunctor (Bitwise value) where + hmap _ = coerce + {-# INLINE hmap #-} + +instance Effect (Bitwise value) where + handle state handler = coerce . fmap (handler . (<$ state)) + +runBitwise :: Carrier (Bitwise value :+: sig) (BitwiseC value (Eff m)) + => Evaluator term address value (BitwiseC value (Eff m)) a + -> Evaluator term address value m a +runBitwise = raiseHandler $ runBitwiseC . interpret + +newtype BitwiseC value m a = BitwiseC { runBitwiseC :: m a } + + class Show value => AbstractIntro value where -- | Construct a key-value pair for use in a hash. kvPair :: value -> value -> value diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 616775b79..3b50acdda 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -21,7 +21,7 @@ import qualified Control.Abstract as Abstract import Control.Abstract.Context as X import Control.Abstract.Evaluator as X hiding (LoopControl(..), Return(..), catchLoopControl, runLoopControl, catchReturn, runReturn) import Control.Abstract.Modules as X (Modules, ModuleResult, ResolutionError(..), load, lookupModule, listModulesInDir, require, resolve, throwResolutionError) -import Control.Abstract.Value as X hiding (Boolean(..), Function(..), Numeric(..), String(..), Unit(..), While(..)) +import Control.Abstract.Value as X hiding (Bitwise(..), Boolean(..), Function(..), Numeric(..), String(..), Unit(..), While(..)) import Data.Abstract.BaseError as X import Data.Abstract.Declarations as X import Data.Abstract.FreeVariables as X diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index 1e119b80d..4fba1803d 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -9,7 +9,7 @@ import Data.Fixed import Data.List (intersperse) import Proto3.Suite.Class -import Control.Abstract hiding (Call, Member, Void) +import Control.Abstract hiding (Bitwise(..), Call, Member, Void) import Data.Abstract.Evaluatable as Abstract hiding (Member, Void) import Data.Abstract.Name as Name import Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent, liftedFloorDiv) From 2f37f620d95647729e17bdf2003b1f1123dc73b3 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 14 Dec 2018 15:21:44 -0500 Subject: [PATCH 049/127] bitwise carrier instance in abstract domain --- src/Data/Abstract/Value/Abstract.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index 68fbf6617..21070c4e8 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -101,6 +101,16 @@ instance Carrier sig m LiftNumeric _ _ k -> runNumericC (k Abstract) LiftNumeric2 _ _ _ k -> runNumericC (k Abstract)) +instance Carrier sig m + => Carrier (Bitwise Abstract :+: sig) (BitwiseC Abstract m) where + ret = BitwiseC . ret + eff = BitwiseC . handleSum (eff . handleCoercible) (\case + CastToInteger _ k -> runBitwiseC (k Abstract) + LiftBitwise _ _ k -> runBitwiseC (k Abstract) + LiftBitwise2 _ _ _ k -> runBitwiseC (k Abstract) + UnsignedRShift _ _ k -> runBitwiseC (k Abstract)) + + instance Ord address => ValueRoots address Abstract where valueRoots = mempty From ee7b3b74a84e3b13cc37e673eadf9c2cb882457d Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 14 Dec 2018 15:39:14 -0500 Subject: [PATCH 050/127] bitwise carrier instance in type domain --- src/Data/Abstract/Value/Type.hs | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index fde9326f7..6b56b0170 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -355,6 +355,21 @@ instance ( Member (Reader ModuleInfo) sig (Int, Float) -> runNumericC (k Float) _ -> unify left right >>= runNumericC . k) +instance ( Member (Reader ModuleInfo) sig + , Member (Reader Span) sig + , Member (Resumable (BaseError TypeError)) sig + , Member (State TypeMap) sig + , Carrier sig m + , Monad m + ) + => Carrier (Abstract.Bitwise Type :+: sig) (BitwiseC Type m) where + ret = BitwiseC . ret + eff = BitwiseC . handleSum (eff . handleCoercible) (\case + CastToInteger t k -> unify t (Int :+ Float :+ Rational) >> runBitwiseC (k Int) + LiftBitwise _ t k -> unify t Int >>= runBitwiseC . k + LiftBitwise2 _ t1 t2 k -> unify Int t1 >>= unify t2 >>= runBitwiseC . k + UnsignedRShift t1 t2 k -> unify Int t2 *> unify Int t1 >>= runBitwiseC . k) + instance AbstractHole Type where hole = Hole From 3f3825539c831a0f2b740adff67c824372c05b4d Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 14 Dec 2018 16:24:27 -0500 Subject: [PATCH 051/127] bitwise carrier instance in concrete domain --- src/Data/Abstract/Value/Concrete.hs | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 6f84b1878..94ddb75da 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -218,6 +218,30 @@ specialize (Right (Number.SomeNumber (Number.Integer t))) = pure (Integer (Numbe specialize (Right (Number.SomeNumber (Number.Decimal t))) = pure (Float (Number.Decimal t)) specialize (Right (Number.SomeNumber (Number.Ratio t))) = pure (Rational (Number.Ratio t)) + +instance ( Member (Reader ModuleInfo) sig + , Member (Reader Span) sig + , Member (Resumable (BaseError (ValueError term address))) sig + , Carrier sig m + , Monad m + ) + => Carrier (Abstract.Bitwise (Value term address) :+: sig) (BitwiseC (Value term address) m) where + ret = BitwiseC . ret + eff = BitwiseC . handleSum (eff . handleCoercible) (\case + CastToInteger (Integer (Number.Integer i)) k -> runBitwiseC (k (Integer (Number.Integer i))) + CastToInteger (Float (Number.Decimal i)) k -> runBitwiseC (k (Integer (Number.Integer (coefficient (normalize i))))) + CastToInteger i k -> throwBaseError (NumericError i) >>= runBitwiseC . k + LiftBitwise operator (Integer (Number.Integer i)) k -> runBitwiseC . k . Integer . Number.Integer . operator $ i + LiftBitwise _ other k -> throwBaseError (BitwiseError other) >>= runBitwiseC . k + LiftBitwise2 operator (Integer (Number.Integer i)) (Integer (Number.Integer j)) k -> runBitwiseC . k . Integer . Number.Integer $ operator i j + LiftBitwise2 _ left right k -> throwBaseError (Bitwise2Error left right) >>= runBitwiseC . k + UnsignedRShift (Integer (Number.Integer i)) (Integer (Number.Integer j)) k | i >= 0 -> runBitwiseC . k . Integer . Number.Integer $ ourShift (fromIntegral i) (fromIntegral j) + UnsignedRShift left right k -> throwBaseError (Bitwise2Error left right) >>= runBitwiseC . k + ) + +ourShift :: Word64 -> Int -> Integer +ourShift a b = toInteger (shiftR a b) + instance AbstractHole (Value term address) where hole = Hole From 8aad872c24a976747ce857dda3e36cfc05a1450f Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 14 Dec 2018 16:24:54 -0500 Subject: [PATCH 052/127] stylin --- src/Data/Abstract/Value/Concrete.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 94ddb75da..cbe3cb563 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -236,8 +236,7 @@ instance ( Member (Reader ModuleInfo) sig LiftBitwise2 operator (Integer (Number.Integer i)) (Integer (Number.Integer j)) k -> runBitwiseC . k . Integer . Number.Integer $ operator i j LiftBitwise2 _ left right k -> throwBaseError (Bitwise2Error left right) >>= runBitwiseC . k UnsignedRShift (Integer (Number.Integer i)) (Integer (Number.Integer j)) k | i >= 0 -> runBitwiseC . k . Integer . Number.Integer $ ourShift (fromIntegral i) (fromIntegral j) - UnsignedRShift left right k -> throwBaseError (Bitwise2Error left right) >>= runBitwiseC . k - ) + UnsignedRShift left right k -> throwBaseError (Bitwise2Error left right) >>= runBitwiseC . k) ourShift :: Word64 -> Int -> Integer ourShift a b = toInteger (shiftR a b) From eb50b794e62c6afe343a7fcf2a357bba5820946b Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 14 Dec 2018 16:42:59 -0500 Subject: [PATCH 053/127] provide Bitwise effect --- src/Semantic/Analysis.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index e2198bf4d..6424ef3d0 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -32,9 +32,10 @@ type DomainC term address value m ( BooleanC value (Eff ( StringC value (Eff ( NumericC value (Eff + ( BitwiseC value (Eff ( UnitC value (Eff ( InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff - 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 @@ -86,8 +87,11 @@ runDomainEffects :: ( AbstractValue term address value (DomainC term address val , unitC ~ UnitC value (Eff (InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff m))) , unitSig ~ (Unit value :+: Interpose (Resumable (BaseError (UnspecializedError address value))) :+: sig) , Carrier unitSig unitC - , numericC ~ NumericC value (Eff unitC) - , numericSig ~ (Abstract.Numeric value :+: unitSig) + , bitwiseC ~ BitwiseC value (Eff unitC) + , bitwiseSig ~ (Abstract.Bitwise value :+: unitSig) + , Carrier bitwiseSig bitwiseC + , numericC ~ NumericC value (Eff bitwiseC) + , numericSig ~ (Abstract.Numeric value :+: bitwiseSig) , Carrier numericSig numericC , stringC ~ StringC value (Eff numericC) , stringSig ~ (Abstract.String value :+: numericSig) @@ -122,7 +126,7 @@ runDomainEffects :: ( AbstractValue term address value (DomainC term address val => (term -> Evaluator term address value (DomainC term address value m) value) -> Module (Either (proxy lang) term) -> Evaluator term address value m value -runDomainEffects runTerm = raiseHandler runInterpose . runUnit . runNumeric . runString . runBoolean . runWhile . runFunction runTerm . either ((unit <*) . definePrelude) runTerm . moduleBody +runDomainEffects runTerm = raiseHandler runInterpose . runUnit . runBitwise . runNumeric . runString . runBoolean . runWhile . runFunction runTerm . either ((unit <*) . definePrelude) runTerm . moduleBody -- | Evaluate a term recursively, applying the passed function at every recursive position. -- From df0f4ffd3a16f2aba0f23cc3a63d0e4b6b2f5826 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 14 Dec 2018 17:14:01 -0500 Subject: [PATCH 054/127] use the Bitwise effect --- src/Control/Abstract/Value.hs | 46 +++++++++++++++++++---------- src/Data/Abstract/Evaluatable.hs | 1 + src/Data/Abstract/Value/Abstract.hs | 6 ---- src/Data/Abstract/Value/Concrete.hs | 23 --------------- src/Data/Abstract/Value/Type.hs | 7 ----- src/Semantic/Analysis.hs | 1 + 6 files changed, 33 insertions(+), 51 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index d5c8b3017..c7e56b1a5 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -41,6 +41,10 @@ module Control.Abstract.Value , Numeric(..) , NumericC(..) , runNumeric +, castToInteger +, liftBitwise +, liftBitwise2 +, unsignedRShift , Bitwise(..) , BitwiseC(..) , runBitwise @@ -315,6 +319,33 @@ runNumeric :: Carrier (Numeric value :+: sig) (NumericC value (Eff m)) runNumeric = raiseHandler $ runNumericC . interpret +-- | Cast numbers to integers +castToInteger :: (Member (Bitwise value) sig, Carrier sig m) => value -> m value +castToInteger t = send (CastToInteger t ret) + +-- | Lift a unary bitwise operator to values. This is usually 'complement'. +liftBitwise :: (Member (Bitwise value) sig, Carrier sig m) + => (forall a . Bits a => a -> a) + -> value + -> m value +liftBitwise t v = send (LiftBitwise t v ret) + +-- | Lift a binary bitwise operator to values. The Integral constraint is +-- necessary to satisfy implementation details of Haskell left/right shift, +-- but it's fine, since these are only ever operating on integral values. +liftBitwise2 :: (Member (Bitwise value) sig, Carrier sig m) + => (forall a . (Integral a, Bits a) => a -> a -> a) + -> value + -> value + -> m value +liftBitwise2 t v1 v2 = send (LiftBitwise2 t v1 v2 ret) + +unsignedRShift :: (Member (Bitwise value) sig, Carrier sig m) + => value + -> value + -> m value +unsignedRShift v1 v2 = send (UnsignedRShift v1 v2 ret) + data Bitwise value (m :: * -> *) k = CastToInteger value (value -> k) | LiftBitwise (forall a . Bits a => a -> a) value (value -> k) @@ -351,24 +382,9 @@ class Show value => AbstractIntro value where -- -- This allows us to abstract the choice of whether to evaluate under binders for different value types. class AbstractIntro value => AbstractValue term address value carrier where - -- | Cast numbers to integers - castToInteger :: value -> Evaluator term address value carrier value - -- | Lift a Comparator (usually wrapping a function like == or <=) to a function on values. liftComparison :: Comparator -> (value -> value -> Evaluator term address value carrier value) - -- | Lift a unary bitwise operator to values. This is usually 'complement'. - liftBitwise :: (forall a . Bits a => a -> a) - -> (value -> Evaluator term address value carrier value) - - -- | Lift a binary bitwise operator to values. The Integral constraint is - -- necessary to satisfy implementation details of Haskell left/right shift, - -- but it's fine, since these are only ever operating on integral values. - liftBitwise2 :: (forall a . (Integral a, Bits a) => a -> a -> a) - -> (value -> value -> Evaluator term address value carrier value) - - unsignedRShift :: value -> value -> Evaluator term address value carrier value - -- | Construct an N-ary tuple of multiple (possibly-disjoint) values tuple :: [value] -> Evaluator term address value carrier value diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 3b50acdda..e8907013a 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -43,6 +43,7 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where , Declarations term , FreeVariables term , Member (Allocator address) sig + , Member (Bitwise value) sig , Member (Boolean value) sig , Member (While value) sig , Member (Deref value) sig diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index 21070c4e8..abe7da33c 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -137,12 +137,6 @@ instance AbstractValue term address Abstract m where index _ _ = pure Abstract - liftBitwise _ _ = pure Abstract - liftBitwise2 _ _ _ = pure Abstract - - unsignedRShift _ _ = pure Abstract - liftComparison _ _ _ = pure Abstract - castToInteger _ = pure Abstract object _ = pure Abstract diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index cbe3cb563..8a9b52efd 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -315,29 +315,6 @@ instance ( Member (Abstract.Boolean (Value term address)) sig pair = (left, right) - liftBitwise operator target - | Integer (Number.Integer i) <- target = pure . Integer . Number.Integer $ operator i - | otherwise = throwValueError (BitwiseError target) - - liftBitwise2 operator left right - | (Integer (Number.Integer i), Integer (Number.Integer j)) <- pair = pure . Integer . Number.Integer $ operator i j - | otherwise = throwValueError (Bitwise2Error left right) - where pair = (left, right) - - unsignedRShift left right - | (Integer (Number.Integer i), Integer (Number.Integer j)) <- pair = - if i >= 0 then pure . Integer . Number.Integer $ ourShift (fromIntegral i) (fromIntegral j) - else throwValueError (Bitwise2Error left right) - | otherwise = throwValueError (Bitwise2Error left right) - where - pair = (left, right) - ourShift :: Word64 -> Int -> Integer - ourShift a b = toInteger (shiftR a b) - - castToInteger (Integer (Number.Integer i)) = pure (Integer (Number.Integer i)) - castToInteger (Float (Number.Decimal i)) = pure (Integer (Number.Integer (coefficient (normalize i)))) - castToInteger i = throwValueError (NumericError i) - object frameAddress = pure (Object frameAddress) -- | The type of exceptions that can be thrown when constructing values in 'Value'’s 'MonadValue' instance. diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index 6b56b0170..e03721922 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -415,11 +415,6 @@ instance ( Member Fresh sig _ <- unify (Array (Var field)) arr pure (Var field) - liftBitwise _ = unify Int - liftBitwise2 _ t1 t2 = unify Int t1 >>= flip unify t2 - - unsignedRShift t1 t2 = unify Int t2 *> unify Int t1 - liftComparison (Concrete _) left right = case (left, right) of (Float, Int) -> pure Bool (Int, Float) -> pure Bool @@ -428,5 +423,3 @@ instance ( Member Fresh sig (Float, Int) -> pure Int (Int, Float) -> pure Int _ -> unify left right $> Bool - - castToInteger t = unify t (Int :+ Float :+ Rational) $> Int diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 6424ef3d0..84e2b83e4 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -137,6 +137,7 @@ evalTerm :: ( Carrier sig m , FreeVariables term , AbstractValue term address value m , Member (Allocator address) sig + , Member (Bitwise value) sig , Member (Boolean value) sig , Member (Deref value) sig , Member (Error (LoopControl value)) sig From 663aa45bfcd1424480ce327229082ff31a8a4b82 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 14 Dec 2018 17:25:21 -0500 Subject: [PATCH 055/127] remove redunant constraints in python package --- src/Control/Abstract/PythonPackage.hs | 20 -------------------- 1 file changed, 20 deletions(-) diff --git a/src/Control/Abstract/PythonPackage.hs b/src/Control/Abstract/PythonPackage.hs index c7d2d94ff..271ab3527 100644 --- a/src/Control/Abstract/PythonPackage.hs +++ b/src/Control/Abstract/PythonPackage.hs @@ -16,23 +16,13 @@ data Strategy = Unknown | Packages [Text] | FindPackages [Text] deriving (Show, Eq) runPythonPackaging :: ( Carrier sig m - , Ord address , Show address , Show term - , Member Trace sig , Member (Boolean (Value term address)) sig , Member (Abstract.String (Value term address)) sig - , Member (State (Heap address address (Value term address))) sig - , Member (Resumable (BaseError (AddressError address (Value term address)))) sig , Member (Resumable (BaseError (ValueError term address))) sig - , Member Fresh sig , Member (State Strategy) sig - , Member (Allocator address) sig - , Member (Deref (Value term address)) sig - , Member (Error (LoopControl (Value term address))) sig - , Member (Error (Return (Value term address))) sig , Member (Reader ModuleInfo) sig - , Member (Reader PackageInfo) sig , Member (Reader Span) sig , Member (Function term address (Value term address)) sig) => Evaluator term address (Value term address) (PythonPackagingC term address (Eff m)) a @@ -46,23 +36,13 @@ wrap :: Evaluator term address (Value term address) m a -> PythonPackagingC term wrap = PythonPackagingC . runEvaluator instance ( Carrier sig m - , Member (Allocator address) sig , Member (Boolean (Value term address)) sig - , Member (Deref (Value term address)) sig - , Member (Error (LoopControl (Value term address))) sig - , Member (Error (Return (Value term 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 address (Value term address))) sig , Member (State Strategy) sig , Member (Abstract.String (Value term address)) sig - , Member Trace sig - , Ord address , Show address , Show term ) From f37b417fd904ff571b4c717a61c20ea28609010a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 18 Dec 2018 11:19:47 -0500 Subject: [PATCH 056/127] Correct the EvaluatorSpec. --- test/Control/Abstract/Evaluator/Spec.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/test/Control/Abstract/Evaluator/Spec.hs b/test/Control/Abstract/Evaluator/Spec.hs index df35d0f83..bf29a8f2e 100644 --- a/test/Control/Abstract/Evaluator/Spec.hs +++ b/test/Control/Abstract/Evaluator/Spec.hs @@ -26,7 +26,7 @@ import System.IO.Unsafe (unsafePerformIO) spec :: Spec spec = parallel $ do it "constructs integers" $ do - (_, (_, (_, expected))) <- evaluate (pure (integer 123)) + (_, (_, (_, expected))) <- evaluate (integer 123) expected `shouldBe` Right (Value.Integer (Number.Integer 123)) it "calls functions" $ do @@ -40,9 +40,9 @@ spec = parallel $ do declare (Declaration x) Default emptySpan Nothing identity <- function "identity" [ x ] (SpecEff (Heap.lookupDeclaration (ScopeGraph.Declaration (SpecHelpers.name "x")) >>= deref)) associatedScope - val <- pure (integer 123) + val <- integer 123 call identity [val] - expected `shouldBe` Right (integer 123) + expected `shouldBe` Right (Value.Integer (Number.Integer 123)) evaluate = runM @@ -73,6 +73,7 @@ evaluate . runAllocator . runReturn . runLoopControl + . runNumeric . runBoolean . runFunction runSpecEff $ action @@ -85,6 +86,7 @@ type Val = Value SpecEff Precise newtype SpecEff = SpecEff { runSpecEff :: Evaluator SpecEff Precise Val (FunctionC SpecEff Precise Val (Eff (BooleanC Val + (Eff (NumericC Val (Eff (ErrorC (LoopControl Val) (Eff (ErrorC (Return Val) (Eff (AllocatorC Precise @@ -105,7 +107,7 @@ newtype SpecEff = SpecEff (Eff (StateC (Heap Precise Precise Val) (Eff (StateC (ScopeGraph Precise) (Eff (TraceByIgnoringC - (Eff (LiftC IO))))))))))))))))))))))))))))))))))))))))))))) + (Eff (LiftC IO))))))))))))))))))))))))))))))))))))))))))))))) Val } From e84204bbcc15fc2b2e62c5fb8e105a68a72dbe0c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 18 Dec 2018 14:16:42 -0500 Subject: [PATCH 057/127] Reformat runDomainEffects. --- src/Semantic/Analysis.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 032e61ded..f6b908580 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -126,7 +126,17 @@ runDomainEffects :: ( AbstractValue term address value (DomainC term address val => (term -> Evaluator term address value (DomainC term address value m) value) -> Module (Either (proxy lang) term) -> Evaluator term address value m value -runDomainEffects runTerm = raiseHandler runInterpose . runUnit . runBitwise . runNumeric . runString . runBoolean . runWhile . runFunction runTerm . either ((unit <*) . definePrelude) runTerm . moduleBody +runDomainEffects runTerm + = raiseHandler runInterpose + . runUnit + . runBitwise + . runNumeric + . runString + . runBoolean + . runWhile + . runFunction runTerm + . either ((unit <*) . definePrelude) runTerm + . moduleBody -- | Evaluate a term recursively, applying the passed function at every recursive position. -- From f9930eac6cd122cc49a41d5e3122ad738f2f2a38 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 18 Dec 2018 16:38:51 -0500 Subject: [PATCH 058/127] Use a type synonym for the domain effect signature. --- src/Semantic/Analysis.hs | 32 +++++++++++--------------------- 1 file changed, 11 insertions(+), 21 deletions(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index f6b908580..30a6e1b2e 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -37,6 +37,16 @@ type DomainC term address value m ( InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff m))))))))))))))) +type DomainSig term address value m + = Function term address value + :+: While value + :+: Boolean value + :+: Abstract.String value + :+: Numeric value + :+: Bitwise value + :+: Unit value + :+: Interpose (Resumable (BaseError (UnspecializedError address value))) + -- | 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) @@ -84,27 +94,7 @@ evaluate lang runModule modules = do runDomainEffects :: ( AbstractValue term address value (DomainC term address value m) , Carrier sig m - , unitC ~ UnitC value (Eff (InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff m))) - , unitSig ~ (Unit value :+: Interpose (Resumable (BaseError (UnspecializedError address value))) :+: sig) - , Carrier unitSig unitC - , bitwiseC ~ BitwiseC value (Eff unitC) - , bitwiseSig ~ (Abstract.Bitwise value :+: unitSig) - , Carrier bitwiseSig bitwiseC - , numericC ~ NumericC value (Eff bitwiseC) - , numericSig ~ (Abstract.Numeric value :+: bitwiseSig) - , Carrier numericSig numericC - , stringC ~ StringC value (Eff numericC) - , stringSig ~ (Abstract.String value :+: numericSig) - , Carrier stringSig stringC - , booleanC ~ BooleanC value (Eff stringC) - , booleanSig ~ (Boolean value :+: stringSig) - , 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 + , Carrier (DomainSig term address value m) (DomainC term address value m) , HasPrelude lang , Member (Allocator address) sig , Member (Deref value) sig From 11d5d526b00cdb26e219191d949e4d21eee56452 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 18 Dec 2018 16:40:12 -0500 Subject: [PATCH 059/127] :fire: the redundant m parameter from DomainSig. --- src/Semantic/Analysis.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 30a6e1b2e..fa9540512 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -37,7 +37,7 @@ type DomainC term address value m ( InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff m))))))))))))))) -type DomainSig term address value m +type DomainSig term address value = Function term address value :+: While value :+: Boolean value @@ -94,7 +94,7 @@ evaluate lang runModule modules = do runDomainEffects :: ( AbstractValue term address value (DomainC term address value m) , Carrier sig m - , Carrier (DomainSig term address value m) (DomainC term address value m) + , Carrier (DomainSig term address value) (DomainC term address value m) , HasPrelude lang , Member (Allocator address) sig , Member (Deref value) sig From 9537bf3933ee18ef6e85d777adf823ec0bc985d4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 18 Dec 2018 16:43:50 -0500 Subject: [PATCH 060/127] Chain DomainSig onto sig. --- src/Semantic/Analysis.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index fa9540512..a7b0a07e6 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -37,7 +37,7 @@ type DomainC term address value m ( InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff m))))))))))))))) -type DomainSig term address value +type DomainSig term address value sig = Function term address value :+: While value :+: Boolean value @@ -46,6 +46,7 @@ type DomainSig term address value :+: Bitwise value :+: Unit value :+: Interpose (Resumable (BaseError (UnspecializedError address value))) + :+: sig -- | 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 @@ -94,7 +95,7 @@ evaluate lang runModule modules = do runDomainEffects :: ( AbstractValue term address value (DomainC term address value m) , Carrier sig m - , Carrier (DomainSig term address value) (DomainC term address value m) + , Carrier (DomainSig term address value sig) (DomainC term address value m) , HasPrelude lang , Member (Allocator address) sig , Member (Deref value) sig From 36f3b7afaffb57e63ab1dba53c9d093cc7a6c5c3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 18 Dec 2018 16:45:05 -0500 Subject: [PATCH 061/127] Revert "Chain DomainSig onto sig." This reverts commit 13f78b1f4693252068e044d937c6b28e5cc2e347. --- src/Semantic/Analysis.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index a7b0a07e6..fa9540512 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -37,7 +37,7 @@ type DomainC term address value m ( InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff m))))))))))))))) -type DomainSig term address value sig +type DomainSig term address value = Function term address value :+: While value :+: Boolean value @@ -46,7 +46,6 @@ type DomainSig term address value sig :+: Bitwise value :+: Unit value :+: Interpose (Resumable (BaseError (UnspecializedError address value))) - :+: sig -- | 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 @@ -95,7 +94,7 @@ evaluate lang runModule modules = do runDomainEffects :: ( AbstractValue term address value (DomainC term address value m) , Carrier sig m - , Carrier (DomainSig term address value sig) (DomainC term address value m) + , Carrier (DomainSig term address value) (DomainC term address value m) , HasPrelude lang , Member (Allocator address) sig , Member (Deref value) sig From 92f9998746a90b35464a07eb30e4e8d7d96bdd22 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 18 Dec 2018 16:45:08 -0500 Subject: [PATCH 062/127] Revert ":fire: the redundant m parameter from DomainSig." This reverts commit 930283dc52e71b6d2df88cd161d7b990a3e2f739. --- src/Semantic/Analysis.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index fa9540512..30a6e1b2e 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -37,7 +37,7 @@ type DomainC term address value m ( InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff m))))))))))))))) -type DomainSig term address value +type DomainSig term address value m = Function term address value :+: While value :+: Boolean value @@ -94,7 +94,7 @@ evaluate lang runModule modules = do runDomainEffects :: ( AbstractValue term address value (DomainC term address value m) , Carrier sig m - , Carrier (DomainSig term address value) (DomainC term address value m) + , Carrier (DomainSig term address value m) (DomainC term address value m) , HasPrelude lang , Member (Allocator address) sig , Member (Deref value) sig From 0f5023cf5989c9cb7b9d7f93d0e58d7cd8234f6f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 18 Dec 2018 16:45:11 -0500 Subject: [PATCH 063/127] Revert "Use a type synonym for the domain effect signature." This reverts commit 20bf463f73581a5479b09ecd04e3bc3be5619171. --- src/Semantic/Analysis.hs | 32 +++++++++++++++++++++----------- 1 file changed, 21 insertions(+), 11 deletions(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 30a6e1b2e..f6b908580 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -37,16 +37,6 @@ type DomainC term address value m ( InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff m))))))))))))))) -type DomainSig term address value m - = Function term address value - :+: While value - :+: Boolean value - :+: Abstract.String value - :+: Numeric value - :+: Bitwise value - :+: Unit value - :+: Interpose (Resumable (BaseError (UnspecializedError address value))) - -- | 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) @@ -94,7 +84,27 @@ evaluate lang runModule modules = do runDomainEffects :: ( AbstractValue term address value (DomainC term address value m) , Carrier sig m - , Carrier (DomainSig term address value m) (DomainC term address value m) + , unitC ~ UnitC value (Eff (InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff m))) + , unitSig ~ (Unit value :+: Interpose (Resumable (BaseError (UnspecializedError address value))) :+: sig) + , Carrier unitSig unitC + , bitwiseC ~ BitwiseC value (Eff unitC) + , bitwiseSig ~ (Abstract.Bitwise value :+: unitSig) + , Carrier bitwiseSig bitwiseC + , numericC ~ NumericC value (Eff bitwiseC) + , numericSig ~ (Abstract.Numeric value :+: bitwiseSig) + , Carrier numericSig numericC + , stringC ~ StringC value (Eff numericC) + , stringSig ~ (Abstract.String value :+: numericSig) + , Carrier stringSig stringC + , booleanC ~ BooleanC value (Eff stringC) + , booleanSig ~ (Boolean value :+: stringSig) + , 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 From 005ba9ee9f089d37796698ac197f7e190b7ddc40 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Mon, 7 Jan 2019 13:59:28 -0500 Subject: [PATCH 064/127] stub in object effect --- src/Control/Abstract/Value.hs | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index a0d60f4d0..71e51a6f2 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -41,6 +41,7 @@ module Control.Abstract.Value , liftNumeric2 , Numeric(..) , NumericC(..) +, Object(..) , runNumeric , castToInteger , liftBitwise @@ -373,6 +374,18 @@ runBitwise = raiseHandler $ runBitwiseC . interpret newtype BitwiseC value m a = BitwiseC { runBitwiseC :: m a } +data Object value (m :: * -> *) k + = Object value (value -> k) + | ScopedEnvironment value (value -> k) + deriving (Functor) + +instance HFunctor (Object value) where + hmap _ = coerce + {-# INLINE hmap #-} + +instance Effect (Object value) where + handle state handler = coerce . fmap (handler . (<$ state)) + class Show value => AbstractIntro value where -- | Construct a key-value pair for use in a hash. kvPair :: value -> value -> value From b8818fbfdd9292efcb94ed9e42c6476c4b7281c7 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Mon, 7 Jan 2019 14:00:23 -0500 Subject: [PATCH 065/127] define carrier type for object --- src/Control/Abstract/Value.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 71e51a6f2..1f75afc02 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -42,6 +42,7 @@ module Control.Abstract.Value , Numeric(..) , NumericC(..) , Object(..) +, ObjectC(..) , runNumeric , castToInteger , liftBitwise @@ -386,6 +387,8 @@ instance HFunctor (Object value) where instance Effect (Object value) where handle state handler = coerce . fmap (handler . (<$ state)) +newtype ObjectC value m a = ObjectC { runObjectC :: m a } + class Show value => AbstractIntro value where -- | Construct a key-value pair for use in a hash. kvPair :: value -> value -> value From 4e08edb14d80d14a11a6f9fe298eef6f7a1f0952 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Mon, 7 Jan 2019 14:02:07 -0500 Subject: [PATCH 066/127] define handler for object --- src/Control/Abstract/Value.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 1f75afc02..fb30745af 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -43,6 +43,7 @@ module Control.Abstract.Value , NumericC(..) , Object(..) , ObjectC(..) +, runObject , runNumeric , castToInteger , liftBitwise @@ -389,6 +390,12 @@ instance Effect (Object value) where newtype ObjectC value m a = ObjectC { runObjectC :: m a } +runObject :: Carrier (Object value :+: sig) (ObjectC value (Eff m)) + => Evaluator term address value (ObjectC value (Eff m)) a + -> Evaluator term address value m a +runObject = raiseHandler $ runObjectC . interpret + + class Show value => AbstractIntro value where -- | Construct a key-value pair for use in a hash. kvPair :: value -> value -> value From 0ec24759fad317d9e4716844c22676168b9c6ad6 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Mon, 7 Jan 2019 14:12:09 -0500 Subject: [PATCH 067/127] fix parameters to include address and value --- src/Control/Abstract/Value.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index fb30745af..7c188222e 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -376,22 +376,22 @@ runBitwise = raiseHandler $ runBitwiseC . interpret newtype BitwiseC value m a = BitwiseC { runBitwiseC :: m a } -data Object value (m :: * -> *) k - = Object value (value -> k) - | ScopedEnvironment value (value -> k) +data Object address value (m :: * -> *) k + = Object address (value -> k) + | ScopedEnvironment value (Maybe address -> k) deriving (Functor) -instance HFunctor (Object value) where +instance HFunctor (Object address value) where hmap _ = coerce {-# INLINE hmap #-} -instance Effect (Object value) where +instance Effect (Object address value) where handle state handler = coerce . fmap (handler . (<$ state)) -newtype ObjectC value m a = ObjectC { runObjectC :: m a } +newtype ObjectC address value m a = ObjectC { runObjectC :: m a } -runObject :: Carrier (Object value :+: sig) (ObjectC value (Eff m)) - => Evaluator term address value (ObjectC value (Eff m)) a +runObject :: Carrier (Object address value :+: sig) (ObjectC address value (Eff m)) + => Evaluator term address value (ObjectC address value (Eff m)) a -> Evaluator term address value m a runObject = raiseHandler $ runObjectC . interpret From f79017d0195e82a9955c1e59fb14b1166c75fc8b Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Tue, 8 Jan 2019 11:22:39 -0500 Subject: [PATCH 068/127] broken object carrier instance in abstract domain --- src/Data/Abstract/Value/Abstract.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index a3a40437d..5c9e896ae 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -111,6 +111,12 @@ instance Carrier sig m LiftBitwise2 _ _ _ k -> runBitwiseC (k Abstract) UnsignedRShift _ _ k -> runBitwiseC (k Abstract)) +instance Carrier sig m + => Carrier (Object Abstract value :+: sig) (ObjectC Abstract value m) where + ret = ObjectC . ret + eff = ObjectC . handleSum (eff . handleCoercible) (\case + Object _ k -> runObjectC (k Abstract) + ScopedEnvironment _ k -> runObjectC (k (Just Abstract))) instance Ord address => ValueRoots address Abstract where valueRoots = mempty @@ -139,5 +145,3 @@ instance AbstractValue term address Abstract m where index _ _ = pure Abstract liftComparison _ _ _ = pure Abstract - - object _ = pure Abstract From 158c4193db76b1b259618029f65f5c861fe8170f Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Tue, 8 Jan 2019 12:34:31 -0500 Subject: [PATCH 069/127] fix object carrier instance in abstract domain --- src/Data/Abstract/Value/Abstract.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index 5c9e896ae..6c3a18eee 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -112,11 +112,11 @@ instance Carrier sig m UnsignedRShift _ _ k -> runBitwiseC (k Abstract)) instance Carrier sig m - => Carrier (Object Abstract value :+: sig) (ObjectC Abstract value m) where + => Carrier (Object address Abstract :+: sig) (ObjectC address Abstract m) where ret = ObjectC . ret eff = ObjectC . handleSum (eff . handleCoercible) (\case Object _ k -> runObjectC (k Abstract) - ScopedEnvironment _ k -> runObjectC (k (Just Abstract))) + ScopedEnvironment _ k -> runObjectC (k Nothing)) instance Ord address => ValueRoots address Abstract where valueRoots = mempty From da4d43c6819bf31d44c5efa79b67bef56d62656e Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Tue, 8 Jan 2019 12:34:59 -0500 Subject: [PATCH 070/127] get rid of scopedEnvironment in AbstractValue --- src/Data/Abstract/Value/Abstract.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index 6c3a18eee..d249d8684 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -137,8 +137,6 @@ instance AbstractValue term address Abstract m where klass _ _ = pure Abstract namespace _ _ = pure Abstract - scopedEnvironment _ = pure Nothing - asPair _ = pure (Abstract, Abstract) asArray _ = pure mempty From ea520d1dfbe3c20d11212b64bab0b3886cde6acb Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Tue, 8 Jan 2019 13:28:45 -0500 Subject: [PATCH 071/127] add object carrier instance to type --- src/Data/Abstract/Evaluatable.hs | 2 +- src/Data/Abstract/Value/Type.hs | 9 +++++++-- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index a8286b2ac..4ffe8ba61 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -22,7 +22,7 @@ import qualified Control.Abstract as Abstract import Control.Abstract.Context as X import Control.Abstract.Evaluator as X hiding (LoopControl(..), Return(..), catchLoopControl, runLoopControl, catchReturn, runReturn) import Control.Abstract.Modules as X (Modules, ModuleResult, ResolutionError(..), load, lookupModule, listModulesInDir, require, resolve, throwResolutionError) -import Control.Abstract.Value as X hiding (Bitwise(..), Boolean(..), Function(..), Numeric(..), String(..), Unit(..), While(..)) +import Control.Abstract.Value as X hiding (Bitwise(..), Boolean(..), Function(..), Numeric(..), Object(..), String(..), Unit(..), While(..)) import Data.Abstract.BaseError as X import Data.Abstract.Declarations as X import Data.Abstract.FreeVariables as X diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index 81139b83d..8bea50eb2 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -13,7 +13,7 @@ module Data.Abstract.Value.Type import Control.Abstract.ScopeGraph import qualified Control.Abstract as Abstract -import Control.Abstract hiding (Boolean(..), Function(..), Numeric(..), String(..), Unit(..), While(..)) +import Control.Abstract hiding (Boolean(..), Function(..), Numeric(..), Object(..), String(..), Unit(..), While(..)) import Control.Effect.Carrier import Control.Effect.Sum import Data.Abstract.BaseError @@ -371,6 +371,12 @@ instance ( Member (Reader ModuleInfo) sig LiftBitwise2 _ t1 t2 k -> unify Int t1 >>= unify t2 >>= runBitwiseC . k UnsignedRShift t1 t2 k -> unify Int t2 *> unify Int t1 >>= runBitwiseC . k) +instance ( Carrier sig m ) => Carrier (Abstract.Object address Type :+: sig) (ObjectC address Type m) where + ret = ObjectC . ret + eff = ObjectC . handleSum (eff . handleCoercible) (\case + Abstract.Object _ k -> runObjectC (k Object) + Abstract.ScopedEnvironment _ k -> runObjectC (k Nothing)) + instance AbstractHole Type where hole = Hole @@ -399,7 +405,6 @@ instance ( Member Fresh sig namespace _ _ = pure Unit scopedEnvironment _ = pure Nothing - object _ = pure Object asPair t = do From db8149be7fafbfdc7197962ce2632d29fea4a35e Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Tue, 8 Jan 2019 13:41:36 -0500 Subject: [PATCH 072/127] Add object carrier instance to concrete domain --- src/Data/Abstract/Value/Concrete.hs | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 158e7d28c..67716efe7 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -9,7 +9,7 @@ module Data.Abstract.Value.Concrete import Control.Abstract.ScopeGraph (Allocator, ScopeError) import Control.Abstract.Heap (scopeLookup) import qualified Control.Abstract as Abstract -import Control.Abstract hiding (Boolean(..), Function(..), Numeric(..), String(..), Unit(..), While(..)) +import Control.Abstract hiding (Boolean(..), Function(..), Numeric(..), Object(..), String(..), Unit(..), While(..)) import Control.Effect.Carrier import Control.Effect.Interpose import Control.Effect.Sum @@ -249,6 +249,18 @@ instance ( Member (Reader ModuleInfo) sig ourShift :: Word64 -> Int -> Integer ourShift a b = toInteger (shiftR a b) + +instance Carrier sig m => Carrier (Abstract.Object address (Value term address) :+: sig) (ObjectC address (Value term address) m) where + ret = ObjectC . ret + eff = ObjectC . handleSum (eff . handleCoercible) (\case + Abstract.Object address k -> runObjectC (k (Object address)) + Abstract.ScopedEnvironment (Object address) k -> runObjectC (k (Just address)) + Abstract.ScopedEnvironment (Class _ _ address) k -> runObjectC (k (Just address)) + Abstract.ScopedEnvironment (Namespace _ address) k -> runObjectC (k (Just address)) + Abstract.ScopedEnvironment _ k -> runObjectC (k Nothing) + ) + + instance AbstractHole (Value term address) where hole = Hole From 708904abaea597e5a8883b69e3102fe4c9b8f9bd Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Tue, 8 Jan 2019 13:47:27 -0500 Subject: [PATCH 073/127] added object to runDomain effect --- src/Semantic/Analysis.hs | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index f6b908580..81ce8cf54 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -33,9 +33,10 @@ type DomainC term address value m ( StringC value (Eff ( NumericC value (Eff ( BitwiseC value (Eff + ( ObjectC address value (Eff ( UnitC value (Eff ( InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff - 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 @@ -87,8 +88,11 @@ runDomainEffects :: ( AbstractValue term address value (DomainC term address val , unitC ~ UnitC value (Eff (InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff m))) , unitSig ~ (Unit value :+: Interpose (Resumable (BaseError (UnspecializedError address value))) :+: sig) , Carrier unitSig unitC - , bitwiseC ~ BitwiseC value (Eff unitC) - , bitwiseSig ~ (Abstract.Bitwise value :+: unitSig) + , objectC ~ ObjectC address value (Eff unitC) + , objectSig ~ (Abstract.Object address value :+: unitSig) + , Carrier objectSig objectC + , bitwiseC ~ BitwiseC value (Eff objectC) + , bitwiseSig ~ (Abstract.Bitwise value :+: objectSig) , Carrier bitwiseSig bitwiseC , numericC ~ NumericC value (Eff bitwiseC) , numericSig ~ (Abstract.Numeric value :+: bitwiseSig) @@ -129,6 +133,7 @@ runDomainEffects :: ( AbstractValue term address value (DomainC term address val runDomainEffects runTerm = raiseHandler runInterpose . runUnit + . runObject . runBitwise . runNumeric . runString From 8c3305ff47d481906c1862535a1a96eebf0c3cc8 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Tue, 8 Jan 2019 13:54:47 -0500 Subject: [PATCH 074/127] evaluatable instances can now use object effects --- src/Data/Abstract/Evaluatable.hs | 1 + src/Semantic/Analysis.hs | 1 + 2 files changed, 2 insertions(+) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 4ffe8ba61..825e192f6 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -56,6 +56,7 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where , Member (Function term address value) sig , Member (Modules address value) sig , Member (Numeric value) sig + , Member (Object address value) sig , Member (Reader ModuleInfo) sig , Member (Reader PackageInfo) sig , Member (Reader Span) sig diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 81ce8cf54..ccf0631c0 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -160,6 +160,7 @@ evalTerm :: ( Carrier sig m , Member (Function term address value) sig , Member (Modules address value) sig , Member (Numeric value) sig + , Member (Object address value) sig , Member (Reader ModuleInfo) sig , Member (Reader PackageInfo) sig , Member (Reader Span) sig From 9c88dc06157b19130ffef7908b11296e38d985dc Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Tue, 8 Jan 2019 14:38:45 -0500 Subject: [PATCH 075/127] move scopedEnvironment and object from abstractValue to effects --- src/Control/Abstract/Value.hs | 14 +++++++++----- src/Data/Abstract/Evaluatable.hs | 6 ++++-- src/Data/Abstract/Value/Concrete.hs | 9 --------- src/Data/Abstract/Value/Type.hs | 3 --- src/Language/TypeScript/Syntax/TypeScript.hs | 1 + 5 files changed, 14 insertions(+), 19 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 7c188222e..a90d2dcfe 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -41,6 +41,8 @@ module Control.Abstract.Value , liftNumeric2 , Numeric(..) , NumericC(..) +, object +, scopedEnvironment , Object(..) , ObjectC(..) , runObject @@ -376,6 +378,13 @@ runBitwise = raiseHandler $ runBitwiseC . interpret newtype BitwiseC value m a = BitwiseC { runBitwiseC :: m a } +object :: (Member (Object address value) sig, Carrier sig m) => address -> m value +object address = send (Object address ret) + +-- | Extract the environment from any scoped object (e.g. classes, namespaces, etc). +scopedEnvironment :: (Member (Object address value) sig, Carrier sig m) => value -> m (Maybe address) +scopedEnvironment value = send (ScopedEnvironment value ret) + data Object address value (m :: * -> *) k = Object address (value -> k) | ScopedEnvironment value (Maybe address -> k) @@ -438,8 +447,3 @@ class AbstractIntro value => AbstractValue term address value carrier where namespace :: Name -- ^ The namespace's identifier -> address -- ^ The frame of the namespace. -> Evaluator term address value carrier value - - -- | Extract the environment from any scoped object (e.g. classes, namespaces, etc). - scopedEnvironment :: value -> Evaluator term address value carrier (Maybe address) - - object :: address -> Evaluator term address value carrier value diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 825e192f6..de02ae790 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -86,6 +86,7 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where ref :: ( AbstractValue term address value m , Carrier sig m , Declarations term + , Member (Object address value) sig , Member (Reader (CurrentFrame address)) sig , Member (Reader (CurrentScope address)) sig , Member (Reader ModuleInfo) sig @@ -130,6 +131,7 @@ class HasPrelude (language :: Language) where , Member (Reader (CurrentScope address)) sig , Member Trace sig , Member (Unit value) sig + , Member (Object address value) sig , Ord address , Show address ) @@ -165,8 +167,7 @@ instance HasPrelude 'JavaScript where defineSelf defineNamespace (Declaration (X.name "console")) $ defineBuiltIn (Declaration $ X.name "log") Default Print -defineSelf :: ( AbstractValue term address value m - , Carrier sig m +defineSelf :: ( Carrier sig m , Member (State (ScopeGraph address)) sig , Member (Resumable (BaseError (ScopeError address))) sig , Member (Resumable (BaseError (HeapError address))) sig @@ -176,6 +177,7 @@ defineSelf :: ( AbstractValue term address value m , Member (State (Heap address address value)) sig , Member (Reader (CurrentFrame address)) sig , Member (Reader (CurrentScope address)) sig + , Member (Object address value) sig , Ord address ) => Evaluator term address value m () diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 67716efe7..77d448e08 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -296,13 +296,6 @@ instance ( Member (Abstract.Boolean (Value term address)) sig namespace name = pure . Namespace name - scopedEnvironment v - | Object address <- v = pure (Just address) - | Class _ _ address <- v = pure (Just address) - | Namespace _ address <- v = pure (Just address) - | otherwise = pure Nothing - - index = go where tryIdx list ii | ii > genericLength list = throwValueError (BoundsError list ii) @@ -335,8 +328,6 @@ instance ( Member (Abstract.Boolean (Value term address)) sig pair = (left, right) - object frameAddress = pure (Object frameAddress) - -- | The type of exceptions that can be thrown when constructing values in 'Value'’s 'MonadValue' instance. data ValueError term address resume where StringError :: Value term address -> ValueError term address Text diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index 8bea50eb2..e544d97f9 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -404,9 +404,6 @@ instance ( Member Fresh sig klass _ _ = pure Object namespace _ _ = pure Unit - scopedEnvironment _ = pure Nothing - object _ = pure Object - asPair t = do t1 <- fresh t2 <- fresh diff --git a/src/Language/TypeScript/Syntax/TypeScript.hs b/src/Language/TypeScript/Syntax/TypeScript.hs index 7c4c0df47..8a23ed4cb 100644 --- a/src/Language/TypeScript/Syntax/TypeScript.hs +++ b/src/Language/TypeScript/Syntax/TypeScript.hs @@ -222,6 +222,7 @@ declareModule :: ( AbstractValue term address value m , Declarations term , Member (Allocator address) sig , Member (Deref value) sig + , Member (Object address value) sig , Member (Reader (CurrentFrame address)) sig , Member (Reader (CurrentScope address)) sig , Member (Reader Span) sig From b6295817f976c7cc836339ac3571c1969f87c355 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Tue, 8 Jan 2019 16:01:42 -0500 Subject: [PATCH 076/127] add Klass constructor to Object effect data type --- src/Control/Abstract/Value.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index a90d2dcfe..114427230 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -388,6 +388,7 @@ scopedEnvironment value = send (ScopedEnvironment value ret) data Object address value (m :: * -> *) k = Object address (value -> k) | ScopedEnvironment value (Maybe address -> k) + | Klass Declaration address (value -> k) deriving (Functor) instance HFunctor (Object address value) where From bc396f9552f0cf26dc3ac25a1908ef9c1da41a89 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Tue, 8 Jan 2019 20:44:08 -0500 Subject: [PATCH 077/127] add Klass constructor to object carrier instance in Abstract domain --- src/Data/Abstract/Value/Abstract.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index d249d8684..f2eb54cb8 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -116,7 +116,8 @@ instance Carrier sig m ret = ObjectC . ret eff = ObjectC . handleSum (eff . handleCoercible) (\case Object _ k -> runObjectC (k Abstract) - ScopedEnvironment _ k -> runObjectC (k Nothing)) + ScopedEnvironment _ k -> runObjectC (k Nothing) + Klass _ _ k -> runObjectC (k Abstract)) instance Ord address => ValueRoots address Abstract where valueRoots = mempty From 10bab90d276286ecbd392e6d20329f249cd72871 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Tue, 8 Jan 2019 20:45:26 -0500 Subject: [PATCH 078/127] add Klass constructor to object carrier instance in type domain --- src/Data/Abstract/Value/Type.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index e544d97f9..7134680a6 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -375,7 +375,8 @@ instance ( Carrier sig m ) => Carrier (Abstract.Object address Type :+: sig) (Ob ret = ObjectC . ret eff = ObjectC . handleSum (eff . handleCoercible) (\case Abstract.Object _ k -> runObjectC (k Object) - Abstract.ScopedEnvironment _ k -> runObjectC (k Nothing)) + Abstract.ScopedEnvironment _ k -> runObjectC (k Nothing) + Abstract.Klass _ _ k -> runObjectC (k Object)) instance AbstractHole Type where hole = Hole From 1f12fff84fe04d11ac5f27d9abc0638cf088031e Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Tue, 8 Jan 2019 20:55:36 -0500 Subject: [PATCH 079/127] add Klass constructor to object carrier instance in concrete domain --- src/Data/Abstract/Value/Concrete.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 77d448e08..81ec38d7b 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -258,6 +258,7 @@ instance Carrier sig m => Carrier (Abstract.Object address (Value term address) Abstract.ScopedEnvironment (Class _ _ address) k -> runObjectC (k (Just address)) Abstract.ScopedEnvironment (Namespace _ address) k -> runObjectC (k (Just address)) Abstract.ScopedEnvironment _ k -> runObjectC (k Nothing) + Abstract.Klass n frame k -> runObjectC (k (Class n mempty frame)) ) From dbf0b8484753edf96adc5bea5466d5aa4be98fd3 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Wed, 9 Jan 2019 10:20:58 -0500 Subject: [PATCH 080/127] bye felicia to klass in Abstract domain --- src/Data/Abstract/Value/Abstract.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index f2eb54cb8..9324ffb66 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -135,7 +135,6 @@ instance AbstractValue term address Abstract m where tuple _ = pure Abstract - klass _ _ = pure Abstract namespace _ _ = pure Abstract asPair _ = pure (Abstract, Abstract) From b8b20bdd98ab1d6677bb3ad743cea6ff76530755 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Wed, 9 Jan 2019 10:21:07 -0500 Subject: [PATCH 081/127] bye felicia to klass in Type domain --- src/Data/Abstract/Value/Type.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index 7134680a6..fbcce4841 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -402,7 +402,6 @@ instance ( Member Fresh sig tuple fields = pure $ zeroOrMoreProduct fields - klass _ _ = pure Object namespace _ _ = pure Unit asPair t = do From 9abf7b3cc3cc43b8e26a73020679839e0886e5f6 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Wed, 9 Jan 2019 10:21:15 -0500 Subject: [PATCH 082/127] bye felicia to klass in Concrete domain --- src/Data/Abstract/Value/Concrete.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 81ec38d7b..0cb3dcc9c 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -292,9 +292,6 @@ instance ( Member (Abstract.Boolean (Value term address)) sig | Array addresses <- val = pure addresses | otherwise = throwValueError $ ArrayError val - klass n frame = do - pure $ Class n mempty frame - namespace name = pure . Namespace name index = go where From 27efda0de5c7461f3b4dd550d4d7cdc62512c8d0 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Wed, 9 Jan 2019 10:21:56 -0500 Subject: [PATCH 083/127] klass smart constructor replaces klass method in AbstractValue --- src/Control/Abstract/Value.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 114427230..b800db25b 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -43,6 +43,7 @@ module Control.Abstract.Value , NumericC(..) , object , scopedEnvironment +, klass , Object(..) , ObjectC(..) , runObject @@ -385,6 +386,12 @@ object address = send (Object address ret) scopedEnvironment :: (Member (Object address value) sig, Carrier sig m) => value -> m (Maybe address) scopedEnvironment value = send (ScopedEnvironment value ret) +-- | Build a class value from a name and environment. +-- declaration is the new class's identifier +-- address is the environment to capture +klass :: (Member (Object address value) sig, Carrier sig m) => Declaration -> address -> m value +klass d a = send (Klass d a ret) + data Object address value (m :: * -> *) k = Object address (value -> k) | ScopedEnvironment value (Maybe address -> k) @@ -437,11 +444,6 @@ class AbstractIntro value => AbstractValue term address value carrier where -- | @index x i@ computes @x[i]@, with zero-indexing. index :: value -> value -> Evaluator term address value carrier value - -- | Build a class value from a name and environment. - klass :: Declaration -- ^ The new class's identifier - -> address -- ^ The environment to capture - -> Evaluator term address value carrier value - -- | Build a namespace value from a name and environment stack -- -- Namespaces model closures with monoidal environments. From eff8e2bb82810732a34bf2a1f488f3b5ff9b43e7 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Wed, 9 Jan 2019 11:34:15 -0500 Subject: [PATCH 084/127] stub out Array effect data type --- src/Control/Abstract/Value.hs | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index b800db25b..e1a4e2f73 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -54,6 +54,7 @@ module Control.Abstract.Value , unsignedRShift , Bitwise(..) , BitwiseC(..) +, Array(..) , runBitwise ) where @@ -412,6 +413,17 @@ runObject :: Carrier (Object address value :+: sig) (ObjectC address value (Eff -> Evaluator term address value m a runObject = raiseHandler $ runObjectC . interpret +data Array value (m :: * -> *) k + = Array [value] (value -> k) + | AsArray value ([value] -> k) + deriving (Functor) + +instance HFunctor (Array value) where + hmap _ = coerce + {-# INLINE hmap #-} + +instance Effect (Array value) where + handle state handler = coerce . fmap (handler . (<$ state)) class Show value => AbstractIntro value where -- | Construct a key-value pair for use in a hash. From 3eaebef18089fe586e6ef52d9332e77a68dd62d6 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Wed, 9 Jan 2019 11:34:37 -0500 Subject: [PATCH 085/127] ArrayC carrier type --- src/Control/Abstract/Value.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index e1a4e2f73..3f227fa42 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -55,6 +55,7 @@ module Control.Abstract.Value , Bitwise(..) , BitwiseC(..) , Array(..) +, ArrayC(..) , runBitwise ) where @@ -425,6 +426,7 @@ instance HFunctor (Array value) where instance Effect (Array value) where handle state handler = coerce . fmap (handler . (<$ state)) +newtype ArrayC value m a = ArrayC { runArrayC :: m a } class Show value => AbstractIntro value where -- | Construct a key-value pair for use in a hash. kvPair :: value -> value -> value From 8cc1108071777bb4a784282f1ce635f1b5af52e0 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Wed, 9 Jan 2019 11:35:00 -0500 Subject: [PATCH 086/127] create runArray effect handler --- src/Control/Abstract/Value.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 3f227fa42..80a3c8e80 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -56,6 +56,7 @@ module Control.Abstract.Value , BitwiseC(..) , Array(..) , ArrayC(..) +, runArray , runBitwise ) where @@ -427,6 +428,12 @@ instance Effect (Array value) where handle state handler = coerce . fmap (handler . (<$ state)) newtype ArrayC value m a = ArrayC { runArrayC :: m a } + +runArray :: Carrier (Array value :+: sig) (ArrayC value (Eff m)) + => Evaluator term address value (ArrayC value (Eff m)) a + -> Evaluator term address value m a +runArray = raiseHandler $ runArrayC . interpret + class Show value => AbstractIntro value where -- | Construct a key-value pair for use in a hash. kvPair :: value -> value -> value From a14fcccd16159fb12207810d143ed3d7c1804e12 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Wed, 9 Jan 2019 20:38:34 -0500 Subject: [PATCH 087/127] add Array carrier instance to Abstract domain --- src/Data/Abstract/Value/Abstract.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index 9324ffb66..586dae424 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -119,6 +119,13 @@ instance Carrier sig m ScopedEnvironment _ k -> runObjectC (k Nothing) Klass _ _ k -> runObjectC (k Abstract)) +instance Carrier sig m + => Carrier (Array Abstract :+: sig) (ArrayC Abstract m) where + ret = ArrayC . ret + eff = ArrayC . handleSum (eff . handleCoercible) (\case + Array _ k -> runArrayC (k Abstract) + AsArray _ k -> runArrayC (k [])) + instance Ord address => ValueRoots address Abstract where valueRoots = mempty From 7b1fdcb34fa40cea068292b0ddbae479377acdcd Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Wed, 9 Jan 2019 20:39:48 -0500 Subject: [PATCH 088/127] Add initial working but ugly carrier instance for Array in type domain --- src/Data/Abstract/Value/Type.hs | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index fbcce4841..a44e03f88 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -13,7 +13,7 @@ module Data.Abstract.Value.Type import Control.Abstract.ScopeGraph import qualified Control.Abstract as Abstract -import Control.Abstract hiding (Boolean(..), Function(..), Numeric(..), Object(..), String(..), Unit(..), While(..)) +import Control.Abstract hiding (Boolean(..), Function(..), Numeric(..), Object(..), Array(..), String(..), Unit(..), While(..)) import Control.Effect.Carrier import Control.Effect.Sum import Data.Abstract.BaseError @@ -378,6 +378,24 @@ instance ( Carrier sig m ) => Carrier (Abstract.Object address Type :+: sig) (Ob Abstract.ScopedEnvironment _ k -> runObjectC (k Nothing) Abstract.Klass _ _ k -> runObjectC (k Object)) +instance ( Member Fresh sig + , Member (Reader ModuleInfo) sig + , Member (Reader Span) sig + , Member (Resumable (BaseError TypeError)) sig + , Member (State TypeMap) sig + , Carrier sig m + , Monad m + ) + => Carrier (Abstract.Array Type :+: sig) (ArrayC Type m) where + ret = ArrayC . ret + eff = ArrayC . handleSum (eff . handleCoercible) (\case + Abstract.Array fieldTypes k -> (do + var <- fresh + Array <$> foldr (\ t1 -> (unify t1 =<<)) (pure (Var var)) fieldTypes) >>= runArrayC . k + Abstract.AsArray t k -> (do + field <- fresh + unify t (Array (Var field)) $> mempty) >>= runArrayC . k) + instance AbstractHole Type where hole = Hole From 48c32ce4b60073ae7245abd202db994789c4ff6b Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Wed, 9 Jan 2019 20:40:06 -0500 Subject: [PATCH 089/127] update Evaluatable to disambiguate --- 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 de02ae790..59b2b23c7 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -22,7 +22,7 @@ import qualified Control.Abstract as Abstract import Control.Abstract.Context as X import Control.Abstract.Evaluator as X hiding (LoopControl(..), Return(..), catchLoopControl, runLoopControl, catchReturn, runReturn) import Control.Abstract.Modules as X (Modules, ModuleResult, ResolutionError(..), load, lookupModule, listModulesInDir, require, resolve, throwResolutionError) -import Control.Abstract.Value as X hiding (Bitwise(..), Boolean(..), Function(..), Numeric(..), Object(..), String(..), Unit(..), While(..)) +import Control.Abstract.Value as X hiding (Bitwise(..), Boolean(..), Function(..), Numeric(..), Object(..), Array(..), String(..), Unit(..), While(..)) import Data.Abstract.BaseError as X import Data.Abstract.Declarations as X import Data.Abstract.FreeVariables as X From 0bf26f647731f1ce80d718e65fb33f10cf5b99e4 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 11 Jan 2019 11:21:23 -0500 Subject: [PATCH 090/127] rewrite AsArray in type domain --- src/Data/Abstract/Value/Type.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index a44e03f88..f3f828b8a 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -394,7 +394,8 @@ instance ( Member Fresh sig Array <$> foldr (\ t1 -> (unify t1 =<<)) (pure (Var var)) fieldTypes) >>= runArrayC . k Abstract.AsArray t k -> (do field <- fresh - unify t (Array (Var field)) $> mempty) >>= runArrayC . k) + unify t (Array (Var field)) >> runArrayC (k mempty))) + instance AbstractHole Type where hole = Hole From 745b739538cf4d9ce37def02298ad4d06df7f5a4 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 11 Jan 2019 13:26:42 -0500 Subject: [PATCH 091/127] array carrier instance for concrete domain --- src/Data/Abstract/Value/Concrete.hs | 19 +++++++++++++++++-- 1 file changed, 17 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 0cb3dcc9c..4d3bf39cb 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -9,7 +9,7 @@ module Data.Abstract.Value.Concrete import Control.Abstract.ScopeGraph (Allocator, ScopeError) import Control.Abstract.Heap (scopeLookup) import qualified Control.Abstract as Abstract -import Control.Abstract hiding (Boolean(..), Function(..), Numeric(..), Object(..), String(..), Unit(..), While(..)) +import Control.Abstract hiding (Boolean(..), Function(..), Numeric(..), Object(..), Array(..), String(..), Unit(..), While(..)) import Control.Effect.Carrier import Control.Effect.Interpose import Control.Effect.Sum @@ -261,7 +261,22 @@ instance Carrier sig m => Carrier (Abstract.Object address (Value term address) Abstract.Klass n frame k -> runObjectC (k (Class n mempty frame)) ) - +instance ( Member (Abstract.Boolean (Value term address)) sig + , Member (Reader ModuleInfo) sig + , Member (Reader Span) sig + , Member (Resumable (BaseError (ValueError term address))) sig + , Show address + , Show term + , Carrier sig m + , Monad m + ) + => Carrier (Abstract.Array (Value term address) :+: sig) (ArrayC (Value term address) m) where + ret = ArrayC . ret + eff = ArrayC . handleSum (eff . handleCoercible) (\case + Abstract.Array t k -> runArrayC (k (Array t)) + Abstract.AsArray (Array addresses) k -> pure addresses >>= runArrayC . k + Abstract.AsArray val k -> (throwBaseError $ ArrayError val) >>= runArrayC . k) + instance AbstractHole (Value term address) where hole = Hole From 8745c48dfaa3731b0ed4a3e6885e550e0ab77bb1 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 11 Jan 2019 13:27:45 -0500 Subject: [PATCH 092/127] remove redundant constraints --- src/Data/Abstract/Value/Concrete.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 4d3bf39cb..38e7cf65f 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -261,12 +261,9 @@ instance Carrier sig m => Carrier (Abstract.Object address (Value term address) Abstract.Klass n frame k -> runObjectC (k (Class n mempty frame)) ) -instance ( Member (Abstract.Boolean (Value term address)) sig - , Member (Reader ModuleInfo) sig +instance ( Member (Reader ModuleInfo) sig , Member (Reader Span) sig , Member (Resumable (BaseError (ValueError term address))) sig - , Show address - , Show term , Carrier sig m , Monad m ) @@ -276,7 +273,7 @@ instance ( Member (Abstract.Boolean (Value term address)) sig Abstract.Array t k -> runArrayC (k (Array t)) Abstract.AsArray (Array addresses) k -> pure addresses >>= runArrayC . k Abstract.AsArray val k -> (throwBaseError $ ArrayError val) >>= runArrayC . k) - + instance AbstractHole (Value term address) where hole = Hole From 92cd5634dc8e65ba004ee5d91a3c7bc50668dc75 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 11 Jan 2019 13:30:31 -0500 Subject: [PATCH 093/127] rewrite first AsArray condition --- src/Data/Abstract/Value/Concrete.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 38e7cf65f..94e5dbecc 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -271,7 +271,7 @@ instance ( Member (Reader ModuleInfo) sig ret = ArrayC . ret eff = ArrayC . handleSum (eff . handleCoercible) (\case Abstract.Array t k -> runArrayC (k (Array t)) - Abstract.AsArray (Array addresses) k -> pure addresses >>= runArrayC . k + Abstract.AsArray (Array addresses) k -> runArrayC (k addresses) Abstract.AsArray val k -> (throwBaseError $ ArrayError val) >>= runArrayC . k) instance AbstractHole (Value term address) where From 5bfbb0a95bf65e46c3036efe7f13ff3f1e559d69 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 11 Jan 2019 13:44:34 -0500 Subject: [PATCH 094/127] add array to runDomainEffects --- src/Semantic/Analysis.hs | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index ccf0631c0..7519110a1 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -34,9 +34,10 @@ type DomainC term address value m ( NumericC value (Eff ( BitwiseC value (Eff ( ObjectC address value (Eff + ( ArrayC value (Eff ( UnitC value (Eff ( InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff - 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 @@ -88,8 +89,11 @@ runDomainEffects :: ( AbstractValue term address value (DomainC term address val , unitC ~ UnitC value (Eff (InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff m))) , unitSig ~ (Unit value :+: Interpose (Resumable (BaseError (UnspecializedError address value))) :+: sig) , Carrier unitSig unitC - , objectC ~ ObjectC address value (Eff unitC) - , objectSig ~ (Abstract.Object address value :+: unitSig) + , arrayC ~ ArrayC value (Eff unitC) + , arraySig ~ (Abstract.Array value :+: unitSig) + , Carrier arraySig arrayC + , objectC ~ ObjectC address value (Eff arrayC) + , objectSig ~ (Abstract.Object address value :+: arraySig) , Carrier objectSig objectC , bitwiseC ~ BitwiseC value (Eff objectC) , bitwiseSig ~ (Abstract.Bitwise value :+: objectSig) @@ -133,6 +137,7 @@ runDomainEffects :: ( AbstractValue term address value (DomainC term address val runDomainEffects runTerm = raiseHandler runInterpose . runUnit + . runArray . runObject . runBitwise . runNumeric @@ -161,6 +166,7 @@ evalTerm :: ( Carrier sig m , Member (Modules address value) sig , Member (Numeric value) sig , Member (Object address value) sig + , Member (Array value) sig , Member (Reader ModuleInfo) sig , Member (Reader PackageInfo) sig , Member (Reader Span) sig From decbc554aec8ed4957c1cd00057ba641d891bcfc Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 11 Jan 2019 13:44:47 -0500 Subject: [PATCH 095/127] evaluatable instances can now use array effects --- src/Data/Abstract/Evaluatable.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 59b2b23c7..21005e943 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -57,6 +57,7 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where , Member (Modules address value) sig , Member (Numeric value) sig , Member (Object address value) sig + , Member (Array value) sig , Member (Reader ModuleInfo) sig , Member (Reader PackageInfo) sig , Member (Reader Span) sig From 91aee90ae648b731ad00723659d0ba6ec2e118c2 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 11 Jan 2019 13:59:23 -0500 Subject: [PATCH 096/127] smart constructors are better than dumb constructors (array and asArray) --- src/Control/Abstract/Value.hs | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 80a3c8e80..7c629fcd6 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -54,6 +54,8 @@ module Control.Abstract.Value , unsignedRShift , Bitwise(..) , BitwiseC(..) +, array +, asArray , Array(..) , ArrayC(..) , runArray @@ -415,6 +417,15 @@ runObject :: Carrier (Object address value :+: sig) (ObjectC address value (Eff -> Evaluator term address value m a runObject = raiseHandler $ runObjectC . interpret +-- | Construct an array of zero or more values. +-- array :: [value] -> Evaluator term address value carrier value +array :: (Member (Array value) sig, Carrier sig m) => [value] -> m value +array v = send (Array v ret) + +-- asArray :: value -> Evaluator term address value carrier [value] +asArray :: (Member (Array value) sig, Carrier sig m) => value -> m [value] +asArray v = send (AsArray v ret) + data Array value (m :: * -> *) k = Array [value] (value -> k) | AsArray value ([value] -> k) @@ -454,11 +465,6 @@ class AbstractIntro value => AbstractValue term address value carrier where -- | Construct an N-ary tuple of multiple (possibly-disjoint) values tuple :: [value] -> Evaluator term address value carrier value - -- | Construct an array of zero or more values. - array :: [value] -> Evaluator term address value carrier value - - asArray :: value -> Evaluator term address value carrier [value] - -- | Extract the contents of a key-value pair as a tuple. asPair :: value -> Evaluator term address value carrier (value, value) From 30775c4902b2c8591e0d80d29175d6323629228a Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 11 Jan 2019 14:55:58 -0500 Subject: [PATCH 097/127] remove AbstractValue array methods from Abstract domain --- src/Data/Abstract/Value/Abstract.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index 586dae424..9ffbca857 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -138,14 +138,11 @@ instance AbstractIntro Abstract where null = Abstract instance AbstractValue term address Abstract m where - array _ = pure Abstract - tuple _ = pure Abstract namespace _ _ = pure Abstract asPair _ = pure (Abstract, Abstract) - asArray _ = pure mempty index _ _ = pure Abstract From 634affcd31148d28cbcce6078875f0aef4596756 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 11 Jan 2019 14:56:05 -0500 Subject: [PATCH 098/127] remove AbstractValue array methods from Concrete domain --- src/Data/Abstract/Value/Concrete.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 94e5dbecc..968905029 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -298,11 +298,6 @@ instance ( Member (Abstract.Boolean (Value term address)) sig | otherwise = throwValueError $ KeyValueError val tuple = pure . Tuple - array = pure . Array - - asArray val - | Array addresses <- val = pure addresses - | otherwise = throwValueError $ ArrayError val namespace name = pure . Namespace name From c278dc3bd3577e86d896a83f70a0496573917393 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 11 Jan 2019 14:56:11 -0500 Subject: [PATCH 099/127] remove AbstractValue array methods from Type domain --- src/Data/Abstract/Value/Type.hs | 7 ------- 1 file changed, 7 deletions(-) diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index f3f828b8a..6f44bca88 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -415,10 +415,6 @@ instance ( Member Fresh sig , Carrier sig m ) => AbstractValue term address Type m where - array fieldTypes = do - var <- fresh - Array <$> foldr (\ t1 -> (unify t1 =<<)) (pure (Var var)) fieldTypes - tuple fields = pure $ zeroOrMoreProduct fields namespace _ _ = pure Unit @@ -427,9 +423,6 @@ instance ( Member Fresh sig t1 <- fresh t2 <- fresh unify t (Var t1 :* Var t2) $> (Var t1, Var t2) - asArray t = do - field <- fresh - unify t (Array (Var field)) $> mempty index arr sub = do _ <- unify sub Int From 4b5ba568af0e09ba5294f2af2d299165dd27fe9d Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 11 Jan 2019 15:06:36 -0500 Subject: [PATCH 100/127] make ghc happy --- src/Control/Abstract/PythonPackage.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Control/Abstract/PythonPackage.hs b/src/Control/Abstract/PythonPackage.hs index 54e27d241..cb0c4a371 100644 --- a/src/Control/Abstract/PythonPackage.hs +++ b/src/Control/Abstract/PythonPackage.hs @@ -20,6 +20,7 @@ runPythonPackaging :: ( Carrier sig m , Show term , Member (Boolean (Value term address)) sig , Member (Abstract.String (Value term address)) sig + , Member (Abstract.Array (Value term address)) sig , Member (Resumable (BaseError (ValueError term address))) sig , Member (State Strategy) sig , Member (Reader ModuleInfo) sig @@ -43,6 +44,7 @@ instance ( Carrier sig m , Member (Resumable (BaseError (ValueError term address))) sig , Member (State Strategy) sig , Member (Abstract.String (Value term address)) sig + , Member (Abstract.Array (Value term address)) sig , Show address , Show term ) From dc72a67e97b5fd66accc597899dcaafd227b965a Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 11 Jan 2019 15:16:35 -0500 Subject: [PATCH 101/127] get rid of a bajillion redundant constraints and imports --- src/Control/Abstract/PythonPackage.hs | 15 +-------------- 1 file changed, 1 insertion(+), 14 deletions(-) diff --git a/src/Control/Abstract/PythonPackage.hs b/src/Control/Abstract/PythonPackage.hs index cb0c4a371..9fac4bda1 100644 --- a/src/Control/Abstract/PythonPackage.hs +++ b/src/Control/Abstract/PythonPackage.hs @@ -5,10 +5,9 @@ module Control.Abstract.PythonPackage import Control.Abstract as Abstract import Control.Effect.Carrier import Control.Effect.Sum -import Data.Abstract.Evaluatable import Data.Abstract.Name (name) import Data.Abstract.Path (stripQuotes) -import Data.Abstract.Value.Concrete (Value (..), ValueError (..)) +import Data.Abstract.Value.Concrete (Value (..)) import qualified Data.Map as Map import Prologue @@ -16,15 +15,9 @@ data Strategy = Unknown | Packages [Text] | FindPackages [Text] deriving (Show, Eq) runPythonPackaging :: ( Carrier sig m - , Show address - , Show term - , Member (Boolean (Value term address)) sig , Member (Abstract.String (Value term address)) sig , Member (Abstract.Array (Value term address)) sig - , Member (Resumable (BaseError (ValueError term address))) sig , Member (State Strategy) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig , Member (Function term address (Value term address)) sig) => Evaluator term address (Value term address) (PythonPackagingC term address (Eff m)) a -> Evaluator term address (Value term address) m a @@ -37,16 +30,10 @@ wrap :: Evaluator term address (Value term address) m a -> PythonPackagingC term wrap = PythonPackagingC . runEvaluator instance ( Carrier sig m - , Member (Boolean (Value term address)) sig , Member (Function term address (Value term address)) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (ValueError term address))) sig , Member (State Strategy) sig , Member (Abstract.String (Value term address)) sig , Member (Abstract.Array (Value term address)) sig - , Show address - , Show term ) => Carrier sig (PythonPackagingC term address (Eff m)) where ret = PythonPackagingC . ret From 8c37ade84ce21f172a5295a231d32105cd72e13a Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 11 Jan 2019 17:14:29 -0500 Subject: [PATCH 102/127] stub out Hash effect, carrier type and handler --- src/Control/Abstract/Value.hs | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 7c629fcd6..6dc9b2a52 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -60,6 +60,9 @@ module Control.Abstract.Value , ArrayC(..) , runArray , runBitwise +, Hash(..) +, runHash +, HashC(..) ) where import Control.Abstract.Evaluator @@ -445,6 +448,26 @@ runArray :: Carrier (Array value :+: sig) (ArrayC value (Eff m)) -> Evaluator term address value m a runArray = raiseHandler $ runArrayC . interpret + +data Hash value (m :: * -> *) k + = Hash [(value, value)] (value -> k) + | KvPair value (value -> value -> k) + deriving (Functor) + +instance HFunctor (Hash value) where + hmap _ = coerce + {-# INLINE hmap #-} + +instance Effect (Hash value) where + handle state handler = coerce . fmap (handler . (<$ state)) + +newtype HashC value m a = HashC { runHashC :: m a } + +runHash :: Carrier (Hash value :+: sig) (HashC value (Eff m)) + => Evaluator term address value (HashC value (Eff m)) a + -> Evaluator term address value m a +runHash = raiseHandler $ runHashC . interpret + class Show value => AbstractIntro value where -- | Construct a key-value pair for use in a hash. kvPair :: value -> value -> value From cca3cb868b044aa4f63a753d65fa8b18e940f24d Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 11 Jan 2019 17:14:41 -0500 Subject: [PATCH 103/127] hide Hash --- 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 21005e943..0c31368bd 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -22,7 +22,7 @@ import qualified Control.Abstract as Abstract import Control.Abstract.Context as X import Control.Abstract.Evaluator as X hiding (LoopControl(..), Return(..), catchLoopControl, runLoopControl, catchReturn, runReturn) import Control.Abstract.Modules as X (Modules, ModuleResult, ResolutionError(..), load, lookupModule, listModulesInDir, require, resolve, throwResolutionError) -import Control.Abstract.Value as X hiding (Bitwise(..), Boolean(..), Function(..), Numeric(..), Object(..), Array(..), String(..), Unit(..), While(..)) +import Control.Abstract.Value as X hiding (Bitwise(..), Boolean(..), Function(..), Numeric(..), Object(..), Array(..), Hash(..), String(..), Unit(..), While(..)) import Data.Abstract.BaseError as X import Data.Abstract.Declarations as X import Data.Abstract.FreeVariables as X From 77b35435d6f10d46c1be1810dcc3b485574cd637 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 11 Jan 2019 17:19:02 -0500 Subject: [PATCH 104/127] correct parameter booboo --- src/Control/Abstract/Value.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 6dc9b2a52..9f327df0e 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -451,7 +451,7 @@ runArray = raiseHandler $ runArrayC . interpret data Hash value (m :: * -> *) k = Hash [(value, value)] (value -> k) - | KvPair value (value -> value -> k) + | KvPair value value (value -> k) deriving (Functor) instance HFunctor (Hash value) where From 68690bf3d85038c71a44458bc38a5c775962c412 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 11 Jan 2019 17:19:33 -0500 Subject: [PATCH 105/127] hash carrier instance for abstract domain --- src/Data/Abstract/Value/Abstract.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index 9ffbca857..19b086bbb 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -126,6 +126,14 @@ instance Carrier sig m Array _ k -> runArrayC (k Abstract) AsArray _ k -> runArrayC (k [])) +instance Carrier sig m + => Carrier (Hash Abstract :+: sig) (HashC Abstract m) where + ret = HashC . ret + eff = HashC . handleSum (eff . handleCoercible) (\case + Hash _ k -> runHashC (k Abstract) + KvPair _ _ k -> runHashC (k Abstract)) + + instance Ord address => ValueRoots address Abstract where valueRoots = mempty From 0fff151f213f6096d9664188545aabf9983bad03 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 11 Jan 2019 17:36:21 -0500 Subject: [PATCH 106/127] stub out incorrect hash carrier instance for type domain --- src/Data/Abstract/Value/Type.hs | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index 6f44bca88..fc3b1e631 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -13,7 +13,7 @@ module Data.Abstract.Value.Type import Control.Abstract.ScopeGraph import qualified Control.Abstract as Abstract -import Control.Abstract hiding (Boolean(..), Function(..), Numeric(..), Object(..), Array(..), String(..), Unit(..), While(..)) +import Control.Abstract hiding (Boolean(..), Function(..), Numeric(..), Object(..), Array(..), Hash(..), String(..), Unit(..), While(..)) import Control.Effect.Carrier import Control.Effect.Sum import Data.Abstract.BaseError @@ -396,6 +396,20 @@ instance ( Member Fresh sig field <- fresh unify t (Array (Var field)) >> runArrayC (k mempty))) +instance ( Member (Reader ModuleInfo) sig + , Member (Reader Span) sig + , Member (Resumable (BaseError TypeError)) sig + , Member (State TypeMap) sig + , Carrier sig m + , Alternative m + , Monad m + ) + => Carrier (Abstract.Hash Type :+: sig) (HashC Type m) where + ret = HashC . ret + eff = HashC . handleSum (eff . handleCoercible) (\case + Abstract.Hash _ k -> runHashC (k Hash) + Abstract.KvPair t v k -> (t :* v) >>= runHash . k) + instance AbstractHole Type where hole = Hole From 6f9a8c273345211352e221c2e660f8742c078e10 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Fri, 11 Jan 2019 17:36:28 -0500 Subject: [PATCH 107/127] stub out incorrect hash carrier instance for concrete domain --- src/Data/Abstract/Value/Concrete.hs | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 968905029..27e2fb322 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -9,7 +9,7 @@ module Data.Abstract.Value.Concrete import Control.Abstract.ScopeGraph (Allocator, ScopeError) import Control.Abstract.Heap (scopeLookup) import qualified Control.Abstract as Abstract -import Control.Abstract hiding (Boolean(..), Function(..), Numeric(..), Object(..), Array(..), String(..), Unit(..), While(..)) +import Control.Abstract hiding (Boolean(..), Function(..), Numeric(..), Object(..), Array(..), Hash(..), String(..), Unit(..), While(..)) import Control.Effect.Carrier import Control.Effect.Interpose import Control.Effect.Sum @@ -274,6 +274,19 @@ instance ( Member (Reader ModuleInfo) sig Abstract.AsArray (Array addresses) k -> runArrayC (k addresses) Abstract.AsArray val k -> (throwBaseError $ ArrayError val) >>= runArrayC . k) +instance ( Member (Reader ModuleInfo) sig + , Member (Reader Span) sig + , Member (Resumable (BaseError (ValueError term address))) sig + , Carrier sig m + , Monad m + ) + => Carrier (Abstract.Hash (Value term address) :+: sig) (HashC (Value term address) m) where + ret = HashC . ret + eff = HashC . handleSum (eff . handleCoercible) (\case + Abstract.Hash t k -> runHashC (k ((Hash . map (uncurry KVPair)) t)) + Abstract.KVPair t v k -> runHashC (k KVPair)) + + instance AbstractHole (Value term address) where hole = Hole From 7e9b5aee94f6a52df9b52abed1178dad6d2b63cb Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Mon, 14 Jan 2019 15:29:00 -0500 Subject: [PATCH 108/127] fix hash carrier instance for type domain --- src/Data/Abstract/Value/Type.hs | 14 +++----------- 1 file changed, 3 insertions(+), 11 deletions(-) diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index fc3b1e631..dde93f55a 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -396,19 +396,11 @@ instance ( Member Fresh sig field <- fresh unify t (Array (Var field)) >> runArrayC (k mempty))) -instance ( Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError TypeError)) sig - , Member (State TypeMap) sig - , Carrier sig m - , Alternative m - , Monad m - ) - => Carrier (Abstract.Hash Type :+: sig) (HashC Type m) where +instance ( Carrier sig m ) => Carrier (Abstract.Hash Type :+: sig) (HashC Type m) where ret = HashC . ret eff = HashC . handleSum (eff . handleCoercible) (\case - Abstract.Hash _ k -> runHashC (k Hash) - Abstract.KvPair t v k -> (t :* v) >>= runHash . k) + Abstract.Hash t k -> runHashC (k (Hash t)) + Abstract.KvPair t1 t2 k -> runHashC (k (t1 :* t2))) instance AbstractHole Type where From dbf197d3665e0f70cee82c3ae8d373741aa770ee Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Mon, 14 Jan 2019 15:29:15 -0500 Subject: [PATCH 109/127] fix hash carrier instance for concrete domain --- src/Data/Abstract/Value/Concrete.hs | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 27e2fb322..64a46e109 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -274,17 +274,11 @@ instance ( Member (Reader ModuleInfo) sig Abstract.AsArray (Array addresses) k -> runArrayC (k addresses) Abstract.AsArray val k -> (throwBaseError $ ArrayError val) >>= runArrayC . k) -instance ( Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (ValueError term address))) sig - , Carrier sig m - , Monad m - ) - => Carrier (Abstract.Hash (Value term address) :+: sig) (HashC (Value term address) m) where +instance ( Carrier sig m ) => Carrier (Abstract.Hash (Value term address) :+: sig) (HashC (Value term address) m) where ret = HashC . ret eff = HashC . handleSum (eff . handleCoercible) (\case Abstract.Hash t k -> runHashC (k ((Hash . map (uncurry KVPair)) t)) - Abstract.KVPair t v k -> runHashC (k KVPair)) + Abstract.KvPair t v k -> runHashC (k (KVPair t v))) instance AbstractHole (Value term address) where From 7021664a67e5a0b8498ef9f117de84dfbacb0834 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Mon, 14 Jan 2019 15:55:59 -0500 Subject: [PATCH 110/127] add hash to runDomainEffects --- src/Semantic/Analysis.hs | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 7519110a1..a81e43cb7 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -35,9 +35,10 @@ type DomainC term address value m ( BitwiseC value (Eff ( ObjectC address value (Eff ( ArrayC value (Eff + ( HashC value (Eff ( UnitC value (Eff ( InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff - 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 @@ -89,8 +90,11 @@ runDomainEffects :: ( AbstractValue term address value (DomainC term address val , unitC ~ UnitC value (Eff (InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff m))) , unitSig ~ (Unit value :+: Interpose (Resumable (BaseError (UnspecializedError address value))) :+: sig) , Carrier unitSig unitC - , arrayC ~ ArrayC value (Eff unitC) - , arraySig ~ (Abstract.Array value :+: unitSig) + , hashC ~ HashC value (Eff unitC) + , hashSig ~ (Abstract.Hash value :+: unitSig) + , Carrier hashSig hashC + , arrayC ~ ArrayC value (Eff hashC) + , arraySig ~ (Abstract.Array value :+: hashSig) , Carrier arraySig arrayC , objectC ~ ObjectC address value (Eff arrayC) , objectSig ~ (Abstract.Object address value :+: arraySig) @@ -137,6 +141,7 @@ runDomainEffects :: ( AbstractValue term address value (DomainC term address val runDomainEffects runTerm = raiseHandler runInterpose . runUnit + . runHash . runArray . runObject . runBitwise @@ -167,6 +172,7 @@ evalTerm :: ( Carrier sig m , Member (Numeric value) sig , Member (Object address value) sig , Member (Array value) sig + , Member (Hash value) sig , Member (Reader ModuleInfo) sig , Member (Reader PackageInfo) sig , Member (Reader Span) sig From 04b5863011b9383706159295cb72e256e7dfb412 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Mon, 14 Jan 2019 15:56:21 -0500 Subject: [PATCH 111/127] evaluatable instances can now use hash --- src/Data/Abstract/Evaluatable.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 0c31368bd..cc814c0c1 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -58,6 +58,7 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where , Member (Numeric value) sig , Member (Object address value) sig , Member (Array value) sig + , Member (Hash value) sig , Member (Reader ModuleInfo) sig , Member (Reader PackageInfo) sig , Member (Reader Span) sig From a6aa6c812b9af4dc40df65eb423b6251da0d77b1 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Mon, 14 Jan 2019 15:56:50 -0500 Subject: [PATCH 112/127] replace AbstractIntro methods with smart constructors for hash and kvPair --- src/Control/Abstract/Value.hs | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 9f327df0e..b11246d4a 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -60,6 +60,8 @@ module Control.Abstract.Value , ArrayC(..) , runArray , runBitwise +, Control.Abstract.Value.hash +, kvPair , Hash(..) , runHash , HashC(..) @@ -448,6 +450,15 @@ runArray :: Carrier (Array value :+: sig) (ArrayC value (Eff m)) -> Evaluator term address value m a runArray = raiseHandler $ runArrayC . interpret +-- | Construct a hash out of pairs. +-- hash :: [(value, value)] -> value +hash :: (Member (Hash value) sig, Carrier sig m) => [(value, value)] -> m value +hash v = send (Hash v ret) + +-- | Construct a key-value pair for use in a hash. +-- kvPair :: value -> value -> value +kvPair :: (Member (Hash value) sig, Carrier sig m) => value -> value -> m value +kvPair v1 v2 = send (KvPair v1 v2 ret) data Hash value (m :: * -> *) k = Hash [(value, value)] (value -> k) @@ -469,12 +480,6 @@ runHash :: Carrier (Hash value :+: sig) (HashC value (Eff m)) runHash = raiseHandler $ runHashC . interpret class Show value => AbstractIntro value where - -- | Construct a key-value pair for use in a hash. - kvPair :: value -> value -> value - - -- | Construct a hash out of pairs. - hash :: [(value, value)] -> value - -- | Construct the nil/null datatype. null :: value From 4de04378dda8374c4cdf09bfb627594197a0ec7d Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Mon, 14 Jan 2019 16:03:22 -0500 Subject: [PATCH 113/127] delete old hash method implementations in Abstract domain --- src/Data/Abstract/Value/Abstract.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index 19b086bbb..d3988e09e 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -141,8 +141,6 @@ instance AbstractHole Abstract where hole = Abstract instance AbstractIntro Abstract where - hash _ = Abstract - kvPair _ _ = Abstract null = Abstract instance AbstractValue term address Abstract m where From e765d9c9511301051d21743dc3d506a1d2c594e6 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Mon, 14 Jan 2019 16:03:50 -0500 Subject: [PATCH 114/127] delete old hash method implementations in Type domain --- src/Data/Abstract/Value/Type.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index dde93f55a..8b0755939 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -407,9 +407,6 @@ instance AbstractHole Type where hole = Hole instance AbstractIntro Type where - hash = Hash - kvPair k v = k :* v - null = Null -- | Discard the value arguments (if any), constructing a 'Type' instead. From 899e847f3a9da2556e9e25b351181fc9a90384c1 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Mon, 14 Jan 2019 16:03:59 -0500 Subject: [PATCH 115/127] delete old hash method implementations in Concrete domain --- src/Data/Abstract/Value/Concrete.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 64a46e109..66e0174b5 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -285,9 +285,6 @@ instance AbstractHole (Value term address) where hole = Hole instance (Show address, Show term) => AbstractIntro (Value term address) where - kvPair = KVPair - hash = Hash . map (uncurry KVPair) - null = Null -- | Construct a 'Value' wrapping the value arguments (if any). From 3a5b679236003cc6e03692d7bb2477223f77810b Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Mon, 14 Jan 2019 16:38:43 -0500 Subject: [PATCH 116/127] change fmap and applicative to do block --- src/Data/Syntax/Literal.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/Data/Syntax/Literal.hs b/src/Data/Syntax/Literal.hs index b23c719b7..915e32f49 100644 --- a/src/Data/Syntax/Literal.hs +++ b/src/Data/Syntax/Literal.hs @@ -259,7 +259,9 @@ instance Ord1 Hash where liftCompare = genericLiftCompare instance Show1 Hash where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Hash where - eval eval _ t = Eval.hash <$> traverse (eval >=> asPair) (hashElements t) + eval eval _ t = do + elements <- traverse (eval >=> asPair) (hashElements t) + Eval.hash elements instance Tokenize Hash where tokenize = Tok.hash . hashElements @@ -272,8 +274,10 @@ instance Ord1 KeyValue where liftCompare = genericLiftCompare instance Show1 KeyValue where liftShowsPrec = genericLiftShowsPrec instance Evaluatable KeyValue where - eval eval _ (fmap eval -> KeyValue{..}) = - kvPair <$> key <*> value + eval eval _ (KeyValue{..}) = do + k <- eval key + v <- eval value + kvPair k v instance Tokenize KeyValue where tokenize (KeyValue k v) = pair k v From ed6f2252139085f39a68f00f0e668ecd64f7e538 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Tue, 15 Jan 2019 13:57:14 -0500 Subject: [PATCH 117/127] fix build errors --- src/Data/Abstract/Value/Concrete.hs | 2 +- src/Data/Syntax/Literal.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 66e0174b5..3f869f70b 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -272,7 +272,7 @@ instance ( Member (Reader ModuleInfo) sig eff = ArrayC . handleSum (eff . handleCoercible) (\case Abstract.Array t k -> runArrayC (k (Array t)) Abstract.AsArray (Array addresses) k -> runArrayC (k addresses) - Abstract.AsArray val k -> (throwBaseError $ ArrayError val) >>= runArrayC . k) + Abstract.AsArray val k -> throwBaseError (ArrayError val) >>= runArrayC . k) instance ( Carrier sig m ) => Carrier (Abstract.Hash (Value term address) :+: sig) (HashC (Value term address) m) where ret = HashC . ret diff --git a/src/Data/Syntax/Literal.hs b/src/Data/Syntax/Literal.hs index ad76b4e22..78ef6e520 100644 --- a/src/Data/Syntax/Literal.hs +++ b/src/Data/Syntax/Literal.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveAnyClass, DerivingVia, DuplicateRecordFields, ScopedTypeVariables, ViewPatterns #-} +{-# LANGUAGE DeriveAnyClass, DerivingVia, DuplicateRecordFields, ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-missing-export-lists #-} module Data.Syntax.Literal where @@ -223,7 +223,7 @@ data KeyValue a = KeyValue { key :: !a, value :: !a } deriving (Eq1, Ord1, Show1) via Generically KeyValue instance Evaluatable KeyValue where - eval eval _ (KeyValue{..}) = do + eval eval _ KeyValue{..} = do k <- eval key v <- eval value kvPair k v From 7b676dc038ae0f07d17d441941e246e0172ba53f Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Tue, 15 Jan 2019 16:23:08 -0500 Subject: [PATCH 118/127] move runBitwise near its friends --- src/Control/Abstract/Value.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index b11246d4a..04084e07b 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -54,12 +54,12 @@ module Control.Abstract.Value , unsignedRShift , Bitwise(..) , BitwiseC(..) +, runBitwise , array , asArray , Array(..) , ArrayC(..) , runArray -, runBitwise , Control.Abstract.Value.hash , kvPair , Hash(..) From 238bc6ed88f7308f6eccabab9605e42ecb59cda5 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Tue, 15 Jan 2019 16:27:08 -0500 Subject: [PATCH 119/127] hide hash from Prologue import for shorter export name --- 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 04084e07b..0ddff8634 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -60,7 +60,7 @@ module Control.Abstract.Value , Array(..) , ArrayC(..) , runArray -, Control.Abstract.Value.hash +, hash , kvPair , Hash(..) , runHash @@ -78,7 +78,7 @@ import Data.Abstract.Number (Number, SomeNumber) import Data.Scientific (Scientific) import Data.Span import Prelude hiding (String) -import Prologue hiding (TypeError) +import Prologue hiding (TypeError, hash) -- | This datum is passed into liftComparison to handle the fact that Ruby and PHP -- have built-in generalized-comparison ("spaceship") operators. If you want to From 857b644c0dc07a9840f41e90fcfea92b5b65303e Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Tue, 15 Jan 2019 16:29:48 -0500 Subject: [PATCH 120/127] clean up comments --- src/Control/Abstract/Value.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 0ddff8634..16624daa7 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -278,10 +278,6 @@ instance Effect (String value) where newtype StringC value m a = StringC { runStringC :: m a } runString :: Carrier (String value :+: sig) (StringC value (Eff m)) - -- Have to mention String because we don't know what the value type is - -- Enables single effect handler function across abstract, concret, type - -- Allows us to define something once in evaluate in Semantic.Analysis - -- instead of crazy composition => Evaluator term address value (StringC value (Eff m)) a -> Evaluator term address value m a runString = raiseHandler $ runStringC . interpret From bab4759a2f59af66084492b6a1accf7e686473f8 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Tue, 15 Jan 2019 16:31:10 -0500 Subject: [PATCH 121/127] drop more misc comments --- src/Control/Abstract/Value.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 16624daa7..b0c97b421 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -419,11 +419,9 @@ runObject :: Carrier (Object address value :+: sig) (ObjectC address value (Eff runObject = raiseHandler $ runObjectC . interpret -- | Construct an array of zero or more values. --- array :: [value] -> Evaluator term address value carrier value array :: (Member (Array value) sig, Carrier sig m) => [value] -> m value array v = send (Array v ret) --- asArray :: value -> Evaluator term address value carrier [value] asArray :: (Member (Array value) sig, Carrier sig m) => value -> m [value] asArray v = send (AsArray v ret) @@ -447,12 +445,10 @@ runArray :: Carrier (Array value :+: sig) (ArrayC value (Eff m)) runArray = raiseHandler $ runArrayC . interpret -- | Construct a hash out of pairs. --- hash :: [(value, value)] -> value hash :: (Member (Hash value) sig, Carrier sig m) => [(value, value)] -> m value hash v = send (Hash v ret) -- | Construct a key-value pair for use in a hash. --- kvPair :: value -> value -> value kvPair :: (Member (Hash value) sig, Carrier sig m) => value -> value -> m value kvPair v1 v2 = send (KvPair v1 v2 ret) From 12ad3a8a375bfd3e50d5b84cbf0a87a0fda723ed Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Tue, 15 Jan 2019 16:33:39 -0500 Subject: [PATCH 122/127] remove superfluous parens --- src/Data/Abstract/Value/Type.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index 8b0755939..890fe4dbc 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -392,9 +392,9 @@ instance ( Member Fresh sig Abstract.Array fieldTypes k -> (do var <- fresh Array <$> foldr (\ t1 -> (unify t1 =<<)) (pure (Var var)) fieldTypes) >>= runArrayC . k - Abstract.AsArray t k -> (do + Abstract.AsArray t k -> do field <- fresh - unify t (Array (Var field)) >> runArrayC (k mempty))) + unify t (Array (Var field)) >> runArrayC (k mempty)) instance ( Carrier sig m ) => Carrier (Abstract.Hash Type :+: sig) (HashC Type m) where ret = HashC . ret From 790bf4dd1c3e93f466014fa7408fd07d5d1b9ea0 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Tue, 15 Jan 2019 16:35:10 -0500 Subject: [PATCH 123/127] refactor do block using monad laws --- src/Data/Abstract/Value/Type.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index 890fe4dbc..75bc49732 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -389,9 +389,10 @@ instance ( Member Fresh sig => Carrier (Abstract.Array Type :+: sig) (ArrayC Type m) where ret = ArrayC . ret eff = ArrayC . handleSum (eff . handleCoercible) (\case - Abstract.Array fieldTypes k -> (do + Abstract.Array fieldTypes k -> do var <- fresh - Array <$> foldr (\ t1 -> (unify t1 =<<)) (pure (Var var)) fieldTypes) >>= runArrayC . k + fieldType <- foldr (\ t1 -> (unify t1 =<<)) (pure (Var var)) fieldTypes + runArrayC (k (Array fieldType)) Abstract.AsArray t k -> do field <- fresh unify t (Array (Var field)) >> runArrayC (k mempty)) From 2f29c9a566047c66c0fb5e4207a6ccc0ce9bf6e0 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Tue, 15 Jan 2019 16:47:40 -0500 Subject: [PATCH 124/127] disambiguate --- test/SpecHelpers.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index bf76740dc..c0180ad03 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -166,7 +166,7 @@ members :: EdgeLabel -> ScopeGraph Precise -> Value term Precise -> Maybe [Name] -members edgeLabel heap scopeGraph (Object frame) = frameNames [ edgeLabel ] heap scopeGraph frame +members edgeLabel heap scopeGraph (Control.Abstract.Object frame) = frameNames [ edgeLabel ] heap scopeGraph frame members edgeLabel heap scopeGraph (Class _ _ frame) = frameNames [ edgeLabel ] heap scopeGraph frame members _ _ _ _ = Nothing From 896cfe983ce2ccefcca1e9688524222870fd035b Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Tue, 15 Jan 2019 16:54:00 -0500 Subject: [PATCH 125/127] Reference Data.Abstract.Value.Concrete and not Control.Abstract.Value --- test/SpecHelpers.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index c0180ad03..1743ef215 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -166,7 +166,7 @@ members :: EdgeLabel -> ScopeGraph Precise -> Value term Precise -> Maybe [Name] -members edgeLabel heap scopeGraph (Control.Abstract.Object frame) = frameNames [ edgeLabel ] heap scopeGraph frame +members edgeLabel heap scopeGraph (Data.Abstract.Value.Concrete.Object frame) = frameNames [ edgeLabel ] heap scopeGraph frame members edgeLabel heap scopeGraph (Class _ _ frame) = frameNames [ edgeLabel ] heap scopeGraph frame members _ _ _ _ = Nothing From b9f4d362728d1c41be546320eec4bf2ca37e6a7f Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Wed, 16 Jan 2019 12:57:30 -0500 Subject: [PATCH 126/127] fix accidental revert of patrick's changes --- src/Language/TypeScript/Syntax/Types.hs | 83 +++++++------------------ 1 file changed, 21 insertions(+), 62 deletions(-) diff --git a/src/Language/TypeScript/Syntax/Types.hs b/src/Language/TypeScript/Syntax/Types.hs index ea1c880cd..60e3196db 100644 --- a/src/Language/TypeScript/Syntax/Types.hs +++ b/src/Language/TypeScript/Syntax/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveAnyClass, DuplicateRecordFields #-} +{-# LANGUAGE DeriveAnyClass, DerivingVia, DuplicateRecordFields #-} {-# OPTIONS_GHC -Wno-missing-export-lists #-} module Language.TypeScript.Syntax.Types where @@ -15,70 +15,54 @@ import Diffing.Algorithm -- | Lookup type for a type-level key in a typescript map. data LookupType a = LookupType { lookupTypeIdentifier :: a, lookupTypeKey :: a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Eq1, Show1, Ord1) via Generically LookupType -instance Eq1 LookupType where liftEq = genericLiftEq -instance Ord1 LookupType where liftCompare = genericLiftCompare -instance Show1 LookupType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable LookupType data FunctionType a = FunctionType { functionTypeParameters :: !a, functionFormalParameters :: ![a], functionType :: !a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Eq1, Show1, Ord1) via Generically FunctionType -instance Eq1 FunctionType where liftEq = genericLiftEq -instance Ord1 FunctionType where liftCompare = genericLiftCompare -instance Show1 FunctionType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable FunctionType data TypeParameter a = TypeParameter { typeParameter :: !a, typeParameterConstraint :: !a, typeParameterDefaultType :: !a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Eq1, Show1, Ord1) via Generically TypeParameter -instance Eq1 TypeParameter where liftEq = genericLiftEq -instance Ord1 TypeParameter where liftCompare = genericLiftCompare -instance Show1 TypeParameter where liftShowsPrec = genericLiftShowsPrec instance Evaluatable TypeParameter data TypeAssertion a = TypeAssertion { typeAssertionParameters :: !a, typeAssertionExpression :: !a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Eq1, Show1, Ord1) via Generically TypeAssertion -instance Eq1 TypeAssertion where liftEq = genericLiftEq -instance Ord1 TypeAssertion where liftCompare = genericLiftCompare -instance Show1 TypeAssertion where liftShowsPrec = genericLiftShowsPrec instance Evaluatable TypeAssertion newtype DefaultType a = DefaultType { defaultType :: a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Eq1, Show1, Ord1) via Generically DefaultType -instance Eq1 DefaultType where liftEq = genericLiftEq -instance Ord1 DefaultType where liftCompare = genericLiftCompare -instance Show1 DefaultType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable DefaultType newtype ParenthesizedType a = ParenthesizedType { parenthesizedType :: a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Eq1, Show1, Ord1) via Generically ParenthesizedType -instance Eq1 ParenthesizedType where liftEq = genericLiftEq -instance Ord1 ParenthesizedType where liftCompare = genericLiftCompare -instance Show1 ParenthesizedType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ParenthesizedType newtype PredefinedType a = PredefinedType { predefinedType :: T.Text } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Eq1, Show1, Ord1) via Generically PredefinedType -instance Eq1 PredefinedType where liftEq = genericLiftEq -instance Ord1 PredefinedType where liftCompare = genericLiftCompare -instance Show1 PredefinedType where liftShowsPrec = genericLiftShowsPrec -- TODO: Implement Eval instance for PredefinedType instance Evaluatable PredefinedType newtype TypeIdentifier a = TypeIdentifier { contents :: T.Text } deriving (Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Eq1, Show1, Ord1) via Generically TypeIdentifier instance Declarations1 TypeIdentifier where liftDeclaredName _ (TypeIdentifier identifier) = Just (Evaluatable.name identifier) -instance Eq1 TypeIdentifier where liftEq = genericLiftEq -instance Ord1 TypeIdentifier where liftCompare = genericLiftCompare -instance Show1 TypeIdentifier where liftShowsPrec = genericLiftShowsPrec -- TODO: TypeIdentifier shouldn't evaluate to an address in the heap? instance Evaluatable TypeIdentifier where eval _ _ TypeIdentifier{..} = do @@ -88,97 +72,72 @@ instance Evaluatable TypeIdentifier where data NestedTypeIdentifier a = NestedTypeIdentifier { left :: !a, right :: !a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Eq1, Show1, Ord1) via Generically NestedTypeIdentifier -instance Eq1 NestedTypeIdentifier where liftEq = genericLiftEq -instance Ord1 NestedTypeIdentifier where liftCompare = genericLiftCompare -instance Show1 NestedTypeIdentifier where liftShowsPrec = genericLiftShowsPrec instance Evaluatable NestedTypeIdentifier data GenericType a = GenericType { genericTypeIdentifier :: !a, genericTypeArguments :: !a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Eq1, Show1, Ord1) via Generically GenericType -instance Eq1 GenericType where liftEq = genericLiftEq -instance Ord1 GenericType where liftCompare = genericLiftCompare -instance Show1 GenericType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable GenericType data TypePredicate a = TypePredicate { typePredicateIdentifier :: !a, typePredicateType :: !a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Eq1, Show1, Ord1) via Generically TypePredicate -instance Eq1 TypePredicate where liftEq = genericLiftEq -instance Ord1 TypePredicate where liftCompare = genericLiftCompare -instance Show1 TypePredicate where liftShowsPrec = genericLiftShowsPrec instance Evaluatable TypePredicate newtype ObjectType a = ObjectType { objectTypeElements :: [a] } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Eq1, Show1, Ord1) via Generically ObjectType -instance Eq1 ObjectType where liftEq = genericLiftEq -instance Ord1 ObjectType where liftCompare = genericLiftCompare -instance Show1 ObjectType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ObjectType newtype ArrayType a = ArrayType { arrayType :: a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Eq1, Show1, Ord1) via Generically ArrayType -instance Eq1 ArrayType where liftEq = genericLiftEq -instance Ord1 ArrayType where liftCompare = genericLiftCompare -instance Show1 ArrayType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ArrayType newtype FlowMaybeType a = FlowMaybeType { flowMaybeType :: a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Eq1, Show1, Ord1) via Generically FlowMaybeType -instance Eq1 FlowMaybeType where liftEq = genericLiftEq -instance Ord1 FlowMaybeType where liftCompare = genericLiftCompare -instance Show1 FlowMaybeType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable FlowMaybeType newtype TypeQuery a = TypeQuery { typeQuerySubject :: a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Eq1, Show1, Ord1) via Generically TypeQuery -instance Eq1 TypeQuery where liftEq = genericLiftEq -instance Ord1 TypeQuery where liftCompare = genericLiftCompare -instance Show1 TypeQuery where liftShowsPrec = genericLiftShowsPrec instance Evaluatable TypeQuery newtype IndexTypeQuery a = IndexTypeQuery { indexTypeQuerySubject :: a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Eq1, Show1, Ord1) via Generically IndexTypeQuery -instance Eq1 IndexTypeQuery where liftEq = genericLiftEq -instance Ord1 IndexTypeQuery where liftCompare = genericLiftCompare -instance Show1 IndexTypeQuery where liftShowsPrec = genericLiftShowsPrec instance Evaluatable IndexTypeQuery newtype TypeArguments a = TypeArguments { typeArguments :: [a] } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Eq1, Show1, Ord1) via Generically TypeArguments -instance Eq1 TypeArguments where liftEq = genericLiftEq -instance Ord1 TypeArguments where liftCompare = genericLiftCompare -instance Show1 TypeArguments where liftShowsPrec = genericLiftShowsPrec instance Evaluatable TypeArguments newtype ThisType a = ThisType { contents :: T.Text } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Eq1, Show1, Ord1) via Generically ThisType -instance Eq1 ThisType where liftEq = genericLiftEq -instance Ord1 ThisType where liftCompare = genericLiftCompare -instance Show1 ThisType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ThisType newtype ExistentialType a = ExistentialType { contents :: T.Text } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Eq1, Show1, Ord1) via Generically ExistentialType -instance Eq1 ExistentialType where liftEq = genericLiftEq -instance Ord1 ExistentialType where liftCompare = genericLiftCompare -instance Show1 ExistentialType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ExistentialType - newtype LiteralType a = LiteralType { literalTypeSubject :: a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Eq1, Show1, Ord1) via Generically LiteralType -instance Eq1 LiteralType where liftEq = genericLiftEq -instance Ord1 LiteralType where liftCompare = genericLiftCompare -instance Show1 LiteralType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable LiteralType From cef0b1cdb63f24a79d13391c2aa4c18ef9d9dea5 Mon Sep 17 00:00:00 2001 From: Ayman Nadeem Date: Wed, 16 Jan 2019 13:53:07 -0500 Subject: [PATCH 127/127] make sure haskell-tree-sitter reflects master --- vendor/haskell-tree-sitter | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/haskell-tree-sitter b/vendor/haskell-tree-sitter index fe0510243..de469907a 160000 --- a/vendor/haskell-tree-sitter +++ b/vendor/haskell-tree-sitter @@ -1 +1 @@ -Subproject commit fe051024313f048883b50a9905de5fe6ce5e8281 +Subproject commit de469907a0fcd4d522a880c985e533e7849ff8b5