Permalink
Browse files

Added a data structure for tracking timeouts

  • Loading branch information...
1 parent 7292f91 commit b4e785ada516e798baf83d438720c27c537184a5 @gregorycollins committed with tibbe Dec 23, 2009
Showing with 179 additions and 0 deletions.
  1. +2 −0 event.cabal
  2. +120 −0 src/System/Event/TimeoutTable.hs
  3. +57 −0 src/System/Event/TimeoutTable/Internal.hs
View
@@ -22,6 +22,8 @@ library
System.Event.Array
System.Event.Internal
System.Event.Vector
+ System.Event.TimeoutTable
+ System.Event.TimeoutTable.Internal
build-depends:
array,
@@ -0,0 +1,120 @@
+{-# LANGUAGE BangPatterns #-}
+
+module System.Event.TimeoutTable
+ ( TimeoutTable
+ , empty
+ , null
+ , findOldest
+ , find
+ , fromList
+ , member
+ , insert
+ , delete
+ , update
+ ) where
+
+import qualified Data.List as List
+import qualified Data.Map as Map
+import Data.Maybe (fromJust)
+import Prelude hiding (null)
+
+import System.Event.TimeoutTable.Internal
+
+------------------------------------------------------------------------------
+{-| An empty TimeoutTable. -}
+empty :: TimeoutTable tm k a
+empty = TimeoutTable Map.empty Map.empty
+
+
+{-| Returns True if the table is empty. -}
+null :: TimeoutTable tm k a -> Bool
+null (TimeoutTable k _) = Map.null k
+
+
+{-| Create a TimeoutTable from a list -}
+fromList :: (Ord tm, Ord k) => [(tm, k, a)] -> TimeoutTable tm k a
+fromList = List.foldl' insOne empty
+ where
+ insOne !tab (!t,!a,!b) = insert t a b tab
+
+
+{-| Find the entry in the table with the first (oldest) expiry time. -}
+findOldest :: (Ord tm, Ord k) => TimeoutTable tm k a -> Maybe (tm, k, a)
+findOldest (TimeoutTable keys times) | Map.null keys = Nothing
+ | otherwise = Just (t, hd, snd el)
+ where
+ (t,l) = Map.findMin times
+ hd = head l
+ el = fromJust $ Map.lookup hd keys
+
+
+{-| Lookup a value by key. -}
+find :: (Ord tm, Ord k) => k -> TimeoutTable tm k a -> Maybe (tm, a)
+find k tab = Map.lookup k $ _keySet tab
+
+
+{-| Is the given key a member of the table? -}
+member :: (Ord tm, Ord k) => k -> TimeoutTable tm k a -> Bool
+member k tab = Map.member k $ _keySet tab
+
+
+{-| Add a new key-value-timeout mapping to the table. -}
+insert :: (Ord tm, Ord k) =>
+ tm -- ^ timeout for this mapping
+ -> k -- ^ key
+ -> a -- ^ value
+ -> TimeoutTable tm k a -- ^ table
+ -> TimeoutTable tm k a
+insert !tm !k !v !tab = TimeoutTable ks' ts'
+ where
+ !tab' = delete k tab
+ !ks = _keySet tab'
+ !ts = _timeSet tab'
+
+ !ks' = Map.insert k (tm,v) ks
+ !ts' = Map.insertWith' consHead tm [k] ts
+
+
+{-| Delete a key-value mapping from the table. -}
+delete :: (Ord tm, Ord k) => k -> TimeoutTable tm k a -> TimeoutTable tm k a
+delete !k !tab = maybe tab killIt mbTm
+ where
+ !ks = _keySet tab
+ !ts = _timeSet tab
+ !mbTm = Map.lookup k ks
+
+ killIt (!tm,_) = TimeoutTable ks' ts'
+ where
+ !ks' = Map.delete k ks
+ !ts' = removeFromTimeSet tm k ts
+
+
+{-| Update the timeout value for a key in the table. -}
+update :: (Ord tm, Ord k) =>
+ k -- ^ key to update
+ -> tm -- ^ new timeout value
+ -> TimeoutTable tm k a -- ^ table
+ -> TimeoutTable tm k a
+update !k !tm !tab = maybe tab updateIt mbTm
+ where
+ !ks = _keySet tab
+ !ts = _timeSet tab
+ !mbTm = Map.lookup k ks
+
+ updateIt (!oldTm, !v) = TimeoutTable ks' ts''
+ where
+ !ks' = Map.insert k (tm,v) ks
+ !ts' = removeFromTimeSet oldTm k ts
+ !ts'' = Map.insertWith' consHead tm [k] ts'
+
+
+------------------------------------------------------------------------------
+-- private functions follow
+------------------------------------------------------------------------------
+
+{-| Take the head of the first list and cons it to the second. Used w/
+ `Map.insertWith'` to insert values into the time set. -}
+consHead :: [a] -> [a] -> [a]
+consHead !xs !ys = x:ys
+ where
+ !x = head xs
@@ -0,0 +1,57 @@
+{-# LANGUAGE BangPatterns #-}
+
+module System.Event.TimeoutTable.Internal where
+
+import qualified Data.List as List
+import qualified Data.Map as Map
+import Data.Map (Map)
+import Data.Maybe (fromJust)
+import Prelude hiding (null)
+
+
+------------------------------------------------------------------------------
+{-|
+
+A TimeoutTable is a key-value mapping with an associated timeout value. You
+can:
+
+ * look up, query, delete, or modify values by key
+
+ * find the oldest (i.e. first to expire) entry in the table
+
+ * update the timeout value for a key
+
+-}
+
+data TimeoutTable tm k a = TimeoutTable
+ { _keySet :: !(Map k (tm, a))
+ , _timeSet :: !(Map tm [k]) }
+
+
+------------------------------------------------------------------------------
+instance (Show tm, Show k, Show a) => Show (TimeoutTable tm k a) where
+ show (TimeoutTable ks _) = "<TimeoutTable (" ++ show (fmap f ks) ++ ")>"
+
+ where
+ f :: (Show tm, Show a) => (tm, a) -> String
+ f x = show x
+
+
+
+------------------------------------------------------------------------------
+-- internal functions follow
+------------------------------------------------------------------------------
+
+removeFromTimeSet :: (Ord k, Ord tm) =>
+ tm
+ -> k
+ -> Map tm [k]
+ -> Map tm [k]
+removeFromTimeSet tm k ts = killIt old
+ where
+ old = fromJust $ Map.lookup tm ts
+ killIt ks = if List.null ks'
+ then Map.delete tm ts
+ else Map.insert tm ks' ts
+ where
+ !ks' = List.delete k ks

0 comments on commit b4e785a

Please sign in to comment.