mirror of
https://github.com/github/semantic.git
synced 2024-12-30 10:27:45 +03:00
Revert "Revert "Revert "Parameterize the typeclasses by the list of effects."""
This reverts commit 81dc8c50484cf7c415eb3f754ca5fbb934517f2a.
This commit is contained in:
Rob Rix
parent
3aa0b2eddc
commit
54c1f0d2e9
@ -34,54 +34,53 @@ type CachingEffects term value effects
|
||||
type CacheFor m = Cache (LocationFor (ValueFor m)) (TermFor m) (ValueFor m)
|
||||
|
||||
newtype CachingAnalysis m (effects :: [* -> *]) a = CachingAnalysis { runCachingAnalysis :: m effects a }
|
||||
deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadFresh, MonadNonDet)
|
||||
deriving (Alternative, Applicative, Functor, Monad, MonadEvaluator, MonadFail, MonadFresh, MonadNonDet)
|
||||
|
||||
deriving instance Effectful effects (m effects) => Effectful effects (CachingAnalysis m effects)
|
||||
|
||||
deriving instance MonadEvaluator effects m => MonadEvaluator effects (CachingAnalysis m)
|
||||
-- TODO: reabstract these later on
|
||||
|
||||
type InCacheEffectFor m = Reader (CacheFor m)
|
||||
type OutCacheEffectFor m = State (CacheFor m)
|
||||
|
||||
askCache :: (Effectful effects (m effects), Member (InCacheEffectFor m) effects) => CachingAnalysis m effects (CacheFor m)
|
||||
askCache :: (Effectful effects (m effects), Member (InCacheEffectFor (m effects)) effects) => CachingAnalysis m effects (CacheFor (m effects))
|
||||
askCache = lift ask
|
||||
|
||||
localCache :: (Effectful effects (m effects), Member (InCacheEffectFor m) effects) => (CacheFor m -> CacheFor m) -> CachingAnalysis m effects a -> CachingAnalysis m effects a
|
||||
localCache :: (Effectful effects (m effects), Member (InCacheEffectFor (m effects)) effects) => (CacheFor (m effects) -> CacheFor (m effects)) -> CachingAnalysis m effects a -> CachingAnalysis m effects a
|
||||
localCache f a = lift (local f (lower a))
|
||||
|
||||
asksCache :: (Functor (m effects), Effectful effects (m effects), Member (InCacheEffectFor m) effects) => (CacheFor m -> a) -> CachingAnalysis m effects a
|
||||
asksCache :: (Functor (m effects), Effectful effects (m effects), Member (InCacheEffectFor (m effects)) effects) => (CacheFor (m effects) -> a) -> CachingAnalysis m effects a
|
||||
asksCache f = f <$> askCache
|
||||
|
||||
getsCache :: (Functor (m effects), Effectful effects (m effects), Member (OutCacheEffectFor m) effects) => (CacheFor m -> a) -> CachingAnalysis m effects a
|
||||
getsCache :: (Functor (m effects), Effectful effects (m effects), Member (OutCacheEffectFor (m effects)) effects) => (CacheFor (m effects) -> a) -> CachingAnalysis m effects a
|
||||
getsCache f = f <$> getCache
|
||||
|
||||
getCache :: (Effectful effects (m effects), Member (OutCacheEffectFor m) effects) => CachingAnalysis m effects (CacheFor m)
|
||||
getCache :: (Effectful effects (m effects), Member (OutCacheEffectFor (m effects)) effects) => CachingAnalysis m effects (CacheFor (m effects))
|
||||
getCache = lift get
|
||||
|
||||
putCache :: (Effectful effects (m effects), Member (OutCacheEffectFor m) effects) => CacheFor m -> CachingAnalysis m effects ()
|
||||
putCache :: (Effectful effects (m effects), Member (OutCacheEffectFor (m effects)) effects) => CacheFor (m effects) -> CachingAnalysis m effects ()
|
||||
putCache = lift . put
|
||||
|
||||
modifyCache :: (Effectful effects (m effects), Member (OutCacheEffectFor m) effects, Monad (m effects)) => (CacheFor m -> CacheFor m) -> CachingAnalysis m effects ()
|
||||
modifyCache :: (Effectful effects (m effects), Member (OutCacheEffectFor (m effects)) effects, Monad (m effects)) => (CacheFor (m effects) -> CacheFor (m effects)) -> CachingAnalysis m effects ()
|
||||
modifyCache f = fmap f getCache >>= putCache
|
||||
|
||||
-- | This instance coinductively iterates the analysis of a term until the results converge.
|
||||
instance ( Corecursive (TermFor m)
|
||||
, Ord (TermFor m)
|
||||
, Ord (ValueFor m)
|
||||
, Ord (CellFor (ValueFor m))
|
||||
, Ord (LocationFor (ValueFor m))
|
||||
instance ( Corecursive (TermFor (m effects))
|
||||
, Ord (TermFor (m effects))
|
||||
, Ord (ValueFor (m effects))
|
||||
, Ord (CellFor (ValueFor (m effects)))
|
||||
, Ord (LocationFor (ValueFor (m effects)))
|
||||
, Effectful effects (m effects)
|
||||
, MonadFresh (m effects)
|
||||
, MonadNonDet (m effects)
|
||||
, Members (CachingEffectsFor m) effects
|
||||
, Evaluatable (Base (TermFor m))
|
||||
, Foldable (Cell (LocationFor (ValueFor m)))
|
||||
, FreeVariables (TermFor m)
|
||||
, MonadAnalysis effects m
|
||||
, Recursive (TermFor m)
|
||||
, Members (CachingEffectsFor (m effects)) effects
|
||||
, Evaluatable (Base (TermFor (m effects)))
|
||||
, Foldable (Cell (LocationFor (ValueFor (m effects))))
|
||||
, FreeVariables (TermFor (m effects))
|
||||
, MonadAnalysis (m effects)
|
||||
, Recursive (TermFor (m effects))
|
||||
)
|
||||
=> MonadAnalysis effects (CachingAnalysis m) where
|
||||
=> MonadAnalysis (CachingAnalysis m effects) where
|
||||
analyzeTerm e = do
|
||||
c <- getConfiguration (embedSubterm e)
|
||||
-- Convergence here is predicated upon an Eq instance, not α-equivalence
|
||||
@ -115,25 +114,26 @@ converge f = loop
|
||||
loop x'
|
||||
|
||||
-- | Nondeterministically write each of a collection of stores & return their associated results.
|
||||
scatter :: (Alternative (m effects), Foldable t, MonadEvaluator effects m) => t (a, Store (LocationFor (ValueFor m)) (ValueFor m)) -> m effects a
|
||||
scatter :: (Alternative m, Foldable t, MonadEvaluator m) => t (a, Store (LocationFor (ValueFor m)) (ValueFor m)) -> m a
|
||||
scatter = getAlt . foldMap (\ (value, store') -> Alt (putStore store' *> pure value))
|
||||
|
||||
-- | Evaluation of a single iteration of an analysis, given an in-cache as an oracle for results and an out-cache to record computed results in.
|
||||
memoizeEval :: ( Ord (ValueFor m)
|
||||
, Ord (TermFor m)
|
||||
, Ord (LocationFor (ValueFor m))
|
||||
, Ord (CellFor (ValueFor m))
|
||||
memoizeEval :: ( Ord (ValueFor (m effects))
|
||||
, Ord (TermFor (m effects))
|
||||
, Ord (LocationFor (ValueFor (m effects)))
|
||||
, Ord (CellFor (ValueFor (m effects)))
|
||||
, Alternative (m effects)
|
||||
, Corecursive (TermFor m)
|
||||
, FreeVariables (TermFor m)
|
||||
, Foldable (Cell (LocationFor (ValueFor m)))
|
||||
, Functor (Base (TermFor m))
|
||||
, Corecursive (TermFor (m effects))
|
||||
, FreeVariables (TermFor (m effects))
|
||||
, Foldable (Cell (LocationFor (ValueFor (m effects))))
|
||||
, Functor (Base (TermFor (m effects)))
|
||||
, Effectful effects (m effects)
|
||||
, Members (CachingEffectsFor m) effects
|
||||
, Recursive (TermFor m)
|
||||
, MonadAnalysis effects m
|
||||
, Members (CachingEffectsFor (m effects)) effects
|
||||
, Recursive (TermFor (m effects))
|
||||
, MonadAnalysis (m effects)
|
||||
-- , Semigroup (CellFor (ValueFor (m effects)))
|
||||
)
|
||||
=> SubtermAlgebra (Base (TermFor m)) (TermFor m) (CachingAnalysis m effects (ValueFor m))
|
||||
=> SubtermAlgebra (Base (TermFor (m effects))) (TermFor (m effects)) (CachingAnalysis m effects (ValueFor (m effects)))
|
||||
memoizeEval e = do
|
||||
c <- getConfiguration (embedSubterm e)
|
||||
cached <- getsCache (cacheLookup c)
|
||||
|
||||
@ -13,9 +13,8 @@ type DeadCode term = State (Dead term)
|
||||
|
||||
-- | An analysis tracking dead (unreachable) code.
|
||||
newtype DeadCodeAnalysis m (effects :: [* -> *]) a = DeadCodeAnalysis { runDeadCodeAnalysis :: m effects a }
|
||||
deriving (Applicative, Functor, Monad, MonadFail)
|
||||
deriving (Applicative, Functor, Monad, MonadEvaluator, MonadFail)
|
||||
|
||||
deriving instance MonadEvaluator effects m => MonadEvaluator effects (DeadCodeAnalysis m)
|
||||
|
||||
-- | A set of “dead” (unreachable) terms.
|
||||
newtype Dead term = Dead { unDead :: Set term }
|
||||
@ -25,11 +24,11 @@ deriving instance Ord term => Reducer term (Dead term)
|
||||
deriving instance Effectful effects (m effects) => Effectful effects (DeadCodeAnalysis m effects)
|
||||
|
||||
-- | Update the current 'Dead' set.
|
||||
killAll :: (Effectful effects (m effects), Member (State (Dead (TermFor m))) effects) => Dead (TermFor m) -> DeadCodeAnalysis m effects ()
|
||||
killAll :: (Effectful effects (m effects), Member (State (Dead (TermFor (m effects)))) effects) => Dead (TermFor (m effects)) -> DeadCodeAnalysis m effects ()
|
||||
killAll = lift . put
|
||||
|
||||
-- | Revive a single term, removing it from the current 'Dead' set.
|
||||
revive :: (Effectful effects (m effects), Member (State (Dead (TermFor m))) effects) => Ord (TermFor m) => (TermFor m) -> DeadCodeAnalysis m effects ()
|
||||
revive :: (Effectful effects (m effects), Member (State (Dead (TermFor (m effects)))) effects) => Ord (TermFor (m effects)) => (TermFor (m effects)) -> DeadCodeAnalysis m effects ()
|
||||
revive t = lift (modify (Dead . delete t . unDead))
|
||||
|
||||
-- | Compute the set of all subterms recursively.
|
||||
@ -37,16 +36,16 @@ subterms :: (Ord term, Recursive term, Foldable (Base term)) => term -> Dead ter
|
||||
subterms term = term `cons` para (foldMap (uncurry cons)) term
|
||||
|
||||
|
||||
instance ( Corecursive (TermFor m)
|
||||
instance ( Corecursive (TermFor (m effects))
|
||||
, Effectful effects (m effects)
|
||||
, Foldable (Base (TermFor m))
|
||||
, Member (State (Dead (TermFor m))) effects
|
||||
, MonadAnalysis effects m
|
||||
, MonadEvaluator effects m
|
||||
, Ord (TermFor m)
|
||||
, Recursive (TermFor m)
|
||||
, Foldable (Base (TermFor (m effects)))
|
||||
, Member (State (Dead (TermFor (m effects)))) effects
|
||||
, MonadAnalysis (m effects)
|
||||
, MonadEvaluator (m effects)
|
||||
, Ord (TermFor (m effects))
|
||||
, Recursive (TermFor (m effects))
|
||||
)
|
||||
=> MonadAnalysis effects (DeadCodeAnalysis m) where
|
||||
=> MonadAnalysis (DeadCodeAnalysis m effects) where
|
||||
analyzeTerm term = do
|
||||
revive (embedSubterm term)
|
||||
liftAnalyze analyzeTerm term
|
||||
|
||||
@ -21,29 +21,29 @@ import System.FilePath.Posix
|
||||
evaluate :: forall value term
|
||||
. ( Evaluatable (Base term)
|
||||
, FreeVariables term
|
||||
, MonadAddressable (LocationFor value) (EvaluatingEffects term value '[]) (Evaluating term value)
|
||||
, MonadValue value (EvaluatingEffects term value '[]) (Evaluating term value)
|
||||
, MonadAddressable (LocationFor value) (Evaluating term value (EvaluatingEffects term value '[]))
|
||||
, MonadValue value (Evaluating term value (EvaluatingEffects term value '[]))
|
||||
, Recursive term
|
||||
)
|
||||
=> term
|
||||
-> Final (EvaluatingEffects term value '[]) value
|
||||
evaluate = run . evaluateModule @(EvaluatingEffects term value '[]) @(Evaluating term value)
|
||||
evaluate = run . evaluateModule @(Evaluating term value (EvaluatingEffects term value '[]))
|
||||
|
||||
-- | Evaluate terms and an entry point to a value.
|
||||
evaluates :: forall value term
|
||||
. ( Evaluatable (Base term)
|
||||
, FreeVariables term
|
||||
, MonadAddressable (LocationFor value) (EvaluatingEffects term value '[]) (Evaluating term value)
|
||||
, MonadValue value (EvaluatingEffects term value '[]) (Evaluating term value)
|
||||
, MonadAddressable (LocationFor value) (Evaluating term value (EvaluatingEffects term value '[]))
|
||||
, MonadValue value (Evaluating term value (EvaluatingEffects term value '[]))
|
||||
, Recursive term
|
||||
)
|
||||
=> [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated
|
||||
-> (Blob, term) -- Entrypoint
|
||||
-> Final (EvaluatingEffects term value '[]) value
|
||||
evaluates pairs (_, t) = run (withModules pairs (evaluateModule @(EvaluatingEffects term value '[]) @(Evaluating term value) t))
|
||||
evaluates pairs (_, t) = run (withModules pairs (evaluateModule @(Evaluating term value (EvaluatingEffects term value '[])) t))
|
||||
|
||||
-- | Run an action with the passed ('Blob', @term@) pairs available for imports.
|
||||
withModules :: (MonadAnalysis effects m, MonadEvaluator effects m) => [(Blob, TermFor m)] -> m effects a -> m effects a
|
||||
withModules :: (MonadAnalysis m, MonadEvaluator m) => [(Blob, TermFor m)] -> m a -> m a
|
||||
withModules pairs = localModuleTable (const moduleTable)
|
||||
where moduleTable = ModuleTable (Map.fromList (map (first (dropExtensions . blobPath)) pairs))
|
||||
|
||||
@ -66,9 +66,9 @@ type EvaluatingEffects term value effects
|
||||
': State (ModuleTable value) -- Cache of evaluated modules
|
||||
': effects
|
||||
|
||||
instance Members (EvaluatingEffects term value '[]) effects => MonadEvaluator effects (Evaluating term value) where
|
||||
type TermFor (Evaluating term value) = term
|
||||
type ValueFor (Evaluating term value) = value
|
||||
instance Members (EvaluatingEffects term value '[]) effects => MonadEvaluator (Evaluating term value effects) where
|
||||
type TermFor (Evaluating term value effects) = term
|
||||
type ValueFor (Evaluating term value effects) = value
|
||||
|
||||
getGlobalEnv = lift get
|
||||
modifyGlobalEnv f = lift (modify f)
|
||||
@ -88,9 +88,9 @@ instance Members (EvaluatingEffects term value '[]) effects => MonadEvaluator ef
|
||||
instance ( Evaluatable (Base term)
|
||||
, FreeVariables term
|
||||
, Members (EvaluatingEffects term value '[]) effects
|
||||
, MonadAddressable (LocationFor value) effects (Evaluating term value)
|
||||
, MonadValue value effects (Evaluating term value)
|
||||
, MonadAddressable (LocationFor value) (Evaluating term value effects)
|
||||
, MonadValue value (Evaluating term value effects)
|
||||
, Recursive term
|
||||
)
|
||||
=> MonadAnalysis effects (Evaluating term value) where
|
||||
=> MonadAnalysis (Evaluating term value effects) where
|
||||
analyzeTerm = eval
|
||||
|
||||
@ -18,29 +18,28 @@ type TracerFor trace m = Writer (TraceFor trace m)
|
||||
-- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis.
|
||||
newtype TracingAnalysis (trace :: * -> *) m (effects :: [* -> *]) a
|
||||
= TracingAnalysis { runTracingAnalysis :: m effects a }
|
||||
deriving (Applicative, Functor, Monad, MonadFail)
|
||||
deriving (Applicative, Functor, Monad, MonadEvaluator, MonadFail)
|
||||
|
||||
deriving instance Effectful effects (m effects) => Effectful effects (TracingAnalysis trace m effects)
|
||||
deriving instance MonadEvaluator effects m => MonadEvaluator effects (TracingAnalysis trace m)
|
||||
|
||||
instance ( Corecursive (TermFor m)
|
||||
instance ( Corecursive (TermFor (m effects))
|
||||
, Effectful effects (m effects)
|
||||
, Member (TracerFor trace m) effects
|
||||
, MonadAnalysis effects m
|
||||
, MonadEvaluator effects m
|
||||
, Ord (LocationFor (ValueFor m))
|
||||
, Recursive (TermFor m)
|
||||
, Reducer (ConfigurationFor (TermFor m) (ValueFor m)) (TraceFor trace m)
|
||||
, Member (TracerFor trace (m effects)) effects
|
||||
, MonadAnalysis (m effects)
|
||||
, MonadEvaluator (m effects)
|
||||
, Ord (LocationFor (ValueFor (m effects)))
|
||||
, Recursive (TermFor (m effects))
|
||||
, Reducer (ConfigurationFor (TermFor (m effects)) (ValueFor (m effects))) (TraceFor trace (m effects))
|
||||
)
|
||||
=> MonadAnalysis effects (TracingAnalysis trace m) where
|
||||
=> MonadAnalysis (TracingAnalysis trace m effects) where
|
||||
analyzeTerm term = do
|
||||
config <- getConfiguration (embedSubterm term)
|
||||
trace (Reducer.unit config)
|
||||
liftAnalyze analyzeTerm term
|
||||
|
||||
trace :: ( Effectful effects (m effects)
|
||||
, Member (TracerFor trace m) effects
|
||||
, Member (TracerFor trace (m effects)) effects
|
||||
)
|
||||
=> TraceFor trace m
|
||||
=> TraceFor trace (m effects)
|
||||
-> TracingAnalysis trace m effects ()
|
||||
trace = lift . tell
|
||||
|
||||
@ -15,39 +15,39 @@ import Data.Semigroup.Reducer
|
||||
import Prelude hiding (fail)
|
||||
|
||||
-- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Store.
|
||||
class (Monad (m effects), Ord l, l ~ LocationFor (ValueFor m), Reducer (ValueFor m) (Cell l (ValueFor m))) => MonadAddressable l effects m where
|
||||
class (Monad m, Ord l, l ~ LocationFor (ValueFor m), Reducer (ValueFor m) (Cell l (ValueFor m))) => MonadAddressable l m where
|
||||
deref :: Address l (ValueFor m)
|
||||
-> m effects (ValueFor m)
|
||||
-> m (ValueFor m)
|
||||
|
||||
alloc :: Name
|
||||
-> m effects (Address l (ValueFor m))
|
||||
-> m (Address l (ValueFor m))
|
||||
|
||||
-- | Look up or allocate an address for a 'Name' free in a given term & assign it a given value, returning the 'Name' paired with the address.
|
||||
--
|
||||
-- The term is expected to contain one and only one free 'Name', meaning that care should be taken to apply this only to e.g. identifiers.
|
||||
lookupOrAlloc :: ( FreeVariables t
|
||||
, MonadAddressable (LocationFor a) effects m
|
||||
, MonadEvaluator effects m
|
||||
, MonadAddressable (LocationFor a) m
|
||||
, MonadEvaluator m
|
||||
, a ~ ValueFor m
|
||||
, Semigroup (CellFor a)
|
||||
)
|
||||
=> t
|
||||
-> a
|
||||
-> Environment (LocationFor a) a
|
||||
-> m effects (Name, Address (LocationFor a) a)
|
||||
-> m (Name, Address (LocationFor a) a)
|
||||
lookupOrAlloc term = let [name] = toList (freeVariables term) in
|
||||
lookupOrAlloc' name
|
||||
where
|
||||
-- | Look up or allocate an address for a 'Name' & assign it a given value, returning the 'Name' paired with the address.
|
||||
lookupOrAlloc' :: ( Semigroup (CellFor a)
|
||||
, MonadAddressable (LocationFor a) effects m
|
||||
, MonadAddressable (LocationFor a) m
|
||||
, a ~ ValueFor m
|
||||
, MonadEvaluator effects m
|
||||
, MonadEvaluator m
|
||||
)
|
||||
=> Name
|
||||
-> a
|
||||
-> Environment (LocationFor a) a
|
||||
-> m effects (Name, Address (LocationFor a) a)
|
||||
-> m (Name, Address (LocationFor a) a)
|
||||
lookupOrAlloc' name v env = do
|
||||
a <- maybe (alloc name) pure (envLookup name env)
|
||||
assign a v
|
||||
@ -55,20 +55,20 @@ lookupOrAlloc term = let [name] = toList (freeVariables term) in
|
||||
|
||||
-- | Write a value to the given 'Address' in the 'Store'.
|
||||
assign :: ( Ord (LocationFor a)
|
||||
, MonadEvaluator effects m
|
||||
, MonadEvaluator m
|
||||
, a ~ ValueFor m
|
||||
, Reducer a (CellFor a)
|
||||
)
|
||||
=> Address (LocationFor a) a
|
||||
-> a
|
||||
-> m effects ()
|
||||
-> m ()
|
||||
assign address = modifyStore . storeInsert address
|
||||
|
||||
|
||||
-- Instances
|
||||
|
||||
-- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written.
|
||||
instance (Monad (m effects), MonadEvaluator effects m, LocationFor (ValueFor m) ~ Precise) => MonadAddressable Precise effects m where
|
||||
instance (Monad m, MonadEvaluator m, LocationFor (ValueFor m) ~ Precise) => MonadAddressable Precise m where
|
||||
deref = maybe uninitializedAddress (pure . unLatest) <=< flip fmap getStore . storeLookup
|
||||
where
|
||||
-- | Fail with a message denoting an uninitialized address (i.e. one which was 'alloc'ated, but never 'assign'ed a value before being 'deref'erenced).
|
||||
@ -79,7 +79,7 @@ instance (Monad (m effects), MonadEvaluator effects m, LocationFor (ValueFor m)
|
||||
|
||||
|
||||
-- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically.
|
||||
instance (Alternative (m effects), Ord (ValueFor m), LocationFor (ValueFor m) ~ Monovariant, Monad (m effects), MonadEvaluator effects m) => MonadAddressable Monovariant effects m where
|
||||
instance (Alternative m, Ord (ValueFor m), LocationFor (ValueFor m) ~ Monovariant, Monad m, MonadEvaluator m) => MonadAddressable Monovariant m where
|
||||
deref = asum . maybe [] (map pure . toList) <=< flip fmap getStore . storeLookup
|
||||
|
||||
alloc = pure . Address . Monovariant
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE KindSignatures, MultiParamTypeClasses, TypeFamilies #-}
|
||||
{-# LANGUAGE PolyKinds, TypeFamilies #-}
|
||||
module Control.Abstract.Analysis
|
||||
( MonadAnalysis(..)
|
||||
, evaluateTerm
|
||||
@ -20,23 +20,23 @@ import Prologue
|
||||
-- | A 'Monad' in which one can evaluate some specific term type to some specific value type.
|
||||
--
|
||||
-- This typeclass is left intentionally unconstrained to avoid circular dependencies between it and other typeclasses.
|
||||
class (MonadEvaluator effects m, Recursive (TermFor m)) => MonadAnalysis effects m where
|
||||
class (MonadEvaluator m, Recursive (TermFor m)) => MonadAnalysis m where
|
||||
-- | Analyze a term using the semantics of the current analysis. This should generally only be called by definitions of 'evaluateTerm' and 'analyzeTerm' in this or other instances.
|
||||
analyzeTerm :: SubtermAlgebra (Base (TermFor m)) (TermFor m) (m effects (ValueFor m))
|
||||
analyzeTerm :: SubtermAlgebra (Base (TermFor m)) (TermFor m) (m (ValueFor m))
|
||||
|
||||
evaluateModule :: TermFor m -> m effects (ValueFor m)
|
||||
evaluateModule :: TermFor m -> m (ValueFor m)
|
||||
evaluateModule = evaluateTerm
|
||||
|
||||
-- | Evaluate a term to a value using the semantics of the current analysis.
|
||||
--
|
||||
-- This should always be called when e.g. evaluating the bodies of closures instead of explicitly folding either 'eval' or 'analyzeTerm' over subterms, except in 'MonadAnalysis' instances themselves. On the other hand, top-level evaluation should be performed using 'evaluateModule'.
|
||||
evaluateTerm :: MonadAnalysis effects m => TermFor m -> m effects (ValueFor m)
|
||||
evaluateTerm :: MonadAnalysis m => TermFor m -> m (ValueFor m)
|
||||
evaluateTerm = foldSubterms analyzeTerm
|
||||
|
||||
liftAnalyze :: ( term ~ TermFor ( m)
|
||||
, term ~ TermFor (t m)
|
||||
, value ~ ValueFor ( m)
|
||||
, value ~ ValueFor (t m)
|
||||
liftAnalyze :: ( term ~ TermFor ( m effects)
|
||||
, term ~ TermFor (t m effects)
|
||||
, value ~ ValueFor ( m effects)
|
||||
, value ~ ValueFor (t m effects)
|
||||
, Coercible ( m effects value) (t m effects value)
|
||||
, Coercible (t m effects value) ( m effects value)
|
||||
, Functor (Base term)
|
||||
@ -45,10 +45,10 @@ liftAnalyze :: ( term ~ TermFor ( m)
|
||||
-> SubtermAlgebra (Base term) term (t m effects value)
|
||||
liftAnalyze analyze term = coerce (analyze (second coerce <$> term))
|
||||
|
||||
liftEvaluate :: ( term ~ TermFor ( m)
|
||||
, term ~ TermFor (t m)
|
||||
, value ~ ValueFor ( m)
|
||||
, value ~ ValueFor (t m)
|
||||
liftEvaluate :: ( term ~ TermFor ( m effects)
|
||||
, term ~ TermFor (t m effects)
|
||||
, value ~ ValueFor ( m effects)
|
||||
, value ~ ValueFor (t m effects)
|
||||
, Coercible (m effects value) (t m effects value)
|
||||
)
|
||||
=> (term -> m effects value)
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE ConstrainedClassMethods, DataKinds, KindSignatures, MultiParamTypeClasses, TypeFamilies #-}
|
||||
{-# LANGUAGE ConstrainedClassMethods, TypeFamilies #-}
|
||||
module Control.Abstract.Evaluator where
|
||||
|
||||
import Data.Abstract.Configuration
|
||||
@ -14,41 +14,41 @@ import Prologue
|
||||
-- - environments binding names to addresses
|
||||
-- - a heap mapping addresses to (possibly sets of) values
|
||||
-- - tables of modules available for import
|
||||
class MonadFail (m effects) => MonadEvaluator (effects :: [* -> *]) m where
|
||||
class MonadFail m => MonadEvaluator m where
|
||||
type TermFor m
|
||||
type ValueFor m
|
||||
|
||||
-- | Retrieve the global environment.
|
||||
getGlobalEnv :: m effects (EnvironmentFor (ValueFor m))
|
||||
getGlobalEnv :: m (EnvironmentFor (ValueFor m))
|
||||
-- | Update the global environment.
|
||||
modifyGlobalEnv :: (EnvironmentFor (ValueFor m) -> EnvironmentFor (ValueFor m)) -> m effects ()
|
||||
modifyGlobalEnv :: (EnvironmentFor (ValueFor m) -> EnvironmentFor (ValueFor m)) -> m ()
|
||||
|
||||
-- | Retrieve the local environment.
|
||||
askLocalEnv :: m effects (EnvironmentFor (ValueFor m))
|
||||
askLocalEnv :: m (EnvironmentFor (ValueFor m))
|
||||
-- | Run an action with a locally-modified environment.
|
||||
localEnv :: (EnvironmentFor (ValueFor m) -> EnvironmentFor (ValueFor m)) -> m effects a -> m effects a
|
||||
localEnv :: (EnvironmentFor (ValueFor m) -> EnvironmentFor (ValueFor m)) -> m a -> m a
|
||||
|
||||
-- | Retrieve the heap.
|
||||
getStore :: m effects (StoreFor (ValueFor m))
|
||||
getStore :: m (StoreFor (ValueFor m))
|
||||
-- | Update the heap.
|
||||
modifyStore :: (StoreFor (ValueFor m) -> StoreFor (ValueFor m)) -> m effects ()
|
||||
putStore :: StoreFor (ValueFor m) -> m effects ()
|
||||
modifyStore :: (StoreFor (ValueFor m) -> StoreFor (ValueFor m)) -> m ()
|
||||
putStore :: StoreFor (ValueFor m) -> m ()
|
||||
putStore = modifyStore . const
|
||||
|
||||
-- | Retrieve the table of evaluated modules.
|
||||
getModuleTable :: m effects (ModuleTable (ValueFor m))
|
||||
getModuleTable :: m (ModuleTable (ValueFor m))
|
||||
-- | Update the table of evaluated modules.
|
||||
modifyModuleTable :: (ModuleTable (ValueFor m) -> ModuleTable (ValueFor m)) -> m effects ()
|
||||
modifyModuleTable :: (ModuleTable (ValueFor m) -> ModuleTable (ValueFor m)) -> m ()
|
||||
|
||||
-- | Retrieve the table of unevaluated modules.
|
||||
askModuleTable :: m effects (ModuleTable (TermFor m))
|
||||
askModuleTable :: m (ModuleTable (TermFor m))
|
||||
-- | Run an action with a locally-modified table of unevaluated modules.
|
||||
localModuleTable :: (ModuleTable (TermFor m) -> ModuleTable (TermFor m)) -> m effects a -> m effects a
|
||||
localModuleTable :: (ModuleTable (TermFor m) -> ModuleTable (TermFor m)) -> m a -> m a
|
||||
|
||||
-- | Retrieve the current root set.
|
||||
askRoots :: Ord (LocationFor (ValueFor m)) => m effects (Live (LocationFor (ValueFor m)) (ValueFor m))
|
||||
askRoots :: Ord (LocationFor (ValueFor m)) => m (Live (LocationFor (ValueFor m)) (ValueFor m))
|
||||
askRoots = pure mempty
|
||||
|
||||
-- | Get the current 'Configuration' with a passed-in term.
|
||||
getConfiguration :: Ord (LocationFor (ValueFor m)) => term -> m effects (Configuration (LocationFor (ValueFor m)) term (ValueFor m))
|
||||
getConfiguration :: Ord (LocationFor (ValueFor m)) => term -> m (Configuration (LocationFor (ValueFor m)) term (ValueFor m))
|
||||
getConfiguration term = Configuration term <$> askRoots <*> askLocalEnv <*> getStore
|
||||
|
||||
@ -16,40 +16,41 @@ import Prelude hiding (fail)
|
||||
-- | 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 (MonadEvaluator effects m, v ~ ValueFor m) => MonadValue v effects m where
|
||||
class (MonadEvaluator m, v ~ ValueFor m) => MonadValue v m where
|
||||
-- | Construct an abstract unit value.
|
||||
unit :: m effects v
|
||||
unit :: m v
|
||||
|
||||
-- | Construct an abstract integral value.
|
||||
integer :: Prelude.Integer -> m effects v
|
||||
integer :: Prelude.Integer -> m v
|
||||
|
||||
-- | Construct an abstract boolean value.
|
||||
boolean :: Bool -> m effects v
|
||||
boolean :: Bool -> m v
|
||||
|
||||
-- | Construct an abstract string value.
|
||||
string :: ByteString -> m effects v
|
||||
string :: ByteString -> m v
|
||||
|
||||
-- | Construct a floating-point value.
|
||||
float :: Scientific -> m effects v
|
||||
float :: Scientific -> m v
|
||||
|
||||
-- | Eliminate boolean values. TODO: s/boolean/truthy
|
||||
ifthenelse :: v -> m effects v -> m effects v -> m effects v
|
||||
ifthenelse :: v -> m v -> m v -> m v
|
||||
|
||||
-- | Evaluate an abstraction (a binder like a lambda or method definition).
|
||||
abstract :: [Name] -> Subterm (TermFor m) (m effects v) -> m effects v
|
||||
abstract :: [Name] -> Subterm (TermFor m) (m v) -> m v
|
||||
-- | Evaluate an application (like a function call).
|
||||
apply :: v -> [Subterm (TermFor m) (m effects v)] -> m effects v
|
||||
apply :: v -> [Subterm (TermFor m) (m v)] -> m v
|
||||
|
||||
-- | Construct a 'Value' wrapping the value arguments (if any).
|
||||
instance ( FreeVariables t
|
||||
, MonadAddressable location effects m
|
||||
, MonadAnalysis effects m
|
||||
, MonadAddressable location m
|
||||
, MonadAnalysis m
|
||||
, TermFor m ~ t
|
||||
, ValueFor m ~ Value location t
|
||||
, MonadEvaluator m
|
||||
, Recursive t
|
||||
, Semigroup (Cell location (Value location t))
|
||||
)
|
||||
=> MonadValue (Value location t) effects m where
|
||||
=> MonadValue (Value location t) m where
|
||||
|
||||
unit = pure $ inj Value.Unit
|
||||
integer = pure . inj . Integer
|
||||
@ -73,7 +74,7 @@ instance ( FreeVariables t
|
||||
localEnv (mappend bindings) (evaluateTerm body)
|
||||
|
||||
-- | Discard the value arguments (if any), constructing a 'Type.Type' instead.
|
||||
instance (Alternative (m effects), MonadEvaluator effects m, MonadFresh (m effects), ValueFor m ~ Type) => MonadValue Type effects m where
|
||||
instance (Alternative m, MonadEvaluator m, MonadFresh m, ValueFor m ~ Type) => MonadValue Type m where
|
||||
abstract names (Subterm _ body) = do
|
||||
(env, tvars) <- foldr (\ name rest -> do
|
||||
a <- alloc name
|
||||
|
||||
@ -31,12 +31,12 @@ class Evaluatable constr where
|
||||
eval :: ( term ~ TermFor m
|
||||
, value ~ ValueFor m
|
||||
, FreeVariables term
|
||||
, MonadAddressable (LocationFor value) effects m
|
||||
, MonadAnalysis effects m
|
||||
, MonadValue value effects m
|
||||
, MonadAddressable (LocationFor value) m
|
||||
, MonadAnalysis m
|
||||
, MonadValue value m
|
||||
)
|
||||
=> SubtermAlgebra constr term (m effects value)
|
||||
default eval :: (MonadAnalysis effects m, Show1 constr) => SubtermAlgebra constr term (m effects value)
|
||||
=> SubtermAlgebra constr term (m value)
|
||||
default eval :: (MonadFail m, Show1 constr) => SubtermAlgebra constr term (m value)
|
||||
eval expr = fail $ "Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr ""
|
||||
|
||||
-- | If we can evaluate any syntax which can occur in a 'Union', we can evaluate the 'Union'.
|
||||
@ -74,10 +74,10 @@ instance Evaluatable [] where
|
||||
--
|
||||
-- Looks up the term's name in the cache of evaluated modules first, returns a value if found, otherwise loads/evaluates the module.
|
||||
require :: ( FreeVariables (TermFor m)
|
||||
, MonadAnalysis effects m
|
||||
, MonadAnalysis m
|
||||
)
|
||||
=> TermFor m
|
||||
-> m effects (ValueFor m)
|
||||
-> m (ValueFor m)
|
||||
require term = getModuleTable >>= maybe (load term) pure . moduleTableLookup name
|
||||
where name = moduleName term
|
||||
|
||||
@ -85,10 +85,10 @@ require term = getModuleTable >>= maybe (load term) pure . moduleTableLookup nam
|
||||
--
|
||||
-- Always loads/evaluates.
|
||||
load :: ( FreeVariables (TermFor m)
|
||||
, MonadAnalysis effects m
|
||||
, MonadAnalysis m
|
||||
)
|
||||
=> TermFor m
|
||||
-> m effects (ValueFor m)
|
||||
-> m (ValueFor m)
|
||||
load term = askModuleTable >>= maybe notFound evalAndCache . moduleTableLookup name
|
||||
where name = moduleName term
|
||||
notFound = fail ("cannot find " <> show name)
|
||||
|
||||
@ -44,14 +44,14 @@ evaluateRubyFiles paths = do
|
||||
pure $ evaluates @RubyValue rest first
|
||||
|
||||
-- Python
|
||||
typecheckPythonFile path = run . evaluateModule @(CachingEffects Python.Term Type (EvaluatingEffects Python.Term Type '[])) @(CachingAnalysis (Evaluating Python.Term Type)) . snd <$> parseFile pythonParser path
|
||||
typecheckPythonFile path = run . evaluateModule @(CachingAnalysis (Evaluating Python.Term Type) (CachingEffects Python.Term Type (EvaluatingEffects Python.Term Type '[]))) . snd <$> parseFile pythonParser path
|
||||
|
||||
tracePythonFile path = run . evaluateModule @(Tracer [] Python.Term PythonValue ': (EvaluatingEffects Python.Term PythonValue '[])) @(TracingAnalysis [] (Evaluating Python.Term PythonValue)) . snd <$> parseFile pythonParser path
|
||||
tracePythonFile path = run . evaluateModule @(TracingAnalysis [] (Evaluating Python.Term PythonValue) (Tracer [] Python.Term PythonValue ': (EvaluatingEffects Python.Term PythonValue '[]))) . snd <$> parseFile pythonParser path
|
||||
|
||||
type PythonTracer = TracingAnalysis [] (Evaluating Python.Term PythonValue)
|
||||
type PythonTracerEffects = DeadCode Python.Term ': Tracer [] Python.Term PythonValue ': EvaluatingEffects Python.Term PythonValue '[]
|
||||
|
||||
evaluateDeadTracePythonFile path = run . evaluateModule @PythonTracerEffects @(DeadCodeAnalysis PythonTracer) . snd <$> parseFile pythonParser path
|
||||
evaluateDeadTracePythonFile path = run . evaluateModule @(DeadCodeAnalysis PythonTracer PythonTracerEffects) . snd <$> parseFile pythonParser path
|
||||
|
||||
evaluatePythonFile path = evaluate @PythonValue . snd <$> parseFile pythonParser path
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user