mirror of
https://github.com/github/semantic.git
synced 2024-11-28 01:47:01 +03:00
Merge remote-tracking branch 'origin/master' into module-resolution
This commit is contained in:
Timothy Clem
commit
69a46e4edc
@ -54,9 +54,12 @@ library
|
||||
, Data.Abstract.FreeVariables
|
||||
, Data.Abstract.Heap
|
||||
, Data.Abstract.Live
|
||||
, Data.Abstract.Located
|
||||
, Data.Abstract.Module
|
||||
, Data.Abstract.ModuleTable
|
||||
, Data.Abstract.Number
|
||||
, Data.Abstract.Origin
|
||||
, Data.Abstract.Package
|
||||
, Data.Abstract.Path
|
||||
, Data.Abstract.Type
|
||||
, Data.Abstract.Value
|
||||
|
||||
@ -12,19 +12,19 @@ newtype BadVariables m (effects :: [* -> *]) a = BadVariables (m effects a)
|
||||
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
|
||||
|
||||
deriving instance MonadControl term (m effects) => MonadControl term (BadVariables m effects)
|
||||
deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (BadVariables m effects)
|
||||
deriving instance MonadHeap value (m effects) => MonadHeap value (BadVariables m effects)
|
||||
deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (BadVariables m effects)
|
||||
deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (BadVariables m effects)
|
||||
deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (BadVariables m effects)
|
||||
deriving instance MonadHeap location value (m effects) => MonadHeap location value (BadVariables m effects)
|
||||
deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (BadVariables m effects)
|
||||
deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (BadVariables m effects)
|
||||
|
||||
instance ( Effectful m
|
||||
, Member (Resumable (EvalError value)) effects
|
||||
, Member (State [Name]) effects
|
||||
, MonadAnalysis term value (m effects)
|
||||
, MonadValue value (BadVariables m effects)
|
||||
, MonadAnalysis location term value (m effects)
|
||||
, MonadValue location value (BadVariables m effects)
|
||||
)
|
||||
=> MonadAnalysis term value (BadVariables m effects) where
|
||||
type Effects term value (BadVariables m effects) = State [Name] ': Effects term value (m effects)
|
||||
=> MonadAnalysis location term value (BadVariables m effects) where
|
||||
type Effects location term value (BadVariables m effects) = State [Name] ': Effects location term value (m effects)
|
||||
|
||||
analyzeTerm eval term = resumeException @(EvalError value) (liftAnalyze analyzeTerm eval term) (
|
||||
\yield (FreeVariableError name) ->
|
||||
|
||||
@ -4,6 +4,7 @@ module Analysis.Abstract.Caching
|
||||
) where
|
||||
|
||||
import Control.Abstract.Analysis
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.Cache
|
||||
import Data.Abstract.Configuration
|
||||
import Data.Abstract.Heap
|
||||
@ -11,50 +12,46 @@ import Data.Abstract.Module
|
||||
import Prologue
|
||||
|
||||
-- | The effects necessary for caching analyses.
|
||||
type CachingEffects term value effects
|
||||
= Fresh -- For 'MonadFresh'.
|
||||
': NonDet -- For 'Alternative' and 'MonadNonDet'.
|
||||
': Reader (CacheFor term value) -- The in-cache used as an oracle while converging on a result.
|
||||
': State (CacheFor term value) -- The out-cache used to record results in each iteration of convergence.
|
||||
type CachingEffects location term value effects
|
||||
= NonDet -- For 'Alternative' and 'MonadNonDet'.
|
||||
': Reader (Cache location term value) -- The in-cache used as an oracle while converging on a result.
|
||||
': State (Cache location term value) -- The out-cache used to record results in each iteration of convergence.
|
||||
': effects
|
||||
|
||||
-- | The cache for term and abstract value types.
|
||||
type CacheFor term value = Cache (LocationFor value) term value
|
||||
|
||||
-- | A (coinductively-)cached analysis suitable for guaranteeing termination of (suitably finitized) analyses over recursive programs.
|
||||
newtype Caching m (effects :: [* -> *]) a = Caching (m effects a)
|
||||
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
|
||||
|
||||
deriving instance MonadControl term (m effects) => MonadControl term (Caching m effects)
|
||||
deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (Caching m effects)
|
||||
deriving instance MonadHeap value (m effects) => MonadHeap value (Caching m effects)
|
||||
deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Caching m effects)
|
||||
deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Caching m effects)
|
||||
deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (Caching m effects)
|
||||
deriving instance MonadHeap location value (m effects) => MonadHeap location value (Caching m effects)
|
||||
deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (Caching m effects)
|
||||
deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (Caching m effects)
|
||||
|
||||
-- | Functionality used to perform caching analysis. This is not exported, and exists primarily for organizational reasons.
|
||||
class MonadEvaluator term value m => MonadCaching term value m where
|
||||
class MonadEvaluator location term value m => MonadCaching location term value m where
|
||||
-- | Look up the set of values for a given configuration in the in-cache.
|
||||
consultOracle :: ConfigurationFor term value -> m (Set (value, HeapFor value))
|
||||
consultOracle :: Configuration location term value -> m (Set (value, Heap location value))
|
||||
-- | Run an action with the given in-cache.
|
||||
withOracle :: CacheFor term value -> m a -> m a
|
||||
withOracle :: Cache location term value -> m a -> m a
|
||||
|
||||
-- | Look up the set of values for a given configuration in the out-cache.
|
||||
lookupCache :: ConfigurationFor term value -> m (Maybe (Set (value, HeapFor value)))
|
||||
lookupCache :: Configuration location term value -> m (Maybe (Set (value, Heap location value)))
|
||||
-- | Run an action, caching its result and 'Heap' under the given configuration.
|
||||
caching :: ConfigurationFor term value -> Set (value, HeapFor value) -> m value -> m value
|
||||
caching :: Configuration location term value -> Set (value, Heap location value) -> m value -> m value
|
||||
|
||||
-- | Run an action starting from an empty out-cache, and return the out-cache afterwards.
|
||||
isolateCache :: m a -> m (CacheFor term value)
|
||||
isolateCache :: m a -> m (Cache location term value)
|
||||
|
||||
instance ( Effectful m
|
||||
, Members (CachingEffects term value '[]) effects
|
||||
, MonadEvaluator term value (m effects)
|
||||
, Ord (CellFor value)
|
||||
, Ord (LocationFor value)
|
||||
, Members (CachingEffects location term value '[]) effects
|
||||
, MonadEvaluator location term value (m effects)
|
||||
, Ord (Cell location value)
|
||||
, Ord location
|
||||
, Ord term
|
||||
, Ord value
|
||||
)
|
||||
=> MonadCaching term value (Caching m effects) where
|
||||
=> MonadCaching location term value (Caching m effects) where
|
||||
consultOracle configuration = raise (fromMaybe mempty . cacheLookup configuration <$> ask)
|
||||
withOracle cache = raise . local (const cache) . lower
|
||||
|
||||
@ -65,23 +62,23 @@ instance ( Effectful m
|
||||
raise (modify (cacheInsert configuration result))
|
||||
pure (fst result)
|
||||
|
||||
isolateCache action = raise (put (mempty :: CacheFor term value)) *> action *> raise get
|
||||
isolateCache action = raise (put (mempty :: Cache location term value)) *> action *> raise get
|
||||
|
||||
-- | This instance coinductively iterates the analysis of a term until the results converge.
|
||||
instance ( Corecursive term
|
||||
, Effectful m
|
||||
, Members (CachingEffects term value '[]) effects
|
||||
, MonadAnalysis term value (m effects)
|
||||
, Members (CachingEffects location term value '[]) effects
|
||||
, MonadAnalysis location term value (m effects)
|
||||
, MonadFresh (m effects)
|
||||
, MonadNonDet (m effects)
|
||||
, Ord (CellFor value)
|
||||
, Ord (LocationFor value)
|
||||
, Ord (Cell location value)
|
||||
, Ord location
|
||||
, Ord term
|
||||
, Ord value
|
||||
)
|
||||
=> MonadAnalysis term value (Caching m effects) where
|
||||
=> MonadAnalysis location term value (Caching m effects) where
|
||||
-- We require the 'CachingEffects' in addition to the underlying analysis’ 'Effects'.
|
||||
type Effects term value (Caching m effects) = CachingEffects term value (Effects term value (m effects))
|
||||
type Effects location term value (Caching m effects) = CachingEffects location term value (Effects location term value (m effects))
|
||||
|
||||
-- Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache.
|
||||
analyzeTerm recur e = do
|
||||
@ -124,5 +121,5 @@ converge f = loop
|
||||
loop x'
|
||||
|
||||
-- | Nondeterministically write each of a collection of stores & return their associated results.
|
||||
scatter :: (Alternative m, Foldable t, MonadEvaluator term value m) => t (a, Heap (LocationFor value) value) -> m a
|
||||
scatter :: (Alternative m, Foldable t, MonadEvaluator location term value m) => t (a, Heap location value) -> m a
|
||||
scatter = foldMapA (\ (value, heap') -> putHeap heap' $> value)
|
||||
|
||||
@ -14,31 +14,29 @@ newtype Collecting m (effects :: [* -> *]) a = Collecting (m effects a)
|
||||
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
|
||||
|
||||
deriving instance MonadControl term (m effects) => MonadControl term (Collecting m effects)
|
||||
deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (Collecting m effects)
|
||||
deriving instance MonadHeap value (m effects) => MonadHeap value (Collecting m effects)
|
||||
deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Collecting m effects)
|
||||
deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (Collecting m effects)
|
||||
deriving instance MonadHeap location value (m effects) => MonadHeap location value (Collecting m effects)
|
||||
deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (Collecting m effects)
|
||||
|
||||
instance ( Effectful m
|
||||
, Member (Reader (Live (LocationFor value) value)) effects
|
||||
, MonadEvaluator term value (m effects)
|
||||
, Member (Reader (Live location value)) effects
|
||||
, MonadEvaluator location term value (m effects)
|
||||
)
|
||||
=> MonadEvaluator term value (Collecting m effects) where
|
||||
=> MonadEvaluator location term value (Collecting m effects) where
|
||||
getConfiguration term = Configuration term <$> askRoots <*> getEnv <*> getHeap
|
||||
|
||||
askModuleStack = Collecting askModuleStack
|
||||
|
||||
|
||||
instance ( Effectful m
|
||||
, Foldable (Cell (LocationFor value))
|
||||
, Member (Reader (Live (LocationFor value) value)) effects
|
||||
, MonadAnalysis term value (m effects)
|
||||
, Ord (LocationFor value)
|
||||
, ValueRoots value
|
||||
, Foldable (Cell location)
|
||||
, Member (Reader (Live location value)) effects
|
||||
, MonadAnalysis location term value (m effects)
|
||||
, Ord location
|
||||
, ValueRoots location value
|
||||
)
|
||||
=> MonadAnalysis term value (Collecting m effects) where
|
||||
type Effects term value (Collecting m effects)
|
||||
= Reader (Live (LocationFor value) value)
|
||||
': Effects term value (m effects)
|
||||
=> MonadAnalysis location term value (Collecting m effects) where
|
||||
type Effects location term value (Collecting m effects)
|
||||
= Reader (Live location value)
|
||||
': Effects location term value (m effects)
|
||||
|
||||
-- Small-step evaluation which garbage-collects any non-rooted addresses after evaluating each term.
|
||||
analyzeTerm recur term = do
|
||||
@ -51,32 +49,32 @@ instance ( Effectful m
|
||||
|
||||
|
||||
-- | Retrieve the local 'Live' set.
|
||||
askRoots :: (Effectful m, Member (Reader (Live (LocationFor value) value)) effects) => m effects (Live (LocationFor value) value)
|
||||
askRoots :: (Effectful m, Member (Reader (Live location value)) effects) => m effects (Live location value)
|
||||
askRoots = raise ask
|
||||
|
||||
-- | Run a computation with the given 'Live' set added to the local root set.
|
||||
-- extraRoots :: (Effectful m, Member (Reader (Live (LocationFor value) value)) effects, Ord (LocationFor value)) => Live (LocationFor value) value -> m effects a -> m effects a
|
||||
-- extraRoots :: (Effectful m, Member (Reader (Live location value)) effects, Ord location) => Live location value -> m effects a -> m effects a
|
||||
-- extraRoots roots = raise . local (<> roots) . lower
|
||||
|
||||
|
||||
-- | Collect any addresses in the heap not rooted in or reachable from the given 'Live' set.
|
||||
gc :: ( Ord (LocationFor value)
|
||||
, Foldable (Cell (LocationFor value))
|
||||
, ValueRoots value
|
||||
gc :: ( Ord location
|
||||
, Foldable (Cell location)
|
||||
, ValueRoots location value
|
||||
)
|
||||
=> LiveFor value -- ^ The set of addresses to consider rooted.
|
||||
-> HeapFor value -- ^ A heap to collect unreachable addresses within.
|
||||
-> HeapFor value -- ^ A garbage-collected heap.
|
||||
=> Live location value -- ^ The set of addresses to consider rooted.
|
||||
-> Heap location value -- ^ A heap to collect unreachable addresses within.
|
||||
-> Heap location 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 (LocationFor value)
|
||||
, Foldable (Cell (LocationFor value))
|
||||
, ValueRoots value
|
||||
reachable :: ( Ord location
|
||||
, Foldable (Cell location)
|
||||
, ValueRoots location value
|
||||
)
|
||||
=> LiveFor value -- ^ The set of root addresses.
|
||||
-> HeapFor value -- ^ The heap to trace addresses through.
|
||||
-> LiveFor value -- ^ The set of addresses reachable from the root set.
|
||||
=> Live location value -- ^ The set of root addresses.
|
||||
-> Heap location value -- ^ The heap to trace addresses through.
|
||||
-> Live location value -- ^ 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
|
||||
|
||||
@ -14,10 +14,10 @@ newtype DeadCode m (effects :: [* -> *]) a = DeadCode (m effects a)
|
||||
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
|
||||
|
||||
deriving instance MonadControl term (m effects) => MonadControl term (DeadCode m effects)
|
||||
deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (DeadCode m effects)
|
||||
deriving instance MonadHeap value (m effects) => MonadHeap value (DeadCode m effects)
|
||||
deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (DeadCode m effects)
|
||||
deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (DeadCode m effects)
|
||||
deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (DeadCode m effects)
|
||||
deriving instance MonadHeap location value (m effects) => MonadHeap location value (DeadCode m effects)
|
||||
deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (DeadCode m effects)
|
||||
deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (DeadCode m effects)
|
||||
|
||||
-- | A set of “dead” (unreachable) terms.
|
||||
newtype Dead term = Dead { unDead :: Set term }
|
||||
@ -42,12 +42,12 @@ instance ( Corecursive term
|
||||
, Effectful m
|
||||
, Foldable (Base term)
|
||||
, Member (State (Dead term)) effects
|
||||
, MonadAnalysis term value (m effects)
|
||||
, MonadAnalysis location term value (m effects)
|
||||
, Ord term
|
||||
, Recursive term
|
||||
)
|
||||
=> MonadAnalysis term value (DeadCode m effects) where
|
||||
type Effects term value (DeadCode m effects) = State (Dead term) ': Effects term value (m effects)
|
||||
=> MonadAnalysis location term value (DeadCode m effects) where
|
||||
type Effects location term value (DeadCode m effects) = State (Dead term) ': Effects location term value (m effects)
|
||||
|
||||
analyzeTerm recur term = do
|
||||
revive (embedSubterm term)
|
||||
|
||||
@ -6,80 +6,85 @@ module Analysis.Abstract.Evaluating
|
||||
|
||||
import Control.Abstract.Analysis
|
||||
import Control.Monad.Effect
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.Configuration
|
||||
import qualified Data.Abstract.Environment as Env
|
||||
import Data.Abstract.Environment as Env
|
||||
import Data.Abstract.Evaluatable
|
||||
import Data.Abstract.Exports
|
||||
import Data.Abstract.Heap
|
||||
import Data.Abstract.Module
|
||||
import Data.Abstract.ModuleTable
|
||||
import Data.Abstract.Origin
|
||||
import qualified Data.IntMap as IntMap
|
||||
import Lens.Micro
|
||||
import Prelude hiding (fail)
|
||||
import Prologue
|
||||
|
||||
-- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@.
|
||||
newtype Evaluating term value effects a = Evaluating (Eff effects a)
|
||||
newtype Evaluating location term value effects a = Evaluating (Eff effects a)
|
||||
deriving (Applicative, Functor, Effectful, Monad)
|
||||
|
||||
deriving instance Member Fail effects => MonadFail (Evaluating term value effects)
|
||||
deriving instance Member Fresh effects => MonadFresh (Evaluating term value effects)
|
||||
deriving instance Member NonDet effects => Alternative (Evaluating term value effects)
|
||||
deriving instance Member NonDet effects => MonadNonDet (Evaluating term value effects)
|
||||
deriving instance Member Fail effects => MonadFail (Evaluating location term value effects)
|
||||
deriving instance Member Fresh effects => MonadFresh (Evaluating location term value effects)
|
||||
deriving instance Member NonDet effects => Alternative (Evaluating location term value effects)
|
||||
deriving instance Member NonDet effects => MonadNonDet (Evaluating location term value effects)
|
||||
|
||||
-- | Effects necessary for evaluating (whether concrete or abstract).
|
||||
type EvaluatingEffects term value
|
||||
type EvaluatingEffects location term value
|
||||
= '[ Resumable (EvalError value)
|
||||
, Resumable (LoadError term value)
|
||||
, Resumable (ValueExc value)
|
||||
, Resumable (ValueExc location value)
|
||||
, Resumable (Unspecialized value)
|
||||
, Fail -- Failure with an error message
|
||||
, Reader [Module term] -- The stack of currently-evaluating modules.
|
||||
, Fresh -- For allocating new addresses and/or type variables.
|
||||
, Reader (SomeOrigin term) -- The current term’s origin.
|
||||
, Reader (ModuleTable [Module term]) -- Cache of unevaluated modules
|
||||
, Reader (EnvironmentFor value) -- Default environment used as a fallback in lookupEnv
|
||||
, State (EvaluatingState term value) -- Environment, heap, modules, exports, and jumps.
|
||||
, Reader (Environment location value) -- Default environment used as a fallback in lookupEnv
|
||||
, State (EvaluatingState location term value) -- Environment, heap, modules, exports, and jumps.
|
||||
]
|
||||
|
||||
data EvaluatingState term value = EvaluatingState
|
||||
{ environment :: EnvironmentFor value
|
||||
, heap :: HeapFor value
|
||||
, modules :: ModuleTable (EnvironmentFor value, value)
|
||||
, exports :: ExportsFor value
|
||||
data EvaluatingState location term value = EvaluatingState
|
||||
{ environment :: Environment location value
|
||||
, heap :: Heap location value
|
||||
, modules :: ModuleTable (Environment location value, value)
|
||||
, exports :: Exports location value
|
||||
, jumps :: IntMap.IntMap term
|
||||
}
|
||||
|
||||
deriving instance (Eq (CellFor value), Eq (LocationFor value), Eq term, Eq value) => Eq (EvaluatingState term value)
|
||||
deriving instance (Ord (CellFor value), Ord (LocationFor value), Ord term, Ord value) => Ord (EvaluatingState term value)
|
||||
deriving instance (Show (CellFor value), Show (LocationFor value), Show term, Show value) => Show (EvaluatingState term value)
|
||||
deriving instance (Eq (Cell location value), Eq location, Eq term, Eq value) => Eq (EvaluatingState location term value)
|
||||
deriving instance (Ord (Cell location value), Ord location, Ord term, Ord value) => Ord (EvaluatingState location term value)
|
||||
deriving instance (Show (Cell location value), Show location, Show term, Show value) => Show (EvaluatingState location term value)
|
||||
|
||||
instance (Ord (LocationFor value), Semigroup (CellFor value)) => Semigroup (EvaluatingState term value) where
|
||||
instance (Ord location, Semigroup (Cell location value)) => Semigroup (EvaluatingState location term value) where
|
||||
EvaluatingState e1 h1 m1 x1 j1 <> EvaluatingState e2 h2 m2 x2 j2 = EvaluatingState (e1 <> e2) (h1 <> h2) (m1 <> m2) (x1 <> x2) (j1 <> j2)
|
||||
|
||||
instance (Ord (LocationFor value), Semigroup (CellFor value)) => Monoid (EvaluatingState term value) where
|
||||
instance (Ord location, Semigroup (Cell location value)) => Monoid (EvaluatingState location term value) where
|
||||
mempty = EvaluatingState mempty mempty mempty mempty mempty
|
||||
mappend = (<>)
|
||||
|
||||
_environment :: Lens' (EvaluatingState term value) (EnvironmentFor value)
|
||||
_environment :: Lens' (EvaluatingState location term value) (Environment location value)
|
||||
_environment = lens environment (\ s e -> s {environment = e})
|
||||
|
||||
_heap :: Lens' (EvaluatingState term value) (HeapFor value)
|
||||
_heap :: Lens' (EvaluatingState location term value) (Heap location value)
|
||||
_heap = lens heap (\ s h -> s {heap = h})
|
||||
|
||||
_modules :: Lens' (EvaluatingState term value) (ModuleTable (EnvironmentFor value, value))
|
||||
_modules :: Lens' (EvaluatingState location term value) (ModuleTable (Environment location value, value))
|
||||
_modules = lens modules (\ s m -> s {modules = m})
|
||||
|
||||
_exports :: Lens' (EvaluatingState term value) (ExportsFor value)
|
||||
_exports :: Lens' (EvaluatingState location term value) (Exports location value)
|
||||
_exports = lens exports (\ s e -> s {exports = e})
|
||||
|
||||
_jumps :: Lens' (EvaluatingState term value) (IntMap.IntMap term)
|
||||
_jumps :: Lens' (EvaluatingState location term value) (IntMap.IntMap term)
|
||||
_jumps = lens jumps (\ s j -> s {jumps = j})
|
||||
|
||||
|
||||
(.=) :: Member (State (EvaluatingState term value)) effects => ASetter (EvaluatingState term value) (EvaluatingState term value) a b -> b -> Evaluating term value effects ()
|
||||
(.=) :: Member (State (EvaluatingState location term value)) effects => ASetter (EvaluatingState location term value) (EvaluatingState location term value) a b -> b -> Evaluating location term value effects ()
|
||||
lens .= val = raise (modify' (lens .~ val))
|
||||
|
||||
view :: Member (State (EvaluatingState term value)) effects => Getting a (EvaluatingState term value) a -> Evaluating term value effects a
|
||||
view :: Member (State (EvaluatingState location term value)) effects => Getting a (EvaluatingState location term value) a -> Evaluating location term value effects a
|
||||
view lens = raise (gets (^. lens))
|
||||
|
||||
localEvaluatingState :: Member (State (EvaluatingState term value)) effects => Lens' (EvaluatingState term value) prj -> (prj -> prj) -> Evaluating term value effects a -> Evaluating term value effects a
|
||||
localEvaluatingState :: Member (State (EvaluatingState location term value)) effects => Lens' (EvaluatingState location term value) prj -> (prj -> prj) -> Evaluating location term value effects a -> Evaluating location term value effects a
|
||||
localEvaluatingState lens f action = do
|
||||
original <- view lens
|
||||
lens .= f original
|
||||
@ -87,7 +92,7 @@ localEvaluatingState lens f action = do
|
||||
v <$ lens .= original
|
||||
|
||||
|
||||
instance Members '[Fail, State (EvaluatingState term value)] effects => MonadControl term (Evaluating term value effects) where
|
||||
instance Members '[Fail, State (EvaluatingState location term value)] effects => MonadControl term (Evaluating location term value effects) where
|
||||
label term = do
|
||||
m <- view _jumps
|
||||
let i = IntMap.size m
|
||||
@ -96,10 +101,10 @@ instance Members '[Fail, State (EvaluatingState term value)] effects => MonadCon
|
||||
|
||||
goto label = IntMap.lookup label <$> view _jumps >>= maybe (fail ("unknown label: " <> show label)) pure
|
||||
|
||||
instance Members '[ State (EvaluatingState term value)
|
||||
, Reader (EnvironmentFor value)
|
||||
instance Members '[ State (EvaluatingState location term value)
|
||||
, Reader (Environment location value)
|
||||
] effects
|
||||
=> MonadEnvironment value (Evaluating term value effects) where
|
||||
=> MonadEnvironment location value (Evaluating location term value effects) where
|
||||
getEnv = view _environment
|
||||
putEnv = (_environment .=)
|
||||
withEnv s = localEvaluatingState _environment (const s)
|
||||
@ -116,31 +121,31 @@ instance Members '[ State (EvaluatingState term value)
|
||||
result <- a
|
||||
result <$ modifyEnv Env.pop
|
||||
|
||||
instance Member (State (EvaluatingState term value)) effects => MonadHeap value (Evaluating term value effects) where
|
||||
instance Member (State (EvaluatingState location term value)) effects
|
||||
=> MonadHeap location value (Evaluating location term value effects) where
|
||||
getHeap = view _heap
|
||||
putHeap = (_heap .=)
|
||||
|
||||
instance Members '[Reader (ModuleTable [Module term]), State (EvaluatingState term value)] effects => MonadModuleTable term value (Evaluating term value effects) where
|
||||
instance Members '[Reader (ModuleTable [Module term]), State (EvaluatingState location term value)] effects
|
||||
=> MonadModuleTable location term value (Evaluating location term value effects) where
|
||||
getModuleTable = view _modules
|
||||
putModuleTable = (_modules .=)
|
||||
|
||||
askModuleTable = raise ask
|
||||
localModuleTable f a = raise (local f (lower a))
|
||||
|
||||
instance Members (EvaluatingEffects term value) effects => MonadEvaluator term value (Evaluating term value effects) where
|
||||
instance Members (EvaluatingEffects location term value) effects
|
||||
=> MonadEvaluator location term value (Evaluating location term value effects) where
|
||||
getConfiguration term = Configuration term mempty <$> getEnv <*> getHeap
|
||||
|
||||
askModuleStack = raise ask
|
||||
|
||||
instance ( Members (EvaluatingEffects term value) effects
|
||||
, MonadValue value (Evaluating term value effects)
|
||||
instance ( Corecursive term
|
||||
, Members (EvaluatingEffects location term value) effects
|
||||
, MonadValue location value (Evaluating location term value effects)
|
||||
, Recursive term
|
||||
)
|
||||
=> MonadAnalysis term value (Evaluating term value effects) where
|
||||
type Effects term value (Evaluating term value effects) = EvaluatingEffects term value
|
||||
=> MonadAnalysis location term value (Evaluating location term value effects) where
|
||||
type Effects location term value (Evaluating location term value effects) = EvaluatingEffects location term value
|
||||
|
||||
analyzeTerm = id
|
||||
analyzeTerm eval term = pushOrigin (termOrigin (embedSubterm term)) (eval term)
|
||||
|
||||
analyzeModule eval m = pushModule (subterm <$> m) (eval m)
|
||||
|
||||
pushModule :: Member (Reader [Module term]) effects => Module term -> Evaluating term value effects a -> Evaluating term value effects a
|
||||
pushModule m = raise . local (m :) . lower
|
||||
analyzeModule eval m = pushOrigin (moduleOrigin (subterm <$> m)) (eval m)
|
||||
|
||||
@ -12,6 +12,7 @@ import Algebra.Graph.Export.Dot
|
||||
import Control.Abstract.Analysis
|
||||
import Data.Abstract.Evaluatable (LoadError (..))
|
||||
import Data.Abstract.Module
|
||||
import Data.Abstract.Origin
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
import Prologue hiding (empty)
|
||||
|
||||
@ -27,19 +28,20 @@ newtype ImportGraphing m (effects :: [* -> *]) a = ImportGraphing (m effects a)
|
||||
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
|
||||
|
||||
deriving instance MonadControl term (m effects) => MonadControl term (ImportGraphing m effects)
|
||||
deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (ImportGraphing m effects)
|
||||
deriving instance MonadHeap value (m effects) => MonadHeap value (ImportGraphing m effects)
|
||||
deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (ImportGraphing m effects)
|
||||
deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (ImportGraphing m effects)
|
||||
deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (ImportGraphing m effects)
|
||||
deriving instance MonadHeap location value (m effects) => MonadHeap location value (ImportGraphing m effects)
|
||||
deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (ImportGraphing m effects)
|
||||
deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (ImportGraphing m effects)
|
||||
|
||||
|
||||
instance ( Effectful m
|
||||
, Member (Reader (SomeOrigin term)) effects
|
||||
, Member (State ImportGraph) effects
|
||||
, MonadAnalysis term value (m effects)
|
||||
, MonadAnalysis location term value (m effects)
|
||||
, Member (Resumable (LoadError term value)) effects
|
||||
)
|
||||
=> MonadAnalysis term value (ImportGraphing m effects) where
|
||||
type Effects term value (ImportGraphing m effects) = State ImportGraph ': Effects term value (m effects)
|
||||
=> MonadAnalysis location term value (ImportGraphing m effects) where
|
||||
type Effects location term value (ImportGraphing m effects) = State ImportGraph ': Effects location term value (m effects)
|
||||
|
||||
analyzeTerm eval term = resumeException
|
||||
@(LoadError term value)
|
||||
@ -47,17 +49,20 @@ instance ( Effectful m
|
||||
(\yield (LoadError name) -> insertVertexName name >> yield [])
|
||||
|
||||
analyzeModule recur m = do
|
||||
insertVertexName (modulePath m)
|
||||
insertVertexName (modulePath (moduleInfo m))
|
||||
liftAnalyze analyzeModule recur m
|
||||
|
||||
insertVertexName :: (Effectful m
|
||||
insertVertexName :: forall m location term value effects
|
||||
. ( Effectful m
|
||||
, Member (Reader (SomeOrigin term)) effects
|
||||
, Member (State ImportGraph) effects
|
||||
, MonadEvaluator term value (m effects))
|
||||
, MonadEvaluator location term value (m effects)
|
||||
)
|
||||
=> FilePath
|
||||
-> ImportGraphing m effects ()
|
||||
insertVertexName name = do
|
||||
ms <- askModuleStack
|
||||
let parent = maybe empty (vertex . modulePath) (listToMaybe ms)
|
||||
o <- raise ask
|
||||
let parent = maybe empty (vertex . modulePath) (withSomeOrigin (originModule @term) o)
|
||||
modifyImportGraph (parent >< vertex name <>)
|
||||
|
||||
(><) :: Graph a => a -> a -> a
|
||||
|
||||
@ -18,18 +18,18 @@ newtype Quietly m (effects :: [* -> *]) a = Quietly (m effects a)
|
||||
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
|
||||
|
||||
deriving instance MonadControl term (m effects) => MonadControl term (Quietly m effects)
|
||||
deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (Quietly m effects)
|
||||
deriving instance MonadHeap value (m effects) => MonadHeap value (Quietly m effects)
|
||||
deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Quietly m effects)
|
||||
deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Quietly m effects)
|
||||
deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (Quietly m effects)
|
||||
deriving instance MonadHeap location value (m effects) => MonadHeap location value (Quietly m effects)
|
||||
deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (Quietly m effects)
|
||||
deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (Quietly m effects)
|
||||
|
||||
instance ( Effectful m
|
||||
, Member (Resumable (Unspecialized value)) effects
|
||||
, MonadAnalysis term value (m effects)
|
||||
, MonadValue value (Quietly m effects)
|
||||
, MonadAnalysis location term value (m effects)
|
||||
, MonadValue location value (Quietly m effects)
|
||||
)
|
||||
=> MonadAnalysis term value (Quietly m effects) where
|
||||
type Effects term value (Quietly m effects) = Effects term value (m effects)
|
||||
=> MonadAnalysis location term value (Quietly m effects) where
|
||||
type Effects location term value (Quietly m effects) = Effects location term value (m effects)
|
||||
|
||||
analyzeTerm eval term = resumeException @(Unspecialized value) (liftAnalyze analyzeTerm eval term) (\yield (Unspecialized _) -> unit >>= yield)
|
||||
|
||||
|
||||
@ -5,6 +5,7 @@ module Analysis.Abstract.Tracing
|
||||
|
||||
import Control.Abstract.Analysis
|
||||
import Control.Monad.Effect.Writer
|
||||
import Data.Abstract.Configuration
|
||||
import Data.Semigroup.Reducer as Reducer
|
||||
import Data.Union
|
||||
import Prologue
|
||||
@ -16,24 +17,24 @@ newtype Tracing (trace :: * -> *) m (effects :: [* -> *]) a = Tracing (m effects
|
||||
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
|
||||
|
||||
deriving instance MonadControl term (m effects) => MonadControl term (Tracing trace m effects)
|
||||
deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (Tracing trace m effects)
|
||||
deriving instance MonadHeap value (m effects) => MonadHeap value (Tracing trace m effects)
|
||||
deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Tracing trace m effects)
|
||||
deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Tracing trace m effects)
|
||||
deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (Tracing trace m effects)
|
||||
deriving instance MonadHeap location value (m effects) => MonadHeap location value (Tracing trace m effects)
|
||||
deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (Tracing trace m effects)
|
||||
deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (Tracing trace m effects)
|
||||
|
||||
instance ( Corecursive term
|
||||
, Effectful m
|
||||
, Member (Writer (trace (ConfigurationFor term value))) effects
|
||||
, MonadAnalysis term value (m effects)
|
||||
, Ord (LocationFor value)
|
||||
, Reducer (ConfigurationFor term value) (trace (ConfigurationFor term value))
|
||||
, Member (Writer (trace (Configuration location term value))) effects
|
||||
, MonadAnalysis location term value (m effects)
|
||||
, Ord location
|
||||
, Reducer (Configuration location term value) (trace (Configuration location term value))
|
||||
)
|
||||
=> MonadAnalysis term value (Tracing trace m effects) where
|
||||
type Effects term value (Tracing trace m effects) = Writer (trace (ConfigurationFor term value)) ': Effects term value (m effects)
|
||||
=> MonadAnalysis location term value (Tracing trace m effects) where
|
||||
type Effects location term value (Tracing trace m effects) = Writer (trace (Configuration location term value)) ': Effects location term value (m effects)
|
||||
|
||||
analyzeTerm recur term = do
|
||||
config <- getConfiguration (embedSubterm term)
|
||||
raise (tell @(trace (ConfigurationFor term value)) (Reducer.unit config))
|
||||
raise (tell @(trace (Configuration location term value)) (Reducer.unit config))
|
||||
liftAnalyze analyzeTerm recur term
|
||||
|
||||
analyzeModule = liftAnalyze analyzeModule
|
||||
|
||||
@ -1,39 +1,39 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-}
|
||||
{-# LANGUAGE TypeFamilies, UndecidableInstances #-}
|
||||
module Control.Abstract.Addressable where
|
||||
|
||||
import Control.Abstract.Evaluator
|
||||
import Control.Applicative
|
||||
import Control.Monad ((<=<))
|
||||
import Control.Effect.Fresh
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.Environment (insert)
|
||||
import Data.Abstract.FreeVariables
|
||||
import Data.Abstract.Heap
|
||||
import Data.Semigroup.Reducer
|
||||
import Prelude hiding (fail)
|
||||
import Prologue
|
||||
|
||||
-- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Heap.
|
||||
class (Monad m, Ord l, l ~ LocationFor value, Reducer value (Cell l value)) => MonadAddressable l value m where
|
||||
deref :: Address l value -> m value
|
||||
class (MonadFresh m, Ord location) => MonadAddressable location m where
|
||||
derefCell :: Address location value -> Cell location value -> m value
|
||||
|
||||
alloc :: Name -> m (Address l value)
|
||||
allocLoc :: Name -> m location
|
||||
|
||||
-- | Look up or allocate an address for a 'Name'.
|
||||
lookupOrAlloc :: ( MonadAddressable (LocationFor value) value m
|
||||
, MonadEnvironment value m
|
||||
lookupOrAlloc :: ( MonadAddressable location m
|
||||
, MonadEnvironment location value m
|
||||
)
|
||||
=> Name
|
||||
-> m (Address (LocationFor value) value)
|
||||
-> m (Address location value)
|
||||
lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure
|
||||
|
||||
|
||||
letrec :: ( MonadAddressable (LocationFor value) value m
|
||||
, MonadEnvironment value m
|
||||
, MonadHeap value m
|
||||
letrec :: ( MonadAddressable location m
|
||||
, MonadEnvironment location value m
|
||||
, MonadHeap location value m
|
||||
, Reducer value (Cell location value)
|
||||
)
|
||||
=> Name
|
||||
-> m value
|
||||
-> m (value, Address (LocationFor value) value)
|
||||
-> m (value, Address location value)
|
||||
letrec name body = do
|
||||
addr <- lookupOrAlloc name
|
||||
v <- localEnv (insert name addr) body
|
||||
@ -41,11 +41,11 @@ letrec name body = do
|
||||
pure (v, addr)
|
||||
|
||||
-- Lookup/alloc a name passing the address to a body evaluated in a new local environment.
|
||||
letrec' :: ( MonadAddressable (LocationFor value) value m
|
||||
, MonadEnvironment value m
|
||||
letrec' :: ( MonadAddressable location m
|
||||
, MonadEnvironment location value m
|
||||
)
|
||||
=> Name
|
||||
-> (Address (LocationFor value) value -> m value)
|
||||
-> (Address location value -> m value)
|
||||
-> m value
|
||||
letrec' name body = do
|
||||
addr <- lookupOrAlloc name
|
||||
@ -55,22 +55,22 @@ letrec' name body = do
|
||||
-- Instances
|
||||
|
||||
-- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written.
|
||||
instance (MonadFail m, LocationFor value ~ Precise, MonadHeap value m) => MonadAddressable Precise value m where
|
||||
deref = derefWith (maybeM uninitializedAddress . unLatest)
|
||||
alloc _ = do
|
||||
-- Compute the next available address in the heap, then write an empty value into it.
|
||||
addr <- fmap (Address . Precise . heapSize) getHeap
|
||||
addr <$ modifyHeap (heapInit addr mempty)
|
||||
instance (MonadFail m, MonadFresh m) => MonadAddressable Precise m where
|
||||
derefCell addr = maybeM (uninitializedAddress addr) . unLatest
|
||||
allocLoc _ = Precise <$> fresh
|
||||
|
||||
-- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically.
|
||||
instance (Alternative m, LocationFor value ~ Monovariant, MonadFail m, MonadHeap value m, Ord value) => MonadAddressable Monovariant value m where
|
||||
deref = derefWith (foldMapA pure)
|
||||
alloc = pure . Address . Monovariant
|
||||
instance (Alternative m, MonadFresh m) => MonadAddressable Monovariant m where
|
||||
derefCell _ = foldMapA pure
|
||||
allocLoc = pure . Monovariant
|
||||
|
||||
-- | Dereference the given 'Address' in the heap, using the supplied function to act on the cell, or failing if the address is uninitialized.
|
||||
derefWith :: (MonadFail m, MonadHeap value m, Ord (LocationFor value)) => (CellFor value -> m a) -> Address (LocationFor value) value -> m a
|
||||
derefWith with = maybe uninitializedAddress with <=< lookupHeap
|
||||
-- | Dereference the given 'Address'in the heap, or fail if the address is uninitialized.
|
||||
deref :: (MonadFail m, MonadAddressable location m, MonadHeap location value m, Show location) => Address location value -> m value
|
||||
deref addr = lookupHeap addr >>= maybe (uninitializedAddress addr) (derefCell addr)
|
||||
|
||||
alloc :: MonadAddressable location m => Name -> m (Address location value)
|
||||
alloc = fmap Address . allocLoc
|
||||
|
||||
-- | 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).
|
||||
uninitializedAddress :: MonadFail m => m a
|
||||
uninitializedAddress = fail "uninitialized address"
|
||||
uninitializedAddress :: (MonadFail m, Show location) => Address location value -> m a
|
||||
uninitializedAddress addr = fail $ "uninitialized address: " <> show addr
|
||||
|
||||
@ -28,9 +28,9 @@ 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 term value m => MonadAnalysis term value m where
|
||||
class MonadEvaluator location term value m => MonadAnalysis location term value m where
|
||||
-- | The effects necessary to run the analysis. Analyses which are composed on top of (wrap) other analyses should include the inner analyses 'Effects' in their own list.
|
||||
type family Effects term value m :: [* -> *]
|
||||
type family Effects location term value m :: [* -> *]
|
||||
|
||||
-- | Analyze a term using the semantics of the current analysis.
|
||||
analyzeTerm :: (Base term (Subterm term (outer value)) -> m value)
|
||||
@ -56,8 +56,8 @@ liftAnalyze analyze recur term = coerce (analyze (coerceWith (sym Coercion) . r
|
||||
--
|
||||
-- This enables us to refer to the analysis type as e.g. @Analysis1 (Analysis2 Evaluating) Term Value@ without explicitly mentioning its effects (which are inferred to be simply its 'Effects').
|
||||
runAnalysis :: ( Effectful m
|
||||
, Effects term value (m effects) ~ effects
|
||||
, MonadAnalysis term value (m effects)
|
||||
, Effects location term value (m effects) ~ effects
|
||||
, MonadAnalysis location term value (m effects)
|
||||
, RunEffects effects a
|
||||
)
|
||||
=> m effects a
|
||||
|
||||
@ -1,7 +1,6 @@
|
||||
{-# LANGUAGE ConstrainedClassMethods, DataKinds, FunctionalDependencies, TypeFamilies, UndecidableInstances #-}
|
||||
{-# LANGUAGE ConstrainedClassMethods, DataKinds, FunctionalDependencies, RankNTypes, TypeFamilies, UndecidableInstances #-}
|
||||
module Control.Abstract.Evaluator
|
||||
( MonadEvaluator(..)
|
||||
, currentModule
|
||||
, MonadEnvironment(..)
|
||||
, modifyEnv
|
||||
, modifyExports
|
||||
@ -16,25 +15,16 @@ module Control.Abstract.Evaluator
|
||||
, modifyModuleTable
|
||||
, MonadControl(..)
|
||||
, MonadThrow(..)
|
||||
-- Type synonyms specialized for location types
|
||||
, CellFor
|
||||
, ConfigurationFor
|
||||
, EnvironmentFor
|
||||
, ExportsFor
|
||||
, HeapFor
|
||||
, LiveFor
|
||||
, LocationFor
|
||||
) where
|
||||
|
||||
import Control.Effect
|
||||
import Control.Monad.Effect.Resumable
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.Configuration
|
||||
import qualified Data.Abstract.Environment as Env
|
||||
import qualified Data.Abstract.Exports as Export
|
||||
import Data.Abstract.Environment as Env
|
||||
import Data.Abstract.Exports as Export
|
||||
import Data.Abstract.FreeVariables
|
||||
import Data.Abstract.Heap
|
||||
import Data.Abstract.Live
|
||||
import Data.Abstract.Module
|
||||
import Data.Abstract.ModuleTable
|
||||
import Data.Semigroup.Reducer
|
||||
@ -47,119 +37,110 @@ import Prologue hiding (throwError)
|
||||
-- - a heap mapping addresses to (possibly sets of) values
|
||||
-- - tables of modules available for import
|
||||
class ( MonadControl term m
|
||||
, MonadEnvironment value m
|
||||
, MonadEnvironment location value m
|
||||
, MonadFail m
|
||||
, MonadModuleTable term value m
|
||||
, MonadHeap value m
|
||||
, MonadModuleTable location term value m
|
||||
, MonadHeap location value m
|
||||
)
|
||||
=> MonadEvaluator term value m | m -> term, m -> value where
|
||||
=> MonadEvaluator location term value m | m -> location, m -> term, m -> value where
|
||||
-- | Get the current 'Configuration' with a passed-in term.
|
||||
getConfiguration :: Ord (LocationFor value) => term -> m (ConfigurationFor term value)
|
||||
|
||||
-- | Retrieve the stack of modules currently being evaluated.
|
||||
--
|
||||
-- With great power comes great responsibility. If you 'evaluateModule' any of these, you probably deserve what you get.
|
||||
askModuleStack :: m [Module term]
|
||||
|
||||
-- | Get the current module.
|
||||
currentModule :: (MonadEvaluator term value m) => m (Module term)
|
||||
currentModule = head <$> askModuleStack
|
||||
getConfiguration :: Ord location => term -> m (Configuration location term value)
|
||||
|
||||
-- | A 'Monad' abstracting local and global environments.
|
||||
class Monad m => MonadEnvironment value m | m -> value where
|
||||
class Monad m => MonadEnvironment location value m | m -> value, m -> location where
|
||||
-- | Retrieve the environment.
|
||||
getEnv :: m (EnvironmentFor value)
|
||||
getEnv :: m (Environment location value)
|
||||
-- | Set the environment.
|
||||
putEnv :: EnvironmentFor value -> m ()
|
||||
putEnv :: Environment location value -> m ()
|
||||
-- | Sets the environment for the lifetime of the given action.
|
||||
withEnv :: EnvironmentFor value -> m a -> m a
|
||||
withEnv :: Environment location value -> m a -> m a
|
||||
|
||||
-- | Retrieve the default environment.
|
||||
defaultEnvironment :: m (EnvironmentFor value)
|
||||
defaultEnvironment :: m (Environment location value)
|
||||
|
||||
-- | Set the default environment for the lifetime of an action.
|
||||
-- Usually only invoked in a top-level evaluation function.
|
||||
withDefaultEnvironment :: EnvironmentFor value -> m a -> m a
|
||||
withDefaultEnvironment :: Environment location value -> m a -> m a
|
||||
|
||||
-- | Get the global export state.
|
||||
getExports :: m (ExportsFor value)
|
||||
getExports :: m (Exports location value)
|
||||
-- | Set the global export state.
|
||||
putExports :: ExportsFor value -> m ()
|
||||
putExports :: Exports location value -> m ()
|
||||
-- | Sets the global export state for the lifetime of the given action.
|
||||
withExports :: ExportsFor value -> m a -> m a
|
||||
withExports :: Exports location value -> m a -> m a
|
||||
|
||||
-- | Run an action with a locally-modified environment.
|
||||
localEnv :: (EnvironmentFor value -> EnvironmentFor value) -> m a -> m a
|
||||
localEnv :: (Environment location value -> Environment location value) -> m a -> m a
|
||||
|
||||
-- | Look a 'Name' up in the current environment, trying the default environment if no value is found.
|
||||
lookupEnv :: Name -> m (Maybe (Address (LocationFor value) value))
|
||||
lookupEnv :: Name -> m (Maybe (Address location value))
|
||||
lookupEnv name = (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment)
|
||||
|
||||
-- | Look up a 'Name' in the environment, running an action with the resolved address (if any).
|
||||
lookupWith :: (Address (LocationFor value) value -> m value) -> Name -> m (Maybe value)
|
||||
lookupWith :: (Address location value -> m value) -> Name -> m (Maybe value)
|
||||
lookupWith with name = do
|
||||
addr <- lookupEnv name
|
||||
maybe (pure Nothing) (fmap Just . with) addr
|
||||
|
||||
-- | Run a computation in a new local environment.
|
||||
localize :: MonadEnvironment value m => m a -> m a
|
||||
localize :: MonadEnvironment location value m => m a -> m a
|
||||
localize = localEnv id
|
||||
|
||||
-- | Update the global environment.
|
||||
modifyEnv :: MonadEnvironment value m => (EnvironmentFor value -> EnvironmentFor value) -> m ()
|
||||
modifyEnv :: MonadEnvironment location value m => (Environment location value -> Environment location value) -> m ()
|
||||
modifyEnv f = do
|
||||
env <- getEnv
|
||||
putEnv $! f env
|
||||
|
||||
-- | Update the global export state.
|
||||
modifyExports :: MonadEnvironment value m => (ExportsFor value -> ExportsFor value) -> m ()
|
||||
modifyExports :: MonadEnvironment location value m => (Exports location value -> Exports location value) -> m ()
|
||||
modifyExports f = do
|
||||
exports <- getExports
|
||||
putExports $! f exports
|
||||
|
||||
-- | Add an export to the global export state.
|
||||
addExport :: MonadEnvironment value m => Name -> Name -> Maybe (Address (LocationFor value) value) -> m ()
|
||||
addExport :: MonadEnvironment location value m => Name -> Name -> Maybe (Address location value) -> m ()
|
||||
addExport name alias = modifyExports . Export.insert name alias
|
||||
|
||||
-- | Obtain an environment that is the composition of the current and default environments.
|
||||
-- Useful for debugging.
|
||||
fullEnvironment :: MonadEnvironment value m => m (EnvironmentFor value)
|
||||
fullEnvironment :: MonadEnvironment location value m => m (Environment location value)
|
||||
fullEnvironment = mappend <$> getEnv <*> defaultEnvironment
|
||||
|
||||
-- | A 'Monad' abstracting a heap of values.
|
||||
class Monad m => MonadHeap value m | m -> value where
|
||||
class Monad m => MonadHeap location value m | m -> value, m -> location where
|
||||
-- | Retrieve the heap.
|
||||
getHeap :: m (HeapFor value)
|
||||
getHeap :: m (Heap location value)
|
||||
-- | Set the heap.
|
||||
putHeap :: HeapFor value -> m ()
|
||||
putHeap :: Heap location value -> m ()
|
||||
|
||||
-- | Update the heap.
|
||||
modifyHeap :: MonadHeap value m => (HeapFor value -> HeapFor value) -> m ()
|
||||
modifyHeap :: MonadHeap location value m => (Heap location value -> Heap location value) -> m ()
|
||||
modifyHeap f = do
|
||||
s <- getHeap
|
||||
putHeap $! f s
|
||||
|
||||
-- | Look up the cell for the given 'Address' in the 'Heap'.
|
||||
lookupHeap :: (MonadHeap value m, Ord (LocationFor value)) => Address (LocationFor value) value -> m (Maybe (CellFor value))
|
||||
lookupHeap :: (MonadHeap location value m, Ord location) => Address location value -> m (Maybe (Cell location value))
|
||||
lookupHeap = flip fmap getHeap . heapLookup
|
||||
|
||||
-- | Write a value to the given 'Address' in the 'Store'.
|
||||
assign :: ( Ord (LocationFor value)
|
||||
, MonadHeap value m
|
||||
, Reducer value (CellFor value)
|
||||
assign :: ( Ord location
|
||||
, MonadHeap location value m
|
||||
, Reducer value (Cell location value)
|
||||
)
|
||||
=> Address (LocationFor value) value
|
||||
=> Address location value
|
||||
-> value
|
||||
-> m ()
|
||||
assign address = modifyHeap . heapInsert address
|
||||
|
||||
|
||||
-- | A 'Monad' abstracting tables of modules available for import.
|
||||
class Monad m => MonadModuleTable term value m | m -> term, m -> value where
|
||||
class Monad m => MonadModuleTable location term value m | m -> location, m -> term, m -> value where
|
||||
-- | Retrieve the table of evaluated modules.
|
||||
getModuleTable :: m (ModuleTable (EnvironmentFor value, value))
|
||||
getModuleTable :: m (ModuleTable (Environment location value, value))
|
||||
-- | Set the table of evaluated modules.
|
||||
putModuleTable :: ModuleTable (EnvironmentFor value, value) -> m ()
|
||||
putModuleTable :: ModuleTable (Environment location value, value) -> m ()
|
||||
|
||||
-- | Retrieve the table of unevaluated modules.
|
||||
askModuleTable :: m (ModuleTable [Module term])
|
||||
@ -167,7 +148,7 @@ class Monad m => MonadModuleTable term value m | m -> term, m -> value where
|
||||
localModuleTable :: (ModuleTable [Module term] -> ModuleTable [Module term]) -> m a -> m a
|
||||
|
||||
-- | Update the evaluated module table.
|
||||
modifyModuleTable :: MonadModuleTable term value m => (ModuleTable (EnvironmentFor value, value) -> ModuleTable (EnvironmentFor value, value)) -> m ()
|
||||
modifyModuleTable :: MonadModuleTable location term value m => (ModuleTable (Environment location value, value) -> ModuleTable (Environment location value, value)) -> m ()
|
||||
modifyModuleTable f = do
|
||||
table <- getModuleTable
|
||||
putModuleTable $! f table
|
||||
@ -189,25 +170,3 @@ class Monad m => MonadThrow exc m where
|
||||
|
||||
instance (Effectful m, Members '[Resumable exc] effects, Monad (m effects)) => MonadThrow exc (m effects) where
|
||||
throwException = raise . throwError
|
||||
|
||||
|
||||
-- | The cell for an abstract value type.
|
||||
type CellFor value = Cell (LocationFor value) value
|
||||
|
||||
-- | The configuration for term and abstract value types.
|
||||
type ConfigurationFor term value = Configuration (LocationFor value) term value
|
||||
|
||||
-- | The environment for an abstract value type.
|
||||
type EnvironmentFor value = Env.Environment (LocationFor value) value
|
||||
|
||||
-- | The exports for an abstract value type.
|
||||
type ExportsFor value = Export.Exports (LocationFor value) value
|
||||
|
||||
-- | The 'Heap' for an abstract value type.
|
||||
type HeapFor value = Heap (LocationFor value) value
|
||||
|
||||
-- | The address set type for an abstract value type.
|
||||
type LiveFor value = Live (LocationFor value) value
|
||||
|
||||
-- | The location type (the body of 'Address'es) which should be used for an abstract value type.
|
||||
type family LocationFor value :: *
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE GADTs, MultiParamTypeClasses, Rank2Types, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies, GADTs, Rank2Types, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||
module Control.Abstract.Value
|
||||
( MonadValue(..)
|
||||
, Comparator(..)
|
||||
@ -9,20 +9,14 @@ module Control.Abstract.Value
|
||||
, makeNamespace
|
||||
, ValueRoots(..)
|
||||
, ValueExc(..)
|
||||
, EnvironmentFor
|
||||
, ExportsFor
|
||||
, HeapFor
|
||||
, CellFor
|
||||
, LiveFor
|
||||
, LocationFor
|
||||
, ConfigurationFor
|
||||
) where
|
||||
|
||||
import Control.Abstract.Evaluator
|
||||
import Data.Abstract.FreeVariables
|
||||
import Data.Abstract.Environment as Env
|
||||
import Data.Abstract.Address (Address)
|
||||
import Data.Abstract.Address (Address, Cell)
|
||||
import Data.Abstract.Number as Number
|
||||
import Data.Abstract.Live (Live)
|
||||
import Data.Scientific (Scientific)
|
||||
import Data.Semigroup.Reducer hiding (unit)
|
||||
import Prelude
|
||||
@ -41,7 +35,7 @@ data Comparator
|
||||
-- | 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 (Monad m, Show value) => MonadValue value m where
|
||||
class (Monad m, Show value) => MonadValue location value m | m value -> location where
|
||||
-- | Construct an abstract unit value.
|
||||
-- TODO: This might be the same as the empty tuple for some value types
|
||||
unit :: m value
|
||||
@ -116,23 +110,23 @@ class (Monad m, Show value) => MonadValue value m where
|
||||
-- | Build a class value from a name and environment.
|
||||
klass :: Name -- ^ The new class's identifier
|
||||
-> [value] -- ^ A list of superclasses
|
||||
-> EnvironmentFor value -- ^ The environment to capture
|
||||
-> Environment location value -- ^ The environment to capture
|
||||
-> m value
|
||||
|
||||
-- | Build a namespace value from a name and environment stack
|
||||
--
|
||||
-- Namespaces model closures with monoidal environments.
|
||||
namespace :: Name -- ^ The namespace's identifier
|
||||
-> EnvironmentFor value -- ^ The environment to mappend
|
||||
-> Environment location value -- ^ The environment to mappend
|
||||
-> m value
|
||||
|
||||
-- | Extract the environment from any scoped object (e.g. classes, namespaces, etc).
|
||||
scopedEnvironment :: value -> m (EnvironmentFor value)
|
||||
scopedEnvironment :: value -> m (Environment location value)
|
||||
|
||||
-- | Evaluate an abstraction (a binder like a lambda or method definition).
|
||||
abstract :: (FreeVariables term, MonadControl term m) => [Name] -> Subterm term (m value) -> m value
|
||||
lambda :: (FreeVariables term, MonadControl term m) => [Name] -> Subterm term (m value) -> m value
|
||||
-- | Evaluate an application (like a function call).
|
||||
apply :: value -> [m value] -> m value
|
||||
call :: value -> [m value] -> m value
|
||||
|
||||
-- | Primitive looping combinator, approximately equivalent to 'fix'. This should be used in place of direct recursion, as it allows abstraction over recursion.
|
||||
--
|
||||
@ -141,10 +135,10 @@ class (Monad m, Show value) => MonadValue value m where
|
||||
|
||||
|
||||
-- | Attempt to extract a 'Prelude.Bool' from a given value.
|
||||
toBool :: MonadValue value m => value -> m Bool
|
||||
toBool :: MonadValue location value m => value -> m Bool
|
||||
toBool v = ifthenelse v (pure True) (pure False)
|
||||
|
||||
forLoop :: (MonadEnvironment value m, MonadValue value m)
|
||||
forLoop :: (MonadEnvironment location value m, MonadValue location value m)
|
||||
=> m value -- ^ Initial statement
|
||||
-> m value -- ^ Condition
|
||||
-> m value -- ^ Increment/stepper
|
||||
@ -154,7 +148,7 @@ forLoop initial cond step body =
|
||||
localize (initial *> while cond (body *> step))
|
||||
|
||||
-- | The fundamental looping primitive, built on top of ifthenelse.
|
||||
while :: MonadValue value m
|
||||
while :: MonadValue location value m
|
||||
=> m value
|
||||
-> m value
|
||||
-> m value
|
||||
@ -163,7 +157,7 @@ while cond body = loop $ \ continue -> do
|
||||
ifthenelse this (body *> continue) unit
|
||||
|
||||
-- | Do-while loop, built on top of while.
|
||||
doWhile :: MonadValue value m
|
||||
doWhile :: MonadValue location value m
|
||||
=> m value
|
||||
-> m value
|
||||
-> m value
|
||||
@ -171,14 +165,14 @@ doWhile body cond = loop $ \ continue -> body *> do
|
||||
this <- cond
|
||||
ifthenelse this continue unit
|
||||
|
||||
makeNamespace :: ( MonadValue value m
|
||||
, MonadEnvironment value m
|
||||
, MonadHeap value m
|
||||
, Reducer value (CellFor value)
|
||||
, Ord (LocationFor value)
|
||||
makeNamespace :: ( MonadValue location value m
|
||||
, MonadEnvironment location value m
|
||||
, MonadHeap location value m
|
||||
, Ord location
|
||||
, Reducer value (Cell location value)
|
||||
)
|
||||
=> Name
|
||||
-> Address (LocationFor value) value
|
||||
-> Address location value
|
||||
-> [value]
|
||||
-> m value
|
||||
makeNamespace name addr supers = do
|
||||
@ -189,25 +183,25 @@ makeNamespace name addr supers = do
|
||||
|
||||
|
||||
-- | Value types, e.g. closures, which can root a set of addresses.
|
||||
class ValueRoots value where
|
||||
class ValueRoots location value where
|
||||
-- | Compute the set of addresses rooted by a given value.
|
||||
valueRoots :: value -> LiveFor value
|
||||
valueRoots :: value -> Live location value
|
||||
|
||||
|
||||
-- The type of exceptions that can be thrown when constructing values in `MonadValue`.
|
||||
data ValueExc value resume where
|
||||
TypeError :: Prelude.String -> ValueExc value value
|
||||
StringError :: Prelude.String -> ValueExc value ByteString
|
||||
NamespaceError :: Prelude.String -> ValueExc value (EnvironmentFor value)
|
||||
ScopedEnvironmentError :: Prelude.String -> ValueExc value (EnvironmentFor value)
|
||||
data ValueExc location value resume where
|
||||
TypeError :: Prelude.String -> ValueExc location value value
|
||||
StringError :: Prelude.String -> ValueExc location value ByteString
|
||||
NamespaceError :: Prelude.String -> ValueExc location value (Environment location value)
|
||||
ScopedEnvironmentError :: Prelude.String -> ValueExc location value (Environment location value)
|
||||
|
||||
instance Eq1 (ValueExc value) where
|
||||
instance Eq1 (ValueExc location value) where
|
||||
liftEq _ (TypeError a) (TypeError b) = a == b
|
||||
liftEq _ (StringError a) (StringError b) = a == b
|
||||
liftEq _ (NamespaceError a) (NamespaceError b) = a == b
|
||||
liftEq _ (ScopedEnvironmentError a) (ScopedEnvironmentError b) = a == b
|
||||
liftEq _ _ _ = False
|
||||
|
||||
deriving instance Show (ValueExc value resume)
|
||||
instance Show1 (ValueExc value) where
|
||||
deriving instance Show (ValueExc location value resume)
|
||||
instance Show1 (ValueExc location value) where
|
||||
liftShowsPrec _ _ = showsPrec
|
||||
|
||||
@ -4,22 +4,20 @@ module Control.Effect.Fresh where
|
||||
import Control.Effect
|
||||
import Control.Monad.Effect.Internal
|
||||
|
||||
type TName = Int
|
||||
|
||||
-- | An effect offering a (resettable) sequence of always-incrementing, and therefore “fresh,” type variables.
|
||||
data Fresh a where
|
||||
-- | Request a reset of the sequence of variable names.
|
||||
Reset :: TName -> Fresh ()
|
||||
Reset :: Int -> Fresh ()
|
||||
-- | Request a fresh variable name.
|
||||
Fresh :: Fresh TName
|
||||
Fresh :: Fresh Int
|
||||
|
||||
-- | 'Monad's offering a (resettable) sequence of guaranteed-fresh type variables.
|
||||
class Monad m => MonadFresh m where
|
||||
-- | Get a fresh variable name, guaranteed unused (since the last 'reset').
|
||||
fresh :: m TName
|
||||
fresh :: m Int
|
||||
|
||||
-- | Reset the sequence of variable names. Useful to avoid complicated alpha-equivalence comparisons when iteratively recomputing the results of an analysis til convergence.
|
||||
reset :: TName -> m ()
|
||||
reset :: Int -> m ()
|
||||
|
||||
instance (Fresh :< fs) => MonadFresh (Eff fs) where
|
||||
fresh = send Fresh
|
||||
@ -28,6 +26,6 @@ instance (Fresh :< fs) => MonadFresh (Eff fs) where
|
||||
|
||||
-- | 'Fresh' effects are interpreted starting from 0, incrementing the current name with each request for a fresh name, and overwriting the counter on reset.
|
||||
instance RunEffect Fresh a where
|
||||
runEffect = relayState (0 :: TName) (const pure) (\ s action k -> case action of
|
||||
runEffect = relayState (0 :: Int) (const pure) (\ s action k -> case action of
|
||||
Fresh -> k (succ s) s
|
||||
Reset s' -> k s' ())
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses, TypeFamilyDependencies #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
module Data.Abstract.Address where
|
||||
|
||||
import Data.Abstract.FreeVariables
|
||||
@ -14,19 +14,25 @@ instance Ord l => Ord1 (Address l) where liftCompare = genericLiftCompare
|
||||
instance Show l => Show1 (Address l) where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
|
||||
class Ord loc => Location loc where
|
||||
-- | The type into which stored values will be written for a given location type.
|
||||
type family Cell loc :: * -> *
|
||||
|
||||
|
||||
-- | 'Precise' models precise store semantics where only the 'Latest' value is taken. Everything gets it's own address (always makes a new allocation) which makes for a larger store.
|
||||
newtype Precise = Precise { unPrecise :: Int }
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Location Precise where
|
||||
type Cell Precise = Latest
|
||||
|
||||
|
||||
-- | 'Monovariant' models using one address for a particular name. It trackes the set of values that a particular address takes and uses it's name to lookup in the store and only allocation if new.
|
||||
newtype Monovariant = Monovariant { unMonovariant :: Name }
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
|
||||
-- | The type into which stored values will be written for a given location type.
|
||||
type family Cell l = res | res -> l where
|
||||
Cell Precise = Latest
|
||||
Cell Monovariant = Set
|
||||
instance Location Monovariant where
|
||||
type Cell Monovariant = Set
|
||||
|
||||
|
||||
-- | A cell holding a single value. Writes will replace any prior value.
|
||||
|
||||
@ -1,4 +1,7 @@
|
||||
{-# LANGUAGE ConstraintKinds, DefaultSignatures, GADTs, UndecidableInstances #-}
|
||||
{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving,
|
||||
TypeFamilies, TypeOperators #-}
|
||||
|
||||
module Data.Abstract.Evaluatable
|
||||
( module X
|
||||
, MonadEvaluatable
|
||||
@ -6,42 +9,49 @@ module Data.Abstract.Evaluatable
|
||||
, Unspecialized(..)
|
||||
, LoadError(..)
|
||||
, EvalError(..)
|
||||
, currentModule
|
||||
, variable
|
||||
, evaluateTerm
|
||||
, evaluateModule
|
||||
, withModules
|
||||
, evaluateModules
|
||||
, evaluatePackage
|
||||
, throwLoadError
|
||||
, resolve
|
||||
, listModulesInDir
|
||||
, require
|
||||
, load
|
||||
, pushOrigin
|
||||
) where
|
||||
|
||||
import Control.Abstract.Addressable as X
|
||||
import Control.Abstract.Analysis as X
|
||||
import qualified Data.Abstract.Environment as Env
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.Environment as X
|
||||
import qualified Data.Abstract.Exports as Exports
|
||||
import Data.Abstract.FreeVariables as X
|
||||
import Data.Abstract.Module
|
||||
import Data.Abstract.ModuleTable as ModuleTable
|
||||
import Data.Abstract.Origin (SomeOrigin, packageOrigin, originModule, withSomeOrigin)
|
||||
import Data.Abstract.Package as Package
|
||||
import Data.Semigroup.App
|
||||
import Data.Semigroup.Foldable
|
||||
import Data.Semigroup.Reducer hiding (unit)
|
||||
import Data.Term
|
||||
import Prelude hiding (fail)
|
||||
import Prologue
|
||||
|
||||
type MonadEvaluatable term value m =
|
||||
type MonadEvaluatable location term value m =
|
||||
( Evaluatable (Base term)
|
||||
, FreeVariables term
|
||||
, MonadAddressable (LocationFor value) value m
|
||||
, MonadAnalysis term value m
|
||||
, MonadAddressable location m
|
||||
, MonadAnalysis location term value m
|
||||
, MonadThrow (Unspecialized value) m
|
||||
, MonadThrow (ValueExc value) m
|
||||
, MonadThrow (ValueExc location value) m
|
||||
, MonadThrow (LoadError term value) m
|
||||
, MonadThrow (EvalError value) m
|
||||
, MonadValue value m
|
||||
, MonadValue location value m
|
||||
, Recursive term
|
||||
, Show (LocationFor value)
|
||||
, Reducer value (Cell location value)
|
||||
, Show location
|
||||
)
|
||||
|
||||
|
||||
@ -61,6 +71,26 @@ data EvalError value resume where
|
||||
-- Indicates we weren't able to dereference a name from the evaluated environment.
|
||||
FreeVariableError :: Name -> EvalError value value
|
||||
|
||||
-- | Get the current module.
|
||||
-- currentModule :: forall m location term value effects
|
||||
-- . ( Effectful m
|
||||
-- , Member (Reader (SomeOrigin term)) effects
|
||||
-- , MonadEvaluator location term value (m effects)
|
||||
-- )
|
||||
-- => m effects ModuleInfo
|
||||
currentModule :: m ModuleInfo
|
||||
currentModule = undefined
|
||||
-- currentModule = do
|
||||
-- o <- raise ask
|
||||
-- let Just m = withSomeOrigin (originModule @term) o
|
||||
-- pure m
|
||||
-- pure moduleInfo m
|
||||
-- currentModule = head <$> askModuleStack
|
||||
|
||||
-- | Look up and dereference the given 'Name', throwing an exception for free variables.
|
||||
variable :: MonadEvaluatable location term value m => Name -> m value
|
||||
variable name = lookupWith deref name >>= maybeM (throwException (FreeVariableError name))
|
||||
|
||||
deriving instance Eq (EvalError a b)
|
||||
deriving instance Show (EvalError a b)
|
||||
instance Show1 (EvalError value) where
|
||||
@ -68,7 +98,7 @@ instance Show1 (EvalError value) where
|
||||
instance Eq1 (EvalError term) where
|
||||
liftEq _ (FreeVariableError a) (FreeVariableError b) = a == b
|
||||
|
||||
throwLoadError :: MonadEvaluatable term value m => LoadError term value resume -> m resume
|
||||
throwLoadError :: MonadEvaluatable location term value m => LoadError term value resume -> m resume
|
||||
throwLoadError = throwException
|
||||
|
||||
data Unspecialized a b where
|
||||
@ -84,7 +114,7 @@ instance Show1 (Unspecialized a) where
|
||||
|
||||
-- | 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 :: MonadEvaluatable term value m
|
||||
eval :: MonadEvaluatable location term value m
|
||||
=> SubtermAlgebra constr term (m value)
|
||||
default eval :: (MonadThrow (Unspecialized value) m, Show1 constr) => SubtermAlgebra constr term (m value)
|
||||
eval expr = throwException (Unspecialized ("Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr ""))
|
||||
@ -110,37 +140,37 @@ instance Evaluatable [] where
|
||||
eval = maybe unit (runApp . foldMap1 (App . subtermValue)) . nonEmpty
|
||||
|
||||
-- Resolve a list of module paths to a possible module table entry.
|
||||
resolve :: MonadEvaluatable term value m
|
||||
resolve :: MonadEvaluatable location term value m
|
||||
=> [ModuleName]
|
||||
-> m (Maybe ModuleName)
|
||||
resolve names = do
|
||||
tbl <- askModuleTable
|
||||
pure $ find (`moduleTableMember` tbl) names
|
||||
pure $ find (`ModuleTable.member` tbl) names
|
||||
|
||||
listModulesInDir :: MonadEvaluatable term value m
|
||||
listModulesInDir :: MonadEvaluatable location term value m
|
||||
=> FilePath
|
||||
-> m [ModuleName]
|
||||
listModulesInDir dir = moduleTableKeysForDir dir <$> askModuleTable
|
||||
listModulesInDir dir = ModuleTable.moduleTableKeysForDir dir <$> askModuleTable
|
||||
|
||||
-- | Require/import another module by name and return it's environment and value.
|
||||
--
|
||||
-- Looks up the term's name in the cache of evaluated modules first, returns if found, otherwise loads/evaluates the module.
|
||||
require :: MonadEvaluatable term value m
|
||||
require :: MonadEvaluatable location term value m
|
||||
=> ModuleName
|
||||
-> m (EnvironmentFor value, value)
|
||||
require name = getModuleTable >>= maybe (load name) pure . moduleTableLookup name
|
||||
-> m (Environment location value, value)
|
||||
require name = getModuleTable >>= maybeM (load name) . ModuleTable.lookup name
|
||||
|
||||
-- | Load another module by name and return it's environment and value.
|
||||
--
|
||||
-- Always loads/evaluates.
|
||||
load :: MonadEvaluatable term value m
|
||||
load :: MonadEvaluatable location term value m
|
||||
=> ModuleName
|
||||
-> m (EnvironmentFor value, value)
|
||||
load name = askModuleTable >>= maybe notFound pure . moduleTableLookup name >>= evalAndCache
|
||||
-> m (Environment location value, value)
|
||||
load name = askModuleTable >>= maybeM notFound . ModuleTable.lookup name >>= evalAndCache
|
||||
where
|
||||
notFound = throwLoadError (LoadError name)
|
||||
|
||||
evalAndCache [] = (,) <$> pure mempty <*> unit
|
||||
evalAndCache [] = (,) mempty <$> unit
|
||||
evalAndCache [x] = evalAndCache' x
|
||||
evalAndCache (x:xs) = do
|
||||
(env, _) <- evalAndCache' x
|
||||
@ -150,43 +180,62 @@ load name = askModuleTable >>= maybe notFound pure . moduleTableLookup name >>=
|
||||
evalAndCache' x = do
|
||||
v <- evaluateModule x
|
||||
env <- filterEnv <$> getExports <*> getEnv
|
||||
modifyModuleTable (moduleTableInsert name (env, v))
|
||||
modifyModuleTable (ModuleTable.insert name (env, v))
|
||||
pure (env, v)
|
||||
|
||||
-- TODO: If the set of exports is empty because no exports have been
|
||||
-- defined, do we export all terms, or no terms? This behavior varies across
|
||||
-- languages. We need better semantics rather than doing it ad-hoc.
|
||||
filterEnv :: Exports.Exports l a -> Env.Environment l a -> Env.Environment l a
|
||||
filterEnv :: Exports.Exports l a -> Environment l a -> Environment l a
|
||||
filterEnv ports env
|
||||
| Exports.null ports = env
|
||||
| otherwise = Exports.toEnvironment ports <> Env.overwrite (Exports.aliases ports) env
|
||||
| otherwise = Exports.toEnvironment ports <> overwrite (Exports.aliases ports) env
|
||||
|
||||
|
||||
-- | 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 :: MonadEvaluatable term value m
|
||||
evaluateTerm :: MonadEvaluatable location term value m
|
||||
=> term
|
||||
-> m value
|
||||
evaluateTerm = foldSubterms (analyzeTerm eval)
|
||||
|
||||
-- | Evaluate a (root-level) term to a value using the semantics of the current analysis. This should be used to evaluate single-term programs, or (via 'evaluateModules') the entry point of multi-term programs.
|
||||
evaluateModule :: MonadEvaluatable term value m
|
||||
evaluateModule :: MonadEvaluatable location term value m
|
||||
=> Module term
|
||||
-> m value
|
||||
evaluateModule m = analyzeModule (subtermValue . moduleBody) (fmap (Subterm <*> evaluateTerm) m)
|
||||
|
||||
|
||||
-- | Run an action with the a list of 'Module's available for imports.
|
||||
withModules :: MonadEvaluatable term value m
|
||||
=> [Module term]
|
||||
-> m a
|
||||
-> m a
|
||||
withModules = localModuleTable . const . ModuleTable.fromList
|
||||
|
||||
-- | Evaluate with a list of modules in scope, taking the head module as the entry point.
|
||||
evaluateModules :: MonadEvaluatable term value m
|
||||
evaluateModules :: MonadEvaluatable location term value m
|
||||
=> [Module term]
|
||||
-> m value
|
||||
evaluateModules [] = fail "evaluateModules: empty list"
|
||||
evaluateModules (m:ms) = withModules ms (evaluateModule m)
|
||||
evaluateModules = fmap Prelude.head . evaluatePackageBody . Package.fromModules
|
||||
|
||||
-- | Evaluate a given package.
|
||||
evaluatePackage :: ( Effectful m
|
||||
, Member (Reader (SomeOrigin term)) effects
|
||||
, MonadEvaluatable location term value (m effects)
|
||||
)
|
||||
=> Package term
|
||||
-> m effects [value]
|
||||
evaluatePackage p = pushOrigin (packageOrigin p) (evaluatePackageBody (packageBody p))
|
||||
|
||||
-- | Evaluate a given package body (module table and entry points).
|
||||
evaluatePackageBody :: MonadEvaluatable location term value m
|
||||
=> PackageBody term
|
||||
-> m [value]
|
||||
evaluatePackageBody body = localModuleTable (<> packageModules body)
|
||||
(traverse evaluateEntryPoint (ModuleTable.toPairs (packageEntryPoints body)))
|
||||
where evaluateEntryPoint (m, sym) = do
|
||||
(_, v) <- require m
|
||||
maybe (pure v) ((`call` []) <=< variable) sym
|
||||
|
||||
-- | Push a 'SomeOrigin' onto the stack. This should be used to contextualize execution with information about the originating term, module, or package.
|
||||
pushOrigin :: ( Effectful m
|
||||
, Member (Reader (SomeOrigin term)) effects
|
||||
)
|
||||
=> SomeOrigin term
|
||||
-> m effects a
|
||||
-> m effects a
|
||||
pushOrigin o = raise . local (<> o) . lower
|
||||
|
||||
28
src/Data/Abstract/Located.hs
Normal file
28
src/Data/Abstract/Located.hs
Normal file
@ -0,0 +1,28 @@
|
||||
{-# LANGUAGE TypeFamilies, UndecidableInstances #-}
|
||||
module Data.Abstract.Located where
|
||||
|
||||
import Control.Abstract.Addressable
|
||||
import Control.Effect
|
||||
import Control.Monad.Effect.Reader
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.Origin
|
||||
import Prologue
|
||||
|
||||
data Located location term = Located { location :: location, origin :: !(SomeOrigin term) }
|
||||
|
||||
deriving instance (Eq location, Eq (Base term ())) => Eq (Located location term)
|
||||
deriving instance (Ord location, Ord (Base term ())) => Ord (Located location term)
|
||||
deriving instance (Show location, Show (Base term ())) => Show (Located location term)
|
||||
|
||||
instance (Location location, Ord (Base term ())) => Location (Located location term) where
|
||||
type Cell (Located location term) = Cell location
|
||||
|
||||
instance ( Effectful m
|
||||
, Member (Reader (SomeOrigin term)) effects
|
||||
, MonadAddressable location (m effects)
|
||||
, Ord (Base term ())
|
||||
)
|
||||
=> MonadAddressable (Located location term) (m effects) where
|
||||
derefCell (Address (Located loc _)) = derefCell (Address loc)
|
||||
|
||||
allocLoc name = Located <$> allocLoc name <*> raise ask
|
||||
@ -1,5 +1,6 @@
|
||||
module Data.Abstract.Module
|
||||
( Module(..)
|
||||
, ModuleInfo(..)
|
||||
, ModuleName
|
||||
, moduleForBlob
|
||||
) where
|
||||
@ -10,21 +11,20 @@ import System.FilePath.Posix
|
||||
|
||||
type ModuleName = FilePath
|
||||
|
||||
data Module term = Module
|
||||
{ modulePath :: FilePath -- ^ Path to this module
|
||||
, moduleRoot :: FilePath -- ^ Root path for module resolution
|
||||
, moduleBody :: term -- ^ @term@ body of the module
|
||||
} deriving (Eq, Foldable, Functor, Ord, Traversable)
|
||||
data ModuleInfo = ModuleInfo { modulePath :: FilePath, moduleRoot :: FilePath }
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data Module term = Module { moduleInfo :: ModuleInfo, moduleBody :: term }
|
||||
deriving (Eq, Foldable, Functor, Ord, Show, Traversable)
|
||||
|
||||
instance Show (Module term) where
|
||||
showsPrec _ Module{..} = showString modulePath
|
||||
|
||||
-- | Construct a 'Module' for a 'Blob' and @term@, relative to some root 'FilePath'.
|
||||
moduleForBlob :: Maybe FilePath -- ^ The root directory relative to which the module will be resolved, if any.
|
||||
-> Blob -- ^ The 'Blob' containing the module.
|
||||
-> term -- ^ The @term@ representing the body of the module.
|
||||
-> Module term -- ^ A 'Module' named appropriate for the 'Blob', holding the @term@, and constructed relative to the root 'FilePath', if any.
|
||||
moduleForBlob rootDir Blob{..} = Module (modulePath blobPath) root
|
||||
moduleForBlob rootDir Blob{..} = Module info
|
||||
where
|
||||
root = fromMaybe (takeDirectory blobPath) rootDir
|
||||
modulePath = maybe takeFileName makeRelative rootDir
|
||||
info = ModuleInfo (modulePath blobPath) root
|
||||
|
||||
@ -2,11 +2,13 @@
|
||||
module Data.Abstract.ModuleTable
|
||||
( ModuleName
|
||||
, ModuleTable (..)
|
||||
, moduleTableLookup
|
||||
, moduleTableMember
|
||||
, moduleTableInsert
|
||||
, singleton
|
||||
, lookup
|
||||
, member
|
||||
, moduleTableKeysForDir
|
||||
, fromList
|
||||
, insert
|
||||
, fromModules
|
||||
, toPairs
|
||||
) where
|
||||
|
||||
import Data.Abstract.Module
|
||||
@ -15,24 +17,31 @@ import Data.Semigroup
|
||||
import Prologue
|
||||
import System.FilePath.Posix
|
||||
import GHC.Generics (Generic1)
|
||||
import Prelude hiding (lookup)
|
||||
|
||||
newtype ModuleTable a = ModuleTable { unModuleTable :: Map.Map ModuleName a }
|
||||
deriving (Eq, Foldable, Functor, Generic1, Monoid, Ord, Semigroup, Show, Traversable)
|
||||
|
||||
moduleTableLookup :: ModuleName -> ModuleTable a -> Maybe a
|
||||
moduleTableLookup k = Map.lookup k . unModuleTable
|
||||
|
||||
moduleTableMember :: ModuleName -> ModuleTable a -> Bool
|
||||
moduleTableMember k = Map.member k . unModuleTable
|
||||
|
||||
moduleTableInsert :: ModuleName -> a -> ModuleTable a -> ModuleTable a
|
||||
moduleTableInsert k v = ModuleTable . Map.insert k v . unModuleTable
|
||||
singleton :: ModuleName -> a -> ModuleTable a
|
||||
singleton name = ModuleTable . Map.singleton name
|
||||
|
||||
moduleTableKeysForDir :: FilePath -> ModuleTable a -> [ModuleName]
|
||||
moduleTableKeysForDir k = filter (\e -> k == takeDirectory e) . Map.keys . unModuleTable
|
||||
|
||||
lookup :: ModuleName -> ModuleTable a -> Maybe a
|
||||
lookup k = Map.lookup k . unModuleTable
|
||||
|
||||
member :: ModuleName -> ModuleTable a -> Bool
|
||||
member k = Map.member k . unModuleTable
|
||||
|
||||
insert :: ModuleName -> a -> ModuleTable a -> ModuleTable a
|
||||
insert k v = ModuleTable . Map.insert k v . unModuleTable
|
||||
|
||||
|
||||
-- | Construct a 'ModuleTable' from a list of 'Module's.
|
||||
fromList :: [Module term] -> ModuleTable [Module term]
|
||||
fromList modules = let m = ModuleTable (Map.fromListWith (<>) (map toEntry modules)) in traceShow m m
|
||||
where toEntry m = (modulePath m, [m])
|
||||
fromModules :: [Module term] -> ModuleTable [Module term]
|
||||
fromModules = ModuleTable . Map.fromListWith (<>) . map toEntry
|
||||
where toEntry m = (modulePath (moduleInfo m), [m])
|
||||
|
||||
toPairs :: ModuleTable a -> [(ModuleName, a)]
|
||||
toPairs = Map.toList . unModuleTable
|
||||
|
||||
100
src/Data/Abstract/Origin.hs
Normal file
100
src/Data/Abstract/Origin.hs
Normal file
@ -0,0 +1,100 @@
|
||||
{-# LANGUAGE GADTs, RankNTypes, UndecidableInstances #-}
|
||||
module Data.Abstract.Origin where
|
||||
|
||||
import qualified Data.Abstract.Module as M
|
||||
import qualified Data.Abstract.Package as P
|
||||
import Prologue
|
||||
|
||||
-- | An 'Origin' encapsulates the location at which a name is bound or allocated.
|
||||
data Origin term ty where
|
||||
-- | We don’t know anything, or there isn’t even something to know anything about.
|
||||
Unknown :: Origin term any
|
||||
-- | We know the package.
|
||||
Package :: P.PackageInfo -> Origin term 'P
|
||||
-- | We know the module, and possibly package.
|
||||
Module :: Origin term 'P -> M.ModuleInfo -> Origin term 'M
|
||||
-- | We know the term, and possibly module and package.
|
||||
Term :: Origin term 'M -> Base term () -> Origin term 'T
|
||||
|
||||
-- | A type index indicating the finest grain of information available in a given 'Origin'.
|
||||
data OriginType = P | M | T
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
-- | Project the 'ModuleInfo' out of an 'Origin', if available.
|
||||
originModule :: Origin term ty -> Maybe M.ModuleInfo
|
||||
originModule (Term o _) = originModule o
|
||||
originModule (Module _ m) = Just m
|
||||
originModule _ = Nothing
|
||||
|
||||
-- | Project the 'PackageInfo' out of an 'Origin', if available.
|
||||
originPackage :: Origin term ty -> Maybe P.PackageInfo
|
||||
originPackage (Term o _) = originPackage o
|
||||
originPackage (Module o _) = originPackage o
|
||||
originPackage (Package p) = Just p
|
||||
originPackage _ = Nothing
|
||||
|
||||
deriving instance Eq (Base term ()) => Eq (Origin term ty)
|
||||
deriving instance Show (Base term ()) => Show (Origin term ty)
|
||||
|
||||
-- | Compare two origins with arbitrary type indices using a function to compare term functors.
|
||||
liftCompareOrigins :: (Base term () -> Base term () -> Ordering) -> Origin term ty1 -> Origin term ty2 -> Ordering
|
||||
liftCompareOrigins _ Unknown Unknown = EQ
|
||||
liftCompareOrigins _ Unknown _ = LT
|
||||
liftCompareOrigins _ _ Unknown = GT
|
||||
liftCompareOrigins _ (Package p1) (Package p2) = compare p1 p2
|
||||
liftCompareOrigins _ (Package _) _ = LT
|
||||
liftCompareOrigins _ _ (Package _) = GT
|
||||
liftCompareOrigins c (Module p1 m1) (Module p2 m2) = liftCompareOrigins c p1 p2 <> compare m1 m2
|
||||
liftCompareOrigins _ (Module _ _) _ = LT
|
||||
liftCompareOrigins _ _ (Module _ _) = GT
|
||||
liftCompareOrigins c (Term m1 t1) (Term m2 t2) = liftCompareOrigins c m1 m2 <> c t1 t2
|
||||
|
||||
instance Ord (Base term ()) => Ord (Origin term ty) where
|
||||
compare = liftCompareOrigins compare
|
||||
|
||||
-- | An existential abstraction over 'Origin's of different types.
|
||||
data SomeOrigin term where
|
||||
SomeOrigin :: Origin term ty -> SomeOrigin term
|
||||
|
||||
-- | Construct a 'SomeOrigin' from 'P.Package' metadata.
|
||||
packageOrigin :: P.Package term -> SomeOrigin term
|
||||
packageOrigin = SomeOrigin . Package . P.packageInfo
|
||||
|
||||
-- | Construct a 'SomeOrigin' from 'M.Module' metadata.
|
||||
moduleOrigin :: M.Module term -> SomeOrigin term
|
||||
moduleOrigin = SomeOrigin . Module Unknown . M.moduleInfo
|
||||
|
||||
-- | Construct a 'SomeOrigin' from a recursive term type.
|
||||
termOrigin :: Recursive term => term -> SomeOrigin term
|
||||
termOrigin = SomeOrigin . Term Unknown . (() <$) . project
|
||||
|
||||
-- | Project information out of a 'SomeOrigin' using a helper function.
|
||||
withSomeOrigin :: (forall ty . Origin term ty -> b) -> SomeOrigin term -> b
|
||||
withSomeOrigin with (SomeOrigin o) = with o
|
||||
|
||||
instance Eq (Base term ()) => Eq (SomeOrigin term) where
|
||||
SomeOrigin o1 == SomeOrigin o2 = liftCompareOrigins (\ t1 t2 -> if t1 == t2 then EQ else LT) o1 o2 == EQ
|
||||
|
||||
instance Ord (Base term ()) => Ord (SomeOrigin term) where
|
||||
compare (SomeOrigin o1) (SomeOrigin o2) = liftCompareOrigins compare o1 o2
|
||||
|
||||
deriving instance Show (Base term ()) => Show (SomeOrigin term)
|
||||
|
||||
|
||||
-- | Merge two 'Origin's of possibly differing type indices into a 'SomeOrigin' containing as much information as is available in either side, with ties broken in favour of the right-hand argument.
|
||||
merge :: Origin term ty1 -> Origin term ty2 -> SomeOrigin term
|
||||
merge a Unknown = SomeOrigin a
|
||||
merge (Package p) (Module Unknown m) = SomeOrigin (Module (Package p) m)
|
||||
merge (Module p _) (Module Unknown m) = SomeOrigin (Module p m)
|
||||
merge (Term (Module p _) _) (Module Unknown m) = SomeOrigin (Module p m)
|
||||
merge (Term (Module p _) _) (Term (Module Unknown m) t) = SomeOrigin (Term (Module p m) t)
|
||||
merge (Module p m) (Term Unknown t) = SomeOrigin (Term (Module p m) t)
|
||||
merge (Term m _) (Term Unknown t) = SomeOrigin (Term m t)
|
||||
merge _ b = SomeOrigin b
|
||||
|
||||
instance Semigroup (SomeOrigin term) where
|
||||
SomeOrigin a <> SomeOrigin b = merge a b
|
||||
|
||||
instance Monoid (SomeOrigin term) where
|
||||
mempty = SomeOrigin Unknown
|
||||
mappend = (<>)
|
||||
36
src/Data/Abstract/Package.hs
Normal file
36
src/Data/Abstract/Package.hs
Normal file
@ -0,0 +1,36 @@
|
||||
module Data.Abstract.Package where
|
||||
|
||||
import Data.Abstract.FreeVariables
|
||||
import Data.Abstract.Module
|
||||
import Data.Abstract.ModuleTable as ModuleTable
|
||||
|
||||
type PackageName = Name
|
||||
|
||||
-- | Metadata for a package (name and version).
|
||||
data PackageInfo = PackageInfo
|
||||
{ packageName :: PackageName
|
||||
, packageVersion :: Maybe Version
|
||||
}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
newtype Version = Version { versionString :: String }
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data PackageBody term = PackageBody
|
||||
{ packageModules :: ModuleTable [Module term]
|
||||
, packageEntryPoints :: ModuleTable (Maybe Name)
|
||||
}
|
||||
deriving (Eq, Functor, Ord, Show)
|
||||
|
||||
|
||||
-- | A package represents the unit of dependency, i.e. something which can depend upon, or be depended upon by, other packages. Packages have modules and may have entry points from which evaluation can proceed.
|
||||
data Package term = Package
|
||||
{ packageInfo :: PackageInfo
|
||||
, packageBody :: PackageBody term
|
||||
}
|
||||
deriving (Eq, Functor, Ord, Show)
|
||||
|
||||
fromModules :: [Module term] -> PackageBody term
|
||||
fromModules [] = PackageBody mempty mempty
|
||||
fromModules (m:ms) = PackageBody (ModuleTable.fromModules (m:ms)) entryPoints
|
||||
where entryPoints = ModuleTable.singleton (modulePath (moduleInfo m)) Nothing
|
||||
@ -5,9 +5,12 @@ import Control.Abstract.Analysis
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.Environment as Env
|
||||
import Data.Align (alignWith)
|
||||
import Data.Semigroup.Reducer (Reducer)
|
||||
import Prelude hiding (fail)
|
||||
import Prologue
|
||||
|
||||
type TName = Int
|
||||
|
||||
-- | A datatype representing primitive types and combinations thereof.
|
||||
data Type
|
||||
= Int -- ^ Primitive int type.
|
||||
@ -43,15 +46,21 @@ unify t1 t2
|
||||
| otherwise = fail ("cannot unify " ++ show t1 ++ " with " ++ show t2)
|
||||
|
||||
|
||||
type instance LocationFor Type = Monovariant
|
||||
|
||||
instance ValueRoots Type where
|
||||
instance Ord location => ValueRoots location Type where
|
||||
valueRoots _ = mempty
|
||||
|
||||
|
||||
-- | Discard the value arguments (if any), constructing a 'Type' instead.
|
||||
instance (Alternative m, MonadEnvironment Type m, MonadFail m, MonadFresh m, MonadHeap Type m) => MonadValue Type m where
|
||||
abstract names (Subterm _ body) = do
|
||||
instance ( Alternative m
|
||||
, MonadAddressable location m
|
||||
, MonadEnvironment location Type m
|
||||
, MonadFail m
|
||||
, MonadFresh m
|
||||
, MonadHeap location Type m
|
||||
, Reducer Type (Cell location Type)
|
||||
)
|
||||
=> MonadValue location Type m where
|
||||
lambda names (Subterm _ body) = do
|
||||
(env, tvars) <- foldr (\ name rest -> do
|
||||
a <- alloc name
|
||||
tvar <- Var <$> fresh
|
||||
@ -109,7 +118,7 @@ instance (Alternative m, MonadEnvironment Type m, MonadFail m, MonadFresh m, Mon
|
||||
(Int, Float) -> pure Int
|
||||
_ -> unify left right $> Bool
|
||||
|
||||
apply op params = do
|
||||
call op params = do
|
||||
tvar <- fresh
|
||||
paramTypes <- sequenceA params
|
||||
_ :-> ret <- op `unify` (Product paramTypes :-> Var tvar)
|
||||
|
||||
@ -2,7 +2,6 @@
|
||||
module Data.Abstract.Value where
|
||||
|
||||
import Control.Abstract.Analysis
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.Environment (Environment)
|
||||
import qualified Data.Abstract.Environment as Env
|
||||
import Data.Abstract.Evaluatable
|
||||
@ -13,16 +12,16 @@ import Prologue hiding (TypeError)
|
||||
import Prelude hiding (Float, Integer, String, Rational, fail)
|
||||
import qualified Prelude
|
||||
|
||||
type ValueConstructors
|
||||
type ValueConstructors location
|
||||
= '[Array
|
||||
, Boolean
|
||||
, Class
|
||||
, Closure
|
||||
, Class location
|
||||
, Closure location
|
||||
, Float
|
||||
, Hash
|
||||
, Integer
|
||||
, KVPair
|
||||
, Namespace
|
||||
, Namespace location
|
||||
, Null
|
||||
, Rational
|
||||
, String
|
||||
@ -33,32 +32,32 @@ type ValueConstructors
|
||||
|
||||
-- | Open union of primitive values that terms can be evaluated to.
|
||||
-- Fix by another name.
|
||||
newtype Value = Value { deValue :: Union ValueConstructors Value }
|
||||
newtype Value location = Value { deValue :: Union (ValueConstructors location) (Value location) }
|
||||
deriving (Eq, Show, Ord)
|
||||
|
||||
-- | Identical to 'inj', but wraps the resulting sub-entity in a 'Value'.
|
||||
injValue :: (f :< ValueConstructors) => f Value -> Value
|
||||
injValue :: (f :< ValueConstructors location) => f (Value location) -> Value location
|
||||
injValue = Value . inj
|
||||
|
||||
-- | Identical to 'prj', but unwraps the argument out of its 'Value' wrapper.
|
||||
prjValue :: (f :< ValueConstructors) => Value -> Maybe (f Value)
|
||||
prjValue :: (f :< ValueConstructors location) => Value location -> Maybe (f (Value location))
|
||||
prjValue = prj . deValue
|
||||
|
||||
-- | Convenience function for projecting two values.
|
||||
prjPair :: (f :< ValueConstructors , g :< ValueConstructors)
|
||||
=> (Value, Value)
|
||||
-> Maybe (f Value, g Value)
|
||||
prjPair :: (f :< ValueConstructors location , g :< ValueConstructors location)
|
||||
=> (Value location, Value location)
|
||||
-> Maybe (f (Value location), g (Value location))
|
||||
prjPair = bitraverse prjValue prjValue
|
||||
|
||||
-- TODO: Parameterize Value by the set of constructors s.t. each language can have a distinct value union.
|
||||
|
||||
-- | A function value consisting of a list of parameter 'Name's, a 'Label' to jump to the body of the function, and an 'Environment' of bindings captured by the body.
|
||||
data Closure value = Closure [Name] Label (Environment Precise value)
|
||||
data Closure location value = Closure [Name] Label (Environment location value)
|
||||
deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Eq1 Closure where liftEq = genericLiftEq
|
||||
instance Ord1 Closure where liftCompare = genericLiftCompare
|
||||
instance Show1 Closure where liftShowsPrec = genericLiftShowsPrec
|
||||
instance Eq location => Eq1 (Closure location) where liftEq = genericLiftEq
|
||||
instance Ord location => Ord1 (Closure location) where liftCompare = genericLiftCompare
|
||||
instance Show location => Show1 (Closure location) where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- | The unit value. Typically used to represent the result of imperative statements.
|
||||
data Unit value = Unit
|
||||
@ -138,23 +137,23 @@ instance Show1 Array where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- | Class values. There will someday be a difference between classes and objects,
|
||||
-- but for the time being we're pretending all languages have prototypical inheritance.
|
||||
data Class value = Class
|
||||
data Class location value = Class
|
||||
{ _className :: Name
|
||||
, _classScope :: Environment Precise value
|
||||
, _classScope :: Environment location value
|
||||
} deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Eq1 Class where liftEq = genericLiftEq
|
||||
instance Ord1 Class where liftCompare = genericLiftCompare
|
||||
instance Show1 Class where liftShowsPrec = genericLiftShowsPrec
|
||||
instance Eq location => Eq1 (Class location) where liftEq = genericLiftEq
|
||||
instance Ord location => Ord1 (Class location) where liftCompare = genericLiftCompare
|
||||
instance Show location => Show1 (Class location) where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
data Namespace value = Namespace
|
||||
data Namespace location value = Namespace
|
||||
{ namespaceName :: Name
|
||||
, namespaceScope :: Environment Precise value
|
||||
, namespaceScope :: Environment location value
|
||||
} deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Eq1 Namespace where liftEq = genericLiftEq
|
||||
instance Ord1 Namespace where liftCompare = genericLiftCompare
|
||||
instance Show1 Namespace where liftShowsPrec = genericLiftShowsPrec
|
||||
instance Eq location => Eq1 (Namespace location) where liftEq = genericLiftEq
|
||||
instance Ord location => Ord1 (Namespace location) where liftCompare = genericLiftCompare
|
||||
instance Show location => Show1 (Namespace location) where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
data KVPair value = KVPair value value
|
||||
deriving (Eq, Generic1, Ord, Show)
|
||||
@ -184,15 +183,14 @@ instance Ord1 Null where liftCompare = genericLiftCompare
|
||||
instance Show1 Null where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
|
||||
type instance LocationFor Value = Precise
|
||||
|
||||
instance ValueRoots Value where
|
||||
instance Ord location => ValueRoots location (Value location) where
|
||||
valueRoots v
|
||||
| Just (Closure _ _ env) <- prjValue v = Env.addresses env
|
||||
| otherwise = mempty
|
||||
|
||||
|
||||
-- | Construct a 'Value' wrapping the value arguments (if any).
|
||||
instance (Monad m, MonadEvaluatable term Value m) => MonadValue Value m where
|
||||
instance (Monad m, MonadEvaluatable location term (Value location) m) => MonadValue location (Value location) m where
|
||||
unit = pure . injValue $ Unit
|
||||
integer = pure . injValue . Integer . Number.Integer
|
||||
boolean = pure . injValue . Boolean
|
||||
@ -259,7 +257,7 @@ instance (Monad m, MonadEvaluatable term Value m) => MonadValue Value m where
|
||||
| otherwise = fail ("Invalid operands to liftNumeric2: " <> show pair)
|
||||
where
|
||||
-- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor
|
||||
specialize :: MonadValue value m => Number.SomeNumber -> m value
|
||||
specialize :: MonadValue location value m => Number.SomeNumber -> m value
|
||||
specialize (Number.SomeNumber (Number.Integer i)) = integer i
|
||||
specialize (Number.SomeNumber (Number.Ratio r)) = rational r
|
||||
specialize (Number.SomeNumber (Number.Decimal d)) = float d
|
||||
@ -277,7 +275,7 @@ instance (Monad m, MonadEvaluatable term Value m) => MonadValue Value m where
|
||||
where
|
||||
-- Explicit type signature is necessary here because we're passing all sorts of things
|
||||
-- to these comparison functions.
|
||||
go :: (Ord a, MonadValue value m) => a -> a -> m value
|
||||
go :: (Ord a, MonadValue location value m) => a -> a -> m value
|
||||
go l r = case comparator of
|
||||
Concrete f -> boolean (f l r)
|
||||
Generalized -> integer (orderingToInt (compare l r))
|
||||
@ -298,11 +296,11 @@ instance (Monad m, MonadEvaluatable term Value m) => MonadValue Value m where
|
||||
| otherwise = fail ("Type error: invalid binary bitwise operation on " <> show pair)
|
||||
where pair = (left, right)
|
||||
|
||||
abstract names (Subterm body _) = do
|
||||
lambda names (Subterm body _) = do
|
||||
l <- label body
|
||||
injValue . Closure names l . Env.bind (foldr Set.delete (Set.fromList (freeVariables body)) names) <$> getEnv
|
||||
|
||||
apply op params = do
|
||||
call op params = do
|
||||
Closure names label env <- maybe (fail ("expected a closure, got: " <> show op)) pure (prjValue op)
|
||||
bindings <- foldr (\ (name, param) rest -> do
|
||||
v <- param
|
||||
|
||||
@ -106,7 +106,7 @@ instance Ord1 Identifier where liftCompare = genericLiftCompare
|
||||
instance Show1 Identifier where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Identifier where
|
||||
eval (Identifier name) = lookupWith deref name >>= maybe (throwException $ FreeVariableError name) pure
|
||||
eval (Identifier name) = variable name
|
||||
|
||||
instance FreeVariables1 Identifier where
|
||||
liftFreeVariables _ (Identifier x) = pure x
|
||||
|
||||
@ -22,7 +22,7 @@ instance Show1 Function where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Function where
|
||||
eval Function{..} = do
|
||||
(v, addr) <- letrec name (abstract (paramNames functionParameters) functionBody)
|
||||
(v, addr) <- letrec name (lambda (paramNames functionParameters) functionBody)
|
||||
modifyEnv (Env.insert name addr)
|
||||
pure v
|
||||
where paramNames = foldMap (freeVariables . subterm)
|
||||
@ -43,7 +43,7 @@ instance Show1 Method where liftShowsPrec = genericLiftShowsPrec
|
||||
-- local environment.
|
||||
instance Evaluatable Method where
|
||||
eval Method{..} = do
|
||||
(v, addr) <- letrec name (abstract (paramNames methodParameters) methodBody)
|
||||
(v, addr) <- letrec name (lambda (paramNames methodParameters) methodBody)
|
||||
modifyEnv (Env.insert name addr)
|
||||
pure v
|
||||
where paramNames = foldMap (freeVariables . subterm)
|
||||
|
||||
@ -6,7 +6,7 @@ import Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent)
|
||||
import Data.Fixed
|
||||
import Diffing.Algorithm
|
||||
import Prelude
|
||||
import Prologue hiding (apply)
|
||||
import Prologue
|
||||
|
||||
-- | Typical prefix function application, like `f(x)` in many languages, or `f x` in Haskell.
|
||||
data Call a = Call { callContext :: ![a], callFunction :: !a, callParams :: ![a], callBlock :: !a }
|
||||
@ -19,7 +19,7 @@ instance Show1 Call where liftShowsPrec = genericLiftShowsPrec
|
||||
instance Evaluatable Call where
|
||||
eval Call{..} = do
|
||||
op <- subtermValue callFunction
|
||||
apply op (map subtermValue callParams)
|
||||
call op (map subtermValue callParams)
|
||||
|
||||
data Comparison a
|
||||
= LessThan !a !a
|
||||
|
||||
@ -20,9 +20,9 @@ defaultAlias :: ImportPath -> Name
|
||||
defaultAlias = BC.pack . takeFileName . unPath
|
||||
|
||||
-- TODO: need to delineate between relative and absolute Go imports
|
||||
resolveGoImport :: MonadEvaluatable term value m => FilePath -> m [M.ModuleName]
|
||||
resolveGoImport :: MonadEvaluatable location term value m => FilePath -> m [M.ModuleName]
|
||||
resolveGoImport relImportPath = do
|
||||
M.Module{..} <- currentModule
|
||||
M.ModuleInfo{..} <- currentModule
|
||||
let relRootDir = takeDirectory (makeRelative moduleRoot modulePath)
|
||||
listModulesInDir $ normalise (relRootDir </> normalise relImportPath)
|
||||
|
||||
|
||||
@ -34,13 +34,13 @@ instance Evaluatable VariableName
|
||||
-- file, the complete contents of the included file are treated as though it
|
||||
-- were defined inside that function.
|
||||
|
||||
resolvePHPName :: MonadEvaluatable term value m => ByteString -> m M.ModuleName
|
||||
resolvePHPName :: MonadEvaluatable location term value m => ByteString -> m M.ModuleName
|
||||
resolvePHPName n = resolve [name] >>= maybeFail notFound
|
||||
where name = toName n
|
||||
notFound = "Unable to resolve: " <> name
|
||||
toName = BC.unpack . dropRelativePrefix . stripQuotes
|
||||
|
||||
doInclude :: MonadEvaluatable term value m => Subterm t (m value) -> m value
|
||||
doInclude :: MonadEvaluatable location term value m => Subterm t (m value) -> m value
|
||||
doInclude pathTerm = do
|
||||
name <- subtermValue pathTerm >>= asString
|
||||
path <- resolvePHPName name
|
||||
@ -48,7 +48,7 @@ doInclude pathTerm = do
|
||||
modifyEnv (mappend importedEnv)
|
||||
pure v
|
||||
|
||||
doIncludeOnce :: MonadEvaluatable term value m => Subterm t (m value) -> m value
|
||||
doIncludeOnce :: MonadEvaluatable location term value m => Subterm t (m value) -> m value
|
||||
doIncludeOnce pathTerm = do
|
||||
name <- subtermValue pathTerm >>= asString
|
||||
path <- resolvePHPName name
|
||||
|
||||
@ -21,6 +21,8 @@ import System.FilePath.Posix
|
||||
-- 3. Parameterize and use eval (Evaluatable instance) and `subtermValue x >>= asString` in syntaxes like QualifiedImport
|
||||
|
||||
-- TODO: Model relative imports
|
||||
-- import .a
|
||||
-- import ..a
|
||||
|
||||
newtype QualifiedModuleName = QualifiedModuleName { unQualifiedModuleName :: NonEmpty FilePath }
|
||||
deriving (Eq, Ord, Show)
|
||||
@ -60,9 +62,9 @@ friendlyName (QualifiedModuleName xs) = intercalate "." (NonEmpty.toList xs)
|
||||
-- Subsequent imports of `parent.two` or `parent.three` will execute
|
||||
-- `parent/two/__init__.py` and
|
||||
-- `parent/three/__init__.py` respectively.
|
||||
resolvePythonModules :: MonadEvaluatable term value m => QualifiedModuleName -> m (NonEmpty M.ModuleName)
|
||||
resolvePythonModules :: MonadEvaluatable location term value m => QualifiedModuleName -> m (NonEmpty M.ModuleName)
|
||||
resolvePythonModules q@(QualifiedModuleName qualifiedName) = do
|
||||
M.Module{..} <- currentModule
|
||||
M.ModuleInfo{..} <- currentModule
|
||||
let relRootDir = takeDirectory (makeRelative moduleRoot modulePath)
|
||||
for (moduleNames qualifiedName) $ \name -> do
|
||||
go relRootDir name
|
||||
|
||||
@ -4,7 +4,7 @@ module Language.Ruby.Syntax where
|
||||
import Control.Monad (unless)
|
||||
import Data.Abstract.Evaluatable
|
||||
import qualified Data.Abstract.Module as M
|
||||
import Data.Abstract.ModuleTable
|
||||
import Data.Abstract.ModuleTable as ModuleTable
|
||||
import Data.Abstract.Path
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
import Diffing.Algorithm
|
||||
@ -16,14 +16,14 @@ import System.FilePath.Posix
|
||||
-- TODO: Fully sort out ruby require/load mechanics
|
||||
--
|
||||
-- require "json"
|
||||
resolveRubyName :: MonadEvaluatable term value m => ByteString -> m M.ModuleName
|
||||
resolveRubyName :: MonadEvaluatable location term value m => ByteString -> m M.ModuleName
|
||||
resolveRubyName n = resolve [name <.> "rb"] >>= maybeFail notFound
|
||||
where name = toName n
|
||||
notFound = "Unable to resolve: " <> name
|
||||
toName = BC.unpack . dropRelativePrefix . stripQuotes
|
||||
|
||||
-- load "/root/src/file.rb"
|
||||
resolveRubyPath :: MonadEvaluatable term value m => ByteString -> m M.ModuleName
|
||||
resolveRubyPath :: MonadEvaluatable location term value m => ByteString -> m M.ModuleName
|
||||
resolveRubyPath n = resolve [name] >>= maybeFail notFound
|
||||
where name = toName n
|
||||
notFound = "Unable to resolve: " <> name
|
||||
@ -44,12 +44,12 @@ instance Evaluatable Require where
|
||||
modifyEnv (mappend importedEnv)
|
||||
pure 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 :: MonadEvaluatable term value m
|
||||
doRequire :: MonadEvaluatable location term value m
|
||||
=> ModuleName
|
||||
-> m (EnvironmentFor value, value)
|
||||
-> m (Environment location value, value)
|
||||
doRequire name = do
|
||||
moduleTable <- getModuleTable
|
||||
case moduleTableLookup name moduleTable of
|
||||
case ModuleTable.lookup name moduleTable of
|
||||
Nothing -> (,) . fst <$> load name <*> boolean True
|
||||
Just (env, _) -> (,) env <$> boolean False
|
||||
|
||||
@ -71,7 +71,7 @@ instance Evaluatable Load where
|
||||
doLoad path shouldWrap
|
||||
eval (Load _) = fail "invalid argument supplied to load, path is required"
|
||||
|
||||
doLoad :: MonadEvaluatable term value m => ByteString -> Bool -> m value
|
||||
doLoad :: MonadEvaluatable location term value m => ByteString -> Bool -> m value
|
||||
doLoad path shouldWrap = do
|
||||
path' <- resolveRubyPath path
|
||||
(importedEnv, _) <- isolate (load path')
|
||||
|
||||
@ -27,7 +27,7 @@ importPath str = let path = stripQuotes str in ImportPath (BC.unpack path) (path
|
||||
toName :: ImportPath -> Name
|
||||
toName = BC.pack . unPath
|
||||
|
||||
resolveTypeScriptModule :: MonadEvaluatable term value m => ImportPath -> m M.ModuleName
|
||||
resolveTypeScriptModule :: MonadEvaluatable location term value m => ImportPath -> m M.ModuleName
|
||||
resolveTypeScriptModule (ImportPath path Relative) = resolveRelativeTSModule path
|
||||
resolveTypeScriptModule (ImportPath path NonRelative) = resolveNonRelativeTSModule path
|
||||
|
||||
@ -38,9 +38,9 @@ resolveTypeScriptModule (ImportPath path NonRelative) = resolveNonRelativeTSModu
|
||||
-- /root/src/moduleB.ts
|
||||
-- /root/src/moduleB/package.json (if it specifies a "types" property)
|
||||
-- /root/src/moduleB/index.ts
|
||||
resolveRelativeTSModule :: MonadEvaluatable term value m => FilePath -> m M.ModuleName
|
||||
resolveRelativeTSModule :: MonadEvaluatable location term value m => FilePath -> m M.ModuleName
|
||||
resolveRelativeTSModule relImportPath = do
|
||||
M.Module{..} <- currentModule
|
||||
M.ModuleInfo{..} <- currentModule
|
||||
let relRootDir = takeDirectory (makeRelative moduleRoot modulePath)
|
||||
let path = normalise (relRootDir </> normalise relImportPath)
|
||||
resolveTSModule path >>= either notFound pure
|
||||
@ -57,9 +57,9 @@ resolveRelativeTSModule relImportPath = do
|
||||
--
|
||||
-- /root/node_modules/moduleB.ts, etc
|
||||
-- /node_modules/moduleB.ts, etc
|
||||
resolveNonRelativeTSModule :: MonadEvaluatable term value m => FilePath -> m M.ModuleName
|
||||
resolveNonRelativeTSModule :: MonadEvaluatable location term value m => FilePath -> m M.ModuleName
|
||||
resolveNonRelativeTSModule name = do
|
||||
M.Module{..} <- currentModule
|
||||
M.ModuleInfo{..} <- currentModule
|
||||
go "." (makeRelative moduleRoot modulePath) mempty
|
||||
where
|
||||
nodeModulesPath dir = takeDirectory dir </> "node_modules" </> name
|
||||
@ -72,7 +72,7 @@ resolveNonRelativeTSModule name = do
|
||||
Right m -> pure m
|
||||
notFound xs = fail $ "Unable to resolve non-relative module import: " <> show name <> ", looked for it in: " <> show xs
|
||||
|
||||
resolveTSModule :: MonadEvaluatable term value m => FilePath -> m (Either [FilePath] M.ModuleName)
|
||||
resolveTSModule :: MonadEvaluatable location term value m => FilePath -> m (Either [FilePath] M.ModuleName)
|
||||
resolveTSModule path = maybe (Left searchPaths) Right <$> resolve searchPaths
|
||||
where exts = ["ts", "tsx", "d.ts"]
|
||||
searchPaths =
|
||||
|
||||
@ -12,15 +12,17 @@ import Analysis.Abstract.Tracing
|
||||
import Analysis.Declaration
|
||||
import Control.Abstract.Analysis
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Abstract.Evaluatable
|
||||
import Data.Abstract.Evaluatable hiding (head)
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.Module
|
||||
import Data.Abstract.Package as Package
|
||||
import Data.Abstract.Type
|
||||
import Data.Abstract.Value
|
||||
import Data.Blob
|
||||
import Data.Diff
|
||||
import Data.Range
|
||||
import Data.Record
|
||||
import Data.Semigroup.Reducer
|
||||
import Data.Span
|
||||
import Data.Term
|
||||
import Diffing.Algorithm
|
||||
@ -43,20 +45,20 @@ import qualified Language.TypeScript.Assignment as TypeScript
|
||||
-- Ruby
|
||||
evalRubyProject = evaluateProjectWithPrelude rubyParser ["rb"]
|
||||
evalRubyFile = evaluateWithPrelude rubyParser
|
||||
evaluateRubyImportGraph paths = runAnalysis @(ImportGraphing (Evaluating Ruby.Term Value)) . evaluateModules <$> parseFiles rubyParser (dropFileName (head paths)) paths
|
||||
evaluateRubyBadVariables paths = runAnalysis @(BadVariables (Evaluating Ruby.Term Value)) . evaluateModules <$> parseFiles rubyParser (dropFileName (head paths)) paths
|
||||
evaluateRubyImportGraph paths = runAnalysis @(ImportGraphing (Evaluating Precise Ruby.Term (Value Precise))) . evaluateModules <$> parseFiles rubyParser (dropFileName (head paths)) paths
|
||||
evaluateRubyBadVariables paths = runAnalysis @(BadVariables (Evaluating Precise Ruby.Term (Value Precise))) . evaluateModules <$> parseFiles rubyParser (dropFileName (head paths)) paths
|
||||
|
||||
-- Go
|
||||
evalGoProject = evaluateProject goParser ["go"]
|
||||
evalGoFile = evaluateFile goParser
|
||||
typecheckGoFile path = runAnalysis @(Caching (Evaluating Go.Term Type)) . evaluateModule <$> parseFile goParser Nothing path
|
||||
typecheckGoFile path = runAnalysis @(Caching (Evaluating Monovariant Go.Term Type)) . evaluateModule <$> parseFile goParser Nothing path
|
||||
|
||||
-- Python
|
||||
evalPythonProject = evaluateProject pythonParser ["py"]
|
||||
evalPythonFile = evaluateWithPrelude pythonParser
|
||||
typecheckPythonFile path = runAnalysis @(Caching (Evaluating Python.Term Type)) . evaluateModule <$> parseFile pythonParser Nothing path
|
||||
tracePythonFile path = runAnalysis @(Tracing [] (Evaluating Python.Term Value)) . evaluateModule <$> parseFile pythonParser Nothing path
|
||||
evaluateDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] (Evaluating Python.Term Value))) . evaluateModule <$> parseFile pythonParser Nothing path
|
||||
typecheckPythonFile path = runAnalysis @(Caching (Evaluating Monovariant Python.Term Type)) . evaluateModule <$> parseFile pythonParser Nothing path
|
||||
tracePythonFile path = runAnalysis @(Tracing [] (Evaluating Precise Python.Term (Value Precise))) . evaluateModule <$> parseFile pythonParser Nothing path
|
||||
evaluateDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] (Evaluating Precise Python.Term (Value Precise)))) . evaluateModule <$> parseFile pythonParser Nothing path
|
||||
|
||||
-- PHP
|
||||
evalPHPProject = evaluateProject phpParser ["php"]
|
||||
@ -65,38 +67,38 @@ evalPHPFile = evaluateFile phpParser
|
||||
-- TypeScript
|
||||
evalTypeScriptProject = evaluateProject typescriptParser ["ts", "tsx"]
|
||||
evalTypeScriptFile = evaluateFile typescriptParser
|
||||
typecheckTypeScriptFile path = runAnalysis @(Caching (Evaluating TypeScript.Term Type)) . evaluateModule <$> parseFile typescriptParser Nothing path
|
||||
typecheckTypeScriptFile path = runAnalysis @(Caching (Evaluating Monovariant TypeScript.Term Type)) . evaluateModule <$> parseFile typescriptParser Nothing path
|
||||
|
||||
evaluateProject :: forall term effects
|
||||
. ( Evaluatable (Base term)
|
||||
. ( Corecursive term
|
||||
, Evaluatable (Base term)
|
||||
, FreeVariables term
|
||||
, effects ~ Effects term Value (Evaluating term Value effects)
|
||||
, MonadAddressable Precise Value (Evaluating term Value effects)
|
||||
, MonadValue Value (Evaluating term Value effects)
|
||||
, effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects)
|
||||
, MonadAddressable Precise (Evaluating Precise term (Value Precise) effects)
|
||||
, Recursive term
|
||||
)
|
||||
=> Parser term
|
||||
-> [FilePath]
|
||||
-> FilePath
|
||||
-> IO (Final effects Value)
|
||||
-> IO (Final effects (Value Precise))
|
||||
evaluateProject parser exts entryPoint = do
|
||||
let rootDir = takeDirectory entryPoint
|
||||
paths <- filter (/= entryPoint) <$> getPaths exts rootDir
|
||||
evaluateFiles parser rootDir (entryPoint : paths)
|
||||
|
||||
evaluateProjectWithPrelude :: forall term effects
|
||||
. ( Evaluatable (Base term)
|
||||
. ( Corecursive term
|
||||
, Evaluatable (Base term)
|
||||
, FreeVariables term
|
||||
, effects ~ Effects term Value (Evaluating term Value effects)
|
||||
, MonadAddressable Precise Value (Evaluating term Value effects)
|
||||
, MonadValue Value (Evaluating term Value effects)
|
||||
, effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects)
|
||||
, MonadAddressable Precise (Evaluating Precise term (Value Precise) effects)
|
||||
, Recursive term
|
||||
, TypeLevel.KnownSymbol (PreludePath term)
|
||||
)
|
||||
=> Parser term
|
||||
-> [FilePath]
|
||||
-> FilePath
|
||||
-> IO (Final effects Value)
|
||||
-> IO (Final effects (Value Precise))
|
||||
evaluateProjectWithPrelude parser exts entryPoint = do
|
||||
let rootDir = takeDirectory entryPoint
|
||||
paths <- filter (/= entryPoint) <$> getPaths exts rootDir
|
||||
@ -106,31 +108,33 @@ getPaths exts = fmap fold . globDir (compile . mappend "**/*." <$> exts)
|
||||
|
||||
-- Evalute a single file.
|
||||
evaluateFile :: forall term effects
|
||||
. ( Evaluatable (Base term)
|
||||
. ( Corecursive term
|
||||
, Evaluatable (Base term)
|
||||
, FreeVariables term
|
||||
, effects ~ Effects term Value (Evaluating term Value effects)
|
||||
, MonadAddressable Precise Value (Evaluating term Value effects)
|
||||
, MonadValue Value (Evaluating term Value effects)
|
||||
, effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects)
|
||||
, MonadAddressable Precise (Evaluating Precise term (Value Precise) effects)
|
||||
, Recursive term
|
||||
)
|
||||
=> Parser term
|
||||
-> FilePath
|
||||
-> IO (Final effects Value)
|
||||
evaluateFile parser path = runAnalysis @(Evaluating term Value) . evaluateModule <$> parseFile parser Nothing path
|
||||
-> IO (Final effects (Value Precise))
|
||||
evaluateFile parser path = runAnalysis @(Evaluating Precise term (Value Precise)) . evaluateModule <$> parseFile parser Nothing path
|
||||
|
||||
evaluateWith :: forall value term effects
|
||||
. ( effects ~ Effects term value (Evaluating term value effects)
|
||||
evaluateWith :: forall location value term effects
|
||||
. ( Corecursive term
|
||||
, effects ~ Effects location term value (Evaluating location term value effects)
|
||||
, Evaluatable (Base term)
|
||||
, FreeVariables term
|
||||
, MonadAddressable (LocationFor value) value (Evaluating term value effects)
|
||||
, MonadValue value (Evaluating term value effects)
|
||||
, MonadAddressable location (Evaluating location term value effects)
|
||||
, MonadValue location value (Evaluating location term value effects)
|
||||
, Recursive term
|
||||
, Show (LocationFor value)
|
||||
, Reducer value (Cell location value)
|
||||
, Show location
|
||||
)
|
||||
=> Module term
|
||||
-> Module term
|
||||
-> Final effects value
|
||||
evaluateWith prelude m = runAnalysis @(Evaluating term value) $ do
|
||||
evaluateWith prelude m = runAnalysis @(Evaluating location term value) $ do
|
||||
-- TODO: we could add evaluatePrelude to MonadAnalysis as an alias for evaluateModule,
|
||||
-- overridden in Evaluating to not reset the environment. In the future we'll want the
|
||||
-- result of evaluating the Prelude to be a build artifact, rather than something that's
|
||||
@ -140,75 +144,76 @@ evaluateWith prelude m = runAnalysis @(Evaluating term value) $ do
|
||||
withDefaultEnvironment preludeEnv (evaluateModule m)
|
||||
|
||||
evaluateWithPrelude :: forall term effects
|
||||
. ( Evaluatable (Base term)
|
||||
. ( Corecursive term
|
||||
, Evaluatable (Base term)
|
||||
, FreeVariables term
|
||||
, effects ~ Effects term Value (Evaluating term Value effects)
|
||||
, MonadAddressable Precise Value (Evaluating term Value effects)
|
||||
, MonadValue Value (Evaluating term Value effects)
|
||||
, effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects)
|
||||
, MonadAddressable Precise (Evaluating Precise term (Value Precise) effects)
|
||||
, Recursive term
|
||||
, TypeLevel.KnownSymbol (PreludePath term)
|
||||
)
|
||||
=> Parser term
|
||||
-> FilePath
|
||||
-> IO (Final effects Value)
|
||||
-> IO (Final effects (Value Precise))
|
||||
evaluateWithPrelude parser path = do
|
||||
let preludePath = TypeLevel.symbolVal (Proxy :: Proxy (PreludePath term))
|
||||
prelude <- parseFile parser Nothing preludePath
|
||||
m <- parseFile parser Nothing path
|
||||
pure $ evaluateWith prelude m
|
||||
pure $ evaluateWith @Precise prelude m
|
||||
|
||||
|
||||
-- Evaluate a list of files (head of file list is considered the entry point).
|
||||
evaluateFiles :: forall term effects
|
||||
. ( Evaluatable (Base term)
|
||||
. ( Corecursive term
|
||||
, Evaluatable (Base term)
|
||||
, FreeVariables term
|
||||
, effects ~ Effects term Value (Evaluating term Value effects)
|
||||
, MonadAddressable Precise Value (Evaluating term Value effects)
|
||||
, MonadValue Value (Evaluating term Value effects)
|
||||
, effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects)
|
||||
, MonadAddressable Precise (Evaluating Precise term (Value Precise) effects)
|
||||
, Recursive term
|
||||
)
|
||||
=> Parser term
|
||||
-> FilePath
|
||||
-> [FilePath]
|
||||
-> IO (Final effects Value)
|
||||
evaluateFiles parser rootDir paths = runAnalysis @(Evaluating term Value) . evaluateModules <$> parseFiles parser rootDir paths
|
||||
-> IO (Final effects (Value Precise))
|
||||
evaluateFiles parser rootDir paths = runAnalysis @(Evaluating Precise term (Value Precise)) . evaluateModules <$> parseFiles parser rootDir paths
|
||||
|
||||
-- | Evaluate terms and an entry point to a value with a given prelude.
|
||||
evaluatesWith :: forall value term effects
|
||||
. ( effects ~ Effects term value (Evaluating term value effects)
|
||||
evaluatesWith :: forall location value term effects
|
||||
. ( Corecursive term
|
||||
, effects ~ Effects location term value (Evaluating location term value effects)
|
||||
, Evaluatable (Base term)
|
||||
, FreeVariables term
|
||||
, MonadAddressable (LocationFor value) value (Evaluating term value effects)
|
||||
, MonadValue value (Evaluating term value effects)
|
||||
, MonadAddressable location (Evaluating location term value effects)
|
||||
, MonadValue location value (Evaluating location term value effects)
|
||||
, Recursive term
|
||||
, Show (LocationFor value)
|
||||
, Reducer value (Cell location value)
|
||||
, Show location
|
||||
)
|
||||
=> Module term -- ^ Prelude to evaluate once
|
||||
-> [Module term] -- ^ List of (blob, term) pairs that make up the program to be evaluated
|
||||
-> Module term -- ^ Entrypoint
|
||||
-> [Module term] -- ^ List of modules that make up the program to be evaluated
|
||||
-> Final effects value
|
||||
evaluatesWith prelude modules m = runAnalysis @(Evaluating term value) $ do
|
||||
evaluatesWith prelude modules = runAnalysis @(Evaluating location term value) $ do
|
||||
preludeEnv <- evaluateModule prelude *> getEnv
|
||||
withDefaultEnvironment preludeEnv (withModules modules (evaluateModule m))
|
||||
withDefaultEnvironment preludeEnv (evaluateModules modules)
|
||||
|
||||
evaluateFilesWithPrelude :: forall term effects
|
||||
. ( Evaluatable (Base term)
|
||||
. ( Corecursive term
|
||||
, Evaluatable (Base term)
|
||||
, FreeVariables term
|
||||
, effects ~ Effects term Value (Evaluating term Value effects)
|
||||
, MonadAddressable Precise Value (Evaluating term Value effects)
|
||||
, MonadValue Value (Evaluating term Value effects)
|
||||
, effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects)
|
||||
, MonadAddressable Precise (Evaluating Precise term (Value Precise) effects)
|
||||
, Recursive term
|
||||
, TypeLevel.KnownSymbol (PreludePath term)
|
||||
)
|
||||
=> Parser term
|
||||
-> FilePath
|
||||
-> [FilePath]
|
||||
-> IO (Final effects Value)
|
||||
-> IO (Final effects (Value Precise))
|
||||
evaluateFilesWithPrelude parser rootDir paths = do
|
||||
let preludePath = TypeLevel.symbolVal (Proxy :: Proxy (PreludePath term))
|
||||
prelude <- parseFile parser Nothing preludePath
|
||||
entry:xs <- parseFiles parser rootDir paths
|
||||
pure $ evaluatesWith @Value prelude xs entry
|
||||
xs <- parseFiles parser rootDir paths
|
||||
pure $ evaluatesWith @Precise @(Value Precise) prelude xs
|
||||
|
||||
-- Read and parse a file.
|
||||
parseFile :: Parser term -> Maybe FilePath -> FilePath -> IO (Module term)
|
||||
@ -218,7 +223,10 @@ parseFile parser rootDir path = runTask $ do
|
||||
|
||||
parseFiles :: Parser term -> FilePath -> [FilePath] -> IO [Module term]
|
||||
parseFiles parser rootDir = traverse (parseFile parser (Just rootDir))
|
||||
-- where x = (Just (dropFileName (head paths)))
|
||||
|
||||
parsePackage :: PackageName -> Parser term -> FilePath -> [FilePath] -> IO (Package term)
|
||||
parsePackage name parser rootDir files = Package (PackageInfo name Nothing) . Package.fromModules <$> parseFiles parser rootDir files
|
||||
|
||||
|
||||
-- Read a file from the filesystem into a Blob.
|
||||
file :: MonadIO m => FilePath -> m Blob
|
||||
|
||||
@ -15,7 +15,7 @@ import Analysis.Abstract.Evaluating as X (EvaluatingState(..))
|
||||
import Data.Abstract.Address as X
|
||||
import Data.Abstract.FreeVariables as X hiding (dropExtension)
|
||||
import Data.Abstract.Heap as X
|
||||
import Data.Abstract.ModuleTable as X
|
||||
import Data.Abstract.ModuleTable as X hiding (lookup)
|
||||
import Data.Blob as X
|
||||
import Data.Functor.Listable as X
|
||||
import Data.Language as X
|
||||
|
||||
Loading…
Reference in New Issue
Block a user