lrucache-1.1.1.3/0000755000000000000000000000000012046311061011621 5ustar0000000000000000lrucache-1.1.1.3/LICENSE0000644000000000000000000000275512046311061012637 0ustar0000000000000000Copyright 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. lrucache-1.1.1.3/lrucache.cabal0000644000000000000000000000525212046311061014377 0ustar0000000000000000Name: lrucache Version: 1.1.1.3 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. . Version History: . 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. Additionally, 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 - First release Extra-source-files: LICENSE README MemTest.hs OpTest.hs Setup.hs Cabal-version: >=1.6 Source-repository this type: git location: https://github.com/chowells79/lrucache.git tag: 1.1.1.3 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.6 GHC-options: -Wall -O2 HS-source-dirs: src lrucache-1.1.1.3/MemTest.hs0000644000000000000000000000106412046311061013534 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.1.1.3/OpTest.hs0000644000000000000000000000773312046311061013405 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.1.1.3/README0000644000000000000000000000024412046311061012501 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.1.1.3/Setup.hs0000644000000000000000000000011012046311061013245 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMain lrucache-1.1.1.3/src/0000755000000000000000000000000012046311061012410 5ustar0000000000000000lrucache-1.1.1.3/src/Data/0000755000000000000000000000000012046311061013261 5ustar0000000000000000lrucache-1.1.1.3/src/Data/Cache/0000755000000000000000000000000012046311061014264 5ustar0000000000000000lrucache-1.1.1.3/src/Data/Cache/LRU.hs0000644000000000000000000000114112046311061015257 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 , maxSize , insert , lookup , delete , pop , size ) where import Prelude hiding ( lookup ) import Data.Cache.LRU.Internal lrucache-1.1.1.3/src/Data/Cache/LRU/0000755000000000000000000000000012046311061014726 5ustar0000000000000000lrucache-1.1.1.3/src/Data/Cache/LRU/Internal.hs0000644000000000000000000002671212046311061017046 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE CPP #-} -- | 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.Map ( Map ) import qualified Data.Map as Map #if MIN_VERSION_containers(0,5,0) import qualified Data.Map.Strict as MapStrict #endif -- | 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 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 } -- | 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 -- | 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 = 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' 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' = 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' . 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 = 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 lrucache-1.1.1.3/src/Data/Cache/LRU/IO.hs0000644000000000000000000000170612046311061015575 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.1.1.3/src/Data/Cache/LRU/IO/0000755000000000000000000000000012046311061015235 5ustar0000000000000000lrucache-1.1.1.3/src/Data/Cache/LRU/IO/Internal.hs0000644000000000000000000001005412046311061017345 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} -- | 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 -- | The opaque wrapper type newtype AtomicLRU key val = C (MVar (LRU key val)) -- | 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