├── cabal.project ├── Setup.hs ├── stack.yaml ├── .gitignore ├── test ├── Spec.hs └── Data │ ├── LruCacheSpec.hs │ └── LruCache │ ├── IOSpec.hs │ └── SpecHelper.hs ├── stack.yaml.lock ├── CHANGELOG.md ├── README.md ├── src └── Data │ ├── LruCache │ ├── Internal.hs │ ├── IO.hs │ └── IO │ │ └── Finalizer.hs │ └── LruCache.hs ├── LICENSE ├── lrucaching.cabal └── .travis.yml /cabal.project: -------------------------------------------------------------------------------- 1 | packages: ./. -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2024-01-10 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | flags: {} 6 | extra-package-dbs: [] 7 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | /.stack-work/ 3 | /dist-newstyle/ 4 | /cabal.sandbox.config 5 | /.cabal-sandbox/ 6 | /dist/ 7 | cabal.project.local 8 | .ghc.environment.* 9 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Hspec 4 | import qualified Data.LruCacheSpec as LruCacheSpec 5 | import qualified Data.LruCache.IOSpec as IOSpec 6 | 7 | main :: IO () 8 | main = 9 | hspec $ do 10 | describe "Data.LruCache" LruCacheSpec.spec 11 | describe "Data.LruCache.IO" IOSpec.spec 12 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | sha256: fb194ea04d72ba9680dc67ce413af055913d48fee1e7e2433e2d36441c19e094 10 | size: 556051 11 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2024/1/10.yaml 12 | original: nightly-2024-01-10 13 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 0.3.3 2 | ---- 3 | * Drop support for GHC 7.8 4 | * Bump QuickCheck upper bound 5 | 6 | 0.3.2 7 | ---- 8 | * Bump QuickCheck upper bound 9 | 10 | 0.3.1 11 | ----- 12 | * Allow vector == 0.12.* 13 | * Do not use hspec-discover. This allows building the tests using 14 | `cabal new-build`. 15 | 16 | 0.3.0 17 | ----- 18 | * Add `Data.LruCache.IO.Finalizer` for automatically running finalizer 19 | when evicting cache entrvies. 20 | * Rename `newStripedHandle` to `newStripedLruHandle` 21 | 22 | 0.2.1 23 | ----- 24 | * Fix build with GHC 7.8 25 | 26 | 0.2.0 27 | ---- 28 | * Don’t clear cache on clock overflow. This means that elements are 29 | never evicted without notifying the user via insertView. 30 | 31 | 0.1.0 32 | ----- 33 | Initial release. 34 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # lrucaching 2 | 3 | [![Build Status](https://travis-ci.org/cocreature/lrucaching.svg?branch=master)](https://travis-ci.org/cocreature/lrucaching) 4 | [![Hackage](https://img.shields.io/hackage/v/lrucaching.svg)](https://hackage.haskell.org/package/lrucaching) 5 | 6 | An implementation of lrucaches based on a 7 | [blogpost](https://jaspervdj.be/posts/2015-02-24-lru-cache.html) by 8 | Jasper Van der Jeugt. 9 | 10 | This package has no relation to 11 | [lrucache](https://hackage.haskell.org/package/lrucache). I created it 12 | because there were bugs in `lrucache` and the maintainer was not 13 | responding to issues. 14 | 15 | 16 | ## Usage 17 | 18 | The easiest way to use this library is to use `Data.LruCache.IO`. This wraps the 19 | cache in a `Data.IORef`, a mutable varible in the `IO` monad. 20 | 21 | e.g. To create a `1000`-item cache, keyed by `Integer`, storing `String`: 22 | 23 | ```haskell 24 | import qualified Data.LruCache.IO as LRU 25 | 26 | newCache :: IO (LRU.LruHandle Integer String) 27 | newCache = LRU.newLruHandle 1000 28 | 29 | cachedLookup cache key = LRU.cached cache key $ 30 | -- insert some something expensive 31 | return $ show key 32 | 33 | main :: IO () 34 | main = do 35 | cache <- newCache 36 | cachedLookup cache 123 >>= putStrLn 37 | ``` 38 | -------------------------------------------------------------------------------- /src/Data/LruCache/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | {-| 5 | Module : Data.LruCache.Internal 6 | Copyright : (c) Moritz Kiefer, 2016 7 | (c) Jasper Van der Jeugt, 2015 8 | License : BSD3 9 | Maintainer : moritz.kiefer@purelyfunctional.org 10 | 11 | This module contains internal datastructures. 12 | No guarantees are made as to the stability of this module 13 | and violating invariants can result in unspecified behavior. 14 | -} 15 | module Data.LruCache.Internal 16 | ( LruCache(..) 17 | , Priority 18 | ) where 19 | 20 | import Control.DeepSeq (NFData,rnf) 21 | import Data.Int 22 | import qualified Data.HashPSQ as HashPSQ 23 | import Data.Foldable (Foldable) 24 | import Data.Traversable (Traversable) 25 | 26 | -- | Logical time at which an element was last accessed. 27 | type Priority = Int64 28 | 29 | -- | LRU cache based on hashing. 30 | data LruCache k v = LruCache 31 | { lruCapacity :: !Int -- ^ The maximum number of elements in the queue 32 | , lruSize :: !Int -- ^ The current number of elements in the queue 33 | , lruTick :: !Priority -- ^ The next logical time 34 | , lruQueue :: !(HashPSQ.HashPSQ k Priority v) -- ^ Underlying priority queue 35 | } 36 | deriving (Eq,Show,Functor,Foldable,Traversable) 37 | 38 | instance (NFData k, NFData v) => NFData (LruCache k v) where 39 | rnf (LruCache cap size tick queue) = 40 | rnf cap `seq` rnf size `seq` rnf tick `seq` rnf queue 41 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Moritz Kiefer (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Moritz Kiefer nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /test/Data/LruCacheSpec.hs: -------------------------------------------------------------------------------- 1 | module Data.LruCacheSpec 2 | (spec 3 | ) where 4 | 5 | import Data.Hashable 6 | import Data.Maybe 7 | import Prelude hiding (lookup) 8 | import Test.Hspec 9 | import Test.QuickCheck 10 | 11 | import Data.LruCache 12 | import Data.LruCache.SpecHelper 13 | 14 | spec :: Spec 15 | spec = 16 | do describe "insertView" $ do 17 | it "evicts elements that were previously there" $ do 18 | property (evictExisted :: LruCache SmallInt Int -> SmallInt -> Int -> Bool) 19 | it "removes evicted elements" $ do 20 | property (evictRemoved :: LruCache SmallInt Int -> SmallInt -> Int -> Bool) 21 | describe "insert" $ do 22 | it "inserts elements" $ do 23 | property (insertExists :: LruCache SmallInt Int -> SmallInt -> Int -> Property) 24 | 25 | 26 | insertExists :: 27 | (Hashable k, Ord k, Eq v, Show v) => 28 | LruCache k v -> 29 | k -> 30 | v -> 31 | Property 32 | insertExists cache k v = 33 | let cache' = insert k v cache 34 | in fmap fst (lookup k cache') === Just v 35 | 36 | evictExisted :: (Hashable k, Ord k, Eq v) => LruCache k v -> k -> v -> Bool 37 | evictExisted cache k v = 38 | let evicted = fst (insertView k v cache) 39 | in case evicted of 40 | Nothing -> True 41 | Just (k', v') -> 42 | case lookup k' cache of 43 | Nothing -> False 44 | Just (v'', _) -> v' == v'' 45 | 46 | evictRemoved :: (Hashable k, Ord k) => LruCache k v -> k -> v -> Bool 47 | evictRemoved cache k v = 48 | let (evicted, cache') = insertView k v cache 49 | in case evicted of 50 | Nothing -> True 51 | Just (k',_) -> isNothing (lookup k' cache') -------------------------------------------------------------------------------- /test/Data/LruCache/IOSpec.hs: -------------------------------------------------------------------------------- 1 | module Data.LruCache.IOSpec 2 | (spec 3 | ) where 4 | 5 | import Control.Monad (foldM_) 6 | import Control.Monad.IO.Class 7 | import Data.IORef 8 | import Data.Set (Set) 9 | import qualified Data.Set as Set 10 | import Test.Hspec 11 | import qualified Test.QuickCheck as QC 12 | import qualified Test.QuickCheck.Monadic as QC 13 | 14 | import Data.LruCache.IO 15 | import Data.LruCache.SpecHelper 16 | 17 | spec :: Spec 18 | spec = 19 | do describe "cached" $ do 20 | it "evicts leasts recently used elements" $ do 21 | QC.property historic 22 | 23 | -- | Tests if elements not evicted have been recently accessed. 24 | historic :: 25 | SmallInt -> -- ^ Capacity 26 | [(SmallInt, String)] -> -- ^ Key-value pairs 27 | QC.Property -- ^ Property 28 | historic (SmallInt capacity) pairs = QC.monadicIO $ 29 | do h <- liftIO $ newLruHandle capacity 30 | foldM_ (step h) [] pairs 31 | where 32 | step h history (k, v) = do 33 | wasInCacheRef <- liftIO $ newIORef True 34 | _ <- liftIO $ cached h k $ 35 | do writeIORef wasInCacheRef False 36 | return v 37 | wasInCache <- liftIO $ readIORef wasInCacheRef 38 | let recentKeys = nMostRecentKeys capacity Set.empty history 39 | QC.assert (Set.member k recentKeys == wasInCache) 40 | return ((k, v) : history) 41 | 42 | nMostRecentKeys :: Ord k => Int -> Set k -> [(k, v)] -> Set k 43 | nMostRecentKeys _ keys [] = keys 44 | nMostRecentKeys n keys ((k, _) : history) 45 | | Set.size keys >= n = keys 46 | | otherwise = 47 | nMostRecentKeys n (Set.insert k keys) history 48 | -------------------------------------------------------------------------------- /test/Data/LruCache/SpecHelper.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | {-| 5 | Module : Data.LruCache.SpecHelper 6 | Copyright : (c) Moritz Kiefer, 2016 7 | (c) Jasper Van der Jeugt, 2015 8 | License : BSD3 9 | Maintainer : moritz.kiefer@purelyfunctional.org 10 | -} 11 | module Data.LruCache.SpecHelper where 12 | 13 | import Control.Applicative ((<$>),(<*>)) 14 | import Data.Foldable (foldl') 15 | import Data.Hashable 16 | import Prelude hiding (lookup) 17 | import qualified Test.QuickCheck as QC 18 | 19 | import Data.LruCache 20 | 21 | data CacheAction k v 22 | = InsertAction k v 23 | | LookupAction k 24 | deriving (Show,Eq,Ord) 25 | 26 | instance (QC.Arbitrary k, QC.Arbitrary v) => 27 | QC.Arbitrary (CacheAction k v) where 28 | arbitrary = QC.oneof 29 | [ InsertAction <$> QC.arbitrary <*> QC.arbitrary 30 | , LookupAction <$> QC.arbitrary 31 | ] 32 | 33 | applyCacheAction :: 34 | (Hashable k, Ord k) => 35 | CacheAction k v -> 36 | LruCache k v -> 37 | LruCache k v 38 | applyCacheAction (InsertAction k v) c = 39 | insert k v c 40 | applyCacheAction (LookupAction k) c = 41 | case lookup k c of 42 | Nothing -> c 43 | Just (_, c') -> c' 44 | 45 | instance forall k v. 46 | (QC.Arbitrary k, QC.Arbitrary v, Hashable k, Ord k) => 47 | QC.Arbitrary (LruCache k v) where 48 | arbitrary = do 49 | capacity <- QC.choose (1, 50) 50 | (actions :: [CacheAction k v]) <- QC.arbitrary 51 | let !cache = empty capacity 52 | return $! foldl' (\c a -> applyCacheAction a c) cache actions 53 | 54 | newtype SmallInt = SmallInt Int 55 | deriving (Eq, Ord, Show) 56 | 57 | instance QC.Arbitrary SmallInt where 58 | arbitrary = SmallInt <$> QC.choose (1, 100) 59 | 60 | instance Hashable SmallInt where 61 | hashWithSalt salt (SmallInt x) = (salt + x) `mod` 10 62 | -------------------------------------------------------------------------------- /lrucaching.cabal: -------------------------------------------------------------------------------- 1 | name: lrucaching 2 | version: 0.3.3 3 | synopsis: LRU cache 4 | description: Please see README.md 5 | homepage: https://github.com/cocreature/lrucaching#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Moritz Kiefer 9 | maintainer: moritz.kiefer@purelyfunctional.org 10 | copyright: 2016 11 | category: Unknown 12 | build-type: Simple 13 | extra-source-files: CHANGELOG.md 14 | README.md 15 | cabal-version: >=1.10 16 | tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.5, GHC == 8.8.1 17 | 18 | library 19 | hs-source-dirs: src 20 | exposed-modules: Data.LruCache 21 | Data.LruCache.IO 22 | Data.LruCache.IO.Finalizer 23 | Data.LruCache.Internal 24 | build-depends: base >= 4.8 && < 5 25 | , base-compat >= 0.9 && < 0.14 26 | , deepseq >= 1.4 && < 1.6 27 | , hashable >= 1.2 && < 1.5 28 | , psqueues >= 0.2 && < 0.3 29 | , vector >= 0.11 && < 0.14 30 | ghc-options: -Wall 31 | default-language: Haskell2010 32 | 33 | test-suite lru-test 34 | type: exitcode-stdio-1.0 35 | hs-source-dirs: test 36 | main-is: Spec.hs 37 | other-modules: Data.LruCacheSpec 38 | Data.LruCache.IOSpec 39 | Data.LruCache.SpecHelper 40 | build-depends: base 41 | , containers >= 0.5 && < 0.8 42 | , deepseq 43 | , hashable 44 | , hspec >= 2.2 && < 2.12 45 | , lrucaching 46 | , QuickCheck >= 2.8 && < 2.15 47 | , transformers >= 0.4 && < 0.7 48 | default-language: Haskell2010 49 | 50 | source-repository head 51 | type: git 52 | location: https://github.com/cocreature/lrucaching 53 | -------------------------------------------------------------------------------- /src/Data/LruCache/IO.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Data.LruCache.IO 3 | Copyright : (c) Moritz Kiefer, 2016 4 | (c) Jasper Van der Jeugt, 2015 5 | License : BSD3 6 | Maintainer : moritz.kiefer@purelyfunctional.org 7 | Convenience module for the common case of caching results of IO actions. 8 | See 'Data.LruCache.IO.Finalizer' if you want to run finalizers 9 | automatically when cache entries are evicted 10 | -} 11 | module Data.LruCache.IO 12 | ( LruHandle(..) 13 | , cached 14 | , newLruHandle 15 | , StripedLruHandle(..) 16 | , stripedCached 17 | , newStripedLruHandle 18 | ) where 19 | 20 | import Control.Applicative ((<$>)) 21 | import Data.Hashable (Hashable, hash) 22 | import Data.IORef (IORef, atomicModifyIORef', newIORef) 23 | import Data.Vector (Vector) 24 | import qualified Data.Vector as Vector 25 | import Prelude hiding (lookup) 26 | 27 | import Data.LruCache 28 | 29 | -- | Store a LRU cache in an 'IORef to be able to conveniently update it. 30 | newtype LruHandle k v = LruHandle (IORef (LruCache k v)) 31 | 32 | -- | Create a new LRU cache of the given size. 33 | newLruHandle :: Int -> IO (LruHandle k v) 34 | newLruHandle capacity = LruHandle <$> newIORef (empty capacity) 35 | 36 | -- | Return the cached result of the action or, in the case of a cache 37 | -- miss, execute the action and insert it in the cache. 38 | cached :: (Hashable k, Ord k) => LruHandle k v -> k -> IO v -> IO v 39 | cached (LruHandle ref) k io = 40 | do lookupRes <- atomicModifyIORef' ref $ \c -> 41 | case lookup k c of 42 | Nothing -> (c, Nothing) 43 | Just (v, c') -> (c', Just v) 44 | case lookupRes of 45 | Just v -> return v 46 | Nothing -> 47 | do v <- io 48 | atomicModifyIORef' ref $ \c -> (insert k v c, ()) 49 | return v 50 | 51 | -- | Using a stripe of multiple handles can improve the performance in 52 | -- the case of concurrent accesses since several handles can be 53 | -- accessed in parallel. 54 | newtype StripedLruHandle k v = StripedLruHandle (Vector (LruHandle k v)) 55 | 56 | -- | Create a new 'StripedHandle' with the given number of stripes and 57 | -- the given capacity for each stripe. 58 | newStripedLruHandle :: Int -> Int -> IO (StripedLruHandle k v) 59 | newStripedLruHandle numStripes capacityPerStripe = 60 | StripedLruHandle <$> Vector.replicateM numStripes (newLruHandle capacityPerStripe) 61 | 62 | -- | Striped version of 'cached'. 63 | stripedCached :: 64 | (Hashable k, Ord k) => 65 | StripedLruHandle k v -> 66 | k -> 67 | IO v -> 68 | IO v 69 | stripedCached (StripedLruHandle v) k = 70 | cached (v Vector.! idx) k 71 | where 72 | idx = hash k `mod` Vector.length v -------------------------------------------------------------------------------- /src/Data/LruCache/IO/Finalizer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-| 3 | Module : Data.LruCache.IO.Finalizer 4 | Copyright : (c) Moritz Kiefer, 2016 5 | (c) Jasper Van der Jeugt, 2015 6 | License : BSD3 7 | Maintainer : moritz.kiefer@purelyfunctional.org 8 | Convenience module for the common case of caching results of IO actions 9 | when finalizers have to be run when cache entries are evicted. 10 | -} 11 | module Data.LruCache.IO.Finalizer 12 | ( LruHandle(..) 13 | , newLruHandle 14 | , cached 15 | , StripedLruHandle(..) 16 | , newStripedLruHandle 17 | , stripedCached 18 | ) where 19 | 20 | import Control.Applicative ((<$>)) 21 | import Data.Foldable (traverse_) 22 | import Data.Hashable (Hashable, hash) 23 | import Data.IORef (IORef, atomicModifyIORef', newIORef) 24 | import Data.Tuple (swap) 25 | import Data.Vector (Vector) 26 | import qualified Data.Vector as Vector 27 | import Prelude hiding (lookup) 28 | 29 | import Data.LruCache 30 | 31 | -- | Store a LRU cache in an 'IORef to be able to conveniently update it. 32 | newtype LruHandle k v = LruHandle (IORef (LruCache k (v, v -> IO ()))) 33 | 34 | -- | Create a new LRU cache of the given size. 35 | newLruHandle :: Int -> IO (LruHandle k v) 36 | newLruHandle capacity = LruHandle <$> newIORef (empty capacity) 37 | 38 | -- | Return the cached result of the action or, in the case of a cache 39 | -- miss, execute the action and insert it in the cache. 40 | cached :: 41 | (Hashable k, Ord k) => 42 | LruHandle k v -> 43 | k -> 44 | IO v -> 45 | (v -> IO ()) {- ^ finalizer -} -> 46 | IO v 47 | cached (LruHandle ref) k io finalizer = 48 | do lookupRes <- atomicModifyIORef' ref $ \c -> 49 | case lookup k c of 50 | Nothing -> (c, Nothing) 51 | Just (v, c') -> (c', Just v) 52 | case lookupRes of 53 | Just (!v,_) -> return v 54 | Nothing -> 55 | do v <- io 56 | evicted <- atomicModifyIORef' ref $ \c -> 57 | swap (insertView k (v,finalizer) c) 58 | traverse_ (\(_,(v',finalize')) -> finalize' v') evicted 59 | return v 60 | 61 | -- | Using a stripe of multiple handles can improve the performance in 62 | -- the case of concurrent accesses since several handles can be 63 | -- accessed in parallel. 64 | newtype StripedLruHandle k v = StripedLruHandle (Vector (LruHandle k v)) 65 | 66 | -- | Create a new 'StripedHandle' with the given number of stripes and 67 | -- the given capacity for each stripe. 68 | newStripedLruHandle :: Int -> Int -> IO (StripedLruHandle k v) 69 | newStripedLruHandle numStripes capacityPerStripe = 70 | StripedLruHandle <$> Vector.replicateM numStripes (newLruHandle capacityPerStripe) 71 | 72 | -- | Striped version of 'cached'. 73 | stripedCached :: 74 | (Hashable k, Ord k) => 75 | StripedLruHandle k v -> 76 | k -> 77 | IO v -> 78 | (v -> IO ()) {- ^ finalizer -} -> 79 | IO v 80 | stripedCached (StripedLruHandle v) k = 81 | cached (v Vector.! idx) k 82 | where 83 | idx = hash k `mod` Vector.length v -------------------------------------------------------------------------------- /src/Data/LruCache.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveTraversable #-} 5 | {-| 6 | Module : Data.LruCache 7 | Copyright : (c) Moritz Kiefer, 2016 8 | (c) Jasper Van der Jeugt, 2015 9 | License : BSD3 10 | Maintainer : moritz.kiefer@purelyfunctional.org 11 | Pure API to an LRU cache. 12 | -} 13 | module Data.LruCache 14 | ( LruCache 15 | , empty 16 | , insert 17 | , insertView 18 | , lookup 19 | ) where 20 | 21 | import qualified Data.HashPSQ as HashPSQ 22 | import Data.Hashable (Hashable) 23 | import Data.List.Compat (sortOn) 24 | import Data.Maybe (isNothing) 25 | import Prelude hiding (lookup) 26 | 27 | import Data.LruCache.Internal 28 | 29 | -- | Create an empty 'LruCache' of the given size. 30 | empty :: Int -> LruCache k v 31 | empty capacity 32 | | capacity < 1 = error "LruCache.empty: capacity < 1" 33 | | otherwise = 34 | LruCache 35 | { lruCapacity = capacity 36 | , lruSize = 0 37 | , lruTick = 0 38 | , lruQueue = HashPSQ.empty 39 | } 40 | 41 | -- | Restore 'LruCache' invariants returning the evicted element if any. 42 | trim' :: (Hashable k, Ord k) => LruCache k v -> (Maybe (k, v), LruCache k v) 43 | trim' c 44 | | lruTick c == maxBound = 45 | -- It is not physically possible to have that many elements but 46 | -- the clock could potentially get here. We then simply decrease 47 | -- all priorities in O(nlogn) and start over. 48 | let queue' = HashPSQ.fromList . compress . HashPSQ.toList $ lruQueue c 49 | in trim' $! 50 | c { lruTick = fromIntegral (lruSize c) 51 | , lruQueue = queue' 52 | } 53 | | lruSize c > lruCapacity c = 54 | let Just (k, _, v) = HashPSQ.findMin (lruQueue c) 55 | c' = c { lruSize = lruSize c - 1 56 | , lruQueue = HashPSQ.deleteMin (lruQueue c) 57 | } 58 | in seq c' (Just (k, v), c') 59 | | otherwise = (Nothing, c) 60 | 61 | compress :: [(k,Priority,v)] -> [(k,Priority,v)] 62 | compress q = 63 | let sortedQ = sortOn (\(_,p,_) -> p) q 64 | in zipWith (\(k,_,v) p -> (k,p,v)) sortedQ [1..] 65 | 66 | -- TODO benchmark to see if this is actually faster than snd . trim' 67 | -- | Restore 'LruCache' invariants. For performance reasons this is 68 | -- not @snd . trim'@. 69 | trim :: (Hashable k, Ord k) => LruCache k v -> LruCache k v 70 | trim c 71 | | lruTick c == maxBound = empty (lruCapacity c) 72 | | lruSize c > lruCapacity c = 73 | c { lruSize = lruSize c - 1 74 | , lruQueue = HashPSQ.deleteMin (lruQueue c) 75 | } 76 | | otherwise = c 77 | 78 | -- | Insert an element into the 'LruCache'. 79 | insert :: (Hashable k, Ord k) => k -> v -> LruCache k v -> LruCache k v 80 | insert key val c = 81 | trim $! 82 | let (mbOldVal,queue) = HashPSQ.insertView key (lruTick c) val (lruQueue c) 83 | in c { lruSize = if isNothing mbOldVal 84 | then lruSize c + 1 85 | else lruSize c 86 | , lruTick = lruTick c + 1 87 | , lruQueue = queue 88 | } 89 | 90 | -- | Insert an element into the 'LruCache' returning the evicted 91 | -- element if any. 92 | -- 93 | -- When the logical clock reaches its maximum value and all values are 94 | -- evicted 'Nothing' is returned. 95 | insertView :: (Hashable k, Ord k) => k -> v -> LruCache k v -> (Maybe (k, v), LruCache k v) 96 | insertView key val cache = 97 | let (mbOldVal,queue) = 98 | HashPSQ.insertView key (lruTick cache) val (lruQueue cache) 99 | in trim' $! cache 100 | { lruSize = if isNothing mbOldVal 101 | then lruSize cache + 1 102 | else lruSize cache 103 | , lruTick = lruTick cache + 1 104 | , lruQueue = queue 105 | } 106 | 107 | -- | Lookup an element in an 'LruCache' and mark it as the least 108 | -- recently accessed. 109 | lookup :: (Hashable k, Ord k) => k -> LruCache k v -> Maybe (v, LruCache k v) 110 | lookup k c = 111 | case HashPSQ.alter lookupAndBump k (lruQueue c) of 112 | (Nothing, _) -> Nothing 113 | (Just x, q) -> 114 | let !c' = trim $ c {lruTick = lruTick c + 1, lruQueue = q} 115 | in Just (x, c') 116 | where 117 | lookupAndBump Nothing = (Nothing, Nothing) 118 | lookupAndBump (Just (_, x)) = (Just x, Just ((lruTick c), x)) 119 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This Travis job script has been generated by a script via 2 | # 3 | # haskell-ci 'lrucaching.cabal' 4 | # 5 | # For more information, see https://github.com/haskell-CI/haskell-ci 6 | # 7 | # version: 0.3.20190814 8 | # 9 | language: c 10 | dist: xenial 11 | sudo: required 12 | git: 13 | # whether to recursively clone submodules 14 | submodules: false 15 | cache: 16 | directories: 17 | - $HOME/.cabal/packages 18 | - $HOME/.cabal/store 19 | before_cache: 20 | - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log 21 | # remove files that are regenerated by 'cabal update' 22 | - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* 23 | - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json 24 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache 25 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar 26 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx 27 | - rm -rfv $CABALHOME/packages/head.hackage 28 | matrix: 29 | include: 30 | - compiler: ghc-8.8.1 31 | addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}} 32 | - compiler: ghc-8.6.5 33 | addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-2.4"]}} 34 | - compiler: ghc-8.4.3 35 | addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.3","cabal-install-2.4"]}} 36 | - compiler: ghc-8.2.2 37 | addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-2.4"]}} 38 | - compiler: ghc-8.0.2 39 | addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-2.4"]}} 40 | - compiler: ghc-7.10.3 41 | addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.10.3","cabal-install-2.4"]}} 42 | before_install: 43 | - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') 44 | - WITHCOMPILER="-w $HC" 45 | - HCPKG="$HC-pkg" 46 | - unset CC 47 | - CABAL=/opt/ghc/bin/cabal 48 | - CABALHOME=$HOME/.cabal 49 | - export PATH="$CABALHOME/bin:$PATH" 50 | - TOP=$(pwd) 51 | - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')" 52 | - echo $HCNUMVER 53 | - CABAL="$CABAL -vnormal+nowrap+markoutput" 54 | - set -o pipefail 55 | - | 56 | echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk 57 | echo 'BEGIN { state = "output"; }' >> .colorful.awk 58 | echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk 59 | echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk 60 | echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk 61 | echo ' if (state == "cabal") {' >> .colorful.awk 62 | echo ' print blue($0)' >> .colorful.awk 63 | echo ' } else {' >> .colorful.awk 64 | echo ' print $0' >> .colorful.awk 65 | echo ' }' >> .colorful.awk 66 | echo '}' >> .colorful.awk 67 | - cat .colorful.awk 68 | - | 69 | color_cabal_output () { 70 | awk -f $TOP/.colorful.awk 71 | } 72 | - echo text | color_cabal_output 73 | install: 74 | - ${CABAL} --version 75 | - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" 76 | - TEST=--enable-tests 77 | - BENCH=--enable-benchmarks 78 | - HEADHACKAGE=false 79 | - rm -f $CABALHOME/config 80 | - | 81 | echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config 82 | echo "remote-build-reporting: anonymous" >> $CABALHOME/config 83 | echo "write-ghc-environment-files: always" >> $CABALHOME/config 84 | echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config 85 | echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config 86 | echo "world-file: $CABALHOME/world" >> $CABALHOME/config 87 | echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config 88 | echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config 89 | echo "installdir: $CABALHOME/bin" >> $CABALHOME/config 90 | echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config 91 | echo "store-dir: $CABALHOME/store" >> $CABALHOME/config 92 | echo "install-dirs user" >> $CABALHOME/config 93 | echo " prefix: $CABALHOME" >> $CABALHOME/config 94 | echo "repository hackage.haskell.org" >> $CABALHOME/config 95 | echo " url: http://hackage.haskell.org/" >> $CABALHOME/config 96 | - cat $CABALHOME/config 97 | - rm -fv cabal.project cabal.project.local cabal.project.freeze 98 | - travis_retry ${CABAL} v2-update -v 99 | # Generate cabal.project 100 | - rm -rf cabal.project cabal.project.local cabal.project.freeze 101 | - touch cabal.project 102 | - | 103 | echo "packages: ." >> cabal.project 104 | - | 105 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(lrucaching)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 106 | - cat cabal.project || true 107 | - cat cabal.project.local || true 108 | - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi 109 | - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output 110 | - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" 111 | - rm cabal.project.freeze 112 | - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all | color_cabal_output 113 | - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all | color_cabal_output 114 | script: 115 | - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) 116 | # Packaging... 117 | - ${CABAL} v2-sdist all | color_cabal_output 118 | # Unpacking... 119 | - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ 120 | - cd ${DISTDIR} || false 121 | - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \; 122 | - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \; 123 | - PKGDIR_lrucaching="$(find . -maxdepth 1 -type d -regex '.*/lrucaching-[0-9.]*')" 124 | # Generate cabal.project 125 | - rm -rf cabal.project cabal.project.local cabal.project.freeze 126 | - touch cabal.project 127 | - | 128 | echo "packages: ${PKGDIR_lrucaching}" >> cabal.project 129 | - | 130 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(lrucaching)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 131 | - cat cabal.project || true 132 | - cat cabal.project.local || true 133 | # Building... 134 | # this builds all libraries and executables (without tests/benchmarks) 135 | - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output 136 | # Building with tests and benchmarks... 137 | # build & run tests, build benchmarks 138 | - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output 139 | # Testing... 140 | - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output 141 | # cabal check... 142 | - (cd ${PKGDIR_lrucaching} && ${CABAL} -vnormal check) 143 | # haddock... 144 | - ${CABAL} v2-haddock $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output 145 | # Building without installed constraints for packages in global-db... 146 | - rm -f cabal.project.local 147 | - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output 148 | 149 | # REGENDATA ["lrucaching.cabal"] 150 | # EOF 151 | --------------------------------------------------------------------------------