From 4695e4c544f9a0042393748d710ec4f39f33f60f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 30 Nov 2017 19:16:28 -0500 Subject: [PATCH] Extract Cache into its own module. --- semantic-diff.cabal | 1 + src/Abstract/Interpreter/Caching.hs | 48 ++----------------------- src/Data/Abstract/Cache.hs | 55 +++++++++++++++++++++++++++++ 3 files changed, 58 insertions(+), 46 deletions(-) create mode 100644 src/Data/Abstract/Cache.hs diff --git a/semantic-diff.cabal b/semantic-diff.cabal index ac122fb06..5175e2ae5 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -38,6 +38,7 @@ library , Control.Monad.Effect.Trace -- General datatype definitions & generic algorithms , Data.Abstract.Address + , Data.Abstract.Cache , Data.Abstract.Configuration , Data.Abstract.Environment , Data.Abstract.Eval diff --git a/src/Abstract/Interpreter/Caching.hs b/src/Abstract/Interpreter/Caching.hs index 88e7fe2e9..399c60d13 100644 --- a/src/Abstract/Interpreter/Caching.hs +++ b/src/Abstract/Interpreter/Caching.hs @@ -14,9 +14,10 @@ import Control.Monad.Effect.Reader import Control.Monad.Effect.State import Control.Monad.Effect.Store import Data.Abstract.Address -import Data.Abstract.Eval +import Data.Abstract.Cache import Data.Abstract.Configuration import Data.Abstract.Environment +import Data.Abstract.Eval import Data.Abstract.FreeVariables import Data.Abstract.Store import Data.Abstract.Value @@ -27,26 +28,8 @@ import Data.Maybe import Data.Pointed import Data.Semigroup import qualified Data.Set as Set -import qualified Data.Map as Map import Data.Term -newtype Cache l t v = Cache { unCache :: Map.Map (Configuration l t v) (Set.Set (v, Store l v)) } - -deriving instance (Eq l, Eq t, Eq v, Eq (Cell l v)) => Eq (Cache l t v) -deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Ord (Cache l t v) -deriving instance (Show l, Show t, Show v, Show (Cell l v)) => Show (Cache l t v) -deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Monoid (Cache l t v) - -cacheLookup :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> Cache l t v -> Maybe (Set.Set (v, Store l v)) -cacheLookup key = Map.lookup key . unCache - -cacheSet :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> Set.Set (v, Store l v) -> Cache l t v -> Cache l t v -cacheSet = (((Cache .) . (. unCache)) .) . Map.insert - -cacheInsert :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> (v, Store l v) -> Cache l t v -> Cache l t v -cacheInsert = (((Cache .) . (. unCache)) .) . (. point) . Map.insertWith (<>) - - type CachingInterpreter t v = '[Fresh, Reader (Set.Set (Address (LocationFor v) v)), Reader (Environment (LocationFor v) v), Fail, NonDetEff, State (Store (LocationFor v) v), Reader (Cache (LocationFor v) t v), State (Cache (LocationFor v) t v)] type CachingResult t v = Final (CachingInterpreter t v) v @@ -173,30 +156,3 @@ mlfp a f = loop a return x else loop x' - - -instance (Eq l, Eq1 (Cell l)) => Eq2 (Cache l) where - liftEq2 eqT eqV (Cache a) (Cache b) = liftEq2 (liftEq2 eqT eqV) (liftEq (liftEq2 eqV (liftEq eqV))) a b - -instance (Eq l, Eq t, Eq1 (Cell l)) => Eq1 (Cache l t) where - liftEq = liftEq2 (==) - - -instance (Ord l, Ord1 (Cell l)) => Ord2 (Cache l) where - liftCompare2 compareT compareV (Cache a) (Cache b) = liftCompare2 (liftCompare2 compareT compareV) (liftCompare (liftCompare2 compareV (liftCompare compareV))) a b - -instance (Ord l, Ord t, Ord1 (Cell l)) => Ord1 (Cache l t) where - liftCompare = liftCompare2 compare - - -instance (Show l, Show1 (Cell l)) => Show2 (Cache l) where - liftShowsPrec2 spT slT spV slV d = showsUnaryWith (liftShowsPrec2 spKey slKey (liftShowsPrec spPair slPair) (liftShowList spPair slPair)) "Cache" d . unCache - where spKey = liftShowsPrec2 spT slT spV slV - slKey = liftShowList2 spT slT spV slV - spPair = liftShowsPrec2 spV slV spStore slStore - slPair = liftShowList2 spV slV spStore slStore - spStore = liftShowsPrec spV slV - slStore = liftShowList spV slV - -instance (Show l, Show t, Show1 (Cell l)) => Show1 (Cache l t) where - liftShowsPrec = liftShowsPrec2 showsPrec showList diff --git a/src/Data/Abstract/Cache.hs b/src/Data/Abstract/Cache.hs new file mode 100644 index 000000000..9e317c804 --- /dev/null +++ b/src/Data/Abstract/Cache.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, UndecidableInstances #-} +module Data.Abstract.Cache where + +import Data.Abstract.Address +import Data.Abstract.Configuration +import Data.Abstract.Store +import Data.Functor.Classes +import Data.Pointed +import Data.Semigroup +import Data.Set +import Data.Map as Map + +newtype Cache l t v = Cache { unCache :: Map.Map (Configuration l t v) (Set (v, Store l v)) } + +deriving instance (Eq l, Eq t, Eq v, Eq (Cell l v)) => Eq (Cache l t v) +deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Ord (Cache l t v) +deriving instance (Show l, Show t, Show v, Show (Cell l v)) => Show (Cache l t v) +deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Semigroup (Cache l t v) +deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Monoid (Cache l t v) + +cacheLookup :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> Cache l t v -> Maybe (Set (v, Store l v)) +cacheLookup key = Map.lookup key . unCache + +cacheSet :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> Set (v, Store l v) -> Cache l t v -> Cache l t v +cacheSet = (((Cache .) . (. unCache)) .) . Map.insert + +cacheInsert :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> (v, Store l v) -> Cache l t v -> Cache l t v +cacheInsert = (((Cache .) . (. unCache)) .) . (. point) . Map.insertWith (<>) + + +instance (Eq l, Eq1 (Cell l)) => Eq2 (Cache l) where + liftEq2 eqT eqV (Cache a) (Cache b) = liftEq2 (liftEq2 eqT eqV) (liftEq (liftEq2 eqV (liftEq eqV))) a b + +instance (Eq l, Eq t, Eq1 (Cell l)) => Eq1 (Cache l t) where + liftEq = liftEq2 (==) + + +instance (Ord l, Ord1 (Cell l)) => Ord2 (Cache l) where + liftCompare2 compareT compareV (Cache a) (Cache b) = liftCompare2 (liftCompare2 compareT compareV) (liftCompare (liftCompare2 compareV (liftCompare compareV))) a b + +instance (Ord l, Ord t, Ord1 (Cell l)) => Ord1 (Cache l t) where + liftCompare = liftCompare2 compare + + +instance (Show l, Show1 (Cell l)) => Show2 (Cache l) where + liftShowsPrec2 spT slT spV slV d = showsUnaryWith (liftShowsPrec2 spKey slKey (liftShowsPrec spPair slPair) (liftShowList spPair slPair)) "Cache" d . unCache + where spKey = liftShowsPrec2 spT slT spV slV + slKey = liftShowList2 spT slT spV slV + spPair = liftShowsPrec2 spV slV spStore slStore + slPair = liftShowList2 spV slV spStore slStore + spStore = liftShowsPrec spV slV + slStore = liftShowList spV slV + +instance (Show l, Show t, Show1 (Cell l)) => Show1 (Cache l t) where + liftShowsPrec = liftShowsPrec2 showsPrec showList