mirror of
https://github.com/github/semantic.git
synced 2025-01-04 05:27:08 +03:00
Remove Environment’s value parameter.
This commit is contained in:
Rob Rix
parent
2a46f5ea6f
commit
12cec06dfe
@ -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,12 +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)
|
||||
, State (Cache term location (Cell location) value)
|
||||
, State (Environment location value)
|
||||
, State (Environment location)
|
||||
, State (Heap location (Cell location) value)
|
||||
] effects
|
||||
)
|
||||
|
||||
@ -9,9 +9,9 @@ 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))
|
||||
, modules :: ModuleTable (Maybe (Environment location, value))
|
||||
, exports :: Exports location
|
||||
}
|
||||
|
||||
@ -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 (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)
|
||||
. runState lowerBound -- State (ModuleTable (Maybe (Environment location value, value)))
|
||||
. 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
|
||||
|
||||
@ -53,10 +53,10 @@ 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
|
||||
, Reader PackageInfo
|
||||
, State (Environment (Located location) value)
|
||||
, State (Environment (Located location))
|
||||
, State (Graph Vertex)
|
||||
] effects
|
||||
, term ~ Term (Sum syntax) ann
|
||||
@ -127,8 +127,8 @@ moduleInclusion v = do
|
||||
appendGraph (moduleGraph 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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -24,49 +24,49 @@ 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)
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -15,10 +15,10 @@ import Prologue
|
||||
|
||||
builtin :: ( HasCallStack
|
||||
, Members '[ Allocator location value
|
||||
, Reader (Environment location value)
|
||||
, Reader (Environment location)
|
||||
, Reader ModuleInfo
|
||||
, Reader Span
|
||||
, State (Environment location value)
|
||||
, State (Environment location)
|
||||
, State (Heap location (Cell location) value)
|
||||
] effects
|
||||
, Ord location
|
||||
@ -45,11 +45,11 @@ defineBuiltins :: ( AbstractValue location value effects
|
||||
, HasCallStack
|
||||
, Members '[ Allocator location value
|
||||
, Fresh
|
||||
, Reader (Environment location value)
|
||||
, Reader (Environment location)
|
||||
, Reader ModuleInfo
|
||||
, Reader Span
|
||||
, Resumable (EnvironmentError value)
|
||||
, State (Environment location value)
|
||||
, State (Environment location)
|
||||
, State (Heap location (Cell location) value)
|
||||
, Trace
|
||||
] effects
|
||||
|
||||
@ -209,20 +209,20 @@ class AbstractFunction location value effects => AbstractValue location value ef
|
||||
index :: value -> value -> Evaluator location value effects value
|
||||
|
||||
-- | 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))
|
||||
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.
|
||||
--
|
||||
@ -236,7 +236,7 @@ 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
|
||||
@ -265,7 +265,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)
|
||||
@ -284,7 +284,7 @@ makeNamespace name addr super = do
|
||||
|
||||
-- | Evaluate a term within the context of the scoped environment of 'scopedEnvTerm'.
|
||||
evaluateInScopedEnv :: ( AbstractValue location value effects
|
||||
, Member (State (Environment location value)) effects
|
||||
, Member (State (Environment location)) effects
|
||||
)
|
||||
=> Evaluator location value effects value
|
||||
-> Evaluator location value effects value
|
||||
@ -297,9 +297,9 @@ evaluateInScopedEnv scopedEnvTerm term = do
|
||||
-- | Evaluates a 'Value' returning the referenced value
|
||||
value :: ( AbstractValue location value effects
|
||||
, 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
|
||||
)
|
||||
@ -312,9 +312,9 @@ value (Rval val) = pure val
|
||||
-- | Evaluates a 'Subterm' to its rval
|
||||
subtermValue :: ( AbstractValue location value effects
|
||||
, 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
|
||||
)
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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 location) }
|
||||
newtype Environment location = Environment { unEnvironment :: NonEmpty (Map.Map Name location) }
|
||||
deriving (Eq, Ord)
|
||||
|
||||
instance Eq location => Eq1 (Environment location) where liftEq _ (Environment a) (Environment b) = a == b
|
||||
instance Ord location => Ord1 (Environment location) where liftCompare _ (Environment a) (Environment b) = a `compare` 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 :: Environment location -> [(Name, Address location value)]
|
||||
pairs = map (second Address) . Map.toList . fold . unEnvironment
|
||||
|
||||
unpairs :: [(Name, Address location value)] -> Environment location value
|
||||
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 :: 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 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
|
||||
instance Show location => Show (Environment location) where
|
||||
showsPrec d = showsUnaryWith showsPrec "Environment" d . pairs
|
||||
|
||||
@ -58,7 +58,7 @@ 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
|
||||
@ -67,7 +67,7 @@ type EvaluatableConstraints location term value effects =
|
||||
, Resumable ResolutionError
|
||||
, Resumable (Unspecialized value)
|
||||
, Return value
|
||||
, State (Environment location value)
|
||||
, State (Environment location)
|
||||
, State (Exports location)
|
||||
, State (Heap location (Cell location) value)
|
||||
, Trace
|
||||
@ -85,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 (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
|
||||
@ -153,7 +153,7 @@ 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)] 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 ()
|
||||
|
||||
@ -22,7 +22,7 @@ newtype Exports location = Exports { unExports :: Map.Map Name (Name, Maybe loca
|
||||
null :: Exports location -> Bool
|
||||
null = Map.null . unExports
|
||||
|
||||
toEnvironment :: Exports location -> Environment location value
|
||||
toEnvironment :: Exports location -> Environment location
|
||||
toEnvironment exports = unpairs (mapMaybe sequenceA (map (second (fmap Address)) (toList (unExports exports))))
|
||||
|
||||
insert :: Name -> Name -> Maybe (Address location value) -> Exports location -> Exports location
|
||||
|
||||
@ -104,10 +104,10 @@ instance AbstractHole Type where
|
||||
instance ( Members '[ Allocator location Type
|
||||
, Fresh
|
||||
, NonDet
|
||||
, Reader (Environment location Type)
|
||||
, Reader (Environment location)
|
||||
, Resumable TypeError
|
||||
, Return Type
|
||||
, State (Environment location Type)
|
||||
, State (Environment location)
|
||||
, State (Heap location (Cell location) Type)
|
||||
] effects
|
||||
, Ord location
|
||||
@ -136,10 +136,10 @@ instance ( Members '[ Allocator location Type
|
||||
instance ( Members '[ Allocator location Type
|
||||
, Fresh
|
||||
, NonDet
|
||||
, Reader (Environment location Type)
|
||||
, Reader (Environment location)
|
||||
, Resumable TypeError
|
||||
, Return Type
|
||||
, State (Environment location Type)
|
||||
, State (Environment location)
|
||||
, State (Heap location (Cell location) Type)
|
||||
] effects
|
||||
, Ord location
|
||||
|
||||
@ -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
|
||||
@ -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
|
||||
@ -205,12 +205,12 @@ instance AbstractHole (Value location) where
|
||||
hole = injValue Hole
|
||||
|
||||
instance ( Members '[ Allocator location (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
|
||||
@ -243,12 +243,12 @@ instance ( Members '[ Allocator location (Value location)
|
||||
-- | Construct a 'Value' wrapping the value arguments (if any).
|
||||
instance ( Members '[ Allocator location (Value location)
|
||||
, 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
|
||||
@ -384,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)
|
||||
|
||||
@ -55,17 +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)
|
||||
, State (Environment 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
|
||||
|
||||
@ -130,8 +130,8 @@ instance Evaluatable Import where
|
||||
evalQualifiedImport :: ( AbstractValue location value effects
|
||||
, Members '[ Allocator location value
|
||||
, Modules location value
|
||||
, Reader (Environment location value)
|
||||
, State (Environment location value)
|
||||
, Reader (Environment location)
|
||||
, State (Environment location)
|
||||
, State (Exports location)
|
||||
, State (Heap location (Cell location) value)
|
||||
] effects
|
||||
|
||||
@ -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,7 +111,7 @@ instance Evaluatable Load where
|
||||
doLoad :: ( AbstractValue location value effects
|
||||
, Members '[ Modules location value
|
||||
, Resumable ResolutionError
|
||||
, State (Environment location value)
|
||||
, State (Environment location)
|
||||
, State (Exports location)
|
||||
, Trace
|
||||
] effects
|
||||
|
||||
@ -135,8 +135,8 @@ javascriptExtensions = ["js"]
|
||||
evalRequire :: ( AbstractValue location value effects
|
||||
, Members '[ Allocator location value
|
||||
, Modules location value
|
||||
, Reader (Environment location value)
|
||||
, State (Environment location value)
|
||||
, Reader (Environment location)
|
||||
, State (Environment location)
|
||||
, State (Exports location)
|
||||
, State (Heap location (Cell location) value)
|
||||
, Trace
|
||||
|
||||
@ -127,7 +127,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))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user