diff --git a/semantic.cabal b/semantic.cabal index 0f8c6caec..50b40a34a 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -46,6 +46,7 @@ library , Control.Abstract.Heap , Control.Abstract.Matching , Control.Abstract.Modules + , Control.Abstract.Primitive , Control.Abstract.Roots , Control.Abstract.TermEvaluator , Control.Abstract.Value @@ -62,9 +63,11 @@ library , Data.Abstract.Live , Data.Abstract.Module , Data.Abstract.ModuleTable + , Data.Abstract.Name , Data.Abstract.Number , Data.Abstract.Package , Data.Abstract.Path + , Data.Abstract.Ref , Data.Abstract.Type , Data.Abstract.Value -- General datatype definitions & generic algorithms diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 8b7f18eae..8001ec6e1 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -7,8 +7,8 @@ module Analysis.Abstract.Caching import Control.Abstract import Data.Abstract.Cache -import Data.Abstract.Evaluatable import Data.Abstract.Module +import Data.Abstract.Ref import Data.Semilattice.Lower import Prologue @@ -63,7 +63,7 @@ cachingTerms :: ( Cacheable term location (Cell location) value , Reader (Cache term location (Cell location) value) , Reader (Live location value) , State (Cache term location (Cell location) value) - , State (Environment location value) + , State (Environment location) , State (Heap location (Cell location) value) ] effects ) @@ -84,13 +84,12 @@ convergingModules :: ( AbstractValue location value effects , Fresh , NonDet , Reader (Cache term location (Cell location) value) - , Reader (Environment location value) + , Reader (Environment location) , Reader (Live location value) , Resumable (AddressError location value) , Resumable (EnvironmentError value) - , Resumable (EvalError value) , State (Cache term location (Cell location) value) - , State (Environment location value) + , State (Environment location) , State (Heap location (Cell location) value) ] effects ) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index df9b0c101..3cc429c3d 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -9,10 +9,10 @@ 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 location value = EvaluatingState - { environment :: Environment location value + { environment :: Environment location , heap :: Heap location (Cell location) value - , modules :: ModuleTable (Maybe (Environment location value, value)) - , exports :: Exports location value + , modules :: ModuleTable (Maybe (Environment location, value)) + , exports :: Exports location } deriving instance (Eq (Cell location value), Eq location, Eq value) => Eq (EvaluatingState location value) @@ -23,19 +23,19 @@ deriving instance (Show (Cell location value), Show location, Show value) => Sho evaluating :: Evaluator location value ( Fail ': Fresh - ': Reader (Environment location value) - ': State (Environment location value) + ': Reader (Environment location) + ': State (Environment location) ': State (Heap location (Cell location) value) - ': State (ModuleTable (Maybe (Environment location value, value))) - ': State (Exports location value) + ': State (ModuleTable (Maybe (Environment location, value))) + ': State (Exports location) ': effects) result -> Evaluator location value effects (Either String result, EvaluatingState location value) evaluating = fmap (\ ((((result, env), heap), modules), exports) -> (result, EvaluatingState env heap modules exports)) - . runState lowerBound -- State (Exports location value) - . runState lowerBound -- State (ModuleTable (Maybe (Environment location value, value))) + . runState lowerBound -- State (Exports location) + . runState lowerBound -- State (ModuleTable (Maybe (Environment location, value))) . runState lowerBound -- State (Heap location (Cell location) value) - . runState lowerBound -- State (Environment location value) - . runReader lowerBound -- Reader (Environment location value) + . runState lowerBound -- State (Environment location) + . runReader lowerBound -- Reader (Environment location) . runFresh 0 . runFail diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index 156417419..92fb73528 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -16,8 +16,8 @@ module Analysis.Abstract.Graph import Algebra.Graph.Export.Dot hiding (vertexName) import Control.Abstract import Data.Abstract.Address -import Data.Abstract.FreeVariables import Data.Abstract.Module (Module(moduleInfo), ModuleInfo(..)) +import Data.Abstract.Name import Data.Abstract.Package (PackageInfo(..)) import Data.Aeson hiding (Result) import Data.ByteString.Builder @@ -52,9 +52,9 @@ style = (defaultStyle (byteString . vertexName)) -- | Add vertices to the graph for evaluated identifiers. graphingTerms :: ( Element Syntax.Identifier syntax - , Members '[ Reader (Environment (Located location) value) + , Members '[ Reader (Environment (Located location)) , Reader ModuleInfo - , State (Environment (Located location) value) + , State (Environment (Located location)) , State (Graph Vertex) ] effects , term ~ Term (Sum syntax) ann @@ -125,8 +125,8 @@ 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 (Located location) value)) effects - , Member (State (Environment (Located location) value)) effects +variableDefinition :: ( Member (Reader (Environment (Located location))) effects + , Member (State (Environment (Located location))) effects , Member (State (Graph Vertex)) effects ) => Name diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 93c07af27..79a878819 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 , Members '[ Reader (Live location value) - , State (Environment location value) + , State (Environment location) , State (Heap location (Cell location) value) , Writer (trace (Configuration term location (Cell location) value)) ] effects diff --git a/src/Analysis/Declaration.hs b/src/Analysis/Declaration.hs index 1fc675405..04d12088d 100644 --- a/src/Analysis/Declaration.hs +++ b/src/Analysis/Declaration.hs @@ -5,7 +5,7 @@ module Analysis.Declaration , declarationAlgebra ) where -import Data.Abstract.FreeVariables (Name(..)) +import Data.Abstract.Name (unName) import Data.Blob import Data.Error (Error(..), showExpectation) import Data.Language as Language @@ -130,7 +130,7 @@ getSource blobSource = toText . flip Source.slice blobSource . getField instance (Syntax.Identifier :< fs, Expression.MemberAccess :< fs) => CustomHasDeclaration (Sum fs) Expression.Call where customToDeclaration Blob{..} _ (Expression.Call _ (Term (In fromAnn fromF), _) _ _) | Just (Expression.MemberAccess (Term (In leftAnn leftF)) (Term (In idenAnn _))) <- project fromF = Just $ CallReference (getSource idenAnn) mempty blobLanguage (memberAccess leftAnn leftF) - | Just (Syntax.Identifier (Name name)) <- project fromF = Just $ CallReference (T.decodeUtf8 name) mempty blobLanguage [] + | Just (Syntax.Identifier name) <- project fromF = Just $ CallReference (T.decodeUtf8 (unName name)) mempty blobLanguage [] | otherwise = Just $ CallReference (getSource fromAnn) mempty blobLanguage [] where memberAccess modAnn termFOut diff --git a/src/Analysis/IdentifierName.hs b/src/Analysis/IdentifierName.hs index 700e989f6..f98d13fef 100644 --- a/src/Analysis/IdentifierName.hs +++ b/src/Analysis/IdentifierName.hs @@ -5,7 +5,7 @@ module Analysis.IdentifierName , identifierLabel ) where -import Data.Abstract.FreeVariables (Name (..)) +import Data.Abstract.Name (unName) import Data.Aeson import Data.JSON.Fields import Data.Sum @@ -41,7 +41,7 @@ instance Apply IdentifierName fs => CustomIdentifierName (Sum fs) where customIdentifierName = apply @IdentifierName identifierName instance CustomIdentifierName Data.Syntax.Identifier where - customIdentifierName (Data.Syntax.Identifier (Name name)) = Just name + customIdentifierName (Data.Syntax.Identifier name) = Just (unName name) data Strategy = Default | Custom diff --git a/src/Control/Abstract.hs b/src/Control/Abstract.hs index 08f83b900..a8b00273d 100644 --- a/src/Control/Abstract.hs +++ b/src/Control/Abstract.hs @@ -11,6 +11,7 @@ import Control.Abstract.Exports as X import Control.Abstract.Heap as X import Control.Abstract.Goto as X import Control.Abstract.Modules as X +import Control.Abstract.Primitive as X import Control.Abstract.Roots as X import Control.Abstract.TermEvaluator as X import Control.Abstract.Value as X diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index a37035776..ccadd1736 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -6,7 +6,7 @@ module Control.Abstract.Addressable import Control.Abstract.Context import Control.Abstract.Evaluator import Data.Abstract.Address -import Data.Abstract.FreeVariables +import Data.Abstract.Name import Prologue -- | Defines allocation and dereferencing of 'Address'es in a 'Heap'. diff --git a/src/Control/Abstract/Configuration.hs b/src/Control/Abstract/Configuration.hs index 68cd128af..37a97033a 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 :: Members '[Reader (Live location value), State (Environment location value), State (Heap location (Cell location) value)] effects => term -> TermEvaluator term location value effects (Configuration term location (Cell location) value) +getConfiguration :: Members '[Reader (Live location value), State (Environment location), State (Heap location (Cell location) value)] effects => term -> TermEvaluator term location value effects (Configuration term location (Cell location) 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 4f4ee0f40..08cb9b4db 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -20,53 +20,53 @@ module Control.Abstract.Environment import Control.Abstract.Evaluator import Data.Abstract.Address import Data.Abstract.Environment as Env -import Data.Abstract.FreeVariables +import Data.Abstract.Name import Prologue -- | Retrieve the environment. -getEnv :: Member (State (Environment location value)) effects => Evaluator location value effects (Environment location value) +getEnv :: Member (State (Environment location)) effects => Evaluator location value effects (Environment location) getEnv = get -- | Set the environment. -putEnv :: Member (State (Environment location value)) effects => Environment location value -> Evaluator location value effects () +putEnv :: Member (State (Environment location)) effects => Environment location -> Evaluator location value effects () putEnv = put -- | Update the global environment. -modifyEnv :: Member (State (Environment location value)) effects => (Environment location value -> Environment location value) -> Evaluator location value effects () +modifyEnv :: Member (State (Environment location)) effects => (Environment location -> Environment location) -> Evaluator location value effects () modifyEnv = modify' -- | Sets the environment for the lifetime of the given action. -withEnv :: Member (State (Environment location value)) effects => Environment location value -> Evaluator location value effects a -> Evaluator location value effects a +withEnv :: Member (State (Environment location)) effects => Environment location -> Evaluator location value effects a -> Evaluator location value effects a withEnv = localState . const -- | Retrieve the default environment. -defaultEnvironment :: Member (Reader (Environment location value)) effects => Evaluator location value effects (Environment location value) +defaultEnvironment :: Member (Reader (Environment location)) effects => Evaluator location value effects (Environment location) 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 location value)) effects => Environment location value -> Evaluator location value effects a -> Evaluator location value effects a +withDefaultEnvironment :: Member (Reader (Environment location)) effects => Environment location -> Evaluator location value effects a -> Evaluator location value effects a withDefaultEnvironment e = local (const e) -- | Obtain an environment that is the composition of the current and default environments. -- Useful for debugging. -fullEnvironment :: Members '[Reader (Environment location value), State (Environment location value)] effects => Evaluator location value effects (Environment location value) +fullEnvironment :: Members '[Reader (Environment location), State (Environment location)] effects => Evaluator location value effects (Environment location) fullEnvironment = mergeEnvs <$> getEnv <*> defaultEnvironment -- | Run an action with a locally-modified environment. -localEnv :: Member (State (Environment location value)) effects => (Environment location value -> Environment location value) -> Evaluator location value effects a -> Evaluator location value effects a +localEnv :: Member (State (Environment location)) effects => (Environment location -> Environment location) -> Evaluator location value effects a -> Evaluator location value effects a localEnv f a = do modifyEnv (f . Env.push) result <- a result <$ modifyEnv Env.pop -- | Run a computation in a new local environment. -localize :: Member (State (Environment location value)) effects => Evaluator location value effects a -> Evaluator location value effects a +localize :: Member (State (Environment location)) effects => Evaluator location value effects a -> Evaluator location value effects a localize = localEnv id -- | Look a 'Name' up in the current environment, trying the default environment if no value is found. -lookupEnv :: Members '[Reader (Environment location value), State (Environment location value)] effects => Name -> Evaluator location value effects (Maybe (Address location value)) +lookupEnv :: Members '[Reader (Environment location), State (Environment location)] effects => Name -> Evaluator location value effects (Maybe (Address location value)) lookupEnv name = (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index f0a2eb287..f8c623573 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -1,7 +1,6 @@ {-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators #-} module Control.Abstract.Evaluator ( Evaluator(..) - , ValueRef(..) -- * Effects , Return(..) , earlyReturn @@ -12,25 +11,16 @@ module Control.Abstract.Evaluator , throwContinue , catchLoopControl , runLoopControl - , module Control.Monad.Effect - , module Control.Monad.Effect.Fail - , module Control.Monad.Effect.Fresh - , module Control.Monad.Effect.NonDet - , module Control.Monad.Effect.Reader - , module Control.Monad.Effect.Resumable - , module Control.Monad.Effect.State - , module Control.Monad.Effect.Trace + , module X ) where -import Control.Monad.Effect -import Control.Monad.Effect.Fail -import Control.Monad.Effect.Fresh -import Control.Monad.Effect.NonDet -import Control.Monad.Effect.Reader -import Control.Monad.Effect.Resumable -import Control.Monad.Effect.State -import Control.Monad.Effect.Trace -import Data.Abstract.FreeVariables +import Control.Monad.Effect as X +import Control.Monad.Effect.Fresh as X +import Control.Monad.Effect.NonDet as X +import Control.Monad.Effect.Reader as X +import Control.Monad.Effect.Resumable as X +import Control.Monad.Effect.State as X +import Control.Monad.Effect.Trace as X import Prologue -- | An 'Evaluator' is a thin wrapper around 'Eff' with (phantom) type parameters for the location, term, and value types. @@ -43,16 +33,6 @@ newtype Evaluator location value effects a = Evaluator { runEvaluator :: Eff eff deriving instance Member NonDet effects => Alternative (Evaluator location value effects) --- | 'ValueRef' is the type subterms evaluate to and can represent either values directly ('Rval'), or references to values (lvals - such as local variables or object members) -data ValueRef value where - -- Represents a value: - Rval :: value -> ValueRef value - -- Represents a local variable. No environment is attached - it's assumed that LvalLocal will be evaluated in the same scope it was constructed: - LvalLocal :: Name -> ValueRef value - -- Represents an object member: - LvalMember :: value -> Name -> ValueRef value - - deriving (Eq, Ord, Show) -- Effects diff --git a/src/Control/Abstract/Exports.hs b/src/Control/Abstract/Exports.hs index ac935d4fb..e31e8d376 100644 --- a/src/Control/Abstract/Exports.hs +++ b/src/Control/Abstract/Exports.hs @@ -10,24 +10,24 @@ module Control.Abstract.Exports import Control.Abstract.Evaluator import Data.Abstract.Address import Data.Abstract.Exports -import Data.Abstract.FreeVariables +import Data.Abstract.Name -- | Get the global export state. -getExports :: Member (State (Exports location value)) effects => Evaluator location value effects (Exports location value) +getExports :: Member (State (Exports location)) effects => Evaluator location value effects (Exports location) getExports = get -- | Set the global export state. -putExports :: Member (State (Exports location value)) effects => Exports location value -> Evaluator location value effects () +putExports :: Member (State (Exports location)) effects => Exports location -> Evaluator location value effects () putExports = put -- | Update the global export state. -modifyExports :: Member (State (Exports location value)) effects => (Exports location value -> Exports location value) -> Evaluator location value effects () +modifyExports :: Member (State (Exports location)) effects => (Exports location -> Exports location) -> Evaluator location value effects () modifyExports = modify' -- | Add an export to the global export state. -addExport :: Member (State (Exports location value)) effects => Name -> Name -> Maybe (Address location value) -> Evaluator location value effects () +addExport :: Member (State (Exports location)) effects => Name -> Name -> Maybe (Address location value) -> Evaluator location 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 location value)) effects => Exports location value -> Evaluator location value effects a -> Evaluator location value effects a +withExports :: Member (State (Exports location)) effects => Exports location -> Evaluator location value effects a -> Evaluator location value effects a withExports = localState . const diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 49fa70fcb..846b533c1 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -24,8 +24,8 @@ import Control.Abstract.Environment import Control.Abstract.Evaluator import Data.Abstract.Address import Data.Abstract.Environment -import Data.Abstract.FreeVariables import Data.Abstract.Heap +import Data.Abstract.Name import Data.Semigroup.Reducer import Prologue @@ -63,8 +63,8 @@ assign address = modifyHeap . heapInsert address -- | Look up or allocate an address for a 'Name'. lookupOrAlloc :: Members '[ Allocator location value - , Reader (Environment location value) - , State (Environment location value) + , Reader (Environment location) + , State (Environment location) ] effects => Name -> Evaluator location value effects (Address location value) @@ -72,8 +72,8 @@ lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure letrec :: ( Members '[ Allocator location value - , Reader (Environment location value) - , State (Environment location value) + , Reader (Environment location) + , State (Environment location) , State (Heap location (Cell location) value) ] effects , Ord location @@ -90,8 +90,8 @@ letrec name body = do -- Lookup/alloc a name passing the address to a body evaluated in a new local environment. letrec' :: Members '[ Allocator location value - , Reader (Environment location value) - , State (Environment location value) + , Reader (Environment location) + , State (Environment location) ] effects => Name -> (Address location value -> Evaluator location value effects value) @@ -104,9 +104,9 @@ letrec' name body = do -- | Look up and dereference the given 'Name', throwing an exception for free variables. variable :: Members '[ Allocator location value - , Reader (Environment location value) + , Reader (Environment location) , Resumable (EnvironmentError value) - , State (Environment location value) + , State (Environment location) , State (Heap location (Cell location) value) ] effects => Name diff --git a/src/Control/Abstract/Modules.hs b/src/Control/Abstract/Modules.hs index 7f83e05ba..89a9c9e88 100644 --- a/src/Control/Abstract/Modules.hs +++ b/src/Control/Abstract/Modules.hs @@ -26,7 +26,7 @@ import Data.Language 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. -lookupModule :: Member (Modules location value) effects => ModulePath -> Evaluator location value effects (Maybe (Maybe (Environment location value, value))) +lookupModule :: Member (Modules location value) effects => ModulePath -> Evaluator location value effects (Maybe (Maybe (Environment location, value))) lookupModule = send . Lookup -- | Resolve a list of module paths to a possible module table entry. @@ -40,19 +40,19 @@ listModulesInDir = sendModules . List -- | Require/import another module by name and return its environment and value. -- -- Looks up the module's name in the cache of evaluated modules first, returns if found, otherwise loads/evaluates the module. -require :: Member (Modules location value) effects => ModulePath -> Evaluator location value effects (Maybe (Environment location value, value)) +require :: Member (Modules location value) effects => ModulePath -> Evaluator location value effects (Maybe (Environment location, value)) require path = lookupModule path >>= maybeM (load path) -- | Load another module by name and return its environment and value. -- -- Always loads/evaluates. -load :: Member (Modules location value) effects => ModulePath -> Evaluator location value effects (Maybe (Environment location value, value)) +load :: Member (Modules location value) effects => ModulePath -> Evaluator location value effects (Maybe (Environment location, value)) load = send . Load data Modules location value return where - Load :: ModulePath -> Modules location value (Maybe (Environment location value, value)) - Lookup :: ModulePath -> Modules location value (Maybe (Maybe (Environment location value, value))) + Load :: ModulePath -> Modules location value (Maybe (Environment location, value)) + Lookup :: ModulePath -> Modules location value (Maybe (Maybe (Environment location, value))) Resolve :: [FilePath] -> Modules location value (Maybe ModulePath) List :: FilePath -> Modules location value [ModulePath] @@ -61,10 +61,10 @@ sendModules = send runModules :: forall term location value effects a . Members '[ Resumable (LoadError location value) - , State (ModuleTable (Maybe (Environment location value, value))) + , State (ModuleTable (Maybe (Environment location, value))) , Trace ] effects - => (Module term -> Evaluator location value (Modules location value ': effects) (Environment location value, value)) + => (Module term -> Evaluator location value (Modules location value ': effects) (Environment location, value)) -> Evaluator location value (Modules location value ': effects) a -> Evaluator location value (Reader (ModuleTable [Module term]) ': effects) a runModules evaluateModule = go @@ -89,17 +89,17 @@ runModules evaluateModule = go pure (find isMember names) List dir -> modulePathsInDir dir <$> askModuleTable @term) -getModuleTable :: Member (State (ModuleTable (Maybe (Environment location value, value)))) effects => Evaluator location value effects (ModuleTable (Maybe (Environment location value, value))) +getModuleTable :: Member (State (ModuleTable (Maybe (Environment location, value)))) effects => Evaluator location value effects (ModuleTable (Maybe (Environment location, value))) getModuleTable = get -cacheModule :: Member (State (ModuleTable (Maybe (Environment location value, value)))) effects => ModulePath -> Maybe (Environment location value, value) -> Evaluator location value effects (Maybe (Environment location value, value)) +cacheModule :: Member (State (ModuleTable (Maybe (Environment location, value)))) effects => ModulePath -> Maybe (Environment location, value) -> Evaluator location value effects (Maybe (Environment location, value)) cacheModule path result = modify' (ModuleTable.insert path result) $> result askModuleTable :: Member (Reader (ModuleTable [Module term])) effects => Evaluator location value effects (ModuleTable [Module term]) askModuleTable = ask -newtype Merging m location value = Merging { runMerging :: m (Maybe (Environment location value, value)) } +newtype Merging m location value = Merging { runMerging :: m (Maybe (Environment location, value)) } instance Applicative m => Semigroup (Merging m location value) where Merging a <> Merging b = Merging (merge <$> a <*> b) @@ -113,7 +113,7 @@ instance Applicative m => Monoid (Merging m location 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 location value resume where - ModuleNotFound :: ModulePath -> LoadError location value (Maybe (Environment location value, value)) + ModuleNotFound :: ModulePath -> LoadError location value (Maybe (Environment location, value)) deriving instance Eq (LoadError location value resume) deriving instance Show (LoadError location value resume) @@ -122,7 +122,7 @@ instance Show1 (LoadError location value) where instance Eq1 (LoadError location value) where liftEq _ (ModuleNotFound a) (ModuleNotFound b) = a == b -moduleNotFound :: Member (Resumable (LoadError location value)) effects => ModulePath -> Evaluator location value effects (Maybe (Environment location value, value)) +moduleNotFound :: Member (Resumable (LoadError location value)) effects => ModulePath -> Evaluator location value effects (Maybe (Environment location, value)) moduleNotFound = throwResumable . ModuleNotFound resumeLoadError :: Member (Resumable (LoadError location value)) effects => Evaluator location value effects a -> (forall resume . LoadError location value resume -> Evaluator location value effects resume) -> Evaluator location value effects a diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs new file mode 100644 index 000000000..a557018b7 --- /dev/null +++ b/src/Control/Abstract/Primitive.hs @@ -0,0 +1,61 @@ +module Control.Abstract.Primitive where + +import Control.Abstract.Addressable +import Control.Abstract.Context +import Control.Abstract.Environment +import Control.Abstract.Evaluator +import Control.Abstract.Heap +import Control.Abstract.Value +import Data.Abstract.Environment +import Data.Abstract.Name +import Data.ByteString.Char8 (pack, unpack) +import Data.Semigroup.Reducer hiding (unit) +import Data.Semilattice.Lower +import Prologue + +builtin :: ( HasCallStack + , Members '[ Allocator location value + , Reader (Environment location) + , Reader ModuleInfo + , Reader Span + , State (Environment location) + , State (Heap location (Cell location) value) + ] effects + , Ord location + , Reducer value (Cell location value) + ) + => String + -> Evaluator location value effects value + -> Evaluator location value effects () +builtin n def = withCurrentCallStack callStack $ do + let name' = name ("__semantic_" <> pack n) + addr <- alloc name' + modifyEnv (insert name' addr) + def >>= assign addr + +lambda :: (AbstractFunction location value effects, Member Fresh effects) + => Set Name + -> (Name -> Evaluator location value effects value) + -> Evaluator location value effects value +lambda fvs body = do + var <- nameI <$> fresh + closure [var] fvs (body var) + +defineBuiltins :: ( AbstractValue location value effects + , HasCallStack + , Members '[ Allocator location value + , Fresh + , Reader (Environment location) + , Reader ModuleInfo + , Reader Span + , Resumable (EnvironmentError value) + , State (Environment location) + , State (Heap location (Cell location) value) + , Trace + ] effects + , Ord location + , Reducer value (Cell location value) + ) + => Evaluator location value effects () +defineBuiltins = + builtin "print" (lambda lowerBound (\ v -> variable v >>= asString >>= trace . unpack >> unit)) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index f99675335..a3add57f0 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -1,12 +1,17 @@ -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE GADTs, Rank2Types #-} module Control.Abstract.Value ( AbstractValue(..) +, AbstractFunction(..) , AbstractHole(..) , Comparator(..) +, asBool , while , doWhile , forLoop , makeNamespace +, evaluateInScopedEnv +, value +, subtermValue , ValueRoots(..) ) where @@ -16,9 +21,10 @@ import Control.Abstract.Evaluator import Control.Abstract.Heap import Data.Abstract.Address (Address) import Data.Abstract.Environment as Env -import Data.Abstract.FreeVariables import Data.Abstract.Live (Live) +import Data.Abstract.Name import Data.Abstract.Number as Number +import Data.Abstract.Ref import Data.Scientific (Scientific) import Data.Semigroup.Reducer hiding (unit) import Data.Semilattice.Lower @@ -38,16 +44,27 @@ data Comparator class AbstractHole value where hole :: value + +class Show value => AbstractFunction location value effects where + -- | Build a closure (a binder like a lambda or method definition). + closure :: [Name] -- ^ The parameter names. + -> Set Name -- ^ The set of free variables to close over. + -> Evaluator location value effects value -- ^ The evaluator for the body of the closure. + -> Evaluator location value effects value + -- | Evaluate an application (like a function call). + call :: value -> [Evaluator location value effects value] -> Evaluator location value effects value + + -- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc). -- -- This allows us to abstract the choice of whether to evaluate under binders for different value types. -class Show value => AbstractValue location value effects where +class AbstractFunction location value effects => AbstractValue location value effects where -- | Construct an abstract unit value. -- TODO: This might be the same as the empty tuple for some value types unit :: Evaluator location value effects value -- | Construct an abstract integral value. - integer :: Prelude.Integer -> Evaluator location value effects value + integer :: Integer -> Evaluator location value effects value -- | Lift a unary operator over a 'Num' to a function on 'value's. liftNumeric :: (forall a . Num a => a -> a) @@ -87,7 +104,7 @@ class Show value => AbstractValue location value effects where float :: Scientific -> Evaluator location value effects value -- | Construct a rational value. - rational :: Prelude.Rational -> Evaluator location value effects value + rational :: Rational -> Evaluator location value effects value -- | Construct an N-ary tuple of multiple (possibly-disjoint) values multiple :: [value] -> Evaluator location value effects value @@ -108,10 +125,7 @@ class Show value => AbstractValue location value effects where asString :: value -> Evaluator location value effects ByteString -- | Eliminate boolean values. TODO: s/boolean/truthy - ifthenelse :: value -> Evaluator location value effects value -> Evaluator location value effects value -> Evaluator location value effects value - - -- | Extract a 'Bool' from a given value. - asBool :: value -> Evaluator location value effects Bool + ifthenelse :: value -> Evaluator location value effects a -> Evaluator location value effects a -> Evaluator location value effects a -- | Construct the nil/null datatype. null :: Evaluator location value effects value @@ -119,32 +133,21 @@ class Show value => AbstractValue location value effects where -- | @index x i@ computes @x[i]@, with zero-indexing. index :: value -> value -> Evaluator location value effects value - -- | Determine whether the given datum is a 'Hole'. - isHole :: value -> Evaluator location value effects Bool - -- | Build a class value from a name and environment. - klass :: Name -- ^ The new class's identifier - -> [value] -- ^ A list of superclasses - -> Environment location value -- ^ The environment to capture + klass :: Name -- ^ The new class's identifier + -> [value] -- ^ A list of superclasses + -> Environment location -- ^ The environment to capture -> Evaluator location value effects value -- | Build a namespace value from a name and environment stack -- -- Namespaces model closures with monoidal environments. - namespace :: Name -- ^ The namespace's identifier - -> Environment location value -- ^ The environment to mappend + namespace :: Name -- ^ The namespace's identifier + -> Environment location -- ^ The environment to mappend -> Evaluator location value effects value -- | Extract the environment from any scoped object (e.g. classes, namespaces, etc). - scopedEnvironment :: value -> Evaluator location value effects (Maybe (Environment location value)) - - -- | Build a closure (a binder like a lambda or method definition). - closure :: [Name] -- ^ The parameter names. - -> Set Name -- ^ The set of free variables to close over. - -> Evaluator location value effects value -- ^ The evaluator for the body of the closure. - -> Evaluator location value effects value - -- | Evaluate an application (like a function call). - call :: value -> [Evaluator location value effects value] -> Evaluator location value effects value + scopedEnvironment :: value -> Evaluator location value effects (Maybe (Environment location)) -- | Primitive looping combinator, approximately equivalent to 'fix'. This should be used in place of direct recursion, as it allows abstraction over recursion. -- @@ -152,9 +155,13 @@ class Show value => AbstractValue location value effects where loop :: (Evaluator location value effects value -> Evaluator location value effects value) -> Evaluator location value effects value --- | Attempt to extract a 'Prelude.Bool' from a given value. +-- | Extract a 'Bool' from a given value. +asBool :: AbstractValue location value effects => value -> Evaluator location value effects Bool +asBool value = ifthenelse value (pure True) (pure False) + +-- | C-style for loops. forLoop :: ( AbstractValue location value effects - , Member (State (Environment location value)) effects + , Member (State (Environment location)) effects ) => Evaluator location value effects value -- ^ Initial statement -> Evaluator location value effects value -- ^ Condition @@ -164,7 +171,7 @@ forLoop :: ( AbstractValue location value effects forLoop initial cond step body = localize (initial *> while cond (body *> step)) --- | The fundamental looping primitive, built on top of ifthenelse. +-- | The fundamental looping primitive, built on top of 'ifthenelse'. while :: AbstractValue location value effects => Evaluator location value effects value -> Evaluator location value effects value @@ -183,7 +190,7 @@ doWhile body cond = loop $ \ continue -> body *> do ifthenelse this continue unit makeNamespace :: ( AbstractValue location value effects - , Member (State (Environment location value)) effects + , Member (State (Environment location)) effects , Member (State (Heap location (Cell location) value)) effects , Ord location , Reducer value (Cell location value) @@ -200,6 +207,47 @@ makeNamespace name addr super = do v <$ assign addr v +-- | Evaluate a term within the context of the scoped environment of 'scopedEnvTerm'. +evaluateInScopedEnv :: ( AbstractValue location value effects + , Member (State (Environment location)) effects + ) + => Evaluator location value effects value + -> Evaluator location value effects value + -> Evaluator location value effects value +evaluateInScopedEnv scopedEnvTerm term = do + scopedEnv <- scopedEnvTerm >>= scopedEnvironment + maybe term (flip localEnv term . mergeEnvs) scopedEnv + + +-- | Evaluates a 'Value' returning the referenced value +value :: ( AbstractValue location value effects + , Members '[ Allocator location value + , Reader (Environment location) + , Resumable (EnvironmentError value) + , State (Environment location) + , State (Heap location (Cell location) value) + ] effects + ) + => ValueRef value + -> Evaluator location value effects value +value (LvalLocal var) = variable var +value (LvalMember obj prop) = evaluateInScopedEnv (pure obj) (variable prop) +value (Rval val) = pure val + +-- | Evaluates a 'Subterm' to its rval +subtermValue :: ( AbstractValue location value effects + , Members '[ Allocator location value + , Reader (Environment location) + , Resumable (EnvironmentError value) + , State (Environment location) + , State (Heap location (Cell location) value) + ] effects + ) + => Subterm term (Evaluator location value effects (ValueRef value)) + -> Evaluator location value effects value +subtermValue = value <=< subtermRef + + -- | Value types, e.g. closures, which can root a set of addresses. class ValueRoots location value where -- | Compute the set of addresses rooted by a given value. diff --git a/src/Data/Abstract/Address.hs b/src/Data/Abstract/Address.hs index c61f712bf..16deab806 100644 --- a/src/Data/Abstract/Address.hs +++ b/src/Data/Abstract/Address.hs @@ -1,8 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-} module Data.Abstract.Address where -import Data.Abstract.FreeVariables import Data.Abstract.Module (ModuleInfo) +import Data.Abstract.Name import Data.Abstract.Package (PackageInfo) import Data.Monoid (Last(..)) import Data.Semigroup.Reducer @@ -35,7 +35,7 @@ newtype Monovariant = Monovariant { unMonovariant :: Name } deriving (Eq, Ord) instance Show Monovariant where - showsPrec d = showsUnaryWith showsPrec "Monovariant" d . unName . unMonovariant + showsPrec d = showsUnaryWith showsPrec "Monovariant" d . unMonovariant data Located location = Located diff --git a/src/Data/Abstract/Cache.hs b/src/Data/Abstract/Cache.hs index 07b50f285..07487b216 100644 --- a/src/Data/Abstract/Cache.hs +++ b/src/Data/Abstract/Cache.hs @@ -1,9 +1,9 @@ {-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, TypeFamilies #-} module Data.Abstract.Cache where -import Control.Abstract.Evaluator import Data.Abstract.Configuration import Data.Abstract.Heap +import Data.Abstract.Ref import Data.Map.Monoidal as Monoidal import Data.Semilattice.Lower import Prologue diff --git a/src/Data/Abstract/Configuration.hs b/src/Data/Abstract/Configuration.hs index 38cfa8632..72913421b 100644 --- a/src/Data/Abstract/Configuration.hs +++ b/src/Data/Abstract/Configuration.hs @@ -6,9 +6,9 @@ import Data.Abstract.Live -- | A single point in a program’s execution. data Configuration term location cell value = Configuration - { configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate. - , configurationRoots :: Live location value -- ^ The set of rooted addresses. - , configurationEnvironment :: Environment location value -- ^ The environment binding any free variables in 'configurationTerm'. - , configurationHeap :: Heap location cell value -- ^ The heap of values. + { configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate. + , configurationRoots :: Live location value -- ^ The set of rooted addresses. + , configurationEnvironment :: Environment location -- ^ The environment binding any free variables in 'configurationTerm'. + , configurationHeap :: Heap location cell value -- ^ The heap of values. } deriving (Eq, Ord, Show) diff --git a/src/Data/Abstract/Declarations.hs b/src/Data/Abstract/Declarations.hs index 00a46aaf3..a15c74f04 100644 --- a/src/Data/Abstract/Declarations.hs +++ b/src/Data/Abstract/Declarations.hs @@ -2,6 +2,7 @@ module Data.Abstract.Declarations where import Data.Abstract.FreeVariables +import Data.Abstract.Name import Data.Sum import Data.Term import Prologue diff --git a/src/Data/Abstract/Environment.hs b/src/Data/Abstract/Environment.hs index eb74a724e..924df9d4a 100644 --- a/src/Data/Abstract/Environment.hs +++ b/src/Data/Abstract/Environment.hs @@ -19,8 +19,8 @@ module Data.Abstract.Environment ) where import Data.Abstract.Address -import Data.Abstract.FreeVariables import Data.Abstract.Live +import Data.Abstract.Name import Data.Align import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as Map @@ -35,36 +35,32 @@ import Prologue -- | A LIFO stack of maps of names to addresses, representing a lexically-scoped evaluation environment. -- All behaviors can be assumed to be frontmost-biased: looking up "a" will check the most specific -- scope for "a", then the next, and so on. -newtype Environment location value = Environment { unEnvironment :: NonEmpty (Map.Map Name (Address location value)) } +newtype Environment location = Environment { unEnvironment :: NonEmpty (Map.Map Name location) } deriving (Eq, Ord) -instance Eq location => Eq1 (Environment location) where liftEq eq (Environment a) (Environment b) = liftEq (liftEq (liftEq eq)) a b -instance Ord location => Ord1 (Environment location) where liftCompare compare (Environment a) (Environment b) = liftCompare (liftCompare (liftCompare compare)) a b -instance Show location => Show1 (Environment location) where liftShowsPrec _ _ = showsPrec - -mergeEnvs :: Environment location value -> Environment location value -> Environment location value +mergeEnvs :: Environment location -> Environment location -> Environment location mergeEnvs (Environment (a :| as)) (Environment (b :| bs)) = Environment ((<>) a b :| alignWith (mergeThese (<>)) as bs) -emptyEnv :: Environment location value +emptyEnv :: Environment location emptyEnv = Environment (lowerBound :| []) -- | Make and enter a new empty scope in the given environment. -push :: Environment location value -> Environment location value +push :: Environment location -> Environment location push (Environment (a :| as)) = Environment (mempty :| a : as) -- | Remove the frontmost scope. -pop :: Environment location value -> Environment location value +pop :: Environment location -> Environment location pop (Environment (_ :| [])) = emptyEnv pop (Environment (_ :| a : as)) = Environment (a :| as) -- | Drop all scopes save for the frontmost one. -head :: Environment location value -> Environment location value +head :: Environment location -> Environment location head (Environment (a :| _)) = Environment (a :| []) -- | Take the union of two environments. When duplicate keys are found in the -- name to address map, the second definition wins. -mergeNewer :: Environment location value -> Environment location value -> Environment location value +mergeNewer :: Environment location -> Environment location -> Environment location mergeNewer (Environment a) (Environment b) = Environment (NonEmpty.fromList . reverse $ alignWith (mergeThese combine) (reverse as) (reverse bs)) where @@ -76,45 +72,45 @@ mergeNewer (Environment a) (Environment b) = -- -- >>> pairs shadowed -- [("foo",Precise 1)] -pairs :: Environment location value -> [(Name, Address location value)] -pairs = Map.toList . fold . unEnvironment +pairs :: Environment location -> [(Name, Address location value)] +pairs = map (second Address) . Map.toList . fold . unEnvironment -unpairs :: [(Name, Address location value)] -> Environment location value -unpairs = Environment . pure . Map.fromList +unpairs :: [(Name, Address location value)] -> Environment location +unpairs = Environment . pure . Map.fromList . map (second unAddress) -- | Lookup a 'Name' in the environment. -- -- >>> lookup (name "foo") shadowed -- Just (Precise 1) -lookup :: Name -> Environment location value -> Maybe (Address location value) -lookup k = foldMapA (Map.lookup k) . unEnvironment +lookup :: Name -> Environment location -> Maybe (Address location value) +lookup k = fmap Address . foldMapA (Map.lookup k) . unEnvironment -- | Insert a 'Name' in the environment. -insert :: Name -> Address location value -> Environment location value -> Environment location value -insert name address (Environment (a :| as)) = Environment (Map.insert name address a :| as) +insert :: Name -> Address location value -> Environment location -> Environment location +insert name (Address value) (Environment (a :| as)) = Environment (Map.insert name value a :| as) -- | Remove a 'Name' from the environment. -- -- >>> delete (name "foo") shadowed -- Environment [] -delete :: Name -> Environment location value -> Environment location value +delete :: Name -> Environment location -> Environment location delete name = trim . Environment . fmap (Map.delete name) . unEnvironment -trim :: Environment location value -> Environment location value +trim :: Environment location -> Environment location trim (Environment (a :| as)) = Environment (a :| filtered) where filtered = filter (not . Map.null) as -bind :: Foldable t => t Name -> Environment location value -> Environment location value +bind :: Foldable t => t Name -> Environment location -> Environment location bind names env = unpairs (mapMaybe lookupName (toList names)) where lookupName name = (,) name <$> lookup name env -- | Get all bound 'Name's in an environment. -names :: Environment location value -> [Name] +names :: Environment location -> [Name] names = fmap fst . pairs -- | Lookup and alias name-value bindings from an environment. -overwrite :: [(Name, Name)] -> Environment location value -> Environment location value +overwrite :: [(Name, Name)] -> Environment location -> Environment location overwrite pairs env = unpairs $ mapMaybe lookupAndAlias pairs where lookupAndAlias (oldName, newName) = (,) newName <$> lookup oldName env @@ -122,14 +118,14 @@ overwrite pairs env = unpairs $ mapMaybe lookupAndAlias pairs -- | Retrieve the 'Live' set of addresses to which the given free variable names are bound. -- -- Unbound names are silently dropped. -roots :: (Ord location, Foldable t) => Environment location value -> t Name -> Live location value +roots :: (Ord location, Foldable t) => Environment location -> t Name -> Live location value roots env = foldMap (maybe mempty liveSingleton . flip lookup env) -addresses :: Ord location => Environment location value -> Live location value +addresses :: Ord location => Environment location -> Live location value addresses = fromAddresses . map snd . pairs -instance Lower (Environment location value) where lowerBound = emptyEnv +instance Lower (Environment location) where lowerBound = emptyEnv -instance Show location => Show (Environment location value) where - showsPrec d = showsUnaryWith showsPrec "Environment" d . map (first unName) . pairs +instance Show location => Show (Environment location) where + showsPrec d = showsUnaryWith showsPrec "Environment" d . pairs diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 78902a60b..c24ba25ce 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -2,36 +2,37 @@ module Data.Abstract.Evaluatable ( module X , Evaluatable(..) +, evaluatePackageWith +, isolate +, traceResolve +-- | Effects +, EvalError(..) +, throwEvalError +, runEvalError +, runEvalErrorWith , Unspecialized(..) , runUnspecialized , runUnspecializedWith -, EvalError(..) -, runEvalError -, runEvalErrorWith -, value -, subtermValue -, evaluateInScopedEnv -, evaluatePackageWith -, throwEvalError -, traceResolve -, builtin -, isolate -, Modules +, Cell ) where -import Control.Abstract as X hiding (Goto(..), LoopControl(..), Modules(..), Return(..), TermEvaluator(..)) -import Control.Abstract.Evaluator (LoopControl, Return(..)) -import Control.Abstract.Goto (Goto(..)) -import Control.Abstract.Modules (Modules(..)) -import Control.Abstract.TermEvaluator (TermEvaluator(..)) +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 +import Data.Abstract.Name as X import Data.Abstract.Package as Package -import Data.ByteString.Char8 (pack, unpack) +import Data.Abstract.Ref as X import Data.Scientific (Scientific) import Data.Semigroup.App import Data.Semigroup.Foldable @@ -57,17 +58,17 @@ type EvaluatableConstraints location term value effects = , Members '[ Allocator location value , LoopControl value , Modules location value - , Reader (Environment location value) + , Reader (Environment location) , Reader ModuleInfo , Reader PackageInfo , Reader Span , Resumable (EnvironmentError value) - , Resumable (EvalError value) + , Resumable EvalError , Resumable ResolutionError , Resumable (Unspecialized value) , Return value - , State (Environment location value) - , State (Exports location value) + , State (Environment location) + , State (Exports location) , State (Heap location (Cell location) value) , Trace ] effects @@ -76,148 +77,6 @@ type EvaluatableConstraints location term value effects = ) --- | The type of error thrown when failing to evaluate a term. -data EvalError value resume where - FreeVariablesError :: [Name] -> EvalError value Name - -- Indicates that our evaluator wasn't able to make sense of these literals. - IntegerFormatError :: ByteString -> EvalError value Integer - FloatFormatError :: ByteString -> EvalError value Scientific - RationalFormatError :: ByteString -> EvalError value Rational - DefaultExportError :: EvalError value () - ExportError :: ModulePath -> Name -> EvalError value () - EnvironmentLookupError :: value -> EvalError value value - -runEvalError :: Effectful (m value) => m value (Resumable (EvalError value) ': effects) a -> m value effects (Either (SomeExc (EvalError value)) a) -runEvalError = runResumable - -runEvalErrorWith :: Effectful (m value) => (forall resume . EvalError value resume -> m value effects resume) -> m value (Resumable (EvalError value) ': effects) a -> m value effects a -runEvalErrorWith = runResumableWith - --- | Evaluate a term within the context of the scoped environment of 'scopedEnvTerm'. --- Throws an 'EnvironmentLookupError' if @scopedEnvTerm@ does not have an environment. -evaluateInScopedEnv :: ( AbstractValue location value effects - , Members '[ Resumable (EvalError value) - , State (Environment location value) - ] effects - ) - => Evaluator location value effects value - -> Evaluator location value effects value - -> Evaluator location value effects value -evaluateInScopedEnv scopedEnvTerm term = do - value <- scopedEnvTerm - scopedEnv <- scopedEnvironment value - maybe (throwEvalError (EnvironmentLookupError value)) (flip localEnv term . mergeEnvs) scopedEnv - -deriving instance Eq a => Eq (EvalError a b) -deriving instance Show a => Show (EvalError a b) -instance Show value => Show1 (EvalError value) where - liftShowsPrec _ _ = showsPrec -instance Eq term => Eq1 (EvalError term) where - liftEq _ (FreeVariablesError a) (FreeVariablesError b) = a == b - liftEq _ DefaultExportError DefaultExportError = True - liftEq _ (ExportError a b) (ExportError c d) = (a == c) && (b == d) - liftEq _ (IntegerFormatError a) (IntegerFormatError b) = a == b - liftEq _ (FloatFormatError a) (FloatFormatError b) = a == b - liftEq _ (RationalFormatError a) (RationalFormatError b) = a == b - liftEq _ (EnvironmentLookupError a) (EnvironmentLookupError b) = a == b - liftEq _ _ _ = False - - -throwEvalError :: Member (Resumable (EvalError value)) effects => EvalError value resume -> Evaluator location value effects resume -throwEvalError = throwResumable - - -data Unspecialized a b where - Unspecialized :: Prelude.String -> Unspecialized value (ValueRef value) - -instance Eq1 (Unspecialized a) where - liftEq _ (Unspecialized a) (Unspecialized b) = a == b - -deriving instance Eq (Unspecialized a b) -deriving instance Show (Unspecialized a b) -instance Show1 (Unspecialized a) where - liftShowsPrec _ _ = showsPrec - --- | Evaluates a 'Value' returning the referenced value -value :: ( AbstractValue location value effects - , Members '[ Allocator location value - , Reader (Environment location value) - , Resumable (EnvironmentError value) - , Resumable (EvalError value) - , State (Environment location value) - , State (Heap location (Cell location) value) - ] effects - ) - => ValueRef value - -> Evaluator location value effects value -value (LvalLocal var) = variable var -value (LvalMember obj prop) = evaluateInScopedEnv (pure obj) (variable prop) -value (Rval val) = pure val - --- | Evaluates a 'Subterm' to its rval -subtermValue :: ( AbstractValue location value effects - , Members '[ Allocator location value - , Reader (Environment location value) - , Resumable (EnvironmentError value) - , Resumable (EvalError value) - , State (Environment location value) - , State (Heap location (Cell location) value) - ] effects - ) - => Subterm term (Evaluator location value effects (ValueRef value)) - -> Evaluator location value effects value -subtermValue = value <=< subtermRef - -runUnspecialized :: Effectful (m value) => m value (Resumable (Unspecialized value) ': effects) a -> m value effects (Either (SomeExc (Unspecialized value)) a) -runUnspecialized = runResumable - -runUnspecializedWith :: Effectful (m value) => (forall resume . Unspecialized value resume -> m value effects resume) -> m value (Resumable (Unspecialized value) ': effects) a -> m value effects a -runUnspecializedWith = runResumableWith - --- Instances - --- | If we can evaluate any syntax which can occur in a 'Sum', we can evaluate the 'Sum'. -instance Apply Evaluatable fs => Evaluatable (Sum fs) where - eval = apply @Evaluatable eval - --- | Evaluating a 'TermF' ignores its annotation, evaluating the underlying syntax. -instance Evaluatable s => Evaluatable (TermF s a) where - eval = eval . termFOut - ---- | '[]' is treated as an imperative sequence of statements/declarations s.t.: ---- ---- 1. Each statement’s effects on the store are accumulated; ---- 2. Each statement can affect the environment of later statements (e.g. by 'modify'-ing the environment); and ---- 3. Only the last statement’s return value is returned. -instance Evaluatable [] where - -- 'nonEmpty' and 'foldMap1' enable us to return the last statement’s result instead of 'unit' for non-empty lists. - eval = maybe (Rval <$> unit) (runApp . foldMap1 (App . subtermRef)) . nonEmpty - - -traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator location value effects () -traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path) - - -builtin :: ( HasCallStack - , Members '[ Allocator location value - , Reader (Environment location value) - , Reader ModuleInfo - , Reader Span - , State (Environment location value) - , State (Heap location (Cell location) value) - ] effects - , Ord location - , Reducer value (Cell location value) - ) - => String - -> Evaluator location value effects value - -> Evaluator location value effects () -builtin n def = withCurrentCallStack callStack $ do - let name = X.name ("__semantic_" <> pack n) - addr <- alloc name - modifyEnv (X.insert name addr) - def >>= assign addr - -- | Evaluate a given package. evaluatePackageWith :: forall location term value 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? If not, can we factor this effect list out? @@ -226,13 +85,13 @@ evaluatePackageWith :: forall location term value inner inner' outer , EvaluatableConstraints location term value inner , Members '[ Fail , Fresh - , Reader (Environment location value) + , Reader (Environment location) , Resumable (AddressError location value) , Resumable (LoadError location value) - , State (Environment location value) - , State (Exports location value) + , State (Environment location) + , State (Exports location) , State (Heap location (Cell location) value) - , State (ModuleTable (Maybe (Environment location value, value))) + , State (ModuleTable (Maybe (Environment location, value))) , Trace ] outer , Recursive term @@ -273,9 +132,7 @@ evaluatePackageWith analyzeModule analyzeTerm package maybe v ((`call` []) <=< variable) sym evalPrelude prelude = raiseHandler (runModules (runTermEvaluator . evalModule)) $ do - _ <- runInModule moduleInfoFromCallStack . TermEvaluator $ do - builtin "print" (closure ["s"] lowerBound (variable "s" >>= asString >>= trace . unpack >> unit)) - unit + _ <- runInModule moduleInfoFromCallStack (TermEvaluator (defineBuiltins *> unit)) fst <$> evalModule prelude withPrelude Nothing a = a @@ -296,5 +153,84 @@ newtype Gotos location value outer = Gotos { getGotos :: GotoTable (LoopControl -- | Isolate the given action with an empty global environment and exports. -isolate :: Members '[State (Environment location value), State (Exports location value)] effects => Evaluator location value effects a -> Evaluator location value effects a +isolate :: Members '[State (Environment location), State (Exports location)] effects => Evaluator location value effects a -> Evaluator location value effects a isolate = withEnv lowerBound . withExports lowerBound + +traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator location value effects () +traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path) + + +-- Effects + +-- | The type of error thrown when failing to evaluate a term. +data EvalError return where + FreeVariablesError :: [Name] -> EvalError Name + -- Indicates that our evaluator wasn't able to make sense of these literals. + IntegerFormatError :: ByteString -> EvalError Integer + FloatFormatError :: ByteString -> EvalError Scientific + RationalFormatError :: ByteString -> EvalError Rational + DefaultExportError :: EvalError () + ExportError :: ModulePath -> Name -> EvalError () + +deriving instance Eq (EvalError return) +deriving instance Show (EvalError return) + +instance Eq1 EvalError where + liftEq _ (FreeVariablesError a) (FreeVariablesError b) = a == b + liftEq _ DefaultExportError DefaultExportError = True + liftEq _ (ExportError a b) (ExportError c d) = (a == c) && (b == d) + liftEq _ (IntegerFormatError a) (IntegerFormatError b) = a == b + liftEq _ (FloatFormatError a) (FloatFormatError b) = a == b + liftEq _ (RationalFormatError a) (RationalFormatError b) = a == b + liftEq _ _ _ = False + +instance Show1 EvalError where + liftShowsPrec _ _ = showsPrec + +throwEvalError :: (Effectful m, Member (Resumable EvalError) effects) => EvalError resume -> m effects resume +throwEvalError = throwResumable + +runEvalError :: Effectful m => m (Resumable EvalError ': effects) a -> m effects (Either (SomeExc EvalError) a) +runEvalError = runResumable + +runEvalErrorWith :: Effectful m => (forall resume . EvalError resume -> m effects resume) -> m (Resumable EvalError ': effects) a -> m effects a +runEvalErrorWith = runResumableWith + + +data Unspecialized a b where + Unspecialized :: String -> Unspecialized value (ValueRef value) + +deriving instance Eq (Unspecialized a b) +deriving instance Show (Unspecialized a b) + +instance Eq1 (Unspecialized a) where + liftEq _ (Unspecialized a) (Unspecialized b) = a == b + +instance Show1 (Unspecialized a) where + liftShowsPrec _ _ = showsPrec + +runUnspecialized :: Effectful (m value) => m value (Resumable (Unspecialized value) ': effects) a -> m value effects (Either (SomeExc (Unspecialized value)) a) +runUnspecialized = runResumable + +runUnspecializedWith :: Effectful (m value) => (forall resume . Unspecialized value resume -> m value effects resume) -> m value (Resumable (Unspecialized value) ': effects) a -> m value effects a +runUnspecializedWith = runResumableWith + + +-- Instances + +-- | If we can evaluate any syntax which can occur in a 'Sum', we can evaluate the 'Sum'. +instance Apply Evaluatable fs => Evaluatable (Sum fs) where + eval = apply @Evaluatable eval + +-- | Evaluating a 'TermF' ignores its annotation, evaluating the underlying syntax. +instance Evaluatable s => Evaluatable (TermF s a) where + eval = eval . termFOut + +--- | '[]' is treated as an imperative sequence of statements/declarations s.t.: +--- +--- 1. Each statement’s effects on the store are accumulated; +--- 2. Each statement can affect the environment of later statements (e.g. by 'modify'-ing the environment); and +--- 3. Only the last statement’s return value is returned. +instance Evaluatable [] where + -- 'nonEmpty' and 'foldMap1' enable us to return the last statement’s result instead of 'unit' for non-empty lists. + eval = maybe (Rval <$> unit) (runApp . foldMap1 (App . subtermRef)) . nonEmpty diff --git a/src/Data/Abstract/Exports.hs b/src/Data/Abstract/Exports.hs index 09dea7aaf..4c71e508d 100644 --- a/src/Data/Abstract/Exports.hs +++ b/src/Data/Abstract/Exports.hs @@ -11,30 +11,27 @@ import Prelude hiding (null) import Prologue hiding (null) import Data.Abstract.Address import Data.Abstract.Environment (Environment, unpairs) -import Data.Abstract.FreeVariables +import Data.Abstract.Name import qualified Data.Map as Map import Data.Semilattice.Lower -- | A map of export names to an alias & address tuple. -newtype Exports location value = Exports { unExports :: Map.Map Name (Name, Maybe (Address location value)) } +newtype Exports location = Exports { unExports :: Map.Map Name (Name, Maybe location) } deriving (Eq, Lower, Monoid, Ord, Semigroup) -null :: Exports location value -> Bool +null :: Exports location -> Bool null = Map.null . unExports -toEnvironment :: Exports location value -> Environment location value -toEnvironment exports = unpairs (mapMaybe collectExport (toList (unExports exports))) - where - collectExport (_, Nothing) = Nothing - collectExport (n, Just value) = Just (n, value) +toEnvironment :: Exports location -> Environment location +toEnvironment exports = unpairs (mapMaybe (traverse (fmap Address)) (toList (unExports exports))) -insert :: Name -> Name -> Maybe (Address location value) -> Exports location value -> Exports location value -insert name alias address = Exports . Map.insert name (alias, address) . unExports +insert :: Name -> Name -> Maybe (Address location value) -> Exports location -> Exports location +insert name alias address = Exports . Map.insert name (alias, unAddress <$> address) . unExports -- TODO: Should we filter for duplicates here? -aliases :: Exports location value -> [(Name, Name)] +aliases :: Exports location -> [(Name, Name)] aliases = Map.toList . fmap fst . unExports -instance Show location => Show (Exports location value) where +instance Show location => Show (Exports location) where showsPrec d = showsUnaryWith showsPrec "Exports" d . Map.toList . unExports diff --git a/src/Data/Abstract/FreeVariables.hs b/src/Data/Abstract/FreeVariables.hs index a8dbfafb3..ddf54b02e 100644 --- a/src/Data/Abstract/FreeVariables.hs +++ b/src/Data/Abstract/FreeVariables.hs @@ -1,25 +1,11 @@ {-# LANGUAGE DefaultSignatures, GeneralizedNewtypeDeriving, UndecidableInstances #-} module Data.Abstract.FreeVariables where -import qualified Data.ByteString.Char8 as BC -import Data.String +import Data.Abstract.Name import Data.Sum import Data.Term import Prologue --- | The type of variable names. -newtype Name = Name { unName :: ByteString } - deriving (Eq, Hashable, Ord) - -name :: ByteString -> Name -name = Name - -instance IsString Name where - fromString = Name . BC.pack - -instance Show Name where showsPrec d (Name str) = showsPrec d str - - -- | Types which can contain unbound variables. class FreeVariables term where -- | The set of free variables in the given value. diff --git a/src/Data/Abstract/Name.hs b/src/Data/Abstract/Name.hs new file mode 100644 index 000000000..46bf635ee --- /dev/null +++ b/src/Data/Abstract/Name.hs @@ -0,0 +1,55 @@ +module Data.Abstract.Name +( Name +-- * Constructors +, name +, nameI +, unName +) where + +import qualified Data.ByteString.Char8 as BC +import qualified Data.Char as Char +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.String +import Prologue + +-- | The type of variable names. +data Name + = Name ByteString + | I Int + deriving (Eq, Ord) + +-- | Construct a 'Name' from a 'ByteString'. +name :: ByteString -> Name +name = Name + +-- | Construct a 'Name' from an 'Int'. This is suitable for automatic generation, e.g. using a Fresh effect, but should not be used for human-generated names. +nameI :: Int -> Name +nameI = I + +-- | Extract a human-readable 'ByteString' from a 'Name'. +unName :: Name -> ByteString +unName (Name name) = name +unName (I i) = Text.encodeUtf8 . Text.pack $ '_' : (alphabet !! a) : replicate n 'ʹ' + where alphabet = ['a'..'z'] + (n, a) = i `divMod` length alphabet + +instance IsString Name where + fromString = Name . BC.pack + +-- $ +-- >>> I 0 +-- "_a" +-- >>> I 26 +-- "_aʹ" +instance Show Name where + showsPrec _ = prettyShowString . Text.unpack . Text.decodeUtf8 . unName + where prettyShowString str = showChar '"' . foldr ((.) . prettyChar) id str . showChar '"' + prettyChar c + | c `elem` ['\\', '\"'] = Char.showLitChar c + | Char.isPrint c = showChar c + | otherwise = Char.showLitChar c + +instance Hashable Name where + hashWithSalt salt (Name name) = hashWithSalt salt name + hashWithSalt salt (I i) = salt `hashWithSalt` (1 :: Int) `hashWithSalt` i diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index 6fddde453..c95ec8d57 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -1,10 +1,10 @@ {-# LANGUAGE TupleSections #-} module Data.Abstract.Package where -import Data.Abstract.FreeVariables import Data.Abstract.Module import Data.Abstract.ModuleTable as ModuleTable import qualified Data.Map as Map +import Data.Abstract.Name type PackageName = Name diff --git a/src/Data/Abstract/Ref.hs b/src/Data/Abstract/Ref.hs new file mode 100644 index 000000000..c7412cde4 --- /dev/null +++ b/src/Data/Abstract/Ref.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE GADTs #-} +module Data.Abstract.Ref where + +import Data.Abstract.Name + +-- | 'ValueRef' is the type subterms evaluate to and can represent either values directly ('Rval'), or references to values (lvals - such as local variables or object members) +data ValueRef value where + -- | A value. + Rval :: value -> ValueRef value + -- | A local variable. No environment is attached—it’s assumed that 'LvalLocal' will be evaluated in the same scope it was constructed in. + LvalLocal :: Name -> ValueRef value + -- | An object member. + LvalMember :: value -> Name -> ValueRef value + deriving (Eq, Ord, Show) diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 252c60fb7..5f381f3eb 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -9,7 +9,6 @@ module Data.Abstract.Type import Control.Abstract import Data.Abstract.Environment as Env -import Data.Abstract.Evaluatable import Data.Semigroup.Foldable (foldMap1) import Data.Semigroup.Reducer (Reducer) import Prologue hiding (TypeError) @@ -102,22 +101,19 @@ instance Ord location => ValueRoots location Type where instance AbstractHole Type where hole = Hole --- | Discard the value arguments (if any), constructing a 'Type' instead. instance ( Members '[ Allocator location Type , Fresh , NonDet - , Reader (Environment location Type) - , Resumable (AddressError location Type) - , Resumable (EvalError Type) + , Reader (Environment location) , Resumable TypeError , Return Type - , State (Environment location Type) + , State (Environment location) , State (Heap location (Cell location) Type) ] effects , Ord location , Reducer Type (Cell location Type) ) - => AbstractValue location Type effects where + => AbstractFunction location Type effects where closure names _ body = do (env, tvars) <- foldr (\ name rest -> do a <- alloc name @@ -126,6 +122,30 @@ instance ( Members '[ Allocator location Type bimap (Env.insert name a) (tvar :) <$> rest) (pure (emptyEnv, [])) names (zeroOrMoreProduct tvars :->) <$> localEnv (mergeEnvs env) (body `catchReturn` \ (Return value) -> pure value) + call op params = do + tvar <- fresh + paramTypes <- sequenceA params + let needed = zeroOrMoreProduct paramTypes :-> Var tvar + unified <- op `unify` needed + case unified of + _ :-> ret -> pure ret + gotten -> throwResumable (UnificationError needed gotten) + + +-- | Discard the value arguments (if any), constructing a 'Type' instead. +instance ( Members '[ Allocator location Type + , Fresh + , NonDet + , Reader (Environment location) + , Resumable TypeError + , Return Type + , State (Environment location) + , State (Heap location (Cell location) Type) + ] effects + , Ord location + , Reducer Type (Cell location Type) + ) + => AbstractValue location Type effects where unit = pure Unit integer _ = pure Int boolean _ = pure Bool @@ -152,9 +172,6 @@ instance ( Members '[ Allocator location Type t1 <- fresh t2 <- fresh unify t (Var t1 :* Var t2) $> (Var t1, Var t2) - asBool t = unify t Bool *> (pure True <|> pure False) - - isHole ty = pure (ty == Hole) index arr sub = do _ <- unify sub Int @@ -181,13 +198,4 @@ instance ( Members '[ Allocator location Type (Int, Float) -> pure Int _ -> unify left right $> Bool - call op params = do - tvar <- fresh - paramTypes <- sequenceA params - let needed = zeroOrMoreProduct paramTypes :-> Var tvar - unified <- op `unify` needed - case unified of - _ :-> ret -> pure ret - gotten -> throwResumable (UnificationError needed gotten) - loop f = f empty diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 34d329e7f..43e8c72cc 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -4,7 +4,7 @@ module Data.Abstract.Value where import Control.Abstract import Data.Abstract.Environment (Environment, emptyEnv, mergeEnvs) import qualified Data.Abstract.Environment as Env -import Data.Abstract.FreeVariables +import Data.Abstract.Name import qualified Data.Abstract.Number as Number import Data.List (genericIndex, genericLength) import Data.Scientific (Scientific) @@ -57,7 +57,7 @@ prjPair = bitraverse prjValue prjValue -- TODO: Parameterize Value by the set of constructors s.t. each language can have a distinct value union. -- | A function value consisting of a package & module info, a list of parameter 'Name's, a 'Label' to jump to the body of the function, and an 'Environment' of bindings captured by the body. -data Closure location value = Closure PackageInfo ModuleInfo [Name] Label (Environment location value) +data Closure location value = Closure PackageInfo ModuleInfo [Name] Label (Environment location) deriving (Eq, Generic1, Ord, Show) instance Eq location => Eq1 (Closure location) where liftEq = genericLiftEq @@ -80,7 +80,7 @@ instance Ord1 Hole where liftCompare = genericLiftCompare instance Show1 Hole where liftShowsPrec = genericLiftShowsPrec -- | Boolean values. -newtype Boolean value = Boolean Prelude.Bool +newtype Boolean value = Boolean { getBoolean :: Bool } deriving (Eq, Generic1, Ord, Show) instance Eq1 Boolean where liftEq = genericLiftEq @@ -151,7 +151,7 @@ instance Show1 Array where liftShowsPrec = genericLiftShowsPrec -- but for the time being we're pretending all languages have prototypical inheritance. data Class location value = Class { _className :: Name - , _classScope :: Environment location value + , _classScope :: Environment location } deriving (Eq, Generic1, Ord, Show) instance Eq location => Eq1 (Class location) where liftEq = genericLiftEq @@ -160,7 +160,7 @@ instance Show location => Show1 (Class location) where liftShowsPrec = genericLi data Namespace location value = Namespace { namespaceName :: Name - , namespaceScope :: Environment location value + , namespaceScope :: Environment location } deriving (Eq, Generic1, Ord, Show) instance Eq location => Eq1 (Namespace location) where liftEq = genericLiftEq @@ -204,16 +204,51 @@ instance Ord location => ValueRoots location (Value location) where instance AbstractHole (Value location) where hole = injValue Hole --- | Construct a 'Value' wrapping the value arguments (if any). instance ( Members '[ Allocator location (Value location) - , Fail - , LoopControl (Value location) - , Reader (Environment location (Value location)) + , Reader (Environment location) , Reader ModuleInfo , Reader PackageInfo , Resumable (ValueError location) , Return (Value location) - , State (Environment location (Value location)) + , State (Environment location) + , State (Heap location (Cell location) (Value location)) + ] effects + , Ord location + , Reducer (Value location) (Cell location (Value location)) + , Show location + ) + => AbstractFunction location (Value location) (Goto effects (Value location) ': effects) where + closure parameters freeVariables body = do + packageInfo <- currentPackage + moduleInfo <- currentModule + l <- label body + injValue . Closure packageInfo moduleInfo parameters l . Env.bind (foldr Set.delete freeVariables parameters) <$> getEnv + + call op params = do + case prjValue op of + Just (Closure packageInfo moduleInfo names label env) -> do + body <- goto label + -- Evaluate the bindings and body with the closure’s package/module info in scope in order to + -- charge them to the closure's origin. + withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do + bindings <- foldr (\ (name, param) rest -> do + v <- param + a <- alloc name + assign a v + Env.insert name a <$> rest) (pure env) (zip names params) + localEnv (mergeEnvs bindings) (body `catchReturn` \ (Return value) -> pure value) + Nothing -> throwValueError (CallError op) + + +-- | Construct a 'Value' wrapping the value arguments (if any). +instance ( Members '[ Allocator location (Value location) + , LoopControl (Value location) + , Reader (Environment location) + , Reader ModuleInfo + , Reader PackageInfo + , Resumable (ValueError location) + , Return (Value location) + , State (Environment location) , State (Heap location (Cell location) (Value location)) ] effects , Ord location @@ -265,18 +300,8 @@ instance ( Members '[ Allocator location (Value location) | otherwise = throwValueError $ StringError v ifthenelse cond if' else' = do - isHole <- isHole cond - if isHole then - pure hole - else do - bool <- asBool cond - if bool then if' else else' - - asBool val - | Just (Boolean b) <- prjValue val = pure b - | otherwise = throwValueError $ BoolError val - - isHole val = pure (prjValue val == Just Hole) + bool <- maybe (throwValueError (BoolError cond)) (pure . getBoolean) (prjValue cond) + if bool then if' else else' index = go where tryIdx list ii @@ -348,27 +373,6 @@ instance ( Members '[ Allocator location (Value location) | otherwise = throwValueError (Bitwise2Error left right) where pair = (left, right) - closure parameters freeVariables body = do - packageInfo <- currentPackage - moduleInfo <- currentModule - l <- label body - injValue . Closure packageInfo moduleInfo parameters l . Env.bind (foldr Set.delete freeVariables parameters) <$> getEnv - - call op params = do - case prjValue op of - Just (Closure packageInfo moduleInfo names label env) -> do - body <- goto label - -- Evaluate the bindings and body with the closure’s package/module info in scope in order to - -- charge them to the closure's origin. - withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do - bindings <- foldr (\ (name, param) rest -> do - v <- param - a <- alloc name - assign a v - Env.insert name a <$> rest) (pure env) (zip names params) - localEnv (mergeEnvs bindings) (body `catchReturn` \ (Return value) -> pure value) - Nothing -> throwValueError (CallError op) - loop x = catchLoopControl (fix x) (\ control -> case control of Break value -> pure value -- FIXME: Figure out how to deal with this. Ruby treats this as the result of the current block iteration, while PHP specifies a breakout level and TypeScript appears to take a label. @@ -380,7 +384,7 @@ data ValueError location resume where StringError :: Value location -> ValueError location ByteString BoolError :: Value location -> ValueError location Bool IndexError :: Value location -> Value location -> ValueError location (Value location) - NamespaceError :: Prelude.String -> ValueError location (Environment location (Value location)) + NamespaceError :: Prelude.String -> ValueError location (Environment location) CallError :: Value location -> ValueError location (Value location) NumericError :: Value location -> ValueError location (Value location) Numeric2Error :: Value location -> Value location -> ValueError location (Value location) diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index 4d8bc20b9..2e748adb6 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances, ViewPatterns #-} module Data.Syntax.Statement where -import Control.Abstract.Evaluator (ValueRef(..)) import qualified Data.Abstract.Environment as Env import Data.Abstract.Evaluatable import Data.ByteString.Char8 (unpack) diff --git a/src/Language/Go/Assignment.hs b/src/Language/Go/Assignment.hs index c6f275fa6..a7e6cc44f 100644 --- a/src/Language/Go/Assignment.hs +++ b/src/Language/Go/Assignment.hs @@ -7,7 +7,7 @@ module Language.Go.Assignment ) where import Assigning.Assignment hiding (Assignment, Error) -import Data.Abstract.FreeVariables (name) +import Data.Abstract.Name (name) import Data.Record import Data.Syntax (contextualize, emptyTerm, parseError, handleError, infixContext, makeTerm, makeTerm', makeTerm'', makeTerm1) import Language.Go.Grammar as Grammar diff --git a/src/Language/Go/Syntax.hs b/src/Language/Go/Syntax.hs index 0329ecad3..4d4c9d11f 100644 --- a/src/Language/Go/Syntax.hs +++ b/src/Language/Go/Syntax.hs @@ -1,8 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} module Language.Go.Syntax where -import Data.Abstract.Evaluatable hiding (Label) -import Data.Abstract.FreeVariables (Name (..), name) +import Data.Abstract.Evaluatable import Data.Abstract.Module import qualified Data.Abstract.Package as Package import Data.Abstract.Path diff --git a/src/Language/Haskell/Assignment.hs b/src/Language/Haskell/Assignment.hs index 0276dd867..0da96796c 100644 --- a/src/Language/Haskell/Assignment.hs +++ b/src/Language/Haskell/Assignment.hs @@ -9,18 +9,23 @@ module Language.Haskell.Assignment import Assigning.Assignment hiding (Assignment, Error) import Data.Record import Data.Sum -import Data.Syntax (emptyTerm, handleError, parseError, makeTerm, contextualize, postContextualize) +import Data.Syntax (emptyTerm, handleError, parseError, makeTerm, makeTerm'', contextualize, postContextualize) import Language.Haskell.Grammar as Grammar import qualified Assigning.Assignment as Assignment -import qualified Data.Abstract.FreeVariables as FV +import qualified Data.Abstract.Name as Name import qualified Data.Syntax as Syntax import qualified Data.Syntax.Comment as Comment +import qualified Data.Syntax.Declaration as Declaration +import qualified Data.Syntax.Literal as Literal import qualified Data.Term as Term import qualified Language.Haskell.Syntax as Syntax import Prologue type Syntax = '[ Comment.Comment + , Declaration.Function + , Literal.Float + , Literal.Integer , Syntax.Context , Syntax.Empty , Syntax.Error @@ -37,16 +42,26 @@ assignment :: Assignment assignment = handleError $ module' <|> parseError module' :: Assignment -module' = makeTerm <$> symbol Module <*> children (Syntax.Module <$> moduleIdentifier <*> pure [] <*> (where' <|> emptyTerm)) +module' = makeTerm + <$> symbol Module + <*> children (Syntax.Module <$> (moduleIdentifier <|> emptyTerm) <*> pure [] <*> (where' <|> expressions <|> emptyTerm)) + + +expressions :: Assignment +expressions = makeTerm'' <$> location <*> many expression expression :: Assignment expression = term (handleError (choice expressionChoices)) expressionChoices :: [Assignment.Assignment [] Grammar Term] expressionChoices = [ - constructorIdentifier + comment + , constructorIdentifier + , float + , functionDeclaration + , integer , moduleIdentifier - , comment + , variableIdentifier , where' ] @@ -56,11 +71,36 @@ term term = contextualize comment (postContextualize comment term) comment :: Assignment comment = makeTerm <$> symbol Comment <*> (Comment.Comment <$> source) +variableIdentifier :: Assignment +variableIdentifier = makeTerm <$> symbol VariableIdentifier <*> (Syntax.Identifier . Name.name <$> source) + constructorIdentifier :: Assignment -constructorIdentifier = makeTerm <$> symbol ConstructorIdentifier <*> (Syntax.Identifier . FV.name <$> source) +constructorIdentifier = makeTerm <$> symbol ConstructorIdentifier <*> (Syntax.Identifier . Name.name <$> source) moduleIdentifier :: Assignment -moduleIdentifier = makeTerm <$> symbol ModuleIdentifier <*> (Syntax.Identifier . FV.name <$> source) +moduleIdentifier = makeTerm <$> symbol ModuleIdentifier <*> (Syntax.Identifier . Name.name <$> source) where' :: Assignment where' = makeTerm <$> (symbol Where <|> symbol Where') <*> children (many expression) + +functionBody :: Assignment +functionBody = makeTerm <$> symbol FunctionBody <*> children (many expression) + +functionDeclaration :: Assignment +functionDeclaration = makeTerm + <$> symbol FunctionDeclaration + <*> children (Declaration.Function + <$> pure [] + <*> variableIdentifier + <*> (manyTermsTill expression (symbol FunctionBody) <|> pure []) + <*> functionBody) + +integer :: Assignment +integer = makeTerm <$> symbol Integer <*> (Literal.Integer <$> source) + +float :: Assignment +float = makeTerm <$> symbol Float <*> (Literal.Float <$> source) + +-- | Match a series of terms or comments until a delimiter is matched. +manyTermsTill :: Assignment.Assignment [] Grammar Term -> Assignment.Assignment [] Grammar b -> Assignment.Assignment [] Grammar [Term] +manyTermsTill step = manyTill (step <|> comment) diff --git a/src/Language/PHP/Assignment.hs b/src/Language/PHP/Assignment.hs index b13d74269..256f11948 100644 --- a/src/Language/PHP/Assignment.hs +++ b/src/Language/PHP/Assignment.hs @@ -12,7 +12,7 @@ import Data.Sum import Data.Syntax (emptyTerm, handleError, parseError, infixContext, makeTerm, makeTerm', makeTerm1, contextualize, postContextualize) import Language.PHP.Grammar as Grammar import qualified Assigning.Assignment as Assignment -import qualified Data.Abstract.FreeVariables as FV +import qualified Data.Abstract.Name as Name import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Syntax as Syntax import qualified Data.Syntax.Comment as Comment @@ -445,7 +445,7 @@ classConstDeclaration :: Assignment classConstDeclaration = makeTerm <$> symbol ClassConstDeclaration <*> children (Syntax.ClassConstDeclaration <$> (term visibilityModifier <|> emptyTerm) <*> manyTerm constElement) visibilityModifier :: Assignment -visibilityModifier = makeTerm <$> symbol VisibilityModifier <*> (Syntax.Identifier . FV.name <$> source) +visibilityModifier = makeTerm <$> symbol VisibilityModifier <*> (Syntax.Identifier . Name.name <$> source) constElement :: Assignment constElement = makeTerm <$> symbol ConstElement <*> children (Statement.Assignment [] <$> term name <*> term expression) @@ -651,7 +651,7 @@ propertyDeclaration :: Assignment propertyDeclaration = makeTerm <$> symbol PropertyDeclaration <*> children (Syntax.PropertyDeclaration <$> term propertyModifier <*> someTerm propertyElement) propertyModifier :: Assignment -propertyModifier = (makeTerm <$> symbol PropertyModifier <*> children (Syntax.PropertyModifier <$> (term visibilityModifier <|> emptyTerm) <*> (term staticModifier <|> emptyTerm))) <|> term (makeTerm <$> symbol PropertyModifier <*> (Syntax.Identifier . FV.name <$> source)) +propertyModifier = (makeTerm <$> symbol PropertyModifier <*> children (Syntax.PropertyModifier <$> (term visibilityModifier <|> emptyTerm) <*> (term staticModifier <|> emptyTerm))) <|> term (makeTerm <$> symbol PropertyModifier <*> (Syntax.Identifier . Name.name <$> source)) propertyElement :: Assignment propertyElement = makeTerm <$> symbol PropertyElement <*> children (Statement.Assignment [] <$> term variableName <*> term propertyInitializer) <|> (symbol PropertyElement *> children (term variableName)) @@ -712,7 +712,7 @@ namespaceAliasingClause = makeTerm <$> symbol NamespaceAliasingClause <*> childr -- | TODO Do something better than Identifier namespaceFunctionOrConst :: Assignment -namespaceFunctionOrConst = makeTerm <$> symbol NamespaceFunctionOrConst <*> (Syntax.Identifier . FV.name <$> source) +namespaceFunctionOrConst = makeTerm <$> symbol NamespaceFunctionOrConst <*> (Syntax.Identifier . Name.name <$> source) globalDeclaration :: Assignment globalDeclaration = makeTerm <$> symbol GlobalDeclaration <*> children (Syntax.GlobalDeclaration <$> manyTerm simpleVariable') @@ -748,7 +748,7 @@ variableName :: Assignment variableName = makeTerm <$> symbol VariableName <*> children (Syntax.VariableName <$> term name) name :: Assignment -name = makeTerm <$> (symbol Name <|> symbol Name') <*> (Syntax.Identifier . FV.name <$> source) +name = makeTerm <$> (symbol Name <|> symbol Name') <*> (Syntax.Identifier . Name.name <$> source) functionStaticDeclaration :: Assignment functionStaticDeclaration = makeTerm <$> symbol FunctionStaticDeclaration <*> children (Declaration.VariableDeclaration <$> manyTerm staticVariableDeclaration) diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 47cb043b8..29abe803a 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -55,18 +55,17 @@ resolvePHPName n = do include :: ( AbstractValue location value effects , Members '[ Allocator location value , Modules location value - , Reader (Environment location value) + , Reader (Environment location) , Resumable ResolutionError , Resumable (EnvironmentError value) - , Resumable (EvalError value) - , State (Environment location value) - , State (Exports location value) + , State (Environment location) + , State (Exports location) , State (Heap location (Cell location) value) , Trace ] effects ) => Subterm term (Evaluator location value effects (ValueRef value)) - -> (ModulePath -> Evaluator location value effects (Maybe (Environment location value, value))) + -> (ModulePath -> Evaluator location value effects (Maybe (Environment location, value))) -> Evaluator location value effects (ValueRef value) include pathTerm f = do name <- subtermValue pathTerm >>= asString diff --git a/src/Language/Python/Assignment.hs b/src/Language/Python/Assignment.hs index 19df8dab8..ddbcca6d8 100644 --- a/src/Language/Python/Assignment.hs +++ b/src/Language/Python/Assignment.hs @@ -8,7 +8,7 @@ module Language.Python.Assignment ) where import Assigning.Assignment hiding (Assignment, Error) -import Data.Abstract.FreeVariables (name) +import Data.Abstract.Name (name) import Data.Record import Data.Syntax (contextualize, emptyTerm, handleError, infixContext, makeTerm, makeTerm', makeTerm'', makeTerm1, parseError, postContextualize) import GHC.Stack diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index 6a1506f8b..5358af741 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -3,7 +3,6 @@ module Language.Python.Syntax where import Data.Abstract.Environment as Env import Data.Abstract.Evaluatable -import qualified Data.Abstract.FreeVariables as FV import Data.Abstract.Module import Data.Align.Generic import qualified Data.ByteString.Char8 as BC @@ -131,9 +130,9 @@ instance Evaluatable Import where evalQualifiedImport :: ( AbstractValue location value effects , Members '[ Allocator location value , Modules location value - , Reader (Environment location value) - , State (Environment location value) - , State (Exports location value) + , Reader (Environment location) + , State (Environment location) + , State (Exports location) , State (Heap location (Cell location) value) ] effects , Ord location @@ -158,9 +157,9 @@ instance Show1 QualifiedImport where liftShowsPrec = genericLiftShowsPrec -- import a.b.c instance Evaluatable QualifiedImport where eval (QualifiedImport (RelativeQualifiedName _ _)) = raiseEff (fail "technically this is not allowed in python") - eval (QualifiedImport name@(QualifiedName qualifiedName)) = do - modulePaths <- resolvePythonModules name - Rval <$> go (NonEmpty.zip (FV.name . BC.pack <$> qualifiedName) modulePaths) + eval (QualifiedImport qname@(QualifiedName qualifiedName)) = do + modulePaths <- resolvePythonModules qname + Rval <$> go (NonEmpty.zip (name . BC.pack <$> qualifiedName) modulePaths) where -- Evaluate and import the last module, updating the environment go ((name, path) :| []) = evalQualifiedImport name path diff --git a/src/Language/Ruby/Assignment.hs b/src/Language/Ruby/Assignment.hs index 936959059..be2683e5d 100644 --- a/src/Language/Ruby/Assignment.hs +++ b/src/Language/Ruby/Assignment.hs @@ -7,11 +7,11 @@ module Language.Ruby.Assignment ) where import Assigning.Assignment hiding (Assignment, Error) +import Data.Abstract.Name (name) import Data.List (elem) import Data.Record import Data.Syntax (contextualize, postContextualize, emptyTerm, parseError, handleError, infixContext, makeTerm, makeTerm', makeTerm'', makeTerm1) import Language.Ruby.Grammar as Grammar -import Data.Abstract.FreeVariables (name) import qualified Assigning.Assignment as Assignment import Data.Sum import qualified Data.Syntax as Syntax diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index 4a5a65aaf..56e8532ef 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -81,7 +81,7 @@ doRequire :: ( AbstractValue location value effects , Member (Modules location value) effects ) => M.ModulePath - -> Evaluator location value effects (Environment location value, value) + -> Evaluator location value effects (Environment location, value) doRequire path = do result <- join <$> lookupModule path case result of @@ -111,8 +111,8 @@ instance Evaluatable Load where doLoad :: ( AbstractValue location value effects , Members '[ Modules location value , Resumable ResolutionError - , State (Environment location value) - , State (Exports location value) + , State (Environment location) + , State (Exports location) , Trace ] effects ) diff --git a/src/Language/TypeScript/Assignment.hs b/src/Language/TypeScript/Assignment.hs index 11295e219..5f2599129 100644 --- a/src/Language/TypeScript/Assignment.hs +++ b/src/Language/TypeScript/Assignment.hs @@ -7,7 +7,7 @@ module Language.TypeScript.Assignment ) where import Assigning.Assignment hiding (Assignment, Error) -import Data.Abstract.FreeVariables (name) +import Data.Abstract.Name (name) import qualified Assigning.Assignment as Assignment import Data.Record import Data.Sum diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index 1f3a403ba..a2657e029 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -3,7 +3,6 @@ module Language.TypeScript.Syntax where import qualified Data.Abstract.Environment as Env import Data.Abstract.Evaluatable -import qualified Data.Abstract.FreeVariables as FV import qualified Data.Abstract.Module as M import Data.Abstract.Package import Data.Abstract.Path @@ -32,7 +31,7 @@ importPath str = let path = stripQuotes str in ImportPath (BC.unpack path) (path | otherwise = NonRelative toName :: ImportPath -> Name -toName = FV.name . BC.pack . unPath +toName = name . BC.pack . unPath -- Node.js resolution algorithm: https://nodejs.org/api/modules.html#modules_all_together -- @@ -136,9 +135,9 @@ javascriptExtensions = ["js"] evalRequire :: ( AbstractValue location value effects , Members '[ Allocator location value , Modules location value - , Reader (Environment location value) - , State (Environment location value) - , State (Exports location value) + , Reader (Environment location) + , State (Environment location) + , State (Exports location) , State (Heap location (Cell location) value) , Trace ] effects diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 35c8a9ce5..7a0e5acde 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -112,9 +112,8 @@ resumingResolutionError = runResolutionErrorWith (\ err -> trace ("ResolutionErr resumingLoadError :: Member Trace effects => Evaluator location value (Resumable (LoadError location value) ': effects) a -> Evaluator location value effects a resumingLoadError = runLoadErrorWith (\ (ModuleNotFound path) -> trace ("LoadError: " <> path) $> Nothing) -resumingEvalError :: (AbstractHole value, Member Trace effects, Show value) => Evaluator location value (Resumable (EvalError value) ': effects) a -> Evaluator location value effects a +resumingEvalError :: Member Trace effects => Evaluator location value (Resumable EvalError ': effects) a -> Evaluator location value effects a resumingEvalError = runEvalErrorWith (\ err -> trace ("EvalError" <> show err) *> case err of - EnvironmentLookupError{} -> pure hole DefaultExportError{} -> pure () ExportError{} -> pure () IntegerFormatError{} -> pure 0 @@ -130,7 +129,7 @@ resumingAddressError = runAddressErrorWith (\ err -> trace ("AddressError:" <> s UnallocatedAddress _ -> pure lowerBound UninitializedAddress _ -> pure hole) -resumingValueError :: (Members '[State (Environment location (Value location)), Trace] effects, Show location) => Evaluator location (Value location) (Resumable (ValueError location) ': effects) a -> Evaluator location (Value location) effects a +resumingValueError :: (Members '[State (Environment location), Trace] effects, Show location) => Evaluator location (Value location) (Resumable (ValueError location) ': effects) a -> Evaluator location (Value location) effects a resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err) *> case err of CallError val -> pure val StringError val -> pure (pack (show val)) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 081e12dc7..522ad0836 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -4,9 +4,8 @@ module Semantic.Util where import Analysis.Abstract.Caching import Analysis.Abstract.Collecting -import Analysis.Abstract.Evaluating as X -import Control.Abstract.Evaluator -import Control.Abstract.TermEvaluator +import Analysis.Abstract.Evaluating +import Control.Abstract import Control.Monad.Effect.Trace (runPrintingTrace) import Data.Abstract.Address import Data.Abstract.Evaluatable diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index 3372ddec9..7558aa681 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -32,7 +32,7 @@ spec = parallel $ do it "fails exporting symbols not defined in the module" $ do ((res, _), _) <- evaluate "bad-export.ts" - res `shouldBe` Left (SomeExc (inject @(EvalError (Value Precise)) (ExportError "foo.ts" (Name "pip")))) + res `shouldBe` Left (SomeExc (inject @EvalError (ExportError "foo.ts" (name "pip")))) it "evaluates early return statements" $ do ((res, _), _) <- evaluate "early-return.ts" diff --git a/test/Data/Functor/Listable.hs b/test/Data/Functor/Listable.hs index 797f00d23..1989447b5 100644 --- a/test/Data/Functor/Listable.hs +++ b/test/Data/Functor/Listable.hs @@ -47,7 +47,7 @@ import qualified Data.Syntax as Syntax import qualified Data.Syntax.Comment as Comment import qualified Data.Syntax.Declaration as Declaration import qualified Data.Syntax.Statement as Statement -import qualified Data.Abstract.FreeVariables as FV +import qualified Data.Abstract.Name as Name import Data.Term import Data.Text as T (Text, pack) import qualified Data.Text.Encoding as T @@ -257,8 +257,8 @@ type ListableSyntax = Sum , [] ] -instance Listable FV.Name where - tiers = cons1 FV.name +instance Listable Name.Name where + tiers = cons1 Name.name instance Listable1 Gram where liftTiers tiers = liftCons2 (liftTiers (liftTiers tiers)) (liftTiers (liftTiers tiers)) Gram diff --git a/test/Doctests.hs b/test/Doctests.hs index 9108b2ab0..965f0bbe9 100644 --- a/test/Doctests.hs +++ b/test/Doctests.hs @@ -5,7 +5,12 @@ module Main import System.Environment import Test.DocTest -defaultFiles = ["src/Data/Abstract/Environment.hs", "src/Data/Range.hs", "src/Data/Semigroup/App.hs"] +defaultFiles = + [ "src/Data/Abstract/Environment.hs" + , "src/Data/Abstract/Name.hs" + , "src/Data/Range.hs" + , "src/Data/Semigroup/App.hs" + ] main :: IO () main = do diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index c3d2f4505..9df506259 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -20,9 +20,10 @@ import Control.Monad ((>=>)) import Data.Abstract.Address as X import Data.Abstract.Environment as Env import Data.Abstract.Evaluatable -import Data.Abstract.FreeVariables as X hiding (dropExtension) +import Data.Abstract.FreeVariables as X import Data.Abstract.Heap as X import Data.Abstract.ModuleTable as X hiding (lookup) +import Data.Abstract.Name as X import Data.Abstract.Value (Namespace(..), Value, ValueError, injValue, prjValue, runValueError) import Data.Bifunctor (first) import Data.Blob as X @@ -93,7 +94,7 @@ testEvaluating deNamespace :: Value Precise -> Maybe (Name, [Name]) deNamespace = fmap (namespaceName &&& Env.names . namespaceScope) . prjValue @(Namespace Precise) -derefQName :: Heap Precise (Cell Precise) (Value Precise) -> NonEmpty Name -> Environment Precise (Value Precise) -> Maybe (Value Precise) +derefQName :: Heap Precise (Cell Precise) (Value Precise) -> NonEmpty Name -> Environment Precise -> Maybe (Value Precise) derefQName heap = go where go (n1 :| ns) env = Env.lookup n1 env >>= flip heapLookup heap >>= getLast . unLatest >>= case ns of [] -> Just diff --git a/test/fixtures/haskell/corpus/blank.A.hs b/test/fixtures/haskell/corpus/blank.A.hs new file mode 100644 index 000000000..e69de29bb diff --git a/test/fixtures/haskell/corpus/blank.parseA.txt b/test/fixtures/haskell/corpus/blank.parseA.txt new file mode 100644 index 000000000..0fc8549c6 --- /dev/null +++ b/test/fixtures/haskell/corpus/blank.parseA.txt @@ -0,0 +1,3 @@ +(Module + (Empty) + ([])) diff --git a/test/fixtures/haskell/corpus/literals.A.hs b/test/fixtures/haskell/corpus/literals.A.hs new file mode 100644 index 000000000..210598ae6 --- /dev/null +++ b/test/fixtures/haskell/corpus/literals.A.hs @@ -0,0 +1,37 @@ +module A where +a = 0 +a = 1 + +a = 0o00 +a = 0O77 + +a = 0x00 +a = 0XFF + +a = 0.00 +a = 0.99 + +a = 0.00e01 +a = 0.99E01 +a = 0.00e+01 +a = 0.99E-01 +a = 0.00e-01 +a = 0.99E+01 + +a = 00e01 +a = 99E01 +a = 00e+01 +a = 99E-01 +a = 00e-01 +a = 99E+01 + +a = undefined +_a0 = undefined +_A0 = undefined +a0 = undefined +a9 = undefined +aA = undefined +aZ' = undefined + +a = True +a = False diff --git a/test/fixtures/haskell/corpus/literals.B.hs b/test/fixtures/haskell/corpus/literals.B.hs new file mode 100644 index 000000000..d41b1b37a --- /dev/null +++ b/test/fixtures/haskell/corpus/literals.B.hs @@ -0,0 +1,37 @@ +module A where +b = 0 +b = 1 + +b = 0o00 +b = 0O77 + +b = 0x00 +b = 0XFF + +b = 0.00 +b = 0.99 + +b = 0.00e01 +b = 0.99E01 +b = 0.00e+01 +b = 0.99E-01 +b = 0.00e-01 +b = 0.99E+01 + +b = 00e01 +b = 99E01 +b = 00e+01 +b = 99E-01 +b = 00e-01 +b = 99E+01 + +b = undefined +ba0 = undefined +bA0 = undefined +b0 = undefined +b9 = undefined +bA = undefined +bZ' = undefined + +b = True +b = False diff --git a/test/fixtures/haskell/corpus/literals.diffA-B.txt b/test/fixtures/haskell/corpus/literals.diffA-B.txt new file mode 100644 index 000000000..a7e1f8237 --- /dev/null +++ b/test/fixtures/haskell/corpus/literals.diffA-B.txt @@ -0,0 +1,232 @@ +(Module + (Identifier) + ( + (Function + { (Identifier) + ->(Identifier) } + ( + (Integer))) + {+(Function + {+(Identifier)+} + {+( + {+(Integer)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Integer)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Integer)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Integer)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Integer)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {-(Function + {-(Identifier)-} + {-( + {-(Integer)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Integer)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Integer)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Integer)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Integer)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Float)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Float)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Float)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Float)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Float)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Float)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Float)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Float)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Float)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Float)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Float)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Float)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Float)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Float)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Identifier)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Identifier)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Identifier)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Identifier)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Identifier)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Identifier)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Identifier)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Identifier)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Identifier)-})-})-})) diff --git a/test/fixtures/haskell/corpus/literals.diffB-A.txt b/test/fixtures/haskell/corpus/literals.diffB-A.txt new file mode 100644 index 000000000..34000a913 --- /dev/null +++ b/test/fixtures/haskell/corpus/literals.diffB-A.txt @@ -0,0 +1,230 @@ +(Module + (Identifier) + ( + (Function + { (Identifier) + ->(Identifier) } + ( + (Integer))) + {+(Function + {+(Identifier)+} + {+( + {+(Integer)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Integer)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Integer)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Integer)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Integer)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + (Function + { (Identifier) + ->(Identifier) } + ( + {+(Identifier)+} + {-(Integer)-})) + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {-(Function + {-(Identifier)-} + {-( + {-(Integer)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Integer)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Integer)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Integer)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Float)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Float)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Float)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Float)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Float)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Float)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Float)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Float)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Float)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Float)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Float)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Float)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Float)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Float)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Identifier)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Identifier)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Identifier)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Identifier)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Identifier)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Identifier)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Identifier)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Identifier)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Identifier)-})-})-})) diff --git a/test/fixtures/haskell/corpus/literals.parseA.txt b/test/fixtures/haskell/corpus/literals.parseA.txt new file mode 100644 index 000000000..40982fe4b --- /dev/null +++ b/test/fixtures/haskell/corpus/literals.parseA.txt @@ -0,0 +1,119 @@ +(Module + (Identifier) + ( + (Function + (Identifier) + ( + (Integer))) + (Function + (Identifier) + ( + (Integer))) + (Function + (Identifier) + ( + (Integer))) + (Function + (Identifier) + ( + (Integer))) + (Function + (Identifier) + ( + (Integer))) + (Function + (Identifier) + ( + (Integer))) + (Function + (Identifier) + ( + (Float))) + (Function + (Identifier) + ( + (Float))) + (Function + (Identifier) + ( + (Float))) + (Function + (Identifier) + ( + (Float))) + (Function + (Identifier) + ( + (Float))) + (Function + (Identifier) + ( + (Float))) + (Function + (Identifier) + ( + (Float))) + (Function + (Identifier) + ( + (Float))) + (Function + (Identifier) + ( + (Float))) + (Function + (Identifier) + ( + (Float))) + (Function + (Identifier) + ( + (Float))) + (Function + (Identifier) + ( + (Float))) + (Function + (Identifier) + ( + (Float))) + (Function + (Identifier) + ( + (Float))) + (Function + (Identifier) + ( + (Identifier))) + (Function + (Identifier) + ( + (Identifier))) + (Function + (Identifier) + ( + (Identifier))) + (Function + (Identifier) + ( + (Identifier))) + (Function + (Identifier) + ( + (Identifier))) + (Function + (Identifier) + ( + (Identifier))) + (Function + (Identifier) + ( + (Identifier))) + (Function + (Identifier) + ( + (Identifier))) + (Function + (Identifier) + ( + (Identifier))))) diff --git a/test/fixtures/haskell/corpus/literals.parseB.txt b/test/fixtures/haskell/corpus/literals.parseB.txt new file mode 100644 index 000000000..40982fe4b --- /dev/null +++ b/test/fixtures/haskell/corpus/literals.parseB.txt @@ -0,0 +1,119 @@ +(Module + (Identifier) + ( + (Function + (Identifier) + ( + (Integer))) + (Function + (Identifier) + ( + (Integer))) + (Function + (Identifier) + ( + (Integer))) + (Function + (Identifier) + ( + (Integer))) + (Function + (Identifier) + ( + (Integer))) + (Function + (Identifier) + ( + (Integer))) + (Function + (Identifier) + ( + (Float))) + (Function + (Identifier) + ( + (Float))) + (Function + (Identifier) + ( + (Float))) + (Function + (Identifier) + ( + (Float))) + (Function + (Identifier) + ( + (Float))) + (Function + (Identifier) + ( + (Float))) + (Function + (Identifier) + ( + (Float))) + (Function + (Identifier) + ( + (Float))) + (Function + (Identifier) + ( + (Float))) + (Function + (Identifier) + ( + (Float))) + (Function + (Identifier) + ( + (Float))) + (Function + (Identifier) + ( + (Float))) + (Function + (Identifier) + ( + (Float))) + (Function + (Identifier) + ( + (Float))) + (Function + (Identifier) + ( + (Identifier))) + (Function + (Identifier) + ( + (Identifier))) + (Function + (Identifier) + ( + (Identifier))) + (Function + (Identifier) + ( + (Identifier))) + (Function + (Identifier) + ( + (Identifier))) + (Function + (Identifier) + ( + (Identifier))) + (Function + (Identifier) + ( + (Identifier))) + (Function + (Identifier) + ( + (Identifier))) + (Function + (Identifier) + ( + (Identifier)))))