github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-28 01:47:01 +03:00
Code Issues Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/master' into module-resolution

Browse Source
This commit is contained in:
Timothy Clem 2018-04-02 16:28:35 -07:00
commit 69a46e4edc
33 changed files with 731 additions and 526 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
semantic.cabal
View File

@ -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

18
src/Analysis/Abstract/BadVariables.hs
View File

@ -11,20 +11,20 @@ import Prologue
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 MonadControl term (m effects) => MonadControl term (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) ->

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

@ -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 MonadControl term (m effects) => MonadControl term (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)

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

@ -13,32 +13,30 @@ import Prologue
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 MonadControl term (m effects) => MonadControl term (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

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

@ -13,11 +13,11 @@ import Prologue
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 MonadControl term (m effects) => MonadControl term (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)

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

@ -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.
, 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.
, Fail -- Failure with an error message
, 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 (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)

33
src/Analysis/Abstract/ImportGraph.hs
View File

@ -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)
@ -26,20 +27,21 @@ renderImportGraph = export (defaultStyle BC.pack) . unImportGraph
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 MonadControl term (m effects) => MonadControl term (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
, Member (State ImportGraph) effects
, MonadEvaluator term value (m effects))
insertVertexName :: forall m location term value effects
. ( Effectful m
, Member (Reader (SomeOrigin term)) effects
, Member (State ImportGraph) 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
src/Analysis/Abstract/Quiet.hs
View File

@ -17,19 +17,19 @@ import Prologue
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 MonadControl term (m effects) => MonadControl term (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)

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

@ -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
@ -15,25 +16,25 @@ import Prologue
newtype Tracing (trace :: * -> *) m (effects :: [* -> *]) a = Tracing (m effects a)
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 MonadControl term (m effects) => MonadControl term (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

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

@ -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)
=> Name
-> 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

8
src/Control/Abstract/Analysis.hs
View File

@ -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

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

@ -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 :: *

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

@ -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
@ -114,25 +108,25 @@ class (Monad m, Show value) => MonadValue value m where
null :: m value
-- | 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
klass :: Name -- ^ The new class's identifier
-> [value] -- ^ A list of superclasses
-> 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
namespace :: Name -- ^ The namespace's identifier
-> 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

12
src/Control/Effect/Fresh.hs
View File

@ -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' ())

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

@ -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.

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

@ -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
View 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

16
src/Data/Abstract/Module.hs
View File

@ -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

39
src/Data/Abstract/ModuleTable.hs
View File

@ -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
View 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
View 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

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

@ -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)

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

@ -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

2
src/Data/Syntax.hs
View File

@ -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

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

@ -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)

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

@ -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

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

@ -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)

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

@ -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

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

@ -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

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

@ -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,14 +44,14 @@ 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
Just (env, _) -> (,) env <$> boolean False
newtype Load a = Load { loadArgs :: [a] }
@ -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')

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

@ -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 =

146
src/Semantic/Util.hs
View File

@ -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)
, FreeVariables term
, effects ~ Effects term Value (Evaluating term Value effects)
, MonadAddressable Precise Value (Evaluating term Value effects)
, MonadValue Value (Evaluating term Value effects)
, Recursive term
)
. ( Corecursive term
, Evaluatable (Base term)
, FreeVariables term
, 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)
, FreeVariables term
, effects ~ Effects term Value (Evaluating term Value effects)
, MonadAddressable Precise Value (Evaluating term Value effects)
, MonadValue Value (Evaluating term Value effects)
, Recursive term
, TypeLevel.KnownSymbol (PreludePath term)
)
=> Parser term
-> [FilePath]
-> FilePath
-> IO (Final effects Value)
. ( Corecursive term
, Evaluatable (Base term)
, FreeVariables term
, 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 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

2
test/SpecHelpers.hs
View File

@ -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