lrucache 0.2 → 0.2.0.1
raw patch · 5 files changed
+138/−127 lines, 5 filesdep −QuickCheckdep −explicit-exceptiondep ~basedep ~containers
Dependencies removed: QuickCheck, explicit-exception
Dependency ranges changed: base, containers
Files
- Data/Cache/LRU/Internal.hs +6/−6
- MemTest.hs +25/−0
- OpTest.hs +98/−0
- TestDriver.hs +0/−98
- lrucache.cabal +9/−23
Data/Cache/LRU/Internal.hs view
@@ -17,18 +17,18 @@ -- | Stores the information that makes up an LRU cache data LRU key val = LRU {- first :: Maybe key -- ^ the key of the most recently accessed entry- , last :: Maybe key -- ^ the key of the least recently accessed entry- , maxSize :: Int -- ^ the maximum size of the LRU cache- , content :: Map key (LinkedVal key val) -- ^ the backing 'Map'+ first :: !(Maybe key) -- ^ the key of the most recently accessed entry+ , last :: !(Maybe key) -- ^ the key of the least recently accessed entry+ , maxSize :: !Int -- ^ the maximum size of the LRU cache+ , content :: !(Map key (LinkedVal key val)) -- ^ the backing 'Map' } deriving Eq -- | The values stored in the Map of the LRU cache. They embed a -- doubly-linked list through the values of the 'Map'. data LinkedVal key val = Link { value :: val -- ^ The actual value- , prev :: Maybe key -- ^ the key of the value before this one- , next :: Maybe key -- ^ the key of the value after this one+ , prev :: !(Maybe key) -- ^ the key of the value before this one+ , next :: !(Maybe key) -- ^ the key of the value after this one } deriving Eq -- | Make an LRU. The LRU is guaranteed to not grow above the
+ MemTest.hs view
@@ -0,0 +1,25 @@+import Prelude hiding ( lookup )++import Control.Monad+import Control.Concurrent+import Data.IORef++import Data.Cache.LRU.IO.Internal++main :: IO ()+main = do+ v1 <- newAtomicLRU 10 -- for endless inserts+ v2 <- newAtomicLRU 10 -- for endless lookups (miss)+ v3 <- newAtomicLRU 10 -- for endless lookups (hit)++ counter <- newIORef (0 :: Int)++ insert 1 "bar" v3++ forever $ do+ c <- readIORef counter+ writeIORef counter $ c + 1++ insert c (show c) v1+ lookup (1 :: Int) v2+ lookup (1 :: Int) v3
+ OpTest.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE FlexibleInstances #-}+import Prelude hiding ( lookup )++import Control.Monad+import Control.Monad.Exception.Synchronous++import Data.Cache.LRU.Internal++import Test.QuickCheck+ ( Arbitrary(..)+ , Args(..)+ , choose+ , oneof+ , shrinkNothing+ , quickCheckWith+ , stdArgs+ )+import Test.QuickCheck.Property ( Result(..), result, succeeded )++data Action key val = Insert key val+ | Lookup key+ | Delete key+ deriving (Show, Eq)++instance Arbitrary (Action Int Int) where+ arbitrary = oneof [ins, look, del]+ where ins = liftM2 Insert key $ choose (100, 104)+ look = liftM Lookup key+ del = liftM Delete key+ key = choose (1, 10)++ shrink = shrinkNothing++newtype History key val = H (Int, [Action key val] -> [Action key val])++instance Arbitrary (History Int Int) where+ arbitrary = liftM2 (curry H) s h+ where s = choose (1, 5)+ h = liftM (++) arbitrary++ shrink (H (k, h)) = map (H . (,) k . (++)) . drops . h $ []+ where drops [] = []+ drops (x:xs) = xs:[x:ys | ys <- drops xs]++instance (Show key, Show val) => Show (History key val) where+ show (H (k, h)) = show (k, h [])++execute :: (Ord key, Eq val, Show key, Show val) => History key val+ -> Exceptional String (LRU key val)+execute (H (k, h)) = execute' (h []) (newLRU k)+ where+ execute' [] lru = return lru+ execute' (x:xs) lru = executeA x lru >>= execute' xs++ execA' key val lru lru' = do+ when (not . valid $ lru') $ throw "not valid"++ let pre = toList lru+ post = toList lru'++ naive = (key, val) : filter ((key /=) . fst) pre+ projected = if length naive <= k then naive else init naive+ when (projected /= post) $ throw "unexpected result"++ return lru'++ executeA (Delete key) lru = do+ let (lru', present) = delete key lru+ when (not . valid $ lru') $ throw "not valid"++ let pre = toList lru+ post = toList lru'+ projected = filter ((key /=) . fst) pre+ shouldShorten = length projected /= length pre++ when (present /= shouldShorten) $ throw "unexpected resulting bool"+ when (projected /= post) $ throw "unexpected resulting lru"+ return lru'++ executeA (Insert key val) lru = execA' key val lru $ insert key val lru++ executeA (Lookup key) lru = case mVal of+ Nothing -> checkSame+ Just val -> execA' key val lru lru'+ where (lru', mVal) = lookup key lru+ checkSame = do when (toList lru /= toList lru') $+ throw "unexpected result"+ return lru'++executesProperly :: History Int Int -> Result+executesProperly h = case execute h of+ Success _ -> succeeded+ Exception e -> result { ok = Just False+ , reason = e+ }++main :: IO ()+main = quickCheckWith stdArgs { maxSuccess = 1000 } executesProperly
− TestDriver.hs
@@ -1,98 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-import Prelude hiding ( lookup )--import Control.Monad-import Control.Monad.Exception.Synchronous--import Data.Cache.LRU.Internal--import Test.QuickCheck- ( Arbitrary(..)- , Args(..)- , choose- , oneof- , shrinkNothing- , quickCheckWith- , stdArgs- )-import Test.QuickCheck.Property ( Result(..), result, succeeded )--data Action key val = Insert key val- | Lookup key- | Delete key- deriving (Show, Eq)--instance Arbitrary (Action Int Int) where- arbitrary = oneof [ins, look, del]- where ins = liftM2 Insert key $ choose (100, 104)- look = liftM Lookup key- del = liftM Delete key- key = choose (1, 10)-- shrink = shrinkNothing--newtype History key val = H (Int, [Action key val] -> [Action key val])--instance Arbitrary (History Int Int) where- arbitrary = liftM2 (curry H) s h- where s = choose (1, 5)- h = liftM (++) arbitrary-- shrink (H (k, h)) = map (H . (,) k . (++)) . drops . h $ []- where drops [] = []- drops (x:xs) = xs:[x:ys | ys <- drops xs]--instance (Show key, Show val) => Show (History key val) where- show (H (k, h)) = show (k, h [])--execute :: (Ord key, Eq val, Show key, Show val) => History key val- -> Exceptional String (LRU key val)-execute (H (k, h)) = execute' (h []) (newLRU k)- where- execute' [] lru = return lru- execute' (x:xs) lru = executeA x lru >>= execute' xs-- execA' key val lru lru' = do- when (not . valid $ lru') $ throw "not valid"-- let pre = toList lru- post = toList lru'-- naive = (key, val) : filter ((key /=) . fst) pre- projected = if length naive <= k then naive else init naive- when (projected /= post) $ throw "unexpected result"-- return lru'-- executeA (Delete key) lru = do- let (lru', present) = delete key lru- when (not . valid $ lru') $ throw "not valid"-- let pre = toList lru- post = toList lru'- projected = filter ((key /=) . fst) pre- shouldShorten = length projected /= length pre-- when (present /= shouldShorten) $ throw "unexpected resulting bool"- when (projected /= post) $ throw "unexpected resulting lru"- return lru'-- executeA (Insert key val) lru = execA' key val lru $ insert key val lru-- executeA (Lookup key) lru = case mVal of- Nothing -> checkSame- Just val -> execA' key val lru lru'- where (lru', mVal) = lookup key lru- checkSame = do when (toList lru /= toList lru') $- throw "unexpected result"- return lru'--executesProperly :: History Int Int -> Result-executesProperly h = case execute h of- Success _ -> succeeded- Exception e -> result { ok = Just False- , reason = e- }--main :: IO ()-main = quickCheckWith stdArgs { maxSuccess = 1000 } executesProperly
lrucache.cabal view
@@ -1,5 +1,5 @@ Name: lrucache-Version: 0.2+Version: 0.2.0.1 Synopsis: a simple, pure LRU cache License: BSD3 License-file: LICENSE@@ -19,6 +19,10 @@ . Version History: .+ 0.2.0.1 - Increase strictness slightly.+ Remove cabal target for test executable.+ (Just include test sources instead.)+ . 0.2 - Added an Eq instance for LRU. Added strictness to eliminate space leaks in common use patterns. .@@ -31,14 +35,11 @@ Extra-source-files: README- TestDriver.hs+ MemTest.hs+ OpTest.hs Cabal-version: >=1.6 -Flag Test- Description: Build test executables- Default: False- Library Exposed-modules: Data.Cache.LRU@@ -47,22 +48,7 @@ Data.Cache.LRU.IO.Internal Build-depends:- base > 4 && < 5,- containers > 0.2 && < 0.4-- GHC-Options: -Wall---Executable test- if flag(test)- Buildable: True-- Build-Depends:- explicit-exception == 0.1.*,- QuickCheck == 2.1.*-- else- Buildable: False+ base >= 4 && < 5,+ containers >= 0.2 && < 0.4 - Main-is: TestDriver.hs GHC-Options: -Wall