hiccup-0.40: EventMgr.hs

module EventMgr (EventMgr,addEvent,getDue, emptyMgr) where
import Data.Time.Clock
import Util
import Data.List (sortBy,partition)
import Data.Unique
import Data.Ord (comparing)
import Control.Monad (liftM)

type EvtID = BString
data Event a = Evt { evtTime :: UTCTime, 
                           evtID :: EvtID, 
	                   evtAction :: a }

newtype EventMgr a = EventMgr [Event a]

emptyMgr = EventMgr []
mgrInsert evt (EventMgr evts) = EventMgr (sortBy (comparing evtTime) (evt:evts))  

getNextID :: IO EvtID
getNextID = do
  num <- liftM hashUnique newUnique
  return $! pack ("after#" ++ show num)
  
addEvent act deadline el = do
  id <- getNextID
  return $ (id, mgrInsert (Evt { evtTime = deadline, evtID = id, evtAction = act }) el)

getDue (EventMgr evts) = do
  currTime <- getCurrentTime
  let (due,rest) = partition (\x -> evtTime x <= currTime) evts
  return (map evtAction due, EventMgr rest)