{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, FlexibleContexts, ExistentialQuantification, RankNTypes #-}
module At
    ( AtQ
    , at
    , deleteAtQ
    , newAtQ
    ) where

import Control.Concurrent (ThreadId, forkIO, killThread, threadDelay)
import Control.Concurrent.MVar (MVar, modifyMVar, modifyMVar_, newMVar)
import Control.Monad (forever)
import Data.Function (on)
import Data.List (insertBy)
import Data.Time 

data AtQ 
    = AtQ (MVar [AtEvent]) ThreadId

data AtEvent 
    = AtEvent { atTime  :: UTCTime
              , action  :: IO ()
              }

-- | start a new at queue.
newAtQ :: Int -- ^ how often to process in queue (in seconds)
       -> IO AtQ
newAtQ period =
    do ref <- newMVar []
       tid <- forkIO $ forever $ runAtQ ref >> threadDelay (period * 10^6)
       return (AtQ ref tid)

-- | kill the queue.
-- 
-- Remaining events will not be run.
deleteAtQ :: AtQ -> IO ()
deleteAtQ (AtQ _ tid) = killThread tid

-- | run a 
at :: AtQ -> UTCTime -> IO a -> IO ()
at (AtQ eventsMVar _) time action =
    modifyMVar_ eventsMVar $ 
      return . insertBy (compare `on` atTime) (AtEvent time (action >> return ()))

runAtQ :: MVar [AtEvent] -> IO ()
runAtQ eventsMVar =
    do now <- getCurrentTime
       events <- modifyMVar eventsMVar $  \events ->
                   let (ready, later) = span ((<= now) . atTime) events
                   in return (later, ready)
       mapM_ (forkIO . action) events

test =
    do atq <- newAtQ 2
       now <- getCurrentTime
       at atq now (putStrLn "hello, world!")
       at atq (addUTCTime (fromIntegral 10) now) (putStrLn "goodbye, world!" >> deleteAtQ atq)