mirror of
https://github.com/github/semantic.git
synced 2024-12-20 05:11:44 +03:00
Swap the order of the term & location parameters to Configuration, Cache, and Cacheable.
This commit is contained in:
Rob Rix
parent
5c668b3a0c
commit
e40a549ee3
@ -13,42 +13,42 @@ import Data.Semilattice.Lower
|
||||
import Prologue
|
||||
|
||||
-- | Look up the set of values for a given configuration in the in-cache.
|
||||
consultOracle :: (Cacheable location term value, Member (Reader (Cache location term value)) effects) => Configuration location term value -> Evaluator location value effects (Set (value, Heap location value))
|
||||
consultOracle :: (Cacheable term location value, Member (Reader (Cache term location value)) effects) => Configuration term location value -> Evaluator location value effects (Set (value, Heap location value))
|
||||
consultOracle configuration = raise (fromMaybe mempty . cacheLookup configuration <$> ask)
|
||||
|
||||
-- | Run an action with the given in-cache.
|
||||
withOracle :: Member (Reader (Cache location term value)) effects => Cache location term value -> Evaluator location value effects a -> Evaluator location value effects a
|
||||
withOracle :: Member (Reader (Cache term location value)) effects => Cache term location value -> Evaluator location value effects a -> Evaluator location value effects a
|
||||
withOracle cache = raiseHandler (local (const cache))
|
||||
|
||||
|
||||
-- | Look up the set of values for a given configuration in the out-cache.
|
||||
lookupCache :: (Cacheable location term value, Member (State (Cache location term value)) effects) => Configuration location term value -> Evaluator location value effects (Maybe (Set (value, Heap location value)))
|
||||
lookupCache :: (Cacheable term location value, Member (State (Cache term location value)) effects) => Configuration term location value -> Evaluator location value effects (Maybe (Set (value, Heap location value)))
|
||||
lookupCache configuration = raise (cacheLookup configuration <$> get)
|
||||
|
||||
-- | Run an action, caching its result and 'Heap' under the given configuration.
|
||||
cachingConfiguration :: (Cacheable location term value, Members '[State (Cache location term value), State (Heap location value)] effects) => Configuration location term value -> Set (value, Heap location value) -> Evaluator location value effects value -> Evaluator location value effects value
|
||||
cachingConfiguration :: (Cacheable term location value, Members '[State (Cache term location value), State (Heap location value)] effects) => Configuration term location value -> Set (value, Heap location value) -> Evaluator location value effects value -> Evaluator location value effects value
|
||||
cachingConfiguration configuration values action = do
|
||||
raise (modify (cacheSet configuration values))
|
||||
result <- (,) <$> action <*> raise get
|
||||
raise (modify (cacheInsert configuration result))
|
||||
pure (fst result)
|
||||
|
||||
putCache :: Member (State (Cache location term value)) effects => Cache location term value -> Evaluator location value effects ()
|
||||
putCache :: Member (State (Cache term location value)) effects => Cache term location value -> Evaluator location value effects ()
|
||||
putCache = raise . put
|
||||
|
||||
-- | Run an action starting from an empty out-cache, and return the out-cache afterwards.
|
||||
isolateCache :: forall term location value effects a . Member (State (Cache location term value)) effects => Evaluator location value effects a -> Evaluator location value effects (Cache location term value)
|
||||
isolateCache action = putCache @location @term lowerBound *> action *> raise get
|
||||
isolateCache :: forall term location value effects a . Member (State (Cache term location value)) effects => Evaluator location value effects a -> Evaluator location value effects (Cache term location value)
|
||||
isolateCache action = putCache @term lowerBound *> action *> raise get
|
||||
|
||||
|
||||
-- | Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache.
|
||||
cachingTerms :: ( Cacheable location term value
|
||||
cachingTerms :: ( Cacheable term location value
|
||||
, Corecursive term
|
||||
, Members '[ Fresh
|
||||
, NonDet
|
||||
, Reader (Cache location term value)
|
||||
, Reader (Cache term location value)
|
||||
, Reader (Live location value)
|
||||
, State (Cache location term value)
|
||||
, State (Cache term location value)
|
||||
, State (Environment location value)
|
||||
, State (Heap location value)
|
||||
] effects
|
||||
@ -64,12 +64,12 @@ cachingTerms recur term = do
|
||||
pairs <- consultOracle c
|
||||
cachingConfiguration c pairs (recur term)
|
||||
|
||||
convergingModules :: ( Cacheable location term value
|
||||
convergingModules :: ( Cacheable term location value
|
||||
, Members '[ Fresh
|
||||
, NonDet
|
||||
, Reader (Cache location term value)
|
||||
, Reader (Cache term location value)
|
||||
, Reader (Live location value)
|
||||
, State (Cache location term value)
|
||||
, State (Cache term location value)
|
||||
, State (Environment location value)
|
||||
, State (Heap location value)
|
||||
] effects
|
||||
@ -115,7 +115,7 @@ scatter :: (Foldable t, Members '[NonDet, State (Heap location value)] effects)
|
||||
scatter = foldMapA (\ (value, heap') -> putHeap heap' $> value)
|
||||
|
||||
|
||||
caching :: Alternative f => Evaluator location value (NonDet ': Reader (Cache location term value) ': State (Cache location term value) ': effects) a -> Evaluator location value effects (f a, Cache location term value)
|
||||
caching :: Alternative f => Evaluator location value (NonDet ': Reader (Cache term location value) ': State (Cache term location value) ': effects) a -> Evaluator location value effects (f a, Cache term location value)
|
||||
caching
|
||||
= runState lowerBound
|
||||
. runReader lowerBound
|
||||
|
||||
@ -16,17 +16,17 @@ tracingTerms :: ( Corecursive term
|
||||
, Members '[ Reader (Live location value)
|
||||
, State (Environment location value)
|
||||
, State (Heap location value)
|
||||
, Writer (trace (Configuration location term value))
|
||||
, Writer (trace (Configuration term location value))
|
||||
] effects
|
||||
, Reducer (Configuration location term value) (trace (Configuration location term value))
|
||||
, Reducer (Configuration term location value) (trace (Configuration term location value))
|
||||
)
|
||||
=> trace (Configuration location term value)
|
||||
=> trace (Configuration term location value)
|
||||
-> SubtermAlgebra (Base term) term (Evaluator location value effects a)
|
||||
-> SubtermAlgebra (Base term) term (Evaluator location value effects a)
|
||||
tracingTerms proxy recur term = getConfiguration (embedSubterm term) >>= trace . (`asTypeOf` proxy) . Reducer.unit >> recur term
|
||||
|
||||
trace :: Member (Writer (trace (Configuration location term value))) effects => trace (Configuration location term value) -> Evaluator location value effects ()
|
||||
trace :: Member (Writer (trace (Configuration term location value))) effects => trace (Configuration term location value) -> Evaluator location value effects ()
|
||||
trace = raise . tell
|
||||
|
||||
tracing :: Monoid (trace (Configuration location term value)) => Evaluator location value (Writer (trace (Configuration location term value)) ': effects) a -> Evaluator location value effects (a, trace (Configuration location term value))
|
||||
tracing :: Monoid (trace (Configuration term location value)) => Evaluator location value (Writer (trace (Configuration term location value)) ': effects) a -> Evaluator location value effects (a, trace (Configuration term location value))
|
||||
tracing = raiseHandler runWriter
|
||||
|
||||
@ -12,5 +12,5 @@ import Data.Abstract.Configuration
|
||||
import Prologue
|
||||
|
||||
-- | Get the current 'Configuration' with a passed-in term.
|
||||
getConfiguration :: Members '[Reader (Live location value), State (Environment location value), State (Heap location value)] effects => term -> Evaluator location value effects (Configuration location term value)
|
||||
getConfiguration :: Members '[Reader (Live location value), State (Environment location value), State (Heap location value)] effects => term -> Evaluator location value effects (Configuration term location value)
|
||||
getConfiguration term = Configuration term <$> askRoots <*> getEnv <*> getHeap
|
||||
|
||||
@ -9,39 +9,39 @@ import Data.Semilattice.Lower
|
||||
import Prologue
|
||||
|
||||
-- | A map of 'Configuration's to 'Set's of resulting values & 'Heap's.
|
||||
newtype Cache location term value = Cache { unCache :: Monoidal.Map (Configuration location term value) (Set (value, Heap location value)) }
|
||||
newtype Cache term location value = Cache { unCache :: Monoidal.Map (Configuration term location value) (Set (value, Heap location value)) }
|
||||
deriving (Lower)
|
||||
|
||||
type Cacheable location term value = (Ord (Cell location value), Ord location, Ord term, Ord value)
|
||||
type Cacheable term location value = (Ord (Cell location value), Ord location, Ord term, Ord value)
|
||||
|
||||
deriving instance (Eq location, Eq term, Eq value, Eq (Cell location value)) => Eq (Cache location term value)
|
||||
deriving instance (Ord location, Ord term, Ord value, Ord (Cell location value)) => Ord (Cache location term value)
|
||||
deriving instance (Show location, Show term, Show value, Show (Cell location value)) => Show (Cache location term value)
|
||||
deriving instance (Eq term, Eq location, Eq value, Eq (Cell location value)) => Eq (Cache term location value)
|
||||
deriving instance (Ord term, Ord location, Ord value, Ord (Cell location value)) => Ord (Cache term location value)
|
||||
deriving instance (Show term, Show location, Show value, Show (Cell location value)) => Show (Cache term location value)
|
||||
|
||||
deriving instance Cacheable location term value => Semigroup (Cache location term value)
|
||||
deriving instance Cacheable location term value => Monoid (Cache location term value)
|
||||
deriving instance Cacheable location term value => Reducer (Configuration location term value, (value, Heap location value)) (Cache location term value)
|
||||
deriving instance Cacheable term location value => Semigroup (Cache term location value)
|
||||
deriving instance Cacheable term location value => Monoid (Cache term location value)
|
||||
deriving instance Cacheable term location value => Reducer (Configuration term location value, (value, Heap location value)) (Cache term location value)
|
||||
|
||||
-- | Look up the resulting value & 'Heap' for a given 'Configuration'.
|
||||
cacheLookup :: Cacheable location term value => Configuration location term value -> Cache location term value -> Maybe (Set (value, Heap location value))
|
||||
cacheLookup :: Cacheable term location value => Configuration term location value -> Cache term location value -> Maybe (Set (value, Heap location value))
|
||||
cacheLookup key = Monoidal.lookup key . unCache
|
||||
|
||||
-- | Set the resulting value & 'Heap' for a given 'Configuration', overwriting any previous entry.
|
||||
cacheSet :: Cacheable location term value => Configuration location term value -> Set (value, Heap location value) -> Cache location term value -> Cache location term value
|
||||
cacheSet :: Cacheable term location value => Configuration term location value -> Set (value, Heap location value) -> Cache term location value -> Cache term location 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 location term value => Configuration location term value -> (value, Heap location value) -> Cache location term value -> Cache location term value
|
||||
cacheInsert :: Cacheable term location value => Configuration term location value -> (value, Heap location value) -> Cache term location value -> Cache term location value
|
||||
cacheInsert = curry cons
|
||||
|
||||
|
||||
instance (Eq location, Eq term, Eq1 (Cell location)) => Eq1 (Cache location term) where
|
||||
instance (Eq term, Eq location, Eq1 (Cell location)) => Eq1 (Cache term location) where
|
||||
liftEq eqV (Cache c1) (Cache c2) = liftEq2 (liftEq eqV) (liftEq (liftEq2 eqV (liftEq eqV))) c1 c2
|
||||
|
||||
instance (Ord location, Ord term, Ord1 (Cell location)) => Ord1 (Cache location term) where
|
||||
instance (Ord term, Ord location, Ord1 (Cell location)) => Ord1 (Cache term location) where
|
||||
liftCompare compareV (Cache c1) (Cache c2) = liftCompare2 (liftCompare compareV) (liftCompare (liftCompare2 compareV (liftCompare compareV))) c1 c2
|
||||
|
||||
instance (Show location, Show term, Show1 (Cell location)) => Show1 (Cache location term) where
|
||||
instance (Show term, Show location, Show1 (Cell location)) => Show1 (Cache term location) where
|
||||
liftShowsPrec spV slV d = showsUnaryWith (liftShowsPrec2 spKey slKey (liftShowsPrec spPair slPair) (liftShowList spPair slPair)) "Cache" d . unCache
|
||||
where spKey = liftShowsPrec spV slV
|
||||
slKey = liftShowList spV slV
|
||||
|
||||
@ -8,7 +8,7 @@ import Data.Abstract.Live
|
||||
import Prologue
|
||||
|
||||
-- | A single point in a program’s execution.
|
||||
data Configuration location term value = Configuration
|
||||
data Configuration term location value = Configuration
|
||||
{ configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate.
|
||||
, configurationRoots :: Live location value -- ^ The set of rooted addresses.
|
||||
, configurationEnvironment :: Environment location value -- ^ The environment binding any free variables in 'configurationTerm'.
|
||||
@ -16,12 +16,12 @@ data Configuration location term value = Configuration
|
||||
}
|
||||
deriving (Generic1)
|
||||
|
||||
deriving instance (Eq location, Eq term, Eq value, Eq (Cell location value)) => Eq (Configuration location term value)
|
||||
deriving instance (Ord location, Ord term, Ord value, Ord (Cell location value)) => Ord (Configuration location term value)
|
||||
deriving instance (Show location, Show term, Show value, Show (Cell location value)) => Show (Configuration location term value)
|
||||
deriving instance (Eq term, Eq location, Eq value, Eq (Cell location value)) => Eq (Configuration term location value)
|
||||
deriving instance (Ord term, Ord location, Ord value, Ord (Cell location value)) => Ord (Configuration term location value)
|
||||
deriving instance (Show term, Show location, Show value, Show (Cell location value)) => Show (Configuration term location value)
|
||||
|
||||
deriving instance (Ord location, Foldable (Cell location)) => Foldable (Configuration location term)
|
||||
deriving instance (Ord location, Foldable (Cell location)) => Foldable (Configuration term location)
|
||||
|
||||
instance (Eq location, Eq term, Eq1 (Cell location)) => Eq1 (Configuration location term) where liftEq = genericLiftEq
|
||||
instance (Ord location, Ord term, Ord1 (Cell location)) => Ord1 (Configuration location term) where liftCompare = genericLiftCompare
|
||||
instance (Show location, Show term, Show1 (Cell location)) => Show1 (Configuration location term) where liftShowsPrec = genericLiftShowsPrec
|
||||
instance (Eq term, Eq location, Eq1 (Cell location)) => Eq1 (Configuration term location) where liftEq = genericLiftEq
|
||||
instance (Ord term, Ord location, Ord1 (Cell location)) => Ord1 (Configuration term location) where liftCompare = genericLiftCompare
|
||||
instance (Show term, Show location, Show1 (Cell location)) => Show1 (Configuration term location) where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
Loading…
Reference in New Issue
Block a user