diff --git a/HLint.hs b/HLint.hs index f488a4907..e02ff38b5 100644 --- a/HLint.hs +++ b/HLint.hs @@ -17,8 +17,8 @@ error "Avoid return" = return ==> pure where note = "return is obsolete as of GHC 7.10" -error "use extract" = termAnnotation . unTerm ==> extract -error "use unwrap" = termOut . unTerm ==> unwrap +error "use termAnnotation" = termFAnnotation . unTerm ==> termAnnotation +error "use termOut" = termFOut . unTerm ==> termOut error "avoid head" = head where note = "head is partial; consider using Data.Maybe.listToMaybe" @@ -31,3 +31,5 @@ error "avoid init" = init error "avoid last" = last where note = "last is partial; consider pattern-matching" + +error "use maybeM" = maybe a pure ==> maybeM a diff --git a/semantic.cabal b/semantic.cabal index 7e03f3ca2..f4ca077ba 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -40,7 +40,6 @@ library , Control.Abstract.Context , Control.Abstract.Environment , Control.Abstract.Evaluator - , Control.Abstract.Exports , Control.Abstract.Heap , Control.Abstract.Hole , Control.Abstract.Matching diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index be0cc40c6..f9056858a 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -62,7 +62,7 @@ cachingTerms :: ( Cacheable term address (Cell address) value , Member (Reader (Cache term address (Cell address) value)) effects , Member (Reader (Live address)) effects , Member (State (Cache term address (Cell address) value)) effects - , Member (State (Environment address)) effects + , Member (Env address) effects , Member (State (Heap address (Cell address) value)) effects ) => SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef value)) @@ -82,11 +82,10 @@ convergingModules :: ( AbstractValue address value effects , Member Fresh effects , Member NonDet effects , Member (Reader (Cache term address (Cell address) value)) effects - , Member (Reader (Environment address)) effects , Member (Reader (Live address)) effects , Member (Resumable (EnvironmentError address)) effects , Member (State (Cache term address (Cell address) value)) effects - , Member (State (Environment address)) effects + , Member (Env address) effects , Member (State (Heap address (Cell address) value)) effects ) => SubtermAlgebra Module term (TermEvaluator term address value effects value) @@ -94,8 +93,7 @@ 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 $ do - TermEvaluator (putEnv (configurationEnvironment c)) + 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/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 694719380..b6307cf0c 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -5,14 +5,13 @@ module Analysis.Abstract.Evaluating ) where import Control.Abstract +import Control.Monad.Effect.Fail import Data.Semilattice.Lower -- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@. data EvaluatingState address value = EvaluatingState - { environment :: Environment address - , heap :: Heap address (Cell address) value + { heap :: Heap address (Cell address) value , modules :: ModuleTable (Maybe (Environment address, value)) - , exports :: Exports address } deriving instance (Eq (Cell address value), Eq address, Eq value) => Eq (EvaluatingState address value) @@ -23,19 +22,13 @@ deriving instance (Show (Cell address value), Show address, Show value) => Show evaluating :: Evaluator address value ( Fail ': Fresh - ': Reader (Environment address) - ': State (Environment address) ': State (Heap address (Cell address) value) ': State (ModuleTable (Maybe (Environment address, value))) - ': State (Exports address) ': effects) result -> Evaluator address value effects (Either String result, EvaluatingState address value) evaluating - = fmap (\ ((((result, env), heap), modules), exports) -> (result, EvaluatingState env heap modules exports)) - . runState lowerBound -- State (Exports address) + = fmap (\ ((result, heap), modules) -> (result, EvaluatingState heap modules)) . runState lowerBound -- State (ModuleTable (Maybe (Environment address, value))) . runState lowerBound -- State (Heap address (Cell address) value) - . runState lowerBound -- State (Environment address) - . runReader lowerBound -- Reader (Environment address) . runFresh 0 . runFail diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index 970b7cef3..84931de66 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -52,9 +52,8 @@ style = (defaultStyle (byteString . vertexName)) -- | Add vertices to the graph for evaluated identifiers. graphingTerms :: ( Element Syntax.Identifier syntax - , Member (Reader (Environment (Hole (Located address)))) effects , Member (Reader ModuleInfo) effects - , Member (State (Environment (Hole (Located address)))) effects + , Member (Env (Hole (Located address))) effects , Member (State (Graph Vertex)) effects , term ~ Term (Sum syntax) ann ) @@ -121,8 +120,7 @@ moduleInclusion v = do appendGraph (vertex (moduleVertex m) `connect` vertex v) -- | Add an edge from the passed variable name to the module it originated within. -variableDefinition :: ( Member (Reader (Environment (Hole (Located address)))) effects - , Member (State (Environment (Hole (Located address)))) effects +variableDefinition :: ( Member (Env (Hole (Located address))) effects , Member (State (Graph Vertex)) effects ) => Name diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 80b35d067..ee6cc58b6 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -14,7 +14,7 @@ import Prologue -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. tracingTerms :: ( Corecursive term , Member (Reader (Live address)) effects - , Member (State (Environment address)) effects + , Member (Env address) effects , Member (State (Heap address (Cell address) value)) effects , Member (Writer (trace (Configuration term address (Cell address) value))) effects , Reducer (Configuration term address (Cell address) value) (trace (Configuration term address (Cell address) value)) diff --git a/src/Control/Abstract.hs b/src/Control/Abstract.hs index 681a3dd13..6c6ad0cc1 100644 --- a/src/Control/Abstract.hs +++ b/src/Control/Abstract.hs @@ -5,9 +5,8 @@ module Control.Abstract import Control.Abstract.Addressable as X import Control.Abstract.Configuration as X import Control.Abstract.Context as X -import Control.Abstract.Environment as X +import Control.Abstract.Environment as X hiding (Lookup) import Control.Abstract.Evaluator as X -import Control.Abstract.Exports as X import Control.Abstract.Heap as X import Control.Abstract.Hole as X import Control.Abstract.Modules as X diff --git a/src/Control/Abstract/Configuration.hs b/src/Control/Abstract/Configuration.hs index 764168d8e..d89905f02 100644 --- a/src/Control/Abstract/Configuration.hs +++ b/src/Control/Abstract/Configuration.hs @@ -12,5 +12,5 @@ import Control.Abstract.TermEvaluator import Data.Abstract.Configuration -- | Get the current 'Configuration' with a passed-in term. -getConfiguration :: (Member (Reader (Live address)) effects, Member (State (Environment address)) effects, Member (State (Heap address (Cell address) value)) effects) => term -> TermEvaluator term address value effects (Configuration term address (Cell address) value) +getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address) effects, Member (State (Heap address (Cell address) value)) effects) => term -> TermEvaluator term address value effects (Configuration term address (Cell address) value) getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEnv <*> TermEvaluator getHeap diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 5b7c31af8..c91254b53 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -1,14 +1,16 @@ -{-# LANGUAGE GADTs, RankNTypes, TypeOperators #-} +{-# LANGUAGE GADTs, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators #-} module Control.Abstract.Environment ( Environment +, Exports , getEnv -, putEnv -, withEnv -, withDefaultEnvironment +, export , lookupEnv , bind , bindAll , locally +, close +, Env(..) +, runEnv , EnvironmentError(..) , freeVariableError , runEnvironmentError @@ -16,54 +18,78 @@ module Control.Abstract.Environment ) where import Control.Abstract.Evaluator -import Data.Abstract.Environment as Env +import Data.Abstract.Environment (Environment) +import qualified Data.Abstract.Environment as Env +import Data.Abstract.Exports as Exports import Data.Abstract.Name +import Data.Semilattice.Lower import Prologue -- | Retrieve the environment. -getEnv :: Member (State (Environment address)) effects => Evaluator address value effects (Environment address) -getEnv = get +getEnv :: Member (Env address) effects => Evaluator address value effects (Environment address) +getEnv = send GetEnv --- | Set the environment. -putEnv :: Member (State (Environment address)) effects => Environment address -> Evaluator address value effects () -putEnv = put +-- | 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) --- | Update the global environment. -modifyEnv :: Member (State (Environment address)) effects => (Environment address -> Environment address) -> Evaluator address value effects () -modifyEnv = modify' - --- | Sets the environment for the lifetime of the given action. -withEnv :: Member (State (Environment address)) effects => Environment address -> Evaluator address value effects a -> Evaluator address value effects a -withEnv = localState . const - - --- | Retrieve the default environment. -defaultEnvironment :: Member (Reader (Environment address)) effects => Evaluator address value effects (Environment address) -defaultEnvironment = ask - --- | Set the default environment for the lifetime of an action. --- Usually only invoked in a top-level evaluation function. -withDefaultEnvironment :: Member (Reader (Environment address)) effects => Environment address -> Evaluator address value effects a -> Evaluator address value effects a -withDefaultEnvironment e = local (const e) -- | Look a 'Name' up in the current environment, trying the default environment if no value is found. -lookupEnv :: (Member (Reader (Environment address)) effects, Member (State (Environment address)) effects) => Name -> Evaluator address value effects (Maybe address) -lookupEnv name = (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment) +lookupEnv :: Member (Env address) effects => Name -> Evaluator address value effects (Maybe address) +lookupEnv name = send (Lookup name) --- | Bind a 'Name' to an 'Address' in the current scope. -bind :: Member (State (Environment address)) effects => Name -> address -> Evaluator address value effects () -bind name = modifyEnv . Env.insert name +-- | Bind a 'Name' to an address in the current scope. +bind :: Member (Env address) effects => Name -> address -> Evaluator address value effects () +bind name addr = send (Bind name addr) -- | Bind all of the names from an 'Environment' in the current scope. -bindAll :: Member (State (Environment address)) effects => Environment address -> Evaluator address value effects () -bindAll = foldr ((>>) . uncurry bind) (pure ()) . pairs +bindAll :: Member (Env address) effects => Environment address -> Evaluator address value effects () +bindAll = foldr ((>>) . uncurry bind) (pure ()) . Env.pairs --- | Run an action in a new local environment. -locally :: Member (State (Environment address)) effects => Evaluator address value effects a -> Evaluator address value effects a +-- | 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 - modifyEnv Env.push + send (Push @address) a' <- a - a' <$ modifyEnv Env.pop + a' <$ send (Pop @address) + +close :: Member (Env address) effects => Set Name -> Evaluator address value effects (Environment address) +close = send . Close + +data Env address return where + Lookup :: Name -> Env address (Maybe address) + Bind :: Name -> address -> Env address () + Close :: Set Name -> Env address (Environment address) + Push :: Env address () + Pop :: Env address () + GetEnv :: Env address (Environment address) + Export :: Name -> Name -> Maybe address -> Env address () + +handleEnv :: forall address effects value result + . ( Member (State (Environment address)) effects + , Member (State (Exports address)) effects + ) + => Env address result + -> Evaluator address value effects result +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) + GetEnv -> get + Export name alias addr -> modify (Exports.insert name alias addr) + +runEnv :: Environment address + -> Evaluator address value (Env address ': effects) a + -> Evaluator address value effects (a, Environment address) +runEnv initial = fmap (uncurry filterEnv . first (fmap Env.head)) . runState lowerBound . runState (Env.push initial) . reinterpret2 handleEnv + where -- TODO: If the set of exports is empty because no exports have been + -- defined, do we export all terms, or no terms? This behavior varies across + -- languages. We need better semantics rather than doing it ad-hoc. + filterEnv (a, env) ports + | Exports.null ports = (a, env) + | otherwise = (a, Exports.toEnvironment ports `Env.mergeEnvs` Env.overwrite (Exports.aliases ports) env) -- | Errors involving the environment. diff --git a/src/Control/Abstract/Exports.hs b/src/Control/Abstract/Exports.hs deleted file mode 100644 index 5ad8bc1f3..000000000 --- a/src/Control/Abstract/Exports.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Control.Abstract.Exports -( Exports -, getExports -, putExports -, modifyExports -, addExport -, withExports -) where - -import Control.Abstract.Evaluator -import Data.Abstract.Exports -import Data.Abstract.Name - --- | Get the global export state. -getExports :: Member (State (Exports address)) effects => Evaluator address value effects (Exports address) -getExports = get - --- | Set the global export state. -putExports :: Member (State (Exports address)) effects => Exports address -> Evaluator address value effects () -putExports = put - --- | Update the global export state. -modifyExports :: Member (State (Exports address)) effects => (Exports address -> Exports address) -> Evaluator address value effects () -modifyExports = modify' - --- | Add an export to the global export state. -addExport :: Member (State (Exports address)) effects => Name -> Name -> Maybe address -> Evaluator address value effects () -addExport name alias = modifyExports . insert name alias - --- | Sets the global export state for the lifetime of the given action. -withExports :: Member (State (Exports address)) effects => Exports address -> Evaluator address value effects a -> Evaluator address value effects a -withExports = localState . const diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 93a615dbf..6650abb55 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -62,17 +62,15 @@ assign address = modifyHeap . heapInsert address -- | Look up or allocate an address for a 'Name'. lookupOrAlloc :: ( Member (Allocator address value) effects - , Member (Reader (Environment address)) effects - , Member (State (Environment address)) effects + , Member (Env address) effects ) => Name -> Evaluator address value effects address -lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure +lookupOrAlloc name = lookupEnv name >>= maybeM (alloc name) letrec :: ( Member (Allocator address value) effects - , Member (Reader (Environment address)) effects - , Member (State (Environment address)) effects + , Member (Env address) effects , Member (State (Heap address (Cell address) value)) effects , Ord address , Reducer value (Cell address value) @@ -88,8 +86,7 @@ letrec name body = do -- Lookup/alloc a name passing the address to a body evaluated in a new local environment. letrec' :: ( Member (Allocator address value) effects - , Member (Reader (Environment address)) effects - , Member (State (Environment address)) effects + , Member (Env address) effects ) => Name -> (address -> Evaluator address value effects value) @@ -102,9 +99,8 @@ letrec' name body = do -- | Look up and dereference the given 'Name', throwing an exception for free variables. variable :: ( Member (Allocator address value) effects - , Member (Reader (Environment address)) effects + , Member (Env address) effects , Member (Resumable (EnvironmentError address)) effects - , Member (State (Environment address)) effects ) => Name -> Evaluator address value effects value diff --git a/src/Control/Abstract/Modules.hs b/src/Control/Abstract/Modules.hs index fb22b61bd..2853de21f 100644 --- a/src/Control/Abstract/Modules.hs +++ b/src/Control/Abstract/Modules.hs @@ -23,6 +23,7 @@ import Data.Abstract.Environment import Data.Abstract.Module import Data.Abstract.ModuleTable as ModuleTable import Data.Language +import Data.Tuple (swap) import Prologue -- | Retrieve an evaluated module, if any. The outer 'Maybe' indicates whether we’ve begun loading the module or not, while the inner 'Maybe' indicates whether we’ve completed loading it or not. Thus, @Nothing@ means we’ve never tried to load it, @Just Nothing@ means we’ve started but haven’t yet finished loading it, and @Just (Just (env, value))@ indicates the result of a completed load. @@ -47,11 +48,11 @@ require path = lookupModule path >>= maybeM (load path) -- -- Always loads/evaluates. load :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (Environment address, value)) -load = send . Load +load path = fmap swap <$> send (Load path) data Modules address value return where - Load :: ModulePath -> Modules address value (Maybe (Environment address, value)) + Load :: ModulePath -> Modules address value (Maybe (value, Environment address)) Lookup :: ModulePath -> Modules address value (Maybe (Maybe (Environment address, value))) Resolve :: [FilePath] -> Modules address value (Maybe ModulePath) List :: FilePath -> Modules address value [ModulePath] @@ -64,7 +65,7 @@ runModules :: forall term address value effects a , Member (State (ModuleTable (Maybe (Environment address, value)))) effects , Member Trace effects ) - => (Module term -> Evaluator address value (Modules address value ': effects) (Environment address, value)) + => (Module term -> Evaluator address value (Modules address value ': effects) (value, Environment address)) -> Evaluator address value (Modules address value ': effects) a -> Evaluator address value (Reader (ModuleTable [Module term]) ': effects) a runModules evaluateModule = go @@ -92,19 +93,19 @@ runModules evaluateModule = go getModuleTable :: Member (State (ModuleTable (Maybe (Environment address, value)))) effects => Evaluator address value effects (ModuleTable (Maybe (Environment address, value))) getModuleTable = get -cacheModule :: Member (State (ModuleTable (Maybe (Environment address, value)))) effects => ModulePath -> Maybe (Environment address, value) -> Evaluator address value effects (Maybe (Environment address, value)) -cacheModule path result = modify' (ModuleTable.insert path result) $> result +cacheModule :: Member (State (ModuleTable (Maybe (Environment address, value)))) effects => ModulePath -> Maybe (value, Environment address) -> Evaluator address value effects (Maybe (value, Environment address)) +cacheModule path result = modify' (ModuleTable.insert path (swap <$> result)) $> result askModuleTable :: Member (Reader (ModuleTable [Module term])) effects => Evaluator address value effects (ModuleTable [Module term]) askModuleTable = ask -newtype Merging m address value = Merging { runMerging :: m (Maybe (Environment address, value)) } +newtype Merging m address value = Merging { runMerging :: m (Maybe (value, Environment address)) } instance Applicative m => Semigroup (Merging m address value) where Merging a <> Merging b = Merging (merge <$> a <*> b) where merge a b = mergeJusts <$> a <*> b <|> a <|> b - mergeJusts (env1, _) (env2, v) = (mergeEnvs env1 env2, v) + mergeJusts (_, env1) (v, env2) = (v, mergeEnvs env1 env2) instance Applicative m => Monoid (Merging m address value) where mappend = (<>) @@ -113,7 +114,7 @@ instance Applicative m => Monoid (Merging m address value) where -- | An error thrown when loading a module from the list of provided modules. Indicates we weren't able to find a module with the given name. data LoadError address value resume where - ModuleNotFound :: ModulePath -> LoadError address value (Maybe (Environment address, value)) + ModuleNotFound :: ModulePath -> LoadError address value (Maybe (value, Environment address)) deriving instance Eq (LoadError address value resume) deriving instance Show (LoadError address value resume) @@ -122,7 +123,7 @@ instance Show1 (LoadError address value) where instance Eq1 (LoadError address value) where liftEq _ (ModuleNotFound a) (ModuleNotFound b) = a == b -moduleNotFound :: Member (Resumable (LoadError address value)) effects => ModulePath -> Evaluator address value effects (Maybe (Environment address, value)) +moduleNotFound :: Member (Resumable (LoadError address value)) effects => ModulePath -> Evaluator address value effects (Maybe (value, Environment address)) moduleNotFound = throwResumable . ModuleNotFound resumeLoadError :: Member (Resumable (LoadError address value)) effects => Evaluator address value effects a -> (forall resume . LoadError address value resume -> Evaluator address value effects resume) -> Evaluator address value effects a diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 003363867..927b45b91 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -14,9 +14,9 @@ import Prologue builtin :: ( HasCallStack , Member (Allocator address value) effects + , Member (Env address) effects , Member (Reader ModuleInfo) effects , Member (Reader Span) effects - , Member (State (Environment address)) effects , Member (State (Heap address (Cell address) value)) effects , Ord address , Reducer value (Cell address value) @@ -40,12 +40,11 @@ lambda body = do defineBuiltins :: ( AbstractValue address value effects , HasCallStack , Member (Allocator address value) effects + , Member (Env address) effects , Member Fresh effects - , Member (Reader (Environment address)) effects , Member (Reader ModuleInfo) effects , Member (Reader Span) effects , Member (Resumable (EnvironmentError address)) effects - , Member (State (Environment address)) effects , Member (State (Heap address (Cell address) value)) effects , Member Trace effects , Ord address diff --git a/src/Control/Abstract/TermEvaluator.hs b/src/Control/Abstract/TermEvaluator.hs index 40912ad44..553261078 100644 --- a/src/Control/Abstract/TermEvaluator.hs +++ b/src/Control/Abstract/TermEvaluator.hs @@ -7,7 +7,6 @@ module Control.Abstract.TermEvaluator import Control.Abstract.Evaluator import Control.Monad.Effect as X -import Control.Monad.Effect.Fail as X import Control.Monad.Effect.Fresh as X import Control.Monad.Effect.NonDet as X import Control.Monad.Effect.Reader as X diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 9ee24f8b9..b4aa39867 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -158,7 +158,7 @@ asBool value = ifthenelse value (pure True) (pure False) -- | C-style for loops. forLoop :: ( AbstractValue address value effects - , Member (State (Environment address)) effects + , Member (Env address) effects ) => Evaluator address value effects value -- ^ Initial statement -> Evaluator address value effects value -- ^ Condition @@ -187,7 +187,7 @@ doWhile body cond = loop $ \ continue -> body *> do ifthenelse this continue (pure unit) makeNamespace :: ( AbstractValue address value effects - , Member (State (Environment address)) effects + , Member (Env address) effects , Member (State (Heap address (Cell address) value)) effects , Ord address , Reducer value (Cell address value) @@ -206,7 +206,7 @@ makeNamespace name addr super = do -- | Evaluate a term within the context of the scoped environment of 'scopedEnvTerm'. evaluateInScopedEnv :: ( AbstractValue address value effects - , Member (State (Environment address)) effects + , Member (Env address) effects ) => Evaluator address value effects value -> Evaluator address value effects value @@ -219,9 +219,8 @@ evaluateInScopedEnv scopedEnvTerm term = do -- | Evaluates a 'Value' returning the referenced value value :: ( AbstractValue address value effects , Member (Allocator address value) effects - , Member (Reader (Environment address)) effects + , Member (Env address) effects , Member (Resumable (EnvironmentError address)) effects - , Member (State (Environment address)) effects ) => ValueRef value -> Evaluator address value effects value @@ -232,9 +231,8 @@ value (Rval val) = pure val -- | Evaluates a 'Subterm' to its rval subtermValue :: ( AbstractValue address value effects , Member (Allocator address value) effects - , Member (Reader (Environment address)) effects + , Member (Env address) effects , Member (Resumable (EnvironmentError address)) effects - , Member (State (Environment address)) effects ) => Subterm term (Evaluator address value effects (ValueRef value)) -> Evaluator address value effects value diff --git a/src/Data/Abstract/Environment.hs b/src/Data/Abstract/Environment.hs index e3076cf63..17b98108b 100644 --- a/src/Data/Abstract/Environment.hs +++ b/src/Data/Abstract/Environment.hs @@ -1,7 +1,6 @@ module Data.Abstract.Environment ( Environment(..) , addresses - , intersect , delete , head , emptyEnv @@ -10,6 +9,7 @@ module Data.Abstract.Environment , insert , lookup , names + , intersect , overwrite , pairs , unpairs diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index ca2a5a611..cadaf3cf1 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -3,7 +3,6 @@ module Data.Abstract.Evaluatable ( module X , Evaluatable(..) , evaluatePackageWith -, isolate , traceResolve -- | Effects , EvalError(..) @@ -20,13 +19,11 @@ import Control.Abstract import Control.Abstract.Context as X import Control.Abstract.Environment as X hiding (runEnvironmentError, runEnvironmentErrorWith) import Control.Abstract.Evaluator as X hiding (LoopControl(..), Return(..), catchLoopControl, runLoopControl, catchReturn, runReturn) -import Control.Abstract.Exports as X import Control.Abstract.Heap as X hiding (AddressError(..), runAddressError, runAddressErrorWith) import Control.Abstract.Modules as X (Modules, ResolutionError(..), load, lookupModule, listModulesInDir, require, resolve) import Control.Abstract.Value as X import Data.Abstract.Declarations as X import Data.Abstract.Environment as X -import Data.Abstract.Exports as Exports import Data.Abstract.FreeVariables as X import Data.Abstract.Module import Data.Abstract.ModuleTable as ModuleTable @@ -56,9 +53,9 @@ type EvaluatableConstraints address term value effects = , Declarations term , FreeVariables term , Member (Allocator address value) effects + , Member (Env address) effects , Member (LoopControl value) effects , Member (Modules address value) effects - , Member (Reader (Environment address)) effects , Member (Reader ModuleInfo) effects , Member (Reader PackageInfo) effects , Member (Reader Span) effects @@ -67,8 +64,6 @@ type EvaluatableConstraints address term value effects = , Member (Resumable ResolutionError) effects , Member (Resumable (Unspecialized value)) effects , Member (Return value) effects - , Member (State (Environment address)) effects - , Member (State (Exports address)) effects , Member (State (Heap address (Cell address) value)) effects , Member Trace effects , Ord address @@ -77,75 +72,65 @@ type EvaluatableConstraints address term value effects = -- | Evaluate a given package. -evaluatePackageWith :: forall address term value inner outer - -- FIXME: It’d be nice if we didn’t have to mention 'Addressable' here at all, but 'Located' addresses require knowledge of 'currentModule' to run. Can we fix that? If not, can we factor this effect list out? - . ( Addressable address (Reader ModuleInfo ': Modules address value ': Reader Span ': Reader PackageInfo ': outer) +evaluatePackageWith :: forall address term value inner inner' inner'' outer + -- FIXME: It’d be nice if we didn’t have to mention 'Addressable' here at all, but 'Located' locations require knowledge of 'currentModule' to run. Can we fix that? + . ( Addressable address inner' , Evaluatable (Base term) , EvaluatableConstraints address term value inner , Member Fail outer , Member Fresh outer - , Member (Reader (Environment address)) outer , Member (Resumable (AddressError address value)) outer , Member (Resumable (LoadError address value)) outer - , Member (State (Environment address)) outer - , Member (State (Exports address)) outer , Member (State (Heap address (Cell address) value)) outer , Member (State (ModuleTable (Maybe (Environment address, value)))) outer , Member Trace outer , Recursive term - , inner ~ (LoopControl value ': Return value ': Allocator address value ': Reader ModuleInfo ': Modules address value ': Reader Span ': Reader PackageInfo ': outer) + , inner ~ (LoopControl value ': Return value ': Env address ': Allocator address value ': inner') + , inner' ~ (Reader ModuleInfo ': inner'') + , inner'' ~ (Modules address value ': Reader Span ': Reader PackageInfo ': outer) ) => (SubtermAlgebra Module term (TermEvaluator term address value inner value) -> SubtermAlgebra Module term (TermEvaluator term address value inner value)) -> (SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef value)) -> SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef value))) -> Package term - -> TermEvaluator term address value outer [value] + -> TermEvaluator term address value outer [(value, Environment address)] evaluatePackageWith analyzeModule analyzeTerm package = runReader (packageInfo package) . runReader lowerBound . runReader (packageModules (packageBody package)) . withPrelude (packagePrelude (packageBody package)) - . raiseHandler (runModules (runTermEvaluator . evalModule)) - $ traverse (uncurry evaluateEntryPoint) (ModuleTable.toPairs (packageEntryPoints (packageBody package))) + $ \ preludeEnv + -> raiseHandler (runModules (runTermEvaluator . evalModule preludeEnv)) + . traverse (uncurry (evaluateEntryPoint preludeEnv)) + $ ModuleTable.toPairs (packageEntryPoints (packageBody package)) where - evalModule m - = pairValueWithEnv - . runInModule (moduleInfo m) + evalModule preludeEnv m + = runInModule preludeEnv (moduleInfo m) . analyzeModule (subtermRef . moduleBody) $ evalTerm <$> m evalTerm term = Subterm term (TermEvaluator (value =<< runTermEvaluator (foldSubterms (analyzeTerm (TermEvaluator . eval . fmap (second runTermEvaluator))) term))) - runInModule info + runInModule preludeEnv info = runReader info . raiseHandler runAllocator + . raiseHandler (runEnv preludeEnv) . raiseHandler runReturn . raiseHandler runLoopControl - evaluateEntryPoint :: ModulePath -> Maybe Name -> TermEvaluator term address value (Modules address value ': Reader Span ': Reader PackageInfo ': outer) value - evaluateEntryPoint m sym = runInModule (ModuleInfo m) . TermEvaluator $ do - v <- maybe unit snd <$> require m - maybe (pure v) ((`call` []) <=< variable) sym + evaluateEntryPoint :: Environment address -> ModulePath -> Maybe Name -> TermEvaluator term address value inner'' (value, Environment address) + evaluateEntryPoint preludeEnv m sym = runInModule preludeEnv (ModuleInfo m) . TermEvaluator $ do + (env, value) <- fromMaybe (emptyEnv, unit) <$> require m + bindAll env + maybe (pure value) ((`call` []) <=< variable) sym - evalPrelude prelude = raiseHandler (runModules (runTermEvaluator . evalModule)) $ do - _ <- runInModule moduleInfoFromCallStack (TermEvaluator (defineBuiltins $> unit)) - fst <$> evalModule prelude + evalPrelude prelude = raiseHandler (runModules (runTermEvaluator . evalModule emptyEnv)) $ do + (_, builtinsEnv) <- runInModule emptyEnv moduleInfoFromCallStack (TermEvaluator (defineBuiltins $> unit)) + second (mergeEnvs builtinsEnv) <$> evalModule builtinsEnv prelude - withPrelude Nothing a = a - withPrelude (Just prelude) a = do - preludeEnv <- evalPrelude prelude - raiseHandler (withDefaultEnvironment preludeEnv) a + withPrelude Nothing f = f emptyEnv + withPrelude (Just prelude) f = do + (_, preludeEnv) <- evalPrelude prelude + f preludeEnv - -- TODO: If the set of exports is empty because no exports have been - -- defined, do we export all terms, or no terms? This behavior varies across - -- languages. We need better semantics rather than doing it ad-hoc. - filterEnv ports env - | Exports.null ports = env - | otherwise = Exports.toEnvironment ports `mergeEnvs` overwrite (Exports.aliases ports) env - pairValueWithEnv action = flip (,) <$> action <*> (filterEnv <$> TermEvaluator getExports <*> TermEvaluator getEnv) - - --- | Isolate the given action with an empty global environment and exports. -isolate :: (Member (State (Environment address)) effects, Member (State (Exports address)) effects) => Evaluator address value effects a -> Evaluator address value effects a -isolate = withEnv lowerBound . withExports lowerBound traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator address value effects () traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path) diff --git a/src/Data/Abstract/Ref.hs b/src/Data/Abstract/Ref.hs index c7412cde4..4e218a598 100644 --- a/src/Data/Abstract/Ref.hs +++ b/src/Data/Abstract/Ref.hs @@ -12,3 +12,6 @@ data ValueRef value where -- | An object member. LvalMember :: value -> Name -> ValueRef value deriving (Eq, Ord, Show) + + +newtype Ref address value = Ref address diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index ea16910f2..e112ce257 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -117,21 +117,21 @@ instance AbstractIntro Type where instance ( Member (Allocator address Type) effects + , Member (Env address) effects , Member Fresh effects , Member (Resumable TypeError) effects , Member (Return Type) effects - , Member (State (Environment address)) effects - , Member (State (Heap address (Cell address) Type)) effects + , Member (State (Heap address (Cell address) Type)) effects , Ord address , Reducer Type (Cell address Type) ) => AbstractFunction address Type effects where closure names _ body = do (env, tvars) <- foldr (\ name rest -> do - a <- alloc name + addr <- alloc name tvar <- Var <$> fresh - assign a tvar - bimap (Env.insert name a) (tvar :) <$> rest) (pure (emptyEnv, [])) names + assign addr tvar + bimap (Env.insert name addr) (tvar :) <$> rest) (pure (emptyEnv, [])) names (zeroOrMoreProduct tvars :->) <$> locally (bindAll env *> body `catchReturn` \ (Return value) -> pure value) call op params = do @@ -146,12 +146,12 @@ instance ( Member (Allocator address Type) effects -- | Discard the value arguments (if any), constructing a 'Type' instead. instance ( Member (Allocator address Type) effects + , Member (Env address) effects , Member Fresh effects , Member NonDet effects , Member (Resumable TypeError) effects , Member (Return Type) effects - , Member (State (Environment address)) effects - , Member (State (Heap address (Cell address) Type)) effects + , Member (State (Heap address (Cell address) Type)) effects , Ord address , Reducer Type (Cell address Type) ) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 493bc455f..f81646456 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -42,7 +42,7 @@ instance Ord (ClosureBody address body) where compare = compare `on` closureBodyId instance Show (ClosureBody address body) where - showsPrec d (ClosureBody i _) = showsBinaryWith showsPrec (const showChar) "ClosureBody" d i '_' + showsPrec d (ClosureBody i _) = showsUnaryWith showsPrec "ClosureBody" d i instance Ord address => ValueRoots address (Value address body) where @@ -56,12 +56,12 @@ instance AbstractHole (Value address body) where instance ( Coercible body (Eff effects) , Member (Allocator address (Value address body)) effects + , Member (Env address) effects , Member Fresh effects , Member (Reader ModuleInfo) effects , Member (Reader PackageInfo) effects , Member (Resumable (ValueError address body)) effects , Member (Return (Value address body)) effects - , Member (State (Environment address)) effects , Member (State (Heap address (Cell address) (Value address body))) effects , Ord address , Reducer (Value address body) (Cell address (Value address body)) @@ -72,7 +72,7 @@ instance ( Coercible body (Eff effects) packageInfo <- currentPackage moduleInfo <- currentModule i <- fresh - Closure packageInfo moduleInfo parameters (ClosureBody i (coerce (lowerEff body))) . Env.intersect (foldr Set.delete freeVariables parameters) <$> getEnv + Closure packageInfo moduleInfo parameters (ClosureBody i (coerce (lowerEff body))) <$> close (foldr Set.delete freeVariables parameters) call op params = do case op of @@ -81,10 +81,10 @@ instance ( Coercible body (Eff effects) -- charge them to the closure's origin. withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do bindings <- foldr (\ (name, param) rest -> do - v <- param - a <- alloc name - assign a v - Env.insert name a <$> rest) (pure env) (zip names params) + value <- param + addr <- alloc name + assign addr value + Env.insert name addr <$> rest) (pure env) (zip names params) locally (bindAll bindings *> raiseEff (coerce body) `catchReturn` \ (Return value) -> pure value) _ -> throwValueError (CallError op) @@ -109,14 +109,13 @@ instance Show address => AbstractIntro (Value address body) where -- | Construct a 'Value' wrapping the value arguments (if any). instance ( Coercible body (Eff effects) , Member (Allocator address (Value address body)) effects + , Member (Env address) effects , Member Fresh effects , Member (LoopControl (Value address body)) effects - , Member (Reader (Environment address)) effects , Member (Reader ModuleInfo) effects , Member (Reader PackageInfo) effects , Member (Resumable (ValueError address body)) effects , Member (Return (Value address body)) effects - , Member (State (Environment address)) effects , Member (State (Heap address (Cell address) (Value address body))) effects , Ord address , Reducer (Value address body) (Cell address (Value address body)) diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 34f5f0ce2..0b6dcce94 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -27,8 +27,7 @@ instance Evaluatable Function where eval Function{..} = do name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm functionName) (v, addr) <- letrec name (closure (paramNames functionParameters) (Set.fromList (freeVariables functionBody)) (subtermValue functionBody)) - bind name addr - pure (Rval v) + Rval v <$ bind name addr where paramNames = foldMap (freeVariables . subterm) instance Declarations a => Declarations (Function a) where @@ -53,8 +52,7 @@ instance Evaluatable Method where eval Method{..} = do name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm methodName) (v, addr) <- letrec name (closure (paramNames methodParameters) (Set.fromList (freeVariables methodBody)) (subtermValue methodBody)) - bind name addr - pure (Rval v) + Rval v <$ bind name addr where paramNames = foldMap (freeVariables . subterm) diff --git a/src/Diffing/Algorithm.hs b/src/Diffing/Algorithm.hs index b6b0b300a..be17fd252 100644 --- a/src/Diffing/Algorithm.hs +++ b/src/Diffing/Algorithm.hs @@ -221,7 +221,7 @@ instance Diffable [] where -- | Diff two non-empty lists using RWS. instance Diffable NonEmpty where - algorithmFor (a1:|as1) (a2:|as2) = nonEmpty <$> byRWS (a1:as1) (a2:as2) >>= maybe empty pure + algorithmFor (a1:|as1) (a2:|as2) = nonEmpty <$> byRWS (a1:as1) (a2:as2) >>= maybeM empty tryAlignWith f (a1:|as1) (a2:|as2) = (:|) <$> f (These a1 a2) <*> tryAlignWith f as1 as2 diff --git a/src/Language/Go/Syntax.hs b/src/Language/Go/Syntax.hs index 9b47e4894..328b5b518 100644 --- a/src/Language/Go/Syntax.hs +++ b/src/Language/Go/Syntax.hs @@ -70,7 +70,7 @@ instance Evaluatable Import where paths <- resolveGoImport importPath for_ paths $ \path -> do traceResolve (unPath importPath) path - importedEnv <- maybe emptyEnv fst <$> isolate (require path) + importedEnv <- maybe emptyEnv fst <$> require path bindAll importedEnv pure (Rval unit) @@ -94,7 +94,7 @@ instance Evaluatable QualifiedImport where void $ letrec' alias $ \addr -> do for_ paths $ \p -> do traceResolve (unPath importPath) p - importedEnv <- maybe emptyEnv fst <$> isolate (require p) + importedEnv <- maybe emptyEnv fst <$> require p bindAll importedEnv makeNamespace alias addr Nothing pure (Rval unit) @@ -113,7 +113,7 @@ instance Evaluatable SideEffectImport where eval (SideEffectImport importPath _) = do paths <- resolveGoImport importPath traceResolve (unPath importPath) paths - for_ paths $ \path -> isolate (require path) + for_ paths require pure (Rval unit) -- A composite literal in Go diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 66d023d6e..2dd1175fb 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -48,18 +48,16 @@ resolvePHPName :: ( Member (Modules address value) effects -> Evaluator address value effects ModulePath resolvePHPName n = do modulePath <- resolve [name] - maybe (throwResumable $ NotFoundError name [name] Language.PHP) pure modulePath + maybeM (throwResumable $ NotFoundError name [name] Language.PHP) modulePath where name = toName n toName = BC.unpack . dropRelativePrefix . stripQuotes include :: ( AbstractValue address value effects , Member (Allocator address value) effects + , Member (Env address) effects , Member (Modules address value) effects - , Member (Reader (Environment address)) effects , Member (Resumable ResolutionError) effects , Member (Resumable (EnvironmentError address)) effects - , Member (State (Environment address)) effects - , Member (State (Exports address)) effects , Member Trace effects ) => Subterm term (Evaluator address value effects (ValueRef value)) @@ -69,7 +67,7 @@ include pathTerm f = do name <- subtermValue pathTerm >>= asString path <- resolvePHPName name traceResolve name path - (importedEnv, v) <- isolate (f path) >>= maybeM (pure (emptyEnv, unit)) + (importedEnv, v) <- fromMaybe (emptyEnv, unit) <$> f path bindAll importedEnv pure (Rval v) diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index 310f79e6d..6689b2e41 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -82,7 +82,7 @@ resolvePythonModules q = do , path <.> ".py" ] modulePath <- resolve searchPaths - maybe (throwResumable $ NotFoundError path searchPaths Language.Python) pure modulePath + maybeM (throwResumable $ NotFoundError path searchPaths Language.Python) modulePath -- | Import declarations (symbols are added directly to the calling environment). @@ -113,11 +113,11 @@ instance Evaluatable Import where modulePaths <- resolvePythonModules name -- Eval parent modules first - for_ (NonEmpty.init modulePaths) (isolate . require) + for_ (NonEmpty.init modulePaths) require -- Last module path is the one we want to import let path = NonEmpty.last modulePaths - importedEnv <- maybe emptyEnv fst <$> isolate (require path) + importedEnv <- maybe emptyEnv fst <$> require path bindAll (select importedEnv) pure (Rval unit) where @@ -129,17 +129,15 @@ instance Evaluatable Import where -- Evaluate a qualified import evalQualifiedImport :: ( AbstractValue address value effects , Member (Allocator address value) effects + , Member (Env address) effects , Member (Modules address value) effects - , Member (Reader (Environment address)) effects - , Member (State (Environment address)) effects - , Member (State (Exports address)) effects , Member (State (Heap address (Cell address) value)) effects , Ord address , Reducer.Reducer value (Cell address value) ) => Name -> ModulePath -> Evaluator address value effects value evalQualifiedImport name path = letrec' name $ \addr -> do - importedEnv <- maybe emptyEnv fst <$> isolate (require path) + importedEnv <- maybe emptyEnv fst <$> require path bindAll importedEnv unit <$ makeNamespace name addr Nothing @@ -163,7 +161,7 @@ instance Evaluatable QualifiedImport where go ((name, path) :| []) = evalQualifiedImport name path -- Evaluate each parent module, just creating a namespace go ((name, path) :| xs) = letrec' name $ \addr -> do - void $ isolate (require path) + void $ require path void $ go (NonEmpty.fromList xs) makeNamespace name addr Nothing @@ -182,13 +180,13 @@ instance Evaluatable QualifiedAliasedImport where modulePaths <- resolvePythonModules name -- Evaluate each parent module - for_ (NonEmpty.init modulePaths) (isolate . require) + for_ (NonEmpty.init modulePaths) require -- Evaluate and import the last module, aliasing and updating the environment alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm) Rval <$> letrec' alias (\addr -> do let path = NonEmpty.last modulePaths - importedEnv <- maybe emptyEnv fst <$> isolate (require path) + importedEnv <- maybe emptyEnv fst <$> require path bindAll importedEnv unit <$ makeNamespace alias addr Nothing) diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index 862d41eb7..1eb89f5cd 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -26,7 +26,7 @@ resolveRubyName name = do let name' = cleanNameOrPath name let paths = [name' <.> "rb"] modulePath <- resolve paths - maybe (throwResumable $ NotFoundError name' paths Language.Ruby) pure modulePath + maybeM (throwResumable $ NotFoundError name' paths Language.Ruby) modulePath -- load "/root/src/file.rb" resolveRubyPath :: ( Member (Modules address value) effects @@ -37,7 +37,7 @@ resolveRubyPath :: ( Member (Modules address value) effects resolveRubyPath path = do let name' = cleanNameOrPath path modulePath <- resolve [name'] - maybe (throwResumable $ NotFoundError name' [name'] Language.Ruby) pure modulePath + maybeM (throwResumable $ NotFoundError name' [name'] Language.Ruby) modulePath cleanNameOrPath :: ByteString -> String cleanNameOrPath = BC.unpack . dropRelativePrefix . stripQuotes @@ -73,7 +73,7 @@ instance Evaluatable Require where name <- subtermValue x >>= asString path <- resolveRubyName name traceResolve name path - (importedEnv, v) <- isolate (doRequire path) + (importedEnv, v) <- doRequire path bindAll importedEnv pure (Rval v) -- Returns True if the file was loaded, False if it was already loaded. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-require @@ -109,10 +109,9 @@ instance Evaluatable Load where eval (Load _) = raiseEff (fail "invalid argument supplied to load, path is required") doLoad :: ( AbstractValue address value effects + , Member (Env address) effects , Member (Modules address value) effects , Member (Resumable ResolutionError) effects - , Member (State (Environment address)) effects - , Member (State (Exports address)) effects , Member Trace effects ) => ByteString @@ -121,7 +120,7 @@ doLoad :: ( AbstractValue address value effects doLoad path shouldWrap = do path' <- resolveRubyPath path traceResolve path path' - importedEnv <- maybe emptyEnv fst <$> isolate (load path') + importedEnv <- maybe emptyEnv fst <$> load path' unless shouldWrap $ bindAll importedEnv pure (boolean Prelude.True) -- load always returns true. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-load diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index b05d22bd1..c4db903dc 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -135,10 +135,8 @@ javascriptExtensions = ["js"] evalRequire :: ( AbstractValue address value effects , Member (Allocator address value) effects + , Member (Env address) effects , Member (Modules address value) effects - , Member (Reader (Environment address)) effects - , Member (State (Environment address)) effects - , Member (State (Exports address)) effects , Member (State (Heap address (Cell address) value)) effects , Ord address , Reducer value (Cell address value) @@ -147,7 +145,7 @@ evalRequire :: ( AbstractValue address value effects -> Name -> Evaluator address value effects value evalRequire modulePath alias = letrec' alias $ \addr -> do - importedEnv <- maybe emptyEnv fst <$> isolate (require modulePath) + importedEnv <- maybe emptyEnv fst <$> require modulePath bindAll importedEnv unit <$ makeNamespace alias addr Nothing @@ -164,7 +162,7 @@ instance Show1 Import where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Import where eval (Import symbols importPath) = do modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions - importedEnv <- maybe emptyEnv fst <$> isolate (require modulePath) + importedEnv <- maybe emptyEnv fst <$> require modulePath bindAll (renamed importedEnv) $> Rval unit where renamed importedEnv @@ -214,7 +212,7 @@ instance ToJSONFields1 SideEffectImport instance Evaluatable SideEffectImport where eval (SideEffectImport importPath) = do modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions - void $ isolate (require modulePath) + void $ require modulePath pure (Rval unit) @@ -232,7 +230,7 @@ instance Evaluatable QualifiedExport where eval (QualifiedExport exportSymbols) = do -- Insert the aliases with no addresses. for_ exportSymbols $ \(name, alias) -> - addExport name alias Nothing + export name alias Nothing pure (Rval unit) @@ -249,11 +247,11 @@ instance ToJSONFields1 QualifiedExportFrom instance Evaluatable QualifiedExportFrom where eval (QualifiedExportFrom importPath exportSymbols) = do modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions - importedEnv <- maybe emptyEnv fst <$> isolate (require modulePath) + importedEnv <- maybe emptyEnv fst <$> require modulePath -- Look up addresses in importedEnv and insert the aliases with addresses into the exports. for_ exportSymbols $ \(name, alias) -> do let address = Env.lookup name importedEnv - maybe (throwEvalError $ ExportError modulePath name) (addExport name alias . Just) address + maybe (throwEvalError $ ExportError modulePath name) (export name alias . Just) address pure (Rval unit) newtype DefaultExport a = DefaultExport { defaultExport :: a } @@ -272,8 +270,8 @@ instance Evaluatable DefaultExport where Just name -> do addr <- lookupOrAlloc name assign addr v - addExport name name Nothing - void $ bind name addr + export name name Nothing + bind name addr Nothing -> throwEvalError DefaultExportError pure (Rval unit) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 32f2c0be4..a4b8f07a7 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -129,7 +129,7 @@ resumingAddressError = runAddressErrorWith (\ err -> trace ("AddressError:" <> s UnallocatedAddress _ -> pure lowerBound UninitializedAddress _ -> pure hole) -resumingValueError :: (Member (State (Environment address)) effects, Member Trace effects, Show address) => Evaluator address (Value address body) (Resumable (ValueError address body) ': effects) a -> Evaluator address (Value address body) effects a +resumingValueError :: (Member Trace effects, Show address) => Evaluator address (Value address body) (Resumable (ValueError address body) ': effects) a -> Evaluator address (Value address body) effects a resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err) *> case err of CallError val -> pure val StringError val -> pure (pack (show val)) @@ -139,7 +139,7 @@ resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err NumericError{} -> pure hole Numeric2Error{} -> pure hole ComparisonError{} -> pure hole - NamespaceError{} -> getEnv + NamespaceError{} -> pure emptyEnv BitwiseError{} -> pure hole Bitwise2Error{} -> pure hole KeyValueError{} -> pure (hole, hole) diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index 60e1dd162..9a594e557 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -96,7 +96,7 @@ readBlobsFromHandle = fmap toBlobs . readFromHandle readBlobFromPath :: MonadIO m => File -> m Blob.Blob readBlobFromPath file = do maybeFile <- readFile file - maybe (fail ("cannot read '" <> show file <> "', file not found or language not supported.")) pure maybeFile + maybeM (fail ("cannot read '" <> show file <> "', file not found or language not supported.")) maybeFile readProjectFromPaths :: MonadIO m => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project readProjectFromPaths maybeRoot path lang excludeDirs = do diff --git a/test/Analysis/Go/Spec.hs b/test/Analysis/Go/Spec.hs index b0b43cd97..7c4cfd105 100644 --- a/test/Analysis/Go/Spec.hs +++ b/test/Analysis/Go/Spec.hs @@ -11,16 +11,16 @@ spec :: Spec spec = parallel $ do describe "evaluates Go" $ do it "imports and wildcard imports" $ do - ((_, state), _) <- evaluate "main.go" - Env.names (environment state) `shouldBe` [ "Bar", "Rab", "foo", "main" ] + ((Right [(_, env)], state), _) <- evaluate "main.go" + Env.names env `shouldBe` [ "Bar", "Rab", "foo", "main" ] - (derefQName (heap state) ("foo" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("foo", ["New"]) + (derefQName (heap state) ("foo" :| []) env >>= deNamespace) `shouldBe` Just ("foo", ["New"]) it "imports with aliases (and side effects only)" $ do - ((_, state), _) <- evaluate "main1.go" - Env.names (environment state) `shouldBe` [ "f", "main" ] + ((Right [(_, env)], state), _) <- evaluate "main1.go" + Env.names env `shouldBe` [ "f", "main" ] - (derefQName (heap state) ("f" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("f", ["New"]) + (derefQName (heap state) ("f" :| []) env >>= deNamespace) `shouldBe` Just ("f", ["New"]) where fixtures = "test/fixtures/go/analysis/" diff --git a/test/Analysis/PHP/Spec.hs b/test/Analysis/PHP/Spec.hs index 619136202..168139d48 100644 --- a/test/Analysis/PHP/Spec.hs +++ b/test/Analysis/PHP/Spec.hs @@ -12,22 +12,22 @@ spec :: Spec spec = parallel $ do describe "PHP" $ do it "evaluates include and require" $ do - ((res, state), _) <- evaluate "main.php" - res `shouldBe` Right [unit] - Env.names (environment state) `shouldBe` [ "bar", "foo" ] + ((Right [(res, env)], state), _) <- evaluate "main.php" + res `shouldBe` unit + Env.names env `shouldBe` [ "bar", "foo" ] it "evaluates include_once and require_once" $ do - ((res, state), _) <- evaluate "main_once.php" - res `shouldBe` Right [unit] - Env.names (environment state) `shouldBe` [ "bar", "foo" ] + ((Right [(res, env)], state), _) <- evaluate "main_once.php" + res `shouldBe` unit + Env.names env `shouldBe` [ "bar", "foo" ] it "evaluates namespaces" $ do - ((_, state), _) <- evaluate "namespaces.php" - Env.names (environment state) `shouldBe` [ "Foo", "NS1" ] + ((Right [(_, env)], state), _) <- evaluate "namespaces.php" + Env.names env `shouldBe` [ "Foo", "NS1" ] - (derefQName (heap state) ("NS1" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("NS1", ["Sub1", "b", "c"]) - (derefQName (heap state) ("NS1" :| ["Sub1"]) (environment state) >>= deNamespace) `shouldBe` Just ("Sub1", ["Sub2"]) - (derefQName (heap state) ("NS1" :| ["Sub1", "Sub2"]) (environment state) >>= deNamespace) `shouldBe` Just ("Sub2", ["f"]) + (derefQName (heap state) ("NS1" :| []) env >>= deNamespace) `shouldBe` Just ("NS1", ["Sub1", "b", "c"]) + (derefQName (heap state) ("NS1" :| ["Sub1"]) env >>= deNamespace) `shouldBe` Just ("Sub1", ["Sub2"]) + (derefQName (heap state) ("NS1" :| ["Sub1", "Sub2"]) env >>= deNamespace) `shouldBe` Just ("Sub2", ["f"]) where fixtures = "test/fixtures/php/analysis/" diff --git a/test/Analysis/Python/Spec.hs b/test/Analysis/Python/Spec.hs index 9bd89b98c..66ad0df48 100644 --- a/test/Analysis/Python/Spec.hs +++ b/test/Analysis/Python/Spec.hs @@ -14,33 +14,33 @@ spec :: Spec spec = parallel $ do describe "evaluates Python" $ do it "imports" $ do - ((_, state), _) <- evaluate "main.py" - Env.names (environment state) `shouldContain` [ "a", "b" ] + ((Right [(_, env)], state), _) <- evaluate "main.py" + Env.names env `shouldContain` [ "a", "b" ] - (derefQName (heap state) ("a" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("a", ["foo"]) - (derefQName (heap state) ("b" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("b", ["c"]) - (derefQName (heap state) ("b" :| ["c"]) (environment state) >>= deNamespace) `shouldBe` Just ("c", ["baz"]) + (derefQName (heap state) ("a" :| []) env >>= deNamespace) `shouldBe` Just ("a", ["foo"]) + (derefQName (heap state) ("b" :| []) env >>= deNamespace) `shouldBe` Just ("b", ["c"]) + (derefQName (heap state) ("b" :| ["c"]) env >>= deNamespace) `shouldBe` Just ("c", ["baz"]) it "imports with aliases" $ do - env <- environment . snd . fst <$> evaluate "main1.py" + ((Right [(_, env)], _), _) <- evaluate "main1.py" Env.names env `shouldContain` [ "b", "e" ] it "imports using 'from' syntax" $ do - env <- environment . snd . fst <$> evaluate "main2.py" + ((Right [(_, env)], _), _) <- evaluate "main2.py" Env.names env `shouldContain` [ "bar", "foo" ] it "imports with relative syntax" $ do - ((_, state), _) <- evaluate "main3.py" - Env.names (environment state) `shouldContain` [ "utils" ] - (derefQName (heap state) ("utils" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("utils", ["to_s"]) + ((Right [(_, env)], state), _) <- evaluate "main3.py" + Env.names env `shouldContain` [ "utils" ] + (derefQName (heap state) ("utils" :| []) env >>= deNamespace) `shouldBe` Just ("utils", ["to_s"]) it "subclasses" $ do ((res, _), _) <- evaluate "subclass.py" - res `shouldBe` Right [String "\"bar\""] + fmap fst <$> res `shouldBe` Right [String "\"bar\""] it "handles multiple inheritance left-to-right" $ do ((res, _), _) <- evaluate "multiple_inheritance.py" - res `shouldBe` Right [String "\"foo!\""] + fmap fst <$> res `shouldBe` Right [String "\"foo!\""] where ns n = Just . Latest . Last . Just . Namespace n diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index 5b9743906..83958cde8 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/test/Analysis/Ruby/Spec.hs @@ -20,58 +20,57 @@ spec :: Spec spec = parallel $ do describe "Ruby" $ do it "evaluates require_relative" $ do - ((res, state), _) <- evaluate "main.rb" - res `shouldBe` Right [Value.Integer (Number.Integer 1)] - Env.names (environment state) `shouldContain` ["foo"] + ((Right [(res, env)], state), _) <- evaluate "main.rb" + res `shouldBe` Value.Integer (Number.Integer 1) + Env.names env `shouldContain` ["foo"] it "evaluates load" $ do - env <- environment . snd . fst <$> evaluate "load.rb" + ((Right [(_, env)], _), _) <- evaluate "load.rb" Env.names env `shouldContain` ["foo"] it "evaluates load with wrapper" $ do ((res, state), _) <- evaluate "load-wrap.rb" res `shouldBe` Left (SomeExc (inject @(EnvironmentError Precise) (FreeVariable "foo"))) - Env.names (environment state) `shouldContain` [ "Object" ] it "evaluates subclass" $ do - ((res, state), _) <- evaluate "subclass.rb" - res `shouldBe` Right [String "\"\""] - Env.names (environment state) `shouldContain` [ "Bar", "Foo" ] + ((Right [(res, env)], state), _) <- evaluate "subclass.rb" + res `shouldBe` String "\"\"" + Env.names env `shouldContain` [ "Bar", "Foo" ] - (derefQName (heap state) ("Bar" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("Bar", ["baz", "foo", "inspect"]) + (derefQName (heap state) ("Bar" :| []) env >>= deNamespace) `shouldBe` Just ("Bar", ["baz", "foo", "inspect"]) it "evaluates modules" $ do - ((res, state), _) <- evaluate "modules.rb" - res `shouldBe` Right [String "\"\""] - Env.names (environment state) `shouldContain` [ "Bar" ] + ((Right [(res, env)], state), _) <- evaluate "modules.rb" + res `shouldBe` String "\"\"" + Env.names env `shouldContain` [ "Bar" ] it "handles break correctly" $ do ((res, _), _) <- evaluate "break.rb" - res `shouldBe` Right [Value.Integer (Number.Integer 3)] + fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 3)] it "handles break correctly" $ do ((res, _), _) <- evaluate "next.rb" - res `shouldBe` Right [Value.Integer (Number.Integer 8)] + fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 8)] it "calls functions with arguments" $ do ((res, _), _) <- evaluate "call.rb" - res `shouldBe` Right [Value.Integer (Number.Integer 579)] + fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 579)] it "evaluates early return statements" $ do ((res, _), _) <- evaluate "early-return.rb" - res `shouldBe` Right [Value.Integer (Number.Integer 123)] + fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 123)] it "has prelude" $ do ((res, _), _) <- evaluate "preluded.rb" - res `shouldBe` Right [String "\"\""] + fmap fst <$> res `shouldBe` Right [String "\"\""] it "evaluates __LINE__" $ do ((res, _), _) <- evaluate "line.rb" - res `shouldBe` Right [Value.Integer (Number.Integer 4)] + fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 4)] it "resolves builtins used in the prelude" $ do ((res, _), traces) <- evaluate "puts.rb" - res `shouldBe` Right [Unit] + fmap fst <$> res `shouldBe` Right [Unit] traces `shouldContain` [ "\"hello\"" ] where diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index bb5a29b5b..acb871251 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -15,19 +15,19 @@ spec :: Spec spec = parallel $ do describe "evaluates TypeScript" $ do it "imports with aliased symbols" $ do - env <- environment . snd . fst <$> evaluate "main.ts" + ((Right [(_, env)], _), _) <- evaluate "main.ts" Env.names env `shouldBe` [ "bar", "quz" ] it "imports with qualified names" $ do - ((_, state), _) <- evaluate "main1.ts" - Env.names (environment state) `shouldBe` [ "b", "z" ] + ((Right [(_, env)], state), _) <- evaluate "main1.ts" + Env.names env `shouldBe` [ "b", "z" ] - (derefQName (heap state) ("b" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("b", [ "baz", "foo" ]) - (derefQName (heap state) ("z" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("z", [ "baz", "foo" ]) + (derefQName (heap state) ("b" :| []) env >>= deNamespace) `shouldBe` Just ("b", [ "baz", "foo" ]) + (derefQName (heap state) ("z" :| []) env >>= deNamespace) `shouldBe` Just ("z", [ "baz", "foo" ]) it "side effect only imports" $ do - env <- environment . snd . fst <$> evaluate "main2.ts" - env `shouldBe` emptyEnv + ((res, _), _) <- evaluate "main2.ts" + fmap snd <$> res `shouldBe` Right [emptyEnv] it "fails exporting symbols not defined in the module" $ do ((res, _), _) <- evaluate "bad-export.ts" @@ -35,7 +35,7 @@ spec = parallel $ do it "evaluates early return statements" $ do ((res, _), _) <- evaluate "early-return.ts" - res `shouldBe` Right [Value.Float (Number.Decimal 123.0)] + fmap fst <$> res `shouldBe` Right [Value.Float (Number.Decimal 123.0)] where fixtures = "test/fixtures/typescript/analysis/" diff --git a/test/Control/Abstract/Evaluator/Spec.hs b/test/Control/Abstract/Evaluator/Spec.hs index ddfb4c016..28100f6b1 100644 --- a/test/Control/Abstract/Evaluator/Spec.hs +++ b/test/Control/Abstract/Evaluator/Spec.hs @@ -20,13 +20,13 @@ spec :: Spec spec = parallel $ do it "constructs integers" $ do (expected, _) <- evaluate (pure (integer 123)) - expected `shouldBe` Right (Value.Integer (Number.Integer 123)) + fst <$> expected `shouldBe` Right (Value.Integer (Number.Integer 123)) it "calls functions" $ do (expected, _) <- evaluate $ do identity <- closure [name "x"] lowerBound (variable (name "x")) call identity [pure (integer 123)] - expected `shouldBe` Right (Value.Integer (Number.Integer 123)) + fst <$> expected `shouldBe` Right (Value.Integer (Number.Integer 123)) evaluate = runM @@ -38,6 +38,7 @@ evaluate . runEnvironmentError . runAddressError . runAllocator + . runEnv lowerBound . runReturn . runLoopControl diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 49eec19db..6aee58368 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -34,7 +34,6 @@ import Data.Project as X import Data.Functor.Listable as X import Data.Language as X import Data.List.NonEmpty as X (NonEmpty(..)) -import Data.Monoid as X (Last(..)) import Data.Range as X import Data.Record as X import Data.Source as X