packages feed

exp-cache (empty) → 0.1.0.0

raw patch · 20 files changed

+865/−0 lines, 20 filesdep +HUnitdep +QuickCheckdep +arraysetup-changed

Dependencies added: HUnit, QuickCheck, array, base, containers, criterion, deepseq, exp-cache, hashable, psqueues, random, tasty, tasty-hunit, tasty-quickcheck, time, unordered-containers

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for lru-cache++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2018++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 Author name here 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,3 @@+# lru-cache++[![Build Status](https://travis-ci.org/ChrisCoffey/Cache-Eviction-Strategies.svg?branch=master)](https://travis-ci.org/ChrisCoffey/Cache-Eviction-Strategies)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benchmarks/Benchmarks/LFU.hs view
@@ -0,0 +1,36 @@+module Benchmarks.LFU (+    lfuBenchmarks+) where++import Data.Cache++import Criterion+import Control.Monad (void)+import Data.Foldable (foldl')+import System.Random (newStdGen, randomR)++lfuBenchmarks :: Benchmark+lfuBenchmarks = bgroup "lfu" [+    bench "recordLookup 1000 distinct" $ whnf storeNDistinct 1000,+    bench "recordLookup 10K distinct" $ whnf storeNDistinct 10000,+    bench "store And Evict 1000" $ whnfIO (storeAndEvict 1000),+    bench "store And Evict 10k" $ whnfIO (storeAndEvict 100000),+    bench "store And Evict 100k" $ whnfIO (storeAndEvict 1000000)+    ]+    where+        s :: LFU Int+        s = newLFU+        storeNDistinct n = foldr recordLookup s [0..n]++        storeAndEvict :: Int -> IO (LFU Int)+        storeAndEvict n = do+            gen <- newStdGen+            xs <- pure $ storeNDistinct (n `div` 10)+            lookups <- pure . fst $ foldl' step ([], gen) [0..n]+            res <- pure $ foldl' runLFU xs lookups+            pure res+            where+                step (acc, gen) _ = let+                    (x, gen') = randomR (0,n `div` 10) gen+                    in (x:acc, gen')+                runLFU lfu x = fst . evict $ recordLookup x lfu
+ benchmarks/Benchmarks/LRU.hs view
@@ -0,0 +1,67 @@+module Benchmarks.LRU (+    lruBenchmarks+    ) where++import Data.Cache++import Criterion+import Control.Monad (void)+import Data.Foldable (foldl')+import System.Random (newStdGen, randomR)++lruBenchmarks :: Benchmark+lruBenchmarks = bgroup "lru" [+    lruSeqBenchmarks,+    lruHashBenchmarks+    ]++lruSeqBenchmarks :: Benchmark+lruSeqBenchmarks = bgroup "sequential" [+    bench "recordLookup 1000 distinct" $ whnf storeNDistinct 1000,+    bench "recordLookup 10K distinct" $ whnf storeNDistinct 10000,+    bench "store And Evict 1000" $ whnfIO (storeAndEvict 1000),+    bench "store And Evict 10k" $ whnfIO (storeAndEvict 10000)+    ]+    where+        s :: SeqLRU Int+        s = newSeqLRU+        storeNDistinct n = foldr recordLookup s [0..n]++        storeAndEvict :: Int -> IO (SeqLRU Int)+        storeAndEvict n = do+            gen <- newStdGen+            xs <- pure $ storeNDistinct n+            lookups <- pure . fst $ foldl' step ([], gen) [0..n]+            res <- pure $ foldl' runLRU xs lookups :: IO (SeqLRU Int)+            pure res+            where+                step (acc, gen) _ = let+                    (x, gen') = randomR (0,n) gen+                    in (x:acc, gen')+                runLRU lru x = fst . evict $ recordLookup x lru++lruHashBenchmarks :: Benchmark+lruHashBenchmarks = bgroup "hash priority search queue" [+    bench "recordLookup 1000 distinct" $ whnf storeNDistinct 1000,+    bench "recordLookup 10K distinct" $ whnf storeNDistinct 10000,+    bench "store And Evict 1000" $ whnfIO (storeAndEvict 1000),+    bench "store And Evict 10k" $ whnfIO (storeAndEvict 10000),+    bench "store And Evict 100k" $ whnfIO (storeAndEvict 100000)+    ]+    where+        s :: LRU Int+        s = newLRU+        storeNDistinct n = foldr recordLookup s [0..n]++        storeAndEvict :: Int -> IO (LRU Int)+        storeAndEvict n = do+            gen <- newStdGen+            xs <- pure $ storeNDistinct n+            lookups <- pure . fst $ foldl' step ([], gen) [0..n]+            res <- pure $ foldl' runLRU xs lookups+            pure res+            where+                step (acc, gen) _ = let+                    (x, gen') = randomR (0,n) gen+                    in (x:acc, gen')+                runLRU lru x = fst . evict $ recordLookup x lru
+ benchmarks/Benchmarks/RR.hs view
@@ -0,0 +1,42 @@+module Benchmarks.RR (+    rrBenchmarks+    ) where++import Data.Cache++import Criterion+import Control.Monad (void)+import Data.Foldable (foldl')+import System.Random (newStdGen, randomR, StdGen)+import System.IO.Unsafe (unsafePerformIO)++defaultGen :: StdGen+defaultGen = unsafePerformIO newStdGen+{-# NOINLINE defaultGen #-}++rrBenchmarks :: Benchmark+rrBenchmarks = bgroup "rr" [+    bench "recordLookup 1000 distinct" $ whnf storeNDistinct 1000,+    bench "recordLookup 10K distinct" $ whnf storeNDistinct 10000,+    bench "store And Evict 1000" $ whnfIO (storeAndEvict 1000),+    bench "store And Evict 10k" $ whnfIO (storeAndEvict 10000),+    bench "store And Evict 100k" $ whnfIO (storeAndEvict 100000)+    ]+    where+        s :: StdGen -> Int -> RR Int+        s = newRR+        storeNDistinct n =+            foldr recordLookup (s defaultGen n) [0..n]++        storeAndEvict :: Int -> IO (RR Int)+        storeAndEvict n = do+            gen <- newStdGen+            xs <- pure $ storeNDistinct n+            lookups <- pure . fst $ foldl' step ([], gen) [0..n]+            res <- pure $ foldl' runLRU xs lookups+            pure res+            where+                step (acc, gen) _ = let+                    (x, gen') = randomR (0,n) gen+                    in (x:acc, gen')+                runLRU rr x = fst . evict $ recordLookup x rr
+ benchmarks/Main.hs view
@@ -0,0 +1,13 @@+import Benchmarks.LRU+import Benchmarks.RR+import Benchmarks.LFU++import Criterion.Main++++main = defaultMain [+    lruBenchmarks,+    rrBenchmarks,+    lfuBenchmarks+    ]
+ exp-cache.cabal view
@@ -0,0 +1,84 @@+name:           exp-cache+version:        0.1.0.0+description:    Please see the README on Github at <https://github.com/ChrisCoffey/exp-cache#readme>+homepage:       https://github.com/ChrisCoffey/exp-cache#readme+bug-reports:    https://github.com/ChrisCoffey/exp-cache/issues+author:         Chris Coffey+maintainer:     chris@foldl.io+copyright:      2018 Chris Coffey+license:        MIT+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10++extra-source-files:+    ChangeLog.md+    README.md++source-repository head+  type: git+  location: https://github.com/ChrisCoffey/exp-cache++library+  hs-source-dirs:+      src+  build-depends:+      base >=4.7 && <5+    , time+    , unordered-containers+    , containers+    , deepseq+    , hashable+    , psqueues+    , array+    , random+  exposed-modules:+    Data.Cache+    , Data.Cache.Eviction.LRU+    , Data.Cache.Eviction.LFU+    , Data.Cache.Eviction.MRU+    , Data.Cache.Eviction.RR+  other-modules:+    Data.Cache.Eviction+  default-extensions:  DataKinds FlexibleContexts ScopedTypeVariables OverloadedStrings ViewPatterns NamedFieldPuns+                       KindSignatures RecordWildCards ConstraintKinds TypeSynonymInstances FlexibleInstances MultiParamTypeClasses+                       InstanceSigs FunctionalDependencies TupleSections+  default-language: Haskell2010++test-suite exp-cache-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , exp-cache+    , HUnit+    , QuickCheck+    , tasty+    , tasty-hunit+    , tasty-quickcheck+    , random+  other-modules:+      Spec.LRUTests,+      Spec.MRUTests,+      Spec.RRTests,+      Spec.CacheTests+  default-language: Haskell2010++executable exp-cache-benchmarks+    main-is: Main.hs+    hs-source-dirs:+        benchmarks+    ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 -fno-full-laziness+    build-depends:+        base+      , exp-cache+      , criterion+      , random+    other-modules:+        Benchmarks.LRU+        , Benchmarks.RR+        , Benchmarks.LFU+    default-language: Haskell2010
+ src/Data/Cache.hs view
@@ -0,0 +1,86 @@+module Data.Cache (+    Cache,+    newCache,++    EvictionStrategy(..),++    -- The sequential LRU implementation+    SeqLRU,+    newSeqLRU,+    -- Actual LRU implementation+    LRU,+    newLRU,++    -- An MRU implementation based on the LRU implementation+    MRU,+    newMRU,++    -- Random Replacement cache (RR)+    RR,+    newRR,++    -- | Least Frequently Used Cache+    LFU,+    newLFU+    ) where++import Data.Cache.Eviction (EvictionStrategy(..))+import Data.Cache.Eviction.LRU+import Data.Cache.Eviction.MRU+import Data.Cache.Eviction.RR+import Data.Cache.Eviction.LFU++import qualified Data.HashMap.Strict as HM+import Control.DeepSeq (NFData)+import Data.Hashable (Hashable)++data Cache k v s =+    Cache {+        cacheData :: HM.HashMap k v,+        evictionStrategy :: s,+        maxSize :: Int,+        currentSize :: Int+        }++newCache :: (Hashable k, NFData v, EvictionStrategy s, Eq k, Ord k) =>+    Int -- ^ The maximum cache size+    -> s k -- ^ The evictionStrategy+    -> Cache k v (s k)+newCache maxSize evictionStrategy =+    Cache {+        cacheData = HM.empty,+        evictionStrategy,+        maxSize,+        currentSize = 0+    }++readThrough :: (Hashable k, NFData v, EvictionStrategy s, Eq k, Ord k, Monad m) =>+    Cache k v (s k)+    -> k+    -> (k -> m v)+    -> m (v , Cache k v (s k))+readThrough cache@(Cache {maxSize, evictionStrategy, cacheData, currentSize}) key onMiss =+    case HM.lookup key cacheData of+        -- A hit. Because the value is already in the cache, no need to evict. Update the+        -- accessed time for 'key'+        Just v -> do+            let strat' = recordLookup key evictionStrategy+            pure (v, cache {evictionStrategy = strat'} )+        -- On a miss when the cache is full:+        -- 1) evict the relevant key (removes from HashMap & Strategy)+        -- 2) Record the newest key in the strategy+        -- 3) Add key to the cache data+        Nothing | maxSize == currentSize -> do+            v <- onMiss key+            let (strat', evicted) = evict evictionStrategy+                strat'' = recordLookup key strat'+                cacheData' = HM.insert key v $ maybe cacheData (`HM.delete` cacheData) evicted+            pure (v, cache {cacheData = cacheData', evictionStrategy = strat''})+        -- A miss when the cache is not full+        -- 1) Record the new key in the data cache+        -- 2) Record the new key in the strategy+        Nothing -> do+            v <- onMiss key+            let strat' = recordLookup key evictionStrategy+                cacheData' = HM.insert key v cacheData+            pure (v, cache {cacheData = cacheData', evictionStrategy = strat'})
+ src/Data/Cache/Eviction.hs view
@@ -0,0 +1,15 @@+module Data.Cache.Eviction (+    EvictionStrategy(..)+) where++import Data.Hashable (Hashable)++class EvictionStrategy s where+    recordLookup :: (Eq k, Hashable k, Ord k) =>+        k -- ^ The key to lookup+        -> s k-- ^ The strategy (containing any state necessary)+        -> s k -- ^ The strategy + state folloiwng adding the key++    evict :: (Eq k, Hashable k, Ord k) =>+        s k+        -> (s k, Maybe k)
+ src/Data/Cache/Eviction/LFU.hs view
@@ -0,0 +1,38 @@+module Data.Cache.Eviction.LFU (+    LFU,+    newLFU,+    -- | For testing+    LFUContentsOnlyEq(..)+) where++import Data.Cache.Eviction+import Data.Word (Word64)+import Data.Hashable+import qualified Data.HashPSQ as PSQ++newtype LFU k = LFU {+    queue :: PSQ.HashPSQ k Word64 ()+    } deriving (Eq, Show)++newtype LFUContentsOnlyEq k = LFUContentsOnlyEq (LFU k)+    deriving Show+instance ( Hashable k, Ord k ) => Eq (LFUContentsOnlyEq k) where+    (==) (LFUContentsOnlyEq lfu)+         (LFUContentsOnlyEq lfu') = queue lfu == queue lfu'++newLFU :: LFU k+newLFU = LFU PSQ.empty++instance EvictionStrategy LFU where+    recordLookup key (LFU queue) =+        LFU . snd $ PSQ.alter repsert key queue+        where+            repsert Nothing = ((), Just (1, ()) )+            repsert (Just (count, x)) = ((), Just (count + 1, x))++    evict (LFU queue) =+        case PSQ.findMin queue of+            Just (evicted, _, _) -> (LFU queue', Just evicted)+            Nothing -> (LFU queue, Nothing)+        where+            queue' = PSQ.deleteMin queue
+ src/Data/Cache/Eviction/LRU.hs view
@@ -0,0 +1,87 @@+module Data.Cache.Eviction.LRU (+    SeqLRU,+    newSeqLRU,++    LRU,+    newLRU,+    LRUContentsOnlyEq(..)+) where++import Data.Cache.Eviction++import Data.Sequence+import Data.Monoid ((<>))+import Data.Hashable (Hashable, hash)+import Data.Maybe (maybe)+import Data.Word (Word64)+import qualified Data.HashPSQ as PSQ+++-- | This is a naive and terribly slow version of an LRU cache+newtype SeqLRU k = SeqLRU (Seq k)+    deriving (Eq, Show)++newSeqLRU :: SeqLRU k+newSeqLRU = SeqLRU empty++instance EvictionStrategy SeqLRU where+    recordLookup key (SeqLRU elements) =+        case viewl right of+            EmptyL -> SeqLRU $ elements |> key+            val :< rest -> SeqLRU $ (key <| left) <> right+        where+            (left, right) = breakl (== key) elements++    evict (SeqLRU elements) =+        case viewr elements of+            EmptyR -> (SeqLRU elements, Nothing)+            rest :> last -> (SeqLRU rest, Just last)++-- | An optimized version of an LRU cache+data LRU k =+    LRU {+        queue :: PSQ.HashPSQ k Word64 (),+        time :: Word64+        } deriving (Eq, Show)++newtype LRUContentsOnlyEq k = LRUContentsOnlyEq (LRU k)+    deriving Show+instance (Hashable k, Ord k) => Eq (LRUContentsOnlyEq k) where+    (==) (LRUContentsOnlyEq lru)+         (LRUContentsOnlyEq lru') = queue lru == queue lru'+++newLRU :: LRU k+newLRU = LRU PSQ.empty 0++instance EvictionStrategy LRU where+    recordLookup key (LRU {time, queue} )+        | time == maxBound = let+            (newTime, queue') = shrinkPSQPriorities queue+            in recordLookup key $ LRU queue' newTime+        | otherwise = LRU  queue' (time + 1)+            where+                queue' = PSQ.insert key time () queue++    evict LRU {time, queue} =+        case PSQ.findMin queue of+            Just (evicted, _, _) -> (LRU queue' time, Just evicted)+            _ -> (LRU queue time, Nothing)+        where+            queue' = PSQ.deleteMin queue++-- | Transform the priorities of a PSQ by subtracting the minimum priority from all+-- priorities in the queue. This becomes necessary when reaching the upper bound on an+-- 'Word64'. The ordering of priorities is retained+shrinkPSQPriorities :: (Integral p, Hashable k, Ord k) =>+    PSQ.HashPSQ k p v+    -> (p, PSQ.HashPSQ k p v)+shrinkPSQPriorities psq =+    PSQ.fold' reducePriority (0, PSQ.empty) psq+    where+        reducePriority k p v (maxValue, psq) = let+            newP = p - minValue+            m = max newP maxValue+            in (m, PSQ.insert k newP v psq)+        second (_, a, _) = a+        minValue = maybe 0 second $ PSQ.findMin psq
+ src/Data/Cache/Eviction/MRU.hs view
@@ -0,0 +1,61 @@+module Data.Cache.Eviction.MRU (+    MRU,+    newMRU,+    MRUContentsOnlyEq(..)+) where++import Data.Cache.Eviction++import Data.Sequence+import Data.Monoid ((<>))+import Data.Hashable (Hashable, hash)+import Data.Maybe (maybe)+import Data.Word (Word64)+import qualified Data.HashPSQ as PSQ++data MRU k =+    MRU {+        queue :: PSQ.HashPSQ k Word64 (),+        time :: Word64+        } deriving (Eq, Show)++newtype MRUContentsOnlyEq k = MRUContentsOnlyEq (MRU k)+    deriving Show+instance (Hashable k, Ord k) => Eq (MRUContentsOnlyEq k) where+    (==) (MRUContentsOnlyEq lru)+         (MRUContentsOnlyEq lru') = queue lru == queue lru'+++newMRU :: MRU k+newMRU = MRU PSQ.empty maxBound++instance EvictionStrategy MRU where+    recordLookup key (MRU {time, queue} )+        | time == minBound = let+            (newTime, queue') = expandPSQPriorities queue+            in recordLookup key $ MRU queue' newTime+        | otherwise = MRU  queue' (time - 1)+            where+                queue' = PSQ.insert key time () queue++    evict MRU {time, queue} =+        case PSQ.findMin queue of+            Just (evicted, _, _) -> (MRU queue' time, Just evicted)+            _ -> (MRU queue time, Nothing)+        where+            queue' = PSQ.deleteMin queue++--TODO unify with LRU implementation+expandPSQPriorities :: (Integral p, Hashable k, Ord k, Bounded p) =>+    PSQ.HashPSQ k p v+    -> (p, PSQ.HashPSQ k p v)+expandPSQPriorities psq =+    PSQ.fold' increasePriority (maxValue, PSQ.empty) psq+    where+        increasePriority k p v (minValue, psq) = let+            -- Sutract the difference between p and largest p from upper bound+            newP = maxBound - (maxValue - p)+            m = min newP maxValue+            in (m, PSQ.insert k newP v psq)+        second (_, a, _) = a+        maxValue = maybe maxBound ((maxBound -). second) $ PSQ.findMin psq
+ src/Data/Cache/Eviction/RR.hs view
@@ -0,0 +1,85 @@+module Data.Cache.Eviction.RR (+    RR,+    newRR,+    rrSizeDebug+) where++import Data.Cache.Eviction++import qualified Data.HashSet as S+import qualified Data.Map.Strict as M+import Data.Maybe (isJust)+import System.Random (StdGen, randomR)++-- | Random Replacement cache. The seed is fixed to an 'StdGen' since its both+-- easily accessible & good enough for this purpose.+data RR k = RR {+    seed :: StdGen,+    writeCell :: Int,+    upperBound :: Int,+    overwritten :: Maybe k, -- This is a wart used for tracking evicted nodes+    contents :: StupidBiMap k+    } deriving (Show)++instance Eq k => Eq (RR k) where+    (==) l r = writeCell l == writeCell r &&+             upperBound l == upperBound r &&+             contents l == contents r++newRR ::+    StdGen+    -> Int+    -> RR k+newRR gen upperBound = RR gen 0 upperBound Nothing (StupidBiMap M.empty M.empty)++instance EvictionStrategy RR where+    recordLookup key rr@(RR {seed, upperBound , writeCell, contents=c@(StupidBiMap idxM kM) })+        -- When the key has already been stored, take no action+        | knownKey key c = rr+        -- When its a new key & the cache is full,+        | M.size idxM == upperBound = let+            (nextCell, seed') = randomR (0, upperBound -1) seed+            valAtIndex = keyAtIndex writeCell c+            in RR {+                writeCell = nextCell,+                seed = seed',+                upperBound = upperBound,+                overwritten = valAtIndex,+                contents = recordPair key writeCell c+                }+        | M.size idxM < upperBound =+            rr {writeCell = min (writeCell + 1) (upperBound -1), contents = recordPair key writeCell c}+        | otherwise = rr++    evict rr@(RR {overwritten} ) = (rr {overwritten=Nothing} , overwritten)++-- Horrible space efficiency+data StupidBiMap k = StupidBiMap (M.Map Int k) (M.Map k Int)+    deriving (Eq, Show)++recordPair :: (Eq k, Ord k) =>+    k+    -> Int+    -> StupidBiMap k+    -> StupidBiMap k+recordPair k writeIndex (StupidBiMap idxM kM) =+    StupidBiMap (M.insert writeIndex k idxM) (M.insert k writeIndex kM)++keyAtIndex ::+    Int+    -> StupidBiMap k+    -> Maybe k+keyAtIndex idx (StupidBiMap idxM _) =+    M.lookup idx idxM++knownKey :: (Eq k, Ord k) =>+    k+    -> StupidBiMap k+    -> Bool+knownKey k (StupidBiMap _ kM) =+    isJust $ M.lookup k kM++rrSizeDebug ::+    RR k+    -> Int+rrSizeDebug RR {contents = StupidBiMap l _} = M.size l
+ test/Spec.hs view
@@ -0,0 +1,17 @@+import Spec.LRUTests (lruTests)+import Spec.MRUTests (mruTests)+import Spec.RRTests (rrSpec)+import Spec.LFUTests (lfuTests)++import Test.Tasty  (TestTree, defaultMain, testGroup)++main :: IO ()+main = defaultMain allTests++allTests :: TestTree+allTests = testGroup "Data.Cache" [+    lruTests,+    mruTests,+    rrSpec,+    lfuTests+    ]
+ test/Spec/CacheTests.hs view
@@ -0,0 +1,14 @@+module Spec.CacheTests (+    cacheTests+) where++import Data.Cache++import           Test.HUnit                   ((@=?))+import           Test.Tasty                   (TestTree, testGroup)+import           Test.Tasty.HUnit             (testCase)+++cacheTests :: TestTree+cacheTests = testGroup "Cache" [+    ]
+ test/Spec/LRUTests.hs view
@@ -0,0 +1,83 @@+module Spec.LRUTests (+    lruTests+) where++import Data.Cache+import Data.Cache.Eviction.LRU++import           Test.HUnit                   ((@=?))+import           Test.Tasty                   (TestTree, testGroup)+import           Test.Tasty.HUnit             (testCase)+++lruTests :: TestTree+lruTests = testGroup "LRU" [+    seqLRUTests,+    psqLRUTests+    ]+++seqLRUTests :: TestTree+seqLRUTests = testGroup "Sequential" [+    testCase "evict empty == empty" $ do+        let strat = newSeqLRU :: SeqLRU Int+            (s, Nothing) = evict strat :: (SeqLRU Int, Maybe Int)+        s @=? strat+    , testCase "evict (1:empty) == (empty, Just 1) " $ do+        let strat = newSeqLRU :: SeqLRU Int+            s = recordLookup (1 :: Int) strat+            (s', Just _) = evict s :: (SeqLRU Int, Maybe Int)+        s' @=? strat+    , testCase "read a b a => evict b a" $ do+        let strat = newSeqLRU :: SeqLRU Int+            [x,y] = [1,2] :: [Int]+            s = recordLookup x . recordLookup y $ recordLookup x strat+            (s', Just a) = evict s+            (s'', Just b) = evict s'+            (_, Nothing) = evict s'' :: (SeqLRU Int, Maybe Int)+        a == y @=? True+        b == x @=? True+    , testCase "read a b c => evict a b c" $ do+        let strat = newSeqLRU :: SeqLRU Int+            [x,y,z] = [1,2,3] :: [Int]+            s = recordLookup x . recordLookup y $ recordLookup z strat+            (s', Just a) = evict s+            (s'', Just b) = evict s'+            (_, Just c) = evict s'' :: (SeqLRU Int, Maybe Int)+        a @=? x+        b @=? y+        c @=? z+    ]+++psqLRUTests :: TestTree+psqLRUTests = testGroup "Priority queue" [+    testCase "evict empty == empty" $ do+        let strat = newLRU :: LRU Int+            (s, Nothing) = evict strat :: (LRU Int, Maybe Int)+        s @=? strat+    , testCase "evict (1:empty) == (empty, Just 1) " $ do+        let strat = newLRU :: LRU Int+            s = recordLookup (1 :: Int) strat+            (s', Just _) = evict s :: (LRU Int, Maybe Int)+        LRUContentsOnlyEq s' @=? LRUContentsOnlyEq strat+    , testCase "read a b a => evict b a" $ do+        let strat = newLRU :: LRU Int+            [x,y] = [1,2] :: [Int]+            s = recordLookup x . recordLookup y $ recordLookup x strat+            (s', Just a) = evict s+            (s'', Just b) = evict s'+            (_, Nothing) = evict s'' :: (LRU Int, Maybe Int)+        a == y @=? True+        b == x @=? True+    , testCase "read a b c => evict a b c" $ do+        let strat = newLRU :: LRU Int+            [x,y,z] = [1,2,3] :: [Int]+            s = recordLookup x . recordLookup y $ recordLookup z strat+            (s', Just a) = evict s+            (s'', Just b) = evict s'+            (_, Just c) = evict s'' :: (LRU Int, Maybe Int)+        a @=? z+        b @=? y+        c @=? x+    ]
+ test/Spec/MRUTests.hs view
@@ -0,0 +1,43 @@+module  Spec.MRUTests (+    mruTests+) where++import Data.Cache+import Data.Cache.Eviction.MRU++import           Test.HUnit                   ((@=?))+import           Test.Tasty                   (TestTree, testGroup)+import           Test.Tasty.HUnit             (testCase)+++mruTests :: TestTree+mruTests = testGroup "MRU" [+    testCase "evict empty == empty" $ do+        let strat = newMRU :: MRU Int+            (s, Nothing) = evict strat :: (MRU Int, Maybe Int)+        s @=? strat+    , testCase "evict (1:empty) == (empty, Just 1) " $ do+        let strat = newMRU :: MRU Int+            s = recordLookup (1 :: Int) strat+            (s', Just _) = evict s :: (MRU Int, Maybe Int)+        MRUContentsOnlyEq s' @=? MRUContentsOnlyEq strat+    , testCase "read a b a => evict a b" $ do+        let strat = newMRU :: MRU Int+            [x,y] = [1,2] :: [Int]+            s = recordLookup x . recordLookup y $ recordLookup x strat+            (s', Just a) = evict s+            (s'', Just b) = evict s'+            (_, Nothing) = evict s'' :: (MRU Int, Maybe Int)+        a == x @=? True+        b == y @=? True+    , testCase "read a b c => evict c b a" $ do+        let strat = newMRU :: MRU Int+            [x,y,z] = [1,2,3] :: [Int]+            s = recordLookup x . recordLookup y $ recordLookup z strat+            (s', Just a) = evict s+            (s'', Just b) = evict s'+            (_, Just c) = evict s'' :: (MRU Int, Maybe Int)+        a @=? x+        b @=? y+        c @=? z+    ]
+ test/Spec/RRTests.hs view
@@ -0,0 +1,56 @@+module Spec.RRTests (+    rrSpec+) where++import Data.Cache+import Data.Cache.Eviction.RR++import Test.QuickCheck+import Test.Tasty+import Test.Tasty.HUnit+import System.Random (StdGen, mkStdGen)++rrSpec :: TestTree+rrSpec = testGroup "RR Spec" [+    testGroup "size never exceeds upper bound" [+        testCase "size = 1" $ do+            let rr = newRR defaultGen 1+                rr' = insertN rr 2+            1  @=? rrSizeDebug rr'+        , testCase "size = 1000" $ do+            let rr = newRR defaultGen 1000+                rr' = insertN rr 5000+            1000 @=? rrSizeDebug rr'+        ]+    , testCase "empty strategy eviction is a no-op" $ do+        let rr = newRR defaultGen 10 :: RR Int+            (rr', res) = evict rr+        res @=? Nothing+        rr' @=? rr+    , testCase "evict returns last evicted" $ do+        let rr = newRR defaultGen 10 :: RR Int+            rr' = insertN rr 1000+            (_, evicted) = evict rr'+        Just 5 @=? evicted+    , testCase "evict is deterministic given a seed" $ do+        let rr = newRR defaultGen 10 :: RR Int+            rr' = insertN rr 1000+            (e1, evicted) = evict rr'+            e2 = recordLookup 2000 e1+            (e3, evicted') = evict e2+            e4 = recordLookup 10000 e3+            (_, evicted'') = evict e4+        Just 5 @=? evicted+        Just 7 @=? evicted'+        Just 10 @=? evicted''+    ]+++defaultGen :: StdGen+defaultGen = mkStdGen 25++insertN ::+    RR Int+    -> Int+    -> RR Int+insertN rr n = foldr recordLookup rr [0..n]