packages feed

caching (empty) → 0

raw patch · 9 files changed

+512/−0 lines, 9 filesdep +basedep +dlistdep +hashablesetup-changed

Dependencies added: base, dlist, hashable, mtl, psqueues, ref-tf, transformers

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for caching++## 0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2020, davean++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of davean nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ caching.cabal view
@@ -0,0 +1,45 @@+cabal-version:       2.4+-- Initial package description 'caching.cabal' generated by 'cabal init'.+-- For further documentation, see http://haskell.org/cabal/users-guide/++name:                caching+version:             0+synopsis:            Cache combinators.+-- description:+homepage:            https://oss.xkcd.com/+-- bug-reports:+license:             BSD-3-Clause+license-file:        LICENSE+author:              davean+maintainer:          oss@xkcd.com+-- copyright:+category:            Data+extra-source-files:  CHANGELOG.md++common deps+  default-language:    Haskell2010+  build-depends:+      base ^>=4.12.0.0+    , dlist+    , hashable+    , mtl+    , psqueues+    , ref-tf+    , transformers++library+  import: deps+  hs-source-dirs:      src+  exposed-modules:+    Data.Cache+    Data.Cache.LRU+    Data.Cache.Trace+    Data.Cache.Type+--    Data.Cache.Expires++test-suite caching-test+  import:              deps+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             MyLibTest.hs+  build-depends:
+ src/Data/Cache.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE QuantifiedConstraints #-}+module Data.Cache+  ( filtering+  ) where++import Data.Cache.Trace+import Data.Cache.Type++-- | We can translate the tracking data.+--   When the first cache evicts data, try to insert it into the second.+--   Left bias, faster cache should come first.+--exclusive :: (Cache c1 m k t1 v, Cache c2 k t2 v) => c1 -> c2 -> (t1 -> t2) -> Cache m k t1 v++-- | Insert any data into both caches, retrieve it from either.+--   Left bias, faster cache should come first.+--inclusive :: (Cache c1 m k t v, Cache c2 k t v) => c1 -> c2 -> Cache m k t v++-- | Inserts to both, evicts if evicts from either.+--   Example usage is to augment a cache with a dataset size limit +--intersection :: (Cache c1 m k t1 v, Cache c2 k t2 v) => c1 -> c2 -> Cache m k (t1, t2) v++-- | Maps the key to one of a given number of caches and inserts and retrieves from there.+--stripped :: (Cache c m k t v) => [c] -> Cache m k t v++filtering :: (Monad m, forall (trc::Bool) . (Monad m) => Applicative (Tracable trc (CacheTrace k t v) m), Caching c m k t v)+          => (k -> t -> Bool) -> c -> DictCache m k t v+filtering f c =+  DictCache+    (\k t v -> if f k t then insetTraced c k t v else pure ())+    (lookupTraced c)+    (evictTraced c)+    (updateTracking c)
+ src/Data/Cache/LRU.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Data.Cache.LRU+ ( LRUCache+ , Strategy(..)+ ) where++import           Control.Monad.Ref+import           Data.Cache.Trace+import           Data.Cache.Type+import           Data.Hashable+import qualified Data.HashPSQ as PSQ+import qualified Data.DList as DList++newtype LRUCache m (s::Strategy) p k t v = LRUCache (Ref m (LRUCache' s p k t v))++data Strategy+ = FIFO -- ^ Priority is set on entry and not changed.+ -- | LIFO -- ^ A generally bad policy where the most recent thing is evicted.+ | LRU  -- ^ Every lookup generates a new priority.+ | LFU  -- ^ Priority is number of times looked up (tie breaker of order inserted?).+++data LRUCache' (s::Strategy) p k t v+ = LRUCache1'+   { lcCapacity :: !p+   -- ^ The maximum number of elements in the queue.+   , lcSize     :: !p+   -- ^ The current number of elements in the queue.+   , lcGen     :: !p+   -- ^ The next priority.+   , lcPSQueue  :: !(PSQ.HashPSQ k p (t, v))+   -- ^ The actual cache+   }+ -- | We need a variant with 2 queues to handle rollover of the priority.+ | LRUCache2'+   { lcCapacity :: !p+   -- ^ The maximum number of elements between both queues.+   , lcSize     :: !p+   -- ^ The current number of elements in the queue.+   , lcGen     :: !p+   -- ^ The next priority.+   , lcPSQueue  :: !(PSQ.HashPSQ k p (t, v))+   -- ^ The cache we're currently inserting to.+   , lcPSQueueOverflow  :: !(PSQ.HashPSQ k p (t, v))+   -- ^ The cache we're drawing down.+   }+ deriving (Eq, Show)++shrinkQueue :: forall k p t v . (Hashable k, Ord k, Enum p, Num p, Ord p)+            => p -> p -> PSQ.HashPSQ k p (t, v) -> (p, [CacheEvent k t v], PSQ.HashPSQ k p (t, v))+shrinkQueue c s' q' =+  go s' 0 [] q'+  where+    -- since the number removed is only the distance between c and s' which are in p, a p shouldn't roll over+    -- (This analysis fails with negative ranges taken into account).+    go :: p -> p -> [CacheEvent k t v] -> PSQ.HashPSQ k p (t, v) -> (p, [CacheEvent k t v], PSQ.HashPSQ k p (t, v))+    go s cnt trc q | s <= c = (cnt, trc, q)+    go s cnt trc q =+      case PSQ.minView q of+        -- can't remove anything more somehow.+        Nothing -> (cnt, trc, q)+        Just (k, p, (t, v), q') -> go (pred s) (cnt+1) ((CacheEvict k t v) : trc) q++trim :: forall s k p t v (trc::Bool) m+      . (Hashable k, Ord k, Enum p, Num p, Ord p, MonadTrace trc, Applicative m, Monad (Tracable trc (CacheTrace k t v) m))+     => LRUCache' s p k t v -> Tracable trc (CacheTrace k t v) m (LRUCache' s p k t v)+-- Skip the cases where we're the right size already.+trim (c@(LRUCache1' {lcCapacity=cap, lcSize=sz})) | cap >= sz = pure c+trim (c@(LRUCache2' {lcCapacity=cap, lcSize=sz})) | cap >= sz = pure c+-- Now we must have something to remove.+trim (c@(LRUCache1' {lcCapacity=cap, lcSize=sz, lcPSQueue=q})) = do+  let (removed, trc, nq) = shrinkQueue cap sz q+  trace $ DList.fromList trc+  pure (c {lcSize=sz-removed, lcPSQueue=nq})+-- We remove as much as we want to the limit of availabuility from the over flow queue,+-- if we still need to remove things we start removing from the main queue, possibly+-- switching to the 1 constructor variant.+trim (c@(LRUCache2' {lcCapacity=cap, lcSize=sz, lcPSQueue=q, lcPSQueueOverflow=qo})) = do+  let (removedo, trco, nqo) = shrinkQueue cap sz qo+  trace $ DList.fromList trco+  let newsz = sz-removedo+  if cap >= newsz+  then pure $ reconstructCache newsz q nqo+  else do+      let (removed, trc, nq) = shrinkQueue cap newsz q+      trace $ DList.fromList trc+      pure $ reconstructCache (newsz-removed) nq nqo+  where+    -- One might argue that because we decriment from the current queue we know that the overflow+    -- queue is empty. I choose not to assume since I hadn't worked through all the various priority strategies.+    reconstructCache :: p -> PSQ.HashPSQ k p (t, v) -> PSQ.HashPSQ k p (t, v) -> LRUCache' s p k t v+    reconstructCache resSz resQ resQO | PSQ.null resQO =+          LRUCache1' { lcCapacity=cap+                     , lcSize = resSz+                     , lcPSQueue = resQ+                     , lcGen = lcGen c+                     }+    reconstructCache resSz resQ resQO =+          LRUCache2' { lcCapacity=cap+                     , lcSize = resSz+                     , lcPSQueue = resQ+                     , lcPSQueueOverflow = resQO+                     , lcGen = lcGen c+                     }
+ src/Data/Cache/Trace.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# lANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilyDependencies #-}+module Data.Cache.Trace+ ( CacheEvent(..), CacheTrace+ , MonadTrace(..), MonadAtomicRefTraced(..), atomicModifyRefTracedM'_+ , Tracable(..)+ ) where++import           Control.Applicative+import           Control.Monad+import qualified Control.Monad.Fail as Fail+import           Control.Monad.Fix+import           Control.Monad.Ref+import           Control.Monad.Trans+import qualified Data.DList as DList+import           Data.Functor.Identity+import           Prelude hiding (lookup)++data CacheEvent k t v+ = CacheEvict+   { _ceKey      :: !k+   , _ceTracking :: !t+   , _ceValue    :: v+   }+ | CacheAdd+   { _ceKey      :: !k+   , _ceTracking :: !t+   , _ceValue    :: v+   }+ deriving (Read, Show, Eq, Ord)++type CacheTrace k t v = DList.DList (CacheEvent k t v)++data family Tracable (trc :: Bool) :: * -> (* -> *) -> * -> *+newtype instance Tracable 'False w m a = UntracedT { runUntracedT :: m a }+newtype instance Tracable 'True  w m a = TracedT { runTracedT :: m (a, w) }++class MonadTrace (trc :: Bool) where+  trace :: Applicative m => w -> Tracable trc w m ()++instance MonadTrace 'True where+  trace w = TracedT (pure ((), w))+  {-# INLINE trace #-}++instance MonadTrace 'False where+  trace _ = UntracedT (pure  ())+  {-# INLINE trace #-}++class MonadAtomicRef m => MonadAtomicRefTraced trc w m where+  -- |Atomically mutate the contents of a reference with trace data output+  atomicModifyRefTraced  :: Ref m a -> (a -> (a, w, b)) -> Tracable trc w m b+  -- |Strict version of atomicModifyRefTraced. This forces both the value stored in+  -- the reference as well as the value returned but not the trace.+  atomicModifyRefTraced' :: Ref m a -> (a -> (a, w, b)) -> Tracable trc w m b+  -- | Strict Monadic update function so that tracing is closer to zero cost when unused.+  atomicModifyRefTracedM' :: Ref m a -> (forall m' . (Monad m') => a -> Tracable trc w m' (a, b)) -> Tracable trc w m b++atomicModifyRefTracedM'_ :: (MonadAtomicRefTraced trc w m, forall mg . (Monad mg) => Functor (Tracable trc w mg))+                         => Ref m a+                         -> (forall m' . (Monad m', Functor (Tracable trc w m')) => a -> Tracable trc w m' a)+                         -> Tracable trc w m ()+atomicModifyRefTracedM'_ r f = atomicModifyRefTracedM' r (fmap (,()) .f)++instance (MonadAtomicRef m, Monoid w) => MonadAtomicRefTraced 'True w m where+  atomicModifyRefTraced r f = do+    (w, b) <- lift $ atomicModifyRef r ((\(a, w, b) -> (a, (w, b))) . f)+    trace w+    pure b+  {-# INLINE atomicModifyRefTraced #-}+  atomicModifyRefTraced' r f = do+    (w, b) <- lift $ atomicModifyRef r $+      \x -> let (a, w, b) = f x+             in (a, a `seq` (w, b))+    trace w+    b `seq` pure b+  {-# INLINE atomicModifyRefTraced' #-}+  atomicModifyRefTracedM' r f = do+    (b, w) <- lift $ atomicModifyRef' r $+      (\((a, b), w) -> (a, (b, w))) . runIdentity . runTracedT . f+    trace w+    pure b+  {-# INLINE atomicModifyRefTracedM' #-}++instance (MonadAtomicRef m, Monoid w) => MonadAtomicRefTraced 'False w m where+  atomicModifyRefTraced r f = lift $ atomicModifyRef r ((\(a, _, b) -> (a, b)) . f)+  {-# INLINE atomicModifyRefTraced #-}+  atomicModifyRefTraced' r f = lift $ atomicModifyRef' r ((\(a, _, b) -> (a, b)) . f)+  {-# INLINE atomicModifyRefTraced' #-}+  atomicModifyRefTracedM' r f = lift $ atomicModifyRef' r (runIdentity . runUntracedT . f)+  {-# INLINE atomicModifyRefTracedM' #-}++instance Functor m => Functor (Tracable 'True w m) where+  fmap f (TracedT m) = TracedT $ fmap (\ ~(a, w') -> (f a, w')) $ m+  {-# INLINE fmap #-}++instance Functor m => Functor (Tracable 'False w m) where+  fmap f (UntracedT m) = UntracedT $ fmap f m+  {-# INLINE fmap #-}++instance (Monoid w, Monad m) => Applicative (Tracable 'True w m) where+  pure a = TracedT $ pure (a, mempty)+  {-# INLINE pure #-}+  mf <*> mv = TracedT $ do+    ~(f, w')  <- runTracedT mf+    ~(v, w'') <- runTracedT mv+    pure (f v, w' `mappend` w'')+  {-# INLINE (<*>) #-}++instance (Monad m) => Applicative (Tracable 'False w m) where+  pure a = UntracedT $ pure a+  {-# INLINE pure #-}+  mf <*> mv = UntracedT $ (runUntracedT mf) <*> (runUntracedT mv)+  {-# INLINE (<*>) #-}++instance (Monoid w, MonadPlus m) => Alternative (Tracable 'True w m) where+  empty   = TracedT $ mzero+  {-# INLINE empty #-}+  m <|> n = TracedT $ runTracedT m `mplus` runTracedT n+  {-# INLINE (<|>) #-}++instance (Monoid w, MonadPlus m) => Alternative (Tracable 'False w m) where+  empty   = UntracedT $ mzero+  {-# INLINE empty #-}+  m <|> n = UntracedT $ runUntracedT m `mplus` runUntracedT n+  {-# INLINE (<|>) #-}++instance (Monoid w, Monad m) => Monad (Tracable 'True w m) where+  m >>= k  = TracedT $ do+    ~(a, w')  <- runTracedT m+    ~(b, w'') <- runTracedT (k a)+    return (b, w' `mappend` w'')+  {-# INLINE (>>=) #-}++instance (Monad m) => Monad (Tracable 'False w m) where+  m >>= k  = UntracedT $ runUntracedT m >>= \a -> runUntracedT (k a)+  {-# INLINE (>>=) #-}++instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (Tracable 'True w m) where+  fail msg = TracedT $ Fail.fail msg+  {-# INLINE fail #-}++instance (Fail.MonadFail m) => Fail.MonadFail (Tracable 'False w m) where+  fail msg = UntracedT $ Fail.fail msg+  {-# INLINE fail #-}++instance (Monoid w, MonadPlus m) => MonadPlus (Tracable 'True w m) where+  mzero       = TracedT $ mzero+  {-# INLINE mzero #-}+  m `mplus` n = TracedT $ runTracedT m `mplus` runTracedT n+  {-# INLINE mplus #-}++instance (Monoid w, MonadPlus m) => MonadPlus (Tracable 'False w m) where+  mzero       = UntracedT $ mzero+  {-# INLINE mzero #-}+  m `mplus` n = UntracedT $ runUntracedT m `mplus` runUntracedT n+  {-# INLINE mplus #-}++instance (Monoid w, MonadFix m) => MonadFix (Tracable 'True w m) where+  mfix m = TracedT $ mfix $ \ ~(a, _) -> runTracedT (m a)+  {-# INLINE mfix #-}++instance (MonadFix m) => MonadFix (Tracable 'False w m) where+  mfix m = UntracedT $ mfix $ \ a -> runUntracedT (m a)+  {-# INLINE mfix #-}++instance (Monoid w) => MonadTrans (Tracable 'True w) where+  lift = TracedT . fmap (\a -> (a, mempty))+  {-# INLINE lift #-}++instance (Monoid w) => MonadTrans (Tracable 'False w) where+  lift = UntracedT+  {-# INLINE lift #-}++instance (Monoid w, MonadIO m) => MonadIO (Tracable 'True w m) where+  liftIO = lift . liftIO+  {-# INLINE liftIO #-}++instance (Monoid w, MonadIO m) => MonadIO (Tracable 'False w m) where+  liftIO = lift . liftIO+  {-# INLINE liftIO #-}
+ src/Data/Cache/Type.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+-- | By tracing operations we can transform one type of cache into another.+module Data.Cache.Type+ ( Cache(..)+ , insert, lookup, lookupMaybe, lookupCreating, cached, evict+ , CacheEvent(..)+ , CacheTrace+ , Caching(..)+ , DictCache(..)+ ) where++import qualified Control.Monad.Fail as Fail+import           Control.Monad.Trans+import           Data.Cache.Trace+import           Data.Maybe+import           Prelude hiding (lookup)++-- Time based eviction cache transformer+-- Memory size limit cache transformer+-- LRU+-- MFU+-- FIFOg+-- on disk+-- stripping combiner+-- Rate limiting transformer (like with web service rate limits, so on value querying)+-- key locking transformer for unique gemeration+-- Read through transformer+-- Write through transformer+-- Write behind transformer+-- Refresh ahead transformer (works with expiration transformer?)+--+-- Add resizing class?++-- |+--   c - The cache type.+--   m - The Monad.+--   k - The key.+--   t - The tracking data. This allows caches to store metadata for 3rd parties.+--   v - The value.+class Caching c (m :: * -> *) k t v | c -> m, c -> k, c -> t, c -> v where+  insetTraced    :: forall (trc::Bool) . c -> k -> t -> v -> Tracable trc (CacheTrace k t v) m ()+  lookupTraced   :: forall (trc::Bool) . c -> k -> Tracable trc (CacheTrace k t v) m (Maybe v)+  evictTraced    :: forall (trc::Bool) . c -> k -> Tracable trc (CacheTrace k t v) m ()+  updateTracking :: forall (trc::Bool) . c -> k -> (t -> t) -> Tracable trc (CacheTrace k t v) m ()++data Cache m k t v+ = forall c . Caching c m k t v => Cache c++insert :: (Monad m, Caching c m k () v) => c -> k -> v -> m ()+insert c k v = runUntracedT $ insetTraced c k () v++lookup :: (Fail.MonadFail m, Caching c m k t v) => c -> k -> m v+lookup c k = fmap fromJust $ runUntracedT $ lookupTraced c k++lookupCreating :: (Monad m, Caching c m k () v) => c -> k -> (m v) -> m v+lookupCreating c k a = runUntracedT $ do+  mv <- lookupTraced c k+  case mv of+    Just v -> pure v+    Nothing -> lift a >>= \v -> insetTraced c k () v >> pure v++lookupMaybe :: (Monad m, Caching c m k t v) => c -> k -> m (Maybe v)+lookupMaybe c k = runUntracedT $ lookupTraced c k++cached :: (Monad m, Caching c m k t v) => c -> k -> m Bool+cached c k = isJust <$> lookupMaybe c k++evict :: (Monad m, Caching c m k t v) => c -> k -> m ()+evict c k = runUntracedT $ evictTraced c k++-- | A reified Caching dictionary so that we can assemble them on demand.+data DictCache (m :: * -> *) k t v+ = DictCache+ { dcIns   :: forall (trc::Bool) . k -> t -> v   -> Tracable trc (CacheTrace k t v) m ()+ , dcLook  :: forall (trc::Bool) . k             -> Tracable trc (CacheTrace k t v) m (Maybe v)+ , dcEvict :: forall (trc::Bool) . k             -> Tracable trc (CacheTrace k t v) m ()+ , dcUp    :: forall (trc::Bool) . k -> (t -> t) -> Tracable trc (CacheTrace k t v) m ()+ }++instance Caching (DictCache m k t v) m k t v where+  insetTraced    (DictCache { dcIns=f   }) = f+  lookupTraced   (DictCache { dcLook=f  }) = f+  evictTraced    (DictCache { dcEvict=f }) = f+  updateTracking (DictCache { dcUp=f    }) = f
+ test/MyLibTest.hs view
@@ -0,0 +1,4 @@+module Main (main) where++main :: IO ()+main = putStrLn "Test suite not yet implemented."