lrucache (empty) → 0.1
raw patch · 8 files changed
+513/−0 lines, 8 filesdep +QuickCheckdep +basedep +containerssetup-changed
Dependencies added: QuickCheck, base, containers, explicit-exception
Files
- Data/Cache/LRU.hs +24/−0
- Data/Cache/LRU/IO.hs +75/−0
- Data/Cache/LRU/Internal.hs +222/−0
- LICENSE +30/−0
- README +5/−0
- Setup.hs +3/−0
- TestDriver.hs +98/−0
- lrucache.cabal +56/−0
+ Data/Cache/LRU.hs view
@@ -0,0 +1,24 @@+-- | Implements an LRU cache.+--+-- 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'.+--+-- The interface this module provides is opaque. If further control+-- is desired, the "Data.Cache.LRU.Internal" module can be used.+module Data.Cache.LRU+ ( LRU+ , newLRU+ , fromList+ , toList+ , maxSize+ , insert+ , lookup+ , delete+ , size+ )+where++import Prelude hiding ( lookup )++import Data.Cache.LRU.Internal
+ Data/Cache/LRU/IO.hs view
@@ -0,0 +1,75 @@+-- | This module contains a mutable wrapping of an LRU in the IO+-- monad, providing atomic access in a concurrent environment. All+-- calls preserve the same semantics as those in "Data.Cache.LRU", but+-- perform updates in place.+--+-- (This implementation uses an MVar for coarse locking. It's unclear+-- if anything else would give better performance, given that many+-- calls alter the head of the access list.)+module Data.Cache.LRU.IO+ ( AtomicLRU+ , newAtomicLRU+ , fromList+ , toList+ , maxSize+ , insert+ , lookup+ , delete+ , size+ )+where++import Prelude hiding ( lookup )++import Control.Applicative ( (<$>) )+import Control.Concurrent.MVar+ ( MVar+ , newMVar+ , readMVar+ , modifyMVar+ , modifyMVar_+ )++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+ -> IO (AtomicLRU key val)+newAtomicLRU = fmap C . newMVar . LRU.newLRU++-- | Build a new LRU from the given maximum size and list of+-- contents. See 'LRU.fromList' for the semantics.+fromList :: Ord key => Int -- ^ the maximum size+ -> [(key, val)] -> IO (AtomicLRU key val)+fromList s l = fmap C . newMVar $ LRU.fromList s l++-- | Retreive 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 <$> readMVar mvar++maxSize :: AtomicLRU key val -> IO Int+maxSize (C mvar) = LRU.maxSize <$> readMVar mvar++-- | Insert a key/value pair into an AtomicLRU. See 'LRU.insert' for+-- the semantics.+insert :: Ord key => key -> val -> AtomicLRU key val -> IO ()+insert key val (C mvar) = modifyMVar_ mvar $ return . LRU.insert key val++-- | Look up a key in an AtomicLRU. See 'LRU.lookup' for the+-- semantics.+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+delete key (C mvar) = modifyMVar mvar $ return . LRU.delete key++-- | Returns the number of elements the AtomicLRU currently contains.+size :: AtomicLRU key val -> IO Int+size (C mvar) = LRU.size <$> readMVar mvar
+ Data/Cache/LRU/Internal.hs view
@@ -0,0 +1,222 @@+{-# OPTIONS_HADDOCK not-home #-}++-- | This module provides access to all the internals use by the LRU+-- type. This can be used to create data structures that violate the+-- invariants the public interface maintains. Be careful when using+-- this module. The 'valid' function can be used to check if an LRU+-- structure satisfies the invariants the public interface maintains.+--+-- If this degree of control isn't needed, consider using+-- "Data.Cache.LRU" instead.+module Data.Cache.LRU.Internal where++import Prelude hiding ( last, lookup )++import Data.Maybe ( maybe )+import Data.Map ( Map )+import qualified Data.Map as Map++-- | 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'+ }++-- | 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+ }++-- | 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+ -> LRU key val+newLRU s | s <= 0 = error "non-positive size LRU"+ | otherwise = 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+ -> [(key, val)] -> LRU key val+fromList s l = appendAll $ newLRU s+ where appendAll = foldr ins id l+ ins (k, v) = (insert k v .)++-- | Retrieve a list view of an LRU. The items are returned in+-- order from most recently accessed to least recently accessed.+toList :: Ord key => LRU key val -> [(key, val)]+toList lru = maybe [] (listLinks . content $ lru) $ first lru+ where+ listLinks m key =+ let Just lv = Map.lookup key m+ keyval = (key, value lv)+ in case next lv of+ Nothing -> [keyval]+ Just nk -> keyval : listLinks m nk++-- | Add an item to an LRU. If the key was already present in the+-- LRU, the value is changed to the new value passed in. The+-- item added is marked as the most recently accessed item in the+-- LRU returned.+--+-- If this would cause the LRU to exceed its maximum size, the+-- least recently used item is dropped from the cache.+insert :: Ord key => key -> val -> LRU key val -> LRU key val+insert key val lru = maybe emptyCase nonEmptyCase $ first lru+ where+ contents = content lru+ full = Map.size contents == maxSize lru+ present = key `Map.member` contents++ -- this is the case for adding to an empty LRU Cache+ emptyCase = LRU fl fl (maxSize lru) m'+ where+ fl = Just key+ lv = Link val Nothing Nothing+ m' = Map.insert key lv contents++ nonEmptyCase firstKey = if present then hitSet else add firstKey++ -- this updates the value stored with the key, then marks it as+ -- the most recently accessed+ hitSet = hit' key lru'+ where lru' = lru { content = contents' }+ contents' = Map.adjust (\v -> v {value = val}) key contents++ -- create a new LRU with a new first item, and+ -- conditionally dropping the last item+ add firstKey = if full then lru'' else lru'+ where+ -- add a new first item+ firstLV' = Link val Nothing $ Just firstKey+ contents' = Map.insert key firstLV' .+ Map.adjust (\v -> v { prev = Just key }) firstKey $+ contents+ lru' = lru { first = Just key, content = contents' }++ -- remove the last item+ Just lastKey = last lru'+ Just lastLV = Map.lookup lastKey contents'+ Just pKey = prev lastLV+ contents'' = Map.delete lastKey .+ Map.adjust (\v -> v { next = Nothing }) pKey $+ contents'+ lru'' = lru' { last = Just pKey, content = contents'' }++-- | Look up an item in an LRU. If it was present, it is marked as+-- the most recently accesed in the returned LRU.+lookup :: Ord key => key -> LRU key val -> (LRU key val, Maybe val)+lookup key lru = case Map.lookup key $ content lru of+ Nothing -> (lru, Nothing)+ Just lv -> (hit' key lru, Just . value $ lv)++-- | 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+ where+ cont = content lru+ (mLV, cont') = Map.updateLookupWithKey (\_ _ -> Nothing) key cont++ -- covers all the cases where something is removed+ delete' lv = (if Map.null cont' then deleteOnly else deleteOne, True)+ where+ -- delete the only item in the cache+ deleteOnly = lru { first = Nothing+ , last = Nothing+ , content = cont'+ }++ -- delete an item that isn't the only item+ Just firstKey = first lru+ deleteOne = if firstKey == key then deleteFirst else deleteNotFirst++ -- delete the first item+ deleteFirst = lru { first = next lv+ , content = contFirst+ }+ Just nKey = next lv+ contFirst = Map.adjust (\v -> v { prev = Nothing }) nKey cont'++ -- delete an item other than the first+ Just lastKey = last lru+ deleteNotFirst = if lastKey == key then deleteLast else deleteMid++ -- delete the last item+ deleteLast = lru { last = prev lv+ , content = contLast+ }+ Just pKey = prev lv+ contLast = Map.adjust (\v -> v { next = Nothing}) pKey cont'++ -- delete an item in the middle+ deleteMid = lru { content = contMid }+ contMid = Map.adjust (\v -> v { next = next lv }) pKey .+ Map.adjust (\v -> v { prev = prev lv }) nKey $+ cont'++-- | Returns the number of elements the LRU currently contains.+size :: LRU key val -> Int+size = Map.size . content++-- | Internal function. The key passed in must be present in the+-- LRU. Moves the item associated with that key to the most+-- recently accessed position.+hit' :: Ord key => key -> LRU key val -> LRU key val+hit' key lru = if key == firstKey then lru else notFirst+ where Just firstKey = first lru+ Just lastKey = last lru+ Just lastLV = Map.lookup lastKey conts+ conts = content lru++ -- key wasn't already the head of the list. Some alteration+ -- will be needed+ notFirst = if key == lastKey then replaceLast else replaceMiddle++ adjFront = Map.adjust (\v -> v { prev = Just key}) firstKey .+ Map.adjust (\v -> v { prev = Nothing+ , next = first lru }) key++ -- key was the last entry in the list+ replaceLast = lru { first = Just key+ , last = prev lastLV+ , content = cLast+ }+ Just pKey = prev lastLV+ cLast = Map.adjust (\v -> v { next = Nothing }) pKey . adjFront $+ conts++ -- the key wasn't the first or last key+ replaceMiddle = lru { first = Just key+ , content = cMid+ }+ Just keyLV = Map.lookup key conts+ Just prevKey = prev keyLV+ Just nextKey = next keyLV+ cMid = Map.adjust (\v -> v { next = Just nextKey }) prevKey .+ Map.adjust (\v -> v { prev = Just prevKey }) nextKey .+ adjFront $ conts++-- | Internal function. This checks the three structural invariants+-- of the LRU cache structure:+--+-- 1. The cache's size does not exceed the specified max size.+--+-- 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.+valid :: Ord key => LRU key val -> Bool+valid lru = size lru <= maxSize lru &&+ reverse orderedKeys == reverseKeys &&+ size lru == length orderedKeys+ where contents = content lru+ orderedKeys = traverse next . first $ lru+ traverse _ Nothing = []+ traverse f (Just k) = let Just k' = Map.lookup k contents+ in k : (traverse f . f $ k')+ reverseKeys = traverse prev . last $ lru
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Carl Howells 2010++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 Carl Howells 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 view
@@ -0,0 +1,5 @@+This package contains a simple pure LRU cache, implemented in terms of+"Data.Map".++It also contains a mutable IO wrapper providing atomic updates to an+LRU cache.
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ TestDriver.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
+ lrucache.cabal view
@@ -0,0 +1,56 @@+Name: lrucache+Version: 0.1+Synopsis: a simple pure LRU cache+License: BSD3+License-file: LICENSE+Author: Carl Howells+Maintainer: chowells79@gmail.com+Copyright: Carl Howells, 2010+Homepage: http://github.com/chowells79/lrucache+Stability: Experimental+Category: Data+Build-type: Simple+Description:+ This package contains a simple pure LRU cache, implemented in+ terms of "Data.Map".+ .+ It also contains a mutable IO wrapper providing atomic updates to+ an LRU cache.++Extra-source-files:+ README+ TestDriver.hs++Cabal-version: >=1.6++Flag Test+ Description: Build test executables+ Default: False++Library+ Exposed-modules:+ Data.Cache.LRU+ Data.Cache.LRU.IO+ Data.Cache.LRU.Internal++ Build-depends:+ base < 5,+ containers++ GHC-Options: -Wall+++Executable test+ if flag(test)+ Buildable: True++ Build-Depends:+ base < 4.2,+ explicit-exception == 0.1.*,+ QuickCheck == 2.1.*++ else+ Buildable: False++ Main-is: TestDriver.hs+ GHC-Options: -Wall