{- This module enables events to be scheduled for some time in the future.
 - 'initialize' starts the monitor thread.
 -}
module Hmpf.Monitor ( initialize
               , MonitorState
	       , scheduleAction
	       , scheduleActionAt 
	       , unscheduleAction ) where 

import Control.Concurrent
import Control.Concurrent.MVar
import System.IO
import System.Time
import System.Posix.Time
import System.Posix.Types
import Data.Maybe
import Hmpf.ApplicationTypes
import qualified Control.Monad.State as S


--Initialize the monitor
--We need to be careful not to create race conditions
initialize :: Session ()
initialize = do 
  mvar <- (S.get)
  st <- get
  v <- lift (takeMVar (scheduler st) )
  m <- lower monitor
  threadID <- lift . forkIO $ m
  lift (putMVar (scheduler st) (MonitorState [] threadID))


monitor :: Session ()
monitor =  do
 st <- get
 ms <- lift . takeMVar $ (scheduler st) -- monitorstate ( now empty )
 t <- lift epochTime
 let es = pending ms
     as = map ( snd . snd ) . filter ( (<t) . fst ) $ es
     rest =  filter ( (>=t) . fst ) es
 --lift (putStrLn ( "Pending: " ++ (show . length $ es )  ))
 lift $ putMVar (scheduler st) ( ms {pending = rest} )
 (foldr (>>) (return ()) as)
 lift (threadDelay 100000) -- 1/10th of a second
 monitor 

--Schedule an action to occur in n seconds
scheduleAction :: String -> Int -> Session () -> Session ()
scheduleAction k i f = do
 t <- lift epochTime
 let tt = toEnum ( fromEnum t + i )
 scheduleActionAt k tt f

--Schedule an action to occur at a specified time
scheduleActionAt ::  String -> EpochTime -> Session () -> Session ()
scheduleActionAt k time action = do
 mvar <- get >>= return . scheduler
 st <- lift (takeMVar mvar)
 let ps = ( time , ( k , action ) ) : ( pending st )
 lift $ putMVar mvar (st {pending=ps})
 return ()

unscheduleAction ::  String -> Session  (Maybe (Session ()))
unscheduleAction k = do
 mvar <- get >>= return . scheduler
 st <- lift $ takeMVar mvar
 let x = (lookup k) . map snd . pending $ st
     xs = filter ( (/= k) . fst . snd ) . pending $ st 
 lift $ putMVar mvar (st { pending = xs } )
 return x