lrucache-1.2.0.1/0000755000000000000000000000000007346545000011630 5ustar0000000000000000lrucache-1.2.0.1/LICENSE0000644000000000000000000000276207346545000012644 0ustar0000000000000000Copyright Carl Howells 2010-2015 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. lrucache-1.2.0.1/LICENSE0000755000000000000000000000276207346545000012647 0ustar0000000000000000Copyright Carl Howells 2010-2015 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. lrucache-1.2.0.1/MemTest.hs0000755000000000000000000000106407346545000013546 0ustar0000000000000000import Prelude hiding ( lookup ) import Control.Monad import Control.Concurrent import Data.IORef import Data.Cache.LRU.IO.Internal main :: IO () main = do 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) 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 lrucache-1.2.0.1/OpTest.hs0000755000000000000000000000773307346545000013417 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} module OpTest where import qualified Prelude import Prelude hiding ( lookup, last ) import Control.Applicative import Control.Monad import Control.Monad.Exception.Synchronous import Data.Cache.LRU.Internal import Test.QuickCheck ( Arbitrary(..) , Args(..) , Gen , choose , oneof , shrinkNothing , quickCheckWith , stdArgs ) import Test.QuickCheck.Property ( Result(..), result, succeeded ) 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, 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 ( Maybe Integer , [Action key val] -> [Action key val] ) instance Arbitrary (History Int Int) where arbitrary = liftM2 (curry H) s h where s = liftM2 (<$) (choose (1, 5)) (arbitrary :: Gen (Maybe ())) 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 sizeOk = maybe True (fromIntegral (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', removed) = delete key lru when (not . valid $ lru') $ throw "not valid" let pre = toList lru post = toList lru' projected = filter ((key /=) . fst) pre expectedRemoval = Prelude.lookup key pre when (removed /= expectedRemoval) $ throw "unexpected value removed" 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' 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 Success _ -> succeeded Exception e -> result { ok = Just False , reason = e } main :: IO () main = quickCheckWith stdArgs { maxSuccess = 1000 } executesProperly lrucache-1.2.0.1/README0000755000000000000000000000024407346545000012513 0ustar0000000000000000This 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. lrucache-1.2.0.1/Setup.hs0000644000000000000000000000011007346545000013254 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMain lrucache-1.2.0.1/Setup.hs0000755000000000000000000000011007346545000013257 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMain lrucache-1.2.0.1/changes.txt0000755000000000000000000000302007346545000013777 0ustar0000000000000000** 1.2.0.1 * Bumped version bound on containers. Pull request contributed by mstksg * Finally fixed long-standing error in insertInforming ** 1.2.0.0 * fix build warning on GHC 7.10 * add insertInforming * add instances for Data, Typeable, Foldable, and Traversable * add functions for compatibility with lens ** 1.1.1.4 * move changelog to hackage 2 approved location ** 1.1.1.3 * Test for containers >= 0.5, rather than GHC >= 7.6 ** 1.1.1.2 * Make actually compatible with containers 0.5 - fix strictness issue ** 1.1.1.1 * Fix containers upper bound for GHC 7.6. ** 1.1.1 * Add an additional modification function for AtomicLRUCache. ** 1.1.0.1 * Update containers constraint to allow containers from ghc-7 ** 1.1 * Add a Functor instance for LRUCache. * Add a generic modification function for AtomicLRUCache. ** 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. * 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.) ** 0.2 * Added an Eq instance for LRU. * Added strictness to eliminate space leaks in common use patterns. ** 0.1.1 * Add the Data.Cache.LRU.IO.Internal module. * Clean up build warnings on GHC 6.12.1. ** 0.1.0.1 * Minor refactoring ** 0.1.0.1 * First release lrucache-1.2.0.1/lrucache.cabal0000644000000000000000000000234607346545000014407 0ustar0000000000000000Name: lrucache Version: 1.2.0.1 Synopsis: a simple, pure LRU cache License: BSD3 License-file: LICENSE Author: Carl Howells Maintainer: chowells79@gmail.com Copyright: Carl Howells, 2010-2015 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: LICENSE README MemTest.hs OpTest.hs Setup.hs changes.txt Cabal-version: >=1.6 Source-repository this type: git location: https://github.com/chowells79/lrucache.git tag: 1.2.0.1 Library Exposed-modules: Data.Cache.LRU Data.Cache.LRU.Internal Data.Cache.LRU.IO Data.Cache.LRU.IO.Internal Build-depends: base >= 4 && < 5, containers >= 0.2 && < 0.7, contravariant >= 0.5 && < 2 GHC-options: -Wall -O2 HS-source-dirs: src lrucache-1.2.0.1/src/Data/Cache/0000755000000000000000000000000007346545000014273 5ustar0000000000000000lrucache-1.2.0.1/src/Data/Cache/LRU.hs0000644000000000000000000000121607346545000015271 0ustar0000000000000000-- | 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', '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. module Data.Cache.LRU ( LRU , newLRU , fromList , toList , pairs , keys , maxSize , insert , insertInforming , lookup , delete , pop , size ) where import Prelude hiding ( lookup ) import Data.Cache.LRU.Internal lrucache-1.2.0.1/src/Data/Cache/LRU/0000755000000000000000000000000007346545000014735 5ustar0000000000000000lrucache-1.2.0.1/src/Data/Cache/LRU/IO.hs0000644000000000000000000000170607346545000015604 0ustar0000000000000000-- | 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. All functions use a single atomic update -- of the backing structure. -- -- The interface this module provides is opaque. If further control -- is desired, the "Data.Cache.LRU.IO.Internal" module can be used in -- combination with "Data.Cache.LRU.Internal". -- -- (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 , pop , size , modifyAtomicLRU , modifyAtomicLRU' ) where import Prelude hiding ( lookup ) import Data.Cache.LRU.IO.Internal lrucache-1.2.0.1/src/Data/Cache/LRU/IO/0000755000000000000000000000000007346545000015244 5ustar0000000000000000lrucache-1.2.0.1/src/Data/Cache/LRU/IO/Internal.hs0000644000000000000000000001020307346545000017350 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE DeriveDataTypeable #-} -- | 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 module contains the internal implementation details. It's -- possible to put an 'AtomicLRU' into a bad state with this module. -- It is highly recommended that the external interface, -- "Data.Cache.LRU.IO", be used instead. module Data.Cache.LRU.IO.Internal where 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 import Data.Typeable (Typeable) -- | The opaque wrapper type newtype AtomicLRU key val = C (MVar (LRU key val)) deriving Typeable -- | Make a new AtomicLRU that will not grow beyond the optional -- maximum size, if specified. newAtomicLRU :: Ord key => Maybe Integer -- ^ the optional maximum size -> IO (AtomicLRU key val) newAtomicLRU = fmap C . MV.newMVar . LRU.newLRU -- | Build a new LRU from the optional maximum size and list of -- contents. See 'LRU.fromList' for the semantics. fromList :: Ord key => Maybe Integer -- ^ the optional maximum size -> [(key, val)] -> IO (AtomicLRU key val) fromList s l = fmap C . MV.newMVar $ LRU.fromList s l -- | 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 (Maybe Integer) maxSize (C mvar) = LRU.maxSize <$> MV.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 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 -- | Given a function that takes an 'LRU.LRU' and returns one of the -- same type, use it to modify the contents of this AtomicLRU. modifyAtomicLRU :: (LRU.LRU key val -> LRU.LRU key val) -> AtomicLRU key val -> IO () modifyAtomicLRU f = modifyAtomicLRU' $ return . f -- | Given a function that takes an 'LRU.LRU' and returns an IO action -- producting one of the same type, use it to modify the contents of -- this AtomicLRU. modifyAtomicLRU' :: (LRU.LRU key val -> IO (LRU.LRU key val)) -> AtomicLRU key val -> IO () modifyAtomicLRU' f (C mvar) = modifyMVar_' mvar f -- | 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 let take = MV.takeMVar mvar replace = MV.putMVar mvar mod x = do x' <- f x MV.putMVar mvar $! x' 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 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 lrucache-1.2.0.1/src/Data/Cache/LRU/Internal.hs0000644000000000000000000003227307346545000017054 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} -- | 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 Control.Applicative (Applicative, pure, liftA2) import Data.Traversable (Traversable(traverse), foldMapDefault) import Data.Foldable (Foldable(foldMap), traverse_) import Prelude hiding (last, lookup) import Data.Map ( Map ) import qualified Data.Map as Map #if MIN_VERSION_containers(0,5,0) import qualified Data.Map.Strict as MapStrict #endif import Data.Data (Data) import Data.Typeable (Typeable) import Data.Functor.Contravariant (Contravariant((>$))) -- | 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 :: !(Maybe Integer) -- ^ the maximum size of the LRU cache , content :: !(Map key (LinkedVal key val)) -- ^ the backing 'Map' } deriving (Eq, Data, Typeable, Functor) instance (Ord key) => Traversable (LRU key) where traverse f l = fmap (fromList $ maxSize l) . go $ toList l where go [] = pure [] go (x:xs) = liftA2 (:) (g x) (go xs) g (a, b) = fmap ((,) a) $ f b instance (Ord key) => Foldable (LRU key) where foldMap = foldMapDefault instance (Ord key, Show key, Show val) => Show (LRU key val) where show lru = "fromList " ++ show (toList lru) -- | 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 } deriving (Eq, Data, Typeable, Functor, Foldable, Traversable) -- | 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 Integer -- ^ the optional maximum size of the LRU -> LRU key val 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 => Maybe Integer -- ^ the optional 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 -- | Traverse the (key, value) pairs of the LRU, in a read-only -- way. This is a 'Fold' in the sense used by the -- . It must be -- read-only because alterations could break the underlying 'Map' -- structure. pairs :: (Ord key, Applicative f, Contravariant f) => ((key, val) -> f (key, val)) -> LRU key val -> f (LRU key val) pairs f l = () >$ (traverse_ f $ toList l) -- | Traverse the keys of the LRU, in a read-only -- way. This is a 'Fold' in the sense used by the -- . It must be -- read-only because alterations could break the underlying 'Map' -- structure. keys :: (Ord key, Applicative f, Contravariant f) => (key -> f key) -> LRU key val -> f (LRU key val) keys f l = () >$ (traverse_ (f . fst) $ toList l) -- | 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 = fst (insertInforming key val lru) -- | Same as 'insert', but also returns element which was dropped from -- cache, if any. insertInforming :: Ord key => key -> val -> LRU key val -> (LRU key val, Maybe (key, val)) insertInforming key val lru = maybe emptyCase nonEmptyCase $ first lru where contents = content lru full = maybe False (fromIntegral (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', Nothing) where fl = Just key lv = Link val Nothing Nothing m' = Map.insert key lv contents nonEmptyCase firstKey = if present then (hitSet, Nothing) 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' = 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'', Just (lastKey, value lastLV)) else (lru', Nothing) where -- add a new first item firstLV' = Link val Nothing $ Just firstKey contents' = Map.insert key firstLV' . 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' contents'' = Map.delete lastKey contents' lru'' = delete' lastKey lru' contents'' lastLV -- | 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 the value -- removed if the key was present. delete :: Ord key => key -> LRU key val -> (LRU key val, Maybe val) delete key lru = maybe (lru, Nothing) delete'' mLV where 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 -- | 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 = adjust' (\v -> v { prev = Just key}) firstKey . 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 = 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 = adjust' (\v -> v { next = Just nextKey }) prevKey . adjust' (\v -> v { prev = Just prevKey }) nextKey . adjFront $ conts -- | An internal function used by 'insert' (when the cache is full) -- and 'delete'. This function has strict requirements on its -- arguments in order to work properly. -- -- As this is intended to be an internal function, the arguments were -- chosen to avoid repeated computation, rather than for simplicity of -- calling this function. delete' :: Ord key => key -- ^ The key must be present in the provided 'LRU' -> LRU key val -- ^ This is the 'LRU' to modify -> Map key (LinkedVal key val) -- ^ this is the 'Map' from the -- previous argument, but with -- the key already removed from -- it. This isn't consistent -- yet, as it still might -- contain LinkedVals with -- pointers to the removed key. -> LinkedVal key val -- ^ This is the 'LinkedVal' that -- corresponds to the key in the passed -- in LRU. It is absent from the passed -- in map. -> LRU key val delete' key lru cont' lv = if Map.null cont' then deleteOnly else deleteOne 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 = 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 = adjust' (\v -> v { next = Nothing}) pKey cont' -- delete an item in the middle deleteMid = lru { content = contMid } contMid = adjust' (\v -> v { next = next lv }) pKey . adjust' (\v -> v { prev = prev lv }) nKey $ cont' -- | Internal function. This is very similar to 'Map.adjust', with -- two major differences. First, it's strict in the application of -- the function, which is a huge win when working with this structure. -- -- Second, it requires that the key be present in order to work. If -- the key isn't present, 'undefined' will be inserted into the 'Map', -- which will cause problems later. adjust' :: Ord k => (a -> a) -> k -> Map k a -> Map k a #if MIN_VERSION_containers(0,5,0) adjust' = MapStrict.adjust #else adjust' f k m = Map.insertWith' (\_ o -> f o) k (error "adjust' used wrongly") m #endif -- | 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. -- -- 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 = maybe True (fromIntegral (size lru) <=) (maxSize lru) && reverse orderedKeys == reverseKeys && size lru == length orderedKeys && all (`Map.member` contents) orderedKeys where contents = content lru orderedKeys = walk next . first $ lru walk _ Nothing = [] walk f (Just k) = let Just k' = Map.lookup k contents in k : (walk f . f $ k') reverseKeys = walk prev . last $ lru