lrucaching (empty) → 0.1.0
raw patch · 12 files changed
+472/−0 lines, 12 filesdep +QuickCheckdep +basedep +containerssetup-changed
Dependencies added: QuickCheck, base, containers, deepseq, hashable, hspec, lrucaching, psqueues, transformers, vector
Files
- CHANGELOG.md +3/−0
- LICENSE +30/−0
- README.md +7/−0
- Setup.hs +2/−0
- lrucaching.cabal +50/−0
- src/Data/LruCache.hs +108/−0
- src/Data/LruCache/IO.hs +70/−0
- src/Data/LruCache/Internal.hs +42/−0
- test/Data/LruCache/IOSpec.hs +47/−0
- test/Data/LruCache/SpecHelper.hs +61/−0
- test/Data/LruCacheSpec.hs +51/−0
- test/Spec.hs +1/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+0.1.0+-----+Initial release.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Moritz Kiefer (c) 2016++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 Moritz Kiefer 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.
+ README.md view
@@ -0,0 +1,7 @@+# lrucaching++[](https://travis-ci.org/cocreature/lrucaching)++An implementation of lrucaches based on a+[blogpost](https://jaspervdj.be/posts/2015-02-24-lru-cache.html) by+Jasper Van der Jeugt.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ lrucaching.cabal view
@@ -0,0 +1,50 @@+name: lrucaching+version: 0.1.0+synopsis: LRU cache+description: Please see README.md+homepage: https://github.com/cocreature/lrucaching#readme+license: BSD3+license-file: LICENSE+author: Moritz Kiefer+maintainer: moritz.kiefer@purelyfunctional.org+copyright: 2016+category: Unknown+build-type: Simple+extra-source-files: CHANGELOG.md+ README.md+cabal-version: >=1.10+tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1++library+ hs-source-dirs: src+ exposed-modules: Data.LruCache+ Data.LruCache.IO+ Data.LruCache.Internal+ build-depends: base >= 4.7 && < 5+ , deepseq >= 1.4 && < 1.5+ , hashable >= 1.2 && < 1.3+ , psqueues >= 0.2 && < 0.3+ , vector >= 0.11 && < 0.12+ ghc-options: -Wall+ default-language: Haskell2010++test-suite lru-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules: Data.LruCacheSpec+ Data.LruCache.IOSpec+ Data.LruCache.SpecHelper+ build-depends: base+ , containers >= 0.5 && < 0.6+ , deepseq+ , hashable+ , hspec >= 2.2 && < 2.3+ , lrucaching+ , QuickCheck >= 2.8 && < 2.10+ , transformers >= 0.4 && < 0.6+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/cocreature/lrucaching
+ src/Data/LruCache.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-|+Module : Data.LruCache+Copyright : (c) Moritz Kiefer, 2016+ (c) Jasper Van der Jeugt, 2015+License : BSD3+Maintainer : moritz.kiefer@purelyfunctional.org+Pure API to an LRU cache.+-}+module Data.LruCache+ ( LruCache+ , Priority+ , empty+ , insert+ , insertView+ , lookup+ ) where++import qualified Data.HashPSQ as HashPSQ+import Data.Hashable (Hashable)+import Data.Maybe (isNothing)+import Prelude hiding (lookup)++import Data.LruCache.Internal++-- | Create an empty 'LruCache' of the given size.+empty :: Int -> LruCache k v+empty capacity+ | capacity < 1 = error "LruCache.empty: capacity < 1"+ | otherwise =+ LruCache + { lruCapacity = capacity+ , lruSize = 0+ , lruTick = 0+ , lruQueue = HashPSQ.empty+ }++-- | Restore 'LruCache' invariants returning the evicted element if any.+--+-- When the logical clock reaches its maximum value and all values are+-- evicted 'Nothing' is returned.+trim' :: (Hashable k, Ord k) => LruCache k v -> (Maybe (k, v), LruCache k v)+trim' c+ | lruTick c == maxBound = (Nothing, empty (lruCapacity c))+ | lruSize c > lruCapacity c = + let Just (k, _, v) = HashPSQ.findMin (lruQueue c)+ c' = c { lruSize = lruSize c - 1+ , lruQueue = HashPSQ.deleteMin (lruQueue c)+ }+ in seq c' (Just (k, v), c')+ | otherwise = (Nothing, c)++-- TODO benchmark to see if this is actually faster than snd . trim'+-- | Restore 'LruCache' invariants. For performance reasons this is+-- not @snd . trim'@.+trim :: (Hashable k, Ord k) => LruCache k v -> LruCache k v+trim c+ | lruTick c == maxBound = empty (lruCapacity c)+ | lruSize c > lruCapacity c = + c { lruSize = lruSize c - 1+ , lruQueue = HashPSQ.deleteMin (lruQueue c)+ }+ | otherwise = c++-- | Insert an element into the 'LruCache'.+insert :: (Hashable k, Ord k) => k -> v -> LruCache k v -> LruCache k v+insert key val c =+ trim $!+ let (mbOldVal,queue) = HashPSQ.insertView key (lruTick c) val (lruQueue c)+ in c { lruSize = if isNothing mbOldVal+ then lruSize c + 1+ else lruSize c+ , lruTick = lruTick c + 1+ , lruQueue = queue+ }++-- | Insert an element into the 'LruCache' returning the evicted+-- element if any.+--+-- When the logical clock reaches its maximum value and all values are+-- evicted 'Nothing' is returned.+insertView :: (Hashable k, Ord k) => k -> v -> LruCache k v -> (Maybe (k, v), LruCache k v)+insertView key val cache =+ let (mbOldVal,queue) = + HashPSQ.insertView key (lruTick cache) val (lruQueue cache)+ in trim' $! cache + { lruSize = if isNothing mbOldVal+ then lruSize cache + 1+ else lruSize cache+ , lruTick = lruTick cache + 1+ , lruQueue = queue+ }++-- | Lookup an element in an 'LruCache' and mark it as the least+-- recently accessed.+lookup :: (Hashable k, Ord k) => k -> LruCache k v -> Maybe (v, LruCache k v)+lookup k c = + case HashPSQ.alter lookupAndBump k (lruQueue c) of+ (Nothing, _) -> Nothing+ (Just x, q) ->+ let !c' = trim $ c {lruTick = lruTick c + 1, lruQueue = q}+ in Just (x, c')+ where+ lookupAndBump Nothing = (Nothing, Nothing)+ lookupAndBump (Just (_, x)) = (Just x, Just ((lruTick c), x))
+ src/Data/LruCache/IO.hs view
@@ -0,0 +1,70 @@+{-|+Module : Data.LruCache.IO+Copyright : (c) Moritz Kiefer, 2016+ (c) Jasper Van der Jeugt, 2015+License : BSD3+Maintainer : moritz.kiefer@purelyfunctional.org+Convenience module for the common case of caching results of IO actions.+-}+module Data.LruCache.IO+ ( LruHandle(..)+ , cached+ , newLruHandle+ , StripedLruHandle(..)+ , stripedCached+ , newStripedHandle+ ) where++import Control.Applicative ((<$>))+import Data.Hashable (Hashable, hash)+import Data.IORef (IORef, atomicModifyIORef', newIORef)+import Data.Vector (Vector)+import qualified Data.Vector as Vector+import Prelude hiding (lookup)++import Data.LruCache++-- | Store a LRU cache in an 'IORef to be able to conveniently update it.+newtype LruHandle k v = LruHandle (IORef (LruCache k v))++-- | Create a new LRU cache of the given size.+newLruHandle :: Int -> IO (LruHandle k v)+newLruHandle capacity = LruHandle <$> newIORef (empty capacity)++-- | Return the cached result of the action or, in the case of a cache+-- miss, execute the action and insert it in the cache.+cached :: (Hashable k, Ord k) => LruHandle k v -> k -> IO v -> IO v+cached (LruHandle ref) k io =+ do lookupRes <- atomicModifyIORef' ref $ \c ->+ case lookup k c of+ Nothing -> (c, Nothing)+ Just (v, c') -> (c', Just v)+ case lookupRes of+ Just v -> return v+ Nothing ->+ do v <- io+ atomicModifyIORef' ref $ \c -> (insert k v c, ())+ return v++-- | Using a stripe of multiple handles can improve the performance in+-- the case of concurrent accesses since several handles can be+-- accessed in parallel.+newtype StripedLruHandle k v = StripedLruHandle (Vector (LruHandle k v))++-- | Create a new 'StripedHandle' with the given number of stripes and+-- the given capacity for each stripe.+newStripedHandle :: Int -> Int -> IO (StripedLruHandle k v)+newStripedHandle numStripes capacityPerStripe =+ StripedLruHandle <$> Vector.replicateM numStripes (newLruHandle capacityPerStripe)++-- | Striped version of 'cached'.+stripedCached ::+ (Hashable k, Ord k) =>+ StripedLruHandle k v ->+ k ->+ IO v ->+ IO v+stripedCached (StripedLruHandle v) k =+ cached (v Vector.! idx) k+ where+ idx = hash k `mod` Vector.length v
+ src/Data/LruCache/Internal.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-|+Module : Data.LruCache.Internal+Copyright : (c) Moritz Kiefer, 2016+ (c) Jasper Van der Jeugt, 2015+License : BSD3+Maintainer : moritz.kiefer@purelyfunctional.org++This module contains internal datastructures. +No guarantees are made as to the stability of this module+and violating invariants can result in unspecified behavior.+-}+module Data.LruCache.Internal+ ( LruCache(..)+ , Priority+ ) where+ +import Control.DeepSeq (NFData,rnf)+import Data.Int+import qualified Data.HashPSQ as HashPSQ+import Data.Foldable (Foldable)+import Data.Traversable (Traversable)++-- | Logical time at which an element was last accessed.+type Priority = Int64++-- | LRU cache based on hashing. The times of access are stored in a+-- monotonically increasing 'Int64', when that time is at 'maxbound'+-- the cache is emptied.+data LruCache k v = LruCache+ { lruCapacity :: !Int -- ^ The maximum number of elements in the queue+ , lruSize :: !Int -- ^ The current number of elements in the queue+ , lruTick :: !Priority -- ^ The next logical time+ , lruQueue :: !(HashPSQ.HashPSQ k Priority v) -- ^ Underlying priority queue+ } + deriving (Eq,Show,Functor,Foldable,Traversable)++instance (NFData k, NFData v) => NFData (LruCache k v) where+ rnf (LruCache cap size tick queue) =+ rnf cap `seq` rnf size `seq` rnf tick `seq` rnf queue
+ test/Data/LruCache/IOSpec.hs view
@@ -0,0 +1,47 @@+module Data.LruCache.IOSpec+ (spec+ ) where++import Control.Monad (foldM_)+import Control.Monad.IO.Class+import Data.IORef+import Data.Set (Set)+import qualified Data.Set as Set+import Test.Hspec+import qualified Test.QuickCheck as QC+import qualified Test.QuickCheck.Monadic as QC++import Data.LruCache.IO+import Data.LruCache.SpecHelper++spec :: Spec+spec =+ do describe "cached" $ do+ it "evicts leasts recently used elements" $ do+ QC.property historic++-- | Tests if elements not evicted have been recently accessed.+historic ::+ SmallInt -> -- ^ Capacity+ [(SmallInt, String)] -> -- ^ Key-value pairs+ QC.Property -- ^ Property+historic (SmallInt capacity) pairs = QC.monadicIO $+ do h <- liftIO $ newLruHandle capacity+ foldM_ (step h) [] pairs+ where+ step h history (k, v) = do+ wasInCacheRef <- liftIO $ newIORef True+ _ <- liftIO $ cached h k $ + do writeIORef wasInCacheRef False+ return v+ wasInCache <- liftIO $ readIORef wasInCacheRef+ let recentKeys = nMostRecentKeys capacity Set.empty history+ QC.assert (Set.member k recentKeys == wasInCache)+ return ((k, v) : history)++nMostRecentKeys :: Ord k => Int -> Set k -> [(k, v)] -> Set k+nMostRecentKeys _ keys [] = keys+nMostRecentKeys n keys ((k, _) : history)+ | Set.size keys >= n = keys+ | otherwise =+ nMostRecentKeys n (Set.insert k keys) history
+ test/Data/LruCache/SpecHelper.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-|+Module : Data.LruCache.SpecHelper+Copyright : (c) Moritz Kiefer, 2016+ (c) Jasper Van der Jeugt, 2015+License : BSD3+Maintainer : moritz.kiefer@purelyfunctional.org+-}+module Data.LruCache.SpecHelper where++import Control.Applicative ((<$>),(<*>))+import Data.Foldable (foldl')+import Data.Hashable+import Prelude hiding (lookup)+import qualified Test.QuickCheck as QC++import Data.LruCache++data CacheAction k v+ = InsertAction k v+ | LookupAction k+ deriving (Show,Eq,Ord)++instance (QC.Arbitrary k, QC.Arbitrary v) => + QC.Arbitrary (CacheAction k v) where+ arbitrary = QC.oneof+ [ InsertAction <$> QC.arbitrary <*> QC.arbitrary+ , LookupAction <$> QC.arbitrary+ ]++applyCacheAction :: + (Hashable k, Ord k) =>+ CacheAction k v ->+ LruCache k v ->+ LruCache k v+applyCacheAction (InsertAction k v) c = + insert k v c+applyCacheAction (LookupAction k) c = + case lookup k c of+ Nothing -> c+ Just (_, c') -> c'++instance forall k v. + (QC.Arbitrary k, QC.Arbitrary v, Hashable k, Ord k) =>+ QC.Arbitrary (LruCache k v) where+ arbitrary = do+ capacity <- QC.choose (1, 50)+ (actions :: [CacheAction k v]) <- QC.arbitrary+ let !cache = empty capacity+ return $! foldl' (\c a -> applyCacheAction a c) cache actions++newtype SmallInt = SmallInt Int+ deriving (Eq, Ord, Show)++instance QC.Arbitrary SmallInt where+ arbitrary = SmallInt <$> QC.choose (1, 100)++instance Hashable SmallInt where+ hashWithSalt salt (SmallInt x) = (salt + x) `mod` 10
+ test/Data/LruCacheSpec.hs view
@@ -0,0 +1,51 @@+module Data.LruCacheSpec + (spec+ ) where++import Data.Hashable+import Data.Maybe+import Prelude hiding (lookup)+import Test.Hspec+import Test.QuickCheck++import Data.LruCache+import Data.LruCache.SpecHelper++spec :: Spec+spec = + do describe "insertView" $ do+ it "evicts elements that were previously there" $ do + property (evictExisted :: LruCache SmallInt Int -> SmallInt -> Int -> Bool)+ it "removes evicted elements" $ do+ property (evictRemoved :: LruCache SmallInt Int -> SmallInt -> Int -> Bool)+ describe "insert" $ do+ it "inserts elements" $ do+ property (insertExists :: LruCache SmallInt Int -> SmallInt -> Int -> Property)+++insertExists :: + (Hashable k, Ord k, Eq v, Show v) =>+ LruCache k v ->+ k ->+ v ->+ Property+insertExists cache k v =+ let cache' = insert k v cache+ in fmap fst (lookup k cache') === Just v++evictExisted :: (Hashable k, Ord k, Eq v) => LruCache k v -> k -> v -> Bool+evictExisted cache k v =+ let evicted = fst (insertView k v cache)+ in case evicted of+ Nothing -> True+ Just (k', v') -> + case lookup k' cache of+ Nothing -> False+ Just (v'', _) -> v' == v''++evictRemoved :: (Hashable k, Ord k) => LruCache k v -> k -> v -> Bool+evictRemoved cache k v =+ let (evicted, cache') = insertView k v cache+ in case evicted of+ Nothing -> True+ Just (k',_) -> isNothing (lookup k' cache')
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}