mirror of
https://github.com/github/semantic.git
synced 2024-11-28 01:47:01 +03:00
Merge branch 'master' into update-haskell-tree-sitter
This commit is contained in:
Josh Vera
GitHub
commit
6566b05d4c
@ -13,29 +13,29 @@ import Data.Abstract.Ref
|
||||
import Prologue
|
||||
|
||||
-- | Look up the set of values for a given configuration in the in-cache.
|
||||
consultOracle :: (Cacheable term address (Cell address) value, Member (Reader (Cache term address (Cell address) value)) effects)
|
||||
=> Configuration term address (Cell address) value
|
||||
-> TermEvaluator term address value effects (Set (Cached address (Cell address) value))
|
||||
consultOracle :: (Cacheable term address value, Member (Reader (Cache term address value)) effects)
|
||||
=> Configuration term address value
|
||||
-> TermEvaluator term address value effects (Set (Cached address value))
|
||||
consultOracle configuration = fromMaybe mempty . cacheLookup configuration <$> ask
|
||||
|
||||
-- | Run an action with the given in-cache.
|
||||
withOracle :: Member (Reader (Cache term address (Cell address) value)) effects
|
||||
=> Cache term address (Cell address) value
|
||||
withOracle :: Member (Reader (Cache term address value)) effects
|
||||
=> Cache term address value
|
||||
-> TermEvaluator term address value effects a
|
||||
-> TermEvaluator term address value effects a
|
||||
withOracle cache = local (const cache)
|
||||
|
||||
|
||||
-- | Look up the set of values for a given configuration in the out-cache.
|
||||
lookupCache :: (Cacheable term address (Cell address) value, Member (State (Cache term address (Cell address) value)) effects)
|
||||
=> Configuration term address (Cell address) value
|
||||
-> TermEvaluator term address value effects (Maybe (Set (Cached address (Cell address) value)))
|
||||
lookupCache :: (Cacheable term address value, Member (State (Cache term address value)) effects)
|
||||
=> Configuration term address value
|
||||
-> TermEvaluator term address value effects (Maybe (Set (Cached address value)))
|
||||
lookupCache configuration = cacheLookup configuration <$> get
|
||||
|
||||
-- | Run an action, caching its result and 'Heap' under the given configuration.
|
||||
cachingConfiguration :: (Cacheable term address (Cell address) value, Member (State (Cache term address (Cell address) value)) effects, Member (State (Heap address (Cell address) value)) effects)
|
||||
=> Configuration term address (Cell address) value
|
||||
-> Set (Cached address (Cell address) value)
|
||||
cachingConfiguration :: (Cacheable term address value, Member (State (Cache term address value)) effects, Member (State (Heap address value)) effects)
|
||||
=> Configuration term address value
|
||||
-> Set (Cached address value)
|
||||
-> TermEvaluator term address value effects (ValueRef address)
|
||||
-> TermEvaluator term address value effects (ValueRef address)
|
||||
cachingConfiguration configuration values action = do
|
||||
@ -43,27 +43,27 @@ cachingConfiguration configuration values action = do
|
||||
result <- Cached <$> action <*> TermEvaluator getHeap
|
||||
cachedValue result <$ modify' (cacheInsert configuration result)
|
||||
|
||||
putCache :: Member (State (Cache term address (Cell address) value)) effects
|
||||
=> Cache term address (Cell address) value
|
||||
putCache :: Member (State (Cache term address value)) effects
|
||||
=> Cache term address value
|
||||
-> TermEvaluator term address value effects ()
|
||||
putCache = put
|
||||
|
||||
-- | Run an action starting from an empty out-cache, and return the out-cache afterwards.
|
||||
isolateCache :: Member (State (Cache term address (Cell address) value)) effects
|
||||
isolateCache :: Member (State (Cache term address value)) effects
|
||||
=> TermEvaluator term address value effects a
|
||||
-> TermEvaluator term address value effects (Cache term address (Cell address) value)
|
||||
-> TermEvaluator term address value effects (Cache term address value)
|
||||
isolateCache action = putCache lowerBound *> action *> get
|
||||
|
||||
|
||||
-- | Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache.
|
||||
cachingTerms :: ( Cacheable term address (Cell address) value
|
||||
cachingTerms :: ( Cacheable term address value
|
||||
, Corecursive term
|
||||
, Member NonDet effects
|
||||
, Member (Reader (Cache term address (Cell address) value)) effects
|
||||
, Member (Reader (Cache term address value)) effects
|
||||
, Member (Reader (Live address)) effects
|
||||
, Member (State (Cache term address (Cell address) value)) effects
|
||||
, Member (State (Cache term address value)) effects
|
||||
, Member (Env address) effects
|
||||
, Member (State (Heap address (Cell address) value)) effects
|
||||
, Member (State (Heap address value)) effects
|
||||
)
|
||||
=> SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef address))
|
||||
-> SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef address))
|
||||
@ -77,17 +77,17 @@ cachingTerms recur term = do
|
||||
cachingConfiguration c pairs (recur term)
|
||||
|
||||
convergingModules :: ( AbstractValue address value effects
|
||||
, Cacheable term address (Cell address) value
|
||||
, Cacheable term address value
|
||||
, Member Fresh effects
|
||||
, Member NonDet effects
|
||||
, Member (Reader (Cache term address (Cell address) value)) effects
|
||||
, Member (Reader (Cache term address value)) effects
|
||||
, Member (Reader (Live address)) effects
|
||||
, Member (Reader ModuleInfo) effects
|
||||
, Member (Reader Span) effects
|
||||
, Member (Resumable (BaseError (EnvironmentError address))) effects
|
||||
, Member (State (Cache term address (Cell address) value)) effects
|
||||
, Member (State (Cache term address value)) effects
|
||||
, Member (Env address) effects
|
||||
, Member (State (Heap address (Cell address) value)) effects
|
||||
, Member (State (Heap address value)) effects
|
||||
, Effects effects
|
||||
)
|
||||
=> SubtermAlgebra Module term (TermEvaluator term address value effects address)
|
||||
@ -124,11 +124,11 @@ converge seed f = loop seed
|
||||
loop x'
|
||||
|
||||
-- | Nondeterministically write each of a collection of stores & return their associated results.
|
||||
scatter :: (Foldable t, Member NonDet effects, Member (State (Heap address (Cell address) value)) effects) => t (Cached address (Cell address) value) -> TermEvaluator term address value effects (ValueRef address)
|
||||
scatter :: (Foldable t, Member NonDet effects, Member (State (Heap address value)) effects) => t (Cached address value) -> TermEvaluator term address value effects (ValueRef address)
|
||||
scatter = foldMapA (\ (Cached value heap') -> TermEvaluator (putHeap heap') $> value)
|
||||
|
||||
|
||||
caching :: Effects effects => TermEvaluator term address value (NonDet ': Reader (Cache term address (Cell address) value) ': State (Cache term address (Cell address) value) ': effects) a -> TermEvaluator term address value effects (Cache term address (Cell address) value, [a])
|
||||
caching :: Effects effects => TermEvaluator term address value (NonDet ': Reader (Cache term address value) ': State (Cache term address value) ': effects) a -> TermEvaluator term address value effects (Cache term address value, [a])
|
||||
caching
|
||||
= runState lowerBound
|
||||
. runReader lowerBound
|
||||
|
||||
@ -15,17 +15,17 @@ import Prologue
|
||||
tracingTerms :: ( Corecursive term
|
||||
, Member (Reader (Live address)) effects
|
||||
, Member (Env address) effects
|
||||
, Member (State (Heap address (Cell address) value)) effects
|
||||
, Member (Writer (trace (Configuration term address (Cell address) value))) effects
|
||||
, Reducer (Configuration term address (Cell address) value) (trace (Configuration term address (Cell address) value))
|
||||
, Member (State (Heap address value)) effects
|
||||
, Member (Writer (trace (Configuration term address value))) effects
|
||||
, Reducer (Configuration term address value) (trace (Configuration term address value))
|
||||
)
|
||||
=> trace (Configuration term address (Cell address) value)
|
||||
=> trace (Configuration term address value)
|
||||
-> SubtermAlgebra (Base term) term (TermEvaluator term address value effects a)
|
||||
-> SubtermAlgebra (Base term) term (TermEvaluator term address value effects a)
|
||||
tracingTerms proxy recur term = getConfiguration (embedSubterm term) >>= trace . (`asTypeOf` proxy) . Reducer.unit >> recur term
|
||||
|
||||
trace :: Member (Writer (trace (Configuration term address (Cell address) value))) effects => trace (Configuration term address (Cell address) value) -> TermEvaluator term address value effects ()
|
||||
trace :: Member (Writer (trace (Configuration term address value))) effects => trace (Configuration term address value) -> TermEvaluator term address value effects ()
|
||||
trace = tell
|
||||
|
||||
tracing :: (Monoid (trace (Configuration term address (Cell address) value)), Effects effects) => TermEvaluator term address value (Writer (trace (Configuration term address (Cell address) value)) ': effects) a -> TermEvaluator term address value effects (trace (Configuration term address (Cell address) value), a)
|
||||
tracing :: (Monoid (trace (Configuration term address value)), Effects effects) => TermEvaluator term address value (Writer (trace (Configuration term address value)) ': effects) a -> TermEvaluator term address value effects (trace (Configuration term address value), a)
|
||||
tracing = runWriter
|
||||
|
||||
@ -1,7 +1,6 @@
|
||||
{-# LANGUAGE GADTs, RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Control.Abstract.Addressable
|
||||
( Addressable(..)
|
||||
, Allocatable(..)
|
||||
( Allocatable(..)
|
||||
, Derefable(..)
|
||||
) where
|
||||
|
||||
@ -10,56 +9,51 @@ import Control.Abstract.Evaluator
|
||||
import Control.Abstract.Hole
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.Name
|
||||
import qualified Data.Set as Set
|
||||
import Prologue
|
||||
|
||||
-- | Defines allocation and dereferencing of addresses.
|
||||
class (Ord address, Show address) => Addressable address (effects :: [(* -> *) -> * -> *]) where
|
||||
-- | The type into which stored values will be written for a given address type.
|
||||
type family Cell address :: * -> *
|
||||
|
||||
class Addressable address effects => Allocatable address effects where
|
||||
class (Ord address, Show address) => Allocatable address effects where
|
||||
allocCell :: Name -> Evaluator address value effects address
|
||||
|
||||
class Addressable address effects => Derefable address effects where
|
||||
derefCell :: address -> Cell address value -> Evaluator address value effects (Maybe value)
|
||||
assignCell :: Ord value => address -> value -> Set value -> Evaluator address value effects (Set value)
|
||||
|
||||
class (Ord address, Show address) => Derefable address effects where
|
||||
derefCell :: address -> Set value -> Evaluator address value effects (Maybe value)
|
||||
|
||||
-- | 'Precise' addresses are always allocated a fresh address, and dereference to the 'Latest' value written.
|
||||
instance Addressable Precise effects where
|
||||
type Cell Precise = Latest
|
||||
|
||||
instance Member Fresh effects => Allocatable Precise effects where
|
||||
allocCell _ = Precise <$> fresh
|
||||
|
||||
instance Derefable Precise effects where
|
||||
derefCell _ = pure . getLast . unLatest
|
||||
assignCell _ value _ = pure (Set.singleton value)
|
||||
|
||||
instance Derefable Precise effects where
|
||||
derefCell _ = pure . fmap fst . Set.minView
|
||||
|
||||
-- | 'Monovariant' addresses allocate one address per unique variable name, and dereference once per stored value, nondeterministically.
|
||||
instance Addressable Monovariant effects where
|
||||
type Cell Monovariant = All
|
||||
|
||||
instance Allocatable Monovariant effects where
|
||||
allocCell = pure . Monovariant
|
||||
|
||||
assignCell _ value values = pure (Set.insert value values)
|
||||
|
||||
instance Member NonDet effects => Derefable Monovariant effects where
|
||||
derefCell _ = traverse (foldMapA pure) . nonEmpty . toList
|
||||
|
||||
-- | 'Located' addresses allocate & dereference using the underlying address, contextualizing addresses with the current 'PackageInfo' & 'ModuleInfo'.
|
||||
instance Addressable address effects => Addressable (Located address) effects where
|
||||
type Cell (Located address) = Cell address
|
||||
|
||||
instance (Allocatable address effects, Member (Reader ModuleInfo) effects, Member (Reader PackageInfo) effects, Member (Reader Span) effects) => Allocatable (Located address) effects where
|
||||
allocCell name = relocate (Located <$> allocCell name <*> currentPackage <*> currentModule <*> pure name <*> ask)
|
||||
|
||||
assignCell (Located loc _ _ _ _) value = relocate . assignCell loc value
|
||||
|
||||
instance Derefable address effects => Derefable (Located address) effects where
|
||||
derefCell (Located loc _ _ _ _) = relocate . derefCell loc
|
||||
|
||||
instance (Addressable address effects, Ord context, Show context) => Addressable (Hole context address) effects where
|
||||
type Cell (Hole context address) = Cell address
|
||||
|
||||
instance (Allocatable address effects, Ord context, Show context) => Allocatable (Hole context address) effects where
|
||||
allocCell name = relocate (Total <$> allocCell name)
|
||||
|
||||
assignCell (Total loc) value = relocate . assignCell loc value
|
||||
assignCell (Partial _) _ = pure
|
||||
|
||||
instance (Derefable address effects, Ord context, Show context) => Derefable (Hole context address) effects where
|
||||
derefCell (Total loc) = relocate . derefCell loc
|
||||
derefCell (Partial _) = const (pure Nothing)
|
||||
|
||||
@ -36,25 +36,24 @@ import Data.Abstract.Heap
|
||||
import Data.Abstract.Live
|
||||
import Data.Abstract.Module (ModuleInfo)
|
||||
import Data.Abstract.Name
|
||||
import Data.Semigroup.Reducer
|
||||
import Data.Span (Span)
|
||||
import Prologue
|
||||
|
||||
-- | Get the current 'Configuration' with a passed-in term.
|
||||
getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address) effects, Member (State (Heap address (Cell address) value)) effects) => term -> TermEvaluator term address value effects (Configuration term address (Cell address) value)
|
||||
getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address) effects, Member (State (Heap address value)) effects) => term -> TermEvaluator term address value effects (Configuration term address value)
|
||||
getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEvalContext <*> TermEvaluator getHeap
|
||||
|
||||
|
||||
-- | Retrieve the heap.
|
||||
getHeap :: Member (State (Heap address (Cell address) value)) effects => Evaluator address value effects (Heap address (Cell address) value)
|
||||
getHeap :: Member (State (Heap address value)) effects => Evaluator address value effects (Heap address value)
|
||||
getHeap = get
|
||||
|
||||
-- | Set the heap.
|
||||
putHeap :: Member (State (Heap address (Cell address) value)) effects => Heap address (Cell address) value -> Evaluator address value effects ()
|
||||
putHeap :: Member (State (Heap address value)) effects => Heap address value -> Evaluator address value effects ()
|
||||
putHeap = put
|
||||
|
||||
-- | Update the heap.
|
||||
modifyHeap :: Member (State (Heap address (Cell address) value)) effects => (Heap address (Cell address) value -> Heap address (Cell address) value) -> Evaluator address value effects ()
|
||||
modifyHeap :: Member (State (Heap address value)) effects => (Heap address value -> Heap address value) -> Evaluator address value effects ()
|
||||
modifyHeap = modify'
|
||||
|
||||
box :: ( Member (Allocator address value) effects
|
||||
@ -139,12 +138,11 @@ gc roots = sendAllocator (GC roots)
|
||||
|
||||
-- | Compute the set of addresses reachable from a given root set in a given heap.
|
||||
reachable :: ( Ord address
|
||||
, Foldable (Cell address)
|
||||
, ValueRoots address value
|
||||
)
|
||||
=> Live address -- ^ The set of root addresses.
|
||||
-> Heap address (Cell address) value -- ^ The heap to trace addresses through.
|
||||
-> Live address -- ^ The set of addresses reachable from the root set.
|
||||
=> Live address -- ^ The set of root addresses.
|
||||
-> Heap address value -- ^ The heap to trace addresses through.
|
||||
-> Live address -- ^ The set of addresses reachable from the root set.
|
||||
reachable roots heap = go mempty roots
|
||||
where go seen set = case liveSplit set of
|
||||
Nothing -> seen
|
||||
@ -167,17 +165,19 @@ data Deref address value (m :: * -> *) return where
|
||||
Deref :: address -> Deref address value m value
|
||||
|
||||
runAllocator :: ( Allocatable address effects
|
||||
, Foldable (Cell address)
|
||||
, Member (State (Heap address (Cell address) value)) effects
|
||||
, Member (State (Heap address value)) effects
|
||||
, Ord value
|
||||
, PureEffects effects
|
||||
, Reducer value (Cell address value)
|
||||
, ValueRoots address value
|
||||
)
|
||||
=> Evaluator address value (Allocator address value ': effects) a
|
||||
-> Evaluator address value effects a
|
||||
runAllocator = interpret $ \ eff -> case eff of
|
||||
Alloc name -> allocCell name
|
||||
Assign addr value -> modifyHeap (heapInsert addr value)
|
||||
Assign addr value -> do
|
||||
heap <- getHeap
|
||||
cell <- assignCell addr value (fromMaybe mempty (heapLookup addr heap))
|
||||
putHeap (heapInit addr cell heap)
|
||||
GC roots -> modifyHeap (heapRestrict <*> reachable roots)
|
||||
|
||||
runDeref :: ( Derefable address effects
|
||||
@ -185,7 +185,7 @@ runDeref :: ( Derefable address effects
|
||||
, Member (Reader ModuleInfo) effects
|
||||
, Member (Reader Span) effects
|
||||
, Member (Resumable (BaseError (AddressError address value))) effects
|
||||
, Member (State (Heap address (Cell address) value)) effects
|
||||
, Member (State (Heap address value)) effects
|
||||
)
|
||||
=> Evaluator address value (Deref address value ': effects) a
|
||||
-> Evaluator address value effects a
|
||||
@ -205,7 +205,7 @@ instance Effect (Deref address value) where
|
||||
handleState c dist (Request (Deref addr) k) = Request (Deref addr) (dist . (<$ c) . k)
|
||||
|
||||
data AddressError address value resume where
|
||||
UnallocatedAddress :: address -> AddressError address value (Cell address value)
|
||||
UnallocatedAddress :: address -> AddressError address value (Set value)
|
||||
UninitializedAddress :: address -> AddressError address value value
|
||||
|
||||
deriving instance Eq address => Eq (AddressError address value resume)
|
||||
|
||||
@ -88,7 +88,7 @@ instance (Member Fresh effects, Lambda address value effects ret) => Lambda addr
|
||||
{-# INLINE lambda' #-}
|
||||
|
||||
instance Member (Function address value) effects => Lambda address value effects (Evaluator address value effects address) where
|
||||
lambda' vars body = function vars lowerBound body
|
||||
lambda' vars = function vars lowerBound
|
||||
{-# INLINE lambda' #-}
|
||||
|
||||
builtInPrint :: ( AbstractValue address value effects
|
||||
|
||||
@ -1,19 +1,13 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-}
|
||||
module Data.Abstract.Address
|
||||
( Precise (..)
|
||||
, Located (..)
|
||||
, Latest (..)
|
||||
, All (..)
|
||||
, Monovariant (..)
|
||||
) where
|
||||
|
||||
import Data.Abstract.Module (ModuleInfo)
|
||||
import Data.Abstract.Name
|
||||
import Data.Abstract.Package (PackageInfo)
|
||||
import Data.Monoid (Last(..))
|
||||
import Data.Semigroup.Reducer
|
||||
import Data.Span
|
||||
import Data.Set as Set
|
||||
import Prologue
|
||||
|
||||
-- | '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.
|
||||
@ -40,26 +34,3 @@ data Located address = Located
|
||||
, addressSpan :: Span
|
||||
}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
|
||||
-- | A cell holding a single value. Writes will replace any prior value.
|
||||
--
|
||||
-- This is equivalent to 'Data.Monoid.Last', but with a 'Show' instance designed to minimize the amount of text we have to scroll past in ghci.
|
||||
newtype Latest value = Latest { unLatest :: Last value }
|
||||
deriving (Eq, Foldable, Functor, Lower, Monoid, Semigroup, Ord, Traversable)
|
||||
|
||||
instance Reducer value (Latest value) where
|
||||
unit = Latest . unit . Just
|
||||
|
||||
instance Show value => Show (Latest value) where
|
||||
showsPrec d = showsPrec d . getLast . unLatest
|
||||
|
||||
|
||||
-- | A cell holding all values written to its address.
|
||||
--
|
||||
-- This is equivalent to 'Set', but with a 'Show' instance designed to minimize the amount of text we have to scroll past in ghci.
|
||||
newtype All value = All { unAll :: Set value }
|
||||
deriving (Eq, Foldable, Lower, Monoid, Ord, Reducer value, Semigroup)
|
||||
|
||||
instance Show value => Show (All value) where
|
||||
showsPrec d = showsPrec d . Set.toList . unAll
|
||||
|
||||
@ -16,33 +16,33 @@ import Data.Map.Monoidal as Monoidal
|
||||
import Prologue
|
||||
|
||||
-- | A map of 'Configuration's to 'Set's of resulting values & 'Heap's.
|
||||
newtype Cache term address cell value = Cache { unCache :: Monoidal.Map (Configuration term address cell value) (Set (Cached address cell value)) }
|
||||
deriving (Eq, Lower, Monoid, Ord, Reducer (Configuration term address cell value, Cached address cell value), Semigroup)
|
||||
newtype Cache term address value = Cache { unCache :: Monoidal.Map (Configuration term address value) (Set (Cached address value)) }
|
||||
deriving (Eq, Lower, Monoid, Ord, Reducer (Configuration term address value, Cached address value), Semigroup)
|
||||
|
||||
data Cached address cell value = Cached
|
||||
data Cached address value = Cached
|
||||
{ cachedValue :: ValueRef address
|
||||
, cachedHeap :: Heap address cell value
|
||||
, cachedHeap :: Heap address value
|
||||
}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
|
||||
type Cacheable term address cell value = (Ord (cell value), Ord address, Ord term, Ord value)
|
||||
type Cacheable term address value = (Ord address, Ord term, Ord value)
|
||||
|
||||
-- | Look up the resulting value & 'Heap' for a given 'Configuration'.
|
||||
cacheLookup :: Cacheable term address cell value => Configuration term address cell value -> Cache term address cell value -> Maybe (Set (Cached address cell value))
|
||||
cacheLookup :: Cacheable term address value => Configuration term address value -> Cache term address value -> Maybe (Set (Cached address value))
|
||||
cacheLookup key = Monoidal.lookup key . unCache
|
||||
|
||||
-- | Set the resulting value & 'Heap' for a given 'Configuration', overwriting any previous entry.
|
||||
cacheSet :: Cacheable term address cell value => Configuration term address cell value -> Set (Cached address cell value) -> Cache term address cell value -> Cache term address cell value
|
||||
cacheSet :: Cacheable term address value => Configuration term address value -> Set (Cached address value) -> Cache term address value -> Cache term address value
|
||||
cacheSet key value = Cache . Monoidal.insert key value . unCache
|
||||
|
||||
-- | Insert the resulting value & 'Heap' for a given 'Configuration', appending onto any previous entry.
|
||||
cacheInsert :: Cacheable term address cell value => Configuration term address cell value -> Cached address cell value -> Cache term address cell value -> Cache term address cell value
|
||||
cacheInsert :: Cacheable term address value => Configuration term address value -> Cached address value -> Cache term address value -> Cache term address value
|
||||
cacheInsert = curry cons
|
||||
|
||||
-- | Return all 'Configuration's in the provided cache.
|
||||
cacheKeys :: Cache term address cell value -> [Configuration term address cell value]
|
||||
cacheKeys :: Cache term address value -> [Configuration term address value]
|
||||
cacheKeys = Monoidal.keys . unCache
|
||||
|
||||
instance (Show term, Show address, Show (cell value), Show value) => Show (Cache term address cell value) where
|
||||
instance (Show term, Show address, Show value) => Show (Cache term address value) where
|
||||
showsPrec d = showsUnaryWith showsPrec "Cache" d . map (second toList) . Monoidal.pairs . unCache
|
||||
|
||||
@ -5,10 +5,10 @@ import Data.Abstract.Heap
|
||||
import Data.Abstract.Live
|
||||
|
||||
-- | A single point in a program’s execution.
|
||||
data Configuration term address cell value = Configuration
|
||||
{ configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate.
|
||||
, configurationRoots :: Live address -- ^ The set of rooted addresses.
|
||||
, configurationContext :: EvalContext address -- ^ The evaluation context in 'configurationTerm'.
|
||||
, configurationHeap :: Heap address cell value -- ^ The heap of values.
|
||||
data Configuration term address value = Configuration
|
||||
{ configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate.
|
||||
, configurationRoots :: Live address -- ^ The set of rooted addresses.
|
||||
, configurationContext :: EvalContext address -- ^ The evaluation context in 'configurationTerm'.
|
||||
, configurationHeap :: Heap address value -- ^ The heap of values.
|
||||
}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
@ -17,7 +17,6 @@ module Data.Abstract.Evaluatable
|
||||
, runUnspecialized
|
||||
, runUnspecializedWith
|
||||
, throwUnspecializedError
|
||||
, Cell
|
||||
) where
|
||||
|
||||
import Control.Abstract hiding (Load)
|
||||
@ -40,7 +39,6 @@ import Data.Language
|
||||
import Data.Scientific (Scientific)
|
||||
import Data.Semigroup.App
|
||||
import Data.Semigroup.Foldable
|
||||
import Data.Semigroup.Reducer hiding (unit)
|
||||
import Data.Sum
|
||||
import Data.Term
|
||||
import Prologue
|
||||
@ -80,7 +78,6 @@ evaluate :: ( AbstractValue address value valueEffects
|
||||
, Declarations term
|
||||
, Effects effects
|
||||
, Evaluatable (Base term)
|
||||
, Foldable (Cell address)
|
||||
, FreeVariables term
|
||||
, HasPostlude lang
|
||||
, HasPrelude lang
|
||||
@ -94,10 +91,10 @@ evaluate :: ( AbstractValue address value valueEffects
|
||||
, Member (Resumable (BaseError EvalError)) effects
|
||||
, Member (Resumable (BaseError ResolutionError)) effects
|
||||
, Member (Resumable (BaseError (UnspecializedError value))) effects
|
||||
, Member (State (Heap address (Cell address) value)) effects
|
||||
, Member (State (Heap address value)) effects
|
||||
, Member Trace effects
|
||||
, Ord value
|
||||
, Recursive term
|
||||
, Reducer value (Cell address value)
|
||||
, ValueRoots address value
|
||||
, moduleEffects ~ (Exc (LoopControl address) ': Exc (Return address) ': Env address ': Deref address value ': Allocator address value ': Reader ModuleInfo ': effects)
|
||||
, valueEffects ~ (Function address value ': moduleEffects)
|
||||
|
||||
@ -15,38 +15,38 @@ import Data.Semigroup.Reducer
|
||||
import Prologue
|
||||
|
||||
-- | A map of addresses onto cells holding their values.
|
||||
newtype Heap address cell value = Heap { unHeap :: Monoidal.Map address (cell value) }
|
||||
deriving (Eq, Foldable, Functor, Lower, Monoid, Ord, Semigroup, Traversable)
|
||||
newtype Heap address value = Heap { unHeap :: Monoidal.Map address (Set value) }
|
||||
deriving (Eq, Foldable, Lower, Monoid, Ord, Semigroup)
|
||||
|
||||
-- | Look up the cell of values for an 'Address' in a 'Heap', if any.
|
||||
heapLookup :: Ord address => address -> Heap address cell value -> Maybe (cell value)
|
||||
heapLookup :: Ord address => address -> Heap address value -> Maybe (Set value)
|
||||
heapLookup address = Monoidal.lookup address . unHeap
|
||||
|
||||
-- | Look up the list of values stored for a given address, if any.
|
||||
heapLookupAll :: (Ord address, Foldable cell) => address -> Heap address cell value -> Maybe [value]
|
||||
heapLookupAll :: Ord address => address -> Heap address value -> Maybe [value]
|
||||
heapLookupAll address = fmap toList . heapLookup address
|
||||
|
||||
-- | Append a value onto the cell for a given address, inserting a new cell if none existed.
|
||||
heapInsert :: (Ord address, Reducer value (cell value)) => address -> value -> Heap address cell value -> Heap address cell value
|
||||
heapInsert :: (Ord address, Ord value) => address -> value -> Heap address value -> Heap address value
|
||||
heapInsert address value = flip snoc (address, value)
|
||||
|
||||
-- | Manually insert a cell into the heap at a given address.
|
||||
heapInit :: Ord address => address -> cell value -> Heap address cell value -> Heap address cell value
|
||||
heapInit :: Ord address => address -> Set value -> Heap address value -> Heap address value
|
||||
heapInit address cell (Heap h) = Heap (Monoidal.insert address cell h)
|
||||
|
||||
-- | The number of addresses extant in a 'Heap'.
|
||||
heapSize :: Heap address cell value -> Int
|
||||
heapSize :: Heap address value -> Int
|
||||
heapSize = Monoidal.size . unHeap
|
||||
|
||||
-- | Restrict a 'Heap' to only those addresses in the given 'Live' set (in essence garbage collecting the rest).
|
||||
heapRestrict :: Ord address => Heap address cell value -> Live address -> Heap address cell value
|
||||
heapRestrict :: Ord address => Heap address value -> Live address -> Heap address value
|
||||
heapRestrict (Heap m) roots = Heap (Monoidal.filterWithKey (\ address _ -> address `liveMember` roots) m)
|
||||
|
||||
|
||||
instance (Ord address, Reducer value (cell value)) => Reducer (address, value) (Heap address cell value) where
|
||||
instance (Ord address, Ord value) => Reducer (address, value) (Heap address value) where
|
||||
unit = Heap . unit
|
||||
cons (addr, a) (Heap heap) = Heap (cons (addr, a) heap)
|
||||
snoc (Heap heap) (addr, a) = Heap (snoc heap (addr, a))
|
||||
|
||||
instance (Show address, Show (cell value)) => Show (Heap address cell value) where
|
||||
instance (Show address, Show value) => Show (Heap address value) where
|
||||
showsPrec d = showsUnaryWith showsPrec "Heap" d . Monoidal.pairs . unHeap
|
||||
|
||||
@ -100,7 +100,7 @@ runCallGraph lang includePackages modules package = do
|
||||
= runTermEvaluator @_ @(Hole (Maybe Name) (Located Monovariant)) @Abstract
|
||||
. graphing @_ @_ @(Maybe Name) @Monovariant
|
||||
. caching
|
||||
. runState (lowerBound @(Heap (Hole (Maybe Name) (Located Monovariant)) All Abstract))
|
||||
. runState (lowerBound @(Heap (Hole (Maybe Name) (Located Monovariant)) Abstract))
|
||||
. runFresh 0
|
||||
. resumingLoadError
|
||||
. resumingUnspecialized
|
||||
@ -204,7 +204,7 @@ newtype ImportGraphEff address outerEffects a = ImportGraphEff
|
||||
': Resumable (BaseError (UnspecializedError (Value address (ImportGraphEff address outerEffects))))
|
||||
': Resumable (BaseError (LoadError address))
|
||||
': Fresh
|
||||
': State (Heap address Latest (Value address (ImportGraphEff address outerEffects)))
|
||||
': State (Heap address (Value address (ImportGraphEff address outerEffects)))
|
||||
': outerEffects
|
||||
) a
|
||||
}
|
||||
@ -295,7 +295,6 @@ resumingAddressError :: ( AbstractHole value
|
||||
, Applicative (m address value effects)
|
||||
, Effectful (m address value)
|
||||
, Effects effects
|
||||
, Lower (Cell address value)
|
||||
, Member Trace effects
|
||||
, Show address
|
||||
)
|
||||
|
||||
@ -73,14 +73,14 @@ newtype UtilEff a = UtilEff
|
||||
, Resumable (BaseError (LoadError Precise))
|
||||
, Trace
|
||||
, Fresh
|
||||
, State (Heap Precise Latest (Value Precise UtilEff))
|
||||
, State (Heap Precise (Value Precise UtilEff))
|
||||
, Lift IO
|
||||
] a
|
||||
}
|
||||
|
||||
checking
|
||||
= runM @_ @IO
|
||||
. runState (lowerBound @(Heap Monovariant All Type))
|
||||
. runState (lowerBound @(Heap Monovariant Type))
|
||||
. runFresh 0
|
||||
. runPrintingTrace
|
||||
. runTermEvaluator @_ @Monovariant @Type
|
||||
|
||||
@ -57,7 +57,6 @@ spec config = parallel $ do
|
||||
other -> expectationFailure (show other)
|
||||
|
||||
where
|
||||
ns n = Just . Latest . Last . Just . Namespace n
|
||||
fixtures = "test/fixtures/python/analysis/"
|
||||
evaluate = evalPythonProject . map (fixtures <>)
|
||||
evalPythonProject = testEvaluating <=< evaluateProject' config (Proxy :: Proxy 'Language.Python) pythonParser
|
||||
|
||||
@ -101,7 +101,6 @@ spec config = parallel $ do
|
||||
other -> expectationFailure (show other)
|
||||
|
||||
where
|
||||
ns n = Just . Latest . Last . Just . Namespace n
|
||||
fixtures = "test/fixtures/ruby/analysis/"
|
||||
evaluate = evalRubyProject . map (fixtures <>)
|
||||
evalRubyProject = testEvaluating <=< evaluateProject' config (Proxy :: Proxy 'Language.Ruby) rubyParser
|
||||
|
||||
@ -33,7 +33,7 @@ spec = parallel $ do
|
||||
|
||||
evaluate
|
||||
= runM
|
||||
. runState (lowerBound @(Heap Precise Latest Val))
|
||||
. runState (lowerBound @(Heap Precise Val))
|
||||
. runFresh 0
|
||||
. runReader (PackageInfo (name "test") mempty)
|
||||
. runReader (ModuleInfo "test/Control/Abstract/Evaluator/Spec.hs")
|
||||
@ -68,7 +68,7 @@ newtype SpecEff a = SpecEff
|
||||
, Reader ModuleInfo
|
||||
, Reader PackageInfo
|
||||
, Fresh
|
||||
, State (Heap Precise Latest Val)
|
||||
, State (Heap Precise Val)
|
||||
, Lift IO
|
||||
] a
|
||||
}
|
||||
|
||||
@ -70,6 +70,7 @@ import Test.Hspec.LeanCheck as X
|
||||
import Test.LeanCheck as X
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.Set as Set
|
||||
import qualified Semantic.IO as IO
|
||||
import Semantic.Config (Config)
|
||||
import Semantic.Telemetry (LogQueue, StatQueue)
|
||||
@ -105,7 +106,7 @@ type TestEvaluatingEffects = '[ Resumable (BaseError (ValueError Precise UtilEff
|
||||
, Resumable (BaseError (LoadError Precise))
|
||||
, Trace
|
||||
, Fresh
|
||||
, State (Heap Precise Latest Val)
|
||||
, State (Heap Precise Val)
|
||||
, Lift IO
|
||||
]
|
||||
type TestEvaluatingErrors = '[ BaseError (ValueError Precise UtilEff)
|
||||
@ -119,7 +120,7 @@ type TestEvaluatingErrors = '[ BaseError (ValueError Precise UtilEff)
|
||||
testEvaluating :: Evaluator Precise Val TestEvaluatingEffects (ModuleTable (NonEmpty (Module (ModuleResult Precise))))
|
||||
-> IO
|
||||
( [String]
|
||||
, ( Heap Precise Latest Val
|
||||
, ( Heap Precise Val
|
||||
, Either (SomeExc (Data.Sum.Sum TestEvaluatingErrors))
|
||||
(ModuleTable (NonEmpty (Module (ModuleResult Precise))))
|
||||
)
|
||||
@ -142,13 +143,13 @@ testEvaluating
|
||||
type Val = Value Precise UtilEff
|
||||
|
||||
|
||||
deNamespace :: Heap Precise (Cell Precise) (Value Precise term)
|
||||
deNamespace :: Heap Precise (Value Precise term)
|
||||
-> Value Precise term
|
||||
-> Maybe (Name, [Name])
|
||||
deNamespace heap ns@(Namespace name _ _) = (,) name . Env.allNames <$> namespaceScope heap ns
|
||||
deNamespace _ _ = Nothing
|
||||
|
||||
namespaceScope :: Heap Precise (Cell Precise) (Value Precise term)
|
||||
namespaceScope :: Heap Precise (Value Precise term)
|
||||
-> Value Precise term
|
||||
-> Maybe (Environment Precise)
|
||||
namespaceScope heap ns@(Namespace _ _ _)
|
||||
@ -164,9 +165,9 @@ namespaceScope heap ns@(Namespace _ _ _)
|
||||
|
||||
namespaceScope _ _ = Nothing
|
||||
|
||||
derefQName :: Heap Precise (Cell Precise) (Value Precise term) -> NonEmpty Name -> Bindings Precise -> Maybe (Value Precise term)
|
||||
derefQName :: Heap Precise (Value Precise term) -> NonEmpty Name -> Bindings Precise -> Maybe (Value Precise term)
|
||||
derefQName heap names binds = go names (Env.newEnv binds)
|
||||
where go (n1 :| ns) env = Env.lookupEnv' n1 env >>= flip heapLookup heap >>= getLast . unLatest >>= case ns of
|
||||
where go (n1 :| ns) env = Env.lookupEnv' n1 env >>= flip heapLookup heap >>= fmap fst . Set.minView >>= case ns of
|
||||
[] -> Just
|
||||
(n2 : ns) -> namespaceScope heap >=> go (n2 :| ns)
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user