diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Carl Howells 2010 +Copyright Carl Howells 2010-2015 All rights reserved. diff --git a/changes.txt b/changes.txt --- a/changes.txt +++ b/changes.txt @@ -1,3 +1,10 @@ +** 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 @@ -6,7 +13,7 @@ * Test for containers >= 0.5, rather than GHC >= 7.6 -** 1.1.1.2 +** 1.1.1.2 * Make actually compatible with containers 0.5 - fix strictness issue diff --git a/lrucache.cabal b/lrucache.cabal --- a/lrucache.cabal +++ b/lrucache.cabal @@ -1,11 +1,11 @@ Name: lrucache -Version: 1.1.1.4 +Version: 1.2.0.0 Synopsis: a simple, pure LRU cache License: BSD3 License-file: LICENSE Author: Carl Howells Maintainer: chowells79@gmail.com -Copyright: Carl Howells, 2010 +Copyright: Carl Howells, 2010-2015 Homepage: http://github.com/chowells79/lrucache Stability: Experimental Category: Data @@ -30,7 +30,7 @@ Source-repository this type: git location: https://github.com/chowells79/lrucache.git - tag: 1.1.1.4 + tag: 1.2.0.0 Library Exposed-modules: @@ -41,7 +41,9 @@ Build-depends: base >= 4 && < 5, - containers >= 0.2 && < 0.6 + containers >= 0.2 && < 0.6, + contravariant >= 0.5 && < 2 + GHC-options: -Wall -O2 diff --git a/src/Data/Cache/LRU.hs b/src/Data/Cache/LRU.hs --- a/src/Data/Cache/LRU.hs +++ b/src/Data/Cache/LRU.hs @@ -11,8 +11,11 @@ , newLRU , fromList , toList + , pairs + , keys , maxSize , insert + , insertInforming , lookup , delete , pop diff --git a/src/Data/Cache/LRU/IO/Internal.hs b/src/Data/Cache/LRU/IO/Internal.hs --- a/src/Data/Cache/LRU/IO/Internal.hs +++ b/src/Data/Cache/LRU/IO/Internal.hs @@ -1,4 +1,5 @@ {-# 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 @@ -22,8 +23,10 @@ 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)) +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. diff --git a/src/Data/Cache/LRU/Internal.hs b/src/Data/Cache/LRU/Internal.hs --- a/src/Data/Cache/LRU/Internal.hs +++ b/src/Data/Cache/LRU/Internal.hs @@ -1,5 +1,6 @@ {-# OPTIONS_HADDOCK not-home #-} -{-# LANGUAGE CPP #-} +{-# 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 @@ -11,39 +12,51 @@ -- "Data.Cache.LRU" instead. module Data.Cache.LRU.Internal where -import Prelude hiding ( last, lookup ) +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 + } 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) -instance Functor (LRU key) where - fmap f lru = lru { content = fmap (fmap f) . content $ 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 - -instance Functor (LinkedVal key) where - fmap f lv = lv { value = f . value $ lv } + } 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. @@ -72,6 +85,26 @@ 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 @@ -80,20 +113,27 @@ -- 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 +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' + 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 else add firstKey + 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 @@ -103,7 +143,8 @@ -- create a new LRU with a new first item, and -- conditionally dropping the last item - add firstKey = if full then lru'' else lru' + add firstKey = if full then (lru'', Just (key, val)) + else (lru', Nothing) where -- add a new first item firstLV' = Link val Nothing $ Just firstKey @@ -271,8 +312,8 @@ size lru == length orderedKeys && all (`Map.member` contents) 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 + 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