github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-29 01:42:43 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into enhanced-json-output

Browse Source
This commit is contained in:
Timothy Clem 2018-05-30 11:14:39 -07:00 committed by GitHub
commit f7448522c8
34 changed files with 561 additions and 561 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
src/Analysis/Abstract/Caching.hs
View File

@ -13,60 +13,60 @@ import Data.Semilattice.Lower
import Prologue
-- | Look up the set of values for a given configuration in the in-cache.
consultOracle :: (Cacheable term location (Cell location) value, Member (Reader (Cache term location (Cell location) value)) effects)
=> Configuration term location (Cell location) value
-> TermEvaluator term location value effects (Set (Cached location (Cell location) value))
consultOracle :: (Cacheable term address (Cell address) value, Member (Reader (Cache term address (Cell address) value)) effects)
=> Configuration term address (Cell address) value
-> TermEvaluator term address value effects (Set (Cached address (Cell address) value))
consultOracle configuration = fromMaybe mempty . cacheLookup configuration <$> ask
-- | Run an action with the given in-cache.
withOracle :: Member (Reader (Cache term location (Cell location) value)) effects
=> Cache term location (Cell location) value
-> TermEvaluator term location value effects a
-> TermEvaluator term location value effects a
withOracle :: Member (Reader (Cache term address (Cell address) value)) effects
=> Cache term address (Cell address) value
-> TermEvaluator term address value effects a
-> TermEvaluator 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 location (Cell location) value, Member (State (Cache term location (Cell location) value)) effects)
=> Configuration term location (Cell location) value
-> TermEvaluator term location value effects (Maybe (Set (Cached location (Cell location) value)))
lookupCache :: (Cacheable term address (Cell address) value, Member (State (Cache term address (Cell address) value)) effects)
=> Configuration term address (Cell address) value
-> TermEvaluator term address value effects (Maybe (Set (Cached address (Cell address) value)))
lookupCache configuration = cacheLookup configuration <$> get
-- | Run an action, caching its result and 'Heap' under the given configuration.
cachingConfiguration :: (Cacheable term location (Cell location) value, Member (State (Cache term location (Cell location) value)) effects, Member (State (Heap location (Cell location) value)) effects)
=> Configuration term location (Cell location) value
-> Set (Cached location (Cell location) value)
-> TermEvaluator term location value effects (ValueRef value)
-> TermEvaluator term location value effects (ValueRef value)
cachingConfiguration :: (Cacheable term address (Cell address) value, Member (State (Cache term address (Cell address) value)) effects, Member (State (Heap address (Cell address) value)) effects)
=> Configuration term address (Cell address) value
-> Set (Cached address (Cell address) value)
-> TermEvaluator term address value effects (ValueRef value)
-> TermEvaluator term address value effects (ValueRef value)
cachingConfiguration configuration values action = do
modify' (cacheSet configuration values)
result <- Cached <$> action <*> TermEvaluator getHeap
cachedValue result <$ modify' (cacheInsert configuration result)
putCache :: Member (State (Cache term location (Cell location) value)) effects
=> Cache term location (Cell location) value
-> TermEvaluator term location value effects ()
putCache :: Member (State (Cache term address (Cell address) value)) effects
=> Cache term address (Cell address) value
-> TermEvaluator 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 location (Cell location) value)) effects
=> TermEvaluator term location value effects a
-> TermEvaluator term location value effects (Cache term location (Cell location) value)
isolateCache :: Member (State (Cache term address (Cell address) value)) effects
=> TermEvaluator term address value effects a
-> TermEvaluator term address value effects (Cache term address (Cell 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 location (Cell location) value
cachingTerms :: ( Cacheable term address (Cell address) value
, Corecursive term
, Member NonDet effects
, Member (Reader (Cache term location (Cell location) value)) effects
, Member (Reader (Live location)) effects
, Member (State (Cache term location (Cell location) value)) effects
, Member (State (Environment location)) effects
, Member (State (Heap location (Cell location) value)) effects
, Member (Reader (Cache term address (Cell address) value)) effects
, Member (Reader (Live address)) effects
, Member (State (Cache term address (Cell address) value)) effects
, Member (State (Environment address)) effects
, Member (State (Heap address (Cell address) value)) effects
)
=> SubtermAlgebra (Base term) term (TermEvaluator term location value effects (ValueRef value))
-> SubtermAlgebra (Base term) term (TermEvaluator term location value effects (ValueRef value))
=> SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef value))
-> SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef value))
cachingTerms recur term = do
c <- getConfiguration (embedSubterm term)
cached <- lookupCache c
@ -76,21 +76,21 @@ cachingTerms recur term = do
pairs <- consultOracle c
cachingConfiguration c pairs (recur term)
convergingModules :: ( AbstractValue location value effects
, Cacheable term location (Cell location) value
, Member (Allocator location value) effects
convergingModules :: ( AbstractValue address value effects
, Cacheable term address (Cell address) value
, Member (Allocator address value) effects
, Member Fresh effects
, Member NonDet effects
, Member (Reader (Cache term location (Cell location) value)) effects
, Member (Reader (Environment location)) effects
, Member (Reader (Live location)) effects
, Member (Resumable (EnvironmentError location)) effects
, Member (State (Cache term location (Cell location) value)) effects
, Member (State (Environment location)) effects
, Member (State (Heap location (Cell location) value)) effects
, Member (Reader (Cache term address (Cell address) value)) effects
, Member (Reader (Environment address)) effects
, Member (Reader (Live address)) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (State (Cache term address (Cell address) value)) effects
, Member (State (Environment address)) effects
, Member (State (Heap address (Cell address) value)) effects
)
=> SubtermAlgebra Module term (TermEvaluator term location value effects value)
-> SubtermAlgebra Module term (TermEvaluator term location value effects value)
=> SubtermAlgebra Module term (TermEvaluator term address value effects value)
-> SubtermAlgebra Module term (TermEvaluator term address value effects value)
convergingModules recur m = do
c <- getConfiguration (subterm (moduleBody m))
-- Convergence here is predicated upon an Eq instance, not α-equivalence
@ -124,11 +124,11 @@ 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 location (Cell location) value)) effects) => t (Cached location (Cell location) value) -> TermEvaluator term location value effects (ValueRef value)
scatter :: (Foldable t, Member NonDet effects, Member (State (Heap address (Cell address) value)) effects) => t (Cached address (Cell address) value) -> TermEvaluator term address value effects (ValueRef value)
scatter = foldMapA (\ (Cached value heap') -> TermEvaluator (putHeap heap') $> value)
caching :: Alternative f => TermEvaluator term location value (NonDet ': Reader (Cache term location (Cell location) value) ': State (Cache term location (Cell location) value) ': effects) a -> TermEvaluator term location value effects (f a, Cache term location (Cell location) value)
caching :: Alternative f => TermEvaluator term address value (NonDet ': Reader (Cache term address (Cell address) value) ': State (Cache term address (Cell address) value) ': effects) a -> TermEvaluator term address value effects (f a, Cache term address (Cell address) value)
caching
= runState lowerBound
. runReader lowerBound

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

@ -11,37 +11,37 @@ import Data.Semilattice.Lower
import Prologue
-- | An analysis performing GC after every instruction.
collectingTerms :: ( Foldable (Cell location)
, Member (Reader (Live location)) effects
, Member (State (Heap location (Cell location) value)) effects
, Ord location
, ValueRoots location value
collectingTerms :: ( Foldable (Cell address)
, Member (Reader (Live address)) effects
, Member (State (Heap address (Cell address) value)) effects
, Ord address
, ValueRoots address value
)
=> SubtermAlgebra (Base term) term (TermEvaluator term location value effects value)
-> SubtermAlgebra (Base term) term (TermEvaluator term location value effects value)
=> SubtermAlgebra (Base term) term (TermEvaluator term address value effects value)
-> SubtermAlgebra (Base term) term (TermEvaluator term address value effects value)
collectingTerms recur term = do
roots <- TermEvaluator askRoots
v <- recur term
v <$ TermEvaluator (modifyHeap (gc (roots <> valueRoots v)))
-- | Collect any addresses in the heap not rooted in or reachable from the given 'Live' set.
gc :: ( Ord location
, Foldable (Cell location)
, ValueRoots location value
gc :: ( Ord address
, Foldable (Cell address)
, ValueRoots address value
)
=> Live location -- ^ The set of addresses to consider rooted.
-> Heap location (Cell location) value -- ^ A heap to collect unreachable addresses within.
-> Heap location (Cell location) value -- ^ A garbage-collected heap.
=> Live address -- ^ The set of addresses to consider rooted.
-> Heap address (Cell address) value -- ^ A heap to collect unreachable addresses within.
-> Heap address (Cell address) value -- ^ A garbage-collected heap.
gc roots heap = heapRestrict heap (reachable roots heap)
-- | Compute the set of addresses reachable from a given root set in a given heap.
reachable :: ( Ord location
, Foldable (Cell location)
, ValueRoots location value
reachable :: ( Ord address
, Foldable (Cell address)
, ValueRoots address value
)
=> Live location -- ^ The set of root addresses.
-> Heap location (Cell location) value -- ^ The heap to trace addresses through.
-> Live location -- ^ The set of addresses reachable from the root set.
=> Live address -- ^ The set of root addresses.
-> Heap address (Cell address) value -- ^ The heap to trace addresses through.
-> Live address -- ^ The set of addresses reachable from the root set.
reachable roots heap = go mempty roots
where go seen set = case liveSplit set of
Nothing -> seen
@ -50,5 +50,5 @@ reachable roots heap = go mempty roots
_ -> seen)
providingLiveSet :: Effectful (m location value) => m location value (Reader (Live location) ': effects) a -> m location value effects a
providingLiveSet :: Effectful (m address value) => m address value (Reader (Live address) ': effects) a -> m address value effects a
providingLiveSet = runReader lowerBound

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

@ -20,11 +20,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 location value effects ()
killAll :: Member (State (Dead term)) effects => Dead term -> TermEvaluator 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 location value effects ()
revive :: (Member (State (Dead term)) effects, Ord term) => term -> TermEvaluator term address value effects ()
revive t = modify' (Dead . delete t . unDead)
-- | Compute the set of all subterms recursively.
@ -36,8 +36,8 @@ revivingTerms :: ( Corecursive term
, Member (State (Dead term)) effects
, Ord term
)
=> SubtermAlgebra (Base term) term (TermEvaluator term location value effects a)
-> SubtermAlgebra (Base term) term (TermEvaluator term location value effects a)
=> 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
killingModules :: ( Foldable (Base term)
@ -45,9 +45,9 @@ killingModules :: ( Foldable (Base term)
, Ord term
, Recursive term
)
=> SubtermAlgebra Module term (TermEvaluator term location value effects a)
-> SubtermAlgebra Module term (TermEvaluator term location value effects a)
=> 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
providingDeadSet :: TermEvaluator term location value (State (Dead term) ': effects) a -> TermEvaluator term location value effects (a, Dead term)
providingDeadSet :: TermEvaluator term address value (State (Dead term) ': effects) a -> TermEvaluator term address value effects (a, Dead term)
providingDeadSet = runState lowerBound

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

@ -8,34 +8,34 @@ import Control.Abstract
import Data.Semilattice.Lower
-- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@.
data EvaluatingState location value = EvaluatingState
{ environment :: Environment location
, heap :: Heap location (Cell location) value
, modules :: ModuleTable (Maybe (Environment location, value))
, exports :: Exports location
data EvaluatingState address value = EvaluatingState
{ environment :: Environment address
, heap :: Heap address (Cell address) value
, modules :: ModuleTable (Maybe (Environment address, value))
, exports :: Exports address
}
deriving instance (Eq (Cell location value), Eq location, Eq value) => Eq (EvaluatingState location value)
deriving instance (Ord (Cell location value), Ord location, Ord value) => Ord (EvaluatingState location value)
deriving instance (Show (Cell location value), Show location, Show value) => Show (EvaluatingState location value)
deriving instance (Eq (Cell address value), Eq address, Eq value) => Eq (EvaluatingState address value)
deriving instance (Ord (Cell address value), Ord address, Ord value) => Ord (EvaluatingState address value)
deriving instance (Show (Cell address value), Show address, Show value) => Show (EvaluatingState address value)
evaluating :: Evaluator location value
evaluating :: Evaluator address value
( Fail
': Fresh
': Reader (Environment location)
': State (Environment location)
': State (Heap location (Cell location) value)
': State (ModuleTable (Maybe (Environment location, value)))
': State (Exports location)
': Reader (Environment address)
': State (Environment address)
': State (Heap address (Cell address) value)
': State (ModuleTable (Maybe (Environment address, value)))
': State (Exports address)
': effects) result
-> Evaluator location value effects (Either String result, EvaluatingState location value)
-> Evaluator address value effects (Either String result, EvaluatingState address value)
evaluating
= fmap (\ ((((result, env), heap), modules), exports) -> (result, EvaluatingState env heap modules exports))
. runState lowerBound -- State (Exports location)
. runState lowerBound -- State (ModuleTable (Maybe (Environment location, value)))
. runState lowerBound -- State (Heap location (Cell location) value)
. runState lowerBound -- State (Environment location)
. runReader lowerBound -- Reader (Environment location)
. runState lowerBound -- State (Exports address)
. runState lowerBound -- State (ModuleTable (Maybe (Environment address, value)))
. runState lowerBound -- State (Heap address (Cell address) value)
. runState lowerBound -- State (Environment address)
. runReader lowerBound -- Reader (Environment address)
. runFresh 0
. runFail

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

@ -52,14 +52,14 @@ style = (defaultStyle (byteString . vertexName))
-- | Add vertices to the graph for evaluated identifiers.
graphingTerms :: ( Element Syntax.Identifier syntax
, Member (Reader (Environment (Hole (Located location)))) effects
, Member (Reader (Environment (Hole (Located address)))) effects
, Member (Reader ModuleInfo) effects
, Member (State (Environment (Hole (Located location)))) effects
, Member (State (Environment (Hole (Located address)))) effects
, Member (State (Graph Vertex)) effects
, term ~ Term (Sum syntax) ann
)
=> SubtermAlgebra (Base term) term (TermEvaluator term (Hole (Located location)) value effects a)
-> SubtermAlgebra (Base term) term (TermEvaluator term (Hole (Located location)) value effects a)
=> SubtermAlgebra (Base term) term (TermEvaluator term (Hole (Located address)) value effects a)
-> SubtermAlgebra (Base term) term (TermEvaluator term (Hole (Located address)) value effects a)
graphingTerms recur term@(In _ syntax) = do
case project syntax of
Just (Syntax.Identifier name) -> do
@ -71,19 +71,19 @@ graphingTerms recur term@(In _ syntax) = do
graphingPackages :: ( Member (Reader PackageInfo) effects
, Member (State (Graph Vertex)) effects
)
=> SubtermAlgebra Module term (TermEvaluator term location value effects a)
-> SubtermAlgebra Module term (TermEvaluator term location value effects a)
=> SubtermAlgebra Module term (TermEvaluator term address value effects a)
-> SubtermAlgebra Module term (TermEvaluator term address value effects a)
graphingPackages recur m = packageInclusion (moduleVertex (moduleInfo m)) *> recur m
-- | Add vertices to the graph for evaluated modules and the packages containing them.
graphingModules :: forall term location value effects a
. ( Member (Modules location value) effects
graphingModules :: forall term address value effects a
. ( Member (Modules address value) effects
, Member (Reader ModuleInfo) effects
, Member (State (Graph Vertex)) effects
)
=> SubtermAlgebra Module term (TermEvaluator term location value effects a)
-> SubtermAlgebra Module term (TermEvaluator term location value effects a)
graphingModules recur m = interpose @(Modules location value) pure (\ m yield -> case m of
=> SubtermAlgebra Module term (TermEvaluator term address value effects a)
-> SubtermAlgebra Module term (TermEvaluator term address value effects a)
graphingModules recur m = interpose @(Modules address value) pure (\ m yield -> case m of
Load path -> moduleInclusion (moduleVertex (ModuleInfo path)) >> send m >>= yield
Lookup path -> moduleInclusion (moduleVertex (ModuleInfo path)) >> send m >>= yield
_ -> send m >>= yield)
@ -121,14 +121,14 @@ moduleInclusion v = do
appendGraph (vertex (moduleVertex m) `connect` vertex v)
-- | Add an edge from the passed variable name to the module it originated within.
variableDefinition :: ( Member (Reader (Environment (Hole (Located location)))) effects
, Member (State (Environment (Hole (Located location)))) effects
variableDefinition :: ( Member (Reader (Environment (Hole (Located address)))) effects
, Member (State (Environment (Hole (Located address)))) effects
, Member (State (Graph Vertex)) effects
)
=> Name
-> TermEvaluator term (Hole (Located location)) value effects ()
-> TermEvaluator term (Hole (Located address)) value effects ()
variableDefinition name = do
graph <- maybe lowerBound (maybe lowerBound (vertex . moduleVertex . locationModule) . toMaybe) <$> TermEvaluator (lookupEnv name)
graph <- maybe lowerBound (maybe lowerBound (vertex . moduleVertex . addressModule) . toMaybe) <$> TermEvaluator (lookupEnv name)
appendGraph (vertex (Variable (unName name)) `connect` graph)
appendGraph :: (Effectful m, Member (State (Graph Vertex)) effects) => Graph Vertex -> m effects ()

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

@ -13,19 +13,19 @@ import Prologue
--
-- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis.
tracingTerms :: ( Corecursive term
, Member (Reader (Live location)) effects
, Member (State (Environment location)) effects
, Member (State (Heap location (Cell location) value)) effects
, Member (Writer (trace (Configuration term location (Cell location) value))) effects
, Reducer (Configuration term location (Cell location) value) (trace (Configuration term location (Cell location) value))
, Member (Reader (Live address)) effects
, Member (State (Environment address)) effects
, Member (State (Heap address (Cell address) value)) effects
, Member (Writer (trace (Configuration term address (Cell address) value))) effects
, Reducer (Configuration term address (Cell address) value) (trace (Configuration term address (Cell address) value))
)
=> trace (Configuration term location (Cell location) value)
-> SubtermAlgebra (Base term) term (TermEvaluator term location value effects a)
-> SubtermAlgebra (Base term) term (TermEvaluator term location value effects a)
=> trace (Configuration term address (Cell 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
trace :: Member (Writer (trace (Configuration term location (Cell location) value))) effects => trace (Configuration term location (Cell location) value) -> TermEvaluator term location value effects ()
trace :: Member (Writer (trace (Configuration term address (Cell address) value))) effects => trace (Configuration term address (Cell address) value) -> TermEvaluator term address value effects ()
trace = tell
tracing :: Monoid (trace (Configuration term location (Cell location) value)) => TermEvaluator term location value (Writer (trace (Configuration term location (Cell location) value)) ': effects) a -> TermEvaluator term location value effects (a, trace (Configuration term location (Cell location) value))
tracing :: Monoid (trace (Configuration term address (Cell address) value)) => TermEvaluator term address value (Writer (trace (Configuration term address (Cell address) value)) ': effects) a -> TermEvaluator term address value effects (a, trace (Configuration term address (Cell address) value))
tracing = runWriter

26
src/Control/Abstract/Addressable.hs
View File

@ -11,41 +11,41 @@ import Data.Abstract.Name
import Prologue
-- | Defines allocation and dereferencing of addresses.
class (Ord location, Show location) => Addressable location effects where
-- | The type into which stored values will be written for a given location type.
type family Cell location :: * -> *
class (Ord address, Show address) => Addressable address effects where
-- | The type into which stored values will be written for a given address type.
type family Cell address :: * -> *
allocCell :: Name -> Evaluator location value effects location
derefCell :: location -> Cell location value -> Evaluator location value effects (Maybe value)
allocCell :: Name -> Evaluator address value effects address
derefCell :: address -> Cell address value -> Evaluator address value effects (Maybe value)
-- | 'Precise' locations are always allocated a fresh address, and dereference to the 'Latest' value written.
-- | 'Precise' addresses are always allocated a fresh address, and dereference to the 'Latest' value written.
instance Member Fresh effects => Addressable Precise effects where
type Cell Precise = Latest
allocCell _ = Precise <$> fresh
derefCell _ = pure . getLast . unLatest
-- | 'Monovariant' locations allocate one address per unique variable name, and dereference once per stored value, nondeterministically.
-- | 'Monovariant' addresses allocate one address per unique variable name, and dereference once per stored value, nondeterministically.
instance Member NonDet effects => Addressable Monovariant effects where
type Cell Monovariant = All
allocCell = pure . Monovariant
derefCell _ = traverse (foldMapA pure) . nonEmpty . toList
-- | 'Located' locations allocate & dereference using the underlying location, contextualizing locations with the current 'PackageInfo' & 'ModuleInfo'.
instance (Addressable location effects, Member (Reader ModuleInfo) effects, Member (Reader PackageInfo) effects) => Addressable (Located location) effects where
type Cell (Located location) = Cell location
-- | 'Located' addresses allocate & dereference using the underlying address, contextualizing addresses with the current 'PackageInfo' & 'ModuleInfo'.
instance (Addressable address effects, Member (Reader ModuleInfo) effects, Member (Reader PackageInfo) effects) => Addressable (Located address) effects where
type Cell (Located address) = Cell address
allocCell name = relocate (Located <$> allocCell name <*> currentPackage <*> currentModule)
derefCell (Located loc _ _) = relocate . derefCell loc
instance Addressable location effects => Addressable (Hole location) effects where
type Cell (Hole location) = Cell location
instance Addressable address effects => Addressable (Hole address) effects where
type Cell (Hole address) = Cell address
allocCell name = relocate (Total <$> allocCell name)
derefCell (Total loc) = relocate . derefCell loc
derefCell Partial = const (pure Nothing)
relocate :: Evaluator location1 value effects a -> Evaluator location2 value effects a
relocate :: Evaluator address1 value effects a -> Evaluator address2 value effects a
relocate = raiseEff . lowerEff

2
src/Control/Abstract/Configuration.hs
View File

@ -12,5 +12,5 @@ import Control.Abstract.TermEvaluator
import Data.Abstract.Configuration
-- | Get the current 'Configuration' with a passed-in term.
getConfiguration :: (Member (Reader (Live location)) effects, Member (State (Environment location)) effects, Member (State (Heap location (Cell location) value)) effects) => term -> TermEvaluator term location value effects (Configuration term location (Cell location) value)
getConfiguration :: (Member (Reader (Live address)) effects, Member (State (Environment address)) effects, Member (State (Heap address (Cell address) value)) effects) => term -> TermEvaluator term address value effects (Configuration term address (Cell address) value)
getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEnv <*> TermEvaluator getHeap

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

@ -21,45 +21,45 @@ import Data.Abstract.Name
import Prologue
-- | Retrieve the environment.
getEnv :: Member (State (Environment location)) effects => Evaluator location value effects (Environment location)
getEnv :: Member (State (Environment address)) effects => Evaluator address value effects (Environment address)
getEnv = get
-- | Set the environment.
putEnv :: Member (State (Environment location)) effects => Environment location -> Evaluator location value effects ()
putEnv :: Member (State (Environment address)) effects => Environment address -> Evaluator address value effects ()
putEnv = put
-- | Update the global environment.
modifyEnv :: Member (State (Environment location)) effects => (Environment location -> Environment location) -> Evaluator location value effects ()
modifyEnv :: Member (State (Environment address)) effects => (Environment address -> Environment address) -> Evaluator address value effects ()
modifyEnv = modify'
-- | Sets the environment for the lifetime of the given action.
withEnv :: Member (State (Environment location)) effects => Environment location -> Evaluator location value effects a -> Evaluator location value effects a
withEnv :: Member (State (Environment address)) effects => Environment address -> Evaluator address value effects a -> Evaluator address value effects a
withEnv = localState . const
-- | Retrieve the default environment.
defaultEnvironment :: Member (Reader (Environment location)) effects => Evaluator location value effects (Environment location)
defaultEnvironment :: Member (Reader (Environment address)) effects => Evaluator address value effects (Environment address)
defaultEnvironment = ask
-- | Set the default environment for the lifetime of an action.
-- Usually only invoked in a top-level evaluation function.
withDefaultEnvironment :: Member (Reader (Environment location)) effects => Environment location -> Evaluator location value effects a -> Evaluator location value effects a
withDefaultEnvironment :: Member (Reader (Environment address)) effects => Environment address -> Evaluator address value effects a -> Evaluator address value effects a
withDefaultEnvironment e = local (const e)
-- | Look a 'Name' up in the current environment, trying the default environment if no value is found.
lookupEnv :: (Member (Reader (Environment location)) effects, Member (State (Environment location)) effects) => Name -> Evaluator location value effects (Maybe location)
lookupEnv :: (Member (Reader (Environment address)) effects, Member (State (Environment address)) effects) => Name -> Evaluator address value effects (Maybe address)
lookupEnv name = (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment)
-- | Bind a 'Name' to an 'Address' in the current scope.
bind :: Member (State (Environment location)) effects => Name -> location -> Evaluator location value effects ()
bind :: Member (State (Environment address)) effects => Name -> address -> Evaluator address value effects ()
bind name = modifyEnv . Env.insert name
-- | Bind all of the names from an 'Environment' in the current scope.
bindAll :: Member (State (Environment location)) effects => Environment location -> Evaluator location value effects ()
bindAll :: Member (State (Environment address)) effects => Environment address -> Evaluator address value effects ()
bindAll = foldr ((>>) . uncurry bind) (pure ()) . pairs
-- | Run an action in a new local environment.
locally :: Member (State (Environment location)) effects => Evaluator location value effects a -> Evaluator location value effects a
locally :: Member (State (Environment address)) effects => Evaluator address value effects a -> Evaluator address value effects a
locally a = do
modifyEnv Env.push
a' <- a
@ -67,19 +67,19 @@ locally a = do
-- | Errors involving the environment.
data EnvironmentError location return where
FreeVariable :: Name -> EnvironmentError location location
data EnvironmentError address return where
FreeVariable :: Name -> EnvironmentError address address
deriving instance Eq (EnvironmentError location return)
deriving instance Show (EnvironmentError location return)
instance Show1 (EnvironmentError location) where liftShowsPrec _ _ = showsPrec
instance Eq1 (EnvironmentError location) where liftEq _ (FreeVariable n1) (FreeVariable n2) = n1 == n2
deriving instance Eq (EnvironmentError address return)
deriving instance Show (EnvironmentError address return)
instance Show1 (EnvironmentError address) where liftShowsPrec _ _ = showsPrec
instance Eq1 (EnvironmentError address) where liftEq _ (FreeVariable n1) (FreeVariable n2) = n1 == n2
freeVariableError :: Member (Resumable (EnvironmentError location)) effects => Name -> Evaluator location value effects location
freeVariableError :: Member (Resumable (EnvironmentError address)) effects => Name -> Evaluator address value effects address
freeVariableError = throwResumable . FreeVariable
runEnvironmentError :: Effectful (m location value) => m location value (Resumable (EnvironmentError location) ': effects) a -> m location value effects (Either (SomeExc (EnvironmentError location)) a)
runEnvironmentError :: Effectful (m address value) => m address value (Resumable (EnvironmentError address) ': effects) a -> m address value effects (Either (SomeExc (EnvironmentError address)) a)
runEnvironmentError = runResumable
runEnvironmentErrorWith :: Effectful (m location value) => (forall resume . EnvironmentError location resume -> m location value effects resume) -> m location value (Resumable (EnvironmentError location) ': effects) a -> m location value effects a
runEnvironmentErrorWith :: Effectful (m address value) => (forall resume . EnvironmentError address resume -> m address value effects resume) -> m address value (Resumable (EnvironmentError address) ': effects) a -> m address value effects a
runEnvironmentErrorWith = runResumableWith

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

@ -24,15 +24,15 @@ import Control.Monad.Effect.State as X
import Control.Monad.Effect.Trace as X
import Prologue
-- | An 'Evaluator' is a thin wrapper around 'Eff' with (phantom) type parameters for the location, term, and value types.
-- | An 'Evaluator' is a thin wrapper around 'Eff' with (phantom) type parameters for the address, term, and value types.
--
-- 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 location value effects a = Evaluator { runEvaluator :: Eff effects a }
newtype Evaluator address value effects a = Evaluator { runEvaluator :: Eff effects a }
deriving (Applicative, Effectful, Functor, Monad)
deriving instance Member NonDet effects => Alternative (Evaluator location value effects)
deriving instance Member NonDet effects => Alternative (Evaluator address value effects)
-- Effects
@ -44,13 +44,13 @@ data Return value resume where
deriving instance Eq value => Eq (Return value a)
deriving instance Show value => Show (Return value a)
earlyReturn :: Member (Return value) effects => value -> Evaluator location value effects value
earlyReturn :: Member (Return value) effects => value -> Evaluator address value effects value
earlyReturn = send . Return
catchReturn :: Member (Return value) effects => Evaluator location value effects a -> (forall x . Return value x -> Evaluator location value effects a) -> Evaluator location value effects a
catchReturn :: Member (Return value) effects => Evaluator address value effects a -> (forall x . Return value x -> Evaluator address value effects a) -> Evaluator address value effects a
catchReturn action handler = interpose pure (\ ret _ -> handler ret) action
runReturn :: Effectful (m location value) => m location value (Return value ': effects) value -> m location value effects value
runReturn :: Effectful (m address value) => m address value (Return value ': effects) value -> m address value effects value
runReturn = raiseHandler (relay pure (\ (Return value) _ -> pure value))
@ -62,16 +62,16 @@ data LoopControl value resume where
deriving instance Eq value => Eq (LoopControl value a)
deriving instance Show value => Show (LoopControl value a)
throwBreak :: Member (LoopControl value) effects => value -> Evaluator location value effects value
throwBreak :: Member (LoopControl value) effects => value -> Evaluator address value effects value
throwBreak = send . Break
throwContinue :: Member (LoopControl value) effects => value -> Evaluator location value effects value
throwContinue :: Member (LoopControl value) effects => value -> Evaluator address value effects value
throwContinue = send . Continue
catchLoopControl :: Member (LoopControl value) effects => Evaluator location value effects a -> (forall x . LoopControl value x -> Evaluator location value effects a) -> Evaluator location value effects a
catchLoopControl :: Member (LoopControl value) effects => Evaluator address value effects a -> (forall x . LoopControl value x -> Evaluator address value effects a) -> Evaluator address value effects a
catchLoopControl action handler = interpose pure (\ control _ -> handler control) action
runLoopControl :: Effectful (m location value) => m location value (LoopControl value ': effects) value -> m location value effects value
runLoopControl :: Effectful (m address value) => m address value (LoopControl value ': effects) value -> m address value effects value
runLoopControl = raiseHandler (relay pure (\ eff _ -> case eff of
Break value -> pure value
Continue value -> pure value))

10
src/Control/Abstract/Exports.hs
View File

@ -12,21 +12,21 @@ import Data.Abstract.Exports
import Data.Abstract.Name
-- | Get the global export state.
getExports :: Member (State (Exports location)) effects => Evaluator location value effects (Exports location)
getExports :: Member (State (Exports address)) effects => Evaluator address value effects (Exports address)
getExports = get
-- | Set the global export state.
putExports :: Member (State (Exports location)) effects => Exports location -> Evaluator location value effects ()
putExports :: Member (State (Exports address)) effects => Exports address -> Evaluator address value effects ()
putExports = put
-- | Update the global export state.
modifyExports :: Member (State (Exports location)) effects => (Exports location -> Exports location) -> Evaluator location value effects ()
modifyExports :: Member (State (Exports address)) effects => (Exports address -> Exports address) -> Evaluator address value effects ()
modifyExports = modify'
-- | Add an export to the global export state.
addExport :: Member (State (Exports location)) effects => Name -> Name -> Maybe location -> Evaluator location value effects ()
addExport :: Member (State (Exports address)) effects => Name -> Name -> Maybe address -> Evaluator address value effects ()
addExport name alias = modifyExports . insert name alias
-- | Sets the global export state for the lifetime of the given action.
withExports :: Member (State (Exports location)) effects => Exports location -> Evaluator location value effects a -> Evaluator location value effects a
withExports :: Member (State (Exports address)) effects => Exports address -> Evaluator address value effects a -> Evaluator address value effects a
withExports = localState . const

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

@ -29,57 +29,57 @@ import Data.Semigroup.Reducer
import Prologue
-- | Retrieve the heap.
getHeap :: Member (State (Heap location (Cell location) value)) effects => Evaluator location value effects (Heap location (Cell location) value)
getHeap :: Member (State (Heap address (Cell address) value)) effects => Evaluator address value effects (Heap address (Cell address) value)
getHeap = get
-- | Set the heap.
putHeap :: Member (State (Heap location (Cell location) value)) effects => Heap location (Cell location) value -> Evaluator location value effects ()
putHeap :: Member (State (Heap address (Cell address) value)) effects => Heap address (Cell address) value -> Evaluator address value effects ()
putHeap = put
-- | Update the heap.
modifyHeap :: Member (State (Heap location (Cell location) value)) effects => (Heap location (Cell location) value -> Heap location (Cell location) value) -> Evaluator location value effects ()
modifyHeap :: Member (State (Heap address (Cell address) value)) effects => (Heap address (Cell address) value -> Heap address (Cell address) value) -> Evaluator address value effects ()
modifyHeap = modify'
alloc :: forall location value effects . Member (Allocator location value) effects => Name -> Evaluator location value effects location
alloc = send . Alloc @location @value
alloc :: forall address value effects . Member (Allocator address value) effects => Name -> Evaluator address value effects address
alloc = send . Alloc @address @value
-- | Dereference the given address in the heap, or fail if the address is uninitialized.
deref :: Member (Allocator location value) effects => location -> Evaluator location value effects value
deref :: Member (Allocator address value) effects => address -> Evaluator address value effects value
deref = send . Deref
-- | Write a value to the given address in the 'Store'.
assign :: ( Member (State (Heap location (Cell location) value)) effects
, Ord location
, Reducer value (Cell location value)
assign :: ( Member (State (Heap address (Cell address) value)) effects
, Ord address
, Reducer value (Cell address value)
)
=> location
=> address
-> value
-> Evaluator location value effects ()
-> Evaluator address value effects ()
assign address = modifyHeap . heapInsert address
-- | Look up or allocate an address for a 'Name'.
lookupOrAlloc :: ( Member (Allocator location value) effects
, Member (Reader (Environment location)) effects
, Member (State (Environment location)) effects
lookupOrAlloc :: ( Member (Allocator address value) effects
, Member (Reader (Environment address)) effects
, Member (State (Environment address)) effects
)
=> Name
-> Evaluator location value effects location
-> Evaluator address value effects address
lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure
letrec :: ( Member (Allocator location value) effects
, Member (Reader (Environment location)) effects
, Member (State (Environment location)) effects
, Member (State (Heap location (Cell location) value)) effects
, Ord location
, Reducer value (Cell location value)
letrec :: ( Member (Allocator address value) effects
, Member (Reader (Environment address)) effects
, Member (State (Environment address)) effects
, Member (State (Heap address (Cell address) value)) effects
, Ord address
, Reducer value (Cell address value)
)
=> Name
-> Evaluator location value effects value
-> Evaluator location value effects (value, location)
-> Evaluator address value effects value
-> Evaluator address value effects (value, address)
letrec name body = do
addr <- lookupOrAlloc name
v <- locally (bind name addr *> body)
@ -87,13 +87,13 @@ letrec name body = do
pure (v, addr)
-- Lookup/alloc a name passing the address to a body evaluated in a new local environment.
letrec' :: ( Member (Allocator location value) effects
, Member (Reader (Environment location)) effects
, Member (State (Environment location)) effects
letrec' :: ( Member (Allocator address value) effects
, Member (Reader (Environment address)) effects
, Member (State (Environment address)) effects
)
=> Name
-> (location -> Evaluator location value effects value)
-> Evaluator location value effects value
-> (address -> Evaluator address value effects value)
-> Evaluator address value effects value
letrec' name body = do
addr <- lookupOrAlloc name
v <- locally (body addr)
@ -101,44 +101,44 @@ letrec' name body = do
-- | Look up and dereference the given 'Name', throwing an exception for free variables.
variable :: ( Member (Allocator location value) effects
, Member (Reader (Environment location)) effects
, Member (Resumable (EnvironmentError location)) effects
, Member (State (Environment location)) effects
variable :: ( Member (Allocator address value) effects
, Member (Reader (Environment address)) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (State (Environment address)) effects
)
=> Name
-> Evaluator location value effects value
-> Evaluator address value effects value
variable name = lookupEnv name >>= maybeM (freeVariableError name) >>= deref
-- Effects
data Allocator location value return where
Alloc :: Name -> Allocator location value location
Deref :: location -> Allocator location value value
data Allocator address value return where
Alloc :: Name -> Allocator address value address
Deref :: address -> Allocator address value value
runAllocator :: (Addressable location effects, Effectful (m location value), Member (Resumable (AddressError location value)) effects, Member (State (Heap location (Cell location) value)) effects) => m location value (Allocator location value ': effects) a -> m location value effects a
runAllocator :: (Addressable address effects, Effectful (m address value), Member (Resumable (AddressError address value)) effects, Member (State (Heap address (Cell address) value)) effects) => m address value (Allocator address value ': effects) a -> m address value effects a
runAllocator = raiseHandler (interpret (\ eff -> case eff of
Alloc name -> lowerEff $ allocCell name
Deref addr -> lowerEff $ heapLookup addr <$> get >>= maybeM (throwResumable (UnallocatedAddress addr)) >>= derefCell addr >>= maybeM (throwResumable (UninitializedAddress addr))))
data AddressError location value resume where
UnallocatedAddress :: location -> AddressError location value (Cell location value)
UninitializedAddress :: location -> AddressError location value value
data AddressError address value resume where
UnallocatedAddress :: address -> AddressError address value (Cell address value)
UninitializedAddress :: address -> AddressError address value value
deriving instance Eq location => Eq (AddressError location value resume)
deriving instance Show location => Show (AddressError location value resume)
instance Show location => Show1 (AddressError location value) where
deriving instance Eq address => Eq (AddressError address value resume)
deriving instance Show address => Show (AddressError address value resume)
instance Show address => Show1 (AddressError address value) where
liftShowsPrec _ _ = showsPrec
instance Eq location => Eq1 (AddressError location value) where
instance Eq address => Eq1 (AddressError address value) where
liftEq _ (UninitializedAddress a) (UninitializedAddress b) = a == b
liftEq _ (UnallocatedAddress a) (UnallocatedAddress b) = a == b
liftEq _ _ _ = False
runAddressError :: Effectful (m location value) => m location value (Resumable (AddressError location value) ': effects) a -> m location value effects (Either (SomeExc (AddressError location value)) a)
runAddressError :: Effectful (m address value) => m address value (Resumable (AddressError address value) ': effects) a -> m address value effects (Either (SomeExc (AddressError address value)) a)
runAddressError = runResumable
runAddressErrorWith :: Effectful (m location value) => (forall resume . AddressError location value resume -> m location value effects resume) -> m location value (Resumable (AddressError location value) ': effects) a -> m location value effects a
runAddressErrorWith :: Effectful (m address value) => (forall resume . AddressError address value resume -> m address value effects resume) -> m address value (Resumable (AddressError address value) ': effects) a -> m address value effects a
runAddressErrorWith = runResumableWith

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

@ -26,49 +26,49 @@ import Data.Language
import Prologue
-- | Retrieve an evaluated module, if any. The outer 'Maybe' indicates whether we’ve begun loading the module or not, while the inner 'Maybe' indicates whether we’ve completed loading it or not. Thus, @Nothing@ means we’ve never tried to load it, @Just Nothing@ means we’ve started but haven’t yet finished loading it, and @Just (Just (env, value))@ indicates the result of a completed load.
lookupModule :: Member (Modules location value) effects => ModulePath -> Evaluator location value effects (Maybe (Maybe (Environment location, value)))
lookupModule :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (Maybe (Environment address, value)))
lookupModule = send . Lookup
-- | Resolve a list of module paths to a possible module table entry.
resolve :: Member (Modules location value) effects => [FilePath] -> Evaluator location value effects (Maybe ModulePath)
resolve :: Member (Modules address value) effects => [FilePath] -> Evaluator address value effects (Maybe ModulePath)
resolve = sendModules . Resolve
listModulesInDir :: Member (Modules location value) effects => FilePath -> Evaluator location value effects [ModulePath]
listModulesInDir :: Member (Modules address value) effects => FilePath -> Evaluator 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 location value) effects => ModulePath -> Evaluator location value effects (Maybe (Environment location, value))
require :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (Environment address, value))
require path = lookupModule path >>= maybeM (load path)
-- | Load another module by name and return its environment and value.
--
-- Always loads/evaluates.
load :: Member (Modules location value) effects => ModulePath -> Evaluator location value effects (Maybe (Environment location, value))
load :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (Environment address, value))
load = send . Load
data Modules location value return where
Load :: ModulePath -> Modules location value (Maybe (Environment location, value))
Lookup :: ModulePath -> Modules location value (Maybe (Maybe (Environment location, value)))
Resolve :: [FilePath] -> Modules location value (Maybe ModulePath)
List :: FilePath -> Modules location value [ModulePath]
data Modules address value return where
Load :: ModulePath -> Modules address value (Maybe (Environment address, value))
Lookup :: ModulePath -> Modules address value (Maybe (Maybe (Environment address, value)))
Resolve :: [FilePath] -> Modules address value (Maybe ModulePath)
List :: FilePath -> Modules address value [ModulePath]
sendModules :: Member (Modules location value) effects => Modules location value return -> Evaluator location value effects return
sendModules :: Member (Modules address value) effects => Modules address value return -> Evaluator address value effects return
sendModules = send
runModules :: forall term location value effects a
. ( Member (Resumable (LoadError location value)) effects
, Member (State (ModuleTable (Maybe (Environment location, value)))) effects
runModules :: forall term address value effects a
. ( Member (Resumable (LoadError address value)) effects
, Member (State (ModuleTable (Maybe (Environment address, value)))) effects
, Member Trace effects
)
=> (Module term -> Evaluator location value (Modules location value ': effects) (Environment location, value))
-> Evaluator location value (Modules location value ': effects) a
-> Evaluator location value (Reader (ModuleTable [Module term]) ': effects) a
=> (Module term -> Evaluator address value (Modules address value ': effects) (Environment address, value))
-> Evaluator address value (Modules address value ': effects) a
-> Evaluator address value (Reader (ModuleTable [Module term]) ': effects) a
runModules evaluateModule = go
where go :: forall a . Evaluator location value (Modules location value ': effects) a -> Evaluator location value (Reader (ModuleTable [Module term]) ': effects) a
where go :: forall a . Evaluator address value (Modules address value ': effects) a -> Evaluator address value (Reader (ModuleTable [Module term]) ': effects) a
go = reinterpret (\ m -> case m of
Load name -> askModuleTable @term >>= maybe (moduleNotFound name) (runMerging . foldMap (Merging . evalAndCache)) . ModuleTable.lookup name
where
@ -89,49 +89,49 @@ runModules evaluateModule = go
pure (find isMember names)
List dir -> modulePathsInDir dir <$> askModuleTable @term)
getModuleTable :: Member (State (ModuleTable (Maybe (Environment location, value)))) effects => Evaluator location value effects (ModuleTable (Maybe (Environment location, value)))
getModuleTable :: Member (State (ModuleTable (Maybe (Environment address, value)))) effects => Evaluator address value effects (ModuleTable (Maybe (Environment address, value)))
getModuleTable = get
cacheModule :: Member (State (ModuleTable (Maybe (Environment location, value)))) effects => ModulePath -> Maybe (Environment location, value) -> Evaluator location value effects (Maybe (Environment location, value))
cacheModule :: Member (State (ModuleTable (Maybe (Environment address, value)))) effects => ModulePath -> Maybe (Environment address, value) -> Evaluator address value effects (Maybe (Environment address, value))
cacheModule path result = modify' (ModuleTable.insert path result) $> result
askModuleTable :: Member (Reader (ModuleTable [Module term])) effects => Evaluator location value effects (ModuleTable [Module term])
askModuleTable :: Member (Reader (ModuleTable [Module term])) effects => Evaluator address value effects (ModuleTable [Module term])
askModuleTable = ask
newtype Merging m location value = Merging { runMerging :: m (Maybe (Environment location, value)) }
newtype Merging m address value = Merging { runMerging :: m (Maybe (Environment address, value)) }
instance Applicative m => Semigroup (Merging m location value) where
instance Applicative m => Semigroup (Merging m address value) where
Merging a <> Merging b = Merging (merge <$> a <*> b)
where merge a b = mergeJusts <$> a <*> b <|> a <|> b
mergeJusts (env1, _) (env2, v) = (mergeEnvs env1 env2, v)
instance Applicative m => Monoid (Merging m location value) where
instance Applicative m => Monoid (Merging m address value) where
mappend = (<>)
mempty = Merging (pure Nothing)
-- | An error thrown when loading a module from the list of provided modules. Indicates we weren't able to find a module with the given name.
data LoadError location value resume where
ModuleNotFound :: ModulePath -> LoadError location value (Maybe (Environment location, value))
data LoadError address value resume where
ModuleNotFound :: ModulePath -> LoadError address value (Maybe (Environment address, value))
deriving instance Eq (LoadError location value resume)
deriving instance Show (LoadError location value resume)
instance Show1 (LoadError location value) where
deriving instance Eq (LoadError address value resume)
deriving instance Show (LoadError address value resume)
instance Show1 (LoadError address value) where
liftShowsPrec _ _ = showsPrec
instance Eq1 (LoadError location value) where
instance Eq1 (LoadError address value) where
liftEq _ (ModuleNotFound a) (ModuleNotFound b) = a == b
moduleNotFound :: Member (Resumable (LoadError location value)) effects => ModulePath -> Evaluator location value effects (Maybe (Environment location, value))
moduleNotFound :: Member (Resumable (LoadError address value)) effects => ModulePath -> Evaluator address value effects (Maybe (Environment address, value))
moduleNotFound = throwResumable . ModuleNotFound
resumeLoadError :: Member (Resumable (LoadError location value)) effects => Evaluator location value effects a -> (forall resume . LoadError location value resume -> Evaluator location value effects resume) -> Evaluator location value effects a
resumeLoadError :: Member (Resumable (LoadError address value)) effects => Evaluator address value effects a -> (forall resume . LoadError address value resume -> Evaluator address value effects resume) -> Evaluator address value effects a
resumeLoadError = catchResumable
runLoadError :: Effectful (m location value) => m location value (Resumable (LoadError location value) ': effects) a -> m location value effects (Either (SomeExc (LoadError location value)) a)
runLoadError :: Effectful (m address value) => m address value (Resumable (LoadError address value) ': effects) a -> m address value effects (Either (SomeExc (LoadError address value)) a)
runLoadError = runResumable
runLoadErrorWith :: Effectful (m location value) => (forall resume . LoadError location value resume -> m location value effects resume) -> m location value (Resumable (LoadError location value) ': effects) a -> m location value effects a
runLoadErrorWith :: Effectful (m address value) => (forall resume . LoadError address value resume -> m address value effects resume) -> m address value (Resumable (LoadError address value) ': effects) a -> m address value effects a
runLoadErrorWith = runResumableWith

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

@ -13,44 +13,44 @@ import Data.Semilattice.Lower
import Prologue
builtin :: ( HasCallStack
, Member (Allocator location value) effects
, Member (Allocator address value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (State (Environment location)) effects
, Member (State (Heap location (Cell location) value)) effects
, Ord location
, Reducer value (Cell location value)
, Member (State (Environment address)) effects
, Member (State (Heap address (Cell address) value)) effects
, Ord address
, Reducer value (Cell address value)
)
=> String
-> Evaluator location value effects value
-> Evaluator location value effects ()
-> Evaluator address value effects value
-> Evaluator address value effects ()
builtin s def = withCurrentCallStack callStack $ do
let name' = name (pack ("__semantic_" <> s))
addr <- alloc name'
bind name' addr
def >>= assign addr
lambda :: (AbstractFunction location value effects, Member Fresh effects)
=> (Name -> Evaluator location value effects value)
-> Evaluator location value effects value
lambda :: (AbstractFunction address value effects, Member Fresh effects)
=> (Name -> Evaluator address value effects value)
-> Evaluator address value effects value
lambda body = do
var <- nameI <$> fresh
closure [var] lowerBound (body var)
defineBuiltins :: ( AbstractValue location value effects
defineBuiltins :: ( AbstractValue address value effects
, HasCallStack
, Member (Allocator location value) effects
, Member (Allocator address value) effects
, Member Fresh effects
, Member (Reader (Environment location)) effects
, Member (Reader (Environment address)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (EnvironmentError location)) effects
, Member (State (Environment location)) effects
, Member (State (Heap location (Cell location) value)) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (State (Environment address)) effects
, Member (State (Heap address (Cell address) value)) effects
, Member Trace effects
, Ord location
, Reducer value (Cell location value)
, Ord address
, Reducer value (Cell address value)
)
=> Evaluator location value effects ()
=> Evaluator address value effects ()
defineBuiltins =
builtin "print" (lambda (\ v -> variable v >>= asString >>= trace . unpack >> pure unit))

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

@ -9,9 +9,9 @@ import Data.Abstract.Live
import Prologue
-- | Retrieve the local 'Live' set.
askRoots :: Member (Reader (Live location)) effects => Evaluator location value effects (Live location)
askRoots :: Member (Reader (Live address)) effects => Evaluator 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 location)) effects, Ord location) => Live location -> Evaluator location value effects a -> Evaluator location value effects a
extraRoots :: (Member (Reader (Live address)) effects, Ord address) => Live address -> Evaluator address value effects a -> Evaluator address value effects a
extraRoots roots = local (<> roots)

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

@ -19,11 +19,11 @@ 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 location value effects a = TermEvaluator { runTermEvaluator :: Evaluator location value effects a }
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 location value effects)
deriving instance Member NonDet effects => Alternative (TermEvaluator term address value effects)
raiseHandler :: (Evaluator location value effects a -> Evaluator location value effects' a') -> (TermEvaluator term location value effects a -> TermEvaluator term location value effects' a')
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

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

@ -40,14 +40,14 @@ data Comparator
= Concrete (forall a . Ord a => a -> a -> Bool)
| Generalized
class Show value => AbstractFunction location value effects where
class Show value => AbstractFunction address value effects where
-- | Build a closure (a binder like a lambda or method definition).
closure :: [Name] -- ^ The parameter names.
-> Set Name -- ^ The set of free variables to close over.
-> Evaluator location value effects value -- ^ The evaluator for the body of the closure.
-> Evaluator location value effects value
-> Evaluator address value effects value -- ^ The evaluator for the body of the closure.
-> Evaluator address value effects value
-- | Evaluate an application (like a function call).
call :: value -> [Evaluator location value effects value] -> Evaluator location value effects value
call :: value -> [Evaluator address value effects value] -> Evaluator address value effects value
class Show value => AbstractIntro value where
@ -90,112 +90,112 @@ 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 (AbstractFunction location value effects, AbstractIntro value) => AbstractValue location value effects where
class (AbstractFunction address value effects, AbstractIntro value) => AbstractValue address value effects where
-- | Lift a unary operator over a 'Num' to a function on 'value's.
liftNumeric :: (forall a . Num a => a -> a)
-> (value -> Evaluator location value effects value)
-> (value -> Evaluator 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 location value effects value)
-> (value -> value -> Evaluator address value effects value)
-- | Lift a Comparator (usually wrapping a function like == or <=) to a function on values.
liftComparison :: Comparator -> (value -> value -> Evaluator location value effects value)
liftComparison :: Comparator -> (value -> value -> Evaluator address value effects value)
-- | Lift a unary bitwise operator to values. This is usually 'complement'.
liftBitwise :: (forall a . Bits a => a -> a)
-> (value -> Evaluator location value effects value)
-> (value -> Evaluator 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 location value effects value)
-> (value -> value -> Evaluator address value effects value)
-- | Construct an array of zero or more values.
array :: [value] -> Evaluator location value effects value
array :: [value] -> Evaluator address value effects value
-- | Extract the contents of a key-value pair as a tuple.
asPair :: value -> Evaluator location value effects (value, value)
asPair :: value -> Evaluator address value effects (value, value)
-- | Extract a 'ByteString' from a given value.
asString :: value -> Evaluator location value effects ByteString
asString :: value -> Evaluator address value effects ByteString
-- | Eliminate boolean values. TODO: s/boolean/truthy
ifthenelse :: value -> Evaluator location value effects a -> Evaluator location value effects a -> Evaluator location value effects a
ifthenelse :: value -> Evaluator address value effects a -> Evaluator address value effects a -> Evaluator address value effects a
-- | @index x i@ computes @x[i]@, with zero-indexing.
index :: value -> value -> Evaluator location value effects value
index :: value -> value -> Evaluator address value effects value
-- | Build a class value from a name and environment.
klass :: Name -- ^ The new class's identifier
-> [value] -- ^ A list of superclasses
-> Environment location -- ^ The environment to capture
-> Evaluator location value effects value
-> Environment address -- ^ The environment to capture
-> Evaluator address value effects value
-- | Build a namespace value from a name and environment stack
--
-- Namespaces model closures with monoidal environments.
namespace :: Name -- ^ The namespace's identifier
-> Environment location -- ^ The environment to mappend
-> Evaluator location value effects value
-> Environment address -- ^ The environment to mappend
-> Evaluator address value effects value
-- | Extract the environment from any scoped object (e.g. classes, namespaces, etc).
scopedEnvironment :: value -> Evaluator location value effects (Maybe (Environment location))
scopedEnvironment :: value -> Evaluator address value effects (Maybe (Environment address))
-- | Primitive looping combinator, approximately equivalent to 'fix'. This should be used in place of direct recursion, as it allows abstraction over recursion.
--
-- The function argument takes an action which recurs through the loop.
loop :: (Evaluator location value effects value -> Evaluator location value effects value) -> Evaluator location value effects value
loop :: (Evaluator address value effects value -> Evaluator address value effects value) -> Evaluator address value effects value
-- | Extract a 'Bool' from a given value.
asBool :: AbstractValue location value effects => value -> Evaluator location value effects Bool
asBool :: AbstractValue address value effects => value -> Evaluator address value effects Bool
asBool value = ifthenelse value (pure True) (pure False)
-- | C-style for loops.
forLoop :: ( AbstractValue location value effects
, Member (State (Environment location)) effects
forLoop :: ( AbstractValue address value effects
, Member (State (Environment address)) effects
)
=> Evaluator location value effects value -- ^ Initial statement
-> Evaluator location value effects value -- ^ Condition
-> Evaluator location value effects value -- ^ Increment/stepper
-> Evaluator location value effects value -- ^ Body
-> Evaluator location value effects value
=> 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
forLoop initial cond step body =
locally (initial *> while cond (body *> step))
-- | The fundamental looping primitive, built on top of 'ifthenelse'.
while :: AbstractValue location value effects
=> Evaluator location value effects value
-> Evaluator location value effects value
-> Evaluator location value effects value
while :: AbstractValue address value effects
=> Evaluator address value effects value
-> Evaluator address value effects value
-> Evaluator address value effects value
while cond body = loop $ \ continue -> do
this <- cond
ifthenelse this (body *> continue) (pure unit)
-- | Do-while loop, built on top of while.
doWhile :: AbstractValue location value effects
=> Evaluator location value effects value
-> Evaluator location value effects value
-> Evaluator location value effects value
doWhile :: AbstractValue address value effects
=> Evaluator address value effects value
-> Evaluator address value effects value
-> Evaluator address value effects value
doWhile body cond = loop $ \ continue -> body *> do
this <- cond
ifthenelse this continue (pure unit)
makeNamespace :: ( AbstractValue location value effects
, Member (State (Environment location)) effects
, Member (State (Heap location (Cell location) value)) effects
, Ord location
, Reducer value (Cell location value)
makeNamespace :: ( AbstractValue address value effects
, Member (State (Environment address)) effects
, Member (State (Heap address (Cell address) value)) effects
, Ord address
, Reducer value (Cell address value)
)
=> Name
-> location
-> address
-> Maybe value
-> Evaluator location value effects value
-> Evaluator address value effects value
makeNamespace name addr super = do
superEnv <- maybe (pure (Just lowerBound)) scopedEnvironment super
let env' = fromMaybe lowerBound superEnv
@ -205,43 +205,43 @@ makeNamespace name addr super = do
-- | Evaluate a term within the context of the scoped environment of 'scopedEnvTerm'.
evaluateInScopedEnv :: ( AbstractValue location value effects
, Member (State (Environment location)) effects
evaluateInScopedEnv :: ( AbstractValue address value effects
, Member (State (Environment address)) effects
)
=> Evaluator location value effects value
-> Evaluator location value effects value
-> Evaluator location value effects value
=> Evaluator address value effects value
-> Evaluator address value effects value
-> Evaluator address value effects value
evaluateInScopedEnv scopedEnvTerm term = do
scopedEnv <- scopedEnvTerm >>= scopedEnvironment
maybe term (\ env -> locally (bindAll env *> term)) scopedEnv
-- | Evaluates a 'Value' returning the referenced value
value :: ( AbstractValue location value effects
, Member (Allocator location value) effects
, Member (Reader (Environment location)) effects
, Member (Resumable (EnvironmentError location)) effects
, Member (State (Environment location)) effects
value :: ( AbstractValue address value effects
, Member (Allocator address value) effects
, Member (Reader (Environment address)) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (State (Environment address)) effects
)
=> ValueRef value
-> Evaluator location value effects value
-> Evaluator address value effects value
value (LvalLocal var) = variable var
value (LvalMember obj prop) = evaluateInScopedEnv (pure obj) (variable prop)
value (Rval val) = pure val
-- | Evaluates a 'Subterm' to its rval
subtermValue :: ( AbstractValue location value effects
, Member (Allocator location value) effects
, Member (Reader (Environment location)) effects
, Member (Resumable (EnvironmentError location)) effects
, Member (State (Environment location)) effects
subtermValue :: ( AbstractValue address value effects
, Member (Allocator address value) effects
, Member (Reader (Environment address)) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (State (Environment address)) effects
)
=> Subterm term (Evaluator location value effects (ValueRef value))
-> Evaluator location value effects value
=> Subterm term (Evaluator address value effects (ValueRef value))
-> Evaluator address value effects value
subtermValue = value <=< subtermRef
-- | Value types, e.g. closures, which can root a set of addresses.
class ValueRoots location value where
class ValueRoots address value where
-- | Compute the set of addresses rooted by a given value.
valueRoots :: value -> Live location
valueRoots :: value -> Live address

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

@ -26,10 +26,10 @@ instance Show Monovariant where
showsPrec d = showsUnaryWith showsPrec "Monovariant" d . unMonovariant
data Located location = Located
{ location :: location
, locationPackage :: {-# UNPACK #-} !PackageInfo
, locationModule :: !ModuleInfo
data Located address = Located
{ address :: address
, addressPackage :: {-# UNPACK #-} !PackageInfo
, addressModule :: !ModuleInfo
}
deriving (Eq, Ord, Show)

18
src/Data/Abstract/Cache.hs
View File

@ -9,30 +9,30 @@ import Data.Semilattice.Lower
import Prologue
-- | A map of 'Configuration's to 'Set's of resulting values & 'Heap's.
newtype Cache term location cell value = Cache { unCache :: Monoidal.Map (Configuration term location cell value) (Set (Cached location cell value)) }
deriving (Eq, Lower, Monoid, Ord, Reducer (Configuration term location cell value, Cached location cell value), Semigroup)
newtype Cache term address cell value = Cache { unCache :: Monoidal.Map (Configuration term address cell value) (Set (Cached address cell value)) }
deriving (Eq, Lower, Monoid, Ord, Reducer (Configuration term address cell value, Cached address cell value), Semigroup)
data Cached location cell value = Cached
data Cached address cell value = Cached
{ cachedValue :: ValueRef value
, cachedHeap :: Heap location cell value
, cachedHeap :: Heap address cell value
}
deriving (Eq, Ord, Show)
type Cacheable term location cell value = (Ord (cell value), Ord location, Ord term, Ord value)
type Cacheable term address cell value = (Ord (cell value), Ord address, Ord term, Ord value)
-- | Look up the resulting value & 'Heap' for a given 'Configuration'.
cacheLookup :: Cacheable term location cell value => Configuration term location cell value -> Cache term location cell value -> Maybe (Set (Cached location cell value))
cacheLookup :: Cacheable term address cell value => Configuration term address cell value -> Cache term address cell value -> Maybe (Set (Cached address cell value))
cacheLookup key = Monoidal.lookup key . unCache
-- | Set the resulting value & 'Heap' for a given 'Configuration', overwriting any previous entry.
cacheSet :: Cacheable term location cell value => Configuration term location cell value -> Set (Cached location cell value) -> Cache term location cell value -> Cache term location cell value
cacheSet :: Cacheable term address cell value => Configuration term address cell value -> Set (Cached address cell value) -> Cache term address cell value -> Cache term address cell value
cacheSet key value = Cache . Monoidal.insert key value . unCache
-- | Insert the resulting value & 'Heap' for a given 'Configuration', appending onto any previous entry.
cacheInsert :: Cacheable term location cell value => Configuration term location cell value -> Cached location cell value -> Cache term location cell value -> Cache term location cell value
cacheInsert :: Cacheable term address cell value => Configuration term address cell value -> Cached address cell value -> Cache term address cell value -> Cache term address cell value
cacheInsert = curry cons
instance (Show term, Show location, Show (cell value), Show value) => Show (Cache term location cell value) where
instance (Show term, Show address, Show (cell value), Show value) => Show (Cache term address cell value) where
showsPrec d = showsUnaryWith showsPrec "Cache" d . map (second toList) . Monoidal.pairs . unCache

10
src/Data/Abstract/Configuration.hs
View File

@ -5,10 +5,10 @@ import Data.Abstract.Heap
import Data.Abstract.Live
-- | A single point in a program’s execution.
data Configuration term location cell value = Configuration
{ configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate.
, configurationRoots :: Live location -- ^ The set of rooted addresses.
, configurationEnvironment :: Environment location -- ^ The environment binding any free variables in 'configurationTerm'.
, configurationHeap :: Heap location cell value -- ^ The heap of values.
data Configuration term address cell value = Configuration
{ configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate.
, configurationRoots :: Live address -- ^ The set of rooted addresses.
, configurationEnvironment :: Environment address -- ^ The environment binding any free variables in 'configurationTerm'.
, configurationHeap :: Heap address cell value -- ^ The heap of values.
}
deriving (Eq, Ord, Show)

40
src/Data/Abstract/Environment.hs
View File

@ -35,32 +35,32 @@ import Prologue
-- | A LIFO stack of maps of names to addresses, representing a lexically-scoped evaluation environment.
-- All behaviors can be assumed to be frontmost-biased: looking up "a" will check the most specific
-- scope for "a", then the next, and so on.
newtype Environment location = Environment { unEnvironment :: NonEmpty (Map.Map Name location) }
newtype Environment address = Environment { unEnvironment :: NonEmpty (Map.Map Name address) }
deriving (Eq, Ord)
mergeEnvs :: Environment location -> Environment location -> Environment location
mergeEnvs :: Environment address -> Environment address -> Environment address
mergeEnvs (Environment (a :| as)) (Environment (b :| bs)) =
Environment ((<>) a b :| alignWith (mergeThese (<>)) as bs)
emptyEnv :: Environment location
emptyEnv :: Environment address
emptyEnv = Environment (lowerBound :| [])
-- | Make and enter a new empty scope in the given environment.
push :: Environment location -> Environment location
push :: Environment address -> Environment address
push (Environment (a :| as)) = Environment (mempty :| a : as)
-- | Remove the frontmost scope.
pop :: Environment location -> Environment location
pop :: Environment address -> Environment address
pop (Environment (_ :| [])) = emptyEnv
pop (Environment (_ :| a : as)) = Environment (a :| as)
-- | Drop all scopes save for the frontmost one.
head :: Environment location -> Environment location
head :: Environment address -> Environment address
head (Environment (a :| _)) = Environment (a :| [])
-- | Take the union of two environments. When duplicate keys are found in the
-- name to address map, the second definition wins.
mergeNewer :: Environment location -> Environment location -> Environment location
mergeNewer :: Environment address -> Environment address -> Environment address
mergeNewer (Environment a) (Environment b) =
Environment (NonEmpty.fromList . reverse $ alignWith (mergeThese combine) (reverse as) (reverse bs))
where
@ -72,45 +72,45 @@ mergeNewer (Environment a) (Environment b) =
--
-- >>> pairs shadowed
-- [("foo",Precise 1)]
pairs :: Environment location -> [(Name, location)]
pairs :: Environment address -> [(Name, address)]
pairs = Map.toList . fold . unEnvironment
unpairs :: [(Name, location)] -> Environment location
unpairs :: [(Name, address)] -> Environment address
unpairs = Environment . pure . Map.fromList
-- | Lookup a 'Name' in the environment.
--
-- >>> lookup (name "foo") shadowed
-- Just (Precise 1)
lookup :: Name -> Environment location -> Maybe location
lookup :: Name -> Environment address -> Maybe address
lookup name = foldMapA (Map.lookup name) . unEnvironment
-- | Insert a 'Name' in the environment.
insert :: Name -> location -> Environment location -> Environment location
insert :: Name -> address -> Environment address -> Environment address
insert name addr (Environment (a :| as)) = Environment (Map.insert name addr a :| as)
-- | Remove a 'Name' from the environment.
--
-- >>> delete (name "foo") shadowed
-- Environment []
delete :: Name -> Environment location -> Environment location
delete :: Name -> Environment address -> Environment address
delete name = trim . Environment . fmap (Map.delete name) . unEnvironment
trim :: Environment location -> Environment location
trim :: Environment address -> Environment address
trim (Environment (a :| as)) = Environment (a :| filtered)
where filtered = filter (not . Map.null) as
intersect :: Foldable t => t Name -> Environment location -> Environment location
intersect :: Foldable t => t Name -> Environment address -> Environment address
intersect names env = unpairs (mapMaybe lookupName (toList names))
where
lookupName name = (,) name <$> lookup name env
-- | Get all bound 'Name's in an environment.
names :: Environment location -> [Name]
names :: Environment address -> [Name]
names = fmap fst . pairs
-- | Lookup and alias name-value bindings from an environment.
overwrite :: [(Name, Name)] -> Environment location -> Environment location
overwrite :: [(Name, Name)] -> Environment address -> Environment address
overwrite pairs env = unpairs $ mapMaybe lookupAndAlias pairs
where
lookupAndAlias (oldName, newName) = (,) newName <$> lookup oldName env
@ -118,14 +118,14 @@ overwrite pairs env = unpairs $ mapMaybe lookupAndAlias pairs
-- | Retrieve the 'Live' set of addresses to which the given free variable names are bound.
--
-- Unbound names are silently dropped.
roots :: (Ord location, Foldable t) => Environment location -> t Name -> Live location
roots :: (Ord address, Foldable t) => Environment address -> t Name -> Live address
roots env names = addresses (names `intersect` env)
addresses :: Ord location => Environment location -> Live location
addresses :: Ord address => Environment address -> Live address
addresses = fromAddresses . map snd . pairs
instance Lower (Environment location) where lowerBound = emptyEnv
instance Lower (Environment address) where lowerBound = emptyEnv
instance Show location => Show (Environment location) where
instance Show address => Show (Environment address) where
showsPrec d = showsUnaryWith showsPrec "Environment" d . pairs

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

@ -44,61 +44,61 @@ 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 Evaluatable constr where
eval :: ( EvaluatableConstraints location term value effects
eval :: ( EvaluatableConstraints address term value effects
, Member Fail effects
)
=> SubtermAlgebra constr term (Evaluator location value effects (ValueRef value))
default eval :: (Member (Resumable (Unspecialized value)) effects, Show1 constr) => SubtermAlgebra constr term (Evaluator location value effects (ValueRef value))
=> SubtermAlgebra constr term (Evaluator address value effects (ValueRef value))
default eval :: (Member (Resumable (Unspecialized value)) effects, Show1 constr) => SubtermAlgebra constr term (Evaluator address value effects (ValueRef value))
eval expr = throwResumable (Unspecialized ("Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr ""))
type EvaluatableConstraints location term value effects =
( AbstractValue location value effects
type EvaluatableConstraints address term value effects =
( AbstractValue address value effects
, Declarations term
, FreeVariables term
, Member (Allocator location value) effects
, Member (Allocator address value) effects
, Member (LoopControl value) effects
, Member (Modules location value) effects
, Member (Reader (Environment location)) effects
, Member (Modules address value) effects
, Member (Reader (Environment address)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
, Member (Resumable (EnvironmentError location)) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (Resumable EvalError) effects
, Member (Resumable ResolutionError) effects
, Member (Resumable (Unspecialized value)) effects
, Member (Return value) effects
, Member (State (Environment location)) effects
, Member (State (Exports location)) effects
, Member (State (Heap location (Cell location) value)) effects
, Member (State (Environment address)) effects
, Member (State (Exports address)) effects
, Member (State (Heap address (Cell address) value)) effects
, Member Trace effects
, Ord location
, Reducer value (Cell location value)
, Ord address
, Reducer value (Cell address value)
)
-- | Evaluate a given package.
evaluatePackageWith :: forall location term value inner outer
-- FIXME: It’d be nice if we didn’t have to mention 'Addressable' here at all, but 'Located' locations require knowledge of 'currentModule' to run. Can we fix that? If not, can we factor this effect list out?
. ( Addressable location (Reader ModuleInfo ': Modules location value ': Reader Span ': Reader PackageInfo ': outer)
evaluatePackageWith :: forall address term value inner outer
-- FIXME: It’d be nice if we didn’t have to mention 'Addressable' here at all, but 'Located' addresses require knowledge of 'currentModule' to run. Can we fix that? If not, can we factor this effect list out?
. ( Addressable address (Reader ModuleInfo ': Modules address value ': Reader Span ': Reader PackageInfo ': outer)
, Evaluatable (Base term)
, EvaluatableConstraints location term value inner
, EvaluatableConstraints address term value inner
, Member Fail outer
, Member Fresh outer
, Member (Reader (Environment location)) outer
, Member (Resumable (AddressError location value)) outer
, Member (Resumable (LoadError location value)) outer
, Member (State (Environment location)) outer
, Member (State (Exports location)) outer
, Member (State (Heap location (Cell location) value)) outer
, Member (State (ModuleTable (Maybe (Environment location, value)))) outer
, Member (Reader (Environment address)) outer
, Member (Resumable (AddressError address value)) outer
, Member (Resumable (LoadError address value)) outer
, Member (State (Environment address)) outer
, Member (State (Exports address)) outer
, Member (State (Heap address (Cell address) value)) outer
, Member (State (ModuleTable (Maybe (Environment address, value)))) outer
, Member Trace outer
, Recursive term
, inner ~ (LoopControl value ': Return value ': Allocator location value ': Reader ModuleInfo ': Modules location value ': Reader Span ': Reader PackageInfo ': outer)
, inner ~ (LoopControl value ': Return value ': Allocator address value ': Reader ModuleInfo ': Modules address value ': Reader Span ': Reader PackageInfo ': outer)
)
=> (SubtermAlgebra Module term (TermEvaluator term location value inner value) -> SubtermAlgebra Module term (TermEvaluator term location value inner value))
-> (SubtermAlgebra (Base term) term (TermEvaluator term location value inner (ValueRef value)) -> SubtermAlgebra (Base term) term (TermEvaluator term location value inner (ValueRef value)))
=> (SubtermAlgebra Module term (TermEvaluator term address value inner value) -> SubtermAlgebra Module term (TermEvaluator term address value inner value))
-> (SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef value)) -> SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef value)))
-> Package term
-> TermEvaluator term location value outer [value]
-> TermEvaluator term address value outer [value]
evaluatePackageWith analyzeModule analyzeTerm package
= runReader (packageInfo package)
. runReader lowerBound
@ -120,7 +120,7 @@ evaluatePackageWith analyzeModule analyzeTerm package
. raiseHandler runReturn
. raiseHandler runLoopControl
evaluateEntryPoint :: ModulePath -> Maybe Name -> TermEvaluator term location value (Modules location value ': Reader Span ': Reader PackageInfo ': outer) value
evaluateEntryPoint :: ModulePath -> Maybe Name -> TermEvaluator term address value (Modules address value ': Reader Span ': Reader PackageInfo ': outer) value
evaluateEntryPoint m sym = runInModule (ModuleInfo m) . TermEvaluator $ do
v <- maybe unit snd <$> require m
maybe (pure v) ((`call` []) <=< variable) sym
@ -144,10 +144,10 @@ evaluatePackageWith analyzeModule analyzeTerm package
-- | Isolate the given action with an empty global environment and exports.
isolate :: (Member (State (Environment location)) effects, Member (State (Exports location)) effects) => Evaluator location value effects a -> Evaluator location value effects a
isolate :: (Member (State (Environment address)) effects, Member (State (Exports address)) effects) => Evaluator address value effects a -> Evaluator address value effects a
isolate = withEnv lowerBound . withExports lowerBound
traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator location value effects ()
traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator address value effects ()
traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path)

12
src/Data/Abstract/Exports.hs
View File

@ -15,22 +15,22 @@ import Prelude hiding (null)
import Prologue hiding (null)
-- | A map of export names to an alias & address tuple.
newtype Exports location = Exports { unExports :: Map.Map Name (Name, Maybe location) }
newtype Exports address = Exports { unExports :: Map.Map Name (Name, Maybe address) }
deriving (Eq, Lower, Monoid, Ord, Semigroup)
null :: Exports location -> Bool
null :: Exports address -> Bool
null = Map.null . unExports
toEnvironment :: Exports location -> Environment location
toEnvironment :: Exports address -> Environment address
toEnvironment exports = unpairs (mapMaybe sequenceA (toList (unExports exports)))
insert :: Name -> Name -> Maybe location -> Exports location -> Exports location
insert :: Name -> Name -> Maybe address -> Exports address -> Exports address
insert name alias address = Exports . Map.insert name (alias, address) . unExports
-- TODO: Should we filter for duplicates here?
aliases :: Exports location -> [(Name, Name)]
aliases :: Exports address -> [(Name, Name)]
aliases = Map.toList . fmap fst . unExports
instance Show location => Show (Exports location) where
instance Show address => Show (Exports address) where
showsPrec d = showsUnaryWith showsPrec "Exports" d . Map.toList . unExports

18
src/Data/Abstract/Heap.hs
View File

@ -8,38 +8,38 @@ import Data.Semilattice.Lower
import Prologue
-- | A map of addresses onto cells holding their values.
newtype Heap location cell value = Heap { unHeap :: Monoidal.Map location (cell value) }
newtype Heap address cell value = Heap { unHeap :: Monoidal.Map address (cell value) }
deriving (Eq, Foldable, Functor, Lower, Monoid, Ord, Semigroup, Traversable)
-- | Look up the cell of values for an 'Address' in a 'Heap', if any.
heapLookup :: Ord location => location -> Heap location cell value -> Maybe (cell value)
heapLookup :: Ord address => address -> Heap address cell value -> Maybe (cell value)
heapLookup address = Monoidal.lookup address . unHeap
-- | Look up the list of values stored for a given address, if any.
heapLookupAll :: (Ord location, Foldable cell) => location -> Heap location cell value -> Maybe [value]
heapLookupAll :: (Ord address, Foldable cell) => address -> Heap address cell value -> Maybe [value]
heapLookupAll address = fmap toList . heapLookup address
-- | Append a value onto the cell for a given address, inserting a new cell if none existed.
heapInsert :: (Ord location, Reducer value (cell value)) => location -> value -> Heap location cell value -> Heap location cell value
heapInsert :: (Ord address, Reducer value (cell value)) => address -> value -> Heap address cell value -> Heap address cell value
heapInsert address value = flip snoc (address, value)
-- | Manually insert a cell into the heap at a given address.
heapInit :: Ord location => location -> cell value -> Heap location cell value -> Heap location cell value
heapInit :: Ord address => address -> cell value -> Heap address cell value -> Heap address cell value
heapInit address cell (Heap h) = Heap (Monoidal.insert address cell h)
-- | The number of addresses extant in a 'Heap'.
heapSize :: Heap location cell value -> Int
heapSize :: Heap address cell value -> Int
heapSize = Monoidal.size . unHeap
-- | Restrict a 'Heap' to only those addresses in the given 'Live' set (in essence garbage collecting the rest).
heapRestrict :: Ord location => Heap location cell value -> Live location -> Heap location cell value
heapRestrict :: Ord address => Heap address cell value -> Live address -> Heap address cell value
heapRestrict (Heap m) roots = Heap (Monoidal.filterWithKey (\ address _ -> address `liveMember` roots) m)
instance (Ord location, Reducer value (cell value)) => Reducer (location, value) (Heap location cell value) where
instance (Ord address, Reducer value (cell value)) => Reducer (address, value) (Heap address cell value) where
unit = Heap . unit
cons (addr, a) (Heap heap) = Heap (cons (addr, a) heap)
snoc (Heap heap) (addr, a) = Heap (snoc heap (addr, a))
instance (Show location, Show (cell value)) => Show (Heap location cell value) where
instance (Show address, Show (cell value)) => Show (Heap address cell value) where
showsPrec d = showsUnaryWith showsPrec "Heap" d . Monoidal.pairs . unHeap

18
src/Data/Abstract/Live.hs
View File

@ -6,36 +6,36 @@ import Data.Set as Set
import Prologue
-- | A set of live addresses (whether roots or reachable).
newtype Live location = Live { unLive :: Set location }
newtype Live address = Live { unLive :: Set address }
deriving (Eq, Lower, Monoid, Ord, Semigroup)
fromAddresses :: (Foldable t, Ord location) => t location -> Live location
fromAddresses :: (Foldable t, Ord address) => t address -> Live address
fromAddresses = Prologue.foldr liveInsert lowerBound
-- | Construct a 'Live' set containing only the given address.
liveSingleton :: location -> Live location
liveSingleton :: address -> Live address
liveSingleton = Live . Set.singleton
-- | Insert an address into a 'Live' set.
liveInsert :: Ord location => location -> Live location -> Live location
liveInsert :: Ord address => address -> Live address -> Live address
liveInsert addr = Live . Set.insert addr . unLive
-- | Delete an address from a 'Live' set, if present.
liveDelete :: Ord location => location -> Live location -> Live location
liveDelete :: Ord address => address -> Live address -> Live address
liveDelete addr = Live . Set.delete addr . unLive
-- | Compute the (asymmetric) difference of two 'Live' sets, i.e. delete every element of the second set from the first set.
liveDifference :: Ord location => Live location -> Live location -> Live location
liveDifference :: Ord address => Live address -> Live address -> Live address
liveDifference = fmap Live . (Set.difference `on` unLive)
-- | Test whether an address is in a 'Live' set.
liveMember :: Ord location => location -> Live location -> Bool
liveMember :: Ord address => address -> Live address -> Bool
liveMember addr = Set.member addr . unLive
-- | Decompose a 'Live' set into a pair of one member address and the remaining set, or 'Nothing' if empty.
liveSplit :: Live location -> Maybe (location, Live location)
liveSplit :: Live address -> Maybe (address, Live address)
liveSplit = fmap (fmap Live) . Set.minView . unLive
instance Show location => Show (Live location) where
instance Show address => Show (Live address) where
showsPrec d = showsUnaryWith showsPrec "Live" d . Set.toList . unLive

26
src/Data/Abstract/Type.hs
View File

@ -94,7 +94,7 @@ unify t1 t2
| t1 == t2 = pure t2
| otherwise = throwResumable (UnificationError t1 t2)
instance Ord location => ValueRoots location Type where
instance Ord address => ValueRoots address Type where
valueRoots _ = mempty
@ -116,16 +116,16 @@ instance AbstractIntro Type where
null = Null
instance ( Member (Allocator location Type) effects
instance ( Member (Allocator address Type) effects
, Member Fresh effects
, Member (Resumable TypeError) effects
, Member (Return Type) effects
, Member (State (Environment location)) effects
, Member (State (Heap location (Cell location) Type)) effects
, Ord location
, Reducer Type (Cell location Type)
, Member (State (Environment address)) effects
, Member (State (Heap address (Cell address) Type)) effects
, Ord address
, Reducer Type (Cell address Type)
)
=> AbstractFunction location Type effects where
=> AbstractFunction address Type effects where
closure names _ body = do
(env, tvars) <- foldr (\ name rest -> do
a <- alloc name
@ -145,17 +145,17 @@ instance ( Member (Allocator location Type) effects
-- | Discard the value arguments (if any), constructing a 'Type' instead.
instance ( Member (Allocator location Type) effects
instance ( Member (Allocator address Type) effects
, Member Fresh effects
, Member NonDet effects
, Member (Resumable TypeError) effects
, Member (Return Type) effects
, Member (State (Environment location)) effects
, Member (State (Heap location (Cell location) Type)) effects
, Ord location
, Reducer Type (Cell location Type)
, Member (State (Environment address)) effects
, Member (State (Heap address (Cell address) Type)) effects
, Ord address
, Reducer Type (Cell address Type)
)
=> AbstractValue location Type effects where
=> AbstractValue address Type effects where
array fields = do
var <- fresh
Array <$> foldr (\ t1 -> (unify t1 =<<)) (pure (Var var)) fields

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

@ -14,8 +14,8 @@ import Data.Semigroup.Reducer
import qualified Data.Set as Set
import Prologue
data Value location body
= Closure PackageInfo ModuleInfo [Name] (ClosureBody location body) (Environment location)
data Value address body
= Closure PackageInfo ModuleInfo [Name] (ClosureBody address body) (Environment address)
| Unit
| Boolean Bool
| Integer (Number.Number Integer)
@ -23,51 +23,51 @@ data Value location body
| Float (Number.Number Scientific)
| String ByteString
| Symbol ByteString
| Tuple [Value location body]
| Array [Value location body]
| Class Name (Environment location)
| Namespace Name (Environment location)
| KVPair (Value location body) (Value location body)
| Hash [Value location body]
| Tuple [Value address body]
| Array [Value address body]
| Class Name (Environment address)
| Namespace Name (Environment address)
| KVPair (Value address body) (Value address body)
| Hash [Value address body]
| Null
| Hole
deriving (Eq, Ord, Show)
data ClosureBody location body = ClosureBody { closureBodyId :: Int, closureBody :: body (Value location body) }
data ClosureBody address body = ClosureBody { closureBodyId :: Int, closureBody :: body (Value address body) }
instance Eq (ClosureBody location body) where
instance Eq (ClosureBody address body) where
(==) = (==) `on` closureBodyId
instance Ord (ClosureBody location body) where
instance Ord (ClosureBody address body) where
compare = compare `on` closureBodyId
instance Show (ClosureBody location body) where
instance Show (ClosureBody address body) where
showsPrec d (ClosureBody i _) = showsBinaryWith showsPrec (const showChar) "ClosureBody" d i '_'
instance Ord location => ValueRoots location (Value location body) where
instance Ord address => ValueRoots address (Value address body) where
valueRoots v
| Closure _ _ _ _ env <- v = Env.addresses env
| otherwise = mempty
instance AbstractHole (Value location body) where
instance AbstractHole (Value address body) where
hole = Hole
instance ( Coercible body (Eff effects)
, Member (Allocator location (Value location body)) effects
, Member (Allocator address (Value address body)) effects
, Member Fresh effects
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Resumable (ValueError location body)) effects
, Member (Return (Value location body)) effects
, Member (State (Environment location)) effects
, Member (State (Heap location (Cell location) (Value location body))) effects
, Ord location
, Reducer (Value location body) (Cell location (Value location body))
, Show location
, Member (Resumable (ValueError address body)) effects
, Member (Return (Value address body)) effects
, Member (State (Environment address)) effects
, Member (State (Heap address (Cell address) (Value address body))) effects
, Ord address
, Reducer (Value address body) (Cell address (Value address body))
, Show address
)
=> AbstractFunction location (Value location body) effects where
=> AbstractFunction address (Value address body) effects where
closure parameters freeVariables body = do
packageInfo <- currentPackage
moduleInfo <- currentModule
@ -89,7 +89,7 @@ instance ( Coercible body (Eff effects)
_ -> throwValueError (CallError op)
instance Show location => AbstractIntro (Value location body) where
instance Show address => AbstractIntro (Value address body) where
unit = Unit
integer = Integer . Number.Integer
boolean = Boolean
@ -108,21 +108,21 @@ instance Show location => AbstractIntro (Value location body) where
-- | Construct a 'Value' wrapping the value arguments (if any).
instance ( Coercible body (Eff effects)
, Member (Allocator location (Value location body)) effects
, Member (Allocator address (Value address body)) effects
, Member Fresh effects
, Member (LoopControl (Value location body)) effects
, Member (Reader (Environment location)) effects
, Member (LoopControl (Value address body)) effects
, Member (Reader (Environment address)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Resumable (ValueError location body)) effects
, Member (Return (Value location body)) effects
, Member (State (Environment location)) effects
, Member (State (Heap location (Cell location) (Value location body))) effects
, Ord location
, Reducer (Value location body) (Cell location (Value location body))
, Show location
, Member (Resumable (ValueError address body)) effects
, Member (Return (Value address body)) effects
, Member (State (Environment address)) effects
, Member (State (Heap address (Cell address) (Value address body))) effects
, Ord address
, Reducer (Value address body) (Cell address (Value address body))
, Show address
)
=> AbstractValue location (Value location body) effects where
=> AbstractValue address (Value address body) effects where
asPair val
| KVPair k v <- val = pure (k, v)
| otherwise = throwValueError $ KeyValueError val
@ -185,7 +185,7 @@ 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 location (Value location body) effects, Member (Resumable (ValueError location body)) effects) => Either ArithException Number.SomeNumber -> Evaluator location (Value location body) effects (Value location body)
specialize :: (AbstractValue address (Value address body) effects, Member (Resumable (ValueError address body)) effects) => Either ArithException Number.SomeNumber -> Evaluator address (Value address body) effects (Value address body)
specialize (Left exc) = throwValueError (ArithmeticError exc)
specialize (Right (Number.SomeNumber (Number.Integer i))) = pure $ integer i
specialize (Right (Number.SomeNumber (Number.Ratio r))) = pure $ rational r
@ -204,7 +204,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 location (Value location body) effects, Ord a) => a -> a -> Evaluator location (Value location body) effects (Value location body)
go :: (AbstractValue address (Value address body) effects, Ord a) => a -> a -> Evaluator address (Value address body) effects (Value address body)
go l r = case comparator of
Concrete f -> pure $ boolean (f l r)
Generalized -> pure $ integer (orderingToInt (compare l r))
@ -232,25 +232,25 @@ instance ( Coercible body (Eff effects)
-- | The type of exceptions that can be thrown when constructing values in 'Value'’s 'MonadValue' instance.
data ValueError location body resume where
StringError :: Value location body -> ValueError location body ByteString
BoolError :: Value location body -> ValueError location body Bool
IndexError :: Value location body -> Value location body -> ValueError location body (Value location body)
NamespaceError :: Prelude.String -> ValueError location body (Environment location)
CallError :: Value location body -> ValueError location body (Value location body)
NumericError :: Value location body -> ValueError location body (Value location body)
Numeric2Error :: Value location body -> Value location body -> ValueError location body (Value location body)
ComparisonError :: Value location body -> Value location body -> ValueError location body (Value location body)
BitwiseError :: Value location body -> ValueError location body (Value location body)
Bitwise2Error :: Value location body -> Value location body -> ValueError location body (Value location body)
KeyValueError :: Value location body -> ValueError location body (Value location body, Value location body)
data ValueError address body resume where
StringError :: Value address body -> ValueError address body ByteString
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 (Environment 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)
-- Indicates that we encountered an arithmetic exception inside Haskell-native number crunching.
ArithmeticError :: ArithException -> ValueError location body (Value location body)
ArithmeticError :: ArithException -> ValueError address body (Value address body)
-- Out-of-bounds error
BoundsError :: [Value location body] -> Prelude.Integer -> ValueError location body (Value location body)
BoundsError :: [Value address body] -> Prelude.Integer -> ValueError address body (Value address body)
instance Eq location => Eq1 (ValueError location body) where
instance Eq address => Eq1 (ValueError address body) where
liftEq _ (StringError a) (StringError b) = a == b
liftEq _ (NamespaceError a) (NamespaceError b) = a == b
liftEq _ (CallError a) (CallError b) = a == b
@ -264,15 +264,15 @@ instance Eq location => Eq1 (ValueError location body) where
liftEq _ (BoundsError a b) (BoundsError c d) = (a == c) && (b == d)
liftEq _ _ _ = False
deriving instance Show location => Show (ValueError location body resume)
instance Show location => Show1 (ValueError location body) where
deriving instance Show address => Show (ValueError address body resume)
instance Show address => Show1 (ValueError address body) where
liftShowsPrec _ _ = showsPrec
throwValueError :: Member (Resumable (ValueError location body)) effects => ValueError location body resume -> Evaluator location (Value location body) effects resume
throwValueError :: Member (Resumable (ValueError address body)) effects => ValueError address body resume -> Evaluator address (Value address body) effects resume
throwValueError = throwResumable
runValueError :: Effectful (m location (Value location body)) => m location (Value location body) (Resumable (ValueError location body) ': effects) a -> m location (Value location body) effects (Either (SomeExc (ValueError location body)) a)
runValueError :: Effectful (m address (Value address body)) => m address (Value address body) (Resumable (ValueError address body) ': effects) a -> m address (Value address body) effects (Either (SomeExc (ValueError address body)) a)
runValueError = runResumable
runValueErrorWith :: Effectful (m location (Value location body)) => (forall resume . ValueError location body resume -> m location (Value location body) effects resume) -> m location (Value location body) (Resumable (ValueError location body) ': effects) a -> m location (Value location body) effects a
runValueErrorWith :: Effectful (m address (Value address body)) => (forall resume . ValueError address body resume -> m address (Value address body) effects resume) -> m address (Value address body) (Resumable (ValueError address body) ': effects) a -> m address (Value address body) effects a
runValueErrorWith = runResumableWith

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

@ -29,14 +29,14 @@ importPath str = let path = stripQuotes str in ImportPath (BC.unpack path) (path
defaultAlias :: ImportPath -> Name
defaultAlias = name . BC.pack . takeFileName . unPath
resolveGoImport :: ( Member (Modules location value) effects
resolveGoImport :: ( Member (Modules address value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Package.PackageInfo) effects
, Member (Resumable ResolutionError) effects
, Member Trace effects
)
=> ImportPath
-> Evaluator location value effects [ModulePath]
-> Evaluator address value effects [ModulePath]
resolveGoImport (ImportPath path Relative) = do
ModuleInfo{..} <- currentModule
paths <- listModulesInDir (joinPaths (takeDirectory modulePath) path)

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

@ -41,30 +41,30 @@ instance Evaluatable VariableName
-- file, the complete contents of the included file are treated as though it
-- were defined inside that function.
resolvePHPName :: ( Member (Modules location value) effects
resolvePHPName :: ( Member (Modules address value) effects
, Member (Resumable ResolutionError) effects
)
=> ByteString
-> Evaluator location value effects ModulePath
-> Evaluator address value effects ModulePath
resolvePHPName n = do
modulePath <- resolve [name]
maybe (throwResumable $ NotFoundError name [name] Language.PHP) pure modulePath
where name = toName n
toName = BC.unpack . dropRelativePrefix . stripQuotes
include :: ( AbstractValue location value effects
, Member (Allocator location value) effects
, Member (Modules location value) effects
, Member (Reader (Environment location)) effects
include :: ( AbstractValue address value effects
, Member (Allocator address value) effects
, Member (Modules address value) effects
, Member (Reader (Environment address)) effects
, Member (Resumable ResolutionError) effects
, Member (Resumable (EnvironmentError location)) effects
, Member (State (Environment location)) effects
, Member (State (Exports location)) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (State (Environment address)) effects
, Member (State (Exports address)) effects
, Member Trace effects
)
=> Subterm term (Evaluator location value effects (ValueRef value))
-> (ModulePath -> Evaluator location value effects (Maybe (Environment location, value)))
-> Evaluator location value effects (ValueRef value)
=> Subterm term (Evaluator address value effects (ValueRef value))
-> (ModulePath -> Evaluator address value effects (Maybe (Environment address, value)))
-> Evaluator address value effects (ValueRef value)
include pathTerm f = do
name <- subtermValue pathTerm >>= asString
path <- resolvePHPName name

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

@ -52,13 +52,13 @@ relativeQualifiedName prefix paths = RelativeQualifiedName (BC.unpack prefix) (J
-- Subsequent imports of `parent.two` or `parent.three` will execute
-- `parent/two/__init__.py` and
-- `parent/three/__init__.py` respectively.
resolvePythonModules :: ( Member (Modules location value) effects
resolvePythonModules :: ( Member (Modules address value) effects
, Member (Reader ModuleInfo) effects
, Member (Resumable ResolutionError) effects
, Member Trace effects
)
=> QualifiedName
-> Evaluator location value effects (NonEmpty ModulePath)
-> Evaluator address value effects (NonEmpty ModulePath)
resolvePythonModules q = do
relRootDir <- rootDir q <$> currentModule
for (moduleNames q) $ \name -> do
@ -127,17 +127,17 @@ instance Evaluatable Import where
-- Evaluate a qualified import
evalQualifiedImport :: ( AbstractValue location value effects
, Member (Allocator location value) effects
, Member (Modules location value) effects
, Member (Reader (Environment location)) effects
, Member (State (Environment location)) effects
, Member (State (Exports location)) effects
, Member (State (Heap location (Cell location) value)) effects
, Ord location
, Reducer.Reducer value (Cell location value)
evalQualifiedImport :: ( AbstractValue address value effects
, Member (Allocator address value) effects
, Member (Modules address value) effects
, Member (Reader (Environment address)) effects
, Member (State (Environment address)) effects
, Member (State (Exports address)) effects
, Member (State (Heap address (Cell address) value)) effects
, Ord address
, Reducer.Reducer value (Cell address value)
)
=> Name -> ModulePath -> Evaluator location value effects value
=> Name -> ModulePath -> Evaluator address value effects value
evalQualifiedImport name path = letrec' name $ \addr -> do
importedEnv <- maybe emptyEnv fst <$> isolate (require path)
bindAll importedEnv

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

@ -17,11 +17,11 @@ import System.FilePath.Posix
-- TODO: Fully sort out ruby require/load mechanics
--
-- require "json"
resolveRubyName :: ( Member (Modules location value) effects
resolveRubyName :: ( Member (Modules address value) effects
, Member (Resumable ResolutionError) effects
)
=> ByteString
-> Evaluator location value effects M.ModulePath
-> Evaluator address value effects M.ModulePath
resolveRubyName name = do
let name' = cleanNameOrPath name
let paths = [name' <.> "rb"]
@ -29,11 +29,11 @@ resolveRubyName name = do
maybe (throwResumable $ NotFoundError name' paths Language.Ruby) pure modulePath
-- load "/root/src/file.rb"
resolveRubyPath :: ( Member (Modules location value) effects
resolveRubyPath :: ( Member (Modules address value) effects
, Member (Resumable ResolutionError) effects
)
=> ByteString
-> Evaluator location value effects M.ModulePath
-> Evaluator address value effects M.ModulePath
resolveRubyPath path = do
let name' = cleanNameOrPath path
modulePath <- resolve [name']
@ -77,11 +77,11 @@ instance Evaluatable Require where
bindAll importedEnv
pure (Rval v) -- Returns True if the file was loaded, False if it was already loaded. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-require
doRequire :: ( AbstractValue location value effects
, Member (Modules location value) effects
doRequire :: ( AbstractValue address value effects
, Member (Modules address value) effects
)
=> M.ModulePath
-> Evaluator location value effects (Environment location, value)
-> Evaluator address value effects (Environment address, value)
doRequire path = do
result <- join <$> lookupModule path
case result of
@ -108,16 +108,16 @@ instance Evaluatable Load where
Rval <$> doLoad path shouldWrap
eval (Load _) = raiseEff (fail "invalid argument supplied to load, path is required")
doLoad :: ( AbstractValue location value effects
, Member (Modules location value) effects
doLoad :: ( AbstractValue address value effects
, Member (Modules address value) effects
, Member (Resumable ResolutionError) effects
, Member (State (Environment location)) effects
, Member (State (Exports location)) effects
, Member (State (Environment address)) effects
, Member (State (Exports address)) effects
, Member Trace effects
)
=> ByteString
-> Bool
-> Evaluator location value effects value
-> Evaluator address value effects value
doLoad path shouldWrap = do
path' <- resolveRubyPath path
traceResolve path path'

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

@ -38,7 +38,7 @@ toName = name . BC.pack . unPath
--
-- NB: TypeScript has a couple of different strategies, but the main one (and the
-- only one we support) mimics Node.js.
resolveWithNodejsStrategy :: ( Member (Modules location value) effects
resolveWithNodejsStrategy :: ( Member (Modules address value) effects
, Member (Reader M.ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Resumable ResolutionError) effects
@ -46,7 +46,7 @@ resolveWithNodejsStrategy :: ( Member (Modules location value) effects
)
=> ImportPath
-> [String]
-> Evaluator location value effects M.ModulePath
-> Evaluator address value effects M.ModulePath
resolveWithNodejsStrategy (ImportPath path Relative) exts = resolveRelativePath path exts
resolveWithNodejsStrategy (ImportPath path NonRelative) exts = resolveNonRelativePath path exts
@ -57,7 +57,7 @@ resolveWithNodejsStrategy (ImportPath path NonRelative) exts = resolveNonRelativ
-- /root/src/moduleB.ts
-- /root/src/moduleB/package.json (if it specifies a "types" property)
-- /root/src/moduleB/index.ts
resolveRelativePath :: ( Member (Modules location value) effects
resolveRelativePath :: ( Member (Modules address value) effects
, Member (Reader M.ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Resumable ResolutionError) effects
@ -65,7 +65,7 @@ resolveRelativePath :: ( Member (Modules location value) effects
)
=> FilePath
-> [String]
-> Evaluator location value effects M.ModulePath
-> Evaluator address value effects M.ModulePath
resolveRelativePath relImportPath exts = do
M.ModuleInfo{..} <- currentModule
let relRootDir = takeDirectory modulePath
@ -85,7 +85,7 @@ resolveRelativePath relImportPath exts = do
--
-- /root/node_modules/moduleB.ts, etc
-- /node_modules/moduleB.ts, etc
resolveNonRelativePath :: ( Member (Modules location value) effects
resolveNonRelativePath :: ( Member (Modules address value) effects
, Member (Reader M.ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Resumable ResolutionError) effects
@ -93,7 +93,7 @@ resolveNonRelativePath :: ( Member (Modules location value) effects
)
=> FilePath
-> [String]
-> Evaluator location value effects M.ModulePath
-> Evaluator address value effects M.ModulePath
resolveNonRelativePath name exts = do
M.ModuleInfo{..} <- currentModule
go "." modulePath mempty
@ -110,13 +110,13 @@ resolveNonRelativePath name exts = do
notFound xs = throwResumable $ NotFoundError name xs Language.TypeScript
-- | Resolve a module name to a ModulePath.
resolveModule :: ( Member (Modules location value) effects
resolveModule :: ( Member (Modules address value) effects
, Member (Reader PackageInfo) effects
, Member Trace effects
)
=> FilePath -- ^ Module path used as directory to search in
-> [String] -- ^ File extensions to look for
-> Evaluator location value effects (Either [FilePath] M.ModulePath)
-> Evaluator address value effects (Either [FilePath] M.ModulePath)
resolveModule path' exts = do
let path = makeRelative "." path'
PackageInfo{..} <- currentPackage
@ -133,19 +133,19 @@ typescriptExtensions = ["ts", "tsx", "d.ts"]
javascriptExtensions :: [String]
javascriptExtensions = ["js"]
evalRequire :: ( AbstractValue location value effects
, Member (Allocator location value) effects
, Member (Modules location value) effects
, Member (Reader (Environment location)) effects
, Member (State (Environment location)) effects
, Member (State (Exports location)) effects
, Member (State (Heap location (Cell location) value)) effects
, Ord location
, Reducer value (Cell location value)
evalRequire :: ( AbstractValue address value effects
, Member (Allocator address value) effects
, Member (Modules address value) effects
, Member (Reader (Environment address)) effects
, Member (State (Environment address)) effects
, Member (State (Exports address)) effects
, Member (State (Heap address (Cell address) value)) effects
, Ord address
, Reducer value (Cell address value)
)
=> M.ModulePath
-> Name
-> Evaluator location value effects value
-> Evaluator address value effects value
evalRequire modulePath alias = letrec' alias $ \addr -> do
importedEnv <- maybe emptyEnv fst <$> isolate (require modulePath)
bindAll importedEnv

16
src/Semantic/Graph.hs
View File

@ -100,8 +100,8 @@ parseModule parser rootDir file = do
withTermSpans :: ( HasField fields Span
, Member (Reader Span) effects
)
=> SubtermAlgebra (TermF syntax (Record fields)) term (TermEvaluator term location value effects a)
-> SubtermAlgebra (TermF syntax (Record fields)) term (TermEvaluator term location value effects a)
=> SubtermAlgebra (TermF syntax (Record fields)) term (TermEvaluator term address value effects a)
-> SubtermAlgebra (TermF syntax (Record fields)) term (TermEvaluator term address value effects a)
withTermSpans recur term = withCurrentSpan (getField (termFAnnotation term)) (recur term)
resumingResolutionError :: (Applicative (m effects), Effectful m, Member Trace effects) => m (Resumable ResolutionError ': effects) a -> m effects a
@ -109,10 +109,10 @@ resumingResolutionError = runResolutionErrorWith (\ err -> trace ("ResolutionErr
NotFoundError nameToResolve _ _ -> pure nameToResolve
GoImportError pathToResolve -> pure [pathToResolve])
resumingLoadError :: Member Trace effects => Evaluator location value (Resumable (LoadError location value) ': effects) a -> Evaluator location value effects a
resumingLoadError :: Member Trace effects => Evaluator address value (Resumable (LoadError address value) ': effects) a -> Evaluator address value effects a
resumingLoadError = runLoadErrorWith (\ (ModuleNotFound path) -> trace ("LoadError: " <> path) $> Nothing)
resumingEvalError :: Member Trace effects => Evaluator location value (Resumable EvalError ': effects) a -> Evaluator location value effects a
resumingEvalError :: Member Trace effects => Evaluator address value (Resumable EvalError ': effects) a -> Evaluator address value effects a
resumingEvalError = runEvalErrorWith (\ err -> trace ("EvalError" <> show err) *> case err of
DefaultExportError{} -> pure ()
ExportError{} -> pure ()
@ -121,15 +121,15 @@ resumingEvalError = runEvalErrorWith (\ err -> trace ("EvalError" <> show err) *
RationalFormatError{} -> pure 0
FreeVariablesError names -> pure (fromMaybeLast "unknown" names))
resumingUnspecialized :: (Member Trace effects, AbstractHole value) => Evaluator location value (Resumable (Unspecialized value) ': effects) a -> Evaluator location value effects a
resumingUnspecialized :: (Member Trace effects, AbstractHole value) => Evaluator address value (Resumable (Unspecialized value) ': effects) a -> Evaluator address value effects a
resumingUnspecialized = runUnspecializedWith (\ err@(Unspecialized _) -> trace ("Unspecialized:" <> show err) $> Rval hole)
resumingAddressError :: (AbstractHole value, Lower (Cell location value), Member Trace effects, Show location) => Evaluator location value (Resumable (AddressError location value) ': effects) a -> Evaluator location value effects a
resumingAddressError :: (AbstractHole value, Lower (Cell address value), Member Trace effects, Show address) => Evaluator address value (Resumable (AddressError address value) ': effects) a -> Evaluator address value effects a
resumingAddressError = runAddressErrorWith (\ err -> trace ("AddressError:" <> show err) *> case err of
UnallocatedAddress _ -> pure lowerBound
UninitializedAddress _ -> pure hole)
resumingValueError :: (Member (State (Environment location)) effects, Member Trace effects, Show location) => Evaluator location (Value location body) (Resumable (ValueError location body) ': effects) a -> Evaluator location (Value location body) effects a
resumingValueError :: (Member (State (Environment address)) effects, Member Trace effects, Show address) => Evaluator address (Value address body) (Resumable (ValueError address body) ': effects) a -> Evaluator address (Value address body) effects a
resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err) *> case err of
CallError val -> pure val
StringError val -> pure (pack (show val))
@ -145,7 +145,7 @@ resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err
KeyValueError{} -> pure (hole, hole)
ArithmeticError{} -> pure hole)
resumingEnvironmentError :: AbstractHole location => Evaluator location value (Resumable (EnvironmentError location) ': effects) a -> Evaluator location value effects (a, [Name])
resumingEnvironmentError :: AbstractHole address => Evaluator address value (Resumable (EnvironmentError address) ': effects) a -> Evaluator address value effects (a, [Name])
resumingEnvironmentError
= runState []
. reinterpret (\ (Resumable (FreeVariable name)) -> modify' (name :) $> hole)

4
src/Semantic/Task.hs
View File

@ -104,7 +104,7 @@ 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 location value effects a -> result) -> Analysis.TermEvaluator term location value effects a -> Eff effs result
analyze :: Member Task effs => (Analysis.TermEvaluator term address value effects a -> result) -> Analysis.TermEvaluator 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.
@ -160,7 +160,7 @@ runTraceInTelemetry = interpret (\ (Trace str) -> writeLog Debug str [])
-- | An effect describing high-level tasks to be performed.
data Task output where
Parse :: Parser term -> Blob -> Task term
Analyze :: (Analysis.TermEvaluator term location value effects a -> result) -> Analysis.TermEvaluator term location value effects a -> Task result
Analyze :: (Analysis.TermEvaluator term address value effects a -> result) -> Analysis.TermEvaluator term address value effects a -> Task result
Decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> Task (Term f (Record (field ': fields)))
Diff :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => These (Term syntax (Record fields1)) (Term syntax (Record fields2)) -> Task (Diff syntax (Record fields1) (Record fields2))
Render :: Renderer input output -> input -> Task output