module RealTimeQueue (Queue, createQueue, RealTimeQueue.null, scheduleEvent, extractScheduledEvents, scheduleEventIO, runScheduledIO) where
import BasePrelude hiding ((<>))
import System.Clock
import Data.IntPSQ as Q
import Control.Monad.IO.Class
import Data.Semigroup

-- The intended interface of this library is mainly the three functions
-- ''createQueue'', ''scheduleEventIO'' and ''runScheduledIO''.

createQueue :: Queue event
createQueue = Queue Q.empty 0

-- The IO commands wrap pure code alternatives (which are also exported), using
-- MonadIO to add management of the clock and the ability to run a user-supplied
-- handler. The ''Monotonic'' clock type from ''System.Clock'' is used to define
-- scheduling priorities internally, but these functions expect time to be
-- specified relative to the present.

scheduleEventIO :: MonadIO m => (TimeSpec, event) -> Queue event -> m (Queue event)
scheduleEventIO (ts, ev) queue = do
    now <- liftIO $ getTime Monotonic
    return $ scheduleEvent (ts + now, ev) queue

runScheduledIO :: MonadIO m => TimeSpec -> QueueRunner m event -> Queue event -> m (Queue event)
runScheduledIO timeSpan runner queue = do
    now <- liftIO $ getTime Monotonic
    let (events, queue') = extractScheduledEvents now timeSpan queue
    forM_ events $ \(ts, ev) -> runner (ts - now, ev)
    return queue'

null :: Queue event -> Bool
null (Queue q _) = Q.null q




-- The queue runner receives a time, relative to the present, at which the event
-- is scheduled to occur. Thus, it can wait for this amount of time if desired
-- (or, in the case of ALSA, push the event onto the kernel queue with this
-- amount of delay).

-- It is possible for this time to be negative, in which case the event was
-- scheduled to happen in the past.

type QueueRunner m event = (TimeSpec, event) -> m ()




-- It is important that the keys are never re-used. Therefore the constructor is
-- not exported.

-- (Yes, the keys can wrap around, but if your usage is anything remotely like a
-- FIFO, the earlier keys will be removed before they get reused. In order to
-- ensure that the keys _never_ wrap, IntPSQ could be replaced with HashPSQ and
-- the key type made Integer, but then the size of the keys would increase over
-- time.)

data Queue event = Queue {
    _intQueue :: IntPSQ TimeSpec event,
    _nextKey :: Int
}
instance Semigroup (Queue event) where
    _ <> q = q





-- These three functions provide a pure interface to the schedule queue. They
-- are agnostic as to the definition of time, but the IO versions below expect
-- that time should always be defined by the ''Monotonic'' clock in
-- System.Clock.

-- Schedule an event using absolute time.
scheduleEvent :: (TimeSpec, event) -> Queue event -> Queue event
scheduleEvent (ts, ev) (Queue q i) = Queue (Q.insert i ts ev q) (i+1)

-- Given an absolute current time and a timespan (relative to current) into the
-- future, remove and return all events from the queue that are scheduled
-- earlier than the end of the timespan.

-- The returned events specify their time as relative to the supplied absolute
-- current time.
extractScheduledEvents :: TimeSpec -> TimeSpec -> Queue event -> ([(TimeSpec, event)], Queue event)
extractScheduledEvents currentTime timeSpan = getAllScheduled
    where
        getAllScheduled :: Queue event -> ([(TimeSpec, event)], Queue event)
        getAllScheduled queue@(Queue q i)
            | isNothing $ getFirstScheduled queue = ([], queue)
            | otherwise = let (Just (_, p, v, q')) = minView q
                              queue' = Queue q' i
                          in ([(p, v)], queue') <> getAllScheduled queue'


        getFirstScheduled :: Queue event -> Maybe (TimeSpec, event)
        getFirstScheduled (Queue x _) = case findMin x of
            Nothing -> Nothing
            Just (_, ts, _) | ts > currentTime + timeSpan -> Nothing
            Just (_, ts, ev) -> Just (ts - currentTime, ev)