timemap 0.0.2 → 0.0.3

raw patch · 3 files changed

+122/−41 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• src/Data/TimeMap.hs +100/−38
• src/Data/TimeMap/Internal.hs +21/−2
• timemap.cabal +1/−1

@@ -1,3 +1,7 @@+{-# LANGUAGE+    BangPatterns+  #-}+ {- | Module      : Data.TimeMap Copyright   : (c) 2015 Athan Clark@@ -21,8 +25,11 @@   , -- * Construction     newTimeMap   , insert+  , insertWithTime   , update+  , updateWithTime   , adjust+  , adjustWithTime   , delete   , -- * Query     lookup@@ -30,6 +37,7 @@   , ageOf   , keys   , elems+  , toList   , size   , null   , -- * Filter@@ -42,23 +50,28 @@ import Prelude hiding (lookup, null, filter) import Data.Time (UTCTime, NominalDiffTime, addUTCTime, diffUTCTime, getCurrentTime) import Data.Hashable (Hashable (..))-import Data.Maybe (fromMaybe)-import qualified Data.Map                 as Map+import Data.Maybe (fromMaybe, fromJust)+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.Concurrent.STM  --- | A mutable reference for a time-indexed map, similar to a 'Data.STRef.STRef'.-data TimeMap k a = TimeMap-  { timeMap :: TVar (MM.MultiMap UTCTime k)-  , keysMap :: HT.Map k (UTCTime, a)+data TimeIndexed a = TimeIndexed+  { indexedTime  :: {-# UNPACK #-} !UTCTime+  , indexedValue :: a   }  +-- | A mutable reference for a time-indexed map, similar to a 'Data.STRef.STRef'.+data TimeMap k a = TimeMap+  { timeMap :: !(TVar (MM.MultiMap UTCTime k))+  , keysMap :: !(HT.Map k (TimeIndexed a))+  }   -- | Create a fresh, empty map.@@ -73,35 +86,55 @@           ) => k -> a -> TimeMap k a -> IO () insert k x xs = do   now <- getCurrentTime-  atomically $ HT.focus (go now) k (keysMap 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)   where-    go now mx = do+    go mx = do       modifyTVar (timeMap xs) $         let changeOld = case mx of-                          Nothing          -> id-                          Just (oldTime,_) -> MM.remove oldTime k-        in MM.insert now k . changeOld-      pure ((), F.Replace (now, x))+                          Nothing -> id+                          Just (TimeIndexed oldTime _) ->+                            MM.remove oldTime k+        in  MM.insert now k . changeOld+      pure ((), F.Replace (TimeIndexed now x)) +{-# 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 = do-  mx <- HT.lookup k (keysMap xs)-  pure (snd <$> mx)+lookup k xs =+  (\mx' -> indexedValue <$> mx') <$> HT.lookup k (keysMap xs) +{-# INLINEABLE lookup #-}  keys :: ( Hashable k         , Eq k         ) => TimeMap k a -> STM (HS.HashSet k) keys xs = MM.elems <$> readTVar (timeMap xs) +{-# INLINEABLE keys #-}  elems :: TimeMap k a -> STM [a]-elems xs = L.toList $ (snd . snd) <$> HT.stream (keysMap xs)+elems xs = L.toList $ (indexedValue . snd) <$> HT.stream (keysMap xs) +toList :: ( Hashable k+          , Eq k+          ) => TimeMap k a -> STM [(k, a)]+toList xs = do+  keys' <- (HS.toList . MM.elems) <$> readTVar (timeMap xs)+  forM keys' $ \k -> do+    mVal <- HT.lookup k (keysMap xs)+    pure (k, indexedValue (fromJust mVal))+ size :: TimeMap k a -> STM Int size xs = length <$> elems xs @@ -113,16 +146,19 @@           ) => k -> TimeMap k a -> STM (Maybe UTCTime) timeOf k xs = do   mx <- HT.lookup k (keysMap xs)-  pure (fst <$> mx)+  pure $! indexedTime <$> mx +{-# INLINEABLE timeOf #-}+ 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@@ -130,17 +166,26 @@           ) => (a -> Maybe a) -> k -> TimeMap k a -> IO () update p k xs = do   now <- getCurrentTime-  atomically $ HT.focus (go now) k (keysMap 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)   where-    go _ Nothing = pure ((), F.Keep)-    go now (Just (oldTime, y)) =+    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 (now, y'), id)+              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)             pure ((), action) +{-# INLINEABLE updateWithTime #-}   -- | Adjusts the value at @k@, while updating its time.@@ -149,34 +194,45 @@           ) => (a -> a) -> k -> TimeMap k a -> IO () adjust f k xs = do   now <- getCurrentTime-  atomically $ HT.focus (go now) k (keysMap 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)   where-    go _ Nothing = pure ((), F.Keep)-    go now (Just (oldTime, y)) = do+    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 (now, f y))+      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 = do-  HT.focus go k (keysMap xs)+delete k xs = HT.focus go k (keysMap xs)   where     go mx = do       case mx of-        Nothing          -> pure ()-        Just (oldTime,_) -> modifyTVar' (timeMap xs) (MM.remove oldTime k)+        Nothing -> pure ()+        Just (TimeIndexed oldTime _) ->+          modifyTVar' (timeMap xs) (MM.remove oldTime k)       pure ((), F.Remove) -+{-# INLINEABLE delete #-}  filter :: ( Hashable k           , Eq k           ) => (a -> Bool) -> TimeMap k a -> STM () filter p = filterWithKey (const p) +{-# INLINEABLE filter #-}  filterWithKey :: ( Hashable k                  , Eq k@@ -187,10 +243,12 @@   where     go k = HT.focus go' k (keysMap xs)       where-        go' (Just (_,x)) | p k x     = pure ((), F.Keep)-                         | otherwise = pure ((), F.Remove)-        go' Nothing      = pure ((), F.Keep)+        go' (Just (TimeIndexed _ x))+          | p k x     = pure ((), F.Keep)+          | otherwise = pure ((), F.Remove)+        go' Nothing   = pure ((), F.Keep) +{-# INLINEABLE filterWithKey #-}  -- | Filters out all entries older than or equal to a designated time filterSince :: ( Hashable k@@ -204,9 +262,11 @@       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)+  mapM_ (\k -> HT.delete k $ keysMap xs) $! HS.toList toRemove +{-# INLINEABLE filterSince #-} + -- | Filters out all entries within some time frame -- --   > filterFromNow 1 -- removes entities older than or equal to one second from now@@ -217,4 +277,6 @@                    -> IO () filterFromNow t xs = do   now <- getCurrentTime-  atomically $ filterSince (addUTCTime (negate t) now) xs+  atomically $ (filterSince $! addUTCTime (negate t) now) xs++{-# INLINEABLE filterFromNow #-}

@@ -1,8 +1,8 @@ module Data.TimeMap.Internal where  import Data.Hashable (Hashable)-import qualified Data.Map     as Map-import qualified Data.HashSet as HS+import qualified Data.Map.Strict as Map+import qualified Data.HashSet    as HS   type MultiMap k a = Map.Map k (HS.HashSet a)@@ -17,6 +17,8 @@           ) => k -> a -> MultiMap k a -> MultiMap k a insert k x = Map.insertWith (HS.union) k (HS.singleton x) +{-# INLINEABLE insert #-}+ lookup :: ( Ord k           ) => k -> MultiMap k a -> HS.HashSet a lookup k xs =@@ -24,11 +26,15 @@     Nothing -> HS.empty     Just ys -> ys +{-# INLINEABLE lookup #-}+ -- | Deletes all elements at @k@ delete :: ( Ord k           ) => k -> MultiMap k a -> MultiMap k a delete = Map.delete +{-# INLINEABLE delete #-}+ -- | Deletes only the element @a@ from the referenced key @k@ remove :: ( Ord k           , Hashable a@@ -41,7 +47,20 @@               then Nothing               else Just s' +{-# INLINEABLE remove #-}+ elems :: ( Hashable a          , Eq a          ) => MultiMap k a -> HS.HashSet a elems = foldr HS.union HS.empty++{-# INLINEABLE elems #-}++toList :: ( Hashable a+          , Eq a+          ) => MultiMap k a -> [(k, a)]+toList =+  Map.foldrWithKey go []+  where+    go :: k -> HS.HashSet a -> [(k, a)] -> [(k, a)]+    go k x acc = repeat k `zip` HS.toList x ++ acc

@@ -1,5 +1,5 @@ Name:                   timemap-Version:                0.0.2+Version:                0.0.3 Author:                 Athan Clark <athan.clark@gmail.com> Maintainer:             Athan Clark <athan.clark@gmail.com> License:                BSD3