github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-24 17:04:47 +03:00
Code Issues Projects Releases Wiki Activity

Parameterize Evaluator by the term type.

Browse Source
This commit is contained in:
Rob Rix 2018-09-20 12:43:59 -04:00
parent bc7ea051e1
commit 038b56970e
38 changed files with 386 additions and 443 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
semantic.cabal
View File

@ -47,7 +47,6 @@ library
, Control.Abstract.PythonPackage
, Control.Abstract.Roots
, Control.Abstract.ScopeGraph
, Control.Abstract.TermEvaluator
, Control.Abstract.Value
-- Rewriting
, Control.Rewriting

40
src/Analysis/Abstract/Caching/FlowInsensitive.hs
View File

@ -16,29 +16,29 @@ import Prologue
-- | Look up the set of values for a given configuration in the in-cache.
consultOracle :: (Member (Reader (Cache term address)) effects, Ord address, Ord term)
=> Configuration term address
-> TermEvaluator term address value effects (Set (ValueRef address))
-> Evaluator term address value effects (Set (ValueRef address))
consultOracle configuration = fromMaybe mempty . cacheLookup configuration <$> ask
-- | Run an action with the given in-cache.
withOracle :: Member (Reader (Cache term address)) effects
=> Cache term address
-> TermEvaluator term address value effects a
-> TermEvaluator term address value effects a
-> Evaluator term address value effects a
-> Evaluator term address value effects a
withOracle cache = local (const cache)
-- | Look up the set of values for a given configuration in the out-cache.
lookupCache :: (Member (State (Cache term address)) effects, Ord address, Ord term)
=> Configuration term address
-> TermEvaluator term address value effects (Maybe (Set (ValueRef address)))
-> Evaluator term address value effects (Maybe (Set (ValueRef address)))
lookupCache configuration = cacheLookup configuration <$> get
-- | Run an action, caching its result and 'Heap' under the given configuration.
cachingConfiguration :: (Member (State (Cache term address)) effects, Ord address, Ord term)
=> Configuration term address
-> Set (ValueRef address)
-> TermEvaluator term address value effects (ValueRef address)
-> TermEvaluator term address value effects (ValueRef address)
-> Evaluator term address value effects (ValueRef address)
-> Evaluator term address value effects (ValueRef address)
cachingConfiguration configuration values action = do
modify' (cacheSet configuration values)
result <- action
@ -46,13 +46,13 @@ cachingConfiguration configuration values action = do
putCache :: Member (State (Cache term address)) effects
=> Cache term address
-> TermEvaluator term address value effects ()
-> Evaluator term address value effects ()
putCache = put
-- | Run an action starting from an empty out-cache, and return the out-cache afterwards.
isolateCache :: (Member (State (Cache term address)) effects, Member (State (Heap address value)) effects)
=> TermEvaluator term address value effects a
-> TermEvaluator term address value effects (Cache term address, Heap address value)
=> Evaluator term address value effects a
-> Evaluator term address value effects (Cache term address, Heap address value)
isolateCache action = putCache lowerBound *> action *> ((,) <$> get <*> get)
@ -66,8 +66,8 @@ cachingTerms :: ( Corecursive term
, Ord address
, Ord term
)
=> SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef address))
-> SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef address))
=> SubtermAlgebra (Base term) term (Evaluator term address value effects (ValueRef address))
-> SubtermAlgebra (Base term) term (Evaluator term address value effects (ValueRef address))
cachingTerms recur term = do
c <- getConfiguration (embedSubterm term)
cached <- lookupCache c
@ -93,14 +93,14 @@ convergingModules :: ( AbstractValue address value effects
, Ord address
, Ord term
)
=> SubtermAlgebra Module term (TermEvaluator term address value effects address)
-> SubtermAlgebra Module term (TermEvaluator term address value effects address)
=> SubtermAlgebra Module term (Evaluator term address value effects address)
-> SubtermAlgebra Module term (Evaluator term address value effects address)
convergingModules recur m = do
c <- getConfiguration (subterm (moduleBody m))
heap <- TermEvaluator getHeap
heap <- getHeap
-- Convergence here is predicated upon an Eq instance, not α-equivalence
(cache, _) <- converge (lowerBound, heap) (\ (prevCache, _) -> isolateCache $ do
TermEvaluator (putEvalContext (configurationContext c))
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
@ -109,7 +109,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 (address =<< runTermEvaluator (maybe empty scatter (cacheLookup c cache)))
address =<< maybe empty scatter (cacheLookup c cache)
-- | Iterate a monadic action starting from some initial seed until the results converge.
--
@ -127,17 +127,17 @@ converge seed f = loop seed
loop x'
-- | Nondeterministically write each of a collection of stores & return their associated results.
scatter :: (Foldable t, Member NonDet effects) => t (ValueRef address) -> TermEvaluator term address value effects (ValueRef address)
scatter :: (Foldable t, Member NonDet effects) => t (ValueRef address) -> Evaluator term address value effects (ValueRef address)
scatter = foldMapA pure
-- | Get the current 'Configuration' with a passed-in term.
getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address) effects)
=> term
-> TermEvaluator term address value effects (Configuration term address)
getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEvalContext
-> Evaluator term address value effects (Configuration term address)
getConfiguration term = Configuration term <$> askRoots <*> getEvalContext
caching :: Effects effects => TermEvaluator term address value (NonDet ': Reader (Cache term address) ': State (Cache term address) ': effects) a -> TermEvaluator term address value effects (Cache term address, [a])
caching :: Effects effects => Evaluator term address value (NonDet ': Reader (Cache term address) ': State (Cache term address) ': effects) a -> Evaluator term address value effects (Cache term address, [a])
caching
= runState lowerBound
. runReader lowerBound

44
src/Analysis/Abstract/Caching/FlowSensitive.hs
View File

@ -16,43 +16,43 @@ import Prologue
-- | Look up the set of values for a given configuration in the in-cache.
consultOracle :: (Cacheable term address value, Member (Reader (Cache term address value)) effects)
=> Configuration term address value
-> TermEvaluator term address value effects (Set (Cached address value))
-> Evaluator term address value effects (Set (Cached address value))
consultOracle configuration = fromMaybe mempty . cacheLookup configuration <$> ask
-- | Run an action with the given in-cache.
withOracle :: Member (Reader (Cache term address value)) effects
=> Cache term address value
-> TermEvaluator term address value effects a
-> TermEvaluator term address value effects a
-> Evaluator term address value effects a
-> Evaluator term address value effects a
withOracle cache = local (const cache)
-- | Look up the set of values for a given configuration in the out-cache.
lookupCache :: (Cacheable term address value, Member (State (Cache term address value)) effects)
=> Configuration term address value
-> TermEvaluator term address value effects (Maybe (Set (Cached address value)))
-> Evaluator term address value effects (Maybe (Set (Cached address value)))
lookupCache configuration = cacheLookup configuration <$> get
-- | Run an action, caching its result and 'Heap' under the given configuration.
cachingConfiguration :: (Cacheable term address value, Member (State (Cache term address value)) effects, Member (State (Heap address value)) effects)
=> Configuration term address value
-> Set (Cached address value)
-> TermEvaluator term address value effects (ValueRef address)
-> TermEvaluator term address value effects (ValueRef address)
-> Evaluator term address value effects (ValueRef address)
-> Evaluator term address value effects (ValueRef address)
cachingConfiguration configuration values action = do
modify' (cacheSet configuration values)
result <- Cached <$> action <*> TermEvaluator getHeap
result <- Cached <$> action <*> getHeap
cachedValue result <$ modify' (cacheInsert configuration result)
putCache :: Member (State (Cache term address value)) effects
=> Cache term address value
-> TermEvaluator term address value effects ()
-> Evaluator term address value effects ()
putCache = put
-- | Run an action starting from an empty out-cache, and return the out-cache afterwards.
isolateCache :: Member (State (Cache term address value)) effects
=> TermEvaluator term address value effects a
-> TermEvaluator term address value effects (Cache term address value)
=> Evaluator term address value effects a
-> Evaluator term address value effects (Cache term address value)
isolateCache action = putCache lowerBound *> action *> get
@ -66,8 +66,8 @@ cachingTerms :: ( Cacheable term address value
, Member (Env address) effects
, Member (State (Heap address value)) effects
)
=> SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef address))
-> SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef address))
=> SubtermAlgebra (Base term) term (Evaluator term address value effects (ValueRef address))
-> SubtermAlgebra (Base term) term (Evaluator term address value effects (ValueRef address))
cachingTerms recur term = do
c <- getConfiguration (embedSubterm term)
cached <- lookupCache c
@ -91,14 +91,14 @@ convergingModules :: ( AbstractValue address value effects
, Member (State (Heap address value)) effects
, Effects effects
)
=> SubtermAlgebra Module term (TermEvaluator term address value effects address)
-> SubtermAlgebra Module term (TermEvaluator term address value effects address)
=> SubtermAlgebra Module term (Evaluator term address value effects address)
-> SubtermAlgebra Module term (Evaluator term address value effects address)
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 (putEvalContext (configurationContext c))
putHeap (configurationHeap c)
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
@ -107,7 +107,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 (address =<< runTermEvaluator (maybe empty scatter (cacheLookup c cache)))
address =<< maybe empty scatter (cacheLookup c cache)
-- | Iterate a monadic action starting from some initial seed until the results converge.
--
@ -125,17 +125,17 @@ converge seed f = loop seed
loop x'
-- | Nondeterministically write each of a collection of stores & return their associated results.
scatter :: (Foldable t, Member NonDet effects, Member (State (Heap address value)) effects) => t (Cached address value) -> TermEvaluator term address value effects (ValueRef address)
scatter = foldMapA (\ (Cached value heap') -> TermEvaluator (putHeap heap') $> value)
scatter :: (Foldable t, Member NonDet effects, Member (State (Heap address value)) effects) => t (Cached address value) -> Evaluator term address value effects (ValueRef address)
scatter = foldMapA (\ (Cached value heap') -> putHeap heap' $> value)
-- | Get the current 'Configuration' with a passed-in term.
getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address) effects, Member (State (Heap address value)) effects)
=> term
-> TermEvaluator term address value effects (Configuration term address value)
getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEvalContext <*> TermEvaluator getHeap
-> Evaluator term address value effects (Configuration term address value)
getConfiguration term = Configuration term <$> askRoots <*> getEvalContext <*> getHeap
caching :: Effects effects => TermEvaluator term address value (NonDet ': Reader (Cache term address value) ': State (Cache term address value) ': effects) a -> TermEvaluator term address value effects (Cache term address value, [a])
caching :: Effects effects => Evaluator term address value (NonDet ': Reader (Cache term address value) ': State (Cache term address value) ': effects) a -> Evaluator term address value effects (Cache term address value, [a])
caching
= runState lowerBound
. runReader lowerBound

10
src/Analysis/Abstract/Collecting.hs
View File

@ -13,13 +13,13 @@ collectingTerms :: ( Member (Reader (Live address)) effects
, Ord address
, ValueRoots address value
)
=> SubtermAlgebra (Base term) term (TermEvaluator term address value effects value)
-> SubtermAlgebra (Base term) term (TermEvaluator term address value effects value)
=> SubtermAlgebra (Base term) term (Evaluator term address value effects value)
-> SubtermAlgebra (Base term) term (Evaluator term address value effects value)
collectingTerms recur term = do
roots <- TermEvaluator askRoots
roots <- askRoots
v <- recur term
v <$ TermEvaluator (gc (roots <> valueRoots v))
v <$ gc (roots <> valueRoots v)
providingLiveSet :: (Effectful (m address value), PureEffects effects) => m address value (Reader (Live address) ': effects) a -> m address value effects a
providingLiveSet :: PureEffects effects => Evaluator term address value (Reader (Live address) ': effects) a -> Evaluator term address value effects a
providingLiveSet = runReader lowerBound

14
src/Analysis/Abstract/Dead.hs
View File

@ -19,11 +19,11 @@ newtype Dead term = Dead { unDead :: Set term }
deriving instance Ord term => Reducer term (Dead term)
-- | Update the current 'Dead' set.
killAll :: Member (State (Dead term)) effects => Dead term -> TermEvaluator term address value effects ()
killAll :: Member (State (Dead term)) effects => Dead term -> Evaluator term address value effects ()
killAll = put
-- | Revive a single term, removing it from the current 'Dead' set.
revive :: (Member (State (Dead term)) effects, Ord term) => term -> TermEvaluator term address value effects ()
revive :: (Member (State (Dead term)) effects, Ord term) => term -> Evaluator term address value effects ()
revive t = modify' (Dead . delete t . unDead)
-- | Compute the set of all subterms recursively.
@ -35,8 +35,8 @@ revivingTerms :: ( Corecursive term
, Member (State (Dead term)) effects
, Ord term
)
=> SubtermAlgebra (Base term) term (TermEvaluator term address value effects a)
-> SubtermAlgebra (Base term) term (TermEvaluator term address value effects a)
=> SubtermAlgebra (Base term) term (Evaluator term address value effects a)
-> SubtermAlgebra (Base term) term (Evaluator term address value effects a)
revivingTerms recur term = revive (embedSubterm term) *> recur term
killingModules :: ( Foldable (Base term)
@ -44,9 +44,9 @@ killingModules :: ( Foldable (Base term)
, Ord term
, Recursive term
)
=> SubtermAlgebra Module term (TermEvaluator term address value effects a)
-> SubtermAlgebra Module term (TermEvaluator term address value effects a)
=> SubtermAlgebra Module term (Evaluator term address value effects a)
-> SubtermAlgebra Module term (Evaluator term address value effects a)
killingModules recur m = killAll (subterms (subterm (moduleBody m))) *> recur m
providingDeadSet :: Effects effects => TermEvaluator term address value (State (Dead term) ': effects) a -> TermEvaluator term address value effects (Dead term, a)
providingDeadSet :: Effects effects => Evaluator term address value (State (Dead term) ': effects) a -> Evaluator term address value effects (Dead term, a)
providingDeadSet = runState lowerBound

40
src/Analysis/Abstract/Graph.hs
View File

@ -79,8 +79,8 @@ graphingTerms :: ( Member (Reader ModuleInfo) effects
, Functor syntax
, term ~ Term syntax (Record fields)
)
=> SubtermAlgebra (Base term) term (TermEvaluator term (Hole context (Located address)) value effects (ValueRef (Hole context (Located address))))
-> SubtermAlgebra (Base term) term (TermEvaluator term (Hole context (Located address)) value effects (ValueRef (Hole context (Located address))))
=> SubtermAlgebra (Base term) term (Evaluator term (Hole context (Located address)) value effects (ValueRef (Hole context (Located address))))
-> SubtermAlgebra (Base term) term (Evaluator term (Hole context (Located address)) value effects (ValueRef (Hole context (Located address))))
graphingTerms recur term@(In a syntax) = do
definedInModule <- currentModule
case toVertex a definedInModule (subterm <$> syntax) of
@ -88,7 +88,7 @@ graphingTerms recur term@(In a syntax) = do
Just (v@Method{}, _) -> recurWithContext v
Just (v@Variable{..}, name) -> do
variableDefinition v
maybeAddr <- TermEvaluator (lookupEnv name)
maybeAddr <- lookupEnv name
case maybeAddr of
Just a -> do
defined <- gets (Map.lookup a)
@ -102,7 +102,7 @@ graphingTerms recur term@(In a syntax) = do
moduleInclusion v
local (const v) $ do
valRef <- recur term
addr <- TermEvaluator (Control.Abstract.address valRef)
addr <- Control.Abstract.address valRef
modify' (Map.insert addr v)
pure valRef
@ -111,8 +111,8 @@ graphingPackages :: ( Member (Reader PackageInfo) effects
, Member (State (Graph ControlFlowVertex)) effects
, Member (Reader ControlFlowVertex) effects
)
=> SubtermAlgebra Module term (TermEvaluator term address value effects a)
-> SubtermAlgebra Module term (TermEvaluator term address value effects a)
=> SubtermAlgebra Module term (Evaluator term address value effects a)
-> SubtermAlgebra Module term (Evaluator term address value effects a)
graphingPackages recur m =
let v = moduleVertex (moduleInfo m) in packageInclusion v *> local (const v) (recur m)
@ -124,8 +124,8 @@ graphingModules :: forall term address value effects a
, Member (Reader ControlFlowVertex) effects
, PureEffects effects
)
=> SubtermAlgebra Module term (TermEvaluator term address value effects a)
-> SubtermAlgebra Module term (TermEvaluator term address value effects a)
=> SubtermAlgebra Module term (Evaluator term address value effects a)
-> SubtermAlgebra Module term (Evaluator term address value effects a)
graphingModules recur m = do
let v = moduleVertex (moduleInfo m)
appendGraph (vertex v)
@ -147,8 +147,8 @@ graphingModuleInfo :: forall term address value effects a
, Member (State (Graph ModuleInfo)) effects
, PureEffects effects
)
=> SubtermAlgebra Module term (TermEvaluator term address value effects a)
-> SubtermAlgebra Module term (TermEvaluator term address value effects a)
=> SubtermAlgebra Module term (Evaluator term address value effects a)
-> SubtermAlgebra Module term (Evaluator term address value effects a)
graphingModuleInfo recur m = do
appendGraph (vertex (moduleInfo m))
eavesdrop @(Modules address) (\ eff -> case eff of
@ -158,25 +158,21 @@ graphingModuleInfo recur m = do
(recur m)
-- | Add an edge from the current package to the passed vertex.
packageInclusion :: ( Effectful m
, Member (Reader PackageInfo) effects
packageInclusion :: ( Member (Reader PackageInfo) effects
, Member (State (Graph ControlFlowVertex)) effects
, Monad (m effects)
)
=> ControlFlowVertex
-> m effects ()
-> Evaluator term address value effects ()
packageInclusion v = do
p <- currentPackage
appendGraph (vertex (packageVertex p) `connect` vertex v)
-- | Add an edge from the current module to the passed vertex.
moduleInclusion :: ( Effectful m
, Member (Reader ModuleInfo) effects
moduleInclusion :: ( Member (Reader ModuleInfo) effects
, Member (State (Graph ControlFlowVertex)) effects
, Monad (m effects)
)
=> ControlFlowVertex
-> m effects ()
-> Evaluator term address value effects ()
moduleInclusion v = do
m <- currentModule
appendGraph (vertex (moduleVertex m) `connect` vertex v)
@ -186,15 +182,15 @@ variableDefinition :: ( Member (State (Graph ControlFlowVertex)) effects
, Member (Reader ControlFlowVertex) effects
)
=> ControlFlowVertex
-> TermEvaluator term (Hole context (Located address)) value effects ()
-> Evaluator term (Hole context (Located address)) value effects ()
variableDefinition var = do
context <- ask
appendGraph $ vertex context `connect` vertex var
appendGraph :: (Effectful m, Member (State (Graph v)) effects) => Graph v -> m effects ()
appendGraph :: Member (State (Graph v)) effects => Graph v -> Evaluator term address value effects ()
appendGraph = modify' . (<>)
graphing :: (Effectful m, Effects effects, Functor (m (State (Graph ControlFlowVertex) : effects)))
=> m (State (Map (Hole context (Located address)) ControlFlowVertex) ': State (Graph ControlFlowVertex) ': effects) result -> m effects (Graph ControlFlowVertex, result)
graphing :: Effects effects
=> Evaluator term (Hole context (Located address)) value (State (Map (Hole context (Located address)) ControlFlowVertex) ': State (Graph ControlFlowVertex) ': effects) result -> Evaluator term (Hole context (Located address)) value effects (Graph ControlFlowVertex, result)
graphing = runState mempty . fmap snd . runState lowerBound

12
src/Analysis/Abstract/Tracing.hs
View File

@ -20,22 +20,22 @@ tracingTerms :: ( Corecursive term
, Reducer (Configuration term address value) (trace (Configuration term address value))
)
=> trace (Configuration term address value)
-> SubtermAlgebra (Base term) term (TermEvaluator term address value effects a)
-> SubtermAlgebra (Base term) term (TermEvaluator term address value effects a)
-> SubtermAlgebra (Base term) term (Evaluator term address value effects a)
-> SubtermAlgebra (Base term) term (Evaluator term address value effects a)
tracingTerms proxy recur term = getConfiguration (embedSubterm term) >>= trace . (`asTypeOf` proxy) . Reducer.unit >> recur term
trace :: Member (Writer (trace (Configuration term address value))) effects => trace (Configuration term address value) -> TermEvaluator term address value effects ()
trace :: Member (Writer (trace (Configuration term address value))) effects => trace (Configuration term address value) -> Evaluator term address value effects ()
trace = tell
tracing :: (Monoid (trace (Configuration term address value)), Effects effects) => TermEvaluator term address value (Writer (trace (Configuration term address value)) ': effects) a -> TermEvaluator term address value effects (trace (Configuration term address value), a)
tracing :: (Monoid (trace (Configuration term address value)), Effects effects) => Evaluator term address value (Writer (trace (Configuration term address value)) ': effects) a -> Evaluator term address value effects (trace (Configuration term address value), a)
tracing = runWriter
-- | Get the current 'Configuration' with a passed-in term.
getConfiguration :: (Member (Env address) effects, Member (State (Heap address value)) effects)
=> term
-> TermEvaluator term address value effects (Configuration term address value)
getConfiguration term = Configuration term <$> TermEvaluator getEvalContext <*> TermEvaluator getHeap
-> Evaluator term address value effects (Configuration term address value)
getConfiguration term = Configuration term <$> getEvalContext <*> getHeap
-- | A single point in a program’s execution.
data Configuration term address value = Configuration

1
src/Control/Abstract.hs
View File

@ -10,5 +10,4 @@ import Control.Abstract.Hole 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

48
src/Control/Abstract/Environment.hs
View File

@ -36,22 +36,22 @@ import Data.Span
import Prologue
-- | Retrieve the current execution context
getEvalContext :: Member (Env address) effects => Evaluator address value effects (EvalContext address)
getEvalContext :: Member (Env address) effects => Evaluator term address value effects (EvalContext address)
getEvalContext = send GetCtx
-- | Retrieve the current environment
getEnv :: Member (Env address) effects
=> Evaluator address value effects (Environment address)
=> Evaluator term address value effects (Environment address)
getEnv = ctxEnvironment <$> getEvalContext
-- | Replace the execution context. This is only for use in Analysis.Abstract.Caching.
putEvalContext :: Member (Env address) effects => EvalContext address -> Evaluator address value effects ()
putEvalContext :: Member (Env address) effects => EvalContext address -> Evaluator term address value effects ()
putEvalContext = send . PutCtx
withEvalContext :: Member (Env address) effects
=> EvalContext address
-> Evaluator address value effects a
-> Evaluator address value effects a
-> Evaluator term address value effects a
-> Evaluator term address value effects a
withEvalContext ctx comp = do
oldCtx <- getEvalContext
putEvalContext ctx
@ -60,30 +60,30 @@ withEvalContext ctx comp = do
pure value
-- | Add an export to the global export state.
export :: Member (Env address) effects => Name -> Name -> Maybe address -> Evaluator address value effects ()
export :: Member (Env address) effects => Name -> Name -> Maybe address -> Evaluator term address value effects ()
export name alias addr = send (Export name alias addr)
-- | Look a 'Name' up in the current environment, trying the default environment if no value is found.
lookupEnv :: Member (Env address) effects => Name -> Evaluator address value effects (Maybe address)
lookupEnv :: Member (Env address) effects => Name -> Evaluator term address value effects (Maybe address)
lookupEnv name = send (Lookup name)
-- | Bind a 'Name' to an address in the current scope.
bind :: Member (Env address) effects => Name -> address -> Evaluator address value effects ()
bind :: Member (Env address) effects => Name -> address -> Evaluator term address value effects ()
bind name addr = send (Bind name addr)
-- | Bind all of the names from an 'Environment' in the current scope.
bindAll :: Member (Env address) effects => Bindings address -> Evaluator address value effects ()
bindAll :: Member (Env address) effects => Bindings address -> Evaluator term address value effects ()
bindAll = foldr ((>>) . uncurry bind) (pure ()) . Env.pairs
-- | Run an action in a new local scope.
locally :: forall address value effects a . Member (Env address) effects => Evaluator address value effects a -> Evaluator address value effects a
locally :: forall term address value effects a . Member (Env address) effects => Evaluator term address value effects a -> Evaluator term address value effects a
locally = send . Locally @_ @_ @address . lowerEff
close :: Member (Env address) effects => Set Name -> Evaluator address value effects (Environment address)
close :: Member (Env address) effects => Set Name -> Evaluator term address value effects (Environment address)
close = send . Close
self :: Member (Env address) effects => Evaluator address value effects (Maybe address)
self :: Member (Env address) effects => Evaluator term address value effects (Maybe address)
self = ctxSelf <$> getEvalContext
-- | Look up or allocate an address for a 'Name'.
@ -91,7 +91,7 @@ lookupOrAlloc :: ( Member (Allocator address) effects
, Member (Env address) effects
)
=> Name
-> Evaluator address value effects address
-> Evaluator term address value effects address
lookupOrAlloc name = lookupEnv name >>= maybeM (alloc name)
letrec :: ( Member (Allocator address) effects
@ -101,8 +101,8 @@ letrec :: ( Member (Allocator address) effects
, Ord address
)
=> Name
-> Evaluator address value effects value
-> Evaluator address value effects (value, address)
-> Evaluator term address value effects value
-> Evaluator term address value effects (value, address)
letrec name body = do
addr <- lookupOrAlloc name
v <- locally (bind name addr *> body)
@ -114,8 +114,8 @@ letrec' :: ( Member (Allocator address) effects
, Member (Env address) effects
)
=> Name
-> (address -> Evaluator address value effects a)
-> Evaluator address value effects a
-> (address -> Evaluator term address value effects a)
-> Evaluator term address value effects a
letrec' name body = do
addr <- lookupOrAlloc name
v <- locally (body addr)
@ -128,7 +128,7 @@ variable :: ( Member (Env address) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
)
=> Name
-> Evaluator address value effects address
-> Evaluator term address value effects address
variable name = lookupEnv name >>= maybeM (freeVariableError name)
-- Effects
@ -156,8 +156,8 @@ instance Effect (Env address) where
-- New bindings created in the computation are returned.
runEnv :: Effects effects
=> EvalContext address
-> Evaluator address value (Env address ': effects) a
-> Evaluator address value effects (Bindings address, a)
-> Evaluator term address value (Env address ': effects) a
-> Evaluator term address value effects (Bindings address, a)
runEnv initial = fmap (filterEnv . fmap (first (Env.head . ctxEnvironment))) . runState lowerBound . runState initial . reinterpret2 handleEnv
where -- TODO: If the set of exports is empty because no exports have been
-- defined, do we export all terms, or no terms? This behavior varies across
@ -166,9 +166,9 @@ runEnv initial = fmap (filterEnv . fmap (first (Env.head . ctxEnvironment))) . r
| Exports.null ports = (binds, a)
| otherwise = (Exports.toBindings ports <> Env.aliasBindings (Exports.aliases ports) binds, a)
handleEnv :: forall address value effects a . Effects effects
handleEnv :: forall term address value effects a . Effects effects
=> Env address (Eff (Env address ': effects)) a
-> Evaluator address value (State (EvalContext address) ': State (Exports address) ': effects) a
-> Evaluator term address value (State (EvalContext address) ': State (Exports address) ': effects) a
handleEnv = \case
Lookup name -> Env.lookupEnv' name . ctxEnvironment <$> get
Bind name addr -> modify (\EvalContext{..} -> EvalContext ctxSelf (Env.insertEnv name addr ctxEnvironment))
@ -186,7 +186,7 @@ freeVariableError :: ( Member (Reader ModuleInfo) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
)
=> Name
-> Evaluator address value effects address
-> Evaluator term address value effects address
freeVariableError = throwEnvironmentError . FreeVariable
runEnvironmentError :: (Effectful (m address value), Effects effects)
@ -205,5 +205,5 @@ throwEnvironmentError :: ( Member (Resumable (BaseError (EnvironmentError addres
, Member (Reader Span) effects
)
=> EnvironmentError address resume
-> Evaluator address value effects resume
-> Evaluator term address value effects resume
throwEnvironmentError = throwBaseError

20
src/Control/Abstract/Evaluator.hs
View File

@ -31,11 +31,11 @@ import Prologue hiding (MonadError(..))
-- These parameters enable us to constrain the types of effects using them s.t. we can avoid both ambiguous types when they aren’t mentioned outside of the context, and lengthy, redundant annotations on the use sites of functions employing these effects.
--
-- These effects will typically include the environment, heap, module table, etc. effects necessary for evaluation of modules and terms, but may also include any other effects so long as they’re eventually handled.
newtype Evaluator address value effects a = Evaluator { runEvaluator :: Eff effects a }
newtype Evaluator term address value effects a = Evaluator { runEvaluator :: Eff effects a }
deriving (Applicative, Effectful, Functor, Monad)
deriving instance Member NonDet effects => Alternative (Evaluator address value effects)
deriving instance Member (Lift IO) effects => MonadIO (Evaluator address value effects)
deriving instance Member NonDet effects => Alternative (Evaluator term address value effects)
deriving instance Member (Lift IO) effects => MonadIO (Evaluator term address value effects)
-- Effects
@ -45,13 +45,13 @@ newtype Return address = Return { unReturn :: address }
earlyReturn :: Member (Exc (Return address)) effects
=> address
-> Evaluator address value effects address
-> Evaluator term address value effects address
earlyReturn = throwError . Return
catchReturn :: (Member (Exc (Return address)) effects, Effectful (m address value)) => m address value effects address -> m address value effects address
catchReturn :: Member (Exc (Return address)) effects => Evaluator term address value effects address -> Evaluator term address value effects address
catchReturn = Eff.raiseHandler (handleError (\ (Return addr) -> pure addr))
runReturn :: (Effectful (m address value), Effects effects) => m address value (Exc (Return address) ': effects) address -> m address value effects address
runReturn :: Effects effects => Evaluator term address value (Exc (Return address) ': effects) address -> Evaluator term address value effects address
runReturn = Eff.raiseHandler (fmap (either unReturn id) . runError)
@ -63,16 +63,16 @@ data LoopControl address
throwBreak :: Member (Exc (LoopControl address)) effects
=> address
-> Evaluator address value effects address
-> Evaluator term address value effects address
throwBreak = throwError . Break
throwContinue :: Member (Exc (LoopControl address)) effects
=> address
-> Evaluator address value effects address
-> Evaluator term address value effects address
throwContinue = throwError . Continue
catchLoopControl :: (Member (Exc (LoopControl address)) effects, Effectful (m address value)) => m address value effects a -> (LoopControl address -> m address value effects a) -> m address value effects a
catchLoopControl :: Member (Exc (LoopControl address)) effects => Evaluator term address value effects a -> (LoopControl address -> Evaluator term address value effects a) -> Evaluator term address value effects a
catchLoopControl = catchError
runLoopControl :: (Effectful (m address value), Effects effects) => m address value (Exc (LoopControl address) ': effects) address -> m address value effects address
runLoopControl :: Effects effects => Evaluator term address value (Exc (LoopControl address) ': effects) address -> Evaluator term address value effects address
runLoopControl = Eff.raiseHandler (fmap (either unLoopControl id) . runError)

36
src/Control/Abstract/Heap.hs
View File

@ -30,15 +30,15 @@ import Data.Span (Span)
import Prologue
-- | Retrieve the heap.
getHeap :: Member (State (Heap address value)) effects => Evaluator address value effects (Heap address value)
getHeap :: Member (State (Heap address value)) effects => Evaluator term address value effects (Heap address value)
getHeap = get
-- | Set the heap.
putHeap :: Member (State (Heap address value)) effects => Heap address value -> Evaluator address value effects ()
putHeap :: Member (State (Heap address value)) effects => Heap address value -> Evaluator term address value effects ()
putHeap = put
-- | Update the heap.
modifyHeap :: Member (State (Heap address value)) effects => (Heap address value -> Heap address value) -> Evaluator address value effects ()
modifyHeap :: Member (State (Heap address value)) effects => (Heap address value -> Heap address value) -> Evaluator term address value effects ()
modifyHeap = modify'
box :: ( Member (Allocator address) effects
@ -48,17 +48,17 @@ box :: ( Member (Allocator address) effects
, Ord address
)
=> value
-> Evaluator address value effects address
-> Evaluator term address value effects address
box val = do
name <- gensym
addr <- alloc name
assign addr val
pure addr
alloc :: Member (Allocator address) effects => Name -> Evaluator address value effects address
alloc :: Member (Allocator address) effects => Name -> Evaluator term address value effects address
alloc = send . Alloc
dealloc :: (Member (State (Heap address value)) effects, Ord address) => address -> Evaluator address value effects ()
dealloc :: (Member (State (Heap address value)) effects, Ord address) => address -> Evaluator term address value effects ()
dealloc addr = modifyHeap (heapDelete addr)
-- | Dereference the given address in the heap, or fail if the address is uninitialized.
@ -70,7 +70,7 @@ deref :: ( Member (Deref value) effects
, Ord address
)
=> address
-> Evaluator address value effects value
-> Evaluator term address value effects value
deref addr = gets (heapLookup addr) >>= maybeM (throwAddressError (UnallocatedAddress addr)) >>= send . DerefCell >>= maybeM (throwAddressError (UninitializedAddress addr))
@ -81,7 +81,7 @@ assign :: ( Member (Deref value) effects
)
=> address
-> value
-> Evaluator address value effects ()
-> Evaluator term address value effects ()
assign addr value = do
heap <- getHeap
cell <- send (AssignCell value (fromMaybe lowerBound (heapLookup addr heap)))
@ -96,7 +96,7 @@ gc :: ( Member (State (Heap address value)) effects
, ValueRoots address value
)
=> Live address -- ^ The set of addresses to consider rooted.
-> Evaluator address value effects ()
-> Evaluator term address value effects ()
gc roots = modifyHeap (heapRestrict <*> reachable roots)
-- | Compute the set of addresses reachable from a given root set in a given heap.
@ -152,18 +152,16 @@ throwAddressError :: ( Member (Resumable (BaseError (AddressError address body))
, Member (Reader Span) effects
)
=> AddressError address body resume
-> Evaluator address value effects resume
-> Evaluator term address value effects resume
throwAddressError = throwBaseError
runAddressError :: ( Effectful (m address value)
, Effects effects
)
=> m address value (Resumable (BaseError (AddressError address value)) ': effects) a
-> m address value effects (Either (SomeExc (BaseError (AddressError address value))) a)
runAddressError :: Effects effects
=> Evaluator term address value (Resumable (BaseError (AddressError address value)) ': effects) a
-> Evaluator term address value effects (Either (SomeExc (BaseError (AddressError address value))) a)
runAddressError = runResumable
runAddressErrorWith :: (Effectful (m address value), Effects effects)
=> (forall resume . (BaseError (AddressError address value)) resume -> m address value effects resume)
-> m address value (Resumable (BaseError (AddressError address value)) ': effects) a
-> m address value effects a
runAddressErrorWith :: Effects effects
=> (forall resume . (BaseError (AddressError address value)) resume -> Evaluator term address value effects resume)
-> Evaluator term address value (Resumable (BaseError (AddressError address value)) ': effects) a
-> Evaluator term address value effects a
runAddressErrorWith = runResumableWith

50
src/Control/Abstract/Modules.hs
View File

@ -35,27 +35,27 @@ import Data.Abstract.ScopeGraph
type ModuleResult address = (ScopeGraph address, (Bindings address, address))
-- | Retrieve an evaluated module, if any. @Nothing@ means we’ve never tried to load it, and @Just (env, value)@ indicates the result of a completed load.
lookupModule :: Member (Modules address) effects => ModulePath -> Evaluator address value effects (Maybe (ModuleResult address))
lookupModule :: Member (Modules address) effects => ModulePath -> Evaluator term address value effects (Maybe (ModuleResult address))
lookupModule = sendModules . Lookup
-- | Resolve a list of module paths to a possible module table entry.
resolve :: Member (Modules address) effects => [FilePath] -> Evaluator address value effects (Maybe ModulePath)
resolve :: Member (Modules address) effects => [FilePath] -> Evaluator term address value effects (Maybe ModulePath)
resolve = sendModules . Resolve
listModulesInDir :: Member (Modules address) effects => FilePath -> Evaluator address value effects [ModulePath]
listModulesInDir :: Member (Modules address) effects => FilePath -> Evaluator term address value effects [ModulePath]
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 address) effects => ModulePath -> Evaluator address value effects (ModuleResult address)
require :: Member (Modules address) effects => ModulePath -> Evaluator term address value effects (ModuleResult address)
require path = lookupModule path >>= maybeM (load path)
-- | Load another module by name and return its environment and value.
--
-- Always loads/evaluates.
load :: Member (Modules address) effects => ModulePath -> Evaluator address value effects (ModuleResult address)
load :: Member (Modules address) effects => ModulePath -> Evaluator term address value effects (ModuleResult address)
load path = sendModules (Load path)
@ -72,7 +72,7 @@ instance Effect (Modules address) where
handleState c dist (Request (Resolve paths) k) = Request (Resolve paths) (dist . (<$ c) . k)
handleState c dist (Request (List path) k) = Request (List path) (dist . (<$ c) . k)
sendModules :: Member (Modules address) effects => Modules address (Eff effects) return -> Evaluator address value effects return
sendModules :: Member (Modules address) effects => Modules address (Eff effects) return -> Evaluator term address value effects return
sendModules = send
runModules :: ( Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) effects
@ -80,15 +80,15 @@ runModules :: ( Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult addr
, PureEffects effects
)
=> Set ModulePath
-> Evaluator address value (Modules address ': effects) a
-> Evaluator address value effects a
-> Evaluator term address value (Modules address ': effects) a
-> Evaluator term address value effects a
runModules paths = interpret $ \case
Load name -> fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup name <$> askModuleTable >>= maybeM (throwLoadError (ModuleNotFoundError name))
Lookup path -> fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup path <$> askModuleTable
Resolve names -> pure (find (`Set.member` paths) names)
List dir -> pure (filter ((dir ==) . takeDirectory) (toList paths))
askModuleTable :: Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) effects => Evaluator address value effects (ModuleTable (NonEmpty (Module (ModuleResult address))))
askModuleTable :: Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) effects => Evaluator term address value effects (ModuleTable (NonEmpty (Module (ModuleResult address))))
askModuleTable = ask
@ -109,20 +109,20 @@ instance Show1 (LoadError address) where
instance Eq1 (LoadError address) where
liftEq _ (ModuleNotFoundError a) (ModuleNotFoundError b) = a == b
runLoadError :: (Effectful (m address value), Effects effects)
=> m address value (Resumable (BaseError (LoadError address)) ': effects) a
-> m address value effects (Either (SomeExc (BaseError (LoadError address))) a)
runLoadError :: Effects effects
=> Evaluator term address value (Resumable (BaseError (LoadError address)) ': effects) a
-> Evaluator term address value effects (Either (SomeExc (BaseError (LoadError address))) a)
runLoadError = runResumable
runLoadErrorWith :: (Effectful (m address value), Effects effects)
=> (forall resume . (BaseError (LoadError address)) resume -> m address value effects resume)
-> m address value (Resumable (BaseError (LoadError address)) ': effects) a
-> m address value effects a
runLoadErrorWith :: Effects effects
=> (forall resume . (BaseError (LoadError address)) resume -> Evaluator term address value effects resume)
-> Evaluator term address value (Resumable (BaseError (LoadError address)) ': effects) a
-> Evaluator term address value effects a
runLoadErrorWith = runResumableWith
throwLoadError :: Member (Resumable (BaseError (LoadError address))) effects
=> LoadError address resume
-> Evaluator address value effects resume
-> Evaluator term address value effects resume
throwLoadError err@(ModuleNotFoundError name) = throwResumable $ BaseError (ModuleInfo name) emptySpan err
@ -143,15 +143,15 @@ instance Eq1 ResolutionError where
liftEq _ (GoImportError a) (GoImportError b) = a == b
liftEq _ _ _ = False
runResolutionError :: (Effectful m, Effects effects)
=> m (Resumable (BaseError ResolutionError) ': effects) a
-> m effects (Either (SomeExc (BaseError ResolutionError)) a)
runResolutionError :: Effects effects
=> Evaluator term address value (Resumable (BaseError ResolutionError) ': effects) a
-> Evaluator term address value effects (Either (SomeExc (BaseError ResolutionError)) a)
runResolutionError = runResumable
runResolutionErrorWith :: (Effectful m, Effects effects)
=> (forall resume . (BaseError ResolutionError) resume -> m effects resume)
-> m (Resumable (BaseError ResolutionError) ': effects) a
-> m effects a
runResolutionErrorWith :: Effects effects
=> (forall resume . (BaseError ResolutionError) resume -> Evaluator term address value effects resume)
-> Evaluator term address value (Resumable (BaseError ResolutionError) ': effects) a
-> Evaluator term address value effects a
runResolutionErrorWith = runResumableWith
throwResolutionError :: ( Member (Reader ModuleInfo) effects
@ -159,5 +159,5 @@ throwResolutionError :: ( Member (Reader ModuleInfo) effects
, Member (Resumable (BaseError ResolutionError)) effects
)
=> ResolutionError resume
-> Evaluator address value effects resume
-> Evaluator term address value effects resume
throwResolutionError = throwBaseError

28
src/Control/Abstract/Primitive.hs
View File

@ -31,8 +31,8 @@ define :: ( HasCallStack
, Ord address
)
=> Name
-> Evaluator address value effects value
-> Evaluator address value effects ()
-> Evaluator term address value effects value
-> Evaluator term address value effects ()
define name def = withCurrentCallStack callStack $ do
addr <- alloc name
def >>= assign addr
@ -50,8 +50,8 @@ defineClass :: ( AbstractValue address value effects
)
=> Name
-> [address]
-> Evaluator address value effects a
-> Evaluator address value effects ()
-> Evaluator term address value effects a
-> Evaluator term address value effects ()
defineClass name superclasses body = define name $ do
binds <- Env.head <$> locally (body >> getEnv)
klass name superclasses binds
@ -67,8 +67,8 @@ defineNamespace :: ( AbstractValue address value effects
, Ord address
)
=> Name
-> Evaluator address value effects a
-> Evaluator address value effects ()
-> Evaluator term address value effects a
-> Evaluator term address value effects ()
defineNamespace name scope = define name $ do
binds <- Env.head <$> locally (scope >> getEnv)
namespace name Nothing binds
@ -77,27 +77,27 @@ defineNamespace name scope = define name $ do
--
-- The constructed function will have the same arity as the Haskell function. Nullary functions are constructed by providing an evaluator producing an address. Note that the constructed function must not contain free variables as they will not be captured by the closure, and/or will be garbage collected.
lambda :: ( HasCallStack
, Lambda address value effects fn
, Lambda term address value effects fn
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
)
=> fn
-> Evaluator address value effects value
-> Evaluator term address value effects value
lambda body = withCurrentCallStack callStack (lambda' [] body)
-- | A class of types forming the body of 'lambda's. Note that there should in general only be two cases: a recursive case of functions taking 'Name's as parameters, and a base case of an 'Evaluator'.
class Lambda address value effects ty | ty -> address, ty -> value, ty -> effects where
class Lambda term address value effects ty | ty -> term, ty -> address, ty -> value, ty -> effects where
lambda' :: [Name]
-> ty
-> Evaluator address value effects value
-> Evaluator term address value effects value
instance (Member Fresh effects, Lambda address value effects ret) => Lambda address value effects (Name -> ret) where
instance (Member Fresh effects, Lambda term address value effects ret) => Lambda term address value effects (Name -> ret) where
lambda' vars body = do
var <- gensym
lambda' (var : vars) (body var)
{-# INLINE lambda' #-}
instance Member (Function address value) effects => Lambda address value effects (Evaluator address value effects address) where
instance Member (Function address value) effects => Lambda term address value effects (Evaluator term address value effects address) where
lambda' vars = function Nothing vars lowerBound
{-# INLINE lambda' #-}
@ -116,7 +116,7 @@ builtInPrint :: ( AbstractValue address value effects
, Member Trace effects
, Ord address
)
=> Evaluator address value effects value
=> Evaluator term address value effects value
builtInPrint = lambda (\ v -> variable v >>= deref >>= asString >>= trace . unpack >> box unit)
builtInExport :: ( AbstractValue address value effects
@ -133,7 +133,7 @@ builtInExport :: ( AbstractValue address value effects
, Member (State (Heap address value)) effects
, Ord address
)
=> Evaluator address value effects value
=> Evaluator term address value effects value
builtInExport = lambda (\ v -> do
var <- variable v >>= deref
(k, value) <- asPair var

6
src/Control/Abstract/PythonPackage.hs
View File

@ -18,7 +18,7 @@ import Prologue
data Strategy = Unknown | Packages [Text] | FindPackages [Text]
deriving (Show, Eq)
runPythonPackaging :: forall effects address body a. (
runPythonPackaging :: forall effects term address body a. (
Eff.PureEffects effects
, Ord address
, Show address
@ -39,8 +39,8 @@ runPythonPackaging :: forall effects address body a. (
, Member (Eff.Reader PackageInfo) effects
, Member (Eff.Reader Span) effects
, Member (Function address (Value address body)) effects)
=> Evaluator address (Value address body) effects a
-> Evaluator address (Value address body) effects a
=> Evaluator term address (Value address body) effects a
-> Evaluator term address (Value address body) effects a
runPythonPackaging = Eff.interpose @(Function address (Value address body)) $ \case
Call callName super params -> do
case callName of

4
src/Control/Abstract/Roots.hs
View File

@ -14,9 +14,9 @@ class ValueRoots address value where
valueRoots :: value -> Live address
-- | Retrieve the local 'Live' set.
askRoots :: Member (Reader (Live address)) effects => Evaluator address value effects (Live address)
askRoots :: Member (Reader (Live address)) effects => Evaluator term address value effects (Live address)
askRoots = ask
-- | Run a computation with the given 'Live' set added to the local root set.
extraRoots :: (Member (Reader (Live address)) effects, Ord address) => Live address -> Evaluator address value effects a -> Evaluator address value effects a
extraRoots :: (Member (Reader (Live address)) effects, Ord address) => Live address -> Evaluator term address value effects a -> Evaluator term address value effects a
extraRoots roots = local (<> roots)

24
src/Control/Abstract/ScopeGraph.hs
View File

@ -34,28 +34,28 @@ data ScopeEnv address (m :: * -> *) a where
Local :: address -> m a -> ScopeEnv address m a
AssociatedScope :: Declaration -> ScopeEnv address m (Maybe address)
lookup :: forall address value effects. Member (ScopeEnv address) effects => Reference -> Evaluator address value effects (Maybe address)
lookup :: forall term address value effects. Member (ScopeEnv address) effects => Reference -> Evaluator term address value effects (Maybe address)
lookup = send . Lookup @address
declare :: forall address value effects. Member (ScopeEnv address) effects => Declaration -> Span -> Maybe address -> Evaluator address value effects ()
declare :: forall term address value effects. Member (ScopeEnv address) effects => Declaration -> Span -> Maybe address -> Evaluator term address value effects ()
declare = ((send .) .) . Declare @address
putDeclarationScope :: forall address value effects. Member (ScopeEnv address) effects => Declaration -> address -> Evaluator address value effects ()
putDeclarationScope :: forall term address value effects. Member (ScopeEnv address) effects => Declaration -> address -> Evaluator term address value effects ()
putDeclarationScope = (send .) . PutDeclarationScope @address
reference :: forall address value effects. Member (ScopeEnv address) effects => Reference -> Declaration -> Evaluator address value effects ()
reference :: forall term address value effects. Member (ScopeEnv address) effects => Reference -> Declaration -> Evaluator term address value effects ()
reference = (send .) . Reference @address
newScope :: forall address value effects. (Member (ScopeEnv address) effects) => Map EdgeLabel [address] -> Evaluator address value effects address
newScope :: forall term address value effects. (Member (ScopeEnv address) effects) => Map EdgeLabel [address] -> Evaluator term address value effects address
newScope map = send (NewScope map)
currentScope :: forall address value effects. Member (ScopeEnv address) effects => Evaluator address value effects (Maybe address)
currentScope :: forall term address value effects. Member (ScopeEnv address) effects => Evaluator term address value effects (Maybe address)
currentScope = send CurrentScope
associatedScope :: forall address value effects. Member (ScopeEnv address) effects => Declaration -> Evaluator address value effects (Maybe address)
associatedScope :: forall term address value effects. Member (ScopeEnv address) effects => Declaration -> Evaluator term address value effects (Maybe address)
associatedScope = send . AssociatedScope
withScope :: forall address value effects m a. (Effectful (m address value), Member (ScopeEnv address) effects) => address -> m address value effects a -> m address value effects a
withScope :: forall term address value effects a. Member (ScopeEnv address) effects => address -> Evaluator term address value effects a -> Evaluator term address value effects a
withScope scope action = send (Local scope (lowerEff action))
instance PureEffect (ScopeEnv address)
@ -71,13 +71,13 @@ instance Effect (ScopeEnv address) where
runScopeEnv :: (Ord address, Effects effects, Member Fresh effects, Member (Allocator address) effects)
=> Evaluator address value (ScopeEnv address ': effects) a
-> Evaluator address value effects (ScopeGraph address, a)
=> Evaluator term address value (ScopeEnv address ': effects) a
-> Evaluator term address value effects (ScopeGraph address, a)
runScopeEnv evaluator = runState lowerBound (reinterpret handleScopeEnv evaluator)
handleScopeEnv :: forall address value effects a. (Ord address, Member Fresh effects, Member (Allocator address) effects, Effects effects)
handleScopeEnv :: forall term address value effects a. (Ord address, Member Fresh effects, Member (Allocator address) effects, Effects effects)
=> ScopeEnv address (Eff (ScopeEnv address ': effects)) a
-> Evaluator address value (State (ScopeGraph address) ': effects) a
-> Evaluator term address value (State (ScopeGraph address) ': effects) a
handleScopeEnv = \case
Lookup ref -> ScopeGraph.scopeOfRef ref <$> get
Declare decl span scope -> modify @(ScopeGraph address) (ScopeGraph.declare decl span scope)

30
src/Control/Abstract/TermEvaluator.hs
View File

@ -1,30 +0,0 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Control.Abstract.TermEvaluator
( TermEvaluator(..)
, raiseHandler
, module X
) where
import Control.Abstract.Evaluator
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 Control.Monad.IO.Class
import Prologue
-- | Evaluators specialized to some specific term type.
--
-- This is used to constrain the term type so that inference for analyses can resolve it correctly, but should not be used for any of the term-agonstic machinery like builtins, Evaluatable instances, the mechanics of the heap & environment, etc.
newtype TermEvaluator term address value effects a = TermEvaluator { runTermEvaluator :: Evaluator address value effects a }
deriving (Applicative, Effectful, Functor, Monad)
deriving instance Member NonDet effects => Alternative (TermEvaluator term address value effects)
deriving instance Member (Lift IO) effects => MonadIO (TermEvaluator term address value effects)
raiseHandler :: (Evaluator address value effects a -> Evaluator address value effects' a') -> (TermEvaluator term address value effects a -> TermEvaluator term address value effects' a')
raiseHandler f = TermEvaluator . f . runTermEvaluator

90
src/Control/Abstract/Value.hs
View File

@ -62,10 +62,10 @@ data Comparator
--
-- In the concrete domain, introductions & eliminations respectively construct & pattern match against values, while in abstract domains they respectively construct & project finite sets of discrete observations of abstract values. For example, an abstract domain modelling integers as a sign (-, 0, or +) would introduce abstract values by mapping integers to their sign and eliminate them by mapping signs back to some canonical integer, e.g. - -> -1, 0 -> 0, + -> 1.
function :: Member (Function address value) effects => Maybe Name -> [Name] -> Set Name -> Evaluator address value effects address -> Evaluator address value effects value
function :: Member (Function address value) effects => Maybe Name -> [Name] -> Set Name -> Evaluator term address value effects address -> Evaluator term address value effects value
function name params fvs (Evaluator body) = send (Function name params fvs body)
call :: Member (Function address value) effects => value -> address -> [address] -> Evaluator address value effects address
call :: Member (Function address value) effects => value -> address -> [address] -> Evaluator term address value effects address
call fn self args = send (Call fn self args)
data Function address value m result where
@ -77,19 +77,19 @@ instance PureEffect (Function address value) where
handle handler (Request (Call fn self addrs) k) = Request (Call fn self addrs) (handler . k)
-- | Construct a boolean value in the abstract domain.
boolean :: Member (Boolean value) effects => Bool -> Evaluator address value effects value
boolean :: Member (Boolean value) effects => Bool -> Evaluator term address value effects value
boolean = send . Boolean
-- | Extract a 'Bool' from a given value.
asBool :: Member (Boolean value) effects => value -> Evaluator address value effects Bool
asBool :: Member (Boolean value) effects => value -> Evaluator term address value effects Bool
asBool = send . AsBool
-- | Eliminate boolean values. TODO: s/boolean/truthy
ifthenelse :: Member (Boolean value) effects => value -> Evaluator address value effects a -> Evaluator address value effects a -> Evaluator address value effects a
ifthenelse :: Member (Boolean value) effects => value -> Evaluator term address value effects a -> Evaluator term address value effects a -> Evaluator term address value effects a
ifthenelse v t e = asBool v >>= \ c -> if c then t else e
-- | Compute the disjunction (boolean or) of two computed values. This should have short-circuiting semantics where applicable.
disjunction :: Member (Boolean value) effects => Evaluator address value effects value -> Evaluator address value effects value -> Evaluator address value effects value
disjunction :: Member (Boolean value) effects => Evaluator term address value effects value -> Evaluator term address value effects value -> Evaluator term address value effects value
disjunction (Evaluator a) (Evaluator b) = send (Disjunction a b)
data Boolean value m result where
@ -141,57 +141,57 @@ class Show value => AbstractIntro value where
-- This allows us to abstract the choice of whether to evaluate under binders for different value types.
class AbstractIntro value => AbstractValue address value effects where
-- | Cast numbers to integers
castToInteger :: value -> Evaluator address value effects value
castToInteger :: value -> Evaluator term address value effects value
-- | Lift a unary operator over a 'Num' to a function on 'value's.
liftNumeric :: (forall a . Num a => a -> a)
-> (value -> Evaluator address value effects value)
-> (value -> Evaluator term address value effects value)
-- | Lift a pair of binary operators to a function on 'value's.
-- You usually pass the same operator as both arguments, except in the cases where
-- Haskell provides different functions for integral and fractional operations, such
-- as division, exponentiation, and modulus.
liftNumeric2 :: (forall a b. Number a -> Number b -> SomeNumber)
-> (value -> value -> Evaluator address value effects value)
-> (value -> value -> Evaluator term address value effects value)
-- | Lift a Comparator (usually wrapping a function like == or <=) to a function on values.
liftComparison :: Comparator -> (value -> value -> Evaluator address value effects value)
liftComparison :: Comparator -> (value -> value -> Evaluator term address value effects value)
-- | Lift a unary bitwise operator to values. This is usually 'complement'.
liftBitwise :: (forall a . Bits a => a -> a)
-> (value -> Evaluator address value effects value)
-> (value -> Evaluator term address value effects value)
-- | Lift a binary bitwise operator to values. The Integral constraint is
-- necessary to satisfy implementation details of Haskell left/right shift,
-- but it's fine, since these are only ever operating on integral values.
liftBitwise2 :: (forall a . (Integral a, Bits a) => a -> a -> a)
-> (value -> value -> Evaluator address value effects value)
-> (value -> value -> Evaluator term address value effects value)
unsignedRShift :: value -> value -> Evaluator address value effects value
unsignedRShift :: value -> value -> Evaluator term address value effects value
-- | Construct an N-ary tuple of multiple (possibly-disjoint) values
tuple :: [address] -> Evaluator address value effects value
tuple :: [address] -> Evaluator term address value effects value
-- | Construct an array of zero or more values.
array :: [address] -> Evaluator address value effects value
array :: [address] -> Evaluator term address value effects value
asArray :: value -> Evaluator address value effects [address]
asArray :: value -> Evaluator term address value effects [address]
-- | Extract the contents of a key-value pair as a tuple.
asPair :: value -> Evaluator address value effects (value, value)
asPair :: value -> Evaluator term address value effects (value, value)
-- | Extract a 'Text' from a given value.
asString :: value -> Evaluator address value effects Text
asString :: value -> Evaluator term address value effects Text
-- | @index x i@ computes @x[i]@, with zero-indexing.
index :: value -> value -> Evaluator address value effects address
index :: value -> value -> Evaluator term address value effects address
-- | Build a class value from a name and environment.
klass :: Name -- ^ The new class's identifier
-> [address] -- ^ A list of superclasses
-> Bindings address -- ^ The environment to capture
-> Evaluator address value effects value
-> Evaluator term address value effects value
-- | Build a namespace value from a name and environment stack
--
@ -199,15 +199,15 @@ class AbstractIntro value => AbstractValue address value effects where
namespace :: Name -- ^ The namespace's identifier
-> Maybe address -- The ancestor of the namespace
-> Bindings address -- ^ The environment to mappend
-> Evaluator address value effects value
-> Evaluator term address value effects value
-- | Extract the environment from any scoped object (e.g. classes, namespaces, etc).
scopedEnvironment :: address -> Evaluator address value effects (Maybe (Environment address))
scopedEnvironment :: address -> Evaluator term address value effects (Maybe (Environment address))
-- | Primitive looping combinator, approximately equivalent to 'fix'. This should be used in place of direct recursion, as it allows abstraction over recursion.
--
-- The function argument takes an action which recurs through the loop.
loop :: (Evaluator address value effects value -> Evaluator address value effects value) -> Evaluator address value effects value
loop :: (Evaluator term address value effects value -> Evaluator term address value effects value) -> Evaluator term address value effects value
-- | C-style for loops.
@ -215,28 +215,28 @@ forLoop :: ( AbstractValue address value effects
, Member (Boolean value) effects
, Member (Env address) effects
)
=> Evaluator address value effects value -- ^ Initial statement
-> Evaluator address value effects value -- ^ Condition
-> Evaluator address value effects value -- ^ Increment/stepper
-> Evaluator address value effects value -- ^ Body
-> Evaluator address value effects value
=> Evaluator term address value effects value -- ^ Initial statement
-> Evaluator term address value effects value -- ^ Condition
-> Evaluator term address value effects value -- ^ Increment/stepper
-> Evaluator term address value effects value -- ^ Body
-> Evaluator term address value effects value
forLoop initial cond step body =
locally (initial *> while cond (body *> step))
-- | The fundamental looping primitive, built on top of 'ifthenelse'.
while :: (AbstractValue address value effects, Member (Boolean value) effects)
=> Evaluator address value effects value
-> Evaluator address value effects value
-> Evaluator address value effects value
=> Evaluator term address value effects value
-> Evaluator term address value effects value
-> Evaluator term address value effects value
while cond body = loop $ \ continue -> do
this <- cond
ifthenelse this (body *> continue) (pure unit)
-- | Do-while loop, built on top of while.
doWhile :: (AbstractValue address value effects, Member (Boolean value) effects)
=> Evaluator address value effects value
-> Evaluator address value effects value
-> Evaluator address value effects value
=> Evaluator term address value effects value
-> Evaluator term address value effects value
-> Evaluator term address value effects value
doWhile body cond = loop $ \ continue -> body *> do
this <- cond
ifthenelse this continue (pure unit)
@ -250,8 +250,8 @@ makeNamespace :: ( AbstractValue address value effects
=> Name
-> address
-> Maybe address
-> Evaluator address value effects ()
-> Evaluator address value effects value
-> Evaluator term address value effects ()
-> Evaluator term address value effects value
makeNamespace name addr super body = do
namespaceBinds <- Env.head <$> locally (body >> getEnv)
v <- namespace name super namespaceBinds
@ -263,8 +263,8 @@ evaluateInScopedEnv :: ( AbstractValue address value effects
, Member (Env address) effects
)
=> address
-> Evaluator address value effects a
-> Evaluator address value effects a
-> Evaluator term address value effects a
-> Evaluator term address value effects a
evaluateInScopedEnv receiver term = do
scopedEnv <- scopedEnvironment receiver
env <- maybeM getEnv scopedEnv
@ -283,7 +283,7 @@ value :: ( AbstractValue address value effects
, Ord address
)
=> ValueRef address
-> Evaluator address value effects value
-> Evaluator term address value effects value
value = deref <=< address
-- | Evaluates a 'Subterm' to its rval
@ -297,8 +297,8 @@ subtermValue :: ( AbstractValue address value effects
, Member (State (Heap address value)) effects
, Ord address
)
=> Subterm term (Evaluator address value effects (ValueRef address))
-> Evaluator address value effects value
=> Subterm term (Evaluator term address value effects (ValueRef address))
-> Evaluator term address value effects value
subtermValue = value <=< subtermRef
-- | Returns the address of a value referenced by a 'ValueRef'
@ -309,7 +309,7 @@ address :: ( AbstractValue address value effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
)
=> ValueRef address
-> Evaluator address value effects address
-> Evaluator term address value effects address
address (LvalLocal var) = variable var
address (LvalMember ptr prop) = evaluateInScopedEnv ptr (variable prop)
address (Rval addr) = pure addr
@ -321,8 +321,8 @@ subtermAddress :: ( AbstractValue address value effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
)
=> Subterm term (Evaluator address value effects (ValueRef address))
-> Evaluator address value effects address
=> Subterm term (Evaluator term address value effects (ValueRef address))
-> Evaluator term address value effects address
subtermAddress = address <=< subtermRef
-- | Convenience function for boxing a raw value and wrapping it in an Rval
@ -333,5 +333,5 @@ rvalBox :: ( Member (Allocator address) effects
, Ord address
)
=> value
-> Evaluator address value effects (ValueRef address)
-> Evaluator term address value effects (ValueRef address)
rvalBox val = Rval <$> box val

22
src/Data/Abstract/Address/Hole.hs
View File

@ -22,29 +22,29 @@ toMaybe (Partial _) = Nothing
toMaybe (Total a) = Just a
relocate :: Evaluator address1 value effects a -> Evaluator address2 value effects a
relocate :: Evaluator term address1 value effects a -> Evaluator term address2 value effects a
relocate = raiseEff . lowerEff
runAllocator :: PureEffects effects
=> (forall x. Allocator address (Eff (Allocator address ': effects)) x -> Evaluator address value effects x)
-> Evaluator (Hole context address) value (Allocator (Hole context address) ': effects) a
-> Evaluator (Hole context address) value effects a
=> (forall x. Allocator address (Eff (Allocator address ': effects)) x -> Evaluator term address value effects x)
-> Evaluator term (Hole context address) value (Allocator (Hole context address) ': effects) a
-> Evaluator term (Hole context address) value effects a
runAllocator handler = interpret (handleAllocator handler)
handleAllocator :: (forall x. Allocator address (Eff (Allocator address ': effects)) x -> Evaluator address value effects x)
handleAllocator :: (forall x. Allocator address (Eff (Allocator address ': effects)) x -> Evaluator term address value effects x)
-> Allocator (Hole context address) (Eff (Allocator (Hole context address) ': effects)) a
-> Evaluator (Hole context address) value effects a
-> Evaluator term (Hole context address) value effects a
handleAllocator handler (Alloc name) = relocate (Total <$> handler (Alloc name))
runDeref :: PureEffects effects
=> (forall x. Deref value (Eff (Deref value ': effects)) x -> Evaluator address value effects x)
-> Evaluator (Hole context address) value (Deref value ': effects) a
-> Evaluator (Hole context address) value effects a
=> (forall x. Deref value (Eff (Deref value ': effects)) x -> Evaluator term address value effects x)
-> Evaluator term (Hole context address) value (Deref value ': effects) a
-> Evaluator term (Hole context address) value effects a
runDeref handler = interpret (handleDeref handler)
handleDeref :: (forall x. Deref value (Eff (Deref value ': effects)) x -> Evaluator address value effects x)
handleDeref :: (forall x. Deref value (Eff (Deref value ': effects)) x -> Evaluator term address value effects x)
-> Deref value (Eff (Deref value ': effects)) a
-> Evaluator (Hole context address) value effects a
-> Evaluator term (Hole context address) value effects a
handleDeref handler (DerefCell cell) = relocate (handler (DerefCell cell))
handleDeref handler (AssignCell value cell) = relocate (handler (AssignCell value cell))

22
src/Data/Abstract/Address/Located.hs
View File

@ -22,7 +22,7 @@ data Located address = Located
deriving (Eq, Ord, Show)
relocate :: Evaluator address1 value effects a -> Evaluator address2 value effects a
relocate :: Evaluator term address1 value effects a -> Evaluator term address2 value effects a
relocate = raiseEff . lowerEff
@ -31,28 +31,28 @@ runAllocator :: ( Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, PureEffects effects
)
=> (forall x. Allocator address (Eff (Allocator address ': effects)) x -> Evaluator address value effects x)
-> Evaluator (Located address) value (Allocator (Located address) ': effects) a
-> Evaluator (Located address) value effects a
=> (forall x. Allocator address (Eff (Allocator address ': effects)) x -> Evaluator term address value effects x)
-> Evaluator term (Located address) value (Allocator (Located address) ': effects) a
-> Evaluator term (Located address) value effects a
runAllocator handler = interpret (handleAllocator handler)
handleAllocator :: ( Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
)
=> (forall x. Allocator address (Eff (Allocator address ': effects)) x -> Evaluator address value effects x)
=> (forall x. Allocator address (Eff (Allocator address ': effects)) x -> Evaluator term address value effects x)
-> Allocator (Located address) (Eff (Allocator (Located address) ': effects)) a
-> Evaluator (Located address) value effects a
-> Evaluator term (Located address) value effects a
handleAllocator handler (Alloc name) = relocate (Located <$> handler (Alloc name) <*> currentPackage <*> currentModule <*> pure name <*> ask)
runDeref :: PureEffects effects
=> (forall x. Deref value (Eff (Deref value ': effects)) x -> Evaluator address value effects x)
-> Evaluator (Located address) value (Deref value ': effects) a
-> Evaluator (Located address) value effects a
=> (forall x. Deref value (Eff (Deref value ': effects)) x -> Evaluator term address value effects x)
-> Evaluator term (Located address) value (Deref value ': effects) a
-> Evaluator term (Located address) value effects a
runDeref handler = interpret (handleDeref handler)
handleDeref :: (forall x. Deref value (Eff (Deref value ': effects)) x -> Evaluator address value effects x)
handleDeref :: (forall x. Deref value (Eff (Deref value ': effects)) x -> Evaluator term address value effects x)
-> Deref value (Eff (Deref value ': effects)) a
-> Evaluator (Located address) value effects a
-> Evaluator term (Located address) value effects a
handleDeref handler (DerefCell cell) = relocate (handler (DerefCell cell))
handleDeref handler (AssignCell value cell) = relocate (handler (AssignCell value cell))

12
src/Data/Abstract/Address/Monovariant.hs
View File

@ -21,25 +21,25 @@ instance Show Monovariant where
runAllocator :: PureEffects effects
=> Evaluator Monovariant value (Allocator Monovariant ': effects) a
-> Evaluator Monovariant value effects a
=> Evaluator term Monovariant value (Allocator Monovariant ': effects) a
-> Evaluator term Monovariant value effects a
runAllocator = interpret handleAllocator
handleAllocator :: Allocator Monovariant (Eff (Allocator Monovariant ': effects)) a -> Evaluator Monovariant value effects a
handleAllocator :: Allocator Monovariant (Eff (Allocator Monovariant ': effects)) a -> Evaluator term Monovariant value effects a
handleAllocator (Alloc name) = pure (Monovariant name)
runDeref :: ( Member NonDet effects
, Ord value
, PureEffects effects
)
=> Evaluator Monovariant value (Deref value ': effects) a
-> Evaluator Monovariant value effects a
=> Evaluator term Monovariant value (Deref value ': effects) a
-> Evaluator term Monovariant value effects a
runDeref = interpret handleDeref
handleDeref :: ( Member NonDet effects
, Ord value
)
=> Deref value (Eff (Deref value ': effects)) a
-> Evaluator Monovariant value effects a
-> Evaluator term Monovariant value effects a
handleDeref (DerefCell cell) = traverse (foldMapA pure) (nonEmpty (toList cell))
handleDeref (AssignCell value cell) = pure (Set.insert value cell)

12
src/Data/Abstract/Address/Precise.hs
View File

@ -22,18 +22,18 @@ instance Show Precise where
runAllocator :: ( Member Fresh effects
, PureEffects effects
)
=> Evaluator Precise value (Allocator Precise ': effects) a
-> Evaluator Precise value effects a
=> Evaluator term Precise value (Allocator Precise ': effects) a
-> Evaluator term Precise value effects a
runAllocator = interpret handleAllocator
handleAllocator :: Member Fresh effects => Allocator Precise (Eff (Allocator Precise ': effects)) a -> Evaluator Precise value effects a
handleAllocator :: Member Fresh effects => Allocator Precise (Eff (Allocator Precise ': effects)) a -> Evaluator term Precise value effects a
handleAllocator (Alloc _) = Precise <$> fresh
runDeref :: PureEffects effects
=> Evaluator Precise value (Deref value ': effects) a
-> Evaluator Precise value effects a
=> Evaluator term Precise value (Deref value ': effects) a
-> Evaluator term Precise value effects a
runDeref = interpret handleDeref
handleDeref :: Deref value (Eff (Deref value ': effects)) a -> Evaluator Precise value effects a
handleDeref :: Deref value (Eff (Deref value ': effects)) a -> Evaluator term Precise value effects a
handleDeref (DerefCell cell) = pure (fst <$> Set.minView cell)
handleDeref (AssignCell value _) = pure (Set.singleton value)

2
src/Data/Abstract/BaseError.hs
View File

@ -34,7 +34,7 @@ throwBaseError :: ( Member (Resumable (BaseError exc)) effects
, Member (Reader S.Span) effects
)
=> exc resume
-> Evaluator address value effects resume
-> Evaluator term address value effects resume
throwBaseError err = do
moduleInfo <- currentModule
span <- currentSpan

46
src/Data/Abstract/Evaluatable.hs
View File

@ -74,7 +74,7 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where
, Member Trace effects
, Ord address
)
=> SubtermAlgebra constr term (Evaluator address value effects (ValueRef address))
=> SubtermAlgebra constr term (Evaluator term address value effects (ValueRef address))
eval expr = do
traverse_ subtermValue expr
v <- throwUnspecializedError $ UnspecializedError ("Eval unspecialized for " <> liftShowsPrec (const (const id)) (const id) 0 expr "")
@ -122,14 +122,14 @@ evaluate :: ( AbstractValue address value valueEffects
, valueEffects ~ ValueEffects address value moduleEffects
)
=> proxy lang
-> (SubtermAlgebra Module term (TermEvaluator term address value moduleEffects address) -> SubtermAlgebra Module term (TermEvaluator term address value moduleEffects address))
-> (SubtermAlgebra (Base term) term (TermEvaluator term address value valueEffects (ValueRef address)) -> SubtermAlgebra (Base term) term (TermEvaluator term address value valueEffects (ValueRef address)))
-> (forall x . Evaluator address value (Deref value ': Allocator address ': Reader ModuleInfo ': effects) x -> Evaluator address value (Reader ModuleInfo ': effects) x)
-> (forall x . Evaluator address value valueEffects x -> Evaluator address value moduleEffects x)
-> (SubtermAlgebra Module term (Evaluator term address value moduleEffects address) -> SubtermAlgebra Module term (Evaluator term address value moduleEffects address))
-> (SubtermAlgebra (Base term) term (Evaluator term address value valueEffects (ValueRef address)) -> SubtermAlgebra (Base term) term (Evaluator term address value valueEffects (ValueRef address)))
-> (forall x . Evaluator term address value (Deref value ': Allocator address ': Reader ModuleInfo ': effects) x -> Evaluator term address value (Reader ModuleInfo ': effects) x)
-> (forall x . Evaluator term address value valueEffects x -> Evaluator term address value moduleEffects x)
-> [Module term]
-> TermEvaluator term address value effects (ModuleTable (NonEmpty (Module (ModuleResult address))))
-> Evaluator term address value effects (ModuleTable (NonEmpty (Module (ModuleResult address))))
evaluate lang analyzeModule analyzeTerm runAllocDeref runValue modules = do
(_, (preludeBinds, _)) <- TermEvaluator . runInModule lowerBound moduleInfoFromCallStack . runValue $ do
(_, (preludeBinds, _)) <- runInModule lowerBound moduleInfoFromCallStack . runValue $ do
definePrelude lang
box unit
foldr (run preludeBinds) ask modules
@ -142,8 +142,8 @@ evaluate lang analyzeModule analyzeTerm runAllocDeref runValue modules = do
local (ModuleTable.insert (modulePath (moduleInfo m)) ((evaluated <$ m) :| [])) rest
evalModuleBody term = Subterm term (coerce runValue (do
result <- foldSubterms (analyzeTerm (TermEvaluator . eval . fmap (second runTermEvaluator))) term >>= TermEvaluator . address
result <$ TermEvaluator (postlude lang)))
result <- foldSubterms (analyzeTerm eval) term >>= address
result <$ postlude lang))
runInModule preludeBinds info
= runReader info
@ -154,7 +154,7 @@ evaluate lang analyzeModule analyzeTerm runAllocDeref runValue modules = do
. runLoopControl
traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator address value effects ()
traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator term address value effects ()
traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path)
@ -177,7 +177,7 @@ class HasPrelude (language :: Language) where
, Ord address
)
=> proxy language
-> Evaluator address value effects ()
-> Evaluator term address value effects ()
definePrelude _ = pure ()
instance HasPrelude 'Go
@ -221,7 +221,7 @@ class HasPostlude (language :: Language) where
, Member Trace effects
)
=> proxy language
-> Evaluator address value effects ()
-> Evaluator term address value effects ()
postlude _ = pure ()
instance HasPostlude 'Go
@ -263,10 +263,10 @@ instance Eq1 EvalError where
instance Show1 EvalError where
liftShowsPrec _ _ = showsPrec
runEvalError :: (Effectful m, Effects effects) => m (Resumable (BaseError EvalError) ': effects) a -> m effects (Either (SomeExc (BaseError EvalError)) a)
runEvalError :: Effects effects => Evaluator term address value (Resumable (BaseError EvalError) ': effects) a -> Evaluator term address value effects (Either (SomeExc (BaseError EvalError)) a)
runEvalError = runResumable
runEvalErrorWith :: (Effectful m, Effects effects) => (forall resume . (BaseError EvalError) resume -> m effects resume) -> m (Resumable (BaseError EvalError) ': effects) a -> m effects a
runEvalErrorWith :: Effects effects => (forall resume . (BaseError EvalError) resume -> Evaluator term address value effects resume) -> Evaluator term address value (Resumable (BaseError EvalError) ': effects) a -> Evaluator term address value effects a
runEvalErrorWith = runResumableWith
throwEvalError :: ( Member (Reader ModuleInfo) effects
@ -274,7 +274,7 @@ throwEvalError :: ( Member (Reader ModuleInfo) effects
, Member (Resumable (BaseError EvalError)) effects
)
=> EvalError resume
-> Evaluator address value effects resume
-> Evaluator term address value effects resume
throwEvalError = throwBaseError
@ -290,15 +290,15 @@ instance Eq1 (UnspecializedError a) where
instance Show1 (UnspecializedError a) where
liftShowsPrec _ _ = showsPrec
runUnspecialized :: (Effectful (m value), Effects effects)
=> m value (Resumable (BaseError (UnspecializedError value)) ': effects) a
-> m value effects (Either (SomeExc (BaseError (UnspecializedError value))) a)
runUnspecialized :: Effects effects
=> Evaluator term address value (Resumable (BaseError (UnspecializedError value)) ': effects) a
-> Evaluator term address value effects (Either (SomeExc (BaseError (UnspecializedError value))) a)
runUnspecialized = runResumable
runUnspecializedWith :: (Effectful (m value), Effects effects)
=> (forall resume . BaseError (UnspecializedError value) resume -> m value effects resume)
-> m value (Resumable (BaseError (UnspecializedError value)) ': effects) a
-> m value effects a
runUnspecializedWith :: Effects effects
=> (forall resume . BaseError (UnspecializedError value) resume -> Evaluator term address value effects resume)
-> Evaluator term address value (Resumable (BaseError (UnspecializedError value)) ': effects) a
-> Evaluator term address value effects a
runUnspecializedWith = runResumableWith
throwUnspecializedError :: ( Member (Resumable (BaseError (UnspecializedError value))) effects
@ -306,7 +306,7 @@ throwUnspecializedError :: ( Member (Resumable (BaseError (UnspecializedError va
, Member (Reader Span) effects
)
=> UnspecializedError value resume
-> Evaluator address value effects resume
-> Evaluator term address value effects resume
throwUnspecializedError = throwBaseError

8
src/Data/Abstract/Value/Abstract.hs
View File

@ -26,8 +26,8 @@ runFunction :: ( Member (Allocator address) effects
, Ord address
, PureEffects effects
)
=> Evaluator address Abstract (Function address Abstract ': effects) a
-> Evaluator address Abstract effects a
=> Evaluator term address Abstract (Function address Abstract ': effects) a
-> Evaluator term address Abstract effects a
runFunction = interpret $ \case
Function _ params _ body -> do
env <- foldr (\ name rest -> do
@ -43,8 +43,8 @@ runFunction = interpret $ \case
runBoolean :: ( Member NonDet effects
, PureEffects effects
)
=> Evaluator address Abstract (Boolean Abstract ': effects) a
-> Evaluator address Abstract effects a
=> Evaluator term address Abstract (Boolean Abstract ': effects) a
-> Evaluator term address Abstract effects a
runBoolean = interpret $ \case
Boolean _ -> pure Abstract
AsBool _ -> pure True <|> pure False

34
src/Data/Abstract/Value/Concrete.hs
View File

@ -78,10 +78,10 @@ runFunction :: ( Member (Allocator address) effects
, Ord address
, PureEffects effects
)
=> (body address -> Evaluator address (Value address body) (Abstract.Function address (Value address body) ': effects) address)
-> (Evaluator address value (Abstract.Function address (Value address body) ': effects) address -> body address)
-> Evaluator address (Value address body) (Abstract.Function address (Value address body) ': effects) a
-> Evaluator address (Value address body) effects a
=> (body address -> Evaluator term address (Value address body) (Abstract.Function address (Value address body) ': effects) address)
-> (Evaluator term address value (Abstract.Function address (Value address body) ': effects) address -> body address)
-> Evaluator term address (Value address body) (Abstract.Function address (Value address body) ': effects) a
-> Evaluator term address (Value address body) effects a
runFunction toEvaluator fromEvaluator = interpret $ \case
Abstract.Function name params fvs body -> do
packageInfo <- currentPackage
@ -104,8 +104,8 @@ runBoolean :: ( Member (Reader ModuleInfo) effects
, Member (Resumable (BaseError (ValueError address body))) effects
, PureEffects effects
)
=> Evaluator address (Value address body) (Abstract.Boolean (Value address body) ': effects) a
-> Evaluator address (Value address body) effects a
=> Evaluator term address (Value address body) (Abstract.Boolean (Value address body) ': effects) a
-> Evaluator term address (Value address body) effects a
runBoolean = interpret $ \case
Abstract.Boolean b -> pure $! Boolean b
Abstract.AsBool (Boolean b) -> pure b
@ -141,7 +141,7 @@ materializeEnvironment :: ( Member (Deref (Value address body)) effects
, Ord address
)
=> Value address body
-> Evaluator address (Value address body) effects (Maybe (Environment address))
-> Evaluator term address (Value address body) effects (Maybe (Environment address))
materializeEnvironment val = do
ancestors <- rec val
pure (Env.Environment <$> nonEmpty ancestors)
@ -250,7 +250,7 @@ instance ( Coercible body (Eff effects)
, Member (Resumable (BaseError (ValueError address body))) effects
)
=> Either ArithException Number.SomeNumber
-> Evaluator address (Value address body) effects (Value address body)
-> Evaluator term address (Value address body) effects (Value address body)
specialize (Left exc) = throwValueError (ArithmeticError exc)
specialize (Right (Number.SomeNumber (Number.Integer i))) = pure $ integer i
specialize (Right (Number.SomeNumber (Number.Ratio r))) = pure $ rational r
@ -269,7 +269,7 @@ instance ( Coercible body (Eff effects)
where
-- Explicit type signature is necessary here because we're passing all sorts of things
-- to these comparison functions.
go :: (AbstractValue address (Value address body) effects, Member (Abstract.Boolean (Value address body)) effects, Ord a) => a -> a -> Evaluator address (Value address body) effects (Value address body)
go :: (AbstractValue address (Value address body) effects, Member (Abstract.Boolean (Value address body)) effects, Ord a) => a -> a -> Evaluator term address (Value address body) effects (Value address body)
go l r = case comparator of
Concrete f -> boolean (f l r)
Generalized -> pure $ integer (orderingToInt (compare l r))
@ -346,15 +346,15 @@ deriving instance Show address => Show (ValueError address body resume)
instance Show address => Show1 (ValueError address body) where
liftShowsPrec _ _ = showsPrec
runValueError :: (Effectful (m address (Value address body)), Effects effects)
=> m address (Value address body) (Resumable (BaseError (ValueError address body)) ': effects) a
-> m address (Value address body) effects (Either (SomeExc (BaseError (ValueError address body))) a)
runValueError :: Effects effects
=> Evaluator term address (Value address body) (Resumable (BaseError (ValueError address body)) ': effects) a
-> Evaluator term address (Value address body) effects (Either (SomeExc (BaseError (ValueError address body))) a)
runValueError = runResumable
runValueErrorWith :: (Effectful (m address (Value address body)), Effects effects)
=> (forall resume . BaseError (ValueError address body) resume -> m address (Value address body) effects resume)
-> m address (Value address body) (Resumable (BaseError (ValueError address body)) ': effects) a
-> m address (Value address body) effects a
runValueErrorWith :: Effects effects
=> (forall resume . BaseError (ValueError address body) resume -> Evaluator term address (Value address body) effects resume)
-> Evaluator term address (Value address body) (Resumable (BaseError (ValueError address body)) ': effects) a
-> Evaluator term address (Value address body) effects a
runValueErrorWith = runResumableWith
throwValueError :: ( Member (Resumable (BaseError (ValueError address body))) effects
@ -362,5 +362,5 @@ throwValueError :: ( Member (Resumable (BaseError (ValueError address body))) ef
, Member (Reader Span) effects
)
=> ValueError address body resume
-> Evaluator address (Value address body) effects resume
-> Evaluator term address (Value address body) effects resume
throwValueError = throwBaseError

16
src/Data/Abstract/Value/Type.hs
View File

@ -11,7 +11,7 @@ module Data.Abstract.Value.Type
) where
import qualified Control.Abstract as Abstract
import Control.Abstract hiding (Boolean(..), Function(..), raiseHandler)
import Control.Abstract hiding (Boolean(..), Function(..))
import Control.Monad.Effect.Internal (raiseHandler)
import Data.Abstract.Environment as Env
import Data.Abstract.BaseError
@ -97,7 +97,7 @@ throwTypeError :: ( Member (Resumable (BaseError TypeError)) effects
, Member (Reader Span) effects
)
=> TypeError resume
-> Evaluator address value effects resume
-> Evaluator term address value effects resume
throwTypeError = throwBaseError
runTypeMap :: ( Effectful m
@ -190,7 +190,7 @@ substitute :: ( Member (Reader ModuleInfo) effects
)
=> TName
-> Type
-> Evaluator address value effects Type
-> Evaluator term address value effects Type
substitute id ty = do
infiniteType <- occur id ty
ty <- if infiniteType
@ -207,7 +207,7 @@ unify :: ( Member (Reader ModuleInfo) effects
)
=> Type
-> Type
-> Evaluator address value effects Type
-> Evaluator term address value effects Type
unify a b = do
a' <- prune a
b' <- prune b
@ -243,8 +243,8 @@ runFunction :: ( Member (Allocator address) effects
, Ord address
, PureEffects effects
)
=> Evaluator address Type (Abstract.Function address Type ': effects) a
-> Evaluator address Type effects a
=> Evaluator term address Type (Abstract.Function address Type ': effects) a
-> Evaluator term address Type effects a
runFunction = interpret $ \case
Abstract.Function _ params _ body -> do
(env, tvars) <- foldr (\ name rest -> do
@ -269,8 +269,8 @@ runBoolean :: ( Member NonDet effects
, Member (State TypeMap) effects
, PureEffects effects
)
=> Evaluator address Type (Abstract.Boolean Type ': effects) a
-> Evaluator address Type effects a
=> Evaluator term address Type (Abstract.Boolean Type ': effects) a
-> Evaluator term address Type effects a
runBoolean = interpret $ \case
Abstract.Boolean _ -> pure Bool
Abstract.AsBool t -> unify t Bool *> (pure True <|> pure False)

2
src/Language/Go/Syntax.hs
View File

@ -60,7 +60,7 @@ resolveGoImport :: ( Member (Modules address) effects
, Member Trace effects
)
=> ImportPath
-> Evaluator address value effects [ModulePath]
-> Evaluator term address value effects [ModulePath]
resolveGoImport (ImportPath path Unknown) = throwResolutionError $ GoImportError path
resolveGoImport (ImportPath path Relative) = do
ModuleInfo{..} <- currentModule

8
src/Language/PHP/Syntax.hs
View File

@ -44,7 +44,7 @@ resolvePHPName :: ( Member (Modules address) effects
, Member (Resumable (BaseError ResolutionError)) effects
)
=> T.Text
-> Evaluator address value effects ModulePath
-> Evaluator term address value effects ModulePath
resolvePHPName n = do
modulePath <- resolve [name]
maybeM (throwResolutionError $ NotFoundError name [name] Language.PHP) modulePath
@ -64,9 +64,9 @@ include :: ( AbstractValue address value effects
, Member Trace effects
, Ord address
)
=> Subterm term (Evaluator address value effects (ValueRef address))
-> (ModulePath -> Evaluator address value effects (ModuleResult address))
-> Evaluator address value effects (ValueRef address)
=> Subterm term (Evaluator term address value effects (ValueRef address))
-> (ModulePath -> Evaluator term address value effects (ModuleResult address))
-> Evaluator term address value effects (ValueRef address)
include pathTerm f = do
name <- subtermValue pathTerm >>= asString
path <- resolvePHPName name

4
src/Language/Python/Syntax.hs
View File

@ -72,7 +72,7 @@ resolvePythonModules :: ( Member (Modules address) effects
, Member Trace effects
)
=> QualifiedName
-> Evaluator address value effects (NonEmpty ModulePath)
-> Evaluator term address value effects (NonEmpty ModulePath)
resolvePythonModules q = do
relRootDir <- rootDir q <$> currentModule
for (moduleNames q) $ \name -> do
@ -163,7 +163,7 @@ evalQualifiedImport :: ( AbstractValue address value effects
, Member (State (Heap address value)) effects
, Ord address
)
=> Name -> ModulePath -> Evaluator address value effects value
=> Name -> ModulePath -> Evaluator term address value effects value
evalQualifiedImport name path = letrec' name $ \addr -> do
unit <$ makeNamespace name addr Nothing (bindAll . fst . snd =<< require path)

8
src/Language/Ruby/Syntax.hs
View File

@ -28,7 +28,7 @@ resolveRubyName :: ( Member (Modules address) effects
, Member (Resumable (BaseError ResolutionError)) effects
)
=> Text
-> Evaluator address value effects M.ModulePath
-> Evaluator term address value effects M.ModulePath
resolveRubyName name = do
let name' = cleanNameOrPath name
let paths = [name' <.> "rb"]
@ -42,7 +42,7 @@ resolveRubyPath :: ( Member (Modules address) effects
, Member (Resumable (BaseError ResolutionError)) effects
)
=> Text
-> Evaluator address value effects M.ModulePath
-> Evaluator term address value effects M.ModulePath
resolveRubyPath path = do
let name' = cleanNameOrPath path
modulePath <- resolve [name']
@ -95,7 +95,7 @@ doRequire :: ( Member (Boolean value) effects
, Member (Modules address) effects
)
=> M.ModulePath
-> Evaluator address value effects (Bindings address, value)
-> Evaluator term address value effects (Bindings address, value)
doRequire path = do
result <- lookupModule path
case result of
@ -129,7 +129,7 @@ doLoad :: ( Member (Boolean value) effects
)
=> Text
-> Bool
-> Evaluator address value effects value
-> Evaluator term address value effects value
doLoad path shouldWrap = do
path' <- resolveRubyPath path
traceResolve path path'

10
src/Language/TypeScript/Resolution.hs
View File

@ -74,7 +74,7 @@ resolveWithNodejsStrategy :: ( Member (Modules address) effects
)
=> ImportPath
-> [String]
-> Evaluator address value effects M.ModulePath
-> Evaluator term address value effects M.ModulePath
resolveWithNodejsStrategy (ImportPath path NonRelative) exts = resolveNonRelativePath path exts
resolveWithNodejsStrategy (ImportPath path _) exts = resolveRelativePath path exts
@ -94,7 +94,7 @@ resolveRelativePath :: ( Member (Modules address) effects
)
=> FilePath
-> [String]
-> Evaluator address value effects M.ModulePath
-> Evaluator term address value effects M.ModulePath
resolveRelativePath relImportPath exts = do
M.ModuleInfo{..} <- currentModule
let relRootDir = takeDirectory modulePath
@ -123,7 +123,7 @@ resolveNonRelativePath :: ( Member (Modules address) effects
)
=> FilePath
-> [String]
-> Evaluator address value effects M.ModulePath
-> Evaluator term address value effects M.ModulePath
resolveNonRelativePath name exts = do
M.ModuleInfo{..} <- currentModule
go "." modulePath mempty
@ -146,7 +146,7 @@ resolveModule :: ( Member (Modules address) effects
)
=> FilePath -- ^ Module path used as directory to search in
-> [String] -- ^ File extensions to look for
-> Evaluator address value effects (Either [FilePath] M.ModulePath)
-> Evaluator term address value effects (Either [FilePath] M.ModulePath)
resolveModule path' exts = do
let path = makeRelative "." path'
PackageInfo{..} <- currentPackage
@ -173,6 +173,6 @@ evalRequire :: ( AbstractValue address value effects
)
=> M.ModulePath
-> Name
-> Evaluator address value effects value
-> Evaluator term address value effects value
evalRequire modulePath alias = letrec' alias $ \addr ->
unit <$ makeNamespace alias addr Nothing (bindAll . fst . snd =<< require modulePath)

83
src/Semantic/Graph.hs
View File

@ -109,8 +109,7 @@ runCallGraph lang includePackages modules package = do
analyzeModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules
extractGraph (graph, _) = simplify graph
runGraphAnalysis
= runTermEvaluator @_ @(Hole (Maybe Name) (Located Monovariant)) @Abstract
. graphing @_ @_ @(Maybe Name) @Monovariant
= graphing @_ @_ @(Maybe Name) @Monovariant
. runState (lowerBound @(Heap (Hole (Maybe Name) (Located Monovariant)) Abstract))
. caching
. runFresh 0
@ -126,7 +125,7 @@ runCallGraph lang includePackages modules package = do
. runReader (lowerBound @ControlFlowVertex)
. providingLiveSet
. runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult (Hole (Maybe Name) (Located Monovariant)))))))
. raiseHandler (runModules (ModuleTable.modulePaths (packageModules package)))
. runModules (ModuleTable.modulePaths (packageModules package))
runAddressEffects
= Hole.runAllocator (Located.handleAllocator Monovariant.handleAllocator)
. Hole.runDeref (Located.handleDeref Monovariant.handleDeref)
@ -191,14 +190,13 @@ runImportGraph lang (package :: Package term) f =
. resumingValueError
. runReader lowerBound
. runModules (ModuleTable.modulePaths (packageModules package))
. runTermEvaluator @_ @_ @(Value (Hole (Maybe Name) Precise) (ConcreteEff (Hole (Maybe Name) Precise) _))
. runReader (packageInfo package)
. runState lowerBound
. runReader lowerBound
runAddressEffects
= Hole.runAllocator Precise.handleAllocator
. Hole.runDeref Precise.handleDeref
in extractGraph <$> runEvaluator (runImportGraphAnalysis (evaluate lang analyzeModule id runAddressEffects (Concrete.runBoolean . Concrete.runFunction coerce coerce) (ModuleTable.toPairs (packageModules package) >>= toList . snd)))
in extractGraph <$> runEvaluator @_ @_ @(Value (Hole (Maybe Name) Precise) (ConcreteEff (Hole (Maybe Name) Precise) _)) (runImportGraphAnalysis (evaluate lang analyzeModule id runAddressEffects (Concrete.runBoolean . Concrete.runFunction coerce coerce) (ModuleTable.toPairs (packageModules package) >>= toList . snd)))
type ConcreteEffects address rest
= Reader Span
@ -261,7 +259,7 @@ parsePythonPackage :: forall syntax fields effs term.
-> Project -- ^ Project to parse into a package.
-> Eff effs (Package term)
parsePythonPackage parser project = do
let runAnalysis = runEvaluator
let runAnalysis = runEvaluator @_ @_ @(Value (Hole (Maybe Name) Precise) (ConcreteEff (Hole (Maybe Name) Precise) _))
. runState PythonPackage.Unknown
. runState lowerBound
. runFresh 0
@ -274,7 +272,6 @@ parsePythonPackage parser project = do
. resumingValueError
. runReader lowerBound
. runModules lowerBound
. runTermEvaluator @_ @_ @(Value (Hole (Maybe Name) Precise) (ConcreteEff (Hole (Maybe Name) Precise) _))
. runReader (PackageInfo (name "setup") lowerBound)
. runState lowerBound
. runReader lowerBound
@ -328,43 +325,37 @@ withTermSpans :: ( HasField fields Span
, Member (Reader Span) effects
, Member (State Span) effects -- last evaluated child's span
)
=> SubtermAlgebra (TermF syntax (Record fields)) term (TermEvaluator term address value effects a)
-> SubtermAlgebra (TermF syntax (Record fields)) term (TermEvaluator term address value effects a)
=> SubtermAlgebra (TermF syntax (Record fields)) term (Evaluator term address value effects a)
-> SubtermAlgebra (TermF syntax (Record fields)) term (Evaluator term address value effects a)
withTermSpans recur term = let
updatedSpanAlg = withCurrentSpan (getField (termFAnnotation term)) (recur term)
in modifyChildSpan (getField (termFAnnotation term)) updatedSpanAlg
resumingResolutionError :: ( Applicative (m effects)
, Effectful m
, Member Trace effects
resumingResolutionError :: ( Member Trace effects
, Effects effects
)
=> m (Resumable (BaseError ResolutionError) ': effects) a
-> m effects a
=> Evaluator term address value (Resumable (BaseError ResolutionError) ': effects) a
-> Evaluator term address value effects a
resumingResolutionError = runResolutionErrorWith (\ baseError -> traceError "ResolutionError" baseError *> case baseErrorException baseError of
NotFoundError nameToResolve _ _ -> pure nameToResolve
GoImportError pathToResolve -> pure [pathToResolve])
resumingLoadError :: ( Applicative (m address value effects)
, AbstractHole address
, Effectful (m address value)
resumingLoadError :: ( AbstractHole address
, Effects effects
, Member Trace effects
, Ord address
)
=> m address value (Resumable (BaseError (LoadError address)) ': effects) a
-> m address value effects a
=> Evaluator term address value (Resumable (BaseError (LoadError address)) ': effects) a
-> Evaluator term address value effects a
resumingLoadError = runLoadErrorWith (\ baseError -> traceError "LoadError" baseError *> case baseErrorException baseError of
ModuleNotFoundError _ -> pure (lowerBound, (lowerBound, hole)))
resumingEvalError :: ( Applicative (m effects)
, Effectful m
, Effects effects
resumingEvalError :: ( Effects effects
, Member Fresh effects
, Member Trace effects
)
=> m (Resumable (BaseError EvalError) ': effects) a
-> m effects a
=> Evaluator term address value (Resumable (BaseError EvalError) ': effects) a
-> Evaluator term address value effects a
resumingEvalError = runEvalErrorWith (\ baseError -> traceError "EvalError" baseError *> case baseErrorException baseError of
DefaultExportError{} -> pure ()
ExportError{} -> pure ()
@ -373,37 +364,32 @@ resumingEvalError = runEvalErrorWith (\ baseError -> traceError "EvalError" base
RationalFormatError{} -> pure 0
NoNameError -> gensym)
resumingUnspecialized :: ( Applicative (m value effects)
, AbstractHole value
, Effectful (m value)
resumingUnspecialized :: ( AbstractHole value
, Effects effects
, Member Trace effects)
=> m value (Resumable (BaseError (UnspecializedError value)) ': effects) a
-> m value effects a
, Member Trace effects
)
=> Evaluator term address value (Resumable (BaseError (UnspecializedError value)) ': effects) a
-> Evaluator term address value effects a
resumingUnspecialized = runUnspecializedWith (\ baseError -> traceError "UnspecializedError" baseError *> case baseErrorException baseError of
UnspecializedError _ -> pure hole)
resumingAddressError :: ( AbstractHole value
, Applicative (m address value effects)
, Effectful (m address value)
, Effects effects
, Member Trace effects
, Show address
)
=> m address value (Resumable (BaseError (AddressError address value)) ': effects) a
-> m address value effects a
=> Evaluator term address value (Resumable (BaseError (AddressError address value)) ': effects) a
-> Evaluator term address value effects a
resumingAddressError = runAddressErrorWith $ \ baseError -> traceError "AddressError" baseError *> case baseErrorException baseError of
UnallocatedAddress _ -> pure lowerBound
UninitializedAddress _ -> pure hole
resumingValueError :: ( Applicative (m address (Value address body) effects)
, Effectful (m address (Value address body))
, Effects effects
resumingValueError :: ( Effects effects
, Member Trace effects
, Show address
)
=> m address (Value address body) (Resumable (BaseError (ValueError address body)) ': effects) a
-> m address (Value address body) effects a
=> Evaluator term address (Value address body) (Resumable (BaseError (ValueError address body)) ': effects) a
-> Evaluator term address (Value address body) effects a
resumingValueError = runValueErrorWith (\ baseError -> traceError "ValueError" baseError *> case baseErrorException baseError of
CallError val -> pure val
StringError val -> pure (pack (prettyShow val))
@ -420,22 +406,19 @@ resumingValueError = runValueErrorWith (\ baseError -> traceError "ValueError" b
ArrayError{} -> pure lowerBound
ArithmeticError{} -> pure hole)
resumingEnvironmentError :: ( Monad (m (Hole (Maybe Name) address) value effects)
, Effectful (m (Hole (Maybe Name) address) value)
, Effects effects
resumingEnvironmentError :: ( Effects effects
, Member Trace effects
)
=> m (Hole (Maybe Name) address) value (Resumable (BaseError (EnvironmentError (Hole (Maybe Name) address))) ': effects) a
-> m (Hole (Maybe Name) address) value effects a
=> Evaluator term (Hole (Maybe Name) address) value (Resumable (BaseError (EnvironmentError (Hole (Maybe Name) address))) ': effects) a
-> Evaluator term (Hole (Maybe Name) address) value effects a
resumingEnvironmentError = runResumableWith (\ baseError -> traceError "EnvironmentError" baseError >> (\ (FreeVariable name) -> pure (Partial (Just name))) (baseErrorException baseError))
resumingTypeError :: ( Alternative (m address Type (State TypeMap ': effects))
, Effects effects
, Effectful (m address Type)
resumingTypeError :: ( Effects effects
, Member NonDet effects
, Member Trace effects
)
=> m address Type (Resumable (BaseError TypeError) ': State TypeMap ': effects) a
-> m address Type effects a
=> Evaluator term address Type (Resumable (BaseError TypeError) ': State TypeMap ': effects) a
-> Evaluator term address Type effects a
resumingTypeError = runTypesWith (\ baseError -> traceError "TypeError" baseError *> case baseErrorException baseError of
UnificationError l r -> pure l <|> pure r
InfiniteType _ r -> pure r)
@ -443,5 +426,5 @@ resumingTypeError = runTypesWith (\ baseError -> traceError "TypeError" baseErro
prettyShow :: Show a => a -> String
prettyShow = hscolour TTY defaultColourPrefs False False "" False . ppShow
traceError :: (Member Trace effects, Effectful m, Show (exc resume)) => String -> BaseError exc resume -> m effects ()
traceError :: (Member Trace effects, Show (exc resume)) => String -> BaseError exc resume -> Evaluator term address value effects ()
traceError prefix baseError = trace $ prefix <> ": " <> prettyShow baseError

12
src/Semantic/REPL.hs
View File

@ -89,7 +89,7 @@ repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runD
. fmap snd
. runState ([] @Breakpoint)
. runReader Step
. runTermEvaluator @_ @_ @(Value Precise (ConcreteEff Precise _))
. id @(Evaluator _ Precise (Value Precise (ConcreteEff Precise _)) _ _)
. runPrintingTrace
. runState lowerBound
. runFresh 0
@ -102,7 +102,7 @@ repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runD
. runAddressError
. runValueError
. runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Precise)))))
. raiseHandler (runModules (ModuleTable.modulePaths (packageModules (snd <$> package))))
. runModules (ModuleTable.modulePaths (packageModules (snd <$> package)))
. runReader (packageInfo package)
. runState (lowerBound @Span)
. runReader (lowerBound @Span)
@ -129,8 +129,8 @@ step :: ( Member (Env address) effects
, Show address
)
=> [(ModulePath, Blob)]
-> SubtermAlgebra (Base term) term (TermEvaluator term address value effects a)
-> SubtermAlgebra (Base term) term (TermEvaluator term address value effects a)
-> SubtermAlgebra (Base term) term (Evaluator term address value effects a)
-> SubtermAlgebra (Base term) term (Evaluator term address value effects a)
step blobs recur term = do
break <- shouldBreak
if break then do
@ -152,7 +152,7 @@ step blobs recur term = do
output " :show bindings show the current bindings"
output " :quit, :q, :abandon abandon the current evaluation and exit the repl"
showBindings = do
bindings <- Env.head <$> TermEvaluator getEnv
bindings <- Env.head <$> getEnv
output $ unlines (uncurry showBinding <$> Env.pairs bindings)
showBinding name addr = show name <> " = " <> show addr
runCommand run [":step"] = local (const Step) run
@ -190,7 +190,7 @@ data Step
-- TODO: StepLocal/StepModule
shouldBreak :: (Member (State [Breakpoint]) effects, Member (Reader Span) effects, Member (Reader Step) effects) => TermEvaluator term address value effects Bool
shouldBreak :: (Member (State [Breakpoint]) effects, Member (Reader Span) effects, Member (Reader Step) effects) => Evaluator term address value effects Bool
shouldBreak = do
step <- ask
case step of

6
src/Semantic/Task.hs
View File

@ -109,8 +109,8 @@ type Renderer i o = i -> o
parse :: Member Task effs => Parser term -> Blob -> Eff effs term
parse parser = send . Parse parser
-- | A task running some 'Analysis.TermEvaluator' to completion.
analyze :: Member Task effs => (Analysis.TermEvaluator term address value effects a -> result) -> Analysis.TermEvaluator term address value effects a -> Eff effs result
-- | A task running some 'Analysis.Evaluator' to completion.
analyze :: Member Task effs => (Analysis.Evaluator term address value effects a -> result) -> Analysis.Evaluator term address value effects a -> Eff effs result
analyze interpret analysis = send (Analyze interpret analysis)
-- | A task which decorates a 'Term' with values computed using the supplied 'RAlgebra' function.
@ -170,7 +170,7 @@ runTraceInTelemetry = interpret (\ (Trace str) -> writeLog Debug str [])
-- | An effect describing high-level tasks to be performed.
data Task (m :: * -> *) output where
Parse :: Parser term -> Blob -> Task m term
Analyze :: (Analysis.TermEvaluator term address value effects a -> result) -> Analysis.TermEvaluator term address value effects a -> Task m result
Analyze :: (Analysis.Evaluator term address value effects a -> result) -> Analysis.Evaluator term address value effects a -> Task m result
Decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> Task m (Term f (Record (field ': fields)))
Diff :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => These (Term syntax (Record fields1)) (Term syntax (Record fields2)) -> Task m (Diff syntax (Record fields1) (Record fields2))
Render :: Renderer input output -> input -> Task m output

17
src/Semantic/Util.hs
View File

@ -2,12 +2,12 @@
{-# OPTIONS_GHC -Wno-missing-signatures -Wno-missing-export-lists #-}
module Semantic.Util where
import Prelude hiding (id, (.), readFile)
import Prelude hiding (readFile)
import Analysis.Abstract.Caching.FlowSensitive
import Analysis.Abstract.Collecting
import Control.Abstract
import Control.Category
-- import Control.Category
import Control.Exception (displayException)
import Control.Monad.Effect.Trace (runPrintingTrace)
import Data.Abstract.Address.Monovariant as Monovariant
@ -58,7 +58,6 @@ checking
. runPrintingTrace
. runState (lowerBound @(Heap Monovariant Type))
. runFresh 0
. runTermEvaluator @_ @Monovariant @Type
. caching
. providingLiveSet
. fmap reassociate
@ -87,7 +86,7 @@ callGraphProject parser proxy opts paths = runTaskWithOptions opts $ do
x <- runCallGraph proxy False modules package
pure (x, (() <$) <$> modules)
evaluatePythonProject = evaluatePythonProjects (Proxy @'Language.Python) pythonParser Language.Python
evaluatePythonProject = justEvaluating <=< evaluatePythonProjects (Proxy @'Language.Python) pythonParser Language.Python
callGraphRubyProject = callGraphProject rubyParser (Proxy @'Language.Ruby) debugOptions
@ -102,9 +101,9 @@ evaluateProject' (TaskConfig config logger statter) proxy parser paths = either
package <- fmap (quieterm . snd) <$> parsePackage parser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs (Language.reflect proxy) [])
modules <- topologicalSort <$> runImportGraphToModules proxy package
trace $ "evaluating with load order: " <> show (map (modulePath . moduleInfo) modules)
pure (runTermEvaluator @_ @_ @(Value Precise (ConcreteEff Precise _))
pure (id @(Evaluator _ Precise (Value Precise (ConcreteEff Precise _)) _ _)
(runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Precise)))))
(raiseHandler (runModules (ModuleTable.modulePaths (packageModules package)))
(runModules (ModuleTable.modulePaths (packageModules package))
(runReader (packageInfo package)
(runState (lowerBound @Span)
(runReader (lowerBound @Span)
@ -115,9 +114,9 @@ evaluatePythonProjects proxy parser lang path = runTaskWithOptions debugOptions
package <- fmap quieterm <$> parsePythonPackage parser project
modules <- topologicalSort <$> runImportGraphToModules proxy package
trace $ "evaluating with load order: " <> show (map (modulePath . moduleInfo) modules)
pure (runTermEvaluator @_ @_ @(Value Precise (ConcreteEff Precise '[Trace]))
pure (id @(Evaluator _ Precise (Value Precise (ConcreteEff Precise _)) _ _)
(runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Precise)))))
(raiseHandler (runModules (ModuleTable.modulePaths (packageModules package)))
(runModules (ModuleTable.modulePaths (packageModules package))
(runReader (packageInfo package)
(runState (lowerBound @Span)
(runReader (lowerBound @Span)
@ -132,7 +131,7 @@ evaluateProjectWithCaching proxy parser path = runTaskWithOptions debugOptions $
(runState (lowerBound @Span)
(runReader (lowerBound @Span)
(runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Monovariant)))))
(raiseHandler (runModules (ModuleTable.modulePaths (packageModules package)))
(runModules (ModuleTable.modulePaths (packageModules package))
(evaluate proxy id withTermSpans (Monovariant.runAllocator . Monovariant.runDeref) (Type.runBoolean . Type.runFunction) modules))))))

2
test/Control/Abstract/Evaluator/Spec.hs
View File

@ -43,7 +43,7 @@ evaluate
. runValueError
. runEnvironmentError
. runAddressError
. Precise.runDeref @_ @Val
. Precise.runDeref @_ @_ @Val
. Precise.runAllocator
. (>>= deref . snd)
. runEnv lowerBound

5
test/SpecHelpers.hs
View File

@ -10,7 +10,6 @@ module SpecHelpers
, deNamespace
, derefQName
, verbatim
, TermEvaluator(..)
, Verbatim(..)
, toList
, Config
@ -118,7 +117,7 @@ type TestEvaluatingErrors = '[ BaseError (ValueError Precise (ConcreteEff Precis
, BaseError (UnspecializedError Val)
, BaseError (LoadError Precise)
]
testEvaluating :: Evaluator Precise Val TestEvaluatingEffects (Span, a)
testEvaluating :: Evaluator term Precise Val TestEvaluatingEffects (Span, a)
-> IO
( [String]
, ( Heap Precise Val
@ -138,7 +137,7 @@ testEvaluating
. runEvalError
. runResolutionError
. runAddressError
. runValueError @_ @Precise @(ConcreteEff Precise _)
. runValueError @_ @_ @Precise @(ConcreteEff Precise _)
. fmap snd
type Val = Value Precise (ConcreteEff Precise '[Trace, Lift IO])