timemap 0.0.0 → 0.0.1
raw patch · 5 files changed
+132/−84 lines, 5 filesdep +focusdep +list-tdep +stm-containersdep −hashtables
Dependencies added: focus, list-t, stm-containers
Dependencies removed: hashtables
Files
- bench/Bench.hs +4/−3
- bench/Bench2.hs +7/−18
- src/Data/TimeMap.hs +101/−52
- test/Data/TimeMapSpec.hs +7/−6
- timemap.cabal +13/−5
bench/Bench.hs view
@@ -9,6 +9,7 @@ import Data.TimeMap (TimeMap) import qualified Data.TimeMap as TM import Criterion.Main+import Control.Concurrent.STM import Control.Concurrent (threadDelay) @@ -17,15 +18,15 @@ buildTM :: Integer -> IO (TimeMap Key Content) buildTM top = do- x <- TM.newTimeMap+ 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 = mapM (`TM.lookup` x) [0..top]+lookupTM top x = atomically $ mapM (`TM.lookup` x) [0..top] destroyTM :: Key -> TimeMap Key Content -> IO ()-destroyTM top x = mapM_ (`TM.delete` x) [0..top]+destroyTM top x = atomically $ mapM_ (`TM.delete` x) [0..top] main :: IO ()
bench/Bench2.hs view
@@ -8,6 +8,7 @@ import Prelude hiding (lookup) import Data.TimeMap (TimeMap) import qualified Data.TimeMap as TM+import Control.Concurrent.STM import Control.Concurrent (threadDelay) @@ -16,37 +17,25 @@ buildTM :: Integer -> IO (TimeMap Key Content) buildTM top = do- x <- TM.newTimeMap+ 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 = mapM_ (`TM.delete` x) ds+destroyTM ds x = atomically $ mapM_ (`TM.delete` x) ds main :: IO () main = do- x10 <- buildTM 1000- x20 <- buildTM 2000- x30 <- buildTM 3000- x40 <- buildTM 4000- x50 <- buildTM 5000+ xs <- buildTM 5000 threadDelay 500000 fresh <- buildTM 5000 - destroyTM [0..1000] fresh- destroyTM [1001..2000] fresh- destroyTM [2001..3000] fresh- destroyTM [3001..4000] fresh- destroyTM [4001..5000] fresh+ destroyTM [0..5000] fresh - threadDelay 1000000+ threadDelay 500000 - TM.filterFromNow 1 x10- TM.filterFromNow 1 x20- TM.filterFromNow 1 x30- TM.filterFromNow 1 x40- TM.filterFromNow 1 x50+ TM.filterFromNow 1 xs
src/Data/TimeMap.hs view
@@ -25,34 +25,43 @@ , delete , -- * Query lookup+ , timeOf+ , ageOf+ , keys+ , elems+ , null , -- * Filter- filterSince+ filter+ , filterWithKey+ , filterSince , filterFromNow ) where -import Prelude hiding (lookup, null)-import Data.Time (UTCTime, NominalDiffTime, addUTCTime, getCurrentTime)+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 qualified Data.HashTable.IO as HT 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.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.CuckooHashTable k (UTCTime, TVar a)+ , keysMap :: HT.Map k (UTCTime, a) } -- | Create a fresh, empty map.-newTimeMap :: IO (TimeMap k a)-newTimeMap = TimeMap <$> atomically (newTVar MM.empty)+newTimeMap :: STM (TimeMap k a)+newTimeMap = TimeMap <$> newTVar MM.empty <*> HT.new -- | Inserts a key and value into a 'TimeMap' - it adds the value@@ -61,78 +70,118 @@ , Eq k ) => k -> a -> TimeMap k a -> IO () insert k x xs = do- mEnt <- HT.lookup (keysMap xs) k now <- getCurrentTime- xVar <- atomically $ do- case mEnt of- Nothing -> do- xVar <- newTVar x- modifyTVar (timeMap xs) $ MM.insert now k- return xVar- Just (oldTime, xVar) -> do- modifyTVar (timeMap xs)- (MM.insert now k . MM.remove oldTime k)- writeTVar xVar x- return xVar- HT.insert (keysMap xs) k (now, xVar)+ atomically $ HT.focus (go now) k (keysMap xs)+ where+ go now 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)) + -- | Performs a non-mutating lookup for some key. lookup :: ( Hashable k , Eq k- ) => k -> TimeMap k a -> IO (Maybe a)+ ) => k -> TimeMap k a -> STM (Maybe a) lookup k xs = do- mEnt <- HT.lookup (keysMap xs) k- case mEnt of- Nothing -> return Nothing- Just (_, xVar) -> Just <$> readTVarIO xVar+ mx <- HT.lookup k (keysMap xs)+ pure (snd <$> mx) +keys :: ( Hashable k+ , Eq k+ ) => TimeMap k a -> STM (HS.HashSet k)+keys xs = MM.elems <$> readTVar (timeMap xs)+++elems :: TimeMap k a -> STM [a]+elems xs = L.toList $ (snd . snd) <$> HT.stream (keysMap xs)+++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 k xs = do+ mx <- HT.lookup k (keysMap xs)+ pure (fst <$> mx)++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)++ -- | Adjusts the value at @k@, while updating its time. adjust :: ( Hashable k , Eq k ) => (a -> a) -> k -> TimeMap k a -> IO () adjust f k xs = do- mEnt <- HT.lookup (keysMap xs) k- case mEnt of- Nothing -> return ()- Just (oldTime, xVar) -> do- now <- getCurrentTime- atomically $ do- modifyTVar (timeMap xs)- (MM.insert now k . MM.remove oldTime k)- modifyTVar xVar f- HT.insert (keysMap xs) k (now, xVar)+ now <- getCurrentTime+ atomically $ HT.focus (go now) k (keysMap xs)+ where+ go _ Nothing = pure ((), F.Keep)+ go now (Just (oldTime, y)) = do+ modifyTVar (timeMap xs) (MM.insert now k . MM.remove oldTime k)+ pure ((), F.Replace (now, f y)) -- | Deletes the value at @k@. delete :: ( Hashable k , Eq k- ) => k -> TimeMap k a -> IO ()+ ) => k -> TimeMap k a -> STM () delete k xs = do- mEnt <- HT.lookup (keysMap xs) k- case mEnt of- Nothing -> return ()- Just (oldTime,_) -> do- atomically $ modifyTVar' (timeMap xs) $ MM.remove oldTime k- HT.delete (keysMap xs) k+ HT.focus go k (keysMap xs)+ where+ go mx = do+ case mx of+ Nothing -> pure ()+ Just (oldTime,_) -> modifyTVar' (timeMap xs) (MM.remove oldTime k)+ pure ((), F.Remove) +filter :: ( Hashable k+ , Eq k+ ) => (a -> Bool) -> TimeMap k a -> STM ()+filter p = filterWithKey (const p)+++filterWithKey :: ( 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 = 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)++ -- | Filters out all entries older than or equal to a designated time filterSince :: ( Hashable k , Eq k ) => UTCTime -> TimeMap k a- -> IO ()+ -> STM () filterSince t xs = do- toRemove <- atomically $ do- ts <- readTVar (timeMap xs)- let (toCut, mx, result) = Map.splitLookup t ts- found = fromMaybe HS.empty mx- toRemove = MM.elems toCut `HS.union` found- writeTVar (timeMap xs) result- return toRemove- mapM_ (HT.delete $ keysMap xs) (HS.toList toRemove)+ ts <- readTVar (timeMap xs)+ 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) -- | Filters out all entries within some time frame@@ -145,4 +194,4 @@ -> IO () filterFromNow t xs = do now <- getCurrentTime- filterSince (addUTCTime (negate t) now) xs+ atomically $ filterSince (addUTCTime (negate t) now) xs
test/Data/TimeMapSpec.hs view
@@ -13,6 +13,7 @@ import Test.QuickCheck import Test.QuickCheck.Instances +import Control.Concurrent.STM import Control.Concurrent (threadDelay) @@ -39,7 +40,7 @@ buildTimeMap :: BuiltTimeMap -> IO (TimeMap Key Content) buildTimeMap xs = do- x <- TM.newTimeMap+ x <- atomically $ TM.newTimeMap mapM_ (\(k,v) -> TM.insert k v x) $ getBuiltTimeMap xs return x @@ -48,14 +49,14 @@ lookupInsertExists k v xs = ioProperty $ do x <- buildTimeMap xs TM.insert k v x- isJust <$> TM.lookup k x+ isJust <$> atomically (TM.lookup k x) lookupDeleteNotExists :: Key -> BuiltTimeMap -> Property lookupDeleteNotExists k xs = ioProperty $ do x <- buildTimeMap xs- TM.delete k x- isNothing <$> TM.lookup k x+ atomically (TM.delete k x)+ isNothing <$> atomically (TM.lookup k x) lookupAgoNotExists :: Key -> Content -> BuiltTimeMap -> Property lookupAgoNotExists k v xs = ioProperty $ do@@ -63,7 +64,7 @@ TM.insert k v x threadDelay 1000000 TM.filterFromNow 1 x- isNothing <$> TM.lookup k x+ isNothing <$> atomically (TM.lookup k x) lookupAgoExists :: Key -> Content -> BuiltTimeMap -> Property lookupAgoExists k v xs = ioProperty $ do@@ -71,4 +72,4 @@ TM.insert k v x threadDelay 500000 TM.filterFromNow 1 x- isJust <$> TM.lookup k x+ isJust <$> atomically (TM.lookup k x)
timemap.cabal view
@@ -1,5 +1,5 @@ Name: timemap-Version: 0.0.0+Version: 0.0.1 Author: Athan Clark <athan.clark@gmail.com> Maintainer: Athan Clark <athan.clark@gmail.com> License: BSD3@@ -22,9 +22,11 @@ Other-Modules: Data.TimeMap.Internal Build-Depends: base >= 4.8 && < 5 , containers+ , focus , hashable- , hashtables+ , list-t , stm+ , stm-containers , time , unordered-containers @@ -40,9 +42,11 @@ Data.TimeMapSpec Build-Depends: base , containers+ , focus , hashable- , hashtables+ , list-t , stm+ , stm-containers , time , unordered-containers , tasty@@ -62,9 +66,11 @@ Data.TimeMap.Internal Build-Depends: base , containers+ , focus , hashable- , hashtables+ , list-t , stm+ , stm-containers , time , unordered-containers , criterion@@ -83,9 +89,11 @@ Data.TimeMap.Internal Build-Depends: base , containers+ , focus , hashable- , hashtables+ , list-t , stm+ , stm-containers , time , unordered-containers