mirror of
https://github.com/github/semantic.git
synced 2024-12-29 01:42:43 +03:00
push Address location value into the guts of the evaluator
This commit is contained in:
Charlie Somerville
parent
05c85d626e
commit
10022d4de9
@ -6,6 +6,7 @@ module Analysis.Abstract.Caching
|
||||
) where
|
||||
|
||||
import Control.Abstract
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.Cache
|
||||
import Data.Abstract.Evaluatable
|
||||
import Data.Abstract.Module
|
||||
@ -96,8 +97,8 @@ convergingModules :: ( AbstractValue location value effects
|
||||
] effects
|
||||
, Reducer value (Cell location value)
|
||||
)
|
||||
=> SubtermAlgebra Module term (TermEvaluator term location value effects value)
|
||||
-> SubtermAlgebra Module term (TermEvaluator term location value effects value)
|
||||
=> SubtermAlgebra Module term (TermEvaluator term location value effects (Address location value))
|
||||
-> SubtermAlgebra Module term (TermEvaluator term location value effects (Address location value))
|
||||
convergingModules recur m = do
|
||||
c <- getConfiguration (subterm (moduleBody m))
|
||||
-- Convergence here is predicated upon an Eq instance, not α-equivalence
|
||||
@ -112,7 +113,7 @@ convergingModules recur m = do
|
||||
-- would never complete). We don’t need to use the values, so we 'gather' the
|
||||
-- nondeterministic values into @()@.
|
||||
withOracle prevCache (gatherM (const ()) (recur m)))
|
||||
TermEvaluator (value =<< runTermEvaluator (maybe empty scatter (cacheLookup c cache)))
|
||||
TermEvaluator (address =<< runTermEvaluator (maybe empty scatter (cacheLookup c cache)))
|
||||
|
||||
|
||||
-- | Iterate a monadic action starting from some initial seed until the results converge.
|
||||
|
||||
@ -5,13 +5,14 @@ module Analysis.Abstract.Evaluating
|
||||
) where
|
||||
|
||||
import Control.Abstract
|
||||
import Data.Abstract.Address
|
||||
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
|
||||
, heap :: Heap location (Cell location) value
|
||||
, modules :: ModuleTable (Maybe (Environment location value, value))
|
||||
, modules :: ModuleTable (Maybe (Environment location value, Address location value))
|
||||
, exports :: Exports location value
|
||||
}
|
||||
|
||||
@ -26,14 +27,14 @@ evaluating :: Evaluator location value
|
||||
': Reader (Environment location value)
|
||||
': State (Environment location value)
|
||||
': State (Heap location (Cell location) value)
|
||||
': State (ModuleTable (Maybe (Environment location value, value)))
|
||||
': State (ModuleTable (Maybe (Environment location value, Address location value)))
|
||||
': State (Exports location value)
|
||||
': 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 (ModuleTable (Maybe (Environment location value, Address location value)))
|
||||
. runState lowerBound -- State (Heap location (Cell location) value)
|
||||
. runState lowerBound -- State (Environment location value)
|
||||
. runReader lowerBound -- Reader (Environment location value)
|
||||
|
||||
@ -58,40 +58,48 @@ data ValueRef location value where
|
||||
-- Effects
|
||||
|
||||
-- | An effect for explicitly returning out of a function/method body.
|
||||
data Return value resume where
|
||||
Return :: value -> Return value value
|
||||
data Return location value resume where
|
||||
Return :: Address location value -> Return location value (Address location value)
|
||||
|
||||
deriving instance Eq value => Eq (Return value a)
|
||||
deriving instance Show value => Show (Return value a)
|
||||
deriving instance (Eq location, Eq value) => Eq (Return location value a)
|
||||
deriving instance (Show location, Eq value) => Show (Return location value a)
|
||||
|
||||
earlyReturn :: Member (Return value) effects => value -> Evaluator location value effects value
|
||||
earlyReturn :: Member (Return location value) effects => Address location value -> Evaluator location value effects (Address location value)
|
||||
earlyReturn = send . Return
|
||||
|
||||
catchReturn :: Member (Return value) effects => Evaluator location value effects a -> (forall x . Return value x -> Evaluator location value effects a) -> Evaluator location value effects a
|
||||
catchReturn :: Member (Return location value) effects => Evaluator location value effects a -> (forall x . Return location value x -> Evaluator location value effects a) -> Evaluator location value effects a
|
||||
catchReturn action handler = interpose pure (\ ret _ -> handler ret) action
|
||||
|
||||
runReturn :: Evaluator location value (Return value ': effects) value -> Evaluator location value effects value
|
||||
runReturn :: Evaluator location value (Return location value ': effects) (Address location value) -> Evaluator location value effects (Address location value)
|
||||
runReturn = relay pure (\ (Return value) _ -> pure value)
|
||||
|
||||
|
||||
-- | Effects for control flow around loops (breaking and continuing).
|
||||
data LoopControl value resume where
|
||||
Break :: value -> LoopControl value value
|
||||
Continue :: value -> LoopControl value value
|
||||
data LoopControl location value resume where
|
||||
Break :: Address location value -> LoopControl location value (Address location value)
|
||||
Continue :: Address location value -> LoopControl location value (Address location value)
|
||||
|
||||
deriving instance Eq value => Eq (LoopControl value a)
|
||||
deriving instance Show value => Show (LoopControl value a)
|
||||
deriving instance (Eq location, Eq value) => Eq (LoopControl location value a)
|
||||
deriving instance (Show location, Show value) => Show (LoopControl location value a)
|
||||
|
||||
throwBreak :: Member (LoopControl value) effects => value -> Evaluator location value effects value
|
||||
throwBreak :: Member (LoopControl location value) effects
|
||||
=> Address location value
|
||||
-> Evaluator location value effects (Address location value)
|
||||
throwBreak = send . Break
|
||||
|
||||
throwContinue :: Member (LoopControl value) effects => value -> Evaluator location value effects value
|
||||
throwContinue :: Member (LoopControl location value) effects
|
||||
=> Address location value
|
||||
-> Evaluator location value effects (Address location value)
|
||||
throwContinue = send . Continue
|
||||
|
||||
catchLoopControl :: Member (LoopControl value) effects => Evaluator location value effects a -> (forall x . LoopControl value x -> Evaluator location value effects a) -> Evaluator location value effects a
|
||||
catchLoopControl :: Member (LoopControl location value) effects
|
||||
=> Evaluator location value effects a
|
||||
-> (forall x . LoopControl location value x -> Evaluator location value effects a)
|
||||
-> Evaluator location value effects a
|
||||
catchLoopControl action handler = interpose pure (\ control _ -> handler control) action
|
||||
|
||||
runLoopControl :: Evaluator location value (LoopControl value ': effects) value -> Evaluator location value effects value
|
||||
runLoopControl :: Evaluator location value (LoopControl location value ': effects) (Address location value)
|
||||
-> Evaluator location value effects (Address location value)
|
||||
runLoopControl = relay pure (\ eff _ -> case eff of
|
||||
Break value -> pure value
|
||||
Continue value -> pure value)
|
||||
|
||||
@ -10,11 +10,12 @@ module Control.Abstract.Goto
|
||||
|
||||
import Control.Abstract.Evaluator
|
||||
import Control.Monad.Effect (Eff)
|
||||
import Data.Abstract.Address
|
||||
import qualified Data.IntMap as IntMap
|
||||
import Prelude hiding (fail)
|
||||
import Prologue
|
||||
|
||||
type GotoTable inner value = IntMap.IntMap (Eff (Goto inner value ': inner) value)
|
||||
type GotoTable inner location value = IntMap.IntMap (Eff (Goto inner location value ': inner) (Address location value))
|
||||
|
||||
-- | The type of labels.
|
||||
-- TODO: This should be rolled into 'Name' and tracked in the environment, both so that we can abstract over labels like any other location, and so that we can garbage collect unreachable labels.
|
||||
@ -24,11 +25,13 @@ type Label = Int
|
||||
-- | Allocate a 'Label' for the given @term@.
|
||||
--
|
||||
-- Labels must be allocated before being jumped to with 'goto', but are suitable for nonlocal jumps; thus, they can be used to implement coroutines, exception handling, call with current continuation, and other esoteric control mechanisms.
|
||||
label :: Evaluator location value (Goto effects value ': effects) value -> Evaluator location value (Goto effects value ': effects) Label
|
||||
label :: Evaluator location value (Goto effects location value ': effects) (Address location value)
|
||||
-> Evaluator location value (Goto effects location value ': effects) Label
|
||||
label = send . Label . lowerEff
|
||||
|
||||
-- | “Jump” to a previously-allocated 'Label' (retrieving the @term@ at which it points, which can then be evaluated.
|
||||
goto :: Label -> Evaluator location value (Goto effects value ': effects) (Evaluator location value (Goto effects value ': effects) value)
|
||||
goto :: Label
|
||||
-> Evaluator location value (Goto effects location value ': effects) (Evaluator location value (Goto effects location value ': effects) (Address location value))
|
||||
goto = fmap raiseEff . send . Goto
|
||||
|
||||
|
||||
@ -41,9 +44,9 @@ goto = fmap raiseEff . send . Goto
|
||||
-- @
|
||||
--
|
||||
-- However, using this type would require that the type of the effect list include a reference to itself, which is forbidden by the occurs check: we wouldn’t be able to write a handler for 'Goto' if it could be used at that type. Instead, one can either use a smaller, statically known effect list inside the 'Goto', e.g. @Member (Goto outer) inner@ where @outer@ is a suffix of @inner@ (and with some massaging to raise the @outer@ actions into the @inner@ context), or use 'Goto' when it’s statically known to be the head of the list: @Eff (Goto rest a ': rest) b@. In either case, the 'Eff' actions embedded in the effect are themselves able to contain further 'Goto' effects,
|
||||
data Goto effects value return where
|
||||
Label :: Eff (Goto effects value ': effects) value -> Goto effects value Label
|
||||
Goto :: Label -> Goto effects value (Eff (Goto effects value ': effects) value)
|
||||
data Goto effects location value return where
|
||||
Label :: Eff (Goto effects location value ': effects) (Address location value) -> Goto effects location value Label
|
||||
Goto :: Label -> Goto effects location value (Eff (Goto effects location value ': effects) (Address location value))
|
||||
|
||||
-- | Run a 'Goto' effect in terms of a 'State' effect holding a 'GotoTable', accessed via wrap/unwrap functions.
|
||||
--
|
||||
@ -58,9 +61,9 @@ runGoto :: Members '[ Fail
|
||||
, Fresh
|
||||
, State table
|
||||
] effects
|
||||
=> (GotoTable effects value -> table)
|
||||
-> (table -> GotoTable effects value)
|
||||
-> Evaluator location value (Goto effects value ': effects) a
|
||||
=> (GotoTable effects location value -> table)
|
||||
-> (table -> GotoTable effects location value)
|
||||
-> Evaluator location value (Goto effects location value ': effects) a
|
||||
-> Evaluator location value effects a
|
||||
runGoto from to = interpret (\ goto -> do
|
||||
table <- to <$> getTable
|
||||
|
||||
@ -133,7 +133,9 @@ data Allocator location value return where
|
||||
Alloc :: Name -> Allocator location value (Address location value)
|
||||
Deref :: Address location value -> Allocator location value value
|
||||
|
||||
runAllocator :: (Addressable location effects, Members '[Resumable (AddressError location value), State (Heap location (Cell location) value)] effects) => Evaluator location value (Allocator location value ': effects) a -> Evaluator location value effects a
|
||||
runAllocator :: (Addressable location effects, Members '[Resumable (AddressError location value), State (Heap location (Cell location) value)] effects)
|
||||
=> Evaluator location value (Allocator location value ': effects) a
|
||||
-> Evaluator location value effects a
|
||||
runAllocator = interpret (\ eff -> case eff of
|
||||
Alloc name -> Address <$> allocCell name
|
||||
Deref addr -> heapLookup addr <$> get >>= maybeM (throwResumable (UnallocatedAddress addr)) >>= derefCell addr >>= maybeM (throwResumable (UninitializedAddress addr)))
|
||||
|
||||
@ -19,6 +19,7 @@ module Control.Abstract.Modules
|
||||
) where
|
||||
|
||||
import Control.Abstract.Evaluator
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.Environment
|
||||
import Data.Abstract.Module
|
||||
import Data.Abstract.ModuleTable as ModuleTable
|
||||
@ -26,7 +27,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, Address location value)))
|
||||
lookupModule = send . Lookup
|
||||
|
||||
-- | Resolve a list of module paths to a possible module table entry.
|
||||
@ -40,19 +41,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, Address 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, Address 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, Address location value))
|
||||
Lookup :: ModulePath -> Modules location value (Maybe (Maybe (Environment location value, Address location value)))
|
||||
Resolve :: [FilePath] -> Modules location value (Maybe ModulePath)
|
||||
List :: FilePath -> Modules location value [ModulePath]
|
||||
|
||||
@ -61,10 +62,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, Address 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, Address location value))
|
||||
-> Evaluator location value (Modules location value ': effects) a
|
||||
-> Evaluator location value (Reader (ModuleTable [Module term]) ': effects) a
|
||||
runModules evaluateModule = go
|
||||
@ -89,17 +90,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, Address location value)))) effects => Evaluator location value effects (ModuleTable (Maybe (Environment location value, Address 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, Address location value)))) effects => ModulePath -> Maybe (Environment location value, Address location value) -> Evaluator location value effects (Maybe (Environment location value, Address 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, Address location value)) }
|
||||
|
||||
instance Applicative m => Semigroup (Merging m location value) where
|
||||
Merging a <> Merging b = Merging (merge <$> a <*> b)
|
||||
@ -113,7 +114,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, Address location value))
|
||||
|
||||
deriving instance Eq (LoadError location value resume)
|
||||
deriving instance Show (LoadError location value resume)
|
||||
@ -122,7 +123,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, Address 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
|
||||
|
||||
@ -144,7 +144,7 @@ class Show value => AbstractValue location value effects where
|
||||
-> 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
|
||||
call :: value -> [Evaluator location value effects (Address location value)] -> Evaluator location value effects (Address location value)
|
||||
|
||||
-- | Primitive looping combinator, approximately equivalent to 'fix'. This should be used in place of direct recursion, as it allows abstraction over recursion.
|
||||
--
|
||||
|
||||
@ -66,7 +66,7 @@ type EvaluatableConstraints location term value effects =
|
||||
, Declarations term
|
||||
, FreeVariables term
|
||||
, Members '[ Allocator location value
|
||||
, LoopControl value
|
||||
, LoopControl location value
|
||||
, Modules location value
|
||||
, Reader (Environment location value)
|
||||
, Reader ModuleInfo
|
||||
@ -76,7 +76,7 @@ type EvaluatableConstraints location term value effects =
|
||||
, Resumable (EvalError value)
|
||||
, Resumable ResolutionError
|
||||
, Resumable (Unspecialized value)
|
||||
, Return value
|
||||
, Return location value
|
||||
, State (Environment location value)
|
||||
, State (Exports location value)
|
||||
, State (Heap location (Cell location) value)
|
||||
@ -279,17 +279,17 @@ evaluatePackageWith :: forall location term value inner inner' outer
|
||||
, State (Environment location value)
|
||||
, State (Exports location value)
|
||||
, State (Heap location (Cell location) value)
|
||||
, State (ModuleTable (Maybe (Environment location value, value)))
|
||||
, State (ModuleTable (Maybe (Environment location value, Address location value)))
|
||||
, Trace
|
||||
] outer
|
||||
, Recursive term
|
||||
, inner ~ (Goto inner' value ': inner')
|
||||
, inner' ~ (LoopControl value ': Return value ': Allocator location value ': Reader ModuleInfo ': Modules location value ': State (Gotos location value (Reader Span ': Reader PackageInfo ': outer)) ': Reader Span ': Reader PackageInfo ': outer)
|
||||
, inner ~ (Goto inner' location value ': inner')
|
||||
, inner' ~ (LoopControl location value ': Return location value ': Allocator location value ': Reader ModuleInfo ': Modules location value ': State (Gotos location value (Reader Span ': Reader PackageInfo ': outer)) ': Reader Span ': Reader PackageInfo ': outer)
|
||||
)
|
||||
=> (SubtermAlgebra Module term (TermEvaluator term location value inner value) -> SubtermAlgebra Module term (TermEvaluator term location value inner value))
|
||||
=> (SubtermAlgebra Module term (TermEvaluator term location value inner (Address location value)) -> SubtermAlgebra Module term (TermEvaluator term location value inner (Address location value)))
|
||||
-> (SubtermAlgebra (Base term) term (TermEvaluator term location value inner (ValueRef location value)) -> SubtermAlgebra (Base term) term (TermEvaluator term location value inner (ValueRef location value)))
|
||||
-> Package term
|
||||
-> TermEvaluator term location value outer [value]
|
||||
-> TermEvaluator term location value outer [(Address location value)]
|
||||
evaluatePackageWith analyzeModule analyzeTerm package
|
||||
= runReader (packageInfo package)
|
||||
. runReader lowerBound
|
||||
@ -305,24 +305,27 @@ evaluatePackageWith analyzeModule analyzeTerm package
|
||||
. runInModule (moduleInfo m)
|
||||
. analyzeModule (subtermRef . moduleBody)
|
||||
$ evalTerm <$> m
|
||||
evalTerm term = Subterm term (TermEvaluator (value =<< runTermEvaluator (foldSubterms (analyzeTerm (TermEvaluator . eval . fmap (second runTermEvaluator))) term)))
|
||||
evalTerm term = Subterm term (TermEvaluator (address =<< runTermEvaluator (foldSubterms (analyzeTerm (TermEvaluator . eval . fmap (second runTermEvaluator))) term)))
|
||||
|
||||
runInModule info
|
||||
runInModule info val
|
||||
= runReader info
|
||||
. raiseHandler runAllocator
|
||||
. raiseHandler runReturn
|
||||
. raiseHandler runLoopControl
|
||||
. raiseHandler (runGoto Gotos getGotos)
|
||||
$ raiseHandler runAllocator
|
||||
$ raiseHandler runReturn
|
||||
$ raiseHandler runLoopControl
|
||||
$ raiseHandler (runGoto Gotos getGotos)
|
||||
$ val
|
||||
|
||||
evaluateEntryPoint :: ModulePath -> Maybe Name -> TermEvaluator term location value (Modules location value ': State (Gotos location value (Reader Span ': Reader PackageInfo ': outer)) ': Reader Span ': Reader PackageInfo ': outer) value
|
||||
evaluateEntryPoint :: ModulePath
|
||||
-> Maybe Name
|
||||
-> TermEvaluator term location value (Modules location value ': State (Gotos location value (Reader Span ': Reader PackageInfo ': outer)) ': Reader Span ': Reader PackageInfo ': outer) (Address location value)
|
||||
evaluateEntryPoint m sym = runInModule (ModuleInfo m) . TermEvaluator $ do
|
||||
v <- maybe unit (pure . snd) <$> require m
|
||||
v <- maybe (box =<< unit) (pure . snd) <$> require m
|
||||
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
|
||||
box =<< unit
|
||||
fst <$> evalModule prelude
|
||||
|
||||
withPrelude Nothing a = a
|
||||
@ -336,9 +339,24 @@ evaluatePackageWith analyzeModule analyzeTerm package
|
||||
filterEnv ports env
|
||||
| Exports.null ports = env
|
||||
| otherwise = Exports.toEnvironment ports `mergeEnvs` overwrite (Exports.aliases ports) env
|
||||
pairValueWithEnv action = flip (,) <$> action <*> (filterEnv <$> TermEvaluator getExports <*> TermEvaluator getEnv)
|
||||
|
||||
newtype Gotos location value outer = Gotos { getGotos :: GotoTable (LoopControl value ': Return value ': Allocator location value ': Reader ModuleInfo ': Modules location value ': State (Gotos location value outer) ': outer) value }
|
||||
pairValueWithEnv :: pairEffects ~ (Modules location value ': State (Gotos location value (Reader Span ': Reader PackageInfo ': outer)) ': Reader Span ': Reader PackageInfo ': outer)
|
||||
=> TermEvaluator term location value pairEffects (Address location value)
|
||||
-> TermEvaluator term location value pairEffects (Environment location value, Address location value)
|
||||
pairValueWithEnv action = do
|
||||
act <- action
|
||||
env <- (filterEnv <$> TermEvaluator getExports <*> TermEvaluator getEnv)
|
||||
pure (env, act)
|
||||
|
||||
newtype Gotos location value outer = Gotos {
|
||||
getGotos :: GotoTable ( LoopControl location value
|
||||
': Return location value
|
||||
': Allocator location value
|
||||
': Reader ModuleInfo
|
||||
': Modules location value
|
||||
': State (Gotos location value outer)
|
||||
': outer)
|
||||
location value }
|
||||
deriving (Lower)
|
||||
|
||||
|
||||
|
||||
@ -207,12 +207,12 @@ instance AbstractHole (Value location) where
|
||||
-- | Construct a 'Value' wrapping the value arguments (if any).
|
||||
instance ( Members '[ Allocator location (Value location)
|
||||
, Fail
|
||||
, LoopControl (Value location)
|
||||
, LoopControl location (Value location)
|
||||
, Reader (Environment location (Value location))
|
||||
, Reader ModuleInfo
|
||||
, Reader PackageInfo
|
||||
, Resumable (ValueError location)
|
||||
, Return (Value location)
|
||||
, Return location (Value location)
|
||||
, State (Environment location (Value location))
|
||||
, State (Heap location (Cell location) (Value location))
|
||||
] effects
|
||||
@ -220,7 +220,7 @@ instance ( Members '[ Allocator location (Value location)
|
||||
, Reducer (Value location) (Cell location (Value location))
|
||||
, Show location
|
||||
)
|
||||
=> AbstractValue location (Value location) (Goto effects (Value location) ': effects) where
|
||||
=> AbstractValue location (Value location) (Goto effects location (Value location) ': effects) where
|
||||
unit = pure . injValue $ Unit
|
||||
integer = pure . injValue . Integer . Number.Integer
|
||||
boolean = pure . injValue . Boolean
|
||||
@ -351,7 +351,7 @@ instance ( Members '[ Allocator location (Value location)
|
||||
closure parameters freeVariables body = do
|
||||
packageInfo <- currentPackage
|
||||
moduleInfo <- currentModule
|
||||
l <- label body
|
||||
l <- label (body >>= box)
|
||||
injValue . Closure packageInfo moduleInfo parameters l . Env.bind (foldr Set.delete freeVariables parameters) <$> getEnv
|
||||
|
||||
call op params = do
|
||||
@ -362,15 +362,13 @@ instance ( Members '[ Allocator location (Value location)
|
||||
-- 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
|
||||
a <- param
|
||||
Env.insert name a <$> rest) (pure env) (zip names params)
|
||||
localEnv (mergeEnvs bindings) (body `catchReturn` \ (Return value) -> pure value)
|
||||
Nothing -> throwValueError (CallError op)
|
||||
Nothing -> box =<< throwValueError (CallError op)
|
||||
|
||||
loop x = catchLoopControl (fix x) (\ control -> case control of
|
||||
Break value -> pure value
|
||||
Break value -> deref 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.
|
||||
Continue _ -> loop x)
|
||||
|
||||
|
||||
@ -44,7 +44,7 @@ evaluate
|
||||
. runState (Gotos lowerBound)
|
||||
. runGoto Gotos getGotos
|
||||
|
||||
newtype Gotos effects = Gotos { getGotos :: GotoTable (State (Gotos effects) ': effects) (Value Precise) }
|
||||
newtype Gotos effects = Gotos { getGotos :: GotoTable (State (Gotos effects) ': effects) Precise (Value Precise) }
|
||||
|
||||
reassociate :: Either Prelude.String (Either (SomeExc exc1) (Either (SomeExc exc2) (Either (SomeExc exc3) result))) -> Either (SomeExc (Sum '[Const Prelude.String, exc1, exc2, exc3])) result
|
||||
reassociate (Left s) = Left (SomeExc (inject (Const s)))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user