timemap (empty) → 0.0.0
raw patch · 9 files changed
+536/−0 lines, 9 filesdep +QuickCheckdep +basedep +containerssetup-changed
Dependencies added: QuickCheck, base, containers, criterion, hashable, hashtables, quickcheck-instances, stm, tasty, tasty-hunit, tasty-quickcheck, time, unordered-containers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- bench/Bench.hs +76/−0
- bench/Bench2.hs +52/−0
- src/Data/TimeMap.hs +148/−0
- src/Data/TimeMap/Internal.hs +47/−0
- test/Data/TimeMapSpec.hs +74/−0
- test/Spec.hs +13/−0
- timemap.cabal +94/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Athan Clark++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 Athan Clark 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Bench.hs view
@@ -0,0 +1,76 @@+{-# 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 (threadDelay)+++type Key = Integer+type Content = Integer++buildTM :: Integer -> IO (TimeMap Key Content)+buildTM top = do+ x <- 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]++destroyTM :: Key -> TimeMap Key Content -> IO ()+destroyTM top x = 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 view
@@ -0,0 +1,52 @@+{-# LANGUAGE+ OverloadedStrings+ #-}++module Main where+++import Prelude hiding (lookup)+import Data.TimeMap (TimeMap)+import qualified Data.TimeMap as TM+import Control.Concurrent (threadDelay)+++type Key = Integer+type Content = Integer++buildTM :: Integer -> IO (TimeMap Key Content)+buildTM top = do+ x <- 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+++main :: IO ()+main = do+ x10 <- buildTM 1000+ x20 <- buildTM 2000+ x30 <- buildTM 3000+ x40 <- buildTM 4000+ x50 <- 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++ threadDelay 1000000++ TM.filterFromNow 1 x10+ TM.filterFromNow 1 x20+ TM.filterFromNow 1 x30+ TM.filterFromNow 1 x40+ TM.filterFromNow 1 x50+
+ src/Data/TimeMap.hs view
@@ -0,0 +1,148 @@+{- |+Module : Data.TimeMap+Copyright : (c) 2015 Athan Clark++License : BSD-3+Maintainer : athan.clark@gmail.com+Stability : experimental+Portability : GHC++A time-indexed mutable map for hashable keys.++The goal of this map is to provide moderately fast lookups and insertions for+key/value pairs, while implicitly keeping track of the last modification time of+each entity. The auxilliary time data is used for 'filterSince' and 'filterFromNow',+which quickly prune the data set to get rid of old entities.+-}++module Data.TimeMap+ ( -- * Types+ TimeMap+ , -- * Construction+ newTimeMap+ , insert+ , adjust+ , delete+ , -- * Query+ lookup+ , -- * Filter+ filterSince+ , filterFromNow+ ) where++import Prelude hiding (lookup, null)+import Data.Time (UTCTime, NominalDiffTime, addUTCTime, 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 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)+ }+++++-- | Create a fresh, empty map.+newTimeMap :: IO (TimeMap k a)+newTimeMap = TimeMap <$> atomically (newTVar MM.empty)+ <*> HT.new++-- | 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 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)++-- | Performs a non-mutating lookup for some key.+lookup :: ( Hashable k+ , Eq k+ ) => k -> TimeMap k a -> IO (Maybe a)+lookup k xs = do+ mEnt <- HT.lookup (keysMap xs) k+ case mEnt of+ Nothing -> return Nothing+ Just (_, xVar) -> Just <$> readTVarIO xVar+++-- | 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)+++-- | Deletes the value at @k@.+delete :: ( Hashable k+ , Eq k+ ) => k -> TimeMap k a -> IO ()+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++++-- | Filters out all entries older than or equal to a designated time+filterSince :: ( Hashable k+ , Eq k+ ) => UTCTime+ -> TimeMap k a+ -> IO ()+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)+++-- | 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+ filterSince (addUTCTime (negate t) now) xs
+ src/Data/TimeMap/Internal.hs view
@@ -0,0 +1,47 @@+module Data.TimeMap.Internal where++import Data.Hashable (Hashable)+import qualified Data.Map as Map+import qualified Data.HashSet as HS+++type MultiMap k a = Map.Map k (HS.HashSet a)+++empty :: MultiMap k a+empty = Map.empty++insert :: ( Ord k+ , Hashable a+ , Eq a+ ) => k -> a -> MultiMap k a -> MultiMap k a+insert k x = Map.insertWith (HS.union) k (HS.singleton x)++lookup :: ( Ord k+ ) => k -> MultiMap k a -> HS.HashSet a+lookup k xs =+ case Map.lookup k xs of+ Nothing -> HS.empty+ Just ys -> ys++-- | Deletes all elements at @k@+delete :: ( Ord k+ ) => k -> MultiMap k a -> MultiMap k a+delete = Map.delete++-- | Deletes only the element @a@ from the referenced key @k@+remove :: ( Ord k+ , Hashable a+ , Eq a+ ) => k -> a -> MultiMap k a -> MultiMap k a+remove k x = Map.update go k+ where+ go s = let s' = HS.delete x s+ in if s' == HS.empty+ then Nothing+ else Just s'++elems :: ( Hashable a+ , Eq a+ ) => MultiMap k a -> HS.HashSet a+elems = foldr HS.union HS.empty
+ test/Data/TimeMapSpec.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE+ GeneralizedNewtypeDeriving+ #-}++module Data.TimeMapSpec (spec) where++import Data.TimeMap (TimeMap)+import qualified Data.TimeMap as TM++import Data.Maybe (isJust, isNothing)+import Test.Tasty+import Test.Tasty.QuickCheck as QC+import Test.QuickCheck+import Test.QuickCheck.Instances++import Control.Concurrent (threadDelay)+++spec :: TestTree+spec = testGroup "Data.TimeMap"+ [ QC.testProperty "lookups should always succeed after insertion"+ lookupInsertExists+ , QC.testProperty "lookups should always fail after deletion"+ lookupDeleteNotExists+ , QC.testProperty "lookups should always fail after waiting past the time"+ lookupAgoNotExists+ , QC.testProperty "lookups should always succeed after waiting before the time"+ lookupAgoExists+ ]+++type Key = Integer+type Content = Integer+++newtype BuiltTimeMap = BuiltTimeMap+ { getBuiltTimeMap :: [(Key, Content)]+ } deriving (Show, Arbitrary)++buildTimeMap :: BuiltTimeMap -> IO (TimeMap Key Content)+buildTimeMap xs = do+ x <- TM.newTimeMap+ mapM_ (\(k,v) -> TM.insert k v x) $ getBuiltTimeMap xs+ return x+++lookupInsertExists :: Key -> Content -> BuiltTimeMap -> Property+lookupInsertExists k v xs = ioProperty $ do+ x <- buildTimeMap xs+ TM.insert k v x+ isJust <$> 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++lookupAgoNotExists :: Key -> Content -> BuiltTimeMap -> Property+lookupAgoNotExists k v xs = ioProperty $ do+ x <- buildTimeMap xs+ TM.insert k v x+ threadDelay 1000000+ TM.filterFromNow 1 x+ isNothing <$> TM.lookup k x++lookupAgoExists :: Key -> Content -> BuiltTimeMap -> Property+lookupAgoExists k v xs = ioProperty $ do+ x <- buildTimeMap xs+ TM.insert k v x+ threadDelay 500000+ TM.filterFromNow 1 x+ isJust <$> TM.lookup k x
+ test/Spec.hs view
@@ -0,0 +1,13 @@+module Main where++import Data.TimeMapSpec++import Test.Tasty+++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Testing..."+ [spec]
+ timemap.cabal view
@@ -0,0 +1,94 @@+Name: timemap+Version: 0.0.0+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++Flag ThreadScope+ Description: Build the threadscope benchmark+ Default: False++Library+ Default-Language: Haskell2010+ HS-Source-Dirs: src+ GHC-Options: -Wall+ Exposed-Modules: Data.TimeMap+ Other-Modules: Data.TimeMap.Internal+ Build-Depends: base >= 4.8 && < 5+ , containers+ , hashable+ , hashtables+ , stm+ , time+ , unordered-containers++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+ , hashable+ , hashtables+ , stm+ , time+ , unordered-containers+ , tasty+ , tasty-quickcheck+ , tasty-hunit+ , QuickCheck+ , quickcheck-instances++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+ , hashable+ , hashtables+ , stm+ , time+ , unordered-containers+ , criterion++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+ , hashable+ , hashtables+ , stm+ , time+ , unordered-containers++Source-Repository head+ Type: git+ Location: https://github.com/athanclark/timemap