mirror of
https://github.com/github/semantic.git
synced 2024-11-24 17:04:47 +03:00
expand Ctx to EvalContext in get, put, and with function names
This commit is contained in:
parent
cd654ade6c
commit
e92846c518
@ -93,8 +93,8 @@ convergingModules recur m = do
|
||||
c <- getConfiguration (subterm (moduleBody m))
|
||||
-- Convergence here is predicated upon an Eq instance, not α-equivalence
|
||||
cache <- converge lowerBound (\ prevCache -> isolateCache $ do
|
||||
TermEvaluator (putHeap (configurationHeap c))
|
||||
TermEvaluator (putCtx (configurationContext c))
|
||||
TermEvaluator (putHeap (configurationHeap c))
|
||||
TermEvaluator (putEvalContext (configurationContext c))
|
||||
-- We need to reset fresh generation so that this invocation converges.
|
||||
resetFresh 0 $
|
||||
-- This is subtle: though the calling context supports nondeterminism, we want
|
||||
|
@ -2,9 +2,9 @@
|
||||
module Control.Abstract.Environment
|
||||
( Environment
|
||||
, Exports
|
||||
, getCtx
|
||||
, putCtx
|
||||
, withCtx
|
||||
, getEvalContext
|
||||
, putEvalContext
|
||||
, withEvalContext
|
||||
, getEnv
|
||||
, export
|
||||
, lookupEnv
|
||||
@ -30,26 +30,26 @@ import Data.Abstract.Name
|
||||
import Prologue
|
||||
|
||||
-- | Retrieve the current execution context
|
||||
getCtx :: Member (Env address) effects => Evaluator address value effects (EvalContext address)
|
||||
getCtx = send GetCtx
|
||||
getEvalContext :: Member (Env address) effects => Evaluator address value effects (EvalContext address)
|
||||
getEvalContext = send GetCtx
|
||||
|
||||
-- | Retrieve the current environment
|
||||
getEnv :: Member (Env address) effects => Evaluator address value effects (Environment address)
|
||||
getEnv = ctxEnvironment <$> getCtx
|
||||
getEnv = ctxEnvironment <$> getEvalContext
|
||||
|
||||
-- | Replace the execution context. This is only for use in Analysis.Abstract.Caching.
|
||||
putCtx :: Member (Env address) effects => EvalContext address -> Evaluator address value effects ()
|
||||
putCtx = send . PutCtx
|
||||
putEvalContext :: Member (Env address) effects => EvalContext address -> Evaluator address value effects ()
|
||||
putEvalContext = send . PutCtx
|
||||
|
||||
withCtx :: Member (Env address) effects
|
||||
=> EvalContext address
|
||||
-> Evaluator address value effects a
|
||||
-> Evaluator address value effects a
|
||||
withCtx ctx comp = do
|
||||
oldCtx <- getCtx
|
||||
putCtx ctx
|
||||
withEvalContext :: Member (Env address) effects
|
||||
=> EvalContext address
|
||||
-> Evaluator address value effects a
|
||||
-> Evaluator address value effects a
|
||||
withEvalContext ctx comp = do
|
||||
oldCtx <- getEvalContext
|
||||
putEvalContext ctx
|
||||
value <- comp
|
||||
putCtx oldCtx
|
||||
putEvalContext oldCtx
|
||||
pure value
|
||||
|
||||
-- | Add an export to the global export state.
|
||||
@ -77,7 +77,7 @@ close :: Member (Env address) effects => Set Name -> Evaluator address value eff
|
||||
close = send . Close
|
||||
|
||||
self :: Member (Env address) effects => Evaluator address value effects (Maybe address)
|
||||
self = ctxSelf <$> getCtx
|
||||
self = ctxSelf <$> getEvalContext
|
||||
|
||||
-- Effects
|
||||
|
||||
|
@ -39,7 +39,7 @@ import Prologue
|
||||
|
||||
-- | Get the current 'Configuration' with a passed-in term.
|
||||
getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address) effects, Member (State (Heap address (Cell address) value)) effects) => term -> TermEvaluator term address value effects (Configuration term address (Cell address) value)
|
||||
getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getCtx <*> TermEvaluator getHeap
|
||||
getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEvalContext <*> TermEvaluator getHeap
|
||||
|
||||
|
||||
-- | Retrieve the heap.
|
||||
|
@ -219,7 +219,7 @@ evaluateInScopedEnv :: ( AbstractValue address value effects
|
||||
evaluateInScopedEnv receiver term = do
|
||||
scopedEnv <- scopedEnvironment receiver
|
||||
env <- maybeM getEnv scopedEnv
|
||||
withCtx (EvalContext (Just receiver) env) term
|
||||
withEvalContext (EvalContext (Just receiver) env) term
|
||||
|
||||
|
||||
-- | Evaluates a 'Value' returning the referenced value
|
||||
|
@ -87,7 +87,7 @@ runFunction toEvaluator fromEvaluator = interpret $ \case
|
||||
withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do
|
||||
bindings <- foldr (\ (name, addr) rest -> Env.insert name addr <$> rest) (pure lowerBound) (zip names params)
|
||||
let fnCtx = EvalContext (Just self) (Env.push env)
|
||||
withCtx fnCtx (catchReturn (bindAll bindings *> runFunction toEvaluator fromEvaluator (toEvaluator body)))
|
||||
withEvalContext fnCtx (catchReturn (bindAll bindings *> runFunction toEvaluator fromEvaluator (toEvaluator body)))
|
||||
_ -> throwValueError (CallError op) >>= box
|
||||
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user