mirror of
https://github.com/github/semantic.git
synced 2024-12-30 02:14:20 +03:00
Split MonadAnalysis into AnalyzeModule & AnalyzeTerm classes.
This commit is contained in:
Rob Rix
parent
da833e9ac7
commit
4108302aed
@ -9,8 +9,9 @@ import Prologue
|
||||
newtype BadAddresses m (effects :: [* -> *]) a = BadAddresses { runBadAddresses :: m effects a }
|
||||
deriving (Alternative, Applicative, Functor, Effectful, Monad)
|
||||
|
||||
deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadAddresses m)
|
||||
deriving instance Evaluator location term value m => Evaluator location term value (BadAddresses m)
|
||||
deriving instance AnalyzeModule location term value inner outer m => AnalyzeModule location term value inner outer (BadAddresses m)
|
||||
deriving instance AnalyzeTerm location term value inner outer m => AnalyzeTerm location term value inner outer (BadAddresses m)
|
||||
|
||||
instance ( Interpreter m effects
|
||||
, Evaluator location term value m
|
||||
|
||||
@ -9,8 +9,9 @@ import Prologue
|
||||
newtype BadModuleResolutions m (effects :: [* -> *]) a = BadModuleResolutions { runBadModuleResolutions :: m effects a }
|
||||
deriving (Alternative, Applicative, Functor, Effectful, Monad)
|
||||
|
||||
deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadModuleResolutions m)
|
||||
deriving instance Evaluator location term value m => Evaluator location term value (BadModuleResolutions m)
|
||||
deriving instance AnalyzeModule location term value inner outer m => AnalyzeModule location term value inner outer (BadModuleResolutions m)
|
||||
deriving instance AnalyzeTerm location term value inner outer m => AnalyzeTerm location term value inner outer (BadModuleResolutions m)
|
||||
|
||||
instance ( Interpreter m effects
|
||||
, Evaluator location term value m
|
||||
|
||||
@ -18,8 +18,9 @@ import Prologue
|
||||
newtype BadSyntax m (effects :: [* -> *]) a = BadSyntax { runBadSyntax :: m effects a }
|
||||
deriving (Alternative, Applicative, Functor, Effectful, Monad)
|
||||
|
||||
deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadSyntax m)
|
||||
deriving instance Evaluator location term value m => Evaluator location term value (BadSyntax m)
|
||||
deriving instance AnalyzeModule location term value inner outer m => AnalyzeModule location term value inner outer (BadSyntax m)
|
||||
deriving instance AnalyzeTerm location term value inner outer m => AnalyzeTerm location term value inner outer (BadSyntax m)
|
||||
|
||||
instance ( AbstractHole value
|
||||
, Evaluator location term value m
|
||||
|
||||
@ -9,8 +9,9 @@ import Prologue
|
||||
newtype BadValues m (effects :: [* -> *]) a = BadValues { runBadValues :: m effects a }
|
||||
deriving (Alternative, Applicative, Functor, Effectful, Monad)
|
||||
|
||||
deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadValues m)
|
||||
deriving instance Evaluator location term value m => Evaluator location term value (BadValues m)
|
||||
deriving instance AnalyzeModule location term value inner outer m => AnalyzeModule location term value inner outer (BadValues m)
|
||||
deriving instance AnalyzeTerm location term value inner outer m => AnalyzeTerm location term value inner outer (BadValues m)
|
||||
|
||||
instance ( AbstractHole value
|
||||
, Evaluator location term value m
|
||||
|
||||
@ -12,8 +12,9 @@ import Prologue
|
||||
newtype BadVariables m (effects :: [* -> *]) a = BadVariables { runBadVariables :: m effects a }
|
||||
deriving (Alternative, Applicative, Functor, Effectful, Monad)
|
||||
|
||||
deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadVariables m)
|
||||
deriving instance Evaluator location term value m => Evaluator location term value (BadVariables m)
|
||||
deriving instance AnalyzeModule location term value inner outer m => AnalyzeModule location term value inner outer (BadVariables m)
|
||||
deriving instance AnalyzeTerm location term value inner outer m => AnalyzeTerm location term value inner outer (BadVariables m)
|
||||
|
||||
instance ( AbstractHole value
|
||||
, Evaluator location term value m
|
||||
|
||||
@ -48,23 +48,20 @@ putCache = raise . put
|
||||
isolateCache :: forall location term value m effects a . (Applicative (m effects), Effectful m, Member (State (Cache location term value)) effects) => m effects a -> m effects (Cache location term value)
|
||||
isolateCache action = putCache @m @location @term @value lowerBound *> action *> raise get
|
||||
|
||||
|
||||
-- | This instance coinductively iterates the analysis of a term until the results converge.
|
||||
instance ( Alternative (m effects)
|
||||
instance ( Alternative (m outer)
|
||||
, AnalyzeTerm location term value inner outer m
|
||||
, Cacheable location term value
|
||||
, Corecursive term
|
||||
, Effectful m
|
||||
, Member Fresh effects
|
||||
, Member NonDet effects
|
||||
, Member (Reader (Cache location term value)) effects
|
||||
, Member (Reader (Live location value)) effects
|
||||
, Member (State (Cache location term value)) effects
|
||||
, MonadAnalysis location term value effects m
|
||||
, Ord (Cell location value)
|
||||
, Ord location
|
||||
, Ord term
|
||||
, Ord value
|
||||
, Member Fresh outer
|
||||
, Member NonDet outer
|
||||
, Member (Reader (Cache location term value)) outer
|
||||
, Member (Reader (Live location value)) outer
|
||||
, Member (State (Cache location term value)) outer
|
||||
, Member (State (Environment location value)) outer
|
||||
, Member (State (Heap location value)) outer
|
||||
)
|
||||
=> MonadAnalysis location term value effects (Caching m) where
|
||||
=> AnalyzeTerm location term value inner outer (Caching m) where
|
||||
-- Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache.
|
||||
analyzeTerm recur e = do
|
||||
c <- getConfiguration (embedSubterm e)
|
||||
@ -73,8 +70,22 @@ instance ( Alternative (m effects)
|
||||
Just pairs -> scatter pairs
|
||||
Nothing -> do
|
||||
pairs <- consultOracle c
|
||||
caching c pairs (liftAnalyze analyzeTerm recur e)
|
||||
caching c pairs (Caching (analyzeTerm (runCaching . recur) e))
|
||||
|
||||
instance ( Alternative (m outer)
|
||||
, AnalyzeModule location term value inner outer m
|
||||
, Cacheable location term value
|
||||
, Corecursive term
|
||||
, Effectful m
|
||||
, Member Fresh outer
|
||||
, Member NonDet outer
|
||||
, Member (Reader (Cache location term value)) outer
|
||||
, Member (Reader (Live location value)) outer
|
||||
, Member (State (Cache location term value)) outer
|
||||
, Member (State (Environment location value)) outer
|
||||
, Member (State (Heap location value)) outer
|
||||
)
|
||||
=> AnalyzeModule location term value inner outer (Caching m) where
|
||||
analyzeModule recur m = do
|
||||
c <- getConfiguration (subterm (moduleBody m))
|
||||
-- Convergence here is predicated upon an Eq instance, not α-equivalence
|
||||
@ -87,9 +98,10 @@ instance ( Alternative (m effects)
|
||||
-- that it doesn't "leak" to the calling context and diverge (otherwise this
|
||||
-- would never complete). We don’t need to use the values, so we 'gather' the
|
||||
-- nondeterministic values into @()@.
|
||||
withOracle prevCache (raiseHandler (gather (const ())) (liftAnalyze analyzeModule recur m))) mempty
|
||||
withOracle prevCache (raiseHandler (gather (const ())) (Caching (analyzeModule (runCaching . recur) m)))) mempty
|
||||
maybe empty scatter (cacheLookup c cache)
|
||||
|
||||
|
||||
reset :: (Effectful m, Member Fresh effects) => Int -> m effects a -> m effects a
|
||||
reset start = raiseHandler (interposeState start (const pure) (\ counter Fresh yield -> (yield $! succ counter) counter))
|
||||
|
||||
|
||||
@ -9,6 +9,7 @@ import Control.Abstract.Analysis
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.Heap
|
||||
import Data.Abstract.Live
|
||||
import Data.Semilattice.Lower
|
||||
import Prologue
|
||||
|
||||
-- | An analysis performing GC after every instruction.
|
||||
@ -16,25 +17,23 @@ newtype Collecting m (effects :: [* -> *]) a = Collecting { runCollecting :: m e
|
||||
deriving (Alternative, Applicative, Effectful, Functor, Monad)
|
||||
|
||||
deriving instance Evaluator location term value m => Evaluator location term value (Collecting m)
|
||||
|
||||
deriving instance AnalyzeModule location term value inner outer m => AnalyzeModule location term value inner outer (Collecting m)
|
||||
|
||||
instance ( Effectful m
|
||||
, Foldable (Cell location)
|
||||
, Member (Reader (Live location value)) effects
|
||||
, MonadAnalysis location term value effects m
|
||||
, Member (Reader (Live location value)) outer
|
||||
, Member (State (Heap location value)) outer
|
||||
, AnalyzeTerm location term value inner outer m
|
||||
, Ord location
|
||||
, ValueRoots location value
|
||||
)
|
||||
=> MonadAnalysis location term value effects (Collecting m) where
|
||||
-- Small-step evaluation which garbage-collects any non-rooted addresses after evaluating each term.
|
||||
=> AnalyzeTerm location term value inner outer (Collecting m) where
|
||||
analyzeTerm recur term = do
|
||||
roots <- askRoots
|
||||
v <- liftAnalyze analyzeTerm recur term
|
||||
v <- Collecting (analyzeTerm (runCollecting . recur) term)
|
||||
modifyHeap (gc (roots <> valueRoots v))
|
||||
pure v
|
||||
|
||||
analyzeModule = liftAnalyze analyzeModule
|
||||
|
||||
|
||||
-- | Collect any addresses in the heap not rooted in or reachable from the given 'Live' set.
|
||||
gc :: ( Ord location
|
||||
@ -64,11 +63,10 @@ reachable roots heap = go mempty roots
|
||||
|
||||
instance ( Evaluator location term value m
|
||||
, Interpreter m effects
|
||||
, Ord location
|
||||
)
|
||||
=> Interpreter (Collecting m) (Reader (Live location value) ': effects) where
|
||||
type Result (Collecting m) (Reader (Live location value) ': effects) result = Result m effects result
|
||||
interpret = interpret . runCollecting . raiseHandler (`runReader` mempty)
|
||||
interpret = interpret . runCollecting . handleReader lowerBound
|
||||
|
||||
|
||||
-- | An analysis providing a 'Live' set, but never performing GC.
|
||||
@ -76,12 +74,12 @@ newtype Retaining m (effects :: [* -> *]) a = Retaining { runRetaining :: m effe
|
||||
deriving (Alternative, Applicative, Effectful, Functor, Monad)
|
||||
|
||||
deriving instance Evaluator location term value m => Evaluator location term value (Retaining m)
|
||||
deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (Retaining m)
|
||||
deriving instance AnalyzeModule location term value inner outer m => AnalyzeModule location term value inner outer (Retaining m)
|
||||
deriving instance AnalyzeTerm location term value inner outer m => AnalyzeTerm location term value inner outer (Retaining m)
|
||||
|
||||
instance ( Evaluator location term value m
|
||||
, Interpreter m effects
|
||||
, Ord location
|
||||
)
|
||||
=> Interpreter (Retaining m) (Reader (Live location value) ': effects) where
|
||||
type Result (Retaining m) (Reader (Live location value) ': effects) result = Result m effects result
|
||||
interpret = interpret . runRetaining . raiseHandler (`runReader` mempty)
|
||||
interpret = interpret . runRetaining . handleReader lowerBound
|
||||
|
||||
@ -38,19 +38,28 @@ subterms term = term `cons` para (foldMap (uncurry cons)) term
|
||||
instance ( Corecursive term
|
||||
, Effectful m
|
||||
, Foldable (Base term)
|
||||
, Member (State (Dead term)) effects
|
||||
, MonadAnalysis location term value effects m
|
||||
, Member (State (Dead term)) outer
|
||||
, AnalyzeTerm location term value inner outer m
|
||||
, Ord term
|
||||
, Recursive term
|
||||
)
|
||||
=> MonadAnalysis location term value effects (DeadCode m) where
|
||||
=> AnalyzeTerm location term value inner outer (DeadCode m) where
|
||||
analyzeTerm recur term = do
|
||||
revive (embedSubterm term)
|
||||
liftAnalyze analyzeTerm recur term
|
||||
DeadCode (analyzeTerm (runDeadCode . recur) term)
|
||||
|
||||
instance ( Corecursive term
|
||||
, Effectful m
|
||||
, Foldable (Base term)
|
||||
, Member (State (Dead term)) outer
|
||||
, AnalyzeModule location term value inner outer m
|
||||
, Ord term
|
||||
, Recursive term
|
||||
)
|
||||
=> AnalyzeModule location term value inner outer (DeadCode m) where
|
||||
analyzeModule recur m = do
|
||||
killAll (subterms (subterm (moduleBody m)))
|
||||
liftAnalyze analyzeModule recur m
|
||||
DeadCode (analyzeModule (runDeadCode . recur) m)
|
||||
|
||||
instance ( Evaluator location term value m
|
||||
, Interpreter m effects
|
||||
|
||||
@ -11,7 +11,8 @@ newtype Erroring (exc :: * -> *) m (effects :: [* -> *]) a = Erroring { runError
|
||||
deriving (Alternative, Applicative, Effectful, Functor, Monad)
|
||||
|
||||
deriving instance Evaluator location term value m => Evaluator location term value (Erroring exc m)
|
||||
deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (Erroring exc m)
|
||||
deriving instance AnalyzeModule location term value inner outer m => AnalyzeModule location term value inner outer (Erroring exc m)
|
||||
deriving instance AnalyzeTerm location term value inner outer m => AnalyzeTerm location term value inner outer (Erroring exc m)
|
||||
|
||||
instance Interpreter m effects
|
||||
=> Interpreter (Erroring exc m) (Resumable exc ': effects) where
|
||||
|
||||
@ -1,12 +1,13 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, UndecidableInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||
module Analysis.Abstract.Evaluating
|
||||
( Evaluating
|
||||
, EvaluatingState(..)
|
||||
) where
|
||||
|
||||
import Control.Abstract.Analysis
|
||||
import qualified Control.Monad.Effect as Eff
|
||||
import qualified Control.Monad.Effect.Internal as Eff
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.Module
|
||||
import Data.Abstract.Origin
|
||||
import Data.Semilattice.Lower
|
||||
import Prologue
|
||||
@ -32,8 +33,7 @@ deriving instance (Show (Cell location value), Show location, Show term, Show va
|
||||
|
||||
-- | Effects necessary for evaluating (whether concrete or abstract).
|
||||
type EvaluatingEffects location term value
|
||||
= '[ EvalClosure term value
|
||||
, Return value
|
||||
= '[ Return value
|
||||
, LoopControl value
|
||||
, Fail -- Failure with an error message
|
||||
, Fresh -- For allocating new addresses and/or type variables.
|
||||
@ -47,24 +47,17 @@ type EvaluatingEffects location term value
|
||||
, State (JumpTable term)
|
||||
]
|
||||
|
||||
instance ( Corecursive term
|
||||
, Member (Reader (Environment location value)) effects
|
||||
, Member (Reader LoadStack) effects
|
||||
, Member (Reader (SomeOrigin term)) effects
|
||||
, Member (State (Environment location value)) effects
|
||||
, Member (State (Heap location value)) effects
|
||||
, Member (State (ModuleTable (Environment location value, value))) effects
|
||||
, Member (State (Exports location value)) effects
|
||||
, Member (State (JumpTable term)) effects
|
||||
, Recursive term
|
||||
)
|
||||
=> MonadAnalysis location term value effects (Evaluating location term value) where
|
||||
analyzeTerm eval term = pushOrigin (termOrigin (embedSubterm term)) (eval term)
|
||||
instance (termInfo ~ Base term (), Recursive term) => AnalyzeTerm location term value (Reader termInfo ': effects) effects (Evaluating location term value) where
|
||||
analyzeTerm eval = handleReader . (() <$) <*> eval . fmap (second (raiseHandler weakenEff))
|
||||
|
||||
analyzeModule eval m = pushOrigin (moduleOrigin (subterm <$> m)) (eval m)
|
||||
instance AnalyzeModule location term value (Reader ModuleInfo ': effects) effects (Evaluating location term value) where
|
||||
analyzeModule eval = handleReader . moduleInfo <*> eval . fmap (second (raiseHandler weakenEff))
|
||||
|
||||
weakenEff :: Eff effects a -> Eff (effect ': effects) a
|
||||
weakenEff (Eff.Val a) = pure a
|
||||
weakenEff (Eff.E u q) = Eff.E (weaken u) (Eff.tsingleton (q Eff.>>> weakenEff))
|
||||
|
||||
instance (AbstractHole value, Show term, Show value) => Interpreter (Evaluating location term value) (EvaluatingEffects location term value) where
|
||||
instance (AbstractHole value, Show value) => Interpreter (Evaluating location term value) (EvaluatingEffects location term value) where
|
||||
type Result (Evaluating location term value) (EvaluatingEffects location term value) result
|
||||
= ( Either String result
|
||||
, EvaluatingState location term value)
|
||||
@ -72,22 +65,21 @@ instance (AbstractHole value, Show term, Show value) => Interpreter (Evaluating
|
||||
= (\ (((((result, env), heap), modules), exports), jumps) -> (result, EvaluatingState env heap modules exports jumps))
|
||||
. interpret
|
||||
. runEvaluating
|
||||
. handleState lowerBound -- State (JumpTable term)
|
||||
. handleState lowerBound -- State (Exports location value)
|
||||
. handleState lowerBound -- State (ModuleTable (Environment location value, value))
|
||||
. handleState lowerBound -- State (Heap location value)
|
||||
. handleState lowerBound -- State (Environment location value)
|
||||
. handleReader lowerBound -- Reader LoadStack
|
||||
. handleReader lowerBound -- Reader (Environment location value)
|
||||
. handleReader lowerBound -- Reader (SomeOrigin term)
|
||||
. raiseHandler
|
||||
( flip runState lowerBound -- State (JumpTable term)
|
||||
. flip runState lowerBound -- State (Exports location value)
|
||||
. flip runState lowerBound -- State (ModuleTable (Environment location value, value))
|
||||
. flip runState lowerBound -- State (Heap location value)
|
||||
. flip runState lowerBound -- State (Environment location value)
|
||||
. flip runReader lowerBound -- Reader LoadStack
|
||||
. flip runReader lowerBound -- Reader (Environment location value)
|
||||
. flip runReader lowerBound -- Reader (SomeOrigin term)
|
||||
. flip runFresh' 0
|
||||
( flip runFresh' 0
|
||||
. runFail
|
||||
-- NB: We should never have a 'Return', 'Break', or 'Continue' at this point in execution; the scope being returned from/broken from/continued should have intercepted the effect. This handler will therefore only be invoked if we issue a 'Return', 'Break', or 'Continue' outside of such a scope, and unfortunately if this happens it will handle it by resuming the scope being returned from. While it would be _slightly_ more correct to instead exit with the value being returned, we aren’t able to do that here since 'Interpreter'’s type is parametric in the value being returned—we don’t know that we’re returning a @value@ (because we very well may not be). On the balance, I felt the strange behaviour in error cases is worth the improved behaviour in the common case—we get to lose a layer of 'Either' in the result for each.
|
||||
-- In general, it’s expected that none of the following effects will remain by the time 'interpret' is called—they should have been handled by local 'interpose's—but if they do, we’ll at least trace.
|
||||
. Eff.interpret (\ control -> case control of
|
||||
Break value -> traceM ("Evaluating.interpret: resuming uncaught break with " <> show value) $> value
|
||||
Continue -> traceM "Evaluating.interpret: resuming uncaught continue with hole" $> hole)
|
||||
. Eff.interpret (\ (Return value) -> traceM ("Evaluating.interpret: resuming uncaught return with " <> show value) $> value)
|
||||
. Eff.interpret (\ (EvalClosure term) -> traceM ("Evaluating.interpret: resuming uncaught EvalClosure of " <> show term <> " with hole") $> hole))
|
||||
. Eff.interpret (\ (Return value) -> traceM ("Evaluating.interpret: resuming uncaught return with " <> show value) $> value))
|
||||
-- TODO: Replace 'traceM's with e.g. 'Telemetry'.
|
||||
|
||||
@ -58,16 +58,18 @@ newtype ImportGraphing m (effects :: [* -> *]) a = ImportGraphing { runImportGra
|
||||
|
||||
deriving instance Evaluator location term value m => Evaluator location term value (ImportGraphing m)
|
||||
|
||||
|
||||
instance ( Effectful m
|
||||
, Member (Resumable (LoadError term)) effects
|
||||
, Member (State ImportGraph) effects
|
||||
instance ( Member (Reader (Environment (Located location term) value)) outer
|
||||
, Member (Reader (SomeOrigin term)) outer
|
||||
, Member (Resumable (LoadError term)) outer
|
||||
, Member (State (Environment (Located location term) value)) outer
|
||||
, Member (State ImportGraph) outer
|
||||
, Element Syntax.Identifier syntax
|
||||
, MonadAnalysis (Located location term) term value effects m
|
||||
, Evaluator (Located location term) term value m
|
||||
, AnalyzeTerm (Located location term) term value inner outer m
|
||||
, term ~ Term (Sum syntax) ann
|
||||
)
|
||||
=> MonadAnalysis (Located location term) term value effects (ImportGraphing m) where
|
||||
analyzeTerm eval term@(In _ syntax) = do
|
||||
=> AnalyzeTerm (Located location term) term value inner outer (ImportGraphing m) where
|
||||
analyzeTerm recur term@(In _ syntax) = do
|
||||
case projectSum syntax of
|
||||
Just (Syntax.Identifier name) -> do
|
||||
moduleInclusion (Variable (unName name))
|
||||
@ -75,14 +77,22 @@ instance ( Effectful m
|
||||
_ -> pure ()
|
||||
resume
|
||||
@(LoadError term)
|
||||
(liftAnalyze analyzeTerm eval term)
|
||||
(\yield (LoadError name) -> moduleInclusion (Module (BC.pack name)) >> yield [])
|
||||
(ImportGraphing (analyzeTerm (runImportGraphing . recur) term))
|
||||
(\yield (LoadError name) -> moduleInclusion (Module (BC.pack name)) *> yield [])
|
||||
|
||||
instance ( Member (Reader (SomeOrigin term)) outer
|
||||
, Member (State ImportGraph) outer
|
||||
, Evaluator (Located location term) term value m
|
||||
, AnalyzeModule (Located location term) term value inner outer m
|
||||
, term ~ Term (Sum syntax) ann
|
||||
)
|
||||
=> AnalyzeModule (Located location term) term value inner outer (ImportGraphing m) where
|
||||
analyzeModule recur m = do
|
||||
let name = BC.pack (modulePath (moduleInfo m))
|
||||
packageInclusion (Module name)
|
||||
moduleInclusion (Module name)
|
||||
liftAnalyze analyzeModule recur m
|
||||
ImportGraphing (analyzeModule (runImportGraphing . recur) m)
|
||||
|
||||
|
||||
packageGraph :: SomeOrigin term -> ImportGraph
|
||||
packageGraph = maybe empty (vertex . Package . unName . packageName) . withSomeOrigin originPackage
|
||||
@ -176,4 +186,4 @@ vertexToType Variable{} = "variable"
|
||||
instance Interpreter m effects
|
||||
=> Interpreter (ImportGraphing m) (State ImportGraph ': effects) where
|
||||
type Result (ImportGraphing m) (State ImportGraph ': effects) result = Result m effects (result, ImportGraph)
|
||||
interpret = interpret . runImportGraphing . raiseHandler (`runState` mempty)
|
||||
interpret = interpret . runImportGraphing . handleState mempty
|
||||
|
||||
@ -18,22 +18,23 @@ newtype Tracing (trace :: * -> *) m (effects :: [* -> *]) a = Tracing { runTraci
|
||||
deriving (Alternative, Applicative, Functor, Effectful, Monad)
|
||||
|
||||
deriving instance Evaluator location term value m => Evaluator location term value (Tracing trace m)
|
||||
deriving instance AnalyzeModule location term value inner outer m => AnalyzeModule location term value inner outer (Tracing trace m)
|
||||
|
||||
instance ( Corecursive term
|
||||
, Effectful m
|
||||
, Member (Reader (Live location value)) effects
|
||||
, Member (Writer (trace (Configuration location term value))) effects
|
||||
, MonadAnalysis location term value effects m
|
||||
, Member (Reader (Live location value)) effectsOut
|
||||
, Member (Writer (trace (Configuration location term value))) effectsOut
|
||||
, AnalyzeTerm location term value effectsIn effectsOut m
|
||||
, Evaluator location term value m
|
||||
, MonadEvaluator location term value effectsOut m
|
||||
, Ord location
|
||||
, Reducer (Configuration location term value) (trace (Configuration location term value))
|
||||
)
|
||||
=> MonadAnalysis location term value effects (Tracing trace m) where
|
||||
=> AnalyzeTerm location term value effectsIn effectsOut (Tracing trace m) where
|
||||
analyzeTerm recur term = do
|
||||
config <- getConfiguration (embedSubterm term)
|
||||
raise (tell @(trace (Configuration location term value)) (Reducer.unit config))
|
||||
liftAnalyze analyzeTerm recur term
|
||||
|
||||
analyzeModule = liftAnalyze analyzeModule
|
||||
Tracing (analyzeTerm (runTracing . recur) term)
|
||||
|
||||
instance ( Evaluator location term value m
|
||||
, Interpreter m effects
|
||||
|
||||
@ -1,5 +1,4 @@
|
||||
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||
|
||||
module Analysis.Abstract.TypeChecking
|
||||
( TypeChecking
|
||||
) where
|
||||
@ -12,7 +11,8 @@ newtype TypeChecking m (effects :: [* -> *]) a = TypeChecking { runTypeChecking
|
||||
deriving (Alternative, Applicative, Functor, Effectful, Monad)
|
||||
|
||||
deriving instance Evaluator location term value m => Evaluator location term value (TypeChecking m)
|
||||
deriving instance MonadAnalysis location term Type effects m => MonadAnalysis location term Type effects (TypeChecking m)
|
||||
deriving instance AnalyzeModule location term value inner outer m => AnalyzeModule location term value inner outer (TypeChecking m)
|
||||
deriving instance AnalyzeTerm location term value inner outer m => AnalyzeTerm location term value inner outer (TypeChecking m)
|
||||
|
||||
instance Interpreter m effects
|
||||
=> Interpreter (TypeChecking m) (Resumable TypeError ': effects) where
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
module Control.Abstract.Analysis
|
||||
( MonadAnalysis(..)
|
||||
, liftAnalyze
|
||||
( AnalyzeTerm(..)
|
||||
, AnalyzeModule(..)
|
||||
, module X
|
||||
) where
|
||||
|
||||
@ -17,25 +17,18 @@ import Control.Monad.Effect.Reader as X
|
||||
import Control.Monad.Effect.State as X
|
||||
import Control.Monad.Effect.Resumable as X
|
||||
import Data.Abstract.Module
|
||||
import Data.Coerce
|
||||
import Data.Type.Coercion
|
||||
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 location term value effects m => MonadAnalysis location term value effects m where
|
||||
-- | A context enabling the analysis of terms, possibly providing effects to underlying analyses.
|
||||
class (Evaluator location term value m, Monad (m outer)) => AnalyzeTerm location term value inner outer m | m inner -> outer, m outer -> inner where
|
||||
-- | Analyze a term using the semantics of the current analysis.
|
||||
analyzeTerm :: (Base term (Subterm term (outer value)) -> m effects value)
|
||||
-> (Base term (Subterm term (outer value)) -> m effects value)
|
||||
analyzeTerm :: Effectful outside
|
||||
=> (Base term (Subterm term (outside inner value)) -> m inner value)
|
||||
-> (Base term (Subterm term (outside outer value)) -> m outer value)
|
||||
|
||||
-- | A context enabling the analysis of modules, possibly providing effects to underlying analyses.
|
||||
class (Evaluator location term value m, Monad (m outer)) => AnalyzeModule location term value inner outer m | m inner -> outer, m outer -> inner where
|
||||
-- | Analyze a module using the semantics of the current analysis. This should generally only be called by 'evaluateModule' and by definitions of 'analyzeModule' in instances for composite analyses.
|
||||
analyzeModule :: (Module (Subterm term (outer value)) -> m effects value)
|
||||
-> (Module (Subterm term (outer value)) -> m effects value)
|
||||
|
||||
|
||||
-- | Lift a 'SubtermAlgebra' for an underlying analysis into a containing analysis. Use this when defining an analysis which can be composed onto other analyses to ensure that a call to 'analyzeTerm' occurs in the inner analysis and not the outer one.
|
||||
liftAnalyze :: Coercible ( m effects value) (t m (effects :: [* -> *]) value)
|
||||
=> ((base (Subterm term (outer value)) -> m effects value) -> (base (Subterm term (outer value)) -> m effects value))
|
||||
-> ((base (Subterm term (outer value)) -> t m effects value) -> (base (Subterm term (outer value)) -> t m effects value))
|
||||
liftAnalyze analyze recur term = coerce (analyze (coerceWith (sym Coercion) . recur) term)
|
||||
analyzeModule :: Effectful outside
|
||||
=> (Module (Subterm term (outside inner value)) -> m inner value)
|
||||
-> (Module (Subterm term (outside outer value)) -> m outer value)
|
||||
|
||||
@ -281,128 +281,113 @@ instance Applicative m => Monoid (Merging m location value) where
|
||||
mappend = (<>)
|
||||
mempty = Merging (pure Nothing)
|
||||
|
||||
type ModuleEffects term value effects = Reader ModuleInfo ': EvalModule term value ': effects
|
||||
evalModule :: forall location term value inner outer m
|
||||
. ( AnalyzeModule location term value inner (EvalModule term value ': outer) m
|
||||
, Member (EvalClosure term value) outer
|
||||
)
|
||||
=> Module term
|
||||
-> m outer value
|
||||
evalModule
|
||||
= evaluatingModules
|
||||
. analyzeModule (subtermValue . moduleBody)
|
||||
. fmap (Subterm <*> evaluateClosureBody)
|
||||
|
||||
-- | Evaluate a (root-level) term to a value using the semantics of the current analysis.
|
||||
evalModule :: forall location term value effects m inner
|
||||
. ( inner ~ ModuleEffects term value effects
|
||||
evaluatingModules :: forall location term value inner outer m a
|
||||
. ( AnalyzeModule location term value inner (EvalModule term value ': outer) m
|
||||
, Member (EvalClosure term value) outer
|
||||
)
|
||||
=> m (EvalModule term value ': outer) a
|
||||
-> m outer a
|
||||
evaluatingModules = raiseHandler (relay pure (\ (EvalModule m) yield -> lower @m (evalModule m) >>= yield))
|
||||
|
||||
evalTerm :: forall location term value inner outer m
|
||||
. ( AnalyzeTerm location term value inner (EvalClosure term value ': outer) m
|
||||
, Evaluatable (Base term)
|
||||
, Member Fail effects
|
||||
, Member (Reader PackageInfo) effects
|
||||
, MonadAnalysis location term value inner m
|
||||
, Member Fail inner
|
||||
, MonadEvaluatable location term value inner m
|
||||
, Recursive term
|
||||
)
|
||||
=> Module term
|
||||
-> m effects value
|
||||
evalModule m
|
||||
= evaluatingModulesWith evalModule
|
||||
. withReader (moduleInfo m)
|
||||
. localLoadStack (loadStackPush (moduleInfo m))
|
||||
$ analyzeModule (subtermValue . moduleBody) (fmap (Subterm <*> evalTerm) m)
|
||||
|
||||
evalTerm :: forall location term value effects m
|
||||
. ( Evaluatable (Base term)
|
||||
, Member (EvalModule term value) effects
|
||||
, Member Fail effects
|
||||
, Member (Reader ModuleInfo) effects
|
||||
, Member (Reader PackageInfo) effects
|
||||
, MonadAnalysis location term value effects m
|
||||
, MonadEvaluatable location term value effects m
|
||||
, Recursive term
|
||||
)
|
||||
=> term
|
||||
-> m effects value
|
||||
=> term
|
||||
-> m outer value
|
||||
evalTerm
|
||||
= handleReturn @m @value (\ (Return value) -> pure value)
|
||||
. raiseHandler (interpose @(EvalClosure term value) pure (\ (EvalClosure term) yield -> lower @m (evalTerm term) >>= yield))
|
||||
= evaluatingClosures
|
||||
. foldSubterms (analyzeTerm eval)
|
||||
|
||||
|
||||
evaluatingModulesWith :: Effectful m => (Module term -> m effects value) -> m (EvalModule term value ': effects) a -> m effects a
|
||||
evaluatingModulesWith evalModule = raiseHandler (relay pure (\ (EvalModule m) yield -> lower (evalModule m) >>= yield))
|
||||
|
||||
withReader :: Effectful m => info -> m (Reader info ': effects) a -> m effects a
|
||||
withReader = raiseHandler . flip runReader
|
||||
evaluatingClosures :: forall location term value inner outer m a
|
||||
. ( AnalyzeTerm location term value inner (EvalClosure term value ': outer) m
|
||||
, Evaluatable (Base term)
|
||||
, Member Fail inner
|
||||
, MonadEvaluatable location term value inner m
|
||||
, Recursive term
|
||||
)
|
||||
=> m (EvalClosure term value ': outer) a
|
||||
-> m outer a
|
||||
evaluatingClosures = raiseHandler (relay pure (\ (EvalClosure m) yield -> lower @m (evalTerm m) >>= yield))
|
||||
|
||||
-- | Evaluate a given package.
|
||||
evaluatePackage :: ( moduleEffects ~ ModuleEffects term value packageEffects
|
||||
, packageEffects ~ (Reader (ModuleTable [Module term]) ': Reader PackageInfo ': effects)
|
||||
evaluatePackage :: ( AnalyzeModule location term value inner (EvalModule term value ': EvalClosure term value ': Reader (ModuleTable [Module term]) ': Reader PackageInfo ': outer) m
|
||||
, AnalyzeTerm location term value inner (EvalClosure term value ': Reader (ModuleTable [Module term]) ': Reader PackageInfo ': outer) m
|
||||
, Evaluatable (Base term)
|
||||
, Member Fail effects
|
||||
, Member (Resumable (AddressError location value)) effects
|
||||
, Member (Resumable (EvalError value)) effects
|
||||
, Member (Resumable (LoadError term)) effects
|
||||
, MonadAddressable location packageEffects m
|
||||
, MonadAnalysis location term value moduleEffects m
|
||||
, MonadEvaluatable location term value moduleEffects m
|
||||
, MonadEvaluator location term value packageEffects m
|
||||
, MonadValue location value packageEffects m
|
||||
, Member Fail inner
|
||||
, Member (Resumable (AddressError location value)) outer
|
||||
, Member (Resumable (EvalError value)) outer
|
||||
, Member (Resumable (LoadError term)) outer
|
||||
, MonadAddressable location (EvalModule term value ': EvalClosure term value ': Reader (ModuleTable [Module term]) ': Reader PackageInfo ': outer) m
|
||||
, MonadEvaluatable location term value inner m
|
||||
, MonadEvaluator location term value (Reader PackageInfo ': outer) m
|
||||
, MonadValue location value (EvalModule term value ': EvalClosure term value ': Reader (ModuleTable [Module term]) ': Reader PackageInfo ': outer) m
|
||||
, Recursive term
|
||||
)
|
||||
=> Package term
|
||||
-> m effects [value]
|
||||
evaluatePackage p = withReader (packageInfo p) (evaluatePackageBody (packageBody p))
|
||||
-> m outer [value]
|
||||
evaluatePackage = handleReader . packageInfo <*> evaluatePackageBody . packageBody
|
||||
|
||||
-- | Evaluate a given package body (module table and entry points).
|
||||
evaluatePackageBody :: ( moduleEffects ~ ModuleEffects term value packageEffects
|
||||
, packageEffects ~ (Reader (ModuleTable [Module term]) ': effects)
|
||||
evaluatePackageBody :: ( AnalyzeModule location term value inner (EvalModule term value ': EvalClosure term value ': Reader (ModuleTable [Module term]) ': outer) m
|
||||
, AnalyzeTerm location term value inner (EvalClosure term value ': Reader (ModuleTable [Module term]) ': outer) m
|
||||
, Evaluatable (Base term)
|
||||
, Member Fail effects
|
||||
, Member (Reader PackageInfo) effects
|
||||
, Member (Resumable (AddressError location value)) effects
|
||||
, Member (Resumable (EvalError value)) effects
|
||||
, Member (Resumable (LoadError term)) effects
|
||||
, MonadAddressable location packageEffects m
|
||||
, MonadAnalysis location term value moduleEffects m
|
||||
, MonadEvaluatable location term value moduleEffects m
|
||||
, MonadEvaluator location term value packageEffects m
|
||||
, MonadValue location value packageEffects m
|
||||
, Member Fail inner
|
||||
, Member (Resumable (AddressError location value)) outer
|
||||
, Member (Resumable (EvalError value)) outer
|
||||
, Member (Resumable (LoadError term)) outer
|
||||
, MonadAddressable location (EvalModule term value ': EvalClosure term value ': Reader (ModuleTable [Module term]) ': outer) m
|
||||
, MonadEvaluatable location term value inner m
|
||||
, MonadEvaluator location term value outer m
|
||||
, MonadValue location value (EvalModule term value ': EvalClosure term value ': Reader (ModuleTable [Module term]) ': outer) m
|
||||
, Recursive term
|
||||
)
|
||||
=> PackageBody term
|
||||
-> m effects [value]
|
||||
-> m outer [value]
|
||||
evaluatePackageBody body
|
||||
= withReader (packageModules body)
|
||||
= handleReader (packageModules body)
|
||||
. evaluatingClosures
|
||||
. evaluatingModules
|
||||
. withPrelude (packagePrelude body)
|
||||
$ traverse (uncurry evaluateEntryPoint) (ModuleTable.toPairs (packageEntryPoints body))
|
||||
|
||||
evaluateEntryPoint :: ( inner ~ ModuleEffects term value effects
|
||||
, Evaluatable (Base term)
|
||||
evaluateEntryPoint :: ( Member (EvalModule term value) effects
|
||||
, Member (Reader (ModuleTable [Module term])) effects
|
||||
, Member (Resumable (AddressError location value)) effects
|
||||
, Member (Resumable (EvalError value)) effects
|
||||
, Member (Resumable (LoadError term)) effects
|
||||
, Member Fail effects
|
||||
, Member (Reader PackageInfo) effects
|
||||
, MonadAddressable location effects m
|
||||
, MonadAnalysis location term value inner m
|
||||
, MonadEvaluatable location term value inner m
|
||||
, MonadEvaluator location term value effects m
|
||||
, MonadValue location value effects m
|
||||
, Recursive term
|
||||
)
|
||||
=> ModulePath
|
||||
-> Maybe Name
|
||||
-> m effects value
|
||||
evaluateEntryPoint m sym = do
|
||||
v <- maybe unit (pure . snd) <$> requireWith evalModule m
|
||||
v <- maybe unit (pure . snd) <$> require m
|
||||
maybe v ((`call` []) <=< variable) sym
|
||||
|
||||
withPrelude :: forall location term value effects m a inner
|
||||
. ( inner ~ ModuleEffects term value effects
|
||||
, Evaluatable (Base term)
|
||||
, Member Fail effects
|
||||
, Member (Reader PackageInfo) effects
|
||||
, MonadAnalysis location term value inner m
|
||||
, MonadEvaluatable location term value inner m
|
||||
withPrelude :: ( Member (EvalModule term value) effects
|
||||
, MonadEvaluator location term value effects m
|
||||
, Recursive term
|
||||
)
|
||||
=> Maybe (Module term)
|
||||
-> m effects a
|
||||
-> m effects a
|
||||
withPrelude Nothing a = a
|
||||
withPrelude (Just prelude) a = do
|
||||
preludeEnv <- evalModule @location @term @value prelude *> getEnv
|
||||
preludeEnv <- evaluateModule prelude *> getEnv
|
||||
withDefaultEnvironment preludeEnv a
|
||||
|
||||
Loading…
Reference in New Issue
Block a user