github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-20 05:11:44 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #2191 from github/first-order-closures

Browse Source 
First-order closures
This commit is contained in:
Rob Rix 2018-09-27 14:05:12 -05:00 committed by GitHub
commit 86c743a6c8
49 changed files with 840 additions and 963 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

51
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,19 +46,18 @@ 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)
-- | Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache.
cachingTerms :: ( Corecursive term
, Member (Env address) effects
cachingTerms :: ( Member (Env address) effects
, Member NonDet effects
, Member (Reader (Cache term address)) effects
, Member (Reader (Live address)) effects
@ -66,18 +65,17 @@ 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))
cachingTerms recur term = do
c <- getConfiguration (embedSubterm term)
=> Open (Open (term -> Evaluator term address value effects (ValueRef address)))
cachingTerms recur0 recur term = do
c <- getConfiguration term
cached <- lookupCache c
case cached of
Just values -> scatter values
Nothing -> do
values <- consultOracle c
cachingConfiguration c values (recur term)
cachingConfiguration c values (recur0 recur term)
convergingModules :: ( AbstractValue address value effects
convergingModules :: ( AbstractValue term address value effects
, Effects effects
, Eq value
, Member (Env address) effects
@ -93,14 +91,13 @@ 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)
=> Open (Module term -> Evaluator term address value effects address)
convergingModules recur m = do
c <- getConfiguration (subterm (moduleBody m))
heap <- TermEvaluator getHeap
c <- getConfiguration (moduleBody m)
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 +106,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 +124,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

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

@ -16,49 +16,48 @@ 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
-- | Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache.
cachingTerms :: ( Cacheable term address value
, Corecursive term
, Member NonDet effects
, Member (Reader (Cache term address value)) effects
, Member (Reader (Live address)) effects
@ -66,18 +65,17 @@ 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))
cachingTerms recur term = do
c <- getConfiguration (embedSubterm term)
=> Open (Open (term -> Evaluator term address value effects (ValueRef address)))
cachingTerms recur0 recur term = do
c <- getConfiguration term
cached <- lookupCache c
case cached of
Just pairs -> scatter pairs
Nothing -> do
pairs <- consultOracle c
cachingConfiguration c pairs (recur term)
cachingConfiguration c pairs (recur0 recur term)
convergingModules :: ( AbstractValue address value effects
convergingModules :: ( AbstractValue term address value effects
, Cacheable term address value
, Member Fresh effects
, Member NonDet effects
@ -91,14 +89,13 @@ 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)
=> Open (Module term -> Evaluator term address value effects address)
convergingModules recur m = do
c <- getConfiguration (subterm (moduleBody m))
c <- getConfiguration (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 +104,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 +122,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

19
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.
@ -31,22 +31,19 @@ subterms :: (Ord term, Recursive term, Foldable (Base term)) => term -> Dead ter
subterms term = term `cons` para (foldMap (uncurry cons)) term
revivingTerms :: ( Corecursive term
, Member (State (Dead term)) effects
revivingTerms :: ( 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)
revivingTerms recur term = revive (embedSubterm term) *> recur term
=> Open (Open (term -> Evaluator term address value effects a))
revivingTerms recur0 recur term = revive term *> recur0 recur term
killingModules :: ( Foldable (Base term)
, Member (State (Dead term)) effects
, Ord term
, Recursive term
)
=> SubtermAlgebra Module term (TermEvaluator term address value effects a)
-> SubtermAlgebra Module term (TermEvaluator term address value effects a)
killingModules recur m = killAll (subterms (subterm (moduleBody m))) *> recur m
=> Open (Module term -> Evaluator term address value effects a)
killingModules recur m = killAll (subterms (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

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

@ -33,7 +33,7 @@ import Data.Term
import Data.Location
import qualified Data.Map as Map
import qualified Data.Text.Encoding as T
import Prologue hiding (project)
import Prologue
style :: Style ControlFlowVertex Builder
style = (defaultStyle (T.encodeUtf8Builder . vertexIdentifier))
@ -68,40 +68,38 @@ graphingTerms :: ( Member (Reader ModuleInfo) effects
, Member (State (Graph ControlFlowVertex)) effects
, Member (State (Map (Hole context (Located address)) ControlFlowVertex)) effects
, Member (Resumable (BaseError (EnvironmentError (Hole context (Located address))))) effects
, AbstractValue (Hole context (Located address)) value effects
, AbstractValue term (Hole context (Located address)) value effects
, Member (Reader ControlFlowVertex) effects
, VertexDeclaration syntax
, Declarations1 syntax
, Ord address
, Ord context
, Foldable syntax
, Functor syntax
, term ~ Term syntax Location
)
=> 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))))
graphingTerms recur term@(In a syntax) = do
=> Open (Open (term -> Evaluator term (Hole context (Located address)) value effects (ValueRef (Hole context (Located address)))))
graphingTerms recur0 recur term@(Term (In a syntax)) = do
definedInModule <- currentModule
case toVertex a definedInModule (subterm <$> syntax) of
case toVertex a definedInModule syntax of
Just (v@Function{}, _) -> recurWithContext v
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)
maybe (pure ()) (appendGraph . connect (vertex v) . vertex) defined
_ -> pure ()
recur term
_ -> recur term
recur0 recur term
_ -> recur0 recur term
where
recurWithContext v = do
variableDefinition v
moduleInclusion v
local (const v) $ do
valRef <- recur term
addr <- TermEvaluator (Control.Abstract.address valRef)
valRef <- recur0 recur term
addr <- Control.Abstract.address valRef
modify' (Map.insert addr v)
pure valRef
@ -110,8 +108,7 @@ 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)
=> Open (Module term -> Evaluator term address value effects a)
graphingPackages recur m =
let v = moduleVertex (moduleInfo m) in packageInclusion v *> local (const v) (recur m)
@ -123,8 +120,7 @@ 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)
=> Open (Module term -> Evaluator term address value effects a)
graphingModules recur m = do
let v = moduleVertex (moduleInfo m)
appendGraph (vertex v)
@ -146,8 +142,7 @@ 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)
=> Open (Module term -> Evaluator term address value effects a)
graphingModuleInfo recur m = do
appendGraph (vertex (moduleInfo m))
eavesdrop @(Modules address) (\ eff -> case eff of
@ -157,25 +152,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)
@ -185,15 +176,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

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

@ -8,34 +8,31 @@ import Control.Abstract hiding (trace)
import Control.Monad.Effect.Writer
import Data.Abstract.Environment
import Data.Semigroup.Reducer as Reducer
import Prologue
-- | Trace analysis.
--
-- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis.
tracingTerms :: ( Corecursive term
, Member (Env address) effects
tracingTerms :: ( Member (Env address) effects
, Member (State (Heap address value)) effects
, Member (Writer (trace (Configuration term address value))) effects
, 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)
tracingTerms proxy recur term = getConfiguration (embedSubterm term) >>= trace . (`asTypeOf` proxy) . Reducer.unit >> recur term
-> Open (Open (term -> Evaluator term address value effects a))
tracingTerms proxy recur0 recur term = getConfiguration term >>= trace . (`asTypeOf` proxy) . Reducer.unit >> recur0 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

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

@ -1,6 +1,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeOperators, ScopedTypeVariables #-}
module Control.Abstract.Evaluator
( Evaluator(..)
, Open
-- * Effects
, Return(..)
, earlyReturn
@ -32,11 +33,16 @@ 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)
-- | An open-recursive function.
type Open a = a -> a
-- Effects
@ -46,13 +52,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)
@ -65,20 +71,20 @@ 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
throwAbort :: forall address effects value a . Member (Exc (LoopControl address)) effects
=> Evaluator address value effects a
throwAbort :: forall term address effects value a . Member (Exc (LoopControl address)) effects
=> Evaluator term address value effects a
throwAbort = throwError (Abort @address)
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

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

@ -1,24 +1,16 @@
{-# LANGUAGE FunctionalDependencies, UndecidableInstances #-}
module Control.Abstract.Primitive
( define
, defineClass
, defineNamespace
, builtInPrint
, builtInExport
, lambda
, Lambda(..)
) where
import Data.Abstract.Environment
import Control.Abstract.Context
import Control.Abstract.Environment
import Control.Abstract.Evaluator
import Control.Abstract.Heap
import Control.Abstract.Value
import qualified Data.Abstract.Environment as Env
import Data.Abstract.BaseError
import Data.Abstract.Name
import Data.Text (unpack)
import Prologue
define :: ( HasCallStack
@ -31,14 +23,14 @@ 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
bind name addr
defineClass :: ( AbstractValue address value effects
defineClass :: ( AbstractValue term address value effects
, HasCallStack
, Member (Allocator address) effects
, Member (Deref value) effects
@ -50,13 +42,13 @@ 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
defineNamespace :: ( AbstractValue address value effects
defineNamespace :: ( AbstractValue term address value effects
, HasCallStack
, Member (Allocator address) effects
, Member (Deref value) effects
@ -67,77 +59,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
-- | Construct a function from a Haskell function taking 'Name's as arguments.
--
-- 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
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
)
=> fn
-> Evaluator 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
lambda' :: [Name]
-> ty
-> Evaluator address value effects value
instance (Member Fresh effects, Lambda address value effects ret) => Lambda 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
lambda' vars = function Nothing vars lowerBound
{-# INLINE lambda' #-}
builtInPrint :: ( AbstractValue address value effects
, HasCallStack
, Member (Allocator address) effects
, Member (Deref value) effects
, Member (Env address) effects
, Member Fresh effects
, Member (Function address value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (State (Heap address value)) effects
, Member Trace effects
, Ord address
)
=> Evaluator address value effects value
builtInPrint = lambda (\ v -> variable v >>= deref >>= asString >>= trace . unpack >> box unit)
builtInExport :: ( AbstractValue address value effects
, HasCallStack
, Member (Allocator address) effects
, Member (Deref value) effects
, Member (Env address) effects
, Member Fresh effects
, Member (Function address value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (State (Heap address value)) effects
, Ord address
)
=> Evaluator address value effects value
builtInExport = lambda (\ v -> do
var <- variable v >>= deref
(k, value) <- asPair var
sym <- asString k
addr <- box value
export (name sym) (name sym) (Just addr)
box unit)

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

@ -5,43 +5,41 @@ module Control.Abstract.PythonPackage
import Control.Abstract.Evaluator (LoopControl, Return)
import Control.Abstract.Heap (Allocator, Deref, deref)
import Control.Abstract.Value
import Control.Monad.Effect (Effectful (..))
import qualified Control.Monad.Effect as Eff
import Data.Abstract.Evaluatable
import Data.Abstract.Name (name)
import Data.Abstract.Path (stripQuotes)
import Data.Abstract.Value.Concrete (Value (..), ValueError (..))
import Data.Coerce
import qualified Data.Map as Map
import Prologue
data Strategy = Unknown | Packages [Text] | FindPackages [Text]
deriving (Show, Eq)
runPythonPackaging :: forall effects address body a. (
runPythonPackaging :: forall effects term address a. (
Eff.PureEffects effects
, Ord address
, Show address
, Show term
, Member Trace effects
, Member (Boolean (Value address body)) effects
, Member (State (Heap address (Value address body))) effects
, Member (Resumable (BaseError (AddressError address (Value address body)))) effects
, Member (Resumable (BaseError (ValueError address body))) effects
, Member (Boolean (Value term address)) effects
, Member (State (Heap address (Value term address))) effects
, Member (Resumable (BaseError (AddressError address (Value term address)))) effects
, Member (Resumable (BaseError (ValueError term address))) effects
, Member Fresh effects
, Coercible body (Eff.Eff effects)
, Member (State Strategy) effects
, Member (Allocator address) effects
, Member (Deref (Value address body)) effects
, Member (Deref (Value term address)) effects
, Member (Env address) effects
, Member (Eff.Exc (LoopControl address)) effects
, Member (Eff.Exc (Return address)) effects
, Member (Eff.Reader ModuleInfo) effects
, 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
runPythonPackaging = Eff.interpose @(Function address (Value address body)) $ \case
, Member (Function term address (Value term address)) effects)
=> Evaluator term address (Value term address) effects a
-> Evaluator term address (Value term address) effects a
runPythonPackaging = Eff.interpose @(Function term address (Value term address)) $ \case
Call callName super params -> do
case callName of
Closure _ _ name' paramNames _ _ -> do
@ -63,4 +61,5 @@ runPythonPackaging = Eff.interpose @(Function address (Value address body)) $ \c
_ -> pure ()
_ -> pure ()
call callName super params
Function name params vars body -> function name params vars (raiseEff body)
Function name params body -> function name params body
BuiltIn b -> builtIn b

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

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

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, Rank2Types #-}
{-# LANGUAGE GADTs, KindSignatures, Rank2Types #-}
module Control.Abstract.Value
( AbstractValue(..)
, AbstractIntro(..)
@ -6,6 +6,8 @@ module Control.Abstract.Value
-- * Value effects
-- $valueEffects
, function
, BuiltIn(..)
, builtIn
, call
, Function(..)
, boolean
@ -29,8 +31,8 @@ module Control.Abstract.Value
import Control.Abstract.Environment
import Control.Abstract.Evaluator
import Control.Abstract.Heap
import Data.Abstract.Environment as Env
import Data.Abstract.BaseError
import Data.Abstract.Environment as Env
import Data.Abstract.Module
import Data.Abstract.Name
import Data.Abstract.Number as Number
@ -63,34 +65,48 @@ 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 name params fvs (Evaluator body) = send (Function name params fvs body)
function :: Member (Function term address value) effects => Maybe Name -> [Name] -> term -> Evaluator term address value effects value
function name params body = sendFunction (Function name params body)
call :: Member (Function address value) effects => value -> address -> [address] -> Evaluator address value effects address
call fn self args = send (Call fn self args)
data BuiltIn
= Print
| Show
deriving (Eq, Ord, Show)
data Function address value m result where
Function :: Maybe Name -> [Name] -> Set Name -> m address -> Function address value m value
Call :: value -> address -> [address] -> Function address value m address
builtIn :: Member (Function term address value) effects => BuiltIn -> Evaluator term address value effects value
builtIn = sendFunction . BuiltIn
instance PureEffect (Function address value) where
handle handler (Request (Function name params fvs body) k) = Request (Function name params fvs (handler body)) (handler . k)
handle handler (Request (Call fn self addrs) k) = Request (Call fn self addrs) (handler . k)
call :: Member (Function term address value) effects => value -> address -> [address] -> Evaluator term address value effects address
call fn self args = sendFunction (Call fn self args)
sendFunction :: Member (Function term address value) effects => Function term address value (Eff effects) a -> Evaluator term address value effects a
sendFunction = send
data Function term address value (m :: * -> *) result where
Function :: Maybe Name -> [Name] -> term -> Function term address value m value
BuiltIn :: BuiltIn -> Function term address value m value
Call :: value -> address -> [address] -> Function term address value m address
instance PureEffect (Function term address value)
instance Effect (Function term address value) where
handleState state handler (Request (Function name params body) k) = Request (Function name params body) (handler . (<$ state) . k)
handleState state handler (Request (BuiltIn builtIn) k) = Request (BuiltIn builtIn) (handler . (<$ state) . k)
handleState state handler (Request (Call fn self addrs) k) = Request (Call fn self addrs) (handler . (<$ state) . 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
@ -105,25 +121,25 @@ instance PureEffect (Boolean value) where
-- | The fundamental looping primitive, built on top of 'ifthenelse'.
while :: Member (While value) effects
=> Evaluator address value effects value -- ^ Condition
-> Evaluator address value effects value -- ^ Body
-> Evaluator address value effects value
=> Evaluator term address value effects value -- ^ Condition
-> Evaluator term address value effects value -- ^ Body
-> Evaluator term address value effects value
while (Evaluator cond) (Evaluator body) = send (While cond body)
-- | Do-while loop, built on top of while.
doWhile :: Member (While value) effects
=> Evaluator address value effects value -- ^ Body
-> Evaluator address value effects value -- ^ Condition
-> Evaluator address value effects value
=> Evaluator term address value effects value -- ^ Body
-> Evaluator term address value effects value -- ^ Condition
-> Evaluator term address value effects value
doWhile body cond = body *> while cond body
-- | C-style for loops.
forLoop :: (Member (While 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))
@ -170,59 +186,59 @@ class Show value => AbstractIntro value where
-- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc).
--
-- This allows us to abstract the choice of whether to evaluate under binders for different value types.
class AbstractIntro value => AbstractValue address value effects where
class AbstractIntro value => AbstractValue term 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
--
@ -230,13 +246,13 @@ 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))
makeNamespace :: ( AbstractValue address value effects
makeNamespace :: ( AbstractValue term address value effects
, Member (Deref value) effects
, Member (Env address) effects
, Member (State (Heap address value)) effects
@ -245,8 +261,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
@ -254,12 +270,12 @@ makeNamespace name addr super body = do
-- | Evaluate a term within the context of the scoped environment of 'scopedEnvTerm'.
evaluateInScopedEnv :: ( AbstractValue address value effects
evaluateInScopedEnv :: ( AbstractValue term 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
@ -267,7 +283,7 @@ evaluateInScopedEnv receiver term = do
-- | Evaluates a 'Value' returning the referenced value
value :: ( AbstractValue address value effects
value :: ( AbstractValue term address value effects
, Member (Deref value) effects
, Member (Env address) effects
, Member (Reader ModuleInfo) effects
@ -278,11 +294,11 @@ 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
subtermValue :: ( AbstractValue address value effects
subtermValue :: ( AbstractValue term address value effects
, Member (Deref value) effects
, Member (Env address) effects
, Member (Reader ModuleInfo) effects
@ -292,32 +308,32 @@ 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'
address :: ( AbstractValue address value effects
address :: ( AbstractValue term address value effects
, Member (Env address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) 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
-- | Evaluates a 'Subterm' to the address of its rval
subtermAddress :: ( AbstractValue address value effects
subtermAddress :: ( AbstractValue term address value effects
, Member (Env address) effects
, Member (Reader ModuleInfo) 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
@ -328,5 +344,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

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

@ -39,16 +39,17 @@ import Data.Abstract.Name as X
import Data.Abstract.Ref as X
import Data.Coerce
import Data.Language
import Data.Function
import Data.Scientific (Scientific)
import Data.Semigroup.App
import Data.Semigroup.Foldable
import Data.Sum
import Data.Sum hiding (project)
import Data.Term
import Prologue
-- | The 'Evaluatable' class defines the necessary interface for a term to be evaluated. While a default definition of 'eval' is given, instances with computational content must implement 'eval' to perform their small-step operational semantics.
class (Show1 constr, Foldable constr) => Evaluatable constr where
eval :: ( AbstractValue address value effects
eval :: ( AbstractValue term address value effects
, Declarations term
, FreeVariables term
, Member (Allocator address) effects
@ -60,7 +61,7 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where
, Member (Exc (LoopControl address)) effects
, Member (Exc (Return address)) effects
, Member Fresh effects
, Member (Function address value) effects
, Member (Function term address value) effects
, Member (Modules address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
@ -75,9 +76,10 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where
, Member Trace effects
, Ord address
)
=> SubtermAlgebra constr term (Evaluator address value effects (ValueRef address))
eval expr = do
traverse_ subtermValue expr
=> (term -> Evaluator term address value effects (ValueRef address))
-> (constr term -> Evaluator term address value effects (ValueRef address))
eval recur expr = do
traverse_ recur expr
v <- throwUnspecializedError $ UnspecializedError ("Eval unspecialized for " <> liftShowsPrec (const (const id)) (const id) 0 expr "")
rvalBox v
@ -92,13 +94,13 @@ type ModuleEffects address value rest
': Reader ModuleInfo
': rest
type ValueEffects address value rest
= Function address value
type ValueEffects term address value rest
= Function term address value
': While value
': Boolean value
': rest
evaluate :: ( AbstractValue address value valueEffects
evaluate :: ( AbstractValue term address value valueEffects
, Declarations term
, Effects effects
, Evaluatable (Base term)
@ -121,31 +123,33 @@ evaluate :: ( AbstractValue address value valueEffects
, Ord address
, Recursive term
, moduleEffects ~ ModuleEffects address value effects
, valueEffects ~ ValueEffects address value moduleEffects
, valueEffects ~ ValueEffects term 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)
-> Open (Module term -> Evaluator term address value moduleEffects address)
-> Open (Open (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 . (term -> Evaluator term address value valueEffects address) -> 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 evalTerm $ do
definePrelude lang
box unit
foldr (run preludeBinds) ask modules
where run preludeBinds m rest = do
evaluated <- coerce
(runInModule preludeBinds (moduleInfo m))
(analyzeModule (subtermRef . moduleBody)
(evalModuleBody <$> m))
(analyzeModule (evalModuleBody . moduleBody)
m)
-- FIXME: this should be some sort of Monoidal insert à la the Heap to accommodate multiple Go files being part of the same module.
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)))
evalModuleBody term = runValue evalTerm (do
result <- evalTerm term
result <$ postlude lang)
evalTerm = fix (analyzeTerm ((. project) . eval)) >=> address
runInModule preludeBinds info
= runReader info
@ -156,20 +160,20 @@ 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)
-- Preludes
class HasPrelude (language :: Language) where
definePrelude :: ( AbstractValue address value effects
definePrelude :: ( AbstractValue term address value effects
, HasCallStack
, Member (Allocator address) effects
, Member (Deref value) effects
, Member (Env address) effects
, Member Fresh effects
, Member (Function address value) effects
, Member (Function term address value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
@ -179,7 +183,7 @@ class HasPrelude (language :: Language) where
, Ord address
)
=> proxy language
-> Evaluator address value effects ()
-> Evaluator term address value effects ()
definePrelude _ = pure ()
instance HasPrelude 'Go
@ -189,29 +193,29 @@ instance HasPrelude 'PHP
instance HasPrelude 'Python where
definePrelude _ =
define (name "print") builtInPrint
define (name "print") (builtIn Print)
instance HasPrelude 'Ruby where
definePrelude _ = do
define (name "puts") builtInPrint
define (name "puts") (builtIn Print)
defineClass (name "Object") [] $ do
define (name "inspect") (lambda (box (string "<object>")))
define (name "inspect") (builtIn Show)
instance HasPrelude 'TypeScript where
definePrelude _ =
defineNamespace (name "console") $ do
define (name "log") builtInPrint
define (name "log") (builtIn Print)
instance HasPrelude 'JavaScript where
definePrelude _ = do
defineNamespace (name "console") $ do
define (name "log") builtInPrint
define (name "log") (builtIn Print)
-- Postludes
class HasPostlude (language :: Language) where
postlude :: ( AbstractValue address value effects
postlude :: ( AbstractValue term address value effects
, HasCallStack
, Member (Allocator address) effects
, Member (Deref value) effects
@ -223,7 +227,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
@ -265,10 +269,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
@ -276,7 +280,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
@ -292,15 +296,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
@ -308,7 +312,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
@ -316,11 +320,11 @@ throwUnspecializedError = throwBaseError
-- | If we can evaluate any syntax which can occur in a 'Sum', we can evaluate the 'Sum'.
instance (Apply Evaluatable fs, Apply Show1 fs, Apply Foldable fs) => Evaluatable (Sum fs) where
eval = apply @Evaluatable eval
eval eval' = apply @Evaluatable (eval eval')
-- | Evaluating a 'TermF' ignores its annotation, evaluating the underlying syntax.
instance (Evaluatable s, Show a) => Evaluatable (TermF s a) where
eval = eval . termFOut
eval eval' = eval eval' . termFOut
-- NOTE: Use 'Data.Syntax.Statements' instead of '[]' if you need imperative eval semantics.
@ -332,4 +336,4 @@ instance (Evaluatable s, Show a) => Evaluatable (TermF s a) where
-- 3. Only the last statement’s return value is returned.
instance Evaluatable [] where
-- 'nonEmpty' and 'foldMap1' enable us to return the last statement’s result instead of 'unit' for non-empty lists.
eval = maybe (rvalBox unit) (runApp . foldMap1 (App . subtermRef)) . nonEmpty
eval eval = maybe (rvalBox unit) (runApp . foldMap1 (App . eval)) . nonEmpty

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

@ -27,16 +27,18 @@ runFunction :: ( Member (Allocator address) effects
, Ord address
, PureEffects effects
)
=> Evaluator address Abstract (Function address Abstract ': effects) a
-> Evaluator address Abstract effects a
runFunction = interpret $ \case
Function _ params _ body -> do
=> (term -> Evaluator term address Abstract (Abstract.Function term address Abstract ': effects) address)
-> Evaluator term address Abstract (Function term address Abstract ': effects) a
-> Evaluator term address Abstract effects a
runFunction eval = interpret $ \case
Function _ params body -> do
env <- foldr (\ name rest -> do
addr <- alloc name
assign addr Abstract
Env.insert name addr <$> rest) (pure lowerBound) params
addr <- locally (bindAll env *> catchReturn (runFunction (Evaluator body)))
addr <- locally (bindAll env *> catchReturn (runFunction eval (eval body)))
deref addr
BuiltIn _ -> pure Abstract
Call _ _ params -> do
traverse_ deref params
box Abstract
@ -44,8 +46,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
@ -66,8 +68,8 @@ runWhile ::
, Ord address
, PureEffects effects
)
=> Evaluator address Abstract (While Abstract ': effects) a
-> Evaluator address Abstract effects a
=> Evaluator term address Abstract (While Abstract ': effects) a
-> Evaluator term address Abstract effects a
runWhile = interpret $ \case
Abstract.While cond body -> do
cond' <- runWhile (raiseEff cond)
@ -97,7 +99,7 @@ instance ( Member (Allocator address) effects
, Member (State (Heap address Abstract)) effects
, Ord address
)
=> AbstractValue address Abstract effects where
=> AbstractValue term address Abstract effects where
array _ = pure Abstract
tuple _ = pure Abstract

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

@ -2,7 +2,6 @@
module Data.Abstract.Value.Concrete
( Value (..)
, ValueError (..)
, ClosureBody (..)
, runFunction
, runBoolean
, runWhile
@ -17,19 +16,20 @@ import Data.Abstract.BaseError
import Data.Abstract.Evaluatable (UnspecializedError(..))
import Data.Abstract.Environment (Environment, Bindings, EvalContext(..))
import qualified Data.Abstract.Environment as Env
import Data.Abstract.FreeVariables
import Data.Abstract.Name
import qualified Data.Abstract.Number as Number
import Data.Bits
import Data.Coerce
import Data.List (genericIndex, genericLength)
import Data.Scientific (Scientific, coefficient, normalize)
import Data.Scientific.Exts
import qualified Data.Set as Set
import Data.Text (pack)
import Data.Word
import Prologue hiding (catchError)
data Value address body
= Closure PackageInfo ModuleInfo (Maybe Name) [Name] (ClosureBody address body) (Environment address)
data Value term address
= Closure PackageInfo ModuleInfo (Maybe Name) [Name] (Either BuiltIn term) (Environment address)
| Unit
| Boolean Bool
| Integer (Number.Number Integer)
@ -42,72 +42,69 @@ data Value address body
| Array [address]
| Class Name [address] (Bindings address)
| Namespace Name (Maybe address) (Bindings address)
| KVPair (Value address body) (Value address body)
| Hash [Value address body]
| KVPair (Value term address) (Value term address)
| Hash [Value term address]
| Null
| Hole
deriving (Eq, Ord, Show)
data ClosureBody address body = ClosureBody { closureBodyId :: Int, closureBody :: body address }
instance Eq (ClosureBody address body) where
(==) = (==) `on` closureBodyId
instance Ord (ClosureBody address body) where
compare = compare `on` closureBodyId
instance Show (ClosureBody address body) where
showsPrec d (ClosureBody i _) = showsUnaryWith showsPrec "ClosureBody" d i
instance Ord address => ValueRoots address (Value address body) where
instance Ord address => ValueRoots address (Value term address) where
valueRoots v
| Closure _ _ _ _ _ env <- v = Env.addresses env
| otherwise = mempty
| otherwise = mempty
runFunction :: ( Member (Allocator address) effects
, Member (Deref (Value address body)) effects
runFunction :: ( FreeVariables term
, Member (Allocator address) effects
, Member (Deref (Value term address)) effects
, Member (Env address) effects
, Member (Exc (Return address)) effects
, Member Fresh effects
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address (Value address body)))) effects
, Member (Resumable (BaseError (ValueError address body))) effects
, Member (State (Heap address (Value address body))) effects
, Member (Resumable (BaseError (AddressError address (Value term address)))) effects
, Member (Resumable (BaseError (ValueError term address))) effects
, Member (State (Heap address (Value term address))) effects
, Member Trace effects
, Ord address
, PureEffects effects
, Show address
, Show term
)
=> (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
runFunction toEvaluator fromEvaluator = interpret $ \case
Abstract.Function name params fvs body -> do
=> (term -> Evaluator term address (Value term address) (Abstract.Function term address (Value term address) ': effects) address)
-> Evaluator term address (Value term address) (Abstract.Function term address (Value term address) ': effects) a
-> Evaluator term address (Value term address) effects a
runFunction eval = interpret $ \case
Abstract.Function name params body -> do
packageInfo <- currentPackage
moduleInfo <- currentModule
i <- fresh
Closure packageInfo moduleInfo name params (ClosureBody i (fromEvaluator (Evaluator body))) <$> close (foldr Set.delete fvs params)
Closure packageInfo moduleInfo name params (Right body) <$> close (foldr Set.delete (freeVariables body) params)
Abstract.BuiltIn builtIn -> do
packageInfo <- currentPackage
moduleInfo <- currentModule
pure (Closure packageInfo moduleInfo Nothing [] (Left builtIn) lowerBound)
Abstract.Call op self params -> do
case op of
Closure packageInfo moduleInfo _ names (ClosureBody _ body) env -> do
Closure _ _ _ _ (Left Print) _ -> traverse (deref >=> trace . show) params *> box Unit
Closure _ _ _ _ (Left Show) _ -> deref self >>= box . String . pack . show
Closure packageInfo moduleInfo _ names (Right body) env -> do
-- Evaluate the bindings and body with the closure’s package/module info in scope in order to
-- charge them to the closure's origin.
withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do
bindings <- foldr (\ (name, addr) rest -> Env.insert name addr <$> rest) (pure lowerBound) (zip names params)
let fnCtx = EvalContext (Just self) (Env.push env)
withEvalContext fnCtx (catchReturn (bindAll bindings *> runFunction toEvaluator fromEvaluator (toEvaluator body)))
withEvalContext fnCtx (catchReturn (bindAll bindings *> runFunction eval (eval body)))
_ -> throwValueError (CallError op) >>= box
runBoolean :: ( Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (ValueError address body))) effects
, Member (Resumable (BaseError (ValueError term address))) 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 term address) (Abstract.Boolean (Value term address) ': effects) a
-> Evaluator term address (Value term address) effects a
runBoolean = interpret $ \case
Abstract.Boolean b -> pure $! Boolean b
Abstract.AsBool (Boolean b) -> pure b
@ -118,22 +115,23 @@ runBoolean = interpret $ \case
if a'' then pure a' else runBoolean (Evaluator b)
runWhile :: forall effects address body a .
runWhile :: forall effects term address a .
( PureEffects effects
, Member (Deref (Value address body)) effects
, Member (Abstract.Boolean (Value address body)) effects
, Member (Deref (Value term address)) effects
, Member (Abstract.Boolean (Value term address)) effects
, Member (Exc (LoopControl address)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address (Value address body)))) effects
, Member (Resumable (BaseError (ValueError address body))) effects
, Member (Resumable (BaseError (UnspecializedError (Value address body)))) effects
, Member (State (Heap address (Value address body))) effects
, Member (Resumable (BaseError (AddressError address (Value term address)))) effects
, Member (Resumable (BaseError (ValueError term address))) effects
, Member (Resumable (BaseError (UnspecializedError (Value term address)))) effects
, Member (State (Heap address (Value term address))) effects
, Ord address
, Show address
, Show term
)
=> Evaluator address (Value address body) (Abstract.While (Value address body) ': effects) a
-> Evaluator address (Value address body) effects a
=> Evaluator term address (Value term address) (Abstract.While (Value term address) ': effects) a
-> Evaluator term address (Value term address) effects a
runWhile = interpret $ \case
Abstract.While cond body -> loop $ \continue -> do
cond' <- runWhile (raiseEff cond)
@ -141,7 +139,7 @@ runWhile = interpret $ \case
-- `interpose` is used to handle 'UnspecializedError's and abort out of the
-- loop, otherwise under concrete semantics we run the risk of the
-- conditional always being true and getting stuck in an infinite loop.
let body' = interpose @(Resumable (BaseError (UnspecializedError (Value address body))))
let body' = interpose @(Resumable (BaseError (UnspecializedError (Value term address))))
(\(Resumable (BaseError _ _ (UnspecializedError _))) -> throwAbort) $
runWhile (raiseEff body) *> continue
@ -156,10 +154,10 @@ runWhile = interpret $ \case
Continue _ -> loop x)
instance AbstractHole (Value address body) where
instance AbstractHole (Value term address) where
hole = Hole
instance Show address => AbstractIntro (Value address body) where
instance (Show address, Show term) => AbstractIntro (Value term address) where
unit = Unit
integer = Integer . Number.Integer
string = String
@ -173,15 +171,15 @@ instance Show address => AbstractIntro (Value address body) where
null = Null
materializeEnvironment :: ( Member (Deref (Value address body)) effects
materializeEnvironment :: ( Member (Deref (Value term address)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address (Value address body)))) effects
, Member (State (Heap address (Value address body))) effects
, Member (Resumable (BaseError (AddressError address (Value term address)))) effects
, Member (State (Heap address (Value term address))) effects
, Ord address
)
=> Value address body
-> Evaluator address (Value address body) effects (Maybe (Environment address))
=> Value term address
-> Evaluator term address (Value term address) effects (Maybe (Environment address))
materializeEnvironment val = do
ancestors <- rec val
pure (Env.Environment <$> nonEmpty ancestors)
@ -201,10 +199,9 @@ materializeEnvironment val = do
_ -> []
-- | Construct a 'Value' wrapping the value arguments (if any).
instance ( Coercible body (Eff effects)
, Member (Allocator address) effects
, Member (Abstract.Boolean (Value address body)) effects
, Member (Deref (Value address body)) effects
instance ( Member (Allocator address) effects
, Member (Abstract.Boolean (Value term address)) effects
, Member (Deref (Value term address)) effects
, Member (Env address) effects
, Member (Exc (LoopControl address)) effects
, Member (Exc (Return address)) effects
@ -212,14 +209,15 @@ instance ( Coercible body (Eff effects)
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (ValueError address body))) effects
, Member (Resumable (BaseError (AddressError address (Value address body)))) effects
, Member (State (Heap address (Value address body))) effects
, Member (Resumable (BaseError (ValueError term address))) effects
, Member (Resumable (BaseError (AddressError address (Value term address)))) effects
, Member (State (Heap address (Value term address))) effects
, Member Trace effects
, Ord address
, Show address
, Show term
)
=> AbstractValue address (Value address body) effects where
=> AbstractValue term address (Value term address) effects where
asPair val
| KVPair k v <- val = pure (k, v)
| otherwise = throwValueError $ KeyValueError val
@ -284,9 +282,10 @@ instance ( Coercible body (Eff effects)
tentative x i j = attemptUnsafeArithmetic (x i j)
-- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor
specialize :: ( AbstractValue address (Value address body) effects)
specialize :: ( AbstractValue term address (Value term address) effects
)
=> Either ArithException Number.SomeNumber
-> Evaluator address (Value address body) effects (Value address body)
-> Evaluator term address (Value term address) effects (Value term address)
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
@ -305,7 +304,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, Ord a) => a -> a -> Evaluator address (Value address body) effects (Value address body)
go :: (AbstractValue term address (Value term address) effects, Ord a) => a -> a -> Evaluator term address (Value term address) effects (Value term address)
go l r = case comparator of
Concrete f -> boolean (f l r)
Generalized -> pure $ integer (orderingToInt (compare l r))
@ -340,26 +339,26 @@ instance ( Coercible body (Eff effects)
castToInteger i = throwValueError (NumericError i)
-- | The type of exceptions that can be thrown when constructing values in 'Value'’s 'MonadValue' instance.
data ValueError address body resume where
StringError :: Value address body -> ValueError address body Text
BoolError :: Value address body -> ValueError address body Bool
IndexError :: Value address body -> Value address body -> ValueError address body (Value address body)
NamespaceError :: Prelude.String -> ValueError address body (Bindings address)
CallError :: Value address body -> ValueError address body (Value address body)
NumericError :: Value address body -> ValueError address body (Value address body)
Numeric2Error :: Value address body -> Value address body -> ValueError address body (Value address body)
ComparisonError :: Value address body -> Value address body -> ValueError address body (Value address body)
BitwiseError :: Value address body -> ValueError address body (Value address body)
Bitwise2Error :: Value address body -> Value address body -> ValueError address body (Value address body)
KeyValueError :: Value address body -> ValueError address body (Value address body, Value address body)
ArrayError :: Value address body -> ValueError address body [address]
data ValueError term address resume where
StringError :: Value term address -> ValueError term address Text
BoolError :: Value term address -> ValueError term address Bool
IndexError :: Value term address -> Value term address -> ValueError term address (Value term address)
NamespaceError :: Prelude.String -> ValueError term address (Bindings address)
CallError :: Value term address -> ValueError term address (Value term address)
NumericError :: Value term address -> ValueError term address (Value term address)
Numeric2Error :: Value term address -> Value term address -> ValueError term address (Value term address)
ComparisonError :: Value term address -> Value term address -> ValueError term address (Value term address)
BitwiseError :: Value term address -> ValueError term address (Value term address)
Bitwise2Error :: Value term address -> Value term address -> ValueError term address (Value term address)
KeyValueError :: Value term address -> ValueError term address (Value term address, Value term address)
ArrayError :: Value term address -> ValueError term address [address]
-- Indicates that we encountered an arithmetic exception inside Haskell-native number crunching.
ArithmeticError :: ArithException -> ValueError address body (Value address body)
ArithmeticError :: ArithException -> ValueError term address (Value term address)
-- Out-of-bounds error
BoundsError :: [address] -> Prelude.Integer -> ValueError address body (Value address body)
BoundsError :: [address] -> Prelude.Integer -> ValueError term address (Value term address)
instance Eq address => Eq1 (ValueError address body) where
instance (Eq address, Eq term) => Eq1 (ValueError term address) where
liftEq _ (StringError a) (StringError b) = a == b
liftEq _ (NamespaceError a) (NamespaceError b) = a == b
liftEq _ (CallError a) (CallError b) = a == b
@ -373,25 +372,25 @@ instance Eq address => Eq1 (ValueError address body) where
liftEq _ (BoundsError a b) (BoundsError c d) = (a == c) && (b == d)
liftEq _ _ _ = False
deriving instance Show address => Show (ValueError address body resume)
instance Show address => Show1 (ValueError address body) where
deriving instance (Show address, Show term) => Show (ValueError term address resume)
instance (Show address, Show term) => Show1 (ValueError term address) 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 term address) (Resumable (BaseError (ValueError term address)) ': effects) a
-> Evaluator term address (Value term address) effects (Either (SomeExc (BaseError (ValueError term address))) 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 term address) resume -> Evaluator term address (Value term address) effects resume)
-> Evaluator term address (Value term address) (Resumable (BaseError (ValueError term address)) ': effects) a
-> Evaluator term address (Value term address) effects a
runValueErrorWith = runResumableWith
throwValueError :: ( Member (Resumable (BaseError (ValueError address body))) effects
throwValueError :: ( Member (Resumable (BaseError (ValueError term address))) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
)
=> ValueError address body resume
-> Evaluator address (Value address body) effects resume
=> ValueError term address resume
-> Evaluator term address (Value term address) effects resume
throwValueError = throwBaseError

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

@ -12,7 +12,7 @@ module Data.Abstract.Value.Type
) where
import qualified Control.Abstract as Abstract
import Control.Abstract hiding (Boolean(..), Function(..), While(..), raiseHandler)
import Control.Abstract hiding (Boolean(..), Function(..), While(..))
import Control.Monad.Effect.Internal (raiseHandler)
import Data.Abstract.Environment as Env
import Data.Abstract.BaseError
@ -98,7 +98,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
@ -191,7 +191,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
@ -208,7 +208,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
@ -244,16 +244,19 @@ runFunction :: ( Member (Allocator address) effects
, Ord address
, PureEffects effects
)
=> Evaluator address Type (Abstract.Function address Type ': effects) a
-> Evaluator address Type effects a
runFunction = interpret $ \case
Abstract.Function _ params _ body -> do
=> (term -> Evaluator term address Type (Abstract.Function term address Type ': effects) address)
-> Evaluator term address Type (Abstract.Function term address Type ': effects) a
-> Evaluator term address Type effects a
runFunction eval = interpret $ \case
Abstract.Function _ params body -> do
(env, tvars) <- foldr (\ name rest -> do
addr <- alloc name
tvar <- Var <$> fresh
assign addr tvar
bimap (Env.insert name addr) (tvar :) <$> rest) (pure (lowerBound, [])) params
(zeroOrMoreProduct tvars :->) <$> (locally (catchReturn (bindAll env *> runFunction (Evaluator body))) >>= deref)
(zeroOrMoreProduct tvars :->) <$> (locally (catchReturn (bindAll env *> runFunction eval (eval body))) >>= deref)
Abstract.BuiltIn Print -> pure (String :-> Unit)
Abstract.BuiltIn Show -> pure (Object :-> String)
Abstract.Call op _ params -> do
tvar <- fresh
paramTypes <- traverse deref params
@ -270,8 +273,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)
@ -295,8 +298,8 @@ runWhile ::
, Ord address
, PureEffects effects
)
=> Evaluator address Type (Abstract.While Type ': effects) a
-> Evaluator address Type effects a
=> Evaluator term address Type (Abstract.While Type ': effects) a
-> Evaluator term address Type effects a
runWhile = interpret $ \case
Abstract.While cond body -> do
cond' <- runWhile (raiseEff cond)
@ -330,7 +333,7 @@ instance ( Member (Allocator address) effects
, Member (State TypeMap) effects
, Ord address
)
=> AbstractValue address Type effects where
=> AbstractValue term address Type effects where
array fields = do
var <- fresh
fieldTypes <- traverse deref fields

6
src/Data/Syntax.hs
View File

@ -162,7 +162,7 @@ instance Ord1 Identifier where liftCompare = genericLiftCompare
instance Show1 Identifier where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Identifier where
eval (Identifier name) = pure (LvalLocal name)
eval _ (Identifier name) = pure (LvalLocal name)
instance Tokenize Identifier where
tokenize = yield . Run . formatName . Data.Syntax.name
@ -197,7 +197,7 @@ instance Ord1 Empty where liftCompare _ _ _ = EQ
instance Show1 Empty where liftShowsPrec _ _ _ _ = showString "Empty"
instance Evaluatable Empty where
eval _ = rvalBox unit
eval _ _ = rvalBox unit
instance Tokenize Empty where
tokenize = ignore
@ -303,7 +303,7 @@ instance Ord1 Context where liftCompare = genericLiftCompare
instance Show1 Context where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Context where
eval Context{..} = subtermRef contextSubject
eval eval Context{..} = eval contextSubject
instance Tokenize Context where
tokenize Context{..} = sequenceA_ (sepTrailing contextTerms) *> contextSubject

2
src/Data/Syntax/Comment.hs
View File

@ -18,7 +18,7 @@ instance Ord1 Comment where liftCompare = genericLiftCompare
instance Show1 Comment where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Comment where
eval _ = rvalBox unit
eval _ _ = rvalBox unit
instance Tokenize Comment where
tokenize = yield . Run . commentContent

45
src/Data/Syntax/Declaration.hs
View File

@ -28,12 +28,12 @@ instance Show1 Function where liftShowsPrec = genericLiftShowsPrec
-- TODO: How should we represent function types, where applicable?
instance Evaluatable Function where
eval Function{..} = do
name <- maybeM (throwEvalError NoNameError) (declaredName (subterm functionName))
(_, addr) <- letrec name (function (Just name) (paramNames functionParameters) (freeVariables functionBody) (subtermAddress functionBody))
eval _ Function{..} = do
name <- maybeM (throwEvalError NoNameError) (declaredName functionName)
(_, addr) <- letrec name (function (Just name) (paramNames functionParameters) functionBody)
bind name addr
pure (Rval addr)
where paramNames = foldMap (maybeToList . declaredName . subterm)
where paramNames = foldMap (maybeToList . declaredName)
instance Tokenize Function where
tokenize Function{..} = within' Scope.Function $ do
@ -61,12 +61,12 @@ instance Diffable Method where
-- Evaluating a Method creates a closure and makes that value available in the
-- local environment.
instance Evaluatable Method where
eval Method{..} = do
name <- maybeM (throwEvalError NoNameError) (declaredName (subterm methodName))
(_, addr) <- letrec name (function (Just name) (paramNames methodParameters) (freeVariables methodBody) (subtermAddress methodBody))
eval _ Method{..} = do
name <- maybeM (throwEvalError NoNameError) (declaredName methodName)
(_, addr) <- letrec name (function (Just name) (paramNames methodParameters) methodBody)
bind name addr
pure (Rval addr)
where paramNames = foldMap (maybeToList . declaredName . subterm)
where paramNames = foldMap (maybeToList . declaredName)
instance Tokenize Data.Syntax.Declaration.Method where
tokenize Method{..} = within' Scope.Method $ do
@ -127,12 +127,12 @@ instance Ord1 VariableDeclaration where liftCompare = genericLiftCompare
instance Show1 VariableDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable VariableDeclaration where
eval (VariableDeclaration []) = rvalBox unit
eval (VariableDeclaration decs) = do
eval _ (VariableDeclaration []) = rvalBox unit
eval eval (VariableDeclaration decs) = do
addresses <- for decs $ \declaration -> do
name <- maybeM (throwEvalError NoNameError) (declaredName (subterm declaration))
name <- maybeM (throwEvalError NoNameError) (declaredName declaration)
(span, valueRef) <- do
ref <- subtermRef declaration
ref <- eval declaration
subtermSpan <- get @Span
pure (subtermSpan, ref)
@ -173,9 +173,9 @@ instance Show1 PublicFieldDefinition where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for PublicFieldDefinition
instance Evaluatable PublicFieldDefinition where
eval PublicFieldDefinition{..} = do
eval _ PublicFieldDefinition{..} = do
span <- ask @Span
propertyName <- maybeM (throwEvalError NoNameError) (declaredName (subterm publicFieldPropertyName))
propertyName <- maybeM (throwEvalError NoNameError) (declaredName publicFieldPropertyName)
declare (Declaration propertyName) span Nothing
rvalBox unit
@ -205,16 +205,16 @@ instance Ord1 Class where liftCompare = genericLiftCompare
instance Show1 Class where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Class where
eval Class{..} = do
name <- maybeM (throwEvalError NoNameError) (declaredName (subterm classIdentifier))
eval eval Class{..} = do
name <- maybeM (throwEvalError NoNameError) (declaredName classIdentifier)
span <- ask @Span
-- Run the action within the class's scope.
currentScope' <- currentScope
supers <- for classSuperclasses $ \superclass -> do
name <- maybeM (throwEvalError NoNameError) (declaredName (subterm superclass))
name <- maybeM (throwEvalError NoNameError) (declaredName superclass)
scope <- associatedScope (Declaration name)
(scope,) <$> subtermAddress superclass
(scope,) <$> (eval superclass >>= address)
let imports = (Import,) <$> (fmap pure . catMaybes $ fst <$> supers)
current = maybe mempty (fmap (Lexical, ) . pure . pure) currentScope'
@ -224,7 +224,7 @@ instance Evaluatable Class where
withScope childScope $ do
(_, addr) <- letrec name $ do
void $ subtermValue classBody
void $ eval classBody
classBinds <- Env.head <$> getEnv
klass name (snd <$> supers) classBinds
bind name addr
@ -302,11 +302,10 @@ instance Eq1 TypeAlias where liftEq = genericLiftEq
instance Ord1 TypeAlias where liftCompare = genericLiftCompare
instance Show1 TypeAlias where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for TypeAlias
instance Evaluatable TypeAlias where
eval TypeAlias{..} = do
name <- maybeM (throwEvalError NoNameError) (declaredName (subterm typeAliasIdentifier))
addr <- subtermAddress typeAliasKind
eval eval TypeAlias{..} = do
name <- maybeM (throwEvalError NoNameError) (declaredName typeAliasIdentifier)
addr <- eval typeAliasKind >>= address
bind name addr
pure (Rval addr)

4
src/Data/Syntax/Directive.hs
View File

@ -20,7 +20,7 @@ instance Ord1 File where liftCompare = genericLiftCompare
instance Show1 File where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable File where
eval File = rvalBox =<< (string . T.pack . modulePath <$> currentModule)
eval _ File = rvalBox =<< (string . T.pack . modulePath <$> currentModule)
-- A line directive like the Ruby constant `__LINE__`.
@ -32,4 +32,4 @@ instance Ord1 Line where liftCompare = genericLiftCompare
instance Show1 Line where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Line where
eval Line = rvalBox =<< (integer . fromIntegral . posLine . spanStart <$> currentSpan)
eval _ Line = rvalBox =<< (integer . fromIntegral . posLine . spanStart <$> currentSpan)

120
src/Data/Syntax/Expression.hs
View File

@ -9,7 +9,7 @@ import Data.Fixed
import Proto3.Suite.Class
import Control.Abstract.ScopeGraph as ScopeGraph
import Data.Abstract.Evaluatable hiding (Member)
import Data.Abstract.Evaluatable as Abstract hiding (Member)
import Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent, liftedFloorDiv)
import Data.JSON.Fields
import qualified Data.Reprinting.Scope as Scope
@ -26,10 +26,10 @@ instance Ord1 Call where liftCompare = genericLiftCompare
instance Show1 Call where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Call where
eval Call{..} = do
op <- subtermValue callFunction
eval eval Call{..} = do
op <- eval callFunction >>= Abstract.value
recv <- box unit -- TODO
args <- traverse subtermAddress callParams
args <- traverse (eval >=> address) callParams
Rval <$> call op recv args
instance Tokenize Call where
@ -47,7 +47,7 @@ instance Ord1 LessThan where liftCompare = genericLiftCompare
instance Show1 LessThan where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable LessThan where
eval t = rvalBox =<< (traverse subtermValue t >>= go) where
eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where
go x = case x of
(LessThan a b) -> liftComparison (Concrete (<)) a b
@ -59,7 +59,7 @@ instance Ord1 LessThanEqual where liftCompare = genericLiftCompare
instance Show1 LessThanEqual where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable LessThanEqual where
eval t = rvalBox =<< (traverse subtermValue t >>= go) where
eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where
go x = case x of
(LessThanEqual a b) -> liftComparison (Concrete (<=)) a b
@ -71,7 +71,7 @@ instance Ord1 GreaterThan where liftCompare = genericLiftCompare
instance Show1 GreaterThan where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable GreaterThan where
eval t = rvalBox =<< (traverse subtermValue t >>= go) where
eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where
go x = case x of
(GreaterThan a b) -> liftComparison (Concrete (>)) a b
@ -83,7 +83,7 @@ instance Ord1 GreaterThanEqual where liftCompare = genericLiftCompare
instance Show1 GreaterThanEqual where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable GreaterThanEqual where
eval t = rvalBox =<< (traverse subtermValue t >>= go) where
eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where
go x = case x of
(GreaterThanEqual a b) -> liftComparison (Concrete (>=)) a b
@ -95,7 +95,7 @@ instance Ord1 Equal where liftCompare = genericLiftCompare
instance Show1 Equal where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Equal where
eval t = rvalBox =<< (traverse subtermValue t >>= go) where
eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where
go x = case x of
-- TODO: in PHP and JavaScript, the equals operator performs type coercion.
-- We need some mechanism to customize this behavior per-language.
@ -109,7 +109,7 @@ instance Ord1 StrictEqual where liftCompare = genericLiftCompare
instance Show1 StrictEqual where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable StrictEqual where
eval t = rvalBox =<< (traverse subtermValue t >>= go) where
eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where
go x = case x of
-- TODO: in PHP and JavaScript, the equals operator performs type coercion.
-- We need some mechanism to customize this behavior per-language.
@ -123,7 +123,7 @@ instance Ord1 Comparison where liftCompare = genericLiftCompare
instance Show1 Comparison where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Comparison where
eval t = rvalBox =<< (traverse subtermValue t >>= go) where
eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where
go x = case x of
(Comparison a b) -> liftComparison (Concrete (==)) a b
@ -135,7 +135,7 @@ instance Ord1 Plus where liftCompare = genericLiftCompare
instance Show1 Plus where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Plus where
eval t = rvalBox =<< (traverse subtermValue t >>= go) where
eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where
go (Plus a b) = liftNumeric2 add a b where add = liftReal (+)
instance Tokenize Plus where
@ -149,7 +149,7 @@ instance Ord1 Minus where liftCompare = genericLiftCompare
instance Show1 Minus where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Minus where
eval t = rvalBox =<< (traverse subtermValue t >>= go) where
eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where
go (Minus a b) = liftNumeric2 sub a b where sub = liftReal (-)
instance Tokenize Minus where
@ -163,7 +163,7 @@ instance Ord1 Times where liftCompare = genericLiftCompare
instance Show1 Times where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Times where
eval t = rvalBox =<< (traverse subtermValue t >>= go) where
eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where
go (Times a b) = liftNumeric2 mul a b where mul = liftReal (*)
instance Tokenize Times where
@ -177,7 +177,7 @@ instance Ord1 DividedBy where liftCompare = genericLiftCompare
instance Show1 DividedBy where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable DividedBy where
eval t = rvalBox =<< (traverse subtermValue t >>= go) where
eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where
go (DividedBy a b) = liftNumeric2 div' a b where div' = liftIntegralFrac div (/)
data Modulo a = Modulo { lhs :: a, rhs :: a }
@ -188,7 +188,7 @@ instance Ord1 Modulo where liftCompare = genericLiftCompare
instance Show1 Modulo where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Modulo where
eval t = rvalBox =<< (traverse subtermValue t >>= go) where
eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where
go (Modulo a b) = liftNumeric2 mod'' a b where mod'' = liftIntegralFrac mod mod'
data Power a = Power { lhs :: a, rhs :: a }
@ -199,7 +199,7 @@ instance Ord1 Power where liftCompare = genericLiftCompare
instance Show1 Power where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Power where
eval t = rvalBox =<< (traverse subtermValue t >>= go) where
eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where
go (Power a b) = liftNumeric2 liftedExponent a b
newtype Negate a = Negate { value :: a }
@ -210,7 +210,7 @@ instance Ord1 Negate where liftCompare = genericLiftCompare
instance Show1 Negate where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Negate where
eval t = rvalBox =<< (traverse subtermValue t >>= go) where
eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where
go (Negate a) = liftNumeric negate a
data FloorDivision a = FloorDivision { lhs :: a, rhs :: a }
@ -221,7 +221,7 @@ instance Ord1 FloorDivision where liftCompare = genericLiftCompare
instance Show1 FloorDivision where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable FloorDivision where
eval t = rvalBox =<< (traverse subtermValue t >>= go) where
eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where
go (FloorDivision a b) = liftNumeric2 liftedFloorDiv a b
-- | Regex matching operators (Ruby's =~ and ~!)
@ -249,7 +249,7 @@ instance Ord1 Or where liftCompare = genericLiftCompare
instance Show1 Or where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Or where
eval (Or a b) = disjunction (subtermValue a) (subtermValue b) >>= rvalBox
eval eval (Or a b) = disjunction (eval a >>= Abstract.value) (eval b >>= Abstract.value) >>= rvalBox
data And a = And { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1)
@ -258,7 +258,7 @@ instance Eq1 And where liftEq = genericLiftEq
instance Ord1 And where liftCompare = genericLiftCompare
instance Show1 And where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable And where
eval t = rvalBox =<< go (fmap subtermValue t) where
eval eval t = rvalBox =<< go (fmap (eval >=> Abstract.value) t) where
go (And a b) = do
cond <- a
ifthenelse cond b (pure cond)
@ -271,7 +271,7 @@ instance Ord1 Not where liftCompare = genericLiftCompare
instance Show1 Not where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Not where
eval t = rvalBox =<< go (fmap subtermValue t) where
eval eval t = rvalBox =<< go (fmap (eval >=> Abstract.value) t) where
go (Not a) = a >>= asBool >>= boolean . not
data XOr a = XOr { lhs :: a, rhs :: a }
@ -283,7 +283,7 @@ instance Show1 XOr where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable XOr where
-- N.B. we have to use Monad rather than Applicative/Traversable on 'And' and 'Or' so that we don't evaluate both operands
eval t = rvalBox =<< go (fmap subtermValue t) where
eval eval t = rvalBox =<< go (fmap (eval >=> Abstract.value) t) where
go (XOr a b) = liftA2 (/=) (a >>= asBool) (b >>= asBool) >>= boolean
-- | Javascript delete operator
@ -295,8 +295,8 @@ instance Ord1 Delete where liftCompare = genericLiftCompare
instance Show1 Delete where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Delete where
eval (Delete a) = do
valueRef <- subtermRef a
eval eval (Delete a) = do
valueRef <- eval a
addr <- address valueRef
dealloc addr
rvalBox unit
@ -310,8 +310,8 @@ instance Ord1 SequenceExpression where liftCompare = genericLiftCompare
instance Show1 SequenceExpression where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable SequenceExpression where
eval (SequenceExpression a b) =
subtermValue a >> subtermRef b
eval eval (SequenceExpression a b) =
eval a >> eval b
-- | Javascript void operator
newtype Void a = Void { value :: a }
@ -322,8 +322,8 @@ instance Ord1 Void where liftCompare = genericLiftCompare
instance Show1 Void where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Void where
eval (Void a) =
subtermValue a >> rvalBox null
eval eval (Void a) =
eval a >> rvalBox null
-- | Javascript typeof operator
newtype Typeof a = Typeof { value :: a }
@ -344,9 +344,9 @@ instance Eq1 BOr where liftEq = genericLiftEq
instance Ord1 BOr where liftCompare = genericLiftCompare
instance Show1 BOr where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable BOr where
eval (BOr a b) = do
a' <- subtermValue a >>= castToInteger
b' <- subtermValue b >>= castToInteger
eval eval (BOr a b) = do
a' <- eval a >>= Abstract.value >>= castToInteger
b' <- eval b >>= Abstract.value >>= castToInteger
liftBitwise2 (.|.) a' b' >>= rvalBox
data BAnd a = BAnd { left :: a, right :: a }
@ -356,9 +356,9 @@ instance Eq1 BAnd where liftEq = genericLiftEq
instance Ord1 BAnd where liftCompare = genericLiftCompare
instance Show1 BAnd where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable BAnd where
eval (BAnd a b) = do
a' <- subtermValue a >>= castToInteger
b' <- subtermValue b >>= castToInteger
eval eval (BAnd a b) = do
a' <- eval a >>= Abstract.value >>= castToInteger
b' <- eval b >>= Abstract.value >>= castToInteger
liftBitwise2 (.&.) a' b' >>= rvalBox
@ -369,9 +369,9 @@ instance Eq1 BXOr where liftEq = genericLiftEq
instance Ord1 BXOr where liftCompare = genericLiftCompare
instance Show1 BXOr where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable BXOr where
eval (BXOr a b) = do
a' <- subtermValue a >>= castToInteger
b' <- subtermValue b >>= castToInteger
eval eval (BXOr a b) = do
a' <- eval a >>= Abstract.value >>= castToInteger
b' <- eval b >>= Abstract.value >>= castToInteger
liftBitwise2 xor a' b' >>= rvalBox
data LShift a = LShift { left :: a, right :: a }
@ -381,9 +381,9 @@ instance Eq1 LShift where liftEq = genericLiftEq
instance Ord1 LShift where liftCompare = genericLiftCompare
instance Show1 LShift where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable LShift where
eval (LShift a b) = do
a' <- subtermValue a >>= castToInteger
b' <- subtermValue b >>= castToInteger
eval eval (LShift a b) = do
a' <- eval a >>= Abstract.value >>= castToInteger
b' <- eval b >>= Abstract.value >>= castToInteger
liftBitwise2 shiftL' a' b' >>= rvalBox
where
shiftL' a b = shiftL a (fromIntegral (toInteger b))
@ -395,9 +395,9 @@ instance Eq1 RShift where liftEq = genericLiftEq
instance Ord1 RShift where liftCompare = genericLiftCompare
instance Show1 RShift where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable RShift where
eval (RShift a b) = do
a' <- subtermValue a >>= castToInteger
b' <- subtermValue b >>= castToInteger
eval eval (RShift a b) = do
a' <- eval a >>= Abstract.value >>= castToInteger
b' <- eval b >>= Abstract.value >>= castToInteger
liftBitwise2 shiftR' a' b' >>= rvalBox
where
shiftR' a b = shiftR a (fromIntegral (toInteger b))
@ -409,9 +409,9 @@ instance Eq1 UnsignedRShift where liftEq = genericLiftEq
instance Ord1 UnsignedRShift where liftCompare = genericLiftCompare
instance Show1 UnsignedRShift where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable UnsignedRShift where
eval (UnsignedRShift a b) = do
a' <- subtermValue a >>= castToInteger
b' <- subtermValue b >>= castToInteger
eval eval (UnsignedRShift a b) = do
a' <- eval a >>= Abstract.value >>= castToInteger
b' <- eval b >>= Abstract.value >>= castToInteger
unsignedRShift a' b' >>= rvalBox
newtype Complement a = Complement { value :: a }
@ -422,8 +422,8 @@ instance Ord1 Complement where liftCompare = genericLiftCompare
instance Show1 Complement where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Complement where
eval (Complement a) = do
a' <- subtermValue a >>= castToInteger
eval eval (Complement a) = do
a' <- eval a >>= Abstract.value >>= castToInteger
liftBitwise complement a' >>= rvalBox
-- | Member Access (e.g. a.b)
@ -438,12 +438,12 @@ instance Ord1 MemberAccess where liftCompare = genericLiftCompare
instance Show1 MemberAccess where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable MemberAccess where
eval (MemberAccess obj propName) = do
name <- maybeM (throwEvalError NoNameError) (declaredName (subterm obj))
eval eval (MemberAccess obj propName) = do
name <- maybeM (throwEvalError NoNameError) (declaredName obj)
reference (Reference name) (Declaration name)
childScope <- associatedScope (Declaration name)
ptr <- subtermAddress obj
ptr <- eval obj >>= address
case childScope of
Just childScope -> withScope childScope $ reference (Reference propName) (Declaration propName)
Nothing ->
@ -463,8 +463,8 @@ instance Show1 Subscript where liftShowsPrec = genericLiftShowsPrec
-- TODO: Finish Eval instance for Subscript
-- TODO return a special LvalSubscript instance here
instance Evaluatable Subscript where
eval (Subscript l [r]) = Rval <$> join (index <$> subtermValue l <*> subtermValue r)
eval (Subscript _ _) = rvalBox =<< throwUnspecializedError (UnspecializedError "Eval unspecialized for subscript with slices")
eval eval (Subscript l [r]) = Rval <$> join (index <$> (eval l >>= Abstract.value) <*> (eval r >>= Abstract.value))
eval _ (Subscript _ _) = rvalBox =<< throwUnspecializedError (UnspecializedError "Eval unspecialized for subscript with slices")
data Member a = Member { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1)
@ -509,7 +509,7 @@ instance Ord1 ScopeResolution where liftCompare = genericLiftCompare
instance Show1 ScopeResolution where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ScopeResolution where
eval (ScopeResolution xs) = Rval <$> foldl1 f (fmap subtermAddress xs)
eval eval (ScopeResolution xs) = Rval <$> foldl1 f (fmap (eval >=> address) xs)
where f ns id = ns >>= flip evaluateInScopedEnv id
@ -536,7 +536,7 @@ instance Show1 Await where liftShowsPrec = genericLiftShowsPrec
-- TODO: Improve this to model asynchrony or capture some data suggesting async calls are not a problem.
-- We are currently dealing with an asynchronous construct synchronously.
instance Evaluatable Await where
eval (Await a) = subtermRef a
eval eval (Await a) = eval a
-- | An object constructor call in Javascript, Java, etc.
newtype New a = New { newSubject :: [a] }
@ -552,11 +552,11 @@ instance Show1 New where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for New
instance Evaluatable New where
eval New{..} = do
eval _ New{..} = do
case newSubject of
[] -> pure ()
(subject : _) -> do
name <- maybeM (throwEvalError NoNameError) (declaredName (subterm subject))
name <- maybeM (throwEvalError NoNameError) (declaredName subject)
reference (Reference name) (Declaration name)
-- TODO: Traverse subterms and instantiate frames from the corresponding scope
rvalBox unit
@ -578,7 +578,7 @@ instance Eq1 Super where liftEq = genericLiftEq
instance Ord1 Super where liftCompare = genericLiftCompare
instance Show1 Super where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Super where
eval Super = Rval <$> (maybeM (box unit) =<< self)
eval _ Super = Rval <$> (maybeM (box unit) =<< self)
data This a = This
deriving (Diffable, Eq, Foldable, Functor, Generic1, Ord, Show, Traversable, FreeVariables1, Declarations1, ToJSONFields1, Hashable1, Named1, Message1)
@ -587,4 +587,4 @@ instance Eq1 This where liftEq = genericLiftEq
instance Ord1 This where liftCompare = genericLiftCompare
instance Show1 This where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable This where
eval This = Rval <$> (maybeM (box unit) =<< self)
eval _ This = Rval <$> (maybeM (box unit) =<< self)

24
src/Data/Syntax/Literal.hs
View File

@ -31,7 +31,7 @@ instance Ord1 Boolean where liftCompare = genericLiftCompare
instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Boolean where
eval (Boolean x) = boolean x >>= rvalBox
eval _ (Boolean x) = boolean x >>= rvalBox
instance Tokenize Boolean where
tokenize = yield . Truth . booleanContent
@ -48,7 +48,7 @@ instance Show1 Data.Syntax.Literal.Integer where liftShowsPrec = genericLiftShow
instance Evaluatable Data.Syntax.Literal.Integer where
-- TODO: We should use something more robust than shelling out to readMaybe.
eval (Data.Syntax.Literal.Integer x) =
eval _ (Data.Syntax.Literal.Integer x) =
rvalBox =<< (integer <$> either (const (throwEvalError (IntegerFormatError x))) pure (parseInteger x))
instance Tokenize Data.Syntax.Literal.Integer where
@ -64,7 +64,7 @@ instance Ord1 Data.Syntax.Literal.Float where liftCompare = genericLiftCompare
instance Show1 Data.Syntax.Literal.Float where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Data.Syntax.Literal.Float where
eval (Float s) =
eval _ (Float s) =
rvalBox =<< (float <$> either (const (throwEvalError (FloatFormatError s))) pure (parseScientific s))
instance Tokenize Data.Syntax.Literal.Float where
@ -79,7 +79,7 @@ instance Ord1 Data.Syntax.Literal.Rational where liftCompare = genericLiftCompar
instance Show1 Data.Syntax.Literal.Rational where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Data.Syntax.Literal.Rational where
eval (Rational r) =
eval _ (Rational r) =
let
trimmed = T.takeWhile (/= 'r') r
parsed = readMaybe @Prelude.Integer (T.unpack trimmed)
@ -139,7 +139,7 @@ instance Ord1 TextElement where liftCompare = genericLiftCompare
instance Show1 TextElement where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TextElement where
eval (TextElement x) = rvalBox (string x)
eval _ (TextElement x) = rvalBox (string x)
instance Tokenize TextElement where
tokenize = yield . Run . textElementContent
@ -162,7 +162,7 @@ instance Eq1 Null where liftEq = genericLiftEq
instance Ord1 Null where liftCompare = genericLiftCompare
instance Show1 Null where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Null where eval _ = rvalBox null
instance Evaluatable Null where eval _ _ = rvalBox null
instance Tokenize Null where
tokenize _ = yield Nullity
@ -185,7 +185,7 @@ instance Ord1 SymbolElement where liftCompare = genericLiftCompare
instance Show1 SymbolElement where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable SymbolElement where
eval (SymbolElement s) = rvalBox (symbol s)
eval _ (SymbolElement s) = rvalBox (symbol s)
newtype Regex a = Regex { regexContent :: Text }
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Ord, Show, Traversable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1)
@ -198,7 +198,7 @@ instance Show1 Regex where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Regex
instance Evaluatable Regex where
eval (Regex x) = rvalBox (regex x)
eval _ (Regex x) = rvalBox (regex x)
-- Collections
@ -210,7 +210,7 @@ instance Ord1 Array where liftCompare = genericLiftCompare
instance Show1 Array where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Array where
eval (Array a) = rvalBox =<< array =<< traverse subtermAddress a
eval eval (Array a) = rvalBox =<< array =<< traverse (eval >=> address) a
instance Tokenize Array where
tokenize = list . arrayElements
@ -223,7 +223,7 @@ instance Ord1 Hash where liftCompare = genericLiftCompare
instance Show1 Hash where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Hash where
eval t = rvalBox =<< (Eval.hash <$> traverse (subtermValue >=> asPair) (hashElements t))
eval eval t = rvalBox =<< (Eval.hash <$> traverse (eval >=> Eval.value >=> asPair) (hashElements t))
instance Tokenize Hash where
tokenize = Tok.hash . hashElements
@ -236,7 +236,7 @@ instance Ord1 KeyValue where liftCompare = genericLiftCompare
instance Show1 KeyValue where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable KeyValue where
eval (fmap subtermValue -> KeyValue{..}) =
eval eval (fmap (eval >=> Eval.value) -> KeyValue{..}) =
rvalBox =<< (kvPair <$> key <*> value)
instance Tokenize KeyValue where
@ -250,7 +250,7 @@ instance Ord1 Tuple where liftCompare = genericLiftCompare
instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Tuple where
eval (Tuple cs) = rvalBox =<< tuple =<< traverse subtermAddress cs
eval eval (Tuple cs) = rvalBox =<< tuple =<< traverse (eval >=> address) cs
newtype Set a = Set { setElements :: [a] }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1)

42
src/Data/Syntax/Statement.hs
View File

@ -10,7 +10,7 @@ import Data.Semigroup.App
import Data.Semigroup.Foldable
import Proto3.Suite.Class
import Data.Abstract.Evaluatable
import Data.Abstract.Evaluatable as Abstract
import Control.Abstract.ScopeGraph
import Data.JSON.Fields
import Diffing.Algorithm
@ -32,11 +32,11 @@ instance Show1 Statements where liftShowsPrec = genericLiftShowsPrec
instance ToJSON1 Statements
instance Evaluatable Statements where
eval (Statements xs) = do
eval eval (Statements xs) = do
currentScope' <- currentScope
let edges = maybe mempty (Map.singleton Lexical . pure) currentScope'
scope <- newScope edges
withScope scope $ maybe (rvalBox unit) (runApp . foldMap1 (App . subtermRef)) (nonEmpty xs)
withScope scope $ maybe (rvalBox unit) (runApp . foldMap1 (App . eval)) (nonEmpty xs)
instance Tokenize Statements where
tokenize = imperative
@ -50,9 +50,9 @@ instance Ord1 If where liftCompare = genericLiftCompare
instance Show1 If where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable If where
eval (If cond if' else') = do
bool <- subtermValue cond
Rval <$> ifthenelse bool (subtermAddress if') (subtermAddress else')
eval eval (If cond if' else') = do
bool <- eval cond >>= Abstract.value
Rval <$> ifthenelse bool (eval if' >>= address) (eval else' >>= address)
instance Tokenize If where
tokenize If{..} = within' Scope.If $ do
@ -120,10 +120,10 @@ instance Ord1 Let where liftCompare = genericLiftCompare
instance Show1 Let where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Let where
eval Let{..} = do
name <- maybeM (throwEvalError NoNameError) (declaredName (subterm letVariable))
addr <- snd <$> letrec name (subtermValue letValue)
Rval <$> locally (bind name addr *> subtermAddress letBody)
eval eval Let{..} = do
name <- maybeM (throwEvalError NoNameError) (declaredName letVariable)
addr <- snd <$> letrec name (eval letValue >>= Abstract.value)
Rval <$> locally (bind name addr *> (eval letBody >>= address))
-- Assignment
@ -140,13 +140,13 @@ instance Ord1 Assignment where liftCompare = genericLiftCompare
instance Show1 Assignment where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Assignment where
eval Assignment{..} = do
lhs <- subtermRef assignmentTarget
rhs <- subtermAddress assignmentValue
eval eval Assignment{..} = do
lhs <- eval assignmentTarget
rhs <- eval assignmentValue >>= address
case lhs of
LvalLocal name -> do
case declaredName (subterm assignmentValue) of
case declaredName assignmentValue of
Just rhsName -> do
assocScope <- associatedScope (Declaration rhsName)
case assocScope of
@ -224,7 +224,7 @@ instance Ord1 Return where liftCompare = genericLiftCompare
instance Show1 Return where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Return where
eval (Return x) = Rval <$> (subtermAddress x >>= earlyReturn)
eval eval (Return x) = Rval <$> (eval x >>= address >>= earlyReturn)
instance Tokenize Return where
tokenize (Return x) = within' Scope.Return x
@ -248,7 +248,7 @@ instance Ord1 Break where liftCompare = genericLiftCompare
instance Show1 Break where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Break where
eval (Break x) = Rval <$> (subtermAddress x >>= throwBreak)
eval eval (Break x) = Rval <$> (eval x >>= address >>= throwBreak)
newtype Continue a = Continue { value :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1)
@ -258,7 +258,7 @@ instance Ord1 Continue where liftCompare = genericLiftCompare
instance Show1 Continue where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Continue where
eval (Continue x) = Rval <$> (subtermAddress x >>= throwContinue)
eval eval (Continue x) = Rval <$> (eval x >>= address >>= throwContinue)
newtype Retry a = Retry { value :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1)
@ -279,7 +279,7 @@ instance Ord1 NoOp where liftCompare = genericLiftCompare
instance Show1 NoOp where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable NoOp where
eval _ = rvalBox unit
eval _ _ = rvalBox unit
-- Loops
@ -291,7 +291,7 @@ instance Ord1 For where liftCompare = genericLiftCompare
instance Show1 For where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable For where
eval (fmap subtermValue -> For before cond step body) = rvalBox =<< forLoop before cond step body
eval eval (fmap (eval >=> Abstract.value) -> For before cond step body) = rvalBox =<< forLoop before cond step body
data ForEach a = ForEach { forEachBinding :: !a, forEachSubject :: !a, forEachBody :: !a }
@ -313,7 +313,7 @@ instance Ord1 While where liftCompare = genericLiftCompare
instance Show1 While where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable While where
eval While{..} = rvalBox =<< while (subtermValue whileCondition) (subtermValue whileBody)
eval eval While{..} = rvalBox =<< while (eval whileCondition >>= Abstract.value) (eval whileBody >>= Abstract.value)
data DoWhile a = DoWhile { doWhileCondition :: !a, doWhileBody :: !a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1)
@ -323,7 +323,7 @@ instance Ord1 DoWhile where liftCompare = genericLiftCompare
instance Show1 DoWhile where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable DoWhile where
eval DoWhile{..} = rvalBox =<< doWhile (subtermValue doWhileBody) (subtermValue doWhileCondition)
eval eval DoWhile{..} = rvalBox =<< doWhile (eval doWhileBody >>= Abstract.value) (eval doWhileCondition >>= Abstract.value)
-- Exception handling

2
src/Data/Syntax/Type.hs
View File

@ -33,7 +33,7 @@ instance Show1 Annotation where liftShowsPrec = genericLiftShowsPrec
-- TODO: Specialize Evaluatable for Type to unify the inferred type of the subject with the specified type
instance Evaluatable Annotation where
eval Annotation{annotationSubject = Subterm _ action} = action
eval eval Annotation{..} = eval annotationSubject
instance Tokenize Annotation where
-- FIXME: This ignores annotationType.

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

@ -4,6 +4,7 @@ module Language.Go.Syntax where
import Prologue
import Control.Abstract.ScopeGraph hiding (Import)
import Data.Abstract.BaseError
import Data.Abstract.Evaluatable
import Data.Abstract.Module
@ -11,6 +12,9 @@ import qualified Data.Abstract.Package as Package
import Data.Abstract.Path
import Data.Aeson
import Data.JSON.Fields
import qualified Data.Map as Map
import Data.Semigroup.App
import Data.Semigroup.Foldable
import qualified Data.Text as T
import Diffing.Algorithm
import Proto3.Suite.Class
@ -60,7 +64,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
@ -89,7 +93,7 @@ instance Ord1 Import where liftCompare = genericLiftCompare
instance Show1 Import where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Import where
eval (Import importPath _) = do
eval _ (Import importPath _) = do
paths <- resolveGoImport importPath
for_ paths $ \path -> do
traceResolve (unPath importPath) path
@ -109,9 +113,9 @@ instance Ord1 QualifiedImport where liftCompare = genericLiftCompare
instance Show1 QualifiedImport where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable QualifiedImport where
eval (QualifiedImport importPath aliasTerm) = do
eval _ (QualifiedImport importPath aliasTerm) = do
paths <- resolveGoImport importPath
alias <- maybeM (throwEvalError NoNameError) (declaredName (subterm aliasTerm))
alias <- maybeM (throwEvalError NoNameError) (declaredName aliasTerm)
void . letrec' alias $ \addr -> do
makeNamespace alias addr Nothing . for_ paths $ \p -> do
traceResolve (unPath importPath) p
@ -128,7 +132,7 @@ instance Ord1 SideEffectImport where liftCompare = genericLiftCompare
instance Show1 SideEffectImport where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable SideEffectImport where
eval (SideEffectImport importPath _) = do
eval _ (SideEffectImport importPath _) = do
paths <- resolveGoImport importPath
traceResolve (unPath importPath) paths
for_ paths require
@ -297,7 +301,11 @@ instance Ord1 Package where liftCompare = genericLiftCompare
instance Show1 Package where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Package where
eval (Package _ xs) = eval xs
eval eval (Package _ xs) = do
currentScope' <- currentScope
let edges = maybe mempty (Map.singleton Lexical . pure) currentScope'
scope <- newScope edges
withScope scope $ maybe (rvalBox unit) (runApp . foldMap1 (App . eval)) (nonEmpty xs)
-- | A type assertion in Go (e.g. `x.(T)` where the value of `x` is not nil and is of type `T`).

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

@ -3,7 +3,7 @@
module Language.PHP.Syntax where
import Data.Abstract.BaseError
import Data.Abstract.Evaluatable
import Data.Abstract.Evaluatable as Abstract
import Data.Abstract.Module
import Data.Abstract.Path
import Data.JSON.Fields
@ -44,14 +44,14 @@ 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
where name = toName n
toName = T.unpack . dropRelativePrefix . stripQuotes
include :: ( AbstractValue address value effects
include :: ( AbstractValue term address value effects
, Member (Deref value) effects
, Member (Env address) effects
, Member (Modules address) effects
@ -64,11 +64,12 @@ 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)
include pathTerm f = do
name <- subtermValue pathTerm >>= asString
=> (term -> Evaluator term address value effects (ValueRef address))
-> term
-> (ModulePath -> Evaluator term address value effects (ModuleResult address))
-> Evaluator term address value effects (ValueRef address)
include eval pathTerm f = do
name <- eval pathTerm >>= Abstract.value >>= asString
path <- resolvePHPName name
traceResolve name path
(_, (importedEnv, v)) <- f path
@ -83,7 +84,7 @@ instance Ord1 Require where liftCompare = genericLiftCompare
instance Show1 Require where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Require where
eval (Require path) = include path load
eval eval (Require path) = include eval path load
newtype RequireOnce a = RequireOnce { value :: a }
@ -94,7 +95,7 @@ instance Ord1 RequireOnce where liftCompare = genericLiftCompare
instance Show1 RequireOnce where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable RequireOnce where
eval (RequireOnce path) = include path require
eval eval (RequireOnce path) = include eval path require
newtype Include a = Include { value :: a }
@ -105,7 +106,7 @@ instance Ord1 Include where liftCompare = genericLiftCompare
instance Show1 Include where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Include where
eval (Include path) = include path load
eval eval (Include path) = include eval path load
newtype IncludeOnce a = IncludeOnce { value :: a }
@ -116,7 +117,7 @@ instance Ord1 IncludeOnce where liftCompare = genericLiftCompare
instance Show1 IncludeOnce where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable IncludeOnce where
eval (IncludeOnce path) = include path require
eval eval (IncludeOnce path) = include eval path require
newtype ArrayElement a = ArrayElement { value :: a }
@ -210,9 +211,9 @@ instance Ord1 QualifiedName where liftCompare = genericLiftCompare
instance Show1 QualifiedName where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable QualifiedName where
eval (QualifiedName name iden) = do
namePtr <- subtermAddress name
Rval <$> evaluateInScopedEnv namePtr (subtermAddress iden)
eval eval (QualifiedName name iden) = do
namePtr <- eval name >>= address
Rval <$> evaluateInScopedEnv namePtr (eval iden >>= address)
newtype NamespaceName a = NamespaceName { names :: NonEmpty a }
deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Diffable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1)
@ -223,7 +224,7 @@ instance Ord1 NamespaceName where liftCompare = genericLiftCompare
instance Show1 NamespaceName where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable NamespaceName where
eval (NamespaceName xs) = Rval <$> foldl1 f (fmap subtermAddress xs)
eval eval (NamespaceName xs) = Rval <$> foldl1 f (fmap (eval >=> address) xs)
where f ns id = ns >>= flip evaluateInScopedEnv id
newtype ConstDeclaration a = ConstDeclaration { values :: [a] }
@ -379,7 +380,7 @@ instance Ord1 Namespace where liftCompare = genericLiftCompare
instance Show1 Namespace where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Namespace where
eval Namespace{..} = Rval <$> go (declaredName . subterm <$> namespaceName)
eval eval Namespace{..} = Rval <$> go (declaredName <$> namespaceName)
where
-- Each namespace name creates a closure over the subsequent namespace closures
go (n:x:xs) = do
@ -390,9 +391,9 @@ instance Evaluatable Namespace where
go [n] = do
name <- maybeM (throwEvalError NoNameError) n
letrec' name $ \addr ->
box =<< makeNamespace name addr Nothing (void $ subtermAddress namespaceBody)
box =<< makeNamespace name addr Nothing (void $ eval namespaceBody)
-- The absence of names implies global scope, cf http://php.net/manual/en/language.namespaces.definitionmultiple.php
go [] = subtermAddress namespaceBody
go [] = eval namespaceBody >>= address
data TraitDeclaration a = TraitDeclaration { traitName :: a, traitStatements :: [a] }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1)

16
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
@ -129,7 +129,7 @@ toTuple Alias{..} = (aliasValue, aliasName)
instance Evaluatable Import where
-- from . import moduleY
-- This is a bit of a special case in the syntax as this actually behaves like a qualified relative import.
eval (Import (RelativeQualifiedName n Nothing) [Alias{..}]) = do
eval _ (Import (RelativeQualifiedName n Nothing) [Alias{..}]) = do
path <- NonEmpty.last <$> resolvePythonModules (RelativeQualifiedName n (Just (qualifiedName (formatName aliasValue :| []))))
rvalBox =<< evalQualifiedImport aliasValue path
@ -137,7 +137,7 @@ instance Evaluatable Import where
-- from a import b as c
-- from a import *
-- from .moduleY import b
eval (Import name xs) = do
eval _ (Import name xs) = do
modulePaths <- resolvePythonModules name
-- Eval parent modules first
@ -155,7 +155,7 @@ instance Evaluatable Import where
-- Evaluate a qualified import
evalQualifiedImport :: ( AbstractValue address value effects
evalQualifiedImport :: ( AbstractValue term address value effects
, Member (Allocator address) effects
, Member (Deref value) effects
, Member (Env address) effects
@ -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)
@ -188,7 +188,7 @@ instance Show1 QualifiedImport where liftShowsPrec = genericLiftShowsPrec
-- import a.b.c
instance Evaluatable QualifiedImport where
eval (QualifiedImport qualifiedName) = do
eval _ (QualifiedImport qualifiedName) = do
modulePaths <- resolvePythonModules (QualifiedName qualifiedName)
rvalBox =<< go (NonEmpty.zip (name . T.pack <$> qualifiedName) modulePaths)
where
@ -208,14 +208,14 @@ instance Show1 QualifiedAliasedImport where liftShowsPrec = genericLiftShowsPrec
-- import a.b.c as e
instance Evaluatable QualifiedAliasedImport where
eval (QualifiedAliasedImport name aliasTerm) = do
eval _ (QualifiedAliasedImport name aliasTerm) = do
modulePaths <- resolvePythonModules name
-- Evaluate each parent module
for_ (NonEmpty.init modulePaths) require
-- Evaluate and import the last module, aliasing and updating the environment
alias <- maybeM (throwEvalError NoNameError) (declaredName (subterm aliasTerm))
alias <- maybeM (throwEvalError NoNameError) (declaredName aliasTerm)
rvalBox =<< letrec' alias (\addr -> do
let path = NonEmpty.last modulePaths
unit <$ makeNamespace alias addr Nothing (void (bindAll . fst . snd =<< require path)))

48
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']
@ -59,13 +59,13 @@ instance Ord1 Send where liftCompare = genericLiftCompare
instance Show1 Send where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Send where
eval Send{..} = do
eval eval Send{..} = do
let sel = case sendSelector of
Just sel -> subtermAddress sel
Just sel -> eval sel >>= address
Nothing -> variable (name "call")
recv <- maybe (self >>= maybeM (box unit)) subtermAddress sendReceiver
recv <- maybe (self >>= maybeM (box unit)) (eval >=> address) sendReceiver
func <- deref =<< evaluateInScopedEnv recv sel
args <- traverse subtermAddress sendArgs
args <- traverse (eval >=> address) sendArgs
Rval <$> call func recv args -- TODO pass through sendBlock
instance Tokenize Send where
@ -83,8 +83,8 @@ instance Ord1 Require where liftCompare = genericLiftCompare
instance Show1 Require where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Require where
eval (Require _ x) = do
name <- subtermValue x >>= asString
eval eval (Require _ x) = do
name <- eval x >>= value >>= asString
path <- resolveRubyName name
traceResolve name path
(importedEnv, v) <- doRequire path
@ -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
@ -111,12 +111,12 @@ instance Ord1 Load where liftCompare = genericLiftCompare
instance Show1 Load where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Load where
eval (Load x Nothing) = do
path <- subtermValue x >>= asString
eval eval (Load x Nothing) = do
path <- eval x >>= value >>= asString
rvalBox =<< doLoad path False
eval (Load x (Just wrap)) = do
path <- subtermValue x >>= asString
shouldWrap <- subtermValue wrap >>= asBool
eval eval (Load x (Just wrap)) = do
path <- eval x >>= value >>= asString
shouldWrap <- eval wrap >>= value >>= asBool
rvalBox =<< doLoad path shouldWrap
doLoad :: ( Member (Boolean value) effects
@ -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'
@ -150,11 +150,11 @@ instance Ord1 Class where liftCompare = genericLiftCompare
instance Show1 Class where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Class where
eval Class{..} = do
super <- traverse subtermAddress classSuperClass
name <- maybeM (throwEvalError NoNameError) (declaredName (subterm classIdentifier))
eval eval Class{..} = do
super <- traverse (eval >=> address) classSuperClass
name <- maybeM (throwEvalError NoNameError) (declaredName classIdentifier)
rvalBox =<< letrec' name (\addr ->
makeNamespace name addr super (void (subtermAddress classBody)))
makeNamespace name addr super (void (eval classBody)))
data Module a = Module { moduleIdentifier :: !a, moduleStatements :: ![a] }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1)
@ -164,17 +164,17 @@ instance Ord1 Module where liftCompare = genericLiftCompare
instance Show1 Module where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Module where
eval (Module iden xs) = do
name <- maybeM (throwEvalError NoNameError) (declaredName (subterm iden))
eval eval (Module iden xs) = do
name <- maybeM (throwEvalError NoNameError) (declaredName iden)
rvalBox =<< letrec' name (\addr ->
makeNamespace name addr Nothing (void (eval xs)))
makeNamespace name addr Nothing (traverse_ eval xs))
data LowPrecedenceAnd a = LowPrecedenceAnd { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1)
instance Evaluatable LowPrecedenceAnd where
-- N.B. we have to use Monad rather than Applicative/Traversable on 'And' and 'Or' so that we don't evaluate both operands
eval t = rvalBox =<< go (fmap subtermValue t) where
eval eval t = rvalBox =<< go (fmap (eval >=> value) t) where
go (LowPrecedenceAnd a b) = do
cond <- a
ifthenelse cond b (pure cond)
@ -188,7 +188,7 @@ data LowPrecedenceOr a = LowPrecedenceOr { lhs :: a, rhs :: a }
instance Evaluatable LowPrecedenceOr where
-- N.B. we have to use Monad rather than Applicative/Traversable on 'And' and 'Or' so that we don't evaluate both operands
eval t = rvalBox =<< go (fmap subtermValue t) where
eval eval t = rvalBox =<< go (fmap (eval >=> value) t) where
go (LowPrecedenceOr a b) = do
cond <- a
ifthenelse cond (pure cond) b

12
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
@ -163,7 +163,7 @@ typescriptExtensions = ["ts", "tsx", "d.ts"]
javascriptExtensions :: [String]
javascriptExtensions = ["js"]
evalRequire :: ( AbstractValue address value effects
evalRequire :: ( AbstractValue term address value effects
, Member (Allocator address) effects
, Member (Deref value) effects
, Member (Env address) effects
@ -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)

4
src/Language/TypeScript/Syntax/JavaScript.hs
View File

@ -19,9 +19,9 @@ instance Ord1 JavaScriptRequire where liftCompare = genericLiftCompare
instance Show1 JavaScriptRequire where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable JavaScriptRequire where
eval (JavaScriptRequire aliasTerm importPath) = do
eval _ (JavaScriptRequire aliasTerm importPath) = do
modulePath <- resolveWithNodejsStrategy importPath javascriptExtensions
alias <- maybeM (throwEvalError NoNameError) (declaredName (subterm aliasTerm))
alias <- maybeM (throwEvalError NoNameError) (declaredName aliasTerm)
rvalBox =<< evalRequire modulePath alias
data Debugger a = Debugger

44
src/Language/TypeScript/Syntax/TypeScript.hs
View File

@ -24,7 +24,7 @@ instance Show1 Import where liftShowsPrec = genericLiftShowsPrec
-- http://www.typescriptlang.org/docs/handbook/module-resolution.html
instance Evaluatable Import where
eval (Import symbols importPath) = do
eval _ (Import symbols importPath) = do
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
importedBinds <- fst . snd <$> require modulePath
bindAll (renamed importedBinds)
@ -42,9 +42,9 @@ instance Ord1 QualifiedAliasedImport where liftCompare = genericLiftCompare
instance Show1 QualifiedAliasedImport where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable QualifiedAliasedImport where
eval (QualifiedAliasedImport aliasTerm importPath) = do
eval _ (QualifiedAliasedImport aliasTerm importPath) = do
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
alias <- maybeM (throwEvalError NoNameError) (declaredName (subterm aliasTerm))
alias <- maybeM (throwEvalError NoNameError) (declaredName aliasTerm)
rvalBox =<< evalRequire modulePath alias
newtype SideEffectImport a = SideEffectImport { sideEffectImportFrom :: ImportPath }
@ -55,7 +55,7 @@ instance Ord1 SideEffectImport where liftCompare = genericLiftCompare
instance Show1 SideEffectImport where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable SideEffectImport where
eval (SideEffectImport importPath) = do
eval _ (SideEffectImport importPath) = do
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
void $ require modulePath
rvalBox unit
@ -70,7 +70,7 @@ instance Ord1 QualifiedExport where liftCompare = genericLiftCompare
instance Show1 QualifiedExport where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable QualifiedExport where
eval (QualifiedExport exportSymbols) = do
eval _ (QualifiedExport exportSymbols) = do
-- Insert the aliases with no addresses.
for_ exportSymbols $ \Alias{..} ->
export aliasValue aliasName Nothing
@ -91,7 +91,7 @@ instance Ord1 QualifiedExportFrom where liftCompare = genericLiftCompare
instance Show1 QualifiedExportFrom where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable QualifiedExportFrom where
eval (QualifiedExportFrom importPath exportSymbols) = do
eval _ (QualifiedExportFrom importPath exportSymbols) = do
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
importedBinds <- fst . snd <$> require modulePath
-- Look up addresses in importedEnv and insert the aliases with addresses into the exports.
@ -108,10 +108,10 @@ instance Ord1 DefaultExport where liftCompare = genericLiftCompare
instance Show1 DefaultExport where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable DefaultExport where
eval (DefaultExport term) = do
eval eval (DefaultExport term) = do
case declaredName term of
Just name -> do
addr <- subtermAddress term
addr <- eval term >>= address
export name name Nothing
bind name addr
Nothing -> throwEvalError DefaultExportError
@ -286,7 +286,7 @@ instance Ord1 TypeIdentifier where liftCompare = genericLiftCompare
instance Show1 TypeIdentifier where liftShowsPrec = genericLiftShowsPrec
-- TODO: TypeIdentifier shouldn't evaluate to an address in the heap?
instance Evaluatable TypeIdentifier where
eval TypeIdentifier{..} = do
eval _ TypeIdentifier{..} = do
-- Add a reference to the type identifier in the current scope.
reference (Reference (name contents)) (Declaration (name contents))
rvalBox unit
@ -339,7 +339,7 @@ instance Ord1 AmbientDeclaration where liftCompare = genericLiftCompare
instance Show1 AmbientDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable AmbientDeclaration where
eval (AmbientDeclaration body) = subtermRef body
eval eval (AmbientDeclaration body) = eval body
data EnumDeclaration a = EnumDeclaration { enumDeclarationIdentifier :: !a, enumDeclarationBody :: ![a] }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable)
@ -364,9 +364,9 @@ instance Ord1 ExtendsClause where liftCompare = genericLiftCompare
instance Show1 ExtendsClause where liftShowsPrec = genericLiftShowsPrec
-- TODO: ExtendsClause shouldn't evaluate to an address in the heap?
instance Evaluatable ExtendsClause where
eval ExtendsClause{..} = do
eval eval ExtendsClause{..} = do
-- Evaluate subterms
traverse_ subtermRef extendsClauses
traverse_ eval extendsClauses
rvalBox unit
newtype ArrayType a = ArrayType { arrayType :: a }
@ -506,10 +506,10 @@ instance Ord1 Module where liftCompare = genericLiftCompare
instance Show1 Module where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Module where
eval (Module iden xs) = do
name <- maybeM (throwEvalError NoNameError) (declaredName (subterm iden))
eval eval (Module iden xs) = do
name <- maybeM (throwEvalError NoNameError) (declaredName iden)
rvalBox =<< letrec' name (\addr ->
makeNamespace name addr Nothing (void (eval xs)))
makeNamespace name addr Nothing (traverse_ eval xs))
data InternalModule a = InternalModule { internalModuleIdentifier :: !a, internalModuleStatements :: ![a] }
@ -520,10 +520,10 @@ instance Ord1 InternalModule where liftCompare = genericLiftCompare
instance Show1 InternalModule where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable InternalModule where
eval (InternalModule iden xs) = do
name <- maybeM (throwEvalError NoNameError) (declaredName (subterm iden))
eval eval (InternalModule iden xs) = do
name <- maybeM (throwEvalError NoNameError) (declaredName iden)
rvalBox =<< letrec' name (\addr ->
makeNamespace name addr Nothing (void (eval xs)))
makeNamespace name addr Nothing (traverse_ eval xs))
instance Declarations a => Declarations (InternalModule a) where
declaredName InternalModule{..} = declaredName internalModuleIdentifier
@ -555,11 +555,11 @@ instance Declarations a => Declarations (AbstractClass a) where
declaredName AbstractClass{..} = declaredName abstractClassIdentifier
instance Evaluatable AbstractClass where
eval AbstractClass{..} = do
name <- maybeM (throwEvalError NoNameError) (declaredName (subterm abstractClassIdentifier))
supers <- traverse subtermAddress classHeritage
eval eval AbstractClass{..} = do
name <- maybeM (throwEvalError NoNameError) (declaredName abstractClassIdentifier)
supers <- traverse (eval >=> address) classHeritage
(v, addr) <- letrec name $ do
void $ subtermValue classBody
void $ eval classBody
classBinds <- Env.head <$> getEnv
klass name supers classBinds
rvalBox =<< (v <$ bind name addr)

144
src/Semantic/Graph.hs
View File

@ -8,8 +8,8 @@ module Semantic.Graph
, GraphType(..)
, Graph
, ControlFlowVertex
, ConcreteEff(..)
, style
, runHeap
, parsePackage
, parsePythonPackage
, withTermSpans
@ -45,7 +45,6 @@ import Data.Abstract.Value.Concrete as Concrete
(Value, ValueError (..), runWhile, runBoolean, runFunction, runValueErrorWith)
import Data.Abstract.Value.Type as Type
import Data.Blob
import Data.Coerce
import Data.Graph
import Data.Graph.ControlFlowVertex (VertexDeclarationStrategy, VertexDeclarationWithStrategy)
import Data.Language as Language
@ -106,9 +105,8 @@ 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
. runState (lowerBound @(Heap (Hole (Maybe Name) (Located Monovariant)) Abstract))
= graphing @_ @_ @(Maybe Name) @Monovariant
. runHeap
. caching
. runFresh 0
. resumingLoadError
@ -123,11 +121,11 @@ 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)
extractGraph <$> runEvaluator (runGraphAnalysis (evaluate lang analyzeModule analyzeTerm runAddressEffects (Abstract.runBoolean . Abstract.runWhile . Abstract.runFunction) modules))
extractGraph <$> runEvaluator (runGraphAnalysis (evaluate lang analyzeModule analyzeTerm runAddressEffects (fmap (Abstract.runBoolean . Abstract.runWhile) . Abstract.runFunction) modules))
runImportGraphToModuleInfos :: ( Declarations term
, Evaluatable (Base term)
@ -137,6 +135,7 @@ runImportGraphToModuleInfos :: ( Declarations term
, Member Trace effs
, Recursive term
, Effects effs
, Show term
)
=> Proxy lang
-> Package term
@ -152,6 +151,7 @@ runImportGraphToModules :: ( Declarations term
, Member Trace effs
, Recursive term
, Effects effs
, Show term
)
=> Proxy lang
-> Package term
@ -167,6 +167,7 @@ runImportGraph :: ( Declarations term
, Member Trace effs
, Recursive term
, Effects effs
, Show term
)
=> Proxy lang
-> Package term
@ -177,7 +178,7 @@ runImportGraph lang (package :: Package term) f =
extractGraph (graph, _) = graph >>= f
runImportGraphAnalysis
= runState lowerBound
. runState lowerBound
. runHeap
. runFresh 0
. resumingLoadError
. resumingUnspecialized
@ -186,40 +187,19 @@ runImportGraph lang (package :: Package term) f =
. resumingResolutionError
. resumingAddressError
. resumingValueError
. runReader lowerBound
. runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult (Hole (Maybe Name) Precise))))))
. runModules (ModuleTable.modulePaths (packageModules package))
. runTermEvaluator @_ @_ @(Value (Hole (Maybe Name) Precise) (ConcreteEff (Hole (Maybe Name) Precise) _))
. runReader (packageInfo package)
. runState lowerBound
. runReader lowerBound
. runState (lowerBound @Span)
. runReader (lowerBound @Span)
runAddressEffects
= Hole.runAllocator Precise.handleAllocator
. Hole.runDeref Precise.handleDeref
in extractGraph <$> runEvaluator (runImportGraphAnalysis (evaluate lang analyzeModule id runAddressEffects (Concrete.runBoolean . Concrete.runWhile . Concrete.runFunction coerce coerce) (ModuleTable.toPairs (packageModules package) >>= toList . snd)))
in extractGraph <$> runEvaluator @_ @_ @(Value _ (Hole (Maybe Name) Precise)) (runImportGraphAnalysis (evaluate lang analyzeModule id runAddressEffects (fmap (Concrete.runBoolean . Concrete.runWhile) . Concrete.runFunction) (ModuleTable.toPairs (packageModules package) >>= toList . snd)))
type ConcreteEffects address rest
= Reader Span
': State Span
': Reader PackageInfo
': Modules address
': Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))
': Resumable (BaseError (ValueError address (ConcreteEff address rest)))
': Resumable (BaseError (AddressError address (Value address (ConcreteEff address rest))))
': Resumable (BaseError ResolutionError)
': Resumable (BaseError EvalError)
': Resumable (BaseError (EnvironmentError address))
': Resumable (BaseError (UnspecializedError (Value address (ConcreteEff address rest))))
': Resumable (BaseError (LoadError address))
': Fresh
': State (Heap address (Value address (ConcreteEff address rest)))
': rest
newtype ConcreteEff address outerEffects a = ConcreteEff
{ runConcreteEff :: Eff (ValueEffects address (Value address (ConcreteEff address outerEffects))
(ModuleEffects address (Value address (ConcreteEff address outerEffects))
(ConcreteEffects address outerEffects))) a
}
runHeap :: Effects effects => Evaluator term address value (State (Heap address value) ': effects) a -> Evaluator term address value effects (Heap address value, a)
runHeap = runState lowerBound
-- | Parse a list of files into a 'Package'.
parsePackage :: (Member Distribute effs, Member (Exc SomeException) effs, Member Resolution effs, Member Task effs, Member Trace effs)
@ -257,9 +237,9 @@ parsePythonPackage :: forall syntax effs term.
-> Project -- ^ Project to parse into a package.
-> Eff effs (Package term)
parsePythonPackage parser project = do
let runAnalysis = runEvaluator
let runAnalysis = runEvaluator @_ @_ @(Value term (Hole (Maybe Name) Precise))
. runState PythonPackage.Unknown
. runState lowerBound
. runState (lowerBound @(Heap (Hole (Maybe Name) Precise) (Value term (Hole (Maybe Name) Precise))))
. runFresh 0
. resumingLoadError
. resumingUnspecialized
@ -268,12 +248,11 @@ parsePythonPackage parser project = do
. resumingResolutionError
. resumingAddressError
. resumingValueError
. runReader lowerBound
. runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult (Hole (Maybe Name) Precise))))))
. runModules lowerBound
. runTermEvaluator @_ @_ @(Value (Hole (Maybe Name) Precise) (ConcreteEff (Hole (Maybe Name) Precise) _))
. runReader (PackageInfo (name "setup") lowerBound)
. runState lowerBound
. runReader lowerBound
. runState (lowerBound @Span)
. runReader (lowerBound @Span)
runAddressEffects
= Hole.runAllocator Precise.handleAllocator
. Hole.runDeref Precise.handleDeref
@ -281,7 +260,7 @@ parsePythonPackage parser project = do
strat <- case find ((== (projectRootDir project </> "setup.py")) . filePath) (projectFiles project) of
Just setupFile -> do
setupModule <- fmap snd <$> parseModule project parser setupFile
fst <$> runAnalysis (evaluate (Proxy @'Language.Python) id id runAddressEffects (Concrete.runBoolean . Concrete.runWhile . Concrete.runFunction coerce coerce . runPythonPackaging) [ setupModule ])
fst <$> runAnalysis (evaluate (Proxy @'Language.Python) id id runAddressEffects (\ eval -> Concrete.runBoolean . Concrete.runWhile . Concrete.runFunction eval . runPythonPackaging) [ setupModule ])
Nothing -> pure PythonPackage.Unknown
case strat of
PythonPackage.Unknown -> do
@ -322,44 +301,40 @@ parseModule proj parser file = do
withTermSpans :: ( Member (Reader Span) effects
, Member (State Span) effects -- last evaluated child's span
, Recursive term
, Base term ~ TermF syntax Location
)
=> SubtermAlgebra (TermF syntax Location) term (TermEvaluator term address value effects a)
-> SubtermAlgebra (TermF syntax Location) term (TermEvaluator term address value effects a)
withTermSpans recur term = let
updatedSpanAlg = withCurrentSpan (locationSpan (termFAnnotation term)) (recur term)
in modifyChildSpan (locationSpan (termFAnnotation term)) updatedSpanAlg
=> Open (Open (term -> Evaluator term address value effects a))
withTermSpans recur0 recur term = let
span = locationSpan (termFAnnotation (project term))
updatedSpanAlg = withCurrentSpan span (recur0 recur term)
in modifyChildSpan span 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 ()
@ -368,37 +343,33 @@ 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
, Show term
)
=> m address (Value address body) (Resumable (BaseError (ValueError address body)) ': effects) a
-> m address (Value address body) effects a
=> Evaluator term address (Value term address) (Resumable (BaseError (ValueError term address)) ': effects) a
-> Evaluator term address (Value term address) effects a
resumingValueError = runValueErrorWith (\ baseError -> traceError "ValueError" baseError *> case baseErrorException baseError of
CallError val -> pure val
StringError val -> pure (pack (prettyShow val))
@ -415,22 +386,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)
@ -438,5 +406,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

22
src/Semantic/REPL.hs
View File

@ -14,7 +14,6 @@ import Data.Abstract.ModuleTable as ModuleTable
import Data.Abstract.Package
import Data.Abstract.Value.Concrete as Concrete
import Data.Blob (Blob(..))
import Data.Coerce
import Data.Error (showExcerpt)
import Data.Graph (topologicalSort)
import Data.Language as Language
@ -89,9 +88,9 @@ 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) _ _)
. runPrintingTrace
. runState lowerBound
. runHeap
. runFresh 0
. fmap reassociate
. runLoadError
@ -102,11 +101,11 @@ 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)
$ evaluate proxy id (withTermSpans . step (fmap (\ (x:|_) -> moduleBody x) <$> ModuleTable.toPairs (packageModules (fst <$> package)))) (Precise.runAllocator . Precise.runDeref) (Concrete.runBoolean . Concrete.runWhile . Concrete.runFunction coerce coerce) modules
$ evaluate proxy id (withTermSpans . step (fmap (\ (x:|_) -> moduleBody x) <$> ModuleTable.toPairs (packageModules (fst <$> package)))) (Precise.runAllocator . Precise.runDeref) (fmap (Concrete.runBoolean . Concrete.runWhile) . Concrete.runFunction) modules
-- TODO: REPL for typechecking/abstract semantics
-- TODO: drive the flow from within the REPL instead of from without
@ -129,15 +128,14 @@ 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)
step blobs recur term = do
-> Open (Open (term -> Evaluator term address value effects a))
step blobs recur0 recur term = do
break <- shouldBreak
if break then do
list
runCommands (recur term)
runCommands (recur0 recur term)
else
recur term
recur0 recur term
where list = do
path <- asks modulePath
span <- ask
@ -152,7 +150,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 +188,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 Location) (Term f Location) field -> Term f Location -> Task m (Term f field)
Diff :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => These (Term syntax ann) (Term syntax ann) -> Task m (Diff syntax ann ann)
Render :: Renderer input output -> input -> Task m output

27
src/Semantic/Util.hs
View File

@ -2,12 +2,11 @@
{-# 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.Exception (displayException)
import Control.Monad.Effect.Trace (runPrintingTrace)
import Data.Abstract.Address.Monovariant as Monovariant
@ -19,7 +18,6 @@ import Data.Abstract.Package
import Data.Abstract.Value.Concrete as Concrete
import Data.Abstract.Value.Type as Type
import Data.Blob
import Data.Coerce
import Data.Graph (topologicalSort)
import qualified Data.Language as Language
import Data.List (uncons)
@ -42,7 +40,7 @@ import Text.Show.Pretty (ppShow)
justEvaluating
= runM
. runPrintingTrace
. runState lowerBound
. runHeap
. runFresh 0
. fmap reassociate
. runLoadError
@ -58,7 +56,6 @@ checking
. runPrintingTrace
. runState (lowerBound @(Heap Monovariant Type))
. runFresh 0
. runTermEvaluator @_ @Monovariant @Type
. caching
. providingLiveSet
. fmap reassociate
@ -87,7 +84,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,26 +99,26 @@ 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) _ _)
(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)
(evaluate proxy id withTermSpans (Precise.runAllocator . Precise.runDeref) (Concrete.runBoolean . Concrete.runWhile . Concrete.runFunction coerce coerce) modules)))))))
(evaluate proxy id withTermSpans (Precise.runAllocator . Precise.runDeref) (fmap (Concrete.runBoolean . Concrete.runWhile) . Concrete.runFunction) modules)))))))
evaluatePythonProjects proxy parser lang path = runTaskWithOptions debugOptions $ do
project <- readProject Nothing path lang []
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) _ _)
(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)
(evaluate proxy id withTermSpans (Precise.runAllocator . Precise.runDeref) (Concrete.runBoolean . Concrete.runWhile . Concrete.runFunction coerce coerce) modules)))))))
(evaluate proxy id withTermSpans (Precise.runAllocator . Precise.runDeref) (fmap (Concrete.runBoolean . Concrete.runWhile) . Concrete.runFunction) modules)))))))
evaluateProjectWithCaching proxy parser path = runTaskWithOptions debugOptions $ do
@ -132,8 +129,8 @@ 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)))
(evaluate proxy id withTermSpans (Monovariant.runAllocator . Monovariant.runDeref) (Type.runBoolean . Type.runWhile . Type.runFunction) modules))))))
(runModules (ModuleTable.modulePaths (packageModules package))
(evaluate proxy id withTermSpans (Monovariant.runAllocator . Monovariant.runDeref) (fmap (Type.runBoolean . Type.runWhile) . Type.runFunction) modules))))))
parseFile :: Parser term -> FilePath -> IO term
@ -151,3 +148,5 @@ reassociate = mergeExcs . mergeExcs . mergeExcs . mergeExcs . mergeExcs . mergeE
prettyShow :: Show a => a -> IO ()
prettyShow = putStrLn . hscolour TTY defaultColourPrefs False False "" False . ppShow
{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}

2
test/Analysis/Ruby/Spec.hs
View File

@ -97,7 +97,7 @@ spec config = parallel $ do
case ModuleTable.lookup "puts.rb" <$> res of
Right (Just (Module _ (_, (env, addr)) :| [])) -> do
heapLookupAll addr heap `shouldBe` Just [Unit]
traces `shouldContain` [ "\"hello\"" ]
traces `shouldContain` ["String \"\\\"hello\\\"\""]
other -> expectationFailure (show other)
where

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

@ -7,6 +7,7 @@ import Control.Abstract
import Data.Abstract.Address.Precise as Precise
import Data.Abstract.BaseError
import Data.Abstract.Environment
import Data.Abstract.FreeVariables
import Data.Abstract.Module
import qualified Data.Abstract.Number as Number
import Data.Abstract.Package
@ -26,7 +27,7 @@ spec = parallel $ do
it "calls functions" $ do
(_, expected) <- evaluate $ do
identity <- function Nothing [name "x"] lowerBound (variable (name "x"))
identity <- function Nothing [name "x"] (coerce (variable (name "x")))
recv <- box unit
addr <- box (integer 123)
call identity recv [addr]
@ -34,6 +35,7 @@ spec = parallel $ do
evaluate
= runM
. runIgnoringTrace
. runState (lowerBound @(Heap Precise Val))
. runFresh 0
. runReader (PackageInfo (name "test") mempty)
@ -43,21 +45,21 @@ evaluate
. runValueError
. runEnvironmentError
. runAddressError
. Precise.runDeref @_ @Val
. Precise.runDeref @_ @_ @Val
. Precise.runAllocator
. (>>= deref . snd)
. runEnv lowerBound
. runReturn
. runLoopControl
. Value.runBoolean
. Value.runFunction coerce coerce
. Value.runFunction coerce
reassociate :: Either (SomeExc exc1) (Either (SomeExc exc2) (Either (SomeExc exc3) result)) -> Either (SomeExc (Sum '[exc3, exc2, exc1])) result
reassociate = mergeExcs . mergeExcs . mergeExcs . Right
type Val = Value Precise SpecEff
newtype SpecEff a = SpecEff
{ runSpecEff :: Eff '[ Function Precise Val
type Val = Value SpecEff Precise
newtype SpecEff = SpecEff
{ runSpecEff :: Eff '[ Function SpecEff Precise Val
, Boolean Val
, Exc (LoopControl Precise)
, Exc (Return Precise)
@ -66,12 +68,17 @@ newtype SpecEff a = SpecEff
, Deref Val
, Resumable (BaseError (AddressError Precise Val))
, Resumable (BaseError (EnvironmentError Precise))
, Resumable (BaseError (ValueError Precise SpecEff))
, Resumable (BaseError (ValueError SpecEff Precise))
, Reader Span
, Reader ModuleInfo
, Reader PackageInfo
, Fresh
, State (Heap Precise Val)
, Trace
, Lift IO
] a
] Precise
}
instance Eq SpecEff where _ == _ = True
instance Show SpecEff where show _ = "_"
instance FreeVariables SpecEff where freeVariables _ = lowerBound

64
test/SpecHelpers.hs
View File

@ -10,7 +10,6 @@ module SpecHelpers
, deNamespace
, derefQName
, verbatim
, TermEvaluator(..)
, Verbatim(..)
, toList
, Config
@ -72,7 +71,6 @@ import qualified Data.ByteString as B
import qualified Data.Set as Set
import qualified Semantic.IO as IO
import Semantic.Config (Config)
import Semantic.Graph (ConcreteEff)
import Semantic.Telemetry (LogQueue, StatQueue)
import System.Exit (die)
import Control.Exception (displayException)
@ -97,31 +95,33 @@ readFilePair :: Both FilePath -> IO BlobPair
readFilePair paths = let paths' = fmap file paths in
runBothWith IO.readFilePair paths'
type TestEvaluatingEffects = '[ Resumable (BaseError (ValueError Precise (ConcreteEff Precise '[Trace, Lift IO])))
, Resumable (BaseError (AddressError Precise Val))
, Resumable (BaseError ResolutionError)
, Resumable (BaseError EvalError)
, Resumable (BaseError (EnvironmentError Precise))
, Resumable (BaseError (UnspecializedError Val))
, Resumable (BaseError (LoadError Precise))
, Fresh
, State (Heap Precise Val)
, Trace
, Lift IO
]
type TestEvaluatingErrors = '[ BaseError (ValueError Precise (ConcreteEff Precise '[Trace, Lift IO]))
, BaseError (AddressError Precise Val)
, BaseError ResolutionError
, BaseError EvalError
, BaseError (EnvironmentError Precise)
, BaseError (UnspecializedError Val)
, BaseError (LoadError Precise)
]
testEvaluating :: Evaluator Precise Val TestEvaluatingEffects (Span, a)
type TestEvaluatingEffects term
= '[ Resumable (BaseError (ValueError term Precise))
, Resumable (BaseError (AddressError Precise (Val term)))
, Resumable (BaseError ResolutionError)
, Resumable (BaseError EvalError)
, Resumable (BaseError (EnvironmentError Precise))
, Resumable (BaseError (UnspecializedError (Val term)))
, Resumable (BaseError (LoadError Precise))
, Fresh
, State (Heap Precise (Val term))
, Trace
, Lift IO
]
type TestEvaluatingErrors term
= '[ BaseError (ValueError term Precise)
, BaseError (AddressError Precise (Val term))
, BaseError ResolutionError
, BaseError EvalError
, BaseError (EnvironmentError Precise)
, BaseError (UnspecializedError (Val term))
, BaseError (LoadError Precise)
]
testEvaluating :: Evaluator term Precise (Val term) (TestEvaluatingEffects term) (Span, a)
-> IO
( [String]
, ( Heap Precise Val
, Either (SomeExc (Data.Sum.Sum TestEvaluatingErrors))
, ( Heap Precise (Val term)
, Either (SomeExc (Data.Sum.Sum (TestEvaluatingErrors term)))
a
)
)
@ -137,20 +137,20 @@ testEvaluating
. runEvalError
. runResolutionError
. runAddressError
. runValueError @_ @Precise @(ConcreteEff Precise _)
. runValueError @_ @_ @Precise
. fmap snd
type Val = Value Precise (ConcreteEff Precise '[Trace, Lift IO])
type Val term = Value term Precise
deNamespace :: Heap Precise (Value Precise term)
-> Value Precise term
deNamespace :: Heap Precise (Value term Precise)
-> Value term Precise
-> Maybe (Name, [Name])
deNamespace heap ns@(Namespace name _ _) = (,) name . Env.allNames <$> namespaceScope heap ns
deNamespace _ _ = Nothing
namespaceScope :: Heap Precise (Value Precise term)
-> Value Precise term
namespaceScope :: Heap Precise (Value term Precise)
-> Value term Precise
-> Maybe (Environment Precise)
namespaceScope heap ns@(Namespace _ _ _)
= either (const Nothing) (snd . snd)
@ -166,7 +166,7 @@ namespaceScope heap ns@(Namespace _ _ _)
namespaceScope _ _ = Nothing
derefQName :: Heap Precise (Value Precise term) -> NonEmpty Name -> Bindings Precise -> Maybe (Value Precise term)
derefQName :: Heap Precise (Value term Precise) -> NonEmpty Name -> Bindings Precise -> Maybe (Value term Precise)
derefQName heap names binds = go names (Env.newEnv binds)
where go (n1 :| ns) env = Env.lookupEnv' n1 env >>= flip heapLookup heap >>= fmap fst . Set.minView >>= case ns of
[] -> Just