timemap 0.0.6 → 0.0.7
raw patch · 9 files changed
+467/−308 lines, 9 filesdep +timemapdep −tasty-hunitdep ~basePVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: timemap
Dependencies removed: tasty-hunit
Dependency ranges changed: base
API changes (from Hackage documentation)
+ Data.TimeMap: takeFromNow :: Hashable k => Eq k => NominalDiffTime -> TimeMap k a -> IO [(k, a)]
+ Data.TimeMap: takeSince :: Hashable k => Eq k => UTCTime -> TimeMap k a -> STM [(k, a)]
+ Data.TimeMap.Internal: delete :: (Ord k) => k -> MultiMap k a -> MultiMap k a
+ Data.TimeMap.Internal: elems :: (Hashable a, Eq a) => MultiMap k a -> HashSet a
+ Data.TimeMap.Internal: empty :: MultiMap k a
+ Data.TimeMap.Internal: insert :: (Ord k, Hashable a, Eq a) => k -> a -> MultiMap k a -> MultiMap k a
+ Data.TimeMap.Internal: lookup :: (Ord k) => k -> MultiMap k a -> HashSet a
+ Data.TimeMap.Internal: remove :: (Ord k, Hashable a, Eq a) => k -> a -> MultiMap k a -> MultiMap k a
+ Data.TimeMap.Internal: toList :: (Hashable a, Eq a) => MultiMap k a -> [(k, a)]
+ Data.TimeMap.Internal: type MultiMap k a = Map k (HashSet a)
+ Data.TimeMap.Multi: takeFromNow :: (Hashable k, Hashable a, Eq k, Eq a) => NominalDiffTime -> TimeMultiMap k a -> IO [(k, a)]
+ Data.TimeMap.Multi: takeSince :: (Hashable k, Hashable a, Eq k, Eq a) => UTCTime -> TimeMultiMap k a -> STM [(k, a)]
+ Data.TimeSet: takeFromNow :: (Hashable a, Eq a) => NominalDiffTime -> TimeSet a -> IO [a]
+ Data.TimeSet: takeSince :: (Hashable a, Eq a) => UTCTime -> TimeSet a -> STM [a]
- Data.TimeMap: adjust :: (Hashable k, Eq k) => (a -> a) -> k -> TimeMap k a -> IO ()
+ Data.TimeMap: adjust :: Hashable k => Eq k => (a -> a) -> k -> TimeMap k a -> IO ()
- Data.TimeMap: adjustWithTime :: (Hashable k, Eq k) => UTCTime -> (a -> a) -> k -> TimeMap k a -> STM ()
+ Data.TimeMap: adjustWithTime :: forall k a. Hashable k => Eq k => UTCTime -> (a -> a) -> k -> TimeMap k a -> STM ()
- Data.TimeMap: ageOf :: (Hashable k, Eq k) => k -> TimeMap k a -> IO (Maybe NominalDiffTime)
+ Data.TimeMap: ageOf :: Hashable k => Eq k => k -> TimeMap k a -> IO (Maybe NominalDiffTime)
- Data.TimeMap: delete :: (Hashable k, Eq k) => k -> TimeMap k a -> STM ()
+ Data.TimeMap: delete :: Hashable k => Eq k => k -> TimeMap k a -> STM ()
- Data.TimeMap: filter :: (Hashable k, Eq k) => (a -> Bool) -> TimeMap k a -> STM ()
+ Data.TimeMap: filter :: Hashable k => Eq k => (a -> Bool) -> TimeMap k a -> STM ()
- Data.TimeMap: filterFromNow :: (Hashable k, Eq k) => NominalDiffTime -> TimeMap k a -> IO ()
+ Data.TimeMap: filterFromNow :: Hashable k => Eq k => NominalDiffTime -> TimeMap k a -> IO ()
- Data.TimeMap: filterSince :: (Hashable k, Eq k) => UTCTime -> TimeMap k a -> STM ()
+ Data.TimeMap: filterSince :: Hashable k => Eq k => UTCTime -> TimeMap k a -> STM ()
- Data.TimeMap: filterWithKey :: (Hashable k, Eq k) => (k -> a -> Bool) -> TimeMap k a -> STM ()
+ Data.TimeMap: filterWithKey :: forall k a. Hashable k => Eq k => (k -> a -> Bool) -> TimeMap k a -> STM ()
- Data.TimeMap: insert :: (Hashable k, Eq k) => k -> a -> TimeMap k a -> IO ()
+ Data.TimeMap: insert :: Hashable k => Eq k => k -> a -> TimeMap k a -> IO ()
- Data.TimeMap: insertWithTime :: (Hashable k, Eq k) => UTCTime -> k -> a -> TimeMap k a -> STM ()
+ Data.TimeMap: insertWithTime :: forall k a. Hashable k => Eq k => UTCTime -> k -> a -> TimeMap k a -> STM ()
- Data.TimeMap: keys :: (Hashable k, Eq k) => TimeMap k a -> STM (HashSet k)
+ Data.TimeMap: keys :: Hashable k => Eq k => TimeMap k a -> STM (HashSet k)
- Data.TimeMap: lookup :: (Hashable k, Eq k) => k -> TimeMap k a -> STM (Maybe a)
+ Data.TimeMap: lookup :: Hashable k => Eq k => k -> TimeMap k a -> STM (Maybe a)
- Data.TimeMap: timeOf :: (Hashable k, Eq k) => k -> TimeMap k a -> STM (Maybe UTCTime)
+ Data.TimeMap: timeOf :: Hashable k => Eq k => k -> TimeMap k a -> STM (Maybe UTCTime)
- Data.TimeMap: toList :: (Hashable k, Eq k) => TimeMap k a -> STM [(k, a)]
+ Data.TimeMap: toList :: Hashable k => Eq k => TimeMap k a -> STM [(k, a)]
- Data.TimeMap: touch :: (Hashable k, Eq k) => k -> TimeMap k a -> IO ()
+ Data.TimeMap: touch :: Hashable k => Eq k => k -> TimeMap k a -> IO ()
- Data.TimeMap: update :: (Hashable k, Eq k) => (a -> Maybe a) -> k -> TimeMap k a -> IO ()
+ Data.TimeMap: update :: Hashable k => Eq k => (a -> Maybe a) -> k -> TimeMap k a -> IO ()
- Data.TimeMap: updateWithTime :: (Hashable k, Eq k) => UTCTime -> (a -> Maybe a) -> k -> TimeMap k a -> STM ()
+ Data.TimeMap: updateWithTime :: forall k a. Hashable k => Eq k => UTCTime -> (a -> Maybe a) -> k -> TimeMap k a -> STM ()
Files
- README.md +86/−0
- bench/Bench.hs +0/−77
- bench/Bench2.hs +0/−41
- bench1/Main.hs +77/−0
- bench2/Main.hs +41/−0
- src/Data/TimeMap.hs +135/−92
- src/Data/TimeMap/Multi.hs +8/−0
- src/Data/TimeSet.hs +8/−0
- timemap.cabal +112/−98
+ README.md view
@@ -0,0 +1,86 @@+timemap+=======++A mutable `Data.HashMap`-like structure, where each entity is implicitly indexed+by their last-modified time. Useful for keyed caches.++## Usage++```haskell+import qualified Data.TimeMap as TM+import Control.Concurrent.STM+++main :: IO ()+main = do+ -- create a new, empty reference+ mapRef <- atomically TM.newTimeMap++ -- insert a new key/value pair in the map. Note that+ -- `someKey` should implement `Hashable`. This also+ -- sets the creation time of the value to "now".+ TM.insert someKey 0 mapRef++ -- adjusts the value of `someKey` to `1`. Note that+ -- also resets the creation time of the value to "now".+ TM.adjust (+1) someKey mapRef++ -- wait a second+ threadDelay 1000000++ -- delete all values older than 1 second from now.+ atomically $ TM.filterFromNow 1 mapRef++ -- Will return `Nothing`+ atomically $ TM.lookup someKey mapRef++ return ()+```++## How it works++There are two internal maps for a `TimeMap k a`:++- a "time-indexed" map reference: `TVar (Map UTCTime (HashSet k))`+- a mutable map of values: `STMContainers.Map.Map k (UTCTime, a)`++### Insertion++Inserting a new value first performs a lookup on the hashtable to see if the key+already exists:++- If it doesn't, insert the current time and the element that into the mutable map.+ Then, insert the _key_ as the value, and the _time_ as the key into+ the time-indexed multimap.+- If it does, remove the entry from the time-indexed multimap for the old time, before+ doing the same thing as the first bullet.++### Lookups++This doesn't have to create new data, and thus doesn't need full `IO`. All it does is+lookup the key in the mutable map.++### Filtering++To filter out all entries older than some time, you have to use the `Data.Map.splitLookup`+function to split the time-indexed multimap into the entries you want to delete from+the main container, and the ones you want to keep. You simply `writeTVar` the map you want+to keep, but for the ones you want to delete, you need to get all the `elems` of+that map. Then, for every key that we need to delete, we delete it from the+main container. Suprisingly, this appears to operate in constant time, regardless of+the size of the map.++## How to run tests++```bash+stack test+```++## Benchmarks++```bash+stack bench --benchmark-arguments="--output profile.html"+```++You can also view the results on my box+[here](https://htmlpreview.github.io/?https://github.com/athanclark/timemap/blob/master/profile.html).
− bench/Bench.hs
@@ -1,77 +0,0 @@-{-# LANGUAGE- OverloadedStrings- #-}--module Main where---import Prelude hiding (lookup)-import Data.TimeMap (TimeMap)-import qualified Data.TimeMap as TM-import Criterion.Main-import Control.Concurrent.STM-import Control.Concurrent (threadDelay)---type Key = Integer-type Content = Integer--buildTM :: Integer -> IO (TimeMap Key Content)-buildTM top = do- x <- atomically TM.newTimeMap- mapM_ (\(k,v) -> TM.insert k v x) $ [0..top] `zip` [0..top]- return x--lookupTM :: Key -> TimeMap Key Content -> IO [Maybe Content]-lookupTM top x = atomically $ mapM (`TM.lookup` x) [0..top]--destroyTM :: Key -> TimeMap Key Content -> IO ()-destroyTM top x = atomically $ mapM_ (`TM.delete` x) [0..top]---main :: IO ()-main = do- indiv10 <- buildTM 50- indiv20 <- buildTM 50- indiv30 <- buildTM 50- indiv40 <- buildTM 50- indiv50 <- buildTM 50-- batch10 <- buildTM 10- batch20 <- buildTM 20- batch30 <- buildTM 30- batch40 <- buildTM 40- batch50 <- buildTM 50-- threadDelay 1000000-- defaultMain- [ bgroup "build"- [ bench "10" $ whnfIO (buildTM 10)- , bench "20" $ whnfIO (buildTM 20)- , bench "30" $ whnfIO (buildTM 30)- , bench "40" $ whnfIO (buildTM 40)- , bench "50" $ whnfIO (buildTM 50)- ]- , bgroup "lookup"- [ bench "10" $ whnfIO (lookupTM 10 indiv50)- , bench "20" $ whnfIO (lookupTM 20 indiv50)- , bench "30" $ whnfIO (lookupTM 30 indiv50)- , bench "40" $ whnfIO (lookupTM 40 indiv50)- , bench "50" $ whnfIO (lookupTM 50 indiv50)- ]- , bgroup "delete individual"- [ bench "10" $ whnfIO (destroyTM 10 indiv10)- , bench "20" $ whnfIO (destroyTM 20 indiv20)- , bench "30" $ whnfIO (destroyTM 30 indiv30)- , bench "40" $ whnfIO (destroyTM 40 indiv40)- , bench "50" $ whnfIO (destroyTM 50 indiv50)- ]- , bgroup "delete batch"- [ bench "10" $ whnfIO (TM.filterFromNow 1 batch10)- , bench "20" $ whnfIO (TM.filterFromNow 1 batch20)- , bench "30" $ whnfIO (TM.filterFromNow 1 batch30)- , bench "40" $ whnfIO (TM.filterFromNow 1 batch40)- , bench "50" $ whnfIO (TM.filterFromNow 1 batch50)- ]- ]
− bench/Bench2.hs
@@ -1,41 +0,0 @@-{-# LANGUAGE- OverloadedStrings- #-}--module Main where---import Prelude hiding (lookup)-import Data.TimeMap (TimeMap)-import qualified Data.TimeMap as TM-import Control.Concurrent.STM-import Control.Concurrent (threadDelay)---type Key = Integer-type Content = Integer--buildTM :: Integer -> IO (TimeMap Key Content)-buildTM top = do- x <- atomically TM.newTimeMap- mapM_ (\(k,v) -> TM.insert k v x) $ [0..top] `zip` [0..top]- return x--destroyTM :: [Integer] -> TimeMap Key Content -> IO ()-destroyTM ds x = atomically $ mapM_ (`TM.delete` x) ds---main :: IO ()-main = do- xs <- buildTM 5000-- threadDelay 500000-- fresh <- buildTM 5000-- destroyTM [0..5000] fresh-- threadDelay 500000-- TM.filterFromNow 1 xs-
+ bench1/Main.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE+ OverloadedStrings+ #-}++module Main where+++import Prelude hiding (lookup)+import Data.TimeMap (TimeMap)+import qualified Data.TimeMap as TM+import Criterion.Main+import Control.Concurrent.STM+import Control.Concurrent (threadDelay)+++type Key = Integer+type Content = Integer++buildTM :: Integer -> IO (TimeMap Key Content)+buildTM top = do+ x <- atomically TM.newTimeMap+ mapM_ (\(k,v) -> TM.insert k v x) $ [0..top] `zip` [0..top]+ return x++lookupTM :: Key -> TimeMap Key Content -> IO [Maybe Content]+lookupTM top x = atomically $ mapM (`TM.lookup` x) [0..top]++destroyTM :: Key -> TimeMap Key Content -> IO ()+destroyTM top x = atomically $ mapM_ (`TM.delete` x) [0..top]+++main :: IO ()+main = do+ indiv10 <- buildTM 50+ indiv20 <- buildTM 50+ indiv30 <- buildTM 50+ indiv40 <- buildTM 50+ indiv50 <- buildTM 50++ batch10 <- buildTM 10+ batch20 <- buildTM 20+ batch30 <- buildTM 30+ batch40 <- buildTM 40+ batch50 <- buildTM 50++ threadDelay 1000000++ defaultMain+ [ bgroup "build"+ [ bench "10" $ whnfIO (buildTM 10)+ , bench "20" $ whnfIO (buildTM 20)+ , bench "30" $ whnfIO (buildTM 30)+ , bench "40" $ whnfIO (buildTM 40)+ , bench "50" $ whnfIO (buildTM 50)+ ]+ , bgroup "lookup"+ [ bench "10" $ whnfIO (lookupTM 10 indiv50)+ , bench "20" $ whnfIO (lookupTM 20 indiv50)+ , bench "30" $ whnfIO (lookupTM 30 indiv50)+ , bench "40" $ whnfIO (lookupTM 40 indiv50)+ , bench "50" $ whnfIO (lookupTM 50 indiv50)+ ]+ , bgroup "delete individual"+ [ bench "10" $ whnfIO (destroyTM 10 indiv10)+ , bench "20" $ whnfIO (destroyTM 20 indiv20)+ , bench "30" $ whnfIO (destroyTM 30 indiv30)+ , bench "40" $ whnfIO (destroyTM 40 indiv40)+ , bench "50" $ whnfIO (destroyTM 50 indiv50)+ ]+ , bgroup "delete batch"+ [ bench "10" $ whnfIO (TM.filterFromNow 1 batch10)+ , bench "20" $ whnfIO (TM.filterFromNow 1 batch20)+ , bench "30" $ whnfIO (TM.filterFromNow 1 batch30)+ , bench "40" $ whnfIO (TM.filterFromNow 1 batch40)+ , bench "50" $ whnfIO (TM.filterFromNow 1 batch50)+ ]+ ]
+ bench2/Main.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE+ OverloadedStrings+ #-}++module Main where+++import Prelude hiding (lookup)+import Data.TimeMap (TimeMap)+import qualified Data.TimeMap as TM+import Control.Concurrent.STM+import Control.Concurrent (threadDelay)+++type Key = Integer+type Content = Integer++buildTM :: Integer -> IO (TimeMap Key Content)+buildTM top = do+ x <- atomically TM.newTimeMap+ mapM_ (\(k,v) -> TM.insert k v x) $ [0..top] `zip` [0..top]+ return x++destroyTM :: [Integer] -> TimeMap Key Content -> IO ()+destroyTM ds x = atomically $ mapM_ (`TM.delete` x) ds+++main :: IO ()+main = do+ xs <- buildTM 5000++ threadDelay 500000++ fresh <- buildTM 5000++ destroyTM [0..5000] fresh++ threadDelay 500000++ TM.filterFromNow 1 xs+
src/Data/TimeMap.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE BangPatterns+ , NamedFieldPuns+ , ScopedTypeVariables+ , RankNTypes #-} {- |@@ -46,19 +49,22 @@ , filterWithKey , filterSince , filterFromNow+ , -- * Take+ takeSince+ , takeFromNow ) where import Prelude hiding (lookup, null, filter) import Data.Time (UTCTime, NominalDiffTime, addUTCTime, diffUTCTime, getCurrentTime) import Data.Hashable (Hashable (..))-import Data.Maybe (fromMaybe, fromJust)+import Data.Maybe (fromMaybe, fromJust, catMaybes) import qualified Data.Map.Strict as Map import qualified Data.HashSet as HS import qualified Data.TimeMap.Internal as MM import qualified STMContainers.Map as HT import qualified Focus as F import qualified ListT as L-import Control.Monad (forM)+import Control.Monad (forM, void) import Control.Concurrent.STM (STM, atomically, TVar, writeTVar, readTVar, modifyTVar', modifyTVar, newTVar) @@ -82,23 +88,25 @@ -- | Inserts a key and value into a 'TimeMap' - it adds the value -- or overwites an existing entity.-insert :: ( Hashable k- , Eq k- ) => k -> a -> TimeMap k a -> IO ()+insert :: Hashable k+ => Eq k+ => k -> a -> TimeMap k a -> IO () insert k x xs = do now <- getCurrentTime- atomically $ insertWithTime now k x xs+ atomically (insertWithTime now k x xs) {-# INLINEABLE insert #-} -insertWithTime :: ( Hashable k- , Eq k- ) => UTCTime -> k -> a -> TimeMap k a -> STM ()-insertWithTime now k x xs =- HT.focus go k (keysMap xs)+insertWithTime :: forall k a+ . Hashable k+ => Eq k+ => UTCTime -> k -> a -> TimeMap k a -> STM ()+insertWithTime now k x TimeMap{timeMap,keysMap} =+ HT.focus go k keysMap where+ go :: Maybe (TimeIndexed a) -> STM ((), F.Decision (TimeIndexed a)) go mx = do- modifyTVar (timeMap xs) $+ modifyTVar timeMap $ let changeOld = case mx of Nothing -> id Just (TimeIndexed oldTime _) ->@@ -109,31 +117,31 @@ {-# INLINEABLE insertWithTime #-} -- | Performs a non-mutating lookup for some key.-lookup :: ( Hashable k- , Eq k- ) => k -> TimeMap k a -> STM (Maybe a)-lookup k xs =- (\mx' -> indexedValue <$> mx') <$> HT.lookup k (keysMap xs)+lookup :: Hashable k+ => Eq k+ => k -> TimeMap k a -> STM (Maybe a)+lookup k TimeMap{keysMap} =+ (\mx' -> indexedValue <$> mx') <$> HT.lookup k keysMap {-# INLINEABLE lookup #-} -keys :: ( Hashable k- , Eq k- ) => TimeMap k a -> STM (HS.HashSet k)-keys xs = MM.elems <$> readTVar (timeMap xs)+keys :: Hashable k+ => Eq k+ => TimeMap k a -> STM (HS.HashSet k)+keys TimeMap{timeMap} = MM.elems <$> readTVar timeMap {-# INLINEABLE keys #-} elems :: TimeMap k a -> STM [a]-elems xs = L.toList $ (indexedValue . snd) <$> HT.stream (keysMap xs)+elems TimeMap{keysMap} = L.toList $ (indexedValue . snd) <$> HT.stream keysMap -toList :: ( Hashable k- , Eq k- ) => TimeMap k a -> STM [(k, a)]-toList xs = do- keys' <- (HS.toList . MM.elems) <$> readTVar (timeMap xs)+toList :: Hashable k+ => Eq k+ => TimeMap k a -> STM [(k, a)]+toList TimeMap{keysMap,timeMap} = do+ keys' <- (HS.toList . MM.elems) <$> readTVar timeMap forM keys' $ \k -> do- mVal <- HT.lookup k (keysMap xs)+ mVal <- HT.lookup k keysMap pure (k, indexedValue (fromJust mVal)) size :: TimeMap k a -> STM Int@@ -142,88 +150,92 @@ null :: TimeMap k a -> STM Bool null xs = HT.null (keysMap xs) -timeOf :: ( Hashable k- , Eq k- ) => k -> TimeMap k a -> STM (Maybe UTCTime)+timeOf :: Hashable k+ => Eq k+ => k -> TimeMap k a -> STM (Maybe UTCTime) timeOf k xs = do mx <- HT.lookup k (keysMap xs)- pure $! indexedTime <$> mx+ pure (indexedTime <$> mx) {-# INLINEABLE timeOf #-} -ageOf :: ( Hashable k- , Eq k- ) => k -> TimeMap k a -> IO (Maybe NominalDiffTime)+ageOf :: Hashable k+ => Eq k+ => k -> TimeMap k a -> IO (Maybe NominalDiffTime) ageOf k xs = do now <- getCurrentTime- mt <- atomically $! timeOf k xs- pure $! diffUTCTime now <$> mt+ mt <- atomically (timeOf k xs)+ pure (diffUTCTime now <$> mt) {-# INLINEABLE ageOf #-} -- | Updates or deletes the value at @k@, while updating its time.-update :: ( Hashable k- , Eq k- ) => (a -> Maybe a) -> k -> TimeMap k a -> IO ()+update :: Hashable k+ => Eq k+ => (a -> Maybe a) -> k -> TimeMap k a -> IO () update p k xs = do now <- getCurrentTime- atomically $ updateWithTime now p k xs+ atomically (updateWithTime now p k xs) {-# INLINEABLE update #-} -updateWithTime :: ( Hashable k- , Eq k- ) => UTCTime -> (a -> Maybe a) -> k -> TimeMap k a -> STM ()-updateWithTime now p k xs =- HT.focus go k (keysMap xs)+updateWithTime :: forall k a+ . Hashable k+ => Eq k+ => UTCTime -> (a -> Maybe a) -> k -> TimeMap k a -> STM ()+updateWithTime now p k TimeMap{keysMap,timeMap} =+ HT.focus go k keysMap where+ go :: Maybe (TimeIndexed a) -> STM ((), F.Decision (TimeIndexed a)) go Nothing = pure ((), F.Keep) go (Just (TimeIndexed oldTime y)) = let (action,minsert) = case p y of Nothing -> (F.Remove , MM.remove oldTime k) Just y' -> (F.Replace (TimeIndexed now y'), id)- in do modifyTVar (timeMap xs) (MM.insert now k . minsert)+ in do modifyTVar timeMap (MM.insert now k . minsert) pure ((), action) {-# INLINEABLE updateWithTime #-} -- | Adjusts the value at @k@, while updating its time.-adjust :: ( Hashable k- , Eq k- ) => (a -> a) -> k -> TimeMap k a -> IO ()+adjust :: Hashable k+ => Eq k+ => (a -> a) -> k -> TimeMap k a -> IO () adjust f k xs = do now <- getCurrentTime- atomically $ adjustWithTime now f k xs+ atomically (adjustWithTime now f k xs) {-# INLINEABLE adjust #-} -adjustWithTime :: ( Hashable k- , Eq k- ) => UTCTime -> (a -> a) -> k -> TimeMap k a -> STM ()-adjustWithTime now f k xs =- HT.focus go k (keysMap xs)+adjustWithTime :: forall k a+ . Hashable k+ => Eq k+ => UTCTime -> (a -> a) -> k -> TimeMap k a -> STM ()+adjustWithTime now f k TimeMap{keysMap,timeMap} =+ HT.focus go k keysMap where+ go :: Maybe (TimeIndexed a) -> STM ((), F.Decision (TimeIndexed a)) go Nothing = pure ((), F.Keep) go (Just (TimeIndexed oldTime y)) = do- modifyTVar (timeMap xs) (MM.insert now k . MM.remove oldTime k)- pure ((), F.Replace (TimeIndexed now $! f y))+ modifyTVar timeMap (MM.insert now k . MM.remove oldTime k)+ pure ((), F.Replace $ TimeIndexed now $ f y) {-# INLINEABLE adjustWithTime #-} -- | Deletes the value at @k@.-delete :: ( Hashable k- , Eq k- ) => k -> TimeMap k a -> STM ()-delete k xs = HT.focus go k (keysMap xs)+delete :: Hashable k+ => Eq k+ => k -> TimeMap k a -> STM ()+delete k TimeMap{timeMap,keysMap} = HT.focus go k keysMap where go mx = do case mx of Nothing -> pure () Just (TimeIndexed oldTime _) ->- modifyTVar' (timeMap xs) (MM.remove oldTime k)+ modifyTVar' timeMap (MM.remove oldTime k) pure ((), F.Remove) {-# INLINEABLE delete #-}@@ -231,29 +243,32 @@ -- | Resets the key to the current time, and fails silently when the key isn't -- present.-touch :: ( Hashable k- , Eq k- ) => k -> TimeMap k a -> IO ()+touch :: Hashable k+ => Eq k+ => k -> TimeMap k a -> IO () touch = adjust id {-# INLINEABLE touch #-} -filter :: ( Hashable k- , Eq k- ) => (a -> Bool) -> TimeMap k a -> STM ()+filter :: Hashable k+ => Eq k+ => (a -> Bool) -> TimeMap k a -> STM () filter p = filterWithKey (const p) {-# INLINEABLE filter #-} -filterWithKey :: ( Hashable k- , Eq k- ) => (k -> a -> Bool) -> TimeMap k a -> STM ()+filterWithKey :: forall k a+ . Hashable k+ => Eq k+ => (k -> a -> Bool) -> TimeMap k a -> STM () filterWithKey p xs = do ks <- (HS.toList . MM.elems) <$> readTVar (timeMap xs) mapM_ go ks where+ go :: k -> STM () go k = HT.focus go' k (keysMap xs) where+ go' :: Maybe (TimeIndexed a) -> STM ((), F.Decision (TimeIndexed a)) go' (Just (TimeIndexed _ x)) | p k x = pure ((), F.Keep) | otherwise = pure ((), F.Remove)@@ -261,33 +276,61 @@ {-# INLINEABLE filterWithKey #-} --- | Filters out all entries older than or equal to a designated time-filterSince :: ( Hashable k- , Eq k- ) => UTCTime- -> TimeMap k a- -> STM ()-filterSince t xs = do- ts <- readTVar (timeMap xs)++takeSince :: Hashable k+ => Eq k+ => UTCTime+ -> TimeMap k a+ -> STM [(k, a)]+takeSince t TimeMap{timeMap,keysMap} = do+ ts <- readTVar timeMap let (toCut, mx, result) = Map.splitLookup t ts- found = fromMaybe HS.empty mx- toRemove = MM.elems toCut `HS.union` found- writeTVar (timeMap xs) result- mapM_ (\k -> HT.delete k $ keysMap xs) $! HS.toList toRemove+ toRemove = MM.elems toCut `HS.union` fromMaybe HS.empty mx+ writeTVar timeMap result+ taken <- fmap catMaybes $ forM (HS.toList toRemove) $ \k -> do+ mX <- HT.lookup k keysMap+ case mX of+ Nothing -> pure Nothing+ Just (TimeIndexed _ x) -> do+ HT.delete k keysMap+ pure (Just (k, x))+ pure taken ++{-# INLINEABLE takeSince #-}+++takeFromNow :: Hashable k+ => Eq k+ => NominalDiffTime+ -> TimeMap k a+ -> IO [(k, a)]+takeFromNow t xs = do+ now <- getCurrentTime+ atomically (takeSince (addUTCTime (negate t) now) xs)++{-# INLINEABLE takeFromNow #-}+++-- | Filters out all entries older than or equal to a designated time+filterSince :: Hashable k+ => Eq k+ => UTCTime+ -> TimeMap k a+ -> STM ()+filterSince t = void . takeSince t+ {-# INLINEABLE filterSince #-} -- | Filters out all entries within some time frame -- -- > filterFromNow 1 -- removes entities older than or equal to one second from now-filterFromNow :: ( Hashable k- , Eq k- ) => NominalDiffTime -- ^ Assumes a positive distance into the past- -> TimeMap k a- -> IO ()-filterFromNow t xs = do- now <- getCurrentTime- atomically $ (filterSince $! addUTCTime (negate t) now) xs+filterFromNow :: Hashable k+ => Eq k+ => NominalDiffTime -- ^ Assumes a positive distance into the past+ -> TimeMap k a+ -> IO ()+filterFromNow t = void . takeFromNow t {-# INLINEABLE filterFromNow #-}
src/Data/TimeMap/Multi.hs view
@@ -69,8 +69,16 @@ filter f (TimeMultiMap xs) = TimeSet.filter (\(k,a) -> f k a) xs +takeSince :: (Hashable k, Hashable a, Eq k, Eq a) => UTCTime -> TimeMultiMap k a -> STM [(k, a)]+takeSince t (TimeMultiMap xs) = TimeSet.takeSince t xs++ filterSince :: (Hashable k, Hashable a, Eq k, Eq a) => UTCTime -> TimeMultiMap k a -> STM () filterSince t (TimeMultiMap xs) = TimeSet.filterSince t xs+++takeFromNow :: (Hashable k, Hashable a, Eq k, Eq a) => NominalDiffTime -> TimeMultiMap k a -> IO [(k, a)]+takeFromNow t (TimeMultiMap xs) = TimeSet.takeFromNow t xs filterFromNow :: (Hashable k, Hashable a, Eq k, Eq a) => NominalDiffTime -> TimeMultiMap k a -> IO ()
src/Data/TimeSet.hs view
@@ -63,8 +63,16 @@ filter f (TimeSet xs) = TimeMap.filterWithKey (\k _ -> f k) xs +takeSince :: (Hashable a, Eq a) => UTCTime -> TimeSet a -> STM [a]+takeSince t (TimeSet xs) = fmap fst <$> TimeMap.takeSince t xs++ filterSince :: (Hashable a, Eq a) => UTCTime -> TimeSet a -> STM () filterSince t (TimeSet xs) = TimeMap.filterSince t xs+++takeFromNow :: (Hashable a, Eq a) => NominalDiffTime -> TimeSet a -> IO [a]+takeFromNow t (TimeSet xs) = fmap fst <$> TimeMap.takeFromNow t xs filterFromNow :: (Hashable a, Eq a) => NominalDiffTime -> TimeSet a -> IO ()
timemap.cabal view
@@ -1,104 +1,118 @@-Name: timemap-Version: 0.0.6-Author: Athan Clark <athan.clark@gmail.com>-Maintainer: Athan Clark <athan.clark@gmail.com>-License: BSD3-License-File: LICENSE-Synopsis: A mutable hashmap, implicitly indexed by UTCTime.--- Description:-Cabal-Version: >= 1.10-Build-Type: Simple-Category: Data, Time+-- This file has been generated from package.yaml by hpack version 0.21.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 723bc051f5a1788fec620be68d8894605e5a2830dd024e41b93b05a40389fb84 -Flag ThreadScope- Description: Build the threadscope benchmark- Default: False+name: timemap+version: 0.0.7+description: Please see the README on Github at <https://github.com/githubuser/timemap#readme>+homepage: https://github.com/athanclark/timemap#readme+bug-reports: https://github.com/athanclark/timemap/issues+author: Athan Clark+maintainer: athan.clark@localcooking.com+copyright: Copyright (c) 2018 Athan Clark+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10 -Library- Default-Language: Haskell2010- HS-Source-Dirs: src- GHC-Options: -Wall- Exposed-Modules: Data.TimeMap- Data.TimeMap.Multi- Data.TimeSet- Other-Modules: Data.TimeMap.Internal- Build-Depends: base >= 4.8 && < 5- , containers- , focus- , hashable- , list-t- , stm- , stm-containers- , time- , unordered-containers+extra-source-files:+ README.md -Test-Suite spec- Type: exitcode-stdio-1.0- Default-Language: Haskell2010- Hs-Source-Dirs: src- , test- Ghc-Options: -Wall -threaded- Main-Is: Spec.hs- Other-Modules: Data.TimeMap- Data.TimeMap.Internal- Data.TimeMapSpec- Build-Depends: base- , containers- , focus- , hashable- , list-t- , stm- , stm-containers- , time- , unordered-containers- , tasty- , tasty-quickcheck- , tasty-hunit- , QuickCheck- , quickcheck-instances+source-repository head+ type: git+ location: https://github.com/athanclark/timemap -Benchmark bench- Type: exitcode-stdio-1.0- Default-Language: Haskell2010- Hs-Source-Dirs: src- , bench- Ghc-Options: -Wall -threaded- Main-Is: Bench.hs- Other-Modules: Data.TimeMap- Data.TimeMap.Internal- Build-Depends: base- , containers- , focus- , hashable- , list-t- , stm- , stm-containers- , time- , unordered-containers- , criterion+library+ exposed-modules:+ Data.TimeMap+ Data.TimeMap.Internal+ Data.TimeMap.Multi+ Data.TimeSet+ other-modules:+ Paths_timemap+ hs-source-dirs:+ src+ ghc-options: -Wall+ build-depends:+ base >=4.8 && <5+ , containers+ , focus+ , hashable+ , list-t+ , stm+ , stm-containers+ , time+ , unordered-containers+ default-language: Haskell2010 -Executable bench2- if flag(ThreadScope)- Buildable: True- else- Buildable: False- Default-Language: Haskell2010- Hs-Source-Dirs: src- , bench- Ghc-Options: -Wall -threaded -eventlog -rtsopts- Main-Is: Bench2.hs- Other-Modules: Data.TimeMap- Data.TimeMap.Internal- Build-Depends: base- , containers- , focus- , hashable- , list-t- , stm- , stm-containers- , time- , unordered-containers+test-suite timemap-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Data.TimeMapSpec+ Paths_timemap+ hs-source-dirs:+ test+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ QuickCheck+ , base >=4.8 && <5+ , containers+ , focus+ , hashable+ , list-t+ , quickcheck-instances+ , stm+ , stm-containers+ , tasty+ , tasty-quickcheck+ , time+ , timemap+ , unordered-containers+ default-language: Haskell2010 -Source-Repository head- Type: git- Location: https://github.com/athanclark/timemap+benchmark timemap-bench1+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Paths_timemap+ hs-source-dirs:+ bench1+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.8 && <5+ , containers+ , criterion+ , focus+ , hashable+ , list-t+ , stm+ , stm-containers+ , time+ , timemap+ , unordered-containers+ default-language: Haskell2010++benchmark timemap-bench2+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Paths_timemap+ hs-source-dirs:+ bench2+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.8 && <5+ , containers+ , criterion+ , focus+ , hashable+ , list-t+ , stm+ , stm-containers+ , time+ , timemap+ , unordered-containers+ default-language: Haskell2010