packages feed

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 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