From 8f3265682a04aae60c298d5754886e4fcd907d8e Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 26 Jun 2018 13:20:35 -0400 Subject: [PATCH 01/46] extract runCallGraph --- src/Semantic/Graph.hs | 82 +++++++++++++++++++++++++++---------------- 1 file changed, 52 insertions(+), 30 deletions(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 28686e14f..c56cf4347 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -5,7 +5,7 @@ module Semantic.Graph , GraphType(..) , Graph , Vertex -, GraphEff(..) +, CallGraphEff(..) , ImportGraphEff(..) , style , parsePackage @@ -31,6 +31,7 @@ import Data.Abstract.Value (Value, ValueError (..), runValueErrorWith) import Data.Graph import Data.Project import Data.Record +import qualified Data.Syntax as Syntax import Data.Term import Data.Text (pack) import Parsing.Parser @@ -55,36 +56,14 @@ runGraph CallGraph includePackages project | SomeAnalysisParser parser lang <- someAnalysisParser (Proxy :: Proxy AnalysisClasses) (projectLanguage project) = do package <- parsePackage parser project modules <- runImportGraph lang package - let analyzeTerm = withTermSpans . graphingTerms - analyzeModule = (if includePackages then graphingPackages else id) . graphingModules - extractGraph (((_, graph), _), _) = simplify graph - runGraphAnalysis - = run - . runState lowerBound - . runFresh 0 - . runIgnoringTrace - . resumingLoadError - . resumingUnspecialized - . resumingEnvironmentError - . resumingEvalError - . resumingResolutionError - . resumingAddressError - . resumingValueError - . runTermEvaluator @_ @_ @(Value (Hole (Located Precise)) (GraphEff _)) - . graphing - . runReader (packageInfo package) - . runReader lowerBound - . fmap fst - . runState lowerBound - . raiseHandler (runModules (ModuleTable.modulePaths (packageModules package))) - extractGraph <$> analyze runGraphAnalysis (evaluate lang analyzeModule analyzeTerm (topologicalSort modules)) + runCallGraph lang includePackages modules package -- | The full list of effects in flight during the evaluation of terms. This, and other @newtype@s like it, are necessary to type 'Value', since the bodies of closures embed evaluators. This would otherwise require cycles in the effect list (i.e. references to @effects@ within @effects@ itself), which the typechecker forbids. -newtype GraphEff address a = GraphEff +newtype CallGraphEff address a = CallGraphEff { runGraphEff :: Eff '[ LoopControl address , Return address , Env address - , Allocator address (Value address (GraphEff address)) + , Allocator address (Value address (CallGraphEff address)) , Reader ModuleInfo , Modules address -- FIXME: This should really be a Reader effect but for https://github.com/joshvera/effects/issues/47 @@ -92,19 +71,62 @@ newtype GraphEff address a = GraphEff , Reader Span , Reader PackageInfo , State (Graph Vertex) - , Resumable (ValueError address (GraphEff address)) - , Resumable (AddressError address (Value address (GraphEff address))) + , Resumable (ValueError address (CallGraphEff address)) + , Resumable (AddressError address (Value address (CallGraphEff address))) , Resumable ResolutionError , Resumable EvalError , Resumable (EnvironmentError address) - , Resumable (Unspecialized (Value address (GraphEff address))) + , Resumable (Unspecialized (Value address (CallGraphEff address))) , Resumable (LoadError address) , Trace , Fresh - , State (Heap address Latest (Value address (GraphEff address))) + , State (Heap address Latest (Value address (CallGraphEff address))) ] a } +runCallGraph :: ( HasField ann Span + , Element Syntax.Identifier syntax + , Apply Eq1 syntax + , Apply Ord1 syntax + , Ord (Record ann) + , term ~ Term (Sum syntax) (Record ann) + , Declarations term + , Evaluatable (Base term) + , FreeVariables term + , HasPrelude lang + , Member Task effs + , Recursive term + ) + => Proxy lang + -> Bool + -> Graph (Module term) + -> Package term + -> Eff effs (Graph Vertex) +runCallGraph lang includePackages modules package = do + let analyzeTerm = withTermSpans . graphingTerms + analyzeModule = (if includePackages then graphingPackages else id) . graphingModules + extractGraph (((_, graph), _), _) = simplify graph + runGraphAnalysis + = run + . runState lowerBound + . runFresh 0 + . runIgnoringTrace + . resumingLoadError + . resumingUnspecialized + . resumingEnvironmentError + . resumingEvalError + . resumingResolutionError + . resumingAddressError + . resumingValueError + . runTermEvaluator @_ @_ @(Value (Hole (Located Precise)) (CallGraphEff _)) + . graphing + . runReader (packageInfo package) + . runReader lowerBound + . fmap fst + . runState lowerBound + . raiseHandler (runModules (ModuleTable.modulePaths (packageModules package))) + extractGraph <$> analyze runGraphAnalysis (evaluate lang analyzeModule analyzeTerm (topologicalSort modules)) + runImportGraph :: ( Declarations term , Evaluatable (Base term) From 18b20a4ed0512d0620d060a8e5af86da5b4b9c28 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 26 Jun 2018 13:43:50 -0400 Subject: [PATCH 02/46] call `caching` in runCallGraph --- src/Semantic/Graph.hs | 30 ++++++++++++++++++++++-------- 1 file changed, 22 insertions(+), 8 deletions(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index c56cf4347..b19dfbc4d 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -19,14 +19,17 @@ module Semantic.Graph , resumingEnvironmentError ) where +import Analysis.Abstract.Caching import Analysis.Abstract.Graph as Graph import Control.Abstract import Control.Monad.Effect (reinterpret) import Data.Abstract.Address +import Data.Abstract.Cache import Data.Abstract.Evaluatable import Data.Abstract.Module import qualified Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Package as Package +import Data.Abstract.Type import Data.Abstract.Value (Value, ValueError (..), runValueErrorWith) import Data.Graph import Data.Project @@ -35,7 +38,7 @@ import qualified Data.Syntax as Syntax import Data.Term import Data.Text (pack) import Parsing.Parser -import Prologue hiding (MonadError (..)) +import Prologue hiding (MonadError (..), TypeError (..)) import Semantic.IO (Files) import Semantic.Task as Task @@ -59,28 +62,31 @@ runGraph CallGraph includePackages project runCallGraph lang includePackages modules package -- | The full list of effects in flight during the evaluation of terms. This, and other @newtype@s like it, are necessary to type 'Value', since the bodies of closures embed evaluators. This would otherwise require cycles in the effect list (i.e. references to @effects@ within @effects@ itself), which the typechecker forbids. -newtype CallGraphEff address a = CallGraphEff +newtype CallGraphEff term address a = CallGraphEff { runGraphEff :: Eff '[ LoopControl address , Return address , Env address - , Allocator address (Value address (CallGraphEff address)) + , Allocator address (Value address (CallGraphEff term address)) , Reader ModuleInfo , Modules address -- FIXME: This should really be a Reader effect but for https://github.com/joshvera/effects/issues/47 , State (ModuleTable (NonEmpty (Module (address, Environment address)))) , Reader Span , Reader PackageInfo + , NonDet + , Reader (Cache term address (Cell address) (Value address (CallGraphEff term address))) + , State (Cache term address (Cell address) (Value address (CallGraphEff term address))) , State (Graph Vertex) - , Resumable (ValueError address (CallGraphEff address)) - , Resumable (AddressError address (Value address (CallGraphEff address))) + , Resumable (ValueError address (CallGraphEff term address)) + , Resumable (AddressError address (Value address (CallGraphEff term address))) , Resumable ResolutionError , Resumable EvalError , Resumable (EnvironmentError address) - , Resumable (Unspecialized (Value address (CallGraphEff address))) + , Resumable (Unspecialized (Value address (CallGraphEff term address))) , Resumable (LoadError address) , Trace , Fresh - , State (Heap address Latest (Value address (CallGraphEff address))) + , State (Heap address All (Value address (CallGraphEff term address))) ] a } @@ -105,6 +111,7 @@ runCallGraph :: ( HasField ann Span runCallGraph lang includePackages modules package = do let analyzeTerm = withTermSpans . graphingTerms analyzeModule = (if includePackages then graphingPackages else id) . graphingModules + extractGraph :: (((a, Graph Vertex), b), c) -> Graph Vertex extractGraph (((_, graph), _), _) = simplify graph runGraphAnalysis = run @@ -118,8 +125,9 @@ runCallGraph lang includePackages modules package = do . resumingResolutionError . resumingAddressError . resumingValueError - . runTermEvaluator @_ @_ @(Value (Hole (Located Precise)) (CallGraphEff _)) + . runTermEvaluator @_ @_ @(Value (Hole (Located Monovariant)) (CallGraphEff _ _)) . graphing + . caching @[] . runReader (packageInfo package) . runReader lowerBound . fmap fst @@ -271,3 +279,9 @@ resumingEnvironmentError :: AbstractHole address => Evaluator address value (Res resumingEnvironmentError = runState [] . reinterpret (\ (Resumable (FreeVariable name)) -> modify' (name :) $> hole) + +resumingTypeError :: (Alternative (m address Type effects), Effectful (m address Type), Member Trace effects) + => m address Type (Resumable TypeError ': effects) a + -> m address Type effects a +resumingTypeError = runTypeErrorWith (\err -> trace ("TypeError " <> show err) *> case err of + UnificationError l r -> pure l <|> pure r) From 3b7f91975cde1e3fe49a75b82bc9c41c13d2e6b7 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 26 Jun 2018 16:08:40 -0400 Subject: [PATCH 03/46] :pear: with Rob --- src/Analysis/Abstract/Graph.hs | 2 ++ src/Semantic/Graph.hs | 51 ++++++++-------------------------- 2 files changed, 14 insertions(+), 39 deletions(-) diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index fcbfa5e55..d116623da 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -57,6 +57,7 @@ graphingTerms :: ( Element Syntax.Identifier syntax , Member (Reader ModuleInfo) effects , Member (Env (Hole (Located address))) effects , Member (State (Graph Vertex)) effects + , Member Trace effects , term ~ Term (Sum syntax) ann ) => SubtermAlgebra (Base term) term (TermEvaluator term (Hole (Located address)) value effects a) @@ -64,6 +65,7 @@ graphingTerms :: ( Element Syntax.Identifier syntax graphingTerms recur term@(In _ syntax) = do case project syntax of Just (Syntax.Identifier name) -> do + trace ("Examining identifier " <> show name) moduleInclusion (Variable (formatName name)) variableDefinition name _ -> pure () diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index b19dfbc4d..481342c5d 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -5,7 +5,6 @@ module Semantic.Graph , GraphType(..) , Graph , Vertex -, CallGraphEff(..) , ImportGraphEff(..) , style , parsePackage @@ -20,11 +19,12 @@ module Semantic.Graph ) where import Analysis.Abstract.Caching +import Analysis.Abstract.Collecting import Analysis.Abstract.Graph as Graph import Control.Abstract import Control.Monad.Effect (reinterpret) import Data.Abstract.Address -import Data.Abstract.Cache +-- import Data.Abstract.Cache import Data.Abstract.Evaluatable import Data.Abstract.Module import qualified Data.Abstract.ModuleTable as ModuleTable @@ -61,39 +61,11 @@ runGraph CallGraph includePackages project modules <- runImportGraph lang package runCallGraph lang includePackages modules package --- | The full list of effects in flight during the evaluation of terms. This, and other @newtype@s like it, are necessary to type 'Value', since the bodies of closures embed evaluators. This would otherwise require cycles in the effect list (i.e. references to @effects@ within @effects@ itself), which the typechecker forbids. -newtype CallGraphEff term address a = CallGraphEff - { runGraphEff :: Eff '[ LoopControl address - , Return address - , Env address - , Allocator address (Value address (CallGraphEff term address)) - , Reader ModuleInfo - , Modules address - -- FIXME: This should really be a Reader effect but for https://github.com/joshvera/effects/issues/47 - , State (ModuleTable (NonEmpty (Module (address, Environment address)))) - , Reader Span - , Reader PackageInfo - , NonDet - , Reader (Cache term address (Cell address) (Value address (CallGraphEff term address))) - , State (Cache term address (Cell address) (Value address (CallGraphEff term address))) - , State (Graph Vertex) - , Resumable (ValueError address (CallGraphEff term address)) - , Resumable (AddressError address (Value address (CallGraphEff term address))) - , Resumable ResolutionError - , Resumable EvalError - , Resumable (EnvironmentError address) - , Resumable (Unspecialized (Value address (CallGraphEff term address))) - , Resumable (LoadError address) - , Trace - , Fresh - , State (Heap address All (Value address (CallGraphEff term address))) - ] a - } - runCallGraph :: ( HasField ann Span , Element Syntax.Identifier syntax , Apply Eq1 syntax , Apply Ord1 syntax + , Apply Functor syntax , Ord (Record ann) , term ~ Term (Sum syntax) (Record ann) , Declarations term @@ -109,13 +81,13 @@ runCallGraph :: ( HasField ann Span -> Package term -> Eff effs (Graph Vertex) runCallGraph lang includePackages modules package = do - let analyzeTerm = withTermSpans . graphingTerms - analyzeModule = (if includePackages then graphingPackages else id) . graphingModules - extractGraph :: (((a, Graph Vertex), b), c) -> Graph Vertex + let analyzeTerm = withTermSpans . graphingTerms . cachingTerms + analyzeModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules +-- extractGraph :: (((a, Graph Vertex), b), c) -> Graph Vertex extractGraph (((_, graph), _), _) = simplify graph runGraphAnalysis = run - . runState lowerBound + . runState (lowerBound @(Heap (Hole (Located Monovariant)) All Type)) . runFresh 0 . runIgnoringTrace . resumingLoadError @@ -124,14 +96,15 @@ runCallGraph lang includePackages modules package = do . resumingEvalError . resumingResolutionError . resumingAddressError - . resumingValueError - . runTermEvaluator @_ @_ @(Value (Hole (Located Monovariant)) (CallGraphEff _ _)) + . runTermEvaluator @_ @(Hole (Located Monovariant)) @Type . graphing . caching @[] + . resumingTypeError . runReader (packageInfo package) - . runReader lowerBound + . runReader (lowerBound @Span) + . providingLiveSet . fmap fst - . runState lowerBound + . runState (lowerBound @(ModuleTable (NonEmpty (Module (Hole (Located Monovariant), Environment (Hole (Located Monovariant))))))) . raiseHandler (runModules (ModuleTable.modulePaths (packageModules package))) extractGraph <$> analyze runGraphAnalysis (evaluate lang analyzeModule analyzeTerm (topologicalSort modules)) From 9d5d24e1b5a9d0eac32053ff5f2604da77c85155 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 29 Jun 2018 12:26:51 -0400 Subject: [PATCH 04/46] otiose import --- src/Semantic/Graph.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 7b683681a..99c05adc4 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -42,7 +42,6 @@ import Data.Term import Data.Text (pack) import Parsing.Parser import Prologue hiding (MonadError (..), TypeError (..)) -import Semantic.IO (Files) import Semantic.Task as Task data GraphType = ImportGraph | CallGraph From 076aef0015352f27aa13bf8d5f329a92fd3897c3 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 29 Jun 2018 15:28:32 -0400 Subject: [PATCH 05/46] this appears to work --- src/Analysis/Abstract/Caching.hs | 32 +++++++++++++++++++++++++++----- src/Analysis/Abstract/Graph.hs | 10 ++++++++-- src/Control/Abstract/Heap.hs | 7 +++++-- src/Control/Abstract/Value.hs | 4 +++- src/Data/Abstract/Cache.hs | 3 +++ src/Data/Abstract/Evaluatable.hs | 6 +++++- src/Data/Map/Monoidal.hs | 4 ++++ src/Semantic/Graph.hs | 5 ++++- 8 files changed, 59 insertions(+), 12 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 33fa6a180..4b512c67e 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -10,6 +10,8 @@ import Data.Abstract.Cache import Data.Abstract.Module import Data.Abstract.Ref import Prologue +import Debug.Trace (traceM, traceShowId, trace) +import Text.Show.Pretty (ppShow) -- | Look up the set of values for a given configuration in the in-cache. consultOracle :: (Cacheable term address (Cell address) value, Member (Reader (Cache term address (Cell address) value)) effects) @@ -32,14 +34,23 @@ lookupCache :: (Cacheable term address (Cell address) value, Member (State (Cach lookupCache configuration = cacheLookup configuration <$> get -- | Run an action, caching its result and 'Heap' under the given configuration. -cachingConfiguration :: (Cacheable term address (Cell address) value, Member (State (Cache term address (Cell address) value)) effects, Member (State (Heap address (Cell address) value)) effects) +cachingConfiguration :: ( Cacheable term address (Cell address) value + , Member (State (Cache term address (Cell address) value)) effects + , Member (State (Heap address (Cell address) value)) effects + , Show address + , Show (Cell address value) + ) => Configuration term address (Cell address) value -> Set (Cached address (Cell address) value) -> TermEvaluator term address value effects (ValueRef address) -> TermEvaluator term address value effects (ValueRef address) cachingConfiguration configuration values action = do + traceM "modifying caching configuration" + -- traceM ("there are " <> ppShow values <> " values") modify' (cacheSet configuration values) + traceM "evaluating cached result" result <- Cached <$> action <*> TermEvaluator getHeap + traceM "inserting value " cachedValue result <$ modify' (cacheInsert configuration result) putCache :: Member (State (Cache term address (Cell address) value)) effects @@ -63,18 +74,26 @@ cachingTerms :: ( Cacheable term address (Cell address) value , Member (State (Cache term address (Cell address) value)) effects , Member (Env address) effects , Member (State (Heap address (Cell address) value)) effects + , Show address + , Show (Cell address value) ) => SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef address)) -> SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef address)) cachingTerms recur term = do + traceM "cachingTerms: getting configuration" c <- getConfiguration (embedSubterm term) + traceM "looking up cache" cached <- lookupCache c case cached of - Just pairs -> scatter pairs + Just pairs -> traceM "scattering" *> scatter pairs Nothing -> do + traceM "consulting oracle" pairs <- consultOracle c + traceM "caching configuration" cachingConfiguration c pairs (recur term) +tracePrettyId a = Debug.Trace.trace (ppShow a) a + convergingModules :: ( AbstractValue address value effects , Cacheable term address (Cell address) value , Member (Allocator address value) effects @@ -86,14 +105,17 @@ convergingModules :: ( AbstractValue address value effects , Member (State (Cache term address (Cell address) value)) effects , Member (Env address) effects , Member (State (Heap address (Cell address) value)) effects + , Show term + , Show address + , Show (Cell address value) ) => SubtermAlgebra Module term (TermEvaluator term address value effects address) -> SubtermAlgebra Module term (TermEvaluator term address value effects address) convergingModules recur m = do c <- getConfiguration (subterm (moduleBody m)) -- Convergence here is predicated upon an Eq instance, not α-equivalence - cache <- converge lowerBound (\ prevCache -> isolateCache . raiseHandler locally $ do - TermEvaluator (putHeap (configurationHeap c)) + cache <- converge lowerBound (\ prevCache -> fmap tracePrettyId . isolateCache . raiseHandler locally $ do + TermEvaluator (putHeap (configurationHeap c)) -- We need to reset fresh generation so that this invocation converges. resetFresh 0 $ -- This is subtle: though the calling context supports nondeterminism, we want @@ -115,7 +137,7 @@ converge :: (Eq a, Monad m) converge seed f = loop seed where loop x = do x' <- f x - if x' == x then + if x == x' then pure x else loop x' diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index 7b7711266..51e1b72f7 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -15,6 +15,7 @@ module Analysis.Abstract.Graph , graphing ) where +import Debug.Trace (traceM) import Algebra.Graph.Export.Dot hiding (vertexName) import Control.Abstract import Data.Abstract.Address @@ -29,6 +30,7 @@ import qualified Data.Syntax as Syntax import Data.Term import qualified Data.Text.Encoding as T import Prologue hiding (project) +import Text.Show.Pretty (ppShow) style :: Style Vertex Builder style = (defaultStyle (T.encodeUtf8Builder . vertexName)) @@ -51,16 +53,20 @@ graphingTerms :: ( Element Syntax.Identifier syntax , Member (State (Graph Vertex)) effects , Member Trace effects , term ~ Term (Sum syntax) ann + , Apply Show1 syntax + , Apply Functor syntax + , Show ann + , Show term ) => SubtermAlgebra (Base term) term (TermEvaluator term (Hole (Located address)) value effects a) -> SubtermAlgebra (Base term) term (TermEvaluator term (Hole (Located address)) value effects a) graphingTerms recur term@(In _ syntax) = do case project syntax of Just (Syntax.Identifier name) -> do - trace ("Examining identifier " <> show name) + traceM ("Examining identifier " <> show name) moduleInclusion (Variable (formatName name)) variableDefinition name - _ -> pure () + Nothing -> pure () recur term -- | Add vertices to the graph for evaluated modules and the packages containing them. diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 2b1c0cbc4..ae3967b5a 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -53,11 +53,14 @@ putHeap = put modifyHeap :: Member (State (Heap address (Cell address) value)) effects => (Heap address (Cell address) value -> Heap address (Cell address) value) -> Evaluator address value effects () modifyHeap = modify' -box :: Member (Allocator address value) effects +box :: ( Member (Allocator address value) effects + , Member Fresh effects + ) => value -> Evaluator address value effects address box val = do - addr <- alloc "" + nam <- nameI <$> fresh + addr <- alloc nam assign addr val pure addr diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index c23894a3e..7a713df4d 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -254,7 +254,9 @@ subtermAddress :: ( AbstractValue address value effects subtermAddress = address <=< subtermRef -- | Convenience function for boxing a raw value and wrapping it in an Rval -rvalBox :: Member (Allocator address value) effects +rvalBox :: ( Member (Allocator address value) effects + , Member Fresh effects + ) => value -> Evaluator address value effects (ValueRef address) rvalBox val = Rval <$> box val diff --git a/src/Data/Abstract/Cache.hs b/src/Data/Abstract/Cache.hs index 413340276..a5fe94962 100644 --- a/src/Data/Abstract/Cache.hs +++ b/src/Data/Abstract/Cache.hs @@ -32,6 +32,9 @@ cacheSet key value = Cache . Monoidal.insert key value . unCache cacheInsert :: Cacheable term address cell value => Configuration term address cell value -> Cached address cell value -> Cache term address cell value -> Cache term address cell value cacheInsert = curry cons +cacheKeys :: Cache term address cell value -> [Configuration term address cell value] +cacheKeys (Cache c) = Monoidal.keys c + instance (Show term, Show address, Show (cell value), Show value) => Show (Cache term address cell value) where showsPrec d = showsUnaryWith showsPrec "Cache" d . map (second toList) . Monoidal.pairs . unCache diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index a1d836995..7fbfa6315 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -59,6 +59,7 @@ class Show1 constr => Evaluatable constr where , Member (Resumable (Unspecialized value)) effects , Member (Return address) effects , Member Trace effects + , Member Fresh effects ) => SubtermAlgebra constr term (Evaluator address value effects (ValueRef address)) eval expr = rvalBox =<< throwResumable (Unspecialized ("Eval unspecialized for " <> liftShowsPrec (const (const id)) (const id) 0 expr "")) @@ -148,7 +149,10 @@ instance HasPrelude 'PHP builtInPrint :: ( AbstractIntro value , AbstractFunction address value effects , Member (Resumable (EnvironmentError address)) effects - , Member (Env address) effects, Member (Allocator address value) effects) + , Member (Env address) effects + , Member (Allocator address value) effects + , Member Fresh effects + ) => Name -> Evaluator address value effects address builtInPrint v = do diff --git a/src/Data/Map/Monoidal.hs b/src/Data/Map/Monoidal.hs index 34192cb2b..c6ed1ddd2 100644 --- a/src/Data/Map/Monoidal.hs +++ b/src/Data/Map/Monoidal.hs @@ -5,6 +5,7 @@ module Data.Map.Monoidal , lookup , singleton , size +, keys , insert , filterWithKey , pairs @@ -41,6 +42,9 @@ filterWithKey f = Map . Map.filterWithKey f . unMap pairs :: Map key value -> [(key, value)] pairs = Map.toList . unMap +keys :: Map key value -> [key] +keys = fmap fst . pairs + instance (Ord key, Semigroup value) => Semigroup (Map key value) where Map a <> Map b = Map (Map.unionWith (<>) a b) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 99c05adc4..4b2340957 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -21,6 +21,7 @@ module Semantic.Graph import Prelude hiding (readFile) +import Debug.Trace (traceM) import Analysis.Abstract.Caching import Analysis.Abstract.Collecting import Analysis.Abstract.Graph as Graph @@ -76,6 +77,8 @@ runCallGraph :: ( HasField ann Span , HasPrelude lang , Member Task effs , Recursive term + , Show (Record ann) + , Apply Show1 syntax ) => Proxy lang -> Bool @@ -84,7 +87,7 @@ runCallGraph :: ( HasField ann Span -> Eff effs (Graph Vertex) runCallGraph lang includePackages modules package = do let analyzeTerm = withTermSpans . graphingTerms . cachingTerms - analyzeModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules + analyzeModule = (if includePackages then graphingPackages else id) . convergingModules -- extractGraph :: (((a, Graph Vertex), b), c) -> Graph Vertex extractGraph (((_, graph), _), _) = simplify graph runGraphAnalysis From 75b6cd52c01739dd63496dfb918376798d3bd721 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 29 Jun 2018 15:44:51 -0400 Subject: [PATCH 06/46] define gensym and remove the IsString instance for Name --- src/Control/Abstract/Heap.hs | 3 +-- src/Control/Abstract/Primitive.hs | 2 +- src/Data/Abstract/Evaluatable.hs | 10 +++++----- src/Data/Abstract/Name.hs | 9 ++++++--- src/Semantic/Graph.hs | 2 +- 5 files changed, 14 insertions(+), 12 deletions(-) diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index ae3967b5a..bb6787cdf 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -59,8 +59,7 @@ box :: ( Member (Allocator address value) effects => value -> Evaluator address value effects address box val = do - nam <- nameI <$> fresh - addr <- alloc nam + addr <- gensym >>= alloc assign addr val pure addr diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 0912be487..c7ee8ae42 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -60,4 +60,4 @@ defineBuiltins :: ( AbstractValue address value effects ) => Evaluator address value effects () defineBuiltins = - define "__semantic_print" (lambda (\ v -> variable v >>= deref >>= asString >>= trace . unpack >> box unit)) + define (name "__semantic_print") (lambda (\ v -> variable v >>= deref >>= asString >>= trace . unpack >> box unit)) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 7fbfa6315..7252443b8 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -156,20 +156,20 @@ builtInPrint :: ( AbstractIntro value => Name -> Evaluator address value effects address builtInPrint v = do - print <- variable "__semantic_print" >>= deref + print <- variable (name "__semantic_print") >>= deref void $ call print [variable v] box unit instance HasPrelude 'Python where definePrelude _ = - define "print" (lambda builtInPrint) + define (name "print") (lambda builtInPrint) instance HasPrelude 'Ruby where definePrelude _ = do - define "puts" (lambda builtInPrint) + define (name "puts") (lambda builtInPrint) - defineClass "Object" [] $ do - define "inspect" (lambda (const (box (string "")))) + defineClass (name "Object") [] $ do + define (name "inspect") (lambda (const (box (string "")))) instance HasPrelude 'TypeScript -- FIXME: define console.log using __semantic_print diff --git a/src/Data/Abstract/Name.hs b/src/Data/Abstract/Name.hs index cae8a6549..5072a340e 100644 --- a/src/Data/Abstract/Name.hs +++ b/src/Data/Abstract/Name.hs @@ -1,16 +1,18 @@ module Data.Abstract.Name ( Name -- * Constructors +, gensym , name , nameI , formatName ) where +import Control.Monad.Effect +import Control.Monad.Effect.Fresh import Data.Aeson import qualified Data.Char as Char import Data.Text (Text) import qualified Data.Text as Text -import Data.String import Prologue -- | The type of variable names. @@ -19,6 +21,9 @@ data Name | I Int deriving (Eq, Ord) +gensym :: (Functor (m effs), Member Fresh effs, Effectful m) => m effs Name +gensym = I <$> fresh + -- | Construct a 'Name' from a 'Text'. name :: Text -> Name name = Name @@ -34,8 +39,6 @@ formatName (I i) = Text.pack $ '_' : (alphabet !! a) : replicate n 'ʹ' where alphabet = ['a'..'z'] (n, a) = i `divMod` length alphabet -instance IsString Name where - fromString = Name . Text.pack -- $ -- >>> I 0 diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 4b2340957..58ded89ac 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -228,7 +228,7 @@ resumingEvalError = runEvalErrorWith (\ err -> trace ("EvalError" <> show err) * IntegerFormatError{} -> pure 0 FloatFormatError{} -> pure 0 RationalFormatError{} -> pure 0 - FreeVariablesError names -> pure (fromMaybeLast "unknown" names)) + FreeVariablesError names -> pure (fromMaybeLast (name "unknown") names)) resumingUnspecialized :: (Member Trace effects, AbstractHole value) => Evaluator address value (Resumable (Unspecialized value) ': effects) a -> Evaluator address value effects a resumingUnspecialized = runUnspecializedWith (\ err@(Unspecialized _) -> trace ("Unspecialized:" <> show err) $> hole) From b63624ac41a00d8d58ec80e2bf59282cd75390ca Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 29 Jun 2018 15:54:45 -0400 Subject: [PATCH 07/46] cleanup --- src/Analysis/Abstract/Caching.hs | 23 ++--------------------- src/Analysis/Abstract/Graph.hs | 10 +--------- src/Data/Abstract/Cache.hs | 4 ---- src/Data/Map/Monoidal.hs | 4 ---- src/Semantic/Graph.hs | 5 ----- 5 files changed, 3 insertions(+), 43 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 4b512c67e..fcc8af978 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -10,8 +10,6 @@ import Data.Abstract.Cache import Data.Abstract.Module import Data.Abstract.Ref import Prologue -import Debug.Trace (traceM, traceShowId, trace) -import Text.Show.Pretty (ppShow) -- | Look up the set of values for a given configuration in the in-cache. consultOracle :: (Cacheable term address (Cell address) value, Member (Reader (Cache term address (Cell address) value)) effects) @@ -37,20 +35,14 @@ lookupCache configuration = cacheLookup configuration <$> get cachingConfiguration :: ( Cacheable term address (Cell address) value , Member (State (Cache term address (Cell address) value)) effects , Member (State (Heap address (Cell address) value)) effects - , Show address - , Show (Cell address value) ) => Configuration term address (Cell address) value -> Set (Cached address (Cell address) value) -> TermEvaluator term address value effects (ValueRef address) -> TermEvaluator term address value effects (ValueRef address) cachingConfiguration configuration values action = do - traceM "modifying caching configuration" - -- traceM ("there are " <> ppShow values <> " values") modify' (cacheSet configuration values) - traceM "evaluating cached result" result <- Cached <$> action <*> TermEvaluator getHeap - traceM "inserting value " cachedValue result <$ modify' (cacheInsert configuration result) putCache :: Member (State (Cache term address (Cell address) value)) effects @@ -74,26 +66,18 @@ cachingTerms :: ( Cacheable term address (Cell address) value , Member (State (Cache term address (Cell address) value)) effects , Member (Env address) effects , Member (State (Heap address (Cell address) value)) effects - , Show address - , Show (Cell address value) ) => SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef address)) -> SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef address)) cachingTerms recur term = do - traceM "cachingTerms: getting configuration" c <- getConfiguration (embedSubterm term) - traceM "looking up cache" cached <- lookupCache c case cached of - Just pairs -> traceM "scattering" *> scatter pairs + Just pairs -> scatter pairs Nothing -> do - traceM "consulting oracle" pairs <- consultOracle c - traceM "caching configuration" cachingConfiguration c pairs (recur term) -tracePrettyId a = Debug.Trace.trace (ppShow a) a - convergingModules :: ( AbstractValue address value effects , Cacheable term address (Cell address) value , Member (Allocator address value) effects @@ -105,16 +89,13 @@ convergingModules :: ( AbstractValue address value effects , Member (State (Cache term address (Cell address) value)) effects , Member (Env address) effects , Member (State (Heap address (Cell address) value)) effects - , Show term - , Show address - , Show (Cell address value) ) => SubtermAlgebra Module term (TermEvaluator term address value effects address) -> SubtermAlgebra Module term (TermEvaluator term address value effects address) convergingModules recur m = do c <- getConfiguration (subterm (moduleBody m)) -- Convergence here is predicated upon an Eq instance, not α-equivalence - cache <- converge lowerBound (\ prevCache -> fmap tracePrettyId . isolateCache . raiseHandler locally $ do + cache <- converge lowerBound (\ prevCache -> isolateCache . raiseHandler locally $ do TermEvaluator (putHeap (configurationHeap c)) -- We need to reset fresh generation so that this invocation converges. resetFresh 0 $ diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index 51e1b72f7..5a7431529 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -15,7 +15,6 @@ module Analysis.Abstract.Graph , graphing ) where -import Debug.Trace (traceM) import Algebra.Graph.Export.Dot hiding (vertexName) import Control.Abstract import Data.Abstract.Address @@ -30,7 +29,6 @@ import qualified Data.Syntax as Syntax import Data.Term import qualified Data.Text.Encoding as T import Prologue hiding (project) -import Text.Show.Pretty (ppShow) style :: Style Vertex Builder style = (defaultStyle (T.encodeUtf8Builder . vertexName)) @@ -51,22 +49,16 @@ graphingTerms :: ( Element Syntax.Identifier syntax , Member (Reader ModuleInfo) effects , Member (Env (Hole (Located address))) effects , Member (State (Graph Vertex)) effects - , Member Trace effects , term ~ Term (Sum syntax) ann - , Apply Show1 syntax - , Apply Functor syntax - , Show ann - , Show term ) => SubtermAlgebra (Base term) term (TermEvaluator term (Hole (Located address)) value effects a) -> SubtermAlgebra (Base term) term (TermEvaluator term (Hole (Located address)) value effects a) graphingTerms recur term@(In _ syntax) = do case project syntax of Just (Syntax.Identifier name) -> do - traceM ("Examining identifier " <> show name) moduleInclusion (Variable (formatName name)) variableDefinition name - Nothing -> pure () + _ -> pure () recur term -- | Add vertices to the graph for evaluated modules and the packages containing them. diff --git a/src/Data/Abstract/Cache.hs b/src/Data/Abstract/Cache.hs index a5fe94962..82e027f72 100644 --- a/src/Data/Abstract/Cache.hs +++ b/src/Data/Abstract/Cache.hs @@ -32,9 +32,5 @@ cacheSet key value = Cache . Monoidal.insert key value . unCache cacheInsert :: Cacheable term address cell value => Configuration term address cell value -> Cached address cell value -> Cache term address cell value -> Cache term address cell value cacheInsert = curry cons -cacheKeys :: Cache term address cell value -> [Configuration term address cell value] -cacheKeys (Cache c) = Monoidal.keys c - - instance (Show term, Show address, Show (cell value), Show value) => Show (Cache term address cell value) where showsPrec d = showsUnaryWith showsPrec "Cache" d . map (second toList) . Monoidal.pairs . unCache diff --git a/src/Data/Map/Monoidal.hs b/src/Data/Map/Monoidal.hs index c6ed1ddd2..34192cb2b 100644 --- a/src/Data/Map/Monoidal.hs +++ b/src/Data/Map/Monoidal.hs @@ -5,7 +5,6 @@ module Data.Map.Monoidal , lookup , singleton , size -, keys , insert , filterWithKey , pairs @@ -42,9 +41,6 @@ filterWithKey f = Map . Map.filterWithKey f . unMap pairs :: Map key value -> [(key, value)] pairs = Map.toList . unMap -keys :: Map key value -> [key] -keys = fmap fst . pairs - instance (Ord key, Semigroup value) => Semigroup (Map key value) where Map a <> Map b = Map (Map.unionWith (<>) a b) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 58ded89ac..b3556a0ed 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -21,14 +21,12 @@ module Semantic.Graph import Prelude hiding (readFile) -import Debug.Trace (traceM) import Analysis.Abstract.Caching import Analysis.Abstract.Collecting import Analysis.Abstract.Graph as Graph import Control.Abstract import Control.Monad.Effect (reinterpret) import Data.Abstract.Address --- import Data.Abstract.Cache import Data.Abstract.Evaluatable import Data.Abstract.Module import qualified Data.Abstract.ModuleTable as ModuleTable @@ -77,8 +75,6 @@ runCallGraph :: ( HasField ann Span , HasPrelude lang , Member Task effs , Recursive term - , Show (Record ann) - , Apply Show1 syntax ) => Proxy lang -> Bool @@ -88,7 +84,6 @@ runCallGraph :: ( HasField ann Span runCallGraph lang includePackages modules package = do let analyzeTerm = withTermSpans . graphingTerms . cachingTerms analyzeModule = (if includePackages then graphingPackages else id) . convergingModules --- extractGraph :: (((a, Graph Vertex), b), c) -> Graph Vertex extractGraph (((_, graph), _), _) = simplify graph runGraphAnalysis = run From bef406b5c766834fb577cb76d7421eac08d06d9e Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 29 Jun 2018 16:00:23 -0400 Subject: [PATCH 08/46] whitespace changes --- src/Analysis/Abstract/Caching.hs | 9 +++------ src/Data/Abstract/Cache.hs | 1 + src/Data/Abstract/Name.hs | 1 - 3 files changed, 4 insertions(+), 7 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index fcc8af978..33fa6a180 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -32,10 +32,7 @@ lookupCache :: (Cacheable term address (Cell address) value, Member (State (Cach lookupCache configuration = cacheLookup configuration <$> get -- | Run an action, caching its result and 'Heap' under the given configuration. -cachingConfiguration :: ( Cacheable term address (Cell address) value - , Member (State (Cache term address (Cell address) value)) effects - , Member (State (Heap address (Cell address) value)) effects - ) +cachingConfiguration :: (Cacheable term address (Cell address) value, Member (State (Cache term address (Cell address) value)) effects, Member (State (Heap address (Cell address) value)) effects) => Configuration term address (Cell address) value -> Set (Cached address (Cell address) value) -> TermEvaluator term address value effects (ValueRef address) @@ -96,7 +93,7 @@ convergingModules recur m = do c <- getConfiguration (subterm (moduleBody m)) -- Convergence here is predicated upon an Eq instance, not α-equivalence cache <- converge lowerBound (\ prevCache -> isolateCache . raiseHandler locally $ do - TermEvaluator (putHeap (configurationHeap c)) + TermEvaluator (putHeap (configurationHeap c)) -- We need to reset fresh generation so that this invocation converges. resetFresh 0 $ -- This is subtle: though the calling context supports nondeterminism, we want @@ -118,7 +115,7 @@ converge :: (Eq a, Monad m) converge seed f = loop seed where loop x = do x' <- f x - if x == x' then + if x' == x then pure x else loop x' diff --git a/src/Data/Abstract/Cache.hs b/src/Data/Abstract/Cache.hs index 82e027f72..413340276 100644 --- a/src/Data/Abstract/Cache.hs +++ b/src/Data/Abstract/Cache.hs @@ -32,5 +32,6 @@ cacheSet key value = Cache . Monoidal.insert key value . unCache cacheInsert :: Cacheable term address cell value => Configuration term address cell value -> Cached address cell value -> Cache term address cell value -> Cache term address cell value cacheInsert = curry cons + instance (Show term, Show address, Show (cell value), Show value) => Show (Cache term address cell value) where showsPrec d = showsUnaryWith showsPrec "Cache" d . map (second toList) . Monoidal.pairs . unCache diff --git a/src/Data/Abstract/Name.hs b/src/Data/Abstract/Name.hs index 5072a340e..d5e0afa5b 100644 --- a/src/Data/Abstract/Name.hs +++ b/src/Data/Abstract/Name.hs @@ -39,7 +39,6 @@ formatName (I i) = Text.pack $ '_' : (alphabet !! a) : replicate n 'ʹ' where alphabet = ['a'..'z'] (n, a) = i `divMod` length alphabet - -- $ -- >>> I 0 -- "_a" From 1eed347da6df91626cb7b59774815d3c3de0d1a0 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 29 Jun 2018 16:17:27 -0400 Subject: [PATCH 09/46] fix the specs --- test/Diffing/Algorithm/RWS/Spec.hs | 2 +- test/Diffing/Interpreter/Spec.hs | 1 + test/SpecHelpers.hs | 8 ++++++++ 3 files changed, 10 insertions(+), 1 deletion(-) diff --git a/test/Diffing/Algorithm/RWS/Spec.hs b/test/Diffing/Algorithm/RWS/Spec.hs index 5a74597e9..aaf93710a 100644 --- a/test/Diffing/Algorithm/RWS/Spec.hs +++ b/test/Diffing/Algorithm/RWS/Spec.hs @@ -12,8 +12,8 @@ import Data.Term import Data.These import Diffing.Algorithm import Diffing.Algorithm.RWS -import Test.Hspec import Test.Hspec.LeanCheck +import SpecHelpers spec :: Spec spec = parallel $ do diff --git a/test/Diffing/Interpreter/Spec.hs b/test/Diffing/Interpreter/Spec.hs index 75cb107dc..d1e2d5700 100644 --- a/test/Diffing/Interpreter/Spec.hs +++ b/test/Diffing/Interpreter/Spec.hs @@ -14,6 +14,7 @@ import Test.Hspec (Spec, describe, it, parallel) import Test.Hspec.Expectations.Pretty import Test.Hspec.LeanCheck import Test.LeanCheck.Core +import SpecHelpers spec :: Spec spec = parallel $ do diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index b4823e846..c156b6326 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + module SpecHelpers ( module X , runBuilder @@ -41,6 +43,7 @@ import Data.Record as X import Data.Semilattice.Lower as X import Data.Source as X import Data.Span as X +import Data.String import Data.Sum import Data.Term as X import Parsing.Parser as X @@ -68,6 +71,11 @@ import qualified Semantic.IO as IO runBuilder = toStrict . toLazyByteString +-- | This orphan instance is so we don't have to insert @name@ calls +-- in dozens and dozens of environment specs. +instance IsString Name where + fromString = name . fromString + -- | Returns an s-expression formatted diff for the specified FilePath pair. diffFilePaths :: Both FilePath -> IO ByteString diffFilePaths paths = readFilePair paths >>= fmap runBuilder . runTask . runDiff SExpressionDiffRenderer . pure From 0ca991f0ddfd8d0ad84ffa9a7e1a02e79dda6814 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 3 Jul 2018 14:29:47 -0400 Subject: [PATCH 10/46] Fix terrible bug associated with environment comparisons being false --- src/Analysis/Abstract/Caching.hs | 6 ++++-- src/Analysis/Abstract/Graph.hs | 2 +- src/Control/Abstract/Environment.hs | 8 ++++++++ src/Data/Abstract/Cache.hs | 2 ++ src/Data/Map/Monoidal.hs | 3 +++ src/Semantic/Graph.hs | 14 +++++++++----- src/Semantic/Util.hs | 10 ++++++++++ .../include-file-with-undefined-call/main.rb | 7 +++++++ .../include-file-with-undefined-call/target.rb | 3 +++ 9 files changed, 47 insertions(+), 8 deletions(-) create mode 100644 test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call/main.rb create mode 100644 test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call/target.rb diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 33fa6a180..20c85b4b2 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -92,8 +92,9 @@ convergingModules :: ( AbstractValue address value effects convergingModules recur m = do c <- getConfiguration (subterm (moduleBody m)) -- Convergence here is predicated upon an Eq instance, not α-equivalence - cache <- converge lowerBound (\ prevCache -> isolateCache . raiseHandler locally $ do + cache <- converge lowerBound (\ prevCache -> isolateCache $ do TermEvaluator (putHeap (configurationHeap c)) + TermEvaluator (putEnv (configurationEnvironment c)) -- We need to reset fresh generation so that this invocation converges. resetFresh 0 $ -- This is subtle: though the calling context supports nondeterminism, we want @@ -102,8 +103,9 @@ convergingModules recur m = do -- would never complete). We don’t need to use the values, so we 'gather' the -- nondeterministic values into @()@. withOracle prevCache (gatherM (const ()) (recur m))) - TermEvaluator (address =<< runTermEvaluator (maybe empty scatter (cacheLookup c cache))) + -- TODO: We're hitting an infinite loop here, c.f test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call + TermEvaluator (address =<< runTermEvaluator (maybe empty scatter (cacheLookup c cache))) -- | Iterate a monadic action starting from some initial seed until the results converge. -- diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index 5a7431529..bfc661a6d 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -49,7 +49,7 @@ graphingTerms :: ( Element Syntax.Identifier syntax , Member (Reader ModuleInfo) effects , Member (Env (Hole (Located address))) effects , Member (State (Graph Vertex)) effects - , term ~ Term (Sum syntax) ann + , Base term ~ TermF (Sum syntax) ann ) => SubtermAlgebra (Base term) term (TermEvaluator term (Hole (Located address)) value effects a) -> SubtermAlgebra (Base term) term (TermEvaluator term (Hole (Located address)) value effects a) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 3100c5c6f..5681f51dd 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -3,6 +3,7 @@ module Control.Abstract.Environment ( Environment , Exports , getEnv +, putEnv , export , lookupEnv , bind @@ -29,6 +30,10 @@ import Prologue getEnv :: Member (Env address) effects => Evaluator address value effects (Environment address) getEnv = send GetEnv +-- | This is only for use in Analysis.Abstract.Caching. +putEnv :: Member (Env address) effects => Environment address -> Evaluator address value effects () +putEnv = send . PutEnv + -- | Add an export to the global export state. export :: Member (Env address) effects => Name -> Name -> Maybe address -> Evaluator address value effects () export name alias addr = send (Export name alias addr) @@ -67,6 +72,8 @@ data Env address return where Pop :: Env address () GetEnv :: Env address (Environment address) Export :: Name -> Name -> Maybe address -> Env address () + PutEnv :: Environment address -> Env address () + handleEnv :: forall address effects value result . ( Member (State (Environment address)) effects @@ -81,6 +88,7 @@ handleEnv = \case Push -> modify (Env.push @address) Pop -> modify (Env.pop @address) GetEnv -> get + PutEnv e -> put e Export name alias addr -> modify (Exports.insert name alias addr) runEnv :: Environment address diff --git a/src/Data/Abstract/Cache.hs b/src/Data/Abstract/Cache.hs index 413340276..703691dc9 100644 --- a/src/Data/Abstract/Cache.hs +++ b/src/Data/Abstract/Cache.hs @@ -32,6 +32,8 @@ cacheSet key value = Cache . Monoidal.insert key value . unCache cacheInsert :: Cacheable term address cell value => Configuration term address cell value -> Cached address cell value -> Cache term address cell value -> Cache term address cell value cacheInsert = curry cons +cacheKeys :: Cacheable term address cell value => Cache term address cell value -> [Configuration term address cell value] +cacheKeys = Monoidal.keys . unCache instance (Show term, Show address, Show (cell value), Show value) => Show (Cache term address cell value) where showsPrec d = showsUnaryWith showsPrec "Cache" d . map (second toList) . Monoidal.pairs . unCache diff --git a/src/Data/Map/Monoidal.hs b/src/Data/Map/Monoidal.hs index 34192cb2b..6fa553857 100644 --- a/src/Data/Map/Monoidal.hs +++ b/src/Data/Map/Monoidal.hs @@ -8,6 +8,7 @@ module Data.Map.Monoidal , insert , filterWithKey , pairs +, keys , module Reducer ) where @@ -37,6 +38,8 @@ insert key value = Map . Map.insert key value . unMap filterWithKey :: (key -> value -> Bool) -> Map key value -> Map key value filterWithKey f = Map . Map.filterWithKey f . unMap +keys :: Map key value -> [key] +keys = map fst . pairs pairs :: Map key value -> [(key, value)] pairs = Map.toList . unMap diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index b3556a0ed..51658eecc 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -1,6 +1,7 @@ {-# LANGUAGE GADTs, ScopedTypeVariables, TypeOperators #-} module Semantic.Graph ( runGraph +, runCallGraph , runImportGraph , GraphType(..) , Graph @@ -59,7 +60,7 @@ runGraph ImportGraph _ project runGraph CallGraph includePackages project | SomeAnalysisParser parser lang <- someAnalysisParser (Proxy :: Proxy AnalysisClasses) (projectLanguage project) = do package <- parsePackage parser project - modules <- runImportGraph lang package + modules <- topologicalSort <$> runImportGraph lang package runCallGraph lang includePackages modules package runCallGraph :: ( HasField ann Span @@ -68,7 +69,10 @@ runCallGraph :: ( HasField ann Span , Apply Ord1 syntax , Apply Functor syntax , Ord (Record ann) - , term ~ Term (Sum syntax) (Record ann) + , Show term + , Base term ~ TermF (Sum syntax) (Record ann) + , Ord term + , Corecursive term , Declarations term , Evaluatable (Base term) , FreeVariables term @@ -78,12 +82,12 @@ runCallGraph :: ( HasField ann Span ) => Proxy lang -> Bool - -> Graph (Module term) + -> [Module term] -> Package term -> Eff effs (Graph Vertex) runCallGraph lang includePackages modules package = do let analyzeTerm = withTermSpans . graphingTerms . cachingTerms - analyzeModule = (if includePackages then graphingPackages else id) . convergingModules + analyzeModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules extractGraph (((_, graph), _), _) = simplify graph runGraphAnalysis = run @@ -106,7 +110,7 @@ runCallGraph lang includePackages modules package = do . fmap fst . runState (lowerBound @(ModuleTable (NonEmpty (Module (Hole (Located Monovariant), Environment (Hole (Located Monovariant))))))) . raiseHandler (runModules (ModuleTable.modulePaths (packageModules package))) - extractGraph <$> analyze runGraphAnalysis (evaluate lang analyzeModule analyzeTerm (topologicalSort modules)) + extractGraph <$> analyze runGraphAnalysis (evaluate lang analyzeModule analyzeTerm modules) runImportGraph :: ( Declarations term diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index e06100ea4..052227828 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -98,6 +98,16 @@ evalTypeScriptProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Lang typecheckGoFile = checking <=< evaluateProjectWithCaching (Proxy :: Proxy 'Language.Go) goParser Language.Go +callGraphRubyProject paths = runTaskWithOptions debugOptions $ do + let proxy = Proxy @'Language.Ruby + let lang = Language.Ruby + blobs <- catMaybes <$> traverse readFile (flip File lang <$> paths) + package <- parsePackage rubyParser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs lang []) + modules <- topologicalSort <$> runImportGraph proxy package + x <- runCallGraph proxy False modules package + pure (x, modules) + + -- Evaluate a project consisting of the listed paths. evaluateProject proxy parser lang paths = runTaskWithOptions debugOptions $ do blobs <- catMaybes <$> traverse readFile (flip File lang <$> paths) diff --git a/test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call/main.rb b/test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call/main.rb new file mode 100644 index 000000000..92e64d33a --- /dev/null +++ b/test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call/main.rb @@ -0,0 +1,7 @@ +require './target' + +def go() + "done" +end + +go() diff --git a/test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call/target.rb b/test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call/target.rb new file mode 100644 index 000000000..678daf934 --- /dev/null +++ b/test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call/target.rb @@ -0,0 +1,3 @@ +barf() + +def foo(); end From cfefbefaa63d27a9c37d108478211b2f68d94e3e Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 3 Jul 2018 14:30:26 -0400 Subject: [PATCH 11/46] Remove the misleading Show instance for Environments. --- src/Data/Abstract/Environment.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Environment.hs b/src/Data/Abstract/Environment.hs index d742a8ef6..26562ba9d 100644 --- a/src/Data/Abstract/Environment.hs +++ b/src/Data/Abstract/Environment.hs @@ -152,4 +152,4 @@ addresses = fromAddresses . map snd . flatPairs instance Lower (Environment address) where lowerBound = Environment (lowerBound :| []) instance Show address => Show (Environment address) where - showsPrec d = showsUnaryWith showsPrec "Environment" d . flatPairs + showsPrec d = showsUnaryWith showsPrec "Environment" d From 7d6195fe7dee065cfdae7386efd3d0e77f880e0e Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 3 Jul 2018 18:46:45 -0400 Subject: [PATCH 12/46] lints --- src/Data/Abstract/Cache.hs | 3 ++- src/Semantic/Graph.hs | 5 ----- 2 files changed, 2 insertions(+), 6 deletions(-) diff --git a/src/Data/Abstract/Cache.hs b/src/Data/Abstract/Cache.hs index 703691dc9..78bd3ab25 100644 --- a/src/Data/Abstract/Cache.hs +++ b/src/Data/Abstract/Cache.hs @@ -32,7 +32,8 @@ cacheSet key value = Cache . Monoidal.insert key value . unCache cacheInsert :: Cacheable term address cell value => Configuration term address cell value -> Cached address cell value -> Cache term address cell value -> Cache term address cell value cacheInsert = curry cons -cacheKeys :: Cacheable term address cell value => Cache term address cell value -> [Configuration term address cell value] +-- | Return all 'Configuration's in the provided cache. +cacheKeys :: Cache term address cell value -> [Configuration term address cell value] cacheKeys = Monoidal.keys . unCache instance (Show term, Show address, Show (cell value), Show value) => Show (Cache term address cell value) where diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 51658eecc..d89b1c8ca 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -65,11 +65,6 @@ runGraph CallGraph includePackages project runCallGraph :: ( HasField ann Span , Element Syntax.Identifier syntax - , Apply Eq1 syntax - , Apply Ord1 syntax - , Apply Functor syntax - , Ord (Record ann) - , Show term , Base term ~ TermF (Sum syntax) (Record ann) , Ord term , Corecursive term From d6542b9e706bdf26805bb28ae9d0e530bc6ca40d Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 11 Jul 2018 14:44:14 -0400 Subject: [PATCH 13/46] Fix up handleState implementations --- src/Control/Abstract/Environment.hs | 14 +++++++------- src/Control/Abstract/Heap.hs | 8 ++++---- src/Control/Abstract/Modules.hs | 8 ++++---- src/Semantic/Distribute.hs | 2 +- src/Semantic/IO.hs | 8 ++++---- src/Semantic/Resolution.hs | 4 ++-- src/Semantic/Task.hs | 12 ++++++------ src/Semantic/Telemetry.hs | 4 ++-- 8 files changed, 30 insertions(+), 30 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 5ffcb4be3..4f896168d 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -71,13 +71,13 @@ data Env address m return where Export :: Name -> Name -> Maybe address -> Env address m () instance Effect (Env address) where - handleState c dist (Request (Lookup name) k) = Request (Lookup name) (dist . (<$ c) . k) - handleState c dist (Request (Bind name addr) k) = Request (Bind name addr) (dist . (<$ c) . k) - handleState c dist (Request (Close names) k) = Request (Close names) (dist . (<$ c) . k) - handleState c dist (Request (Locally action) k) = Request (Locally (dist (action <$ c))) (dist . fmap k) - handleState c dist (Request GetEnv k) = Request GetEnv (dist . (<$ c) . k) - handleState c dist (Request (PutEnv e) k) = Request (PutEnv e) (dist . (<$ c) . k) - handleState c dist (Request (Export name alias addr) k) = Request (Export name alias addr) (dist . (<$ c) . k) + handleState c dist (Request (Lookup name) k) = Request (Lookup name) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Bind name addr) k) = Request (Bind name addr) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Close names) k) = Request (Close names) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Locally action) k) = Request (Locally (dist (action <$ c) k)) pure + handleState c dist (Request GetEnv k) = Request GetEnv (\result -> dist (pure result <$ c) k) + handleState c dist (Request (PutEnv e) k) = Request (PutEnv e) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Export name alias addr) k) = Request (Export name alias addr) (\result -> dist (pure result <$ c) k) runEnv :: Effects effects => Environment address diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 16cfcab93..64e26112c 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -175,10 +175,10 @@ runAllocator = interpret $ \ eff -> case eff of GC roots -> modifyHeap (heapRestrict <*> reachable roots) instance Effect (Allocator address value) where - handleState c dist (Request (Alloc name) k) = Request (Alloc name) (dist . (<$ c) . k) - handleState c dist (Request (Deref addr) k) = Request (Deref addr) (dist . (<$ c) . k) - handleState c dist (Request (Assign addr value) k) = Request (Assign addr value) (dist . (<$ c) . k) - handleState c dist (Request (GC roots) k) = Request (GC roots) (dist . (<$ c) . k) + handleState c dist (Request (Alloc name) k) = Request (Alloc name) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Deref addr) k) = Request (Deref addr) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Assign addr value) k) = Request (Assign addr value) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (GC roots) k) = Request (GC roots) (\result -> dist (pure result <$ c) k) data AddressError address value resume where diff --git a/src/Control/Abstract/Modules.hs b/src/Control/Abstract/Modules.hs index 7a31dbd3f..73a07af88 100644 --- a/src/Control/Abstract/Modules.hs +++ b/src/Control/Abstract/Modules.hs @@ -59,10 +59,10 @@ data Modules address (m :: * -> *) return where List :: FilePath -> Modules address m [ModulePath] instance Effect (Modules address) where - handleState c dist (Request (Load path) k) = Request (Load path) (dist . (<$ c) . k) - handleState c dist (Request (Lookup path) k) = Request (Lookup path) (dist . (<$ c) . k) - handleState c dist (Request (Resolve paths) k) = Request (Resolve paths) (dist . (<$ c) . k) - handleState c dist (Request (List path) k) = Request (List path) (dist . (<$ c) . k) + handleState c dist (Request (Load path) k) = Request (Load path) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Lookup path) k) = Request (Lookup path) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Resolve paths) k) = Request (Resolve paths) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (List path) k) = Request (List path) (\result -> dist (pure result <$ c) k) sendModules :: Member (Modules address) effects => Modules address (Eff effects) return -> Evaluator address value effects return sendModules = send diff --git a/src/Semantic/Distribute.hs b/src/Semantic/Distribute.hs index 69b162606..0b19c8854 100644 --- a/src/Semantic/Distribute.hs +++ b/src/Semantic/Distribute.hs @@ -36,7 +36,7 @@ distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs)) newtype Distribute task output = Distribute (task output) instance Effect Distribute where - handleState c dist (Request (Distribute task) k) = Request (Distribute (dist (task <$ c))) (dist . fmap k) + handleState c dist (Request (Distribute task) k) = Request (Distribute (dist (task <$ c) k)) pure -- | Evaluate a 'Distribute' effect concurrently. diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index 445f294de..00f01465c 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -221,10 +221,10 @@ data Files (m :: * -> *) out where Write :: Destination -> B.Builder -> Files m () instance Effect Files where - handleState c dist (Request (Read source) k) = Request (Read source) (dist . (<$ c) . k) - handleState c dist (Request (ReadProject rootDir dir language excludeDirs) k) = Request (ReadProject rootDir dir language excludeDirs) (dist . (<$ c) . k) - handleState c dist (Request (FindFiles dir exts paths) k) = Request (FindFiles dir exts paths) (dist . (<$ c) . k) - handleState c dist (Request (Write destination builder) k) = Request (Write destination builder) (dist . (<$ c) . k) + handleState c dist (Request (Read source) k) = Request (Read source) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (ReadProject rootDir dir language excludeDirs) k) = Request (ReadProject rootDir dir language excludeDirs) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (FindFiles dir exts paths) k) = Request (FindFiles dir exts paths) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Write destination builder) k) = Request (Write destination builder) (\result -> dist (pure result <$ c) k) -- | Run a 'Files' effect in 'IO'. runFiles :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Effects effs) => Eff (Files ': effs) a -> Eff effs a diff --git a/src/Semantic/Resolution.hs b/src/Semantic/Resolution.hs index 62ed86246..2db36cea6 100644 --- a/src/Semantic/Resolution.hs +++ b/src/Semantic/Resolution.hs @@ -40,8 +40,8 @@ data Resolution (m :: * -> *) output where NoResolution :: Resolution m (Map FilePath FilePath) instance Effect Resolution where - handleState c dist (Request (NodeJSResolution path key paths) k) = Request (NodeJSResolution path key paths) (dist . (<$ c) . k) - handleState c dist (Request NoResolution k) = Request NoResolution (dist . (<$ c) . k) + handleState c dist (Request (NodeJSResolution path key paths) k) = Request (NodeJSResolution path key paths) (\result -> dist (pure result <$ c) k) + handleState c dist (Request NoResolution k) = Request NoResolution (\result -> dist (pure result <$ c) k) runResolution :: (Member Files effs, Effects effs) => Eff (Resolution ': effs) a -> Eff effs a runResolution = interpret $ \ res -> case res of diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 83d07483c..41b8d2345 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -168,12 +168,12 @@ data Task (m :: * -> *) output where Serialize :: Format input -> input -> Task m Builder instance Effect Task where - handleState c dist (Request (Parse parser blob) k) = Request (Parse parser blob) (dist . (<$ c) . k) - handleState c dist (Request (Analyze run analysis) k) = Request (Analyze run analysis) (dist . (<$ c) . k) - handleState c dist (Request (Decorate decorator term) k) = Request (Decorate decorator term) (dist . (<$ c) . k) - handleState c dist (Request (Semantic.Task.Diff terms) k) = Request (Semantic.Task.Diff terms) (dist . (<$ c) . k) - handleState c dist (Request (Render renderer input) k) = Request (Render renderer input) (dist . (<$ c) . k) - handleState c dist (Request (Serialize format input) k) = Request (Serialize format input) (dist . (<$ c) . k) + handleState c dist (Request (Parse parser blob) k) = Request (Parse parser blob) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Analyze run analysis) k) = Request (Analyze run analysis) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Decorate decorator term) k) = Request (Decorate decorator term) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Semantic.Task.Diff terms) k) = Request (Semantic.Task.Diff terms) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Render renderer input) k) = Request (Render renderer input) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Serialize format input) k) = Request (Serialize format input) (\result -> dist (pure result <$ c) k) -- | Run a 'Task' effect by performing the actions in 'IO'. runTaskF :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Telemetry effs, Member Trace effs, Effects effs) => Eff (Task ': effs) a -> Eff effs a diff --git a/src/Semantic/Telemetry.hs b/src/Semantic/Telemetry.hs index e42152619..5ff47466c 100644 --- a/src/Semantic/Telemetry.hs +++ b/src/Semantic/Telemetry.hs @@ -134,8 +134,8 @@ data Telemetry (m :: * -> *) output where WriteLog :: Level -> String -> [(String, String)] -> Telemetry m () instance Effect Telemetry where - handleState c dist (Request (WriteStat stat) k) = Request (WriteStat stat) (dist . (<$ c) . k) - handleState c dist (Request (WriteLog level message pairs) k) = Request (WriteLog level message pairs) (dist . (<$ c) . k) + handleState c dist (Request (WriteStat stat) k) = Request (WriteStat stat) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (WriteLog level message pairs) k) = Request (WriteLog level message pairs) (\result -> dist (pure result <$ c) k) -- | Run a 'Telemetry' effect by expecting a 'Reader' of 'Queue's to write stats and logs to. runTelemetry :: (Member (Lift IO) effects, Effects effects) => LogQueue -> StatQueue -> Eff (Telemetry ': effects) a -> Eff effects a From 1f156c0ba22b14f313fe8f66e580869f9ad4cfb0 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 11 Jul 2018 15:14:12 -0400 Subject: [PATCH 14/46] More redundant constraints --- 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 aa4580e0b..e1014e17d 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -30,7 +30,6 @@ instance AbstractIntro Abstract where instance ( Member (Allocator address Abstract) effects , Member (Env address) effects , Member (Exc (Return address)) effects - , Member Fresh effects ) => AbstractFunction address Abstract effects where closure names _ body = do From da8c791e9857a6194f529732fe2dd522abfb1a4d Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 11 Jul 2018 15:30:22 -0400 Subject: [PATCH 15/46] Add trace effect to unit tests --- src/Data/Abstract/Value/Abstract.hs | 1 + src/Semantic/Graph.hs | 1 + test/Control/Abstract/Evaluator/Spec.hs | 2 ++ 3 files changed, 4 insertions(+) diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index e1014e17d..aa4580e0b 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -30,6 +30,7 @@ instance AbstractIntro Abstract where instance ( Member (Allocator address Abstract) effects , Member (Env address) effects , Member (Exc (Return address)) effects + , Member Fresh effects ) => AbstractFunction address Abstract effects where closure names _ body = do diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index b22f46e09..6a59fe98b 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -29,6 +29,7 @@ import Data.Abstract.Evaluatable import Data.Abstract.Module import qualified Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Package as Package +import Data.Abstract.Value.Type import Data.Abstract.Value.Concrete (Value, ValueError (..), runValueErrorWith) import Data.Graph import Data.Project diff --git a/test/Control/Abstract/Evaluator/Spec.hs b/test/Control/Abstract/Evaluator/Spec.hs index 72f9ea1d4..75b80402b 100644 --- a/test/Control/Abstract/Evaluator/Spec.hs +++ b/test/Control/Abstract/Evaluator/Spec.hs @@ -37,6 +37,7 @@ evaluate . runValueError . runEnvironmentError . runAddressError + . runIgnoringTrace . runAllocator @Precise @_ @Val . (>>= deref . snd) . runEnv lowerBound @@ -52,6 +53,7 @@ newtype SpecEff a = SpecEff , Exc (Return Precise) , Env Precise , Allocator Precise Val + , Trace , Resumable (AddressError Precise Val) , Resumable (EnvironmentError Precise) , Resumable (ValueError Precise SpecEff) From 25471daee620281d4cdb4ec985e573ee0340a41b Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 11 Jul 2018 15:38:46 -0400 Subject: [PATCH 16/46] ++effects --- vendor/effects | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/effects b/vendor/effects index 105a543cc..181614aef 160000 --- a/vendor/effects +++ b/vendor/effects @@ -1 +1 @@ -Subproject commit 105a543ccc98f2929cf0b1f1e97bcc48dfb8f718 +Subproject commit 181614aeff3aa48d82310bcf0fdf5700d5a4481e From 635de237a26cec22b6917115347aa8012004d101 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 12 Jul 2018 09:17:42 -0400 Subject: [PATCH 17/46] Move builtInPrint to Control.Abstract.Primitive. --- src/Control/Abstract/Primitive.hs | 14 ++++++++++++++ src/Data/Abstract/Evaluatable.hs | 14 -------------- 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 5eeebc4e0..3afeb32f5 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -75,3 +75,17 @@ defineBuiltins :: ( AbstractValue address value effects => Evaluator address value effects () defineBuiltins = define "__semantic_print" (lambda (\ v -> variable v >>= deref >>= asString >>= trace . unpack >> box unit)) + +builtInPrint :: ( AbstractIntro value + , AbstractFunction address value effects + , Member (Allocator address value) effects + , Member (Env address) effects + , Member Fresh effects + , Member (Resumable (EnvironmentError address)) effects + ) + => Name + -> Evaluator address value effects address +builtInPrint v = do + print <- variable "__semantic_print" >>= deref + void $ call print [variable v] + box unit diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 7c8640cb0..9427f02a6 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -148,20 +148,6 @@ instance HasPrelude 'Haskell instance HasPrelude 'Java instance HasPrelude 'PHP -builtInPrint :: ( AbstractIntro value - , AbstractFunction address value effects - , Member (Allocator address value) effects - , Member (Env address) effects - , Member Fresh effects - , Member (Resumable (EnvironmentError address)) effects - ) - => Name - -> Evaluator address value effects address -builtInPrint v = do - print <- variable "__semantic_print" >>= deref - void $ call print [variable v] - box unit - instance HasPrelude 'Python where definePrelude _ = define "print" (lambda builtInPrint) From ca4029ad0a21ae61ed2860abc8b61c1b83fd7e75 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 12 Jul 2018 09:22:39 -0400 Subject: [PATCH 18/46] Move the lambda into builtInPrint. --- src/Control/Abstract/Primitive.hs | 11 ++++------- src/Data/Abstract/Evaluatable.hs | 8 ++++---- 2 files changed, 8 insertions(+), 11 deletions(-) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 3afeb32f5..2951423d3 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -76,16 +76,13 @@ defineBuiltins :: ( AbstractValue address value effects defineBuiltins = define "__semantic_print" (lambda (\ v -> variable v >>= deref >>= asString >>= trace . unpack >> box unit)) -builtInPrint :: ( AbstractIntro value - , AbstractFunction address value effects +builtInPrint :: ( AbstractFunction address value effects , Member (Allocator address value) effects , Member (Env address) effects , Member Fresh effects , Member (Resumable (EnvironmentError address)) effects ) - => Name - -> Evaluator address value effects address -builtInPrint v = do + => Evaluator address value effects value +builtInPrint = lambda $ \ v -> do print <- variable "__semantic_print" >>= deref - void $ call print [variable v] - box unit + call print [variable v] diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 9427f02a6..8e4c7d1e8 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -150,11 +150,11 @@ instance HasPrelude 'PHP instance HasPrelude 'Python where definePrelude _ = - define "print" (lambda builtInPrint) + define "print" builtInPrint instance HasPrelude 'Ruby where definePrelude _ = do - define "puts" (lambda builtInPrint) + define "puts" builtInPrint defineClass "Object" [] $ do define "inspect" (lambda (const (box (string "")))) @@ -162,12 +162,12 @@ instance HasPrelude 'Ruby where instance HasPrelude 'TypeScript where definePrelude _ = defineNamespace "console" $ do - define "log" (lambda builtInPrint) + define "log" builtInPrint instance HasPrelude 'JavaScript where definePrelude _ = do defineNamespace "console" $ do - define "log" (lambda builtInPrint) + define "log" builtInPrint -- Effects From d4704ed489e384659daad66ced1dcaf1ab875340 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 12 Jul 2018 09:24:32 -0400 Subject: [PATCH 19/46] Define builtInPrint without reference to __semantic_print. --- src/Control/Abstract/Primitive.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 2951423d3..4a08047ca 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -76,13 +76,12 @@ defineBuiltins :: ( AbstractValue address value effects defineBuiltins = define "__semantic_print" (lambda (\ v -> variable v >>= deref >>= asString >>= trace . unpack >> box unit)) -builtInPrint :: ( AbstractFunction address value effects +builtInPrint :: ( AbstractValue address value effects , Member (Allocator address value) effects , Member (Env address) effects , Member Fresh effects , Member (Resumable (EnvironmentError address)) effects + , Member Trace effects ) => Evaluator address value effects value -builtInPrint = lambda $ \ v -> do - print <- variable "__semantic_print" >>= deref - call print [variable v] +builtInPrint = lambda (\ v -> variable v >>= deref >>= asString >>= trace . unpack >> box unit) From 6e8a1ad3e16b4a196e0f361780775292cd89d405 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 12 Jul 2018 09:25:02 -0400 Subject: [PATCH 20/46] :fire: defineBuiltins. --- src/Control/Abstract/Primitive.hs | 14 -------------- src/Data/Abstract/Evaluatable.hs | 1 - 2 files changed, 15 deletions(-) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 4a08047ca..0db24c4fa 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -62,20 +62,6 @@ lambda body = do var <- gensym closure [var] lowerBound (body var) -defineBuiltins :: ( AbstractValue address value effects - , HasCallStack - , Member (Allocator address value) effects - , Member (Env address) effects - , Member Fresh effects - , Member (Reader ModuleInfo) effects - , Member (Reader Span) effects - , Member (Resumable (EnvironmentError address)) effects - , Member Trace effects - ) - => Evaluator address value effects () -defineBuiltins = - define "__semantic_print" (lambda (\ v -> variable v >>= deref >>= asString >>= trace . unpack >> box unit)) - builtInPrint :: ( AbstractValue address value effects , Member (Allocator address value) effects , Member (Env address) effects diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 8e4c7d1e8..2697af8f9 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -100,7 +100,6 @@ evaluate :: ( AbstractValue address value inner -> TermEvaluator term address value effects (ModuleTable (NonEmpty (Module (Environment address, address)))) evaluate lang analyzeModule analyzeTerm modules = do (preludeEnv, _) <- TermEvaluator . runInModule lowerBound moduleInfoFromCallStack $ do - defineBuiltins definePrelude lang box unit foldr (run preludeEnv) ask modules From 62edaaa7c9c15fe74954cd82f5bac9f26b73ce2b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 12 Jul 2018 09:26:00 -0400 Subject: [PATCH 21/46] Reformat the signature for lambda. --- src/Control/Abstract/Primitive.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 0db24c4fa..2867ce7b2 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -55,7 +55,9 @@ defineNamespace name scope = define name $ do Env.newEnv . Env.head <$> getEnv namespace name env -lambda :: (AbstractFunction address value effects, Member Fresh effects) +lambda :: ( AbstractFunction address value effects + , Member Fresh effects + ) => (Name -> Evaluator address value effects address) -> Evaluator address value effects value lambda body = do From 7c1b1ce197d0df3d56b8b357ee81d8477160d530 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 12 Jul 2018 09:29:20 -0400 Subject: [PATCH 22/46] Lambdas are evaluated within their call stack. --- src/Control/Abstract/Primitive.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 2867ce7b2..6b9ec3df5 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -56,18 +56,24 @@ defineNamespace name scope = define name $ do namespace name env lambda :: ( AbstractFunction address value effects + , HasCallStack , Member Fresh effects + , Member (Reader ModuleInfo) effects + , Member (Reader Span) effects ) => (Name -> Evaluator address value effects address) -> Evaluator address value effects value -lambda body = do +lambda body = withCurrentCallStack callStack $ do var <- gensym closure [var] lowerBound (body var) builtInPrint :: ( AbstractValue address value effects + , HasCallStack , Member (Allocator address value) effects , Member (Env address) effects , Member Fresh effects + , Member (Reader ModuleInfo) effects + , Member (Reader Span) effects , Member (Resumable (EnvironmentError address)) effects , Member Trace effects ) From 2fd483cc92ccd9ab1008414cbe14fdae224ac0de Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 12 Jul 2018 11:42:01 -0400 Subject: [PATCH 23/46] Define locally via bracketing Push/Pop constructors. --- src/Control/Abstract/Environment.hs | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 4f896168d..4b1e73710 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators #-} +{-# LANGUAGE GADTs, KindSignatures, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators #-} module Control.Abstract.Environment ( Environment , Exports @@ -53,7 +53,10 @@ bindAll = foldr ((>>) . uncurry bind) (pure ()) . Env.flatPairs -- | Run an action in a new local scope. locally :: forall address value effects a . Member (Env address) effects => Evaluator address value effects a -> Evaluator address value effects a -locally = send . Locally @address . lowerEff +locally a = do + send (Push @address) + a' <- a + a' <$ send (Pop @address) close :: Member (Env address) effects => Set Name -> Evaluator address value effects (Environment address) close = send . Close @@ -61,11 +64,12 @@ close = send . Close -- Effects -data Env address m return where +data Env address (m :: * -> *) return where Lookup :: Name -> Env address m (Maybe address) Bind :: Name -> address -> Env address m () Close :: Set Name -> Env address m (Environment address) - Locally :: m a -> Env address m a + Push :: Env address m () + Pop :: Env address m () GetEnv :: Env address m (Environment address) PutEnv :: Environment address -> Env address m () Export :: Name -> Name -> Maybe address -> Env address m () @@ -74,7 +78,8 @@ instance Effect (Env address) where handleState c dist (Request (Lookup name) k) = Request (Lookup name) (\result -> dist (pure result <$ c) k) handleState c dist (Request (Bind name addr) k) = Request (Bind name addr) (\result -> dist (pure result <$ c) k) handleState c dist (Request (Close names) k) = Request (Close names) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (Locally action) k) = Request (Locally (dist (action <$ c) k)) pure + handleState c dist (Request Push k) = Request Push (\result -> dist (pure result <$ c) k) + handleState c dist (Request Pop k) = Request Pop (\result -> dist (pure result <$ c) k) handleState c dist (Request GetEnv k) = Request GetEnv (\result -> dist (pure result <$ c) k) handleState c dist (Request (PutEnv e) k) = Request (PutEnv e) (\result -> dist (pure result <$ c) k) handleState c dist (Request (Export name alias addr) k) = Request (Export name alias addr) (\result -> dist (pure result <$ c) k) @@ -91,15 +96,13 @@ runEnv initial = fmap (filterEnv . fmap (first Env.head)) . runState lowerBound | Exports.null ports = (Env.newEnv binds, a) | otherwise = (Env.newEnv (Exports.toBindings ports <> Env.aliasBindings (Exports.aliases ports) binds), a) -handleEnv :: forall address value effects a . Effects effects => Env address (Eff (Env address ': effects)) a -> Evaluator address value (State (Environment address) ': State (Exports address) ': effects) a +handleEnv :: forall address value effects a . Env address (Eff (Env address ': effects)) a -> Evaluator address value (State (Environment address) ': State (Exports address) ': effects) a handleEnv = \case Lookup name -> Env.lookup name <$> get Bind name addr -> modify (Env.insert name addr) Close names -> Env.intersect names <$> get - Locally action -> do - modify' (Env.push @address) - a <- reinterpret2 handleEnv (raiseEff action) - a <$ modify' (Env.pop @address) + Push -> modify' (Env.push @address) + Pop -> modify' (Env.pop @address) GetEnv -> get PutEnv e -> put e Export name alias addr -> modify (Exports.insert name alias addr) From 0508ab8122b825683b35b11fcfbdba7feeefe2e0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 12 Jul 2018 13:39:21 -0400 Subject: [PATCH 24/46] Bump effects. --- src/Control/Abstract/Environment.hs | 16 ++++++++-------- src/Control/Abstract/Heap.hs | 8 ++++---- src/Control/Abstract/Modules.hs | 8 ++++---- src/Semantic/Distribute.hs | 2 +- src/Semantic/IO.hs | 8 ++++---- src/Semantic/Resolution.hs | 4 ++-- src/Semantic/Task.hs | 12 ++++++------ src/Semantic/Telemetry.hs | 4 ++-- vendor/effects | 2 +- 9 files changed, 32 insertions(+), 32 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 4b1e73710..5b78054a2 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -75,14 +75,14 @@ data Env address (m :: * -> *) return where Export :: Name -> Name -> Maybe address -> Env address m () instance Effect (Env address) where - handleState c dist (Request (Lookup name) k) = Request (Lookup name) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (Bind name addr) k) = Request (Bind name addr) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (Close names) k) = Request (Close names) (\result -> dist (pure result <$ c) k) - handleState c dist (Request Push k) = Request Push (\result -> dist (pure result <$ c) k) - handleState c dist (Request Pop k) = Request Pop (\result -> dist (pure result <$ c) k) - handleState c dist (Request GetEnv k) = Request GetEnv (\result -> dist (pure result <$ c) k) - handleState c dist (Request (PutEnv e) k) = Request (PutEnv e) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (Export name alias addr) k) = Request (Export name alias addr) (\result -> dist (pure result <$ c) k) + handleState c dist (Lookup name) k = Request (Lookup name) (\result -> dist (pure result <$ c) k) + handleState c dist (Bind name addr) k = Request (Bind name addr) (\result -> dist (pure result <$ c) k) + handleState c dist (Close names) k = Request (Close names) (\result -> dist (pure result <$ c) k) + handleState c dist Push k = Request Push (\result -> dist (pure result <$ c) k) + handleState c dist Pop k = Request Pop (\result -> dist (pure result <$ c) k) + handleState c dist GetEnv k = Request GetEnv (\result -> dist (pure result <$ c) k) + handleState c dist (PutEnv e) k = Request (PutEnv e) (\result -> dist (pure result <$ c) k) + handleState c dist (Export name alias addr) k = Request (Export name alias addr) (\result -> dist (pure result <$ c) k) runEnv :: Effects effects => Environment address diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 64e26112c..d7a894ffd 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -175,10 +175,10 @@ runAllocator = interpret $ \ eff -> case eff of GC roots -> modifyHeap (heapRestrict <*> reachable roots) instance Effect (Allocator address value) where - handleState c dist (Request (Alloc name) k) = Request (Alloc name) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (Deref addr) k) = Request (Deref addr) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (Assign addr value) k) = Request (Assign addr value) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (GC roots) k) = Request (GC roots) (\result -> dist (pure result <$ c) k) + handleState c dist (Alloc name) k = Request (Alloc name) (\result -> dist (pure result <$ c) k) + handleState c dist (Deref addr) k = Request (Deref addr) (\result -> dist (pure result <$ c) k) + handleState c dist (Assign addr value) k = Request (Assign addr value) (\result -> dist (pure result <$ c) k) + handleState c dist (GC roots) k = Request (GC roots) (\result -> dist (pure result <$ c) k) data AddressError address value resume where diff --git a/src/Control/Abstract/Modules.hs b/src/Control/Abstract/Modules.hs index 73a07af88..a31d53831 100644 --- a/src/Control/Abstract/Modules.hs +++ b/src/Control/Abstract/Modules.hs @@ -59,10 +59,10 @@ data Modules address (m :: * -> *) return where List :: FilePath -> Modules address m [ModulePath] instance Effect (Modules address) where - handleState c dist (Request (Load path) k) = Request (Load path) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (Lookup path) k) = Request (Lookup path) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (Resolve paths) k) = Request (Resolve paths) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (List path) k) = Request (List path) (\result -> dist (pure result <$ c) k) + handleState c dist (Load path) k = Request (Load path) (\result -> dist (pure result <$ c) k) + handleState c dist (Lookup path) k = Request (Lookup path) (\result -> dist (pure result <$ c) k) + handleState c dist (Resolve paths) k = Request (Resolve paths) (\result -> dist (pure result <$ c) k) + handleState c dist (List path) k = Request (List path) (\result -> dist (pure result <$ c) k) sendModules :: Member (Modules address) effects => Modules address (Eff effects) return -> Evaluator address value effects return sendModules = send diff --git a/src/Semantic/Distribute.hs b/src/Semantic/Distribute.hs index 0b19c8854..bdbc119eb 100644 --- a/src/Semantic/Distribute.hs +++ b/src/Semantic/Distribute.hs @@ -36,7 +36,7 @@ distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs)) newtype Distribute task output = Distribute (task output) instance Effect Distribute where - handleState c dist (Request (Distribute task) k) = Request (Distribute (dist (task <$ c) k)) pure + handleState c dist (Distribute task) k = Request (Distribute (dist (task <$ c) k)) pure -- | Evaluate a 'Distribute' effect concurrently. diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index 00f01465c..e7da761e1 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -221,10 +221,10 @@ data Files (m :: * -> *) out where Write :: Destination -> B.Builder -> Files m () instance Effect Files where - handleState c dist (Request (Read source) k) = Request (Read source) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (ReadProject rootDir dir language excludeDirs) k) = Request (ReadProject rootDir dir language excludeDirs) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (FindFiles dir exts paths) k) = Request (FindFiles dir exts paths) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (Write destination builder) k) = Request (Write destination builder) (\result -> dist (pure result <$ c) k) + handleState c dist (Read source) k = Request (Read source) (\result -> dist (pure result <$ c) k) + handleState c dist (ReadProject rootDir dir language excludeDirs) k = Request (ReadProject rootDir dir language excludeDirs) (\result -> dist (pure result <$ c) k) + handleState c dist (FindFiles dir exts paths) k = Request (FindFiles dir exts paths) (\result -> dist (pure result <$ c) k) + handleState c dist (Write destination builder) k = Request (Write destination builder) (\result -> dist (pure result <$ c) k) -- | Run a 'Files' effect in 'IO'. runFiles :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Effects effs) => Eff (Files ': effs) a -> Eff effs a diff --git a/src/Semantic/Resolution.hs b/src/Semantic/Resolution.hs index 2db36cea6..7252aea7f 100644 --- a/src/Semantic/Resolution.hs +++ b/src/Semantic/Resolution.hs @@ -40,8 +40,8 @@ data Resolution (m :: * -> *) output where NoResolution :: Resolution m (Map FilePath FilePath) instance Effect Resolution where - handleState c dist (Request (NodeJSResolution path key paths) k) = Request (NodeJSResolution path key paths) (\result -> dist (pure result <$ c) k) - handleState c dist (Request NoResolution k) = Request NoResolution (\result -> dist (pure result <$ c) k) + handleState c dist (NodeJSResolution path key paths) k = Request (NodeJSResolution path key paths) (\result -> dist (pure result <$ c) k) + handleState c dist NoResolution k = Request NoResolution (\result -> dist (pure result <$ c) k) runResolution :: (Member Files effs, Effects effs) => Eff (Resolution ': effs) a -> Eff effs a runResolution = interpret $ \ res -> case res of diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 41b8d2345..bef19f7f7 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -168,12 +168,12 @@ data Task (m :: * -> *) output where Serialize :: Format input -> input -> Task m Builder instance Effect Task where - handleState c dist (Request (Parse parser blob) k) = Request (Parse parser blob) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (Analyze run analysis) k) = Request (Analyze run analysis) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (Decorate decorator term) k) = Request (Decorate decorator term) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (Semantic.Task.Diff terms) k) = Request (Semantic.Task.Diff terms) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (Render renderer input) k) = Request (Render renderer input) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (Serialize format input) k) = Request (Serialize format input) (\result -> dist (pure result <$ c) k) + handleState c dist (Parse parser blob) k = Request (Parse parser blob) (\result -> dist (pure result <$ c) k) + handleState c dist (Analyze run analysis) k = Request (Analyze run analysis) (\result -> dist (pure result <$ c) k) + handleState c dist (Decorate decorator term) k = Request (Decorate decorator term) (\result -> dist (pure result <$ c) k) + handleState c dist (Semantic.Task.Diff terms) k = Request (Semantic.Task.Diff terms) (\result -> dist (pure result <$ c) k) + handleState c dist (Render renderer input) k = Request (Render renderer input) (\result -> dist (pure result <$ c) k) + handleState c dist (Serialize format input) k = Request (Serialize format input) (\result -> dist (pure result <$ c) k) -- | Run a 'Task' effect by performing the actions in 'IO'. runTaskF :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Telemetry effs, Member Trace effs, Effects effs) => Eff (Task ': effs) a -> Eff effs a diff --git a/src/Semantic/Telemetry.hs b/src/Semantic/Telemetry.hs index 5ff47466c..506e6f4a4 100644 --- a/src/Semantic/Telemetry.hs +++ b/src/Semantic/Telemetry.hs @@ -134,8 +134,8 @@ data Telemetry (m :: * -> *) output where WriteLog :: Level -> String -> [(String, String)] -> Telemetry m () instance Effect Telemetry where - handleState c dist (Request (WriteStat stat) k) = Request (WriteStat stat) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (WriteLog level message pairs) k) = Request (WriteLog level message pairs) (\result -> dist (pure result <$ c) k) + handleState c dist (WriteStat stat) k = Request (WriteStat stat) (\result -> dist (pure result <$ c) k) + handleState c dist (WriteLog level message pairs) k = Request (WriteLog level message pairs) (\result -> dist (pure result <$ c) k) -- | Run a 'Telemetry' effect by expecting a 'Reader' of 'Queue's to write stats and logs to. runTelemetry :: (Member (Lift IO) effects, Effects effects) => LogQueue -> StatQueue -> Eff (Telemetry ': effects) a -> Eff effects a diff --git a/vendor/effects b/vendor/effects index 181614aef..307e5267d 160000 --- a/vendor/effects +++ b/vendor/effects @@ -1 +1 @@ -Subproject commit 181614aeff3aa48d82310bcf0fdf5700d5a4481e +Subproject commit 307e5267df3956eb9f6bd2b1190ccbfa0f720994 From e1cb98c1780ff9074a2f8aafc1c42de120ebd16a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 12 Jul 2018 13:53:12 -0400 Subject: [PATCH 25/46] Bump. --- vendor/effects | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/effects b/vendor/effects index 307e5267d..0c152ec69 160000 --- a/vendor/effects +++ b/vendor/effects @@ -1 +1 @@ -Subproject commit 307e5267df3956eb9f6bd2b1190ccbfa0f720994 +Subproject commit 0c152ec69087e17190cad9b54e87ed66657043f5 From 57949b03e09748c927aa16ebf85a45805ff9e9cc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 12 Jul 2018 13:53:29 -0400 Subject: [PATCH 26/46] Fix a redundant import warning. --- src/Semantic/Graph.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 6a59fe98b..b22f46e09 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -29,7 +29,6 @@ import Data.Abstract.Evaluatable import Data.Abstract.Module import qualified Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Package as Package -import Data.Abstract.Value.Type import Data.Abstract.Value.Concrete (Value, ValueError (..), runValueErrorWith) import Data.Graph import Data.Project From dd772765fdf015af3d8c29b60901fac3bf04d183 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Thu, 12 Jul 2018 16:54:28 -0700 Subject: [PATCH 27/46] Refactor TypeScript DefaultExport eval instance slightly --- src/Language/TypeScript/Syntax.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index f515fe218..a94067956 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -270,11 +270,10 @@ instance Show1 DefaultExport where liftShowsPrec = genericLiftShowsPrec instance Evaluatable DefaultExport where eval (DefaultExport term) = do - v <- subtermValue term case declaredName term of Just name -> do addr <- lookupOrAlloc name - assign addr v + subtermValue term >>= assign addr export name name Nothing bind name addr Nothing -> throwEvalError DefaultExportError From bb8506b7bf6f6fe069a60046f2af538da31931d8 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Thu, 12 Jul 2018 16:55:07 -0700 Subject: [PATCH 28/46] Adding a Declarations constraint on Declarations1 for use with subterms --- src/Data/Abstract/Declarations.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Declarations.hs b/src/Data/Abstract/Declarations.hs index a15c74f04..d9e2a3573 100644 --- a/src/Data/Abstract/Declarations.hs +++ b/src/Data/Abstract/Declarations.hs @@ -13,7 +13,7 @@ class Declarations syntax where class Declarations1 syntax where -- | Lift a function mapping each element to its set of free variables through a containing structure, collecting the results into a single set. - liftDeclaredName :: (a -> [Name]) -> syntax a -> Maybe Name + liftDeclaredName :: Declarations a => (a -> [Name]) -> syntax a -> Maybe Name liftDeclaredName _ _ = Nothing instance Declarations t => Declarations (Subterm t a) where @@ -21,7 +21,7 @@ instance Declarations t => Declarations (Subterm t a) where deriving instance (Declarations1 syntax, FreeVariables1 syntax) => Declarations (Term syntax ann) -instance (FreeVariables recur, Declarations1 syntax) => Declarations (TermF syntax ann recur) where +instance (Declarations recur, FreeVariables recur, Declarations1 syntax) => Declarations (TermF syntax ann recur) where declaredName = liftDeclaredName freeVariables . termFOut instance (Apply Declarations1 fs) => Declarations1 (Sum fs) where From 57962113bba6e444ac0270f27060dc6201e4dafe Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Thu, 12 Jul 2018 16:55:42 -0700 Subject: [PATCH 29/46] Retrieve the declaredName for a Function declaration --- src/Data/Syntax/Declaration.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 148127c94..bf10221dd 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -10,7 +10,7 @@ import Prologue import Proto3.Suite.Class data Function a = Function { functionContext :: ![a], functionName :: !a, functionParameters :: ![a], functionBody :: !a } - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Mergeable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Mergeable, FreeVariables1, ToJSONFields1, Named1, Message1) instance Diffable Function where equivalentBySubterm = Just . functionName @@ -33,6 +33,8 @@ instance Evaluatable Function where instance Declarations a => Declarations (Function a) where declaredName Function{..} = declaredName functionName +instance Declarations1 Function where + liftDeclaredName _ = declaredName data Method a = Method { methodContext :: ![a], methodReceiver :: !a, methodName :: !a, methodParameters :: ![a], methodBody :: !a } deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Mergeable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1) From 8da0e3910c6cd21d22cc962c5e16394bd1dcaaa2 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Thu, 12 Jul 2018 16:56:27 -0700 Subject: [PATCH 30/46] Add javascript specific export test files --- test/fixtures/javascript/analysis/exports/lib.js | 6 ++++++ test/fixtures/javascript/analysis/exports/main.js | 3 +++ 2 files changed, 9 insertions(+) create mode 100644 test/fixtures/javascript/analysis/exports/lib.js create mode 100644 test/fixtures/javascript/analysis/exports/main.js diff --git a/test/fixtures/javascript/analysis/exports/lib.js b/test/fixtures/javascript/analysis/exports/lib.js new file mode 100644 index 000000000..ba64ec931 --- /dev/null +++ b/test/fixtures/javascript/analysis/exports/lib.js @@ -0,0 +1,6 @@ +export function square(x) { + return x * x; +} +export function area(x, y) { + return x * y; +} diff --git a/test/fixtures/javascript/analysis/exports/main.js b/test/fixtures/javascript/analysis/exports/main.js new file mode 100644 index 000000000..5ce529dbb --- /dev/null +++ b/test/fixtures/javascript/analysis/exports/main.js @@ -0,0 +1,3 @@ +import { square, area } from 'lib'; +console.log(square(11)); // 121 +console.log(area(4, 3)); // 12 From 0107d38a8f4bf829a3f6d3aa567c5d06f5766225 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 13 Jul 2018 08:53:44 -0400 Subject: [PATCH 31/46] Revert "Bump." This reverts commit dd9ea0edb668ba87c93a8c8ea12ffe721d14d6ed. --- vendor/effects | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/effects b/vendor/effects index 0c152ec69..307e5267d 160000 --- a/vendor/effects +++ b/vendor/effects @@ -1 +1 @@ -Subproject commit 0c152ec69087e17190cad9b54e87ed66657043f5 +Subproject commit 307e5267df3956eb9f6bd2b1190ccbfa0f720994 From 243080f2fd3f6a6b59036575383f816842633d60 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 13 Jul 2018 08:53:52 -0400 Subject: [PATCH 32/46] Revert "Bump effects." This reverts commit 7ca00be818896e6353b987965f49405322a9dfed. --- src/Control/Abstract/Environment.hs | 16 ++++++++-------- src/Control/Abstract/Heap.hs | 8 ++++---- src/Control/Abstract/Modules.hs | 8 ++++---- src/Semantic/Distribute.hs | 2 +- src/Semantic/IO.hs | 8 ++++---- src/Semantic/Resolution.hs | 4 ++-- src/Semantic/Task.hs | 12 ++++++------ src/Semantic/Telemetry.hs | 4 ++-- vendor/effects | 2 +- 9 files changed, 32 insertions(+), 32 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 5b78054a2..4b1e73710 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -75,14 +75,14 @@ data Env address (m :: * -> *) return where Export :: Name -> Name -> Maybe address -> Env address m () instance Effect (Env address) where - handleState c dist (Lookup name) k = Request (Lookup name) (\result -> dist (pure result <$ c) k) - handleState c dist (Bind name addr) k = Request (Bind name addr) (\result -> dist (pure result <$ c) k) - handleState c dist (Close names) k = Request (Close names) (\result -> dist (pure result <$ c) k) - handleState c dist Push k = Request Push (\result -> dist (pure result <$ c) k) - handleState c dist Pop k = Request Pop (\result -> dist (pure result <$ c) k) - handleState c dist GetEnv k = Request GetEnv (\result -> dist (pure result <$ c) k) - handleState c dist (PutEnv e) k = Request (PutEnv e) (\result -> dist (pure result <$ c) k) - handleState c dist (Export name alias addr) k = Request (Export name alias addr) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Lookup name) k) = Request (Lookup name) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Bind name addr) k) = Request (Bind name addr) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Close names) k) = Request (Close names) (\result -> dist (pure result <$ c) k) + handleState c dist (Request Push k) = Request Push (\result -> dist (pure result <$ c) k) + handleState c dist (Request Pop k) = Request Pop (\result -> dist (pure result <$ c) k) + handleState c dist (Request GetEnv k) = Request GetEnv (\result -> dist (pure result <$ c) k) + handleState c dist (Request (PutEnv e) k) = Request (PutEnv e) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Export name alias addr) k) = Request (Export name alias addr) (\result -> dist (pure result <$ c) k) runEnv :: Effects effects => Environment address diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index d7a894ffd..64e26112c 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -175,10 +175,10 @@ runAllocator = interpret $ \ eff -> case eff of GC roots -> modifyHeap (heapRestrict <*> reachable roots) instance Effect (Allocator address value) where - handleState c dist (Alloc name) k = Request (Alloc name) (\result -> dist (pure result <$ c) k) - handleState c dist (Deref addr) k = Request (Deref addr) (\result -> dist (pure result <$ c) k) - handleState c dist (Assign addr value) k = Request (Assign addr value) (\result -> dist (pure result <$ c) k) - handleState c dist (GC roots) k = Request (GC roots) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Alloc name) k) = Request (Alloc name) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Deref addr) k) = Request (Deref addr) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Assign addr value) k) = Request (Assign addr value) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (GC roots) k) = Request (GC roots) (\result -> dist (pure result <$ c) k) data AddressError address value resume where diff --git a/src/Control/Abstract/Modules.hs b/src/Control/Abstract/Modules.hs index a31d53831..73a07af88 100644 --- a/src/Control/Abstract/Modules.hs +++ b/src/Control/Abstract/Modules.hs @@ -59,10 +59,10 @@ data Modules address (m :: * -> *) return where List :: FilePath -> Modules address m [ModulePath] instance Effect (Modules address) where - handleState c dist (Load path) k = Request (Load path) (\result -> dist (pure result <$ c) k) - handleState c dist (Lookup path) k = Request (Lookup path) (\result -> dist (pure result <$ c) k) - handleState c dist (Resolve paths) k = Request (Resolve paths) (\result -> dist (pure result <$ c) k) - handleState c dist (List path) k = Request (List path) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Load path) k) = Request (Load path) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Lookup path) k) = Request (Lookup path) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Resolve paths) k) = Request (Resolve paths) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (List path) k) = Request (List path) (\result -> dist (pure result <$ c) k) sendModules :: Member (Modules address) effects => Modules address (Eff effects) return -> Evaluator address value effects return sendModules = send diff --git a/src/Semantic/Distribute.hs b/src/Semantic/Distribute.hs index bdbc119eb..0b19c8854 100644 --- a/src/Semantic/Distribute.hs +++ b/src/Semantic/Distribute.hs @@ -36,7 +36,7 @@ distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs)) newtype Distribute task output = Distribute (task output) instance Effect Distribute where - handleState c dist (Distribute task) k = Request (Distribute (dist (task <$ c) k)) pure + handleState c dist (Request (Distribute task) k) = Request (Distribute (dist (task <$ c) k)) pure -- | Evaluate a 'Distribute' effect concurrently. diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index e7da761e1..00f01465c 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -221,10 +221,10 @@ data Files (m :: * -> *) out where Write :: Destination -> B.Builder -> Files m () instance Effect Files where - handleState c dist (Read source) k = Request (Read source) (\result -> dist (pure result <$ c) k) - handleState c dist (ReadProject rootDir dir language excludeDirs) k = Request (ReadProject rootDir dir language excludeDirs) (\result -> dist (pure result <$ c) k) - handleState c dist (FindFiles dir exts paths) k = Request (FindFiles dir exts paths) (\result -> dist (pure result <$ c) k) - handleState c dist (Write destination builder) k = Request (Write destination builder) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Read source) k) = Request (Read source) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (ReadProject rootDir dir language excludeDirs) k) = Request (ReadProject rootDir dir language excludeDirs) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (FindFiles dir exts paths) k) = Request (FindFiles dir exts paths) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Write destination builder) k) = Request (Write destination builder) (\result -> dist (pure result <$ c) k) -- | Run a 'Files' effect in 'IO'. runFiles :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Effects effs) => Eff (Files ': effs) a -> Eff effs a diff --git a/src/Semantic/Resolution.hs b/src/Semantic/Resolution.hs index 7252aea7f..2db36cea6 100644 --- a/src/Semantic/Resolution.hs +++ b/src/Semantic/Resolution.hs @@ -40,8 +40,8 @@ data Resolution (m :: * -> *) output where NoResolution :: Resolution m (Map FilePath FilePath) instance Effect Resolution where - handleState c dist (NodeJSResolution path key paths) k = Request (NodeJSResolution path key paths) (\result -> dist (pure result <$ c) k) - handleState c dist NoResolution k = Request NoResolution (\result -> dist (pure result <$ c) k) + handleState c dist (Request (NodeJSResolution path key paths) k) = Request (NodeJSResolution path key paths) (\result -> dist (pure result <$ c) k) + handleState c dist (Request NoResolution k) = Request NoResolution (\result -> dist (pure result <$ c) k) runResolution :: (Member Files effs, Effects effs) => Eff (Resolution ': effs) a -> Eff effs a runResolution = interpret $ \ res -> case res of diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index bef19f7f7..41b8d2345 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -168,12 +168,12 @@ data Task (m :: * -> *) output where Serialize :: Format input -> input -> Task m Builder instance Effect Task where - handleState c dist (Parse parser blob) k = Request (Parse parser blob) (\result -> dist (pure result <$ c) k) - handleState c dist (Analyze run analysis) k = Request (Analyze run analysis) (\result -> dist (pure result <$ c) k) - handleState c dist (Decorate decorator term) k = Request (Decorate decorator term) (\result -> dist (pure result <$ c) k) - handleState c dist (Semantic.Task.Diff terms) k = Request (Semantic.Task.Diff terms) (\result -> dist (pure result <$ c) k) - handleState c dist (Render renderer input) k = Request (Render renderer input) (\result -> dist (pure result <$ c) k) - handleState c dist (Serialize format input) k = Request (Serialize format input) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Parse parser blob) k) = Request (Parse parser blob) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Analyze run analysis) k) = Request (Analyze run analysis) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Decorate decorator term) k) = Request (Decorate decorator term) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Semantic.Task.Diff terms) k) = Request (Semantic.Task.Diff terms) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Render renderer input) k) = Request (Render renderer input) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Serialize format input) k) = Request (Serialize format input) (\result -> dist (pure result <$ c) k) -- | Run a 'Task' effect by performing the actions in 'IO'. runTaskF :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Telemetry effs, Member Trace effs, Effects effs) => Eff (Task ': effs) a -> Eff effs a diff --git a/src/Semantic/Telemetry.hs b/src/Semantic/Telemetry.hs index 506e6f4a4..5ff47466c 100644 --- a/src/Semantic/Telemetry.hs +++ b/src/Semantic/Telemetry.hs @@ -134,8 +134,8 @@ data Telemetry (m :: * -> *) output where WriteLog :: Level -> String -> [(String, String)] -> Telemetry m () instance Effect Telemetry where - handleState c dist (WriteStat stat) k = Request (WriteStat stat) (\result -> dist (pure result <$ c) k) - handleState c dist (WriteLog level message pairs) k = Request (WriteLog level message pairs) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (WriteStat stat) k) = Request (WriteStat stat) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (WriteLog level message pairs) k) = Request (WriteLog level message pairs) (\result -> dist (pure result <$ c) k) -- | Run a 'Telemetry' effect by expecting a 'Reader' of 'Queue's to write stats and logs to. runTelemetry :: (Member (Lift IO) effects, Effects effects) => LogQueue -> StatQueue -> Eff (Telemetry ': effects) a -> Eff effects a diff --git a/vendor/effects b/vendor/effects index 307e5267d..181614aef 160000 --- a/vendor/effects +++ b/vendor/effects @@ -1 +1 @@ -Subproject commit 307e5267df3956eb9f6bd2b1190ccbfa0f720994 +Subproject commit 181614aeff3aa48d82310bcf0fdf5700d5a4481e From f2b683db59a9a7d2cdd1978f65c47c021ff5d91c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 13 Jul 2018 08:53:58 -0400 Subject: [PATCH 33/46] Revert "Define locally via bracketing Push/Pop constructors." This reverts commit 25c242672e8f8e20b650bfea2367ed04b7e7a8dd. --- src/Control/Abstract/Environment.hs | 23 ++++++++++------------- 1 file changed, 10 insertions(+), 13 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 4b1e73710..4f896168d 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, KindSignatures, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators #-} +{-# LANGUAGE GADTs, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators #-} module Control.Abstract.Environment ( Environment , Exports @@ -53,10 +53,7 @@ bindAll = foldr ((>>) . uncurry bind) (pure ()) . Env.flatPairs -- | Run an action in a new local scope. locally :: forall address value effects a . Member (Env address) effects => Evaluator address value effects a -> Evaluator address value effects a -locally a = do - send (Push @address) - a' <- a - a' <$ send (Pop @address) +locally = send . Locally @address . lowerEff close :: Member (Env address) effects => Set Name -> Evaluator address value effects (Environment address) close = send . Close @@ -64,12 +61,11 @@ close = send . Close -- Effects -data Env address (m :: * -> *) return where +data Env address m return where Lookup :: Name -> Env address m (Maybe address) Bind :: Name -> address -> Env address m () Close :: Set Name -> Env address m (Environment address) - Push :: Env address m () - Pop :: Env address m () + Locally :: m a -> Env address m a GetEnv :: Env address m (Environment address) PutEnv :: Environment address -> Env address m () Export :: Name -> Name -> Maybe address -> Env address m () @@ -78,8 +74,7 @@ instance Effect (Env address) where handleState c dist (Request (Lookup name) k) = Request (Lookup name) (\result -> dist (pure result <$ c) k) handleState c dist (Request (Bind name addr) k) = Request (Bind name addr) (\result -> dist (pure result <$ c) k) handleState c dist (Request (Close names) k) = Request (Close names) (\result -> dist (pure result <$ c) k) - handleState c dist (Request Push k) = Request Push (\result -> dist (pure result <$ c) k) - handleState c dist (Request Pop k) = Request Pop (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Locally action) k) = Request (Locally (dist (action <$ c) k)) pure handleState c dist (Request GetEnv k) = Request GetEnv (\result -> dist (pure result <$ c) k) handleState c dist (Request (PutEnv e) k) = Request (PutEnv e) (\result -> dist (pure result <$ c) k) handleState c dist (Request (Export name alias addr) k) = Request (Export name alias addr) (\result -> dist (pure result <$ c) k) @@ -96,13 +91,15 @@ runEnv initial = fmap (filterEnv . fmap (first Env.head)) . runState lowerBound | Exports.null ports = (Env.newEnv binds, a) | otherwise = (Env.newEnv (Exports.toBindings ports <> Env.aliasBindings (Exports.aliases ports) binds), a) -handleEnv :: forall address value effects a . Env address (Eff (Env address ': effects)) a -> Evaluator address value (State (Environment address) ': State (Exports address) ': effects) a +handleEnv :: forall address value effects a . Effects effects => Env address (Eff (Env address ': effects)) a -> Evaluator address value (State (Environment address) ': State (Exports address) ': effects) a handleEnv = \case Lookup name -> Env.lookup name <$> get Bind name addr -> modify (Env.insert name addr) Close names -> Env.intersect names <$> get - Push -> modify' (Env.push @address) - Pop -> modify' (Env.pop @address) + Locally action -> do + modify' (Env.push @address) + a <- reinterpret2 handleEnv (raiseEff action) + a <$ modify' (Env.pop @address) GetEnv -> get PutEnv e -> put e Export name alias addr -> modify (Exports.insert name alias addr) From f31657f7b9426eb985f674bff759613975765f62 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 13 Jul 2018 08:54:21 -0400 Subject: [PATCH 34/46] Revert "++effects" This reverts commit 41ac951037a2e75c2fd4d5fce7a38ecb8fe1976e. --- vendor/effects | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/effects b/vendor/effects index 181614aef..105a543cc 160000 --- a/vendor/effects +++ b/vendor/effects @@ -1 +1 @@ -Subproject commit 181614aeff3aa48d82310bcf0fdf5700d5a4481e +Subproject commit 105a543ccc98f2929cf0b1f1e97bcc48dfb8f718 From 4a2d83a4017039dbd3d634260e62efb691286918 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 13 Jul 2018 08:54:37 -0400 Subject: [PATCH 35/46] Revert "Fix up handleState implementations" This reverts commit 80fd530b38c4859d94c946ee6e0f11aa8f11b8c3. --- src/Control/Abstract/Environment.hs | 14 +++++++------- src/Control/Abstract/Heap.hs | 8 ++++---- src/Control/Abstract/Modules.hs | 8 ++++---- src/Semantic/Distribute.hs | 2 +- src/Semantic/IO.hs | 8 ++++---- src/Semantic/Resolution.hs | 4 ++-- src/Semantic/Task.hs | 12 ++++++------ src/Semantic/Telemetry.hs | 4 ++-- 8 files changed, 30 insertions(+), 30 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 4f896168d..5ffcb4be3 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -71,13 +71,13 @@ data Env address m return where Export :: Name -> Name -> Maybe address -> Env address m () instance Effect (Env address) where - handleState c dist (Request (Lookup name) k) = Request (Lookup name) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (Bind name addr) k) = Request (Bind name addr) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (Close names) k) = Request (Close names) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (Locally action) k) = Request (Locally (dist (action <$ c) k)) pure - handleState c dist (Request GetEnv k) = Request GetEnv (\result -> dist (pure result <$ c) k) - handleState c dist (Request (PutEnv e) k) = Request (PutEnv e) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (Export name alias addr) k) = Request (Export name alias addr) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Lookup name) k) = Request (Lookup name) (dist . (<$ c) . k) + handleState c dist (Request (Bind name addr) k) = Request (Bind name addr) (dist . (<$ c) . k) + handleState c dist (Request (Close names) k) = Request (Close names) (dist . (<$ c) . k) + handleState c dist (Request (Locally action) k) = Request (Locally (dist (action <$ c))) (dist . fmap k) + handleState c dist (Request GetEnv k) = Request GetEnv (dist . (<$ c) . k) + handleState c dist (Request (PutEnv e) k) = Request (PutEnv e) (dist . (<$ c) . k) + handleState c dist (Request (Export name alias addr) k) = Request (Export name alias addr) (dist . (<$ c) . k) runEnv :: Effects effects => Environment address diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 64e26112c..16cfcab93 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -175,10 +175,10 @@ runAllocator = interpret $ \ eff -> case eff of GC roots -> modifyHeap (heapRestrict <*> reachable roots) instance Effect (Allocator address value) where - handleState c dist (Request (Alloc name) k) = Request (Alloc name) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (Deref addr) k) = Request (Deref addr) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (Assign addr value) k) = Request (Assign addr value) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (GC roots) k) = Request (GC roots) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Alloc name) k) = Request (Alloc name) (dist . (<$ c) . k) + handleState c dist (Request (Deref addr) k) = Request (Deref addr) (dist . (<$ c) . k) + handleState c dist (Request (Assign addr value) k) = Request (Assign addr value) (dist . (<$ c) . k) + handleState c dist (Request (GC roots) k) = Request (GC roots) (dist . (<$ c) . k) data AddressError address value resume where diff --git a/src/Control/Abstract/Modules.hs b/src/Control/Abstract/Modules.hs index 73a07af88..7a31dbd3f 100644 --- a/src/Control/Abstract/Modules.hs +++ b/src/Control/Abstract/Modules.hs @@ -59,10 +59,10 @@ data Modules address (m :: * -> *) return where List :: FilePath -> Modules address m [ModulePath] instance Effect (Modules address) where - handleState c dist (Request (Load path) k) = Request (Load path) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (Lookup path) k) = Request (Lookup path) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (Resolve paths) k) = Request (Resolve paths) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (List path) k) = Request (List path) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Load path) k) = Request (Load path) (dist . (<$ c) . k) + handleState c dist (Request (Lookup path) k) = Request (Lookup path) (dist . (<$ c) . k) + handleState c dist (Request (Resolve paths) k) = Request (Resolve paths) (dist . (<$ c) . k) + handleState c dist (Request (List path) k) = Request (List path) (dist . (<$ c) . k) sendModules :: Member (Modules address) effects => Modules address (Eff effects) return -> Evaluator address value effects return sendModules = send diff --git a/src/Semantic/Distribute.hs b/src/Semantic/Distribute.hs index 0b19c8854..69b162606 100644 --- a/src/Semantic/Distribute.hs +++ b/src/Semantic/Distribute.hs @@ -36,7 +36,7 @@ distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs)) newtype Distribute task output = Distribute (task output) instance Effect Distribute where - handleState c dist (Request (Distribute task) k) = Request (Distribute (dist (task <$ c) k)) pure + handleState c dist (Request (Distribute task) k) = Request (Distribute (dist (task <$ c))) (dist . fmap k) -- | Evaluate a 'Distribute' effect concurrently. diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index 00f01465c..445f294de 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -221,10 +221,10 @@ data Files (m :: * -> *) out where Write :: Destination -> B.Builder -> Files m () instance Effect Files where - handleState c dist (Request (Read source) k) = Request (Read source) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (ReadProject rootDir dir language excludeDirs) k) = Request (ReadProject rootDir dir language excludeDirs) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (FindFiles dir exts paths) k) = Request (FindFiles dir exts paths) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (Write destination builder) k) = Request (Write destination builder) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Read source) k) = Request (Read source) (dist . (<$ c) . k) + handleState c dist (Request (ReadProject rootDir dir language excludeDirs) k) = Request (ReadProject rootDir dir language excludeDirs) (dist . (<$ c) . k) + handleState c dist (Request (FindFiles dir exts paths) k) = Request (FindFiles dir exts paths) (dist . (<$ c) . k) + handleState c dist (Request (Write destination builder) k) = Request (Write destination builder) (dist . (<$ c) . k) -- | Run a 'Files' effect in 'IO'. runFiles :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Effects effs) => Eff (Files ': effs) a -> Eff effs a diff --git a/src/Semantic/Resolution.hs b/src/Semantic/Resolution.hs index 2db36cea6..62ed86246 100644 --- a/src/Semantic/Resolution.hs +++ b/src/Semantic/Resolution.hs @@ -40,8 +40,8 @@ data Resolution (m :: * -> *) output where NoResolution :: Resolution m (Map FilePath FilePath) instance Effect Resolution where - handleState c dist (Request (NodeJSResolution path key paths) k) = Request (NodeJSResolution path key paths) (\result -> dist (pure result <$ c) k) - handleState c dist (Request NoResolution k) = Request NoResolution (\result -> dist (pure result <$ c) k) + handleState c dist (Request (NodeJSResolution path key paths) k) = Request (NodeJSResolution path key paths) (dist . (<$ c) . k) + handleState c dist (Request NoResolution k) = Request NoResolution (dist . (<$ c) . k) runResolution :: (Member Files effs, Effects effs) => Eff (Resolution ': effs) a -> Eff effs a runResolution = interpret $ \ res -> case res of diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 41b8d2345..83d07483c 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -168,12 +168,12 @@ data Task (m :: * -> *) output where Serialize :: Format input -> input -> Task m Builder instance Effect Task where - handleState c dist (Request (Parse parser blob) k) = Request (Parse parser blob) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (Analyze run analysis) k) = Request (Analyze run analysis) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (Decorate decorator term) k) = Request (Decorate decorator term) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (Semantic.Task.Diff terms) k) = Request (Semantic.Task.Diff terms) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (Render renderer input) k) = Request (Render renderer input) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (Serialize format input) k) = Request (Serialize format input) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (Parse parser blob) k) = Request (Parse parser blob) (dist . (<$ c) . k) + handleState c dist (Request (Analyze run analysis) k) = Request (Analyze run analysis) (dist . (<$ c) . k) + handleState c dist (Request (Decorate decorator term) k) = Request (Decorate decorator term) (dist . (<$ c) . k) + handleState c dist (Request (Semantic.Task.Diff terms) k) = Request (Semantic.Task.Diff terms) (dist . (<$ c) . k) + handleState c dist (Request (Render renderer input) k) = Request (Render renderer input) (dist . (<$ c) . k) + handleState c dist (Request (Serialize format input) k) = Request (Serialize format input) (dist . (<$ c) . k) -- | Run a 'Task' effect by performing the actions in 'IO'. runTaskF :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Telemetry effs, Member Trace effs, Effects effs) => Eff (Task ': effs) a -> Eff effs a diff --git a/src/Semantic/Telemetry.hs b/src/Semantic/Telemetry.hs index 5ff47466c..e42152619 100644 --- a/src/Semantic/Telemetry.hs +++ b/src/Semantic/Telemetry.hs @@ -134,8 +134,8 @@ data Telemetry (m :: * -> *) output where WriteLog :: Level -> String -> [(String, String)] -> Telemetry m () instance Effect Telemetry where - handleState c dist (Request (WriteStat stat) k) = Request (WriteStat stat) (\result -> dist (pure result <$ c) k) - handleState c dist (Request (WriteLog level message pairs) k) = Request (WriteLog level message pairs) (\result -> dist (pure result <$ c) k) + handleState c dist (Request (WriteStat stat) k) = Request (WriteStat stat) (dist . (<$ c) . k) + handleState c dist (Request (WriteLog level message pairs) k) = Request (WriteLog level message pairs) (dist . (<$ c) . k) -- | Run a 'Telemetry' effect by expecting a 'Reader' of 'Queue's to write stats and logs to. runTelemetry :: (Member (Lift IO) effects, Effects effects) => LogQueue -> StatQueue -> Eff (Telemetry ': effects) a -> Eff effects a From 992cb0a4040b8e14c417e88313c92303658c0a39 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 13 Jul 2018 08:54:59 -0400 Subject: [PATCH 36/46] Bump effects. --- vendor/effects | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/effects b/vendor/effects index 105a543cc..59433624f 160000 --- a/vendor/effects +++ b/vendor/effects @@ -1 +1 @@ -Subproject commit 105a543ccc98f2929cf0b1f1e97bcc48dfb8f718 +Subproject commit 59433624fdbb8961596037c6345b9f383d054c92 From 7eec6d7d88950df85ffc4480f2f30e7c650fca01 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 13 Jul 2018 09:22:56 -0400 Subject: [PATCH 37/46] =?UTF-8?q?We=20don=E2=80=99t=20actually=20need=20`T?= =?UTF-8?q?race`=20here.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- test/Control/Abstract/Evaluator/Spec.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/test/Control/Abstract/Evaluator/Spec.hs b/test/Control/Abstract/Evaluator/Spec.hs index 75b80402b..72f9ea1d4 100644 --- a/test/Control/Abstract/Evaluator/Spec.hs +++ b/test/Control/Abstract/Evaluator/Spec.hs @@ -37,7 +37,6 @@ evaluate . runValueError . runEnvironmentError . runAddressError - . runIgnoringTrace . runAllocator @Precise @_ @Val . (>>= deref . snd) . runEnv lowerBound @@ -53,7 +52,6 @@ newtype SpecEff a = SpecEff , Exc (Return Precise) , Env Precise , Allocator Precise Val - , Trace , Resumable (AddressError Precise Val) , Resumable (EnvironmentError Precise) , Resumable (ValueError Precise SpecEff) From c622ba6cbf0696ad204c8c8f5a88d13a4d47dca4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 13 Jul 2018 11:02:39 -0400 Subject: [PATCH 38/46] Bump effects to `master`. --- vendor/effects | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/effects b/vendor/effects index 59433624f..0b6d04713 160000 --- a/vendor/effects +++ b/vendor/effects @@ -1 +1 @@ -Subproject commit 59433624fdbb8961596037c6345b9f383d054c92 +Subproject commit 0b6d04713b70e6b0551b841304fb44c9b1564e9b From 25cc3317899e2fe2ba9837b7da62811d970d9c72 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 13 Jul 2018 11:21:54 -0400 Subject: [PATCH 39/46] merge fallout --- src/Control/Abstract/Environment.hs | 2 -- src/Data/Abstract/Evaluatable.hs | 13 ++++++------- src/Data/Abstract/Value/Abstract.hs | 1 - src/Semantic/Graph.hs | 1 + 4 files changed, 7 insertions(+), 10 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index b169daeda..2c8225426 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -69,7 +69,6 @@ data Env address m return where GetEnv :: Env address m (Environment address) PutEnv :: Environment address -> Env address m () Export :: Name -> Name -> Maybe address -> Env address m () - PutEnv :: Environment address -> Env address m () instance Effect (Env address) where handleState c dist (Request (Lookup name) k) = Request (Lookup name) (dist . (<$ c) . k) @@ -79,7 +78,6 @@ instance Effect (Env address) where handleState c dist (Request GetEnv k) = Request GetEnv (dist . (<$ c) . k) handleState c dist (Request (PutEnv e) k) = Request (PutEnv e) (dist . (<$ c) . k) handleState c dist (Request (Export name alias addr) k) = Request (Export name alias addr) (dist . (<$ c) . k) - handleState c dist (Request (PutEnv e) k) = Request (PutEnv e) (dist . (<$ c) . k) runEnv :: Effects effects => Environment address diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 17e1b3231..d1c8ff330 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -52,7 +52,6 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where , Member (Env address) effects , Member (Exc (LoopControl address)) effects , Member (Exc (Return address)) effects - , Member Fresh effects , Member (Modules address) effects , Member (Reader ModuleInfo) effects , Member (Reader PackageInfo) effects @@ -155,24 +154,24 @@ instance HasPrelude 'PHP instance HasPrelude 'Python where definePrelude _ = - define "print" builtInPrint + define (name "print") builtInPrint instance HasPrelude 'Ruby where definePrelude _ = do - define "puts" builtInPrint + define (name "puts") builtInPrint defineClass (name "Object") [] $ do define (name "inspect") (lambda (const (box (string "")))) instance HasPrelude 'TypeScript where definePrelude _ = - defineNamespace "console" $ do - define "log" builtInPrint + defineNamespace (name "console") $ do + define (name "log") builtInPrint instance HasPrelude 'JavaScript where definePrelude _ = do - defineNamespace "console" $ do - define "log" builtInPrint + defineNamespace (name "console") $ do + define (name "log") builtInPrint -- Postludes diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index 7c0886ddc..3a4561fc4 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -48,7 +48,6 @@ instance ( Member (Allocator address Abstract) effects instance ( Member (Allocator address Abstract) effects , Member (Env address) effects , Member (Exc (Return address)) effects - , Member Fresh effects , Member NonDet effects , Member Fresh effects ) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index f467cffed..f6b456f78 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -72,6 +72,7 @@ runCallGraph :: ( HasField ann Span , Evaluatable (Base term) , FreeVariables term , HasPrelude lang + , HasPostlude lang , Member Trace effs , Recursive term , Effects effs From acb4ac18c3347e3849279d87243f66be39e47bb8 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 13 Jul 2018 12:06:11 -0400 Subject: [PATCH 40/46] Address Rob's concerns. --- src/Analysis/Abstract/Caching.hs | 1 - src/Control/Abstract/Heap.hs | 3 ++- src/Data/Abstract/Evaluatable.hs | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 8cef1c192..67cb3a23c 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -104,7 +104,6 @@ convergingModules recur m = do -- nondeterministic values into @()@. withOracle prevCache (gatherM (const ()) (recur m))) - -- TODO: We're hitting an infinite loop here, c.f test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call TermEvaluator (address =<< runTermEvaluator (maybe empty scatter (cacheLookup c cache))) -- | Iterate a monadic action starting from some initial seed until the results converge. diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 579990c50..16cfcab93 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -59,7 +59,8 @@ box :: ( Member (Allocator address value) effects => value -> Evaluator address value effects address box val = do - addr <- gensym >>= alloc + name <- gensym + addr <- alloc name assign addr val pure addr diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index d1c8ff330..b235ed56b 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -57,11 +57,11 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where , Member (Reader PackageInfo) effects , Member (Reader Span) effects , Member (Resumable (EnvironmentError address)) effects + , Member (Resumable (Unspecialized value)) effects , Member (Resumable EvalError) effects , Member (Resumable ResolutionError) effects - , Member (Resumable (Unspecialized value)) effects - , Member Trace effects , Member Fresh effects + , Member Trace effects ) => SubtermAlgebra constr term (Evaluator address value effects (ValueRef address)) eval expr = do From 6a65fc0bc03141ad67ee34811006a78477aeb391 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 13 Jul 2018 12:10:17 -0400 Subject: [PATCH 41/46] Fix otiose parts of the diff. --- src/Analysis/Abstract/Caching.hs | 1 - .../graphing/include-file-with-undefined-call/main.rb | 7 ------- .../graphing/include-file-with-undefined-call/target.rb | 3 --- 3 files changed, 11 deletions(-) delete mode 100644 test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call/main.rb delete mode 100644 test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call/target.rb diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 67cb3a23c..481f50a1d 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -103,7 +103,6 @@ convergingModules recur m = do -- would never complete). We don’t need to use the values, so we 'gather' the -- nondeterministic values into @()@. withOracle prevCache (gatherM (const ()) (recur m))) - TermEvaluator (address =<< runTermEvaluator (maybe empty scatter (cacheLookup c cache))) -- | Iterate a monadic action starting from some initial seed until the results converge. diff --git a/test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call/main.rb b/test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call/main.rb deleted file mode 100644 index 92e64d33a..000000000 --- a/test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call/main.rb +++ /dev/null @@ -1,7 +0,0 @@ -require './target' - -def go() - "done" -end - -go() diff --git a/test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call/target.rb b/test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call/target.rb deleted file mode 100644 index 678daf934..000000000 --- a/test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call/target.rb +++ /dev/null @@ -1,3 +0,0 @@ -barf() - -def foo(); end From 435d296b6c5cf60583500d228f12fe2dd63e7a5c Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Fri, 13 Jul 2018 09:31:24 -0700 Subject: [PATCH 42/46] Avoid `>>=` in `do` blocks --- src/Language/TypeScript/Syntax.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index a94067956..3fba9f25f 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -273,7 +273,8 @@ instance Evaluatable DefaultExport where case declaredName term of Just name -> do addr <- lookupOrAlloc name - subtermValue term >>= assign addr + v <- subtermValue term + assign addr v export name name Nothing bind name addr Nothing -> throwEvalError DefaultExportError From b928f7879ade7fdefe4e22e31e747e04f1de5ba1 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Fri, 13 Jul 2018 09:32:34 -0700 Subject: [PATCH 43/46] Use higher order `declaredName` function in `Declarations1` instance --- src/Data/Abstract/Declarations.hs | 4 ++-- src/Data/Syntax/Declaration.hs | 4 +++- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Data/Abstract/Declarations.hs b/src/Data/Abstract/Declarations.hs index d9e2a3573..a15c74f04 100644 --- a/src/Data/Abstract/Declarations.hs +++ b/src/Data/Abstract/Declarations.hs @@ -13,7 +13,7 @@ class Declarations syntax where class Declarations1 syntax where -- | Lift a function mapping each element to its set of free variables through a containing structure, collecting the results into a single set. - liftDeclaredName :: Declarations a => (a -> [Name]) -> syntax a -> Maybe Name + liftDeclaredName :: (a -> [Name]) -> syntax a -> Maybe Name liftDeclaredName _ _ = Nothing instance Declarations t => Declarations (Subterm t a) where @@ -21,7 +21,7 @@ instance Declarations t => Declarations (Subterm t a) where deriving instance (Declarations1 syntax, FreeVariables1 syntax) => Declarations (Term syntax ann) -instance (Declarations recur, FreeVariables recur, Declarations1 syntax) => Declarations (TermF syntax ann recur) where +instance (FreeVariables recur, Declarations1 syntax) => Declarations (TermF syntax ann recur) where declaredName = liftDeclaredName freeVariables . termFOut instance (Apply Declarations1 fs) => Declarations1 (Sum fs) where diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index bf10221dd..bad9e0a35 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -34,7 +34,9 @@ instance Declarations a => Declarations (Function a) where declaredName Function{..} = declaredName functionName instance Declarations1 Function where - liftDeclaredName _ = declaredName + liftDeclaredName declaredName Function{..} = case declaredName functionName of + [] -> Nothing + (x:_) -> Just x data Method a = Method { methodContext :: ![a], methodReceiver :: !a, methodName :: !a, methodParameters :: ![a], methodBody :: !a } deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Mergeable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1) From 6b3d930066ddbbb2fea04811bd7c9d2c652f2e7a Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 13 Jul 2018 12:42:26 -0400 Subject: [PATCH 44/46] Fix lints. --- src/Control/Abstract/Environment.hs | 2 +- src/Data/Abstract/Environment.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 2c8225426..3e237ef9e 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -31,7 +31,7 @@ getEnv :: Member (Env address) effects => Evaluator address value effects (Envir getEnv = send GetEnv -- | Replace the environment. This is only for use in Analysis.Abstract.Caching. -putEnv :: Member (Env address) effects => (Environment address) -> Evaluator address value effects () +putEnv :: Member (Env address) effects => Environment address -> Evaluator address value effects () putEnv = send . PutEnv -- | Add an export to the global export state. diff --git a/src/Data/Abstract/Environment.hs b/src/Data/Abstract/Environment.hs index d6e87da73..7f56e62c9 100644 --- a/src/Data/Abstract/Environment.hs +++ b/src/Data/Abstract/Environment.hs @@ -152,4 +152,4 @@ addresses = fromAddresses . map snd . flatPairs instance Lower (Environment address) where lowerBound = Environment (lowerBound :| []) instance Show address => Show (Environment address) where - showsPrec d = showsUnaryWith showsPrec "Environment" d + showsPrec = showsUnaryWith showsPrec "Environment" From 9674d78075842836fe0682e3047af1278ce5fa68 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Fri, 13 Jul 2018 09:49:43 -0700 Subject: [PATCH 45/46] Adjust indentation --- src/Data/Syntax/Declaration.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index bad9e0a35..94c020d08 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -34,9 +34,10 @@ instance Declarations a => Declarations (Function a) where declaredName Function{..} = declaredName functionName instance Declarations1 Function where - liftDeclaredName declaredName Function{..} = case declaredName functionName of - [] -> Nothing - (x:_) -> Just x + liftDeclaredName declaredName Function{..} = + case declaredName functionName of + [] -> Nothing + (x:_) -> Just x data Method a = Method { methodContext :: ![a], methodReceiver :: !a, methodName :: !a, methodParameters :: ![a], methodBody :: !a } deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Mergeable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1) From 37db866b7ac4cf9c96cf1ecd2c1634bdcaa6440f Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 13 Jul 2018 13:25:21 -0400 Subject: [PATCH 46/46] changing that Show instance caused the doctests to loop infinitely --- src/Data/Abstract/Environment.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Environment.hs b/src/Data/Abstract/Environment.hs index 7f56e62c9..25f3557ab 100644 --- a/src/Data/Abstract/Environment.hs +++ b/src/Data/Abstract/Environment.hs @@ -151,5 +151,8 @@ addresses = fromAddresses . map snd . flatPairs instance Lower (Environment address) where lowerBound = Environment (lowerBound :| []) +-- N.B. this show instance drops some information to avoid generating +-- an infinite string in certain cases. As such, two unequal +-- environments may produce equal outputs over Show. instance Show address => Show (Environment address) where - showsPrec = showsUnaryWith showsPrec "Environment" + showsPrec d = showsUnaryWith showsPrec "Environment" d . flatPairs