lrucache 0.3 → 1.0
raw patch · 7 files changed
+113/−50 lines, 7 files
Files
- Data/Cache/LRU.hs +2/−1
- Data/Cache/LRU/IO.hs +1/−0
- Data/Cache/LRU/IO/Internal.hs +37/−21
- Data/Cache/LRU/Internal.hs +27/−14
- MemTest.hs +3/−3
- OpTest.hs +30/−8
- lrucache.cabal +13/−3
Data/Cache/LRU.hs view
@@ -2,7 +2,7 @@ -- -- This module provides a pure LRU cache based on a doubly-linked list -- through a Data.Map structure. This gives O(log n) operations on--- 'insert' and 'lookup', and O(n) for 'toList'.+-- 'insert', 'lookup', 'delete', and 'pop', and O(n * log n) for 'toList'. -- -- The interface this module provides is opaque. If further control -- is desired, the "Data.Cache.LRU.Internal" module can be used.@@ -15,6 +15,7 @@ , insert , lookup , delete+ , pop , size ) where
Data/Cache/LRU/IO.hs view
@@ -19,6 +19,7 @@ , insert , lookup , delete+ , pop , size ) where
Data/Cache/LRU/IO/Internal.hs view
@@ -11,35 +11,38 @@ -- "Data.Cache.LRU.IO", be used instead. module Data.Cache.LRU.IO.Internal where -import Prelude hiding ( lookup )+import Prelude hiding ( lookup, mod, take ) import Control.Applicative ( (<$>) ) import Control.Concurrent.MVar ( MVar ) import qualified Control.Concurrent.MVar as MV +import Control.Exception ( bracketOnError )+ import Data.Cache.LRU ( LRU ) import qualified Data.Cache.LRU as LRU -- | The opaque wrapper type newtype AtomicLRU key val = C (MVar (LRU key val)) --- | Make a new AtomicLRU with the given maximum size.-newAtomicLRU :: Ord key => Int -- ^ the maximum size+-- | Make a new AtomicLRU that will not grow beyond the optional+-- maximum size, if specified.+newAtomicLRU :: Ord key => Maybe Int -- ^ the optional maximum size -> IO (AtomicLRU key val) newAtomicLRU = fmap C . MV.newMVar . LRU.newLRU --- | Build a new LRU from the given maximum size and list of+-- | Build a new LRU from the optional maximum size and list of -- contents. See 'LRU.fromList' for the semantics.-fromList :: Ord key => Int -- ^ the maximum size+fromList :: Ord key => Maybe Int -- ^ the optional maximum size -> [(key, val)] -> IO (AtomicLRU key val) fromList s l = fmap C . MV.newMVar $ LRU.fromList s l --- | Retreive a list view of an AtomicLRU. See 'LRU.toList' for the+-- | Retrieve a list view of an AtomicLRU. See 'LRU.toList' for the -- semantics. toList :: Ord key => AtomicLRU key val -> IO [(key, val)] toList (C mvar) = LRU.toList <$> MV.readMVar mvar -maxSize :: AtomicLRU key val -> IO Int+maxSize :: AtomicLRU key val -> IO (Maybe Int) maxSize (C mvar) = LRU.maxSize <$> MV.readMVar mvar -- | Insert a key/value pair into an AtomicLRU. See 'LRU.insert' for@@ -52,28 +55,41 @@ lookup :: Ord key => key -> AtomicLRU key val -> IO (Maybe val) lookup key (C mvar) = modifyMVar' mvar $ return . LRU.lookup key --- | Remove an item from an AtomicLRU. Returns whether the item was--- present to be removed.-delete :: Ord key => key -> AtomicLRU key val -> IO Bool+-- | Remove an item from an AtomicLRU. Returns the value for the+-- removed key, if it was present+delete :: Ord key => key -> AtomicLRU key val -> IO (Maybe val) delete key (C mvar) = modifyMVar' mvar $ return . LRU.delete key +-- | Remove the least-recently accessed item from an AtomicLRU.+-- Returns the (key, val) pair removed, if one was present.+pop :: Ord key => AtomicLRU key val -> IO (Maybe (key, val))+pop (C mvar) = modifyMVar' mvar $ return . LRU.pop+ -- | Returns the number of elements the AtomicLRU currently contains. size :: AtomicLRU key val -> IO Int size (C mvar) = LRU.size <$> MV.readMVar mvar --- | A version of 'MV.modifyMVar_' that applies the modification--- function strictly.+-- | A version of 'MV.modifyMVar_' that forces the result of the+-- function application to WHNF. modifyMVar_' :: MVar a -> (a -> IO a) -> IO () modifyMVar_' mvar f = do- x <- MV.takeMVar mvar- x' <- f x- MV.putMVar mvar $! x'+ let take = MV.takeMVar mvar+ replace = MV.putMVar mvar+ mod x = do+ x' <- f x+ MV.putMVar mvar $! x' --- | A version of 'MV.modifyMVar' that applies the modification--- function strictly. The returned value is not evaluated strictly.+ bracketOnError take replace mod++-- | A version of 'MV.modifyMVar' that forces the result of the+-- function application to WHNF. modifyMVar' :: MVar a -> (a -> IO (a, b)) -> IO b modifyMVar' mvar f = do- x <- MV.takeMVar mvar- (x', result) <- f x- MV.putMVar mvar $! x'- return result+ let take = MV.takeMVar mvar+ replace = MV.putMVar mvar+ mod x = do+ (x', result) <- f x+ MV.putMVar mvar $! x'+ return result++ bracketOnError take replace mod
Data/Cache/LRU/Internal.hs view
@@ -19,7 +19,7 @@ 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+ , maxSize :: !(Maybe Int) -- ^ the maximum size of the LRU cache , content :: !(Map key (LinkedVal key val)) -- ^ the backing 'Map' } deriving Eq @@ -35,16 +35,16 @@ , 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--- specified number of entries.-newLRU :: (Ord key) => Int -- ^ the maximum size of the LRU+-- | Make an LRU. If a size limit is specified, the LRU is guaranteed+-- to not grow above the specified number of entries.+newLRU :: (Ord key) => Maybe Int -- ^ the optional maximum size of the LRU -> LRU key val-newLRU s | s <= 0 = error "non-positive size LRU"- | otherwise = LRU Nothing Nothing s Map.empty+newLRU (Just s) | s <= 0 = error "non-positive size LRU"+newLRU s = LRU Nothing Nothing s Map.empty -- | Build a new LRU from the given maximum size and list of contents, -- in order from most recently accessed to least recently accessed.-fromList :: Ord key => Int -- ^ the maximum size of the LRU+fromList :: Ord key => Maybe Int -- ^ the optional maximum size of the LRU -> [(key, val)] -> LRU key val fromList s l = appendAll $ newLRU s where appendAll = foldr ins id l@@ -73,7 +73,7 @@ insert key val lru = maybe emptyCase nonEmptyCase $ first lru where contents = content lru- full = Map.size contents == maxSize lru+ full = maybe False (Map.size contents ==) $ maxSize lru present = key `Map.member` contents -- this is the case for adding to an empty LRU Cache@@ -117,12 +117,22 @@ -- | Remove an item from an LRU. Returns the new LRU, and if the item -- was present to be removed.-delete :: Ord key => key -> LRU key val -> (LRU key val, Bool)-delete key lru = maybe (lru, False) delete'' mLV+delete :: Ord key => key -> LRU key val -> (LRU key val, Maybe val)+delete key lru = maybe (lru, Nothing) delete'' mLV where- delete'' = flip (,) True . delete' key lru cont'+ delete'' lv = (delete' key lru cont' lv, Just $ value lv) (mLV, cont') = Map.updateLookupWithKey (\_ _ -> Nothing) key $ content lru +-- | Removes the least-recently accessed element from the LRU.+-- Returns the new LRU, and the key and value from the least-recently+-- used element, if there was one.+pop :: Ord key => LRU key val -> (LRU key val, Maybe (key, val))+pop lru = if size lru == 0 then (lru, Nothing) else (lru', Just pair)+ where+ Just lastKey = last lru+ (lru', Just lastVal) = delete lastKey lru+ pair = (lastKey, lastVal)+ -- | Returns the number of elements the LRU currently contains. size :: LRU key val -> Int size = Map.size . content@@ -231,7 +241,7 @@ adjust' :: Ord k => (a -> a) -> k -> Map k a -> Map k a adjust' f k m = Map.insertWith' (\_ o -> f o) k undefined m --- | Internal function. This checks the three structural invariants+-- | Internal function. This checks the four structural invariants -- of the LRU cache structure: -- -- 1. The cache's size does not exceed the specified max size.@@ -239,10 +249,13 @@ -- 2. The linked list through the nodes is consistent in both directions. -- -- 3. The linked list contains the same number of nodes as the cache.+--+-- 4. Every key in the linked list is in the 'Map'. valid :: Ord key => LRU key val -> Bool-valid lru = size lru <= maxSize lru &&+valid lru = maybe True (size lru <=) (maxSize lru) && reverse orderedKeys == reverseKeys &&- size lru == length orderedKeys+ size lru == length orderedKeys &&+ all (`Map.member` contents) orderedKeys where contents = content lru orderedKeys = traverse next . first $ lru traverse _ Nothing = []
MemTest.hs view
@@ -8,9 +8,9 @@ main :: IO () main = do- v1 <- newAtomicLRU 10 -- for endless inserts- v2 <- newAtomicLRU 10 -- for endless lookups (miss)- v3 <- newAtomicLRU 10 -- for endless lookups (hit)+ v1 <- newAtomicLRU $ Just 10 -- for endless inserts+ v2 <- newAtomicLRU $ Just 10 -- for endless lookups (miss)+ v3 <- newAtomicLRU $ Just 10 -- for endless lookups (hit) counter <- newIORef (0 :: Int)
OpTest.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE FlexibleInstances #-}-import Prelude hiding ( lookup )+import qualified Prelude+import Prelude hiding ( lookup, last ) +import Control.Applicative import Control.Monad import Control.Monad.Exception.Synchronous @@ -9,6 +11,7 @@ import Test.QuickCheck ( Arbitrary(..) , Args(..)+ , Gen , choose , oneof , shrinkNothing@@ -20,22 +23,24 @@ data Action key val = Insert key val | Lookup key | Delete key+ | Pop deriving (Show, Eq) instance Arbitrary (Action Int Int) where- arbitrary = oneof [ins, look, del]+ arbitrary = oneof [ins, look, del, pop] where ins = liftM2 Insert key $ choose (100, 104) look = liftM Lookup key del = liftM Delete key+ pop = return Pop key = choose (1, 10) shrink = shrinkNothing -newtype History key val = H (Int, [Action key val] -> [Action key val])+newtype History key val = H (Maybe Int, [Action key val] -> [Action key val]) instance Arbitrary (History Int Int) where arbitrary = liftM2 (curry H) s h- where s = choose (1, 5)+ where s = liftM2 (<$) (choose (1, 5)) (arbitrary :: Gen (Maybe ())) h = liftM (++) arbitrary shrink (H (k, h)) = map (H . (,) k . (++)) . drops . h $ []@@ -59,21 +64,22 @@ post = toList lru' naive = (key, val) : filter ((key /=) . fst) pre- projected = if length naive <= k then naive else init naive+ sizeOk = maybe True (length naive <=) k+ projected = if sizeOk then naive else init naive when (projected /= post) $ throw "unexpected result" return lru' executeA (Delete key) lru = do- let (lru', present) = delete key lru+ let (lru', removed) = 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+ expectedRemoval = Prelude.lookup key pre - when (present /= shouldShorten) $ throw "unexpected resulting bool"+ when (removed /= expectedRemoval) $ throw "unexpected value removed" when (projected /= post) $ throw "unexpected resulting lru" return lru' @@ -86,6 +92,22 @@ checkSame = do when (toList lru /= toList lru') $ throw "unexpected result" return lru'++ executeA Pop lru = do+ let (lru', popped) = pop lru+ when (not . valid $ lru') $ throw "not valid"++ let pre = toList lru+ post = toList lru'++ (ePost, ePopped) = case pre of+ [] -> ([], Nothing)+ _ -> (init pre, Just $ Prelude.last pre)++ when (post /= ePost) $ throw "unexpected result lru"+ when (popped /= ePopped) $ throw "unexpected result key-value"+ return lru'+ executesProperly :: History Int Int -> Result executesProperly h = case execute h of
lrucache.cabal view
@@ -1,5 +1,5 @@ Name: lrucache-Version: 0.3+Version: 1.0 Synopsis: a simple, pure LRU cache License: BSD3 License-file: LICENSE@@ -19,8 +19,16 @@ . Version History: .- 0.3 - Added a Show instance for LRU.+ 1.0 - Breaking API changes:+ 1) The newLRU smart constructor now makes the maximum+ size optional.+ 2) The delete function now returns the value removed, if+ one was.+ Additionally, a function was added to remove the least-recently+ used element in the LRU. .+ 0.3 - Added a Show instance for LRU. (Requested by Ben Lee)+ . 0.2.0.1 - Increase strictness slightly. Remove cabal target for test executable. (Just include test sources instead.)@@ -36,9 +44,11 @@ 0.1 - First release Extra-source-files:+ LICENSE README MemTest.hs OpTest.hs+ Setup.hs Cabal-version: >=1.6 @@ -53,4 +63,4 @@ base >= 4 && < 5, containers >= 0.2 && < 0.4 - GHC-Options: -Wall+ GHC-options: -Wall -O2