diff --git a/Data/Cache/LRU.hs b/Data/Cache/LRU.hs new file mode 100644 --- /dev/null +++ b/Data/Cache/LRU.hs @@ -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 diff --git a/Data/Cache/LRU/IO.hs b/Data/Cache/LRU/IO.hs new file mode 100644 --- /dev/null +++ b/Data/Cache/LRU/IO.hs @@ -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 diff --git a/Data/Cache/LRU/Internal.hs b/Data/Cache/LRU/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/Cache/LRU/Internal.hs @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/TestDriver.hs b/TestDriver.hs new file mode 100644 --- /dev/null +++ b/TestDriver.hs @@ -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 diff --git a/lrucache.cabal b/lrucache.cabal new file mode 100644 --- /dev/null +++ b/lrucache.cabal @@ -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