{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}
module Data.Schedule.Internal where
import Data.Bifunctor (first)
import Data.Text (Text, pack)
import Data.Word (Word64)
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
import qualified Data.Map.Strict as M
import qualified Data.Rsv.RMMap as RM
import qualified Data.Set as S
import Data.Rsv.RMMap (RMMap)
type Tick = Integer
type TickDelta = Word64
newtype Task t = Task (RM.Delete Tick t)
deriving (Show, Read, Generic, Eq, Ord)
data TaskStatus t =
TaskNotPending
| TaskPending !Tick !t
| TaskRunning !t
deriving (Show, Read, Generic, Eq, Ord)
data Schedule t = Schedule {
now :: !Tick
, tasks :: !(RMMap Tick t)
, pending :: !(S.Set (Task t))
, running :: !(Maybe (Task t, t))
} deriving (Show, Read, Generic, Eq)
newSchedule :: Schedule t
newSchedule =
Schedule { now = 0, tasks = RM.empty, pending = mempty, running = Nothing }
checkValidity :: Schedule t -> Maybe Text
checkValidity Schedule {..} =
let tasksValid = RM.checkValidity tasks
tasks' = RM.content tasks
nowMatch = case M.lookupMin tasks' of
Nothing -> True
Just (nextTaskTick, _) -> now <= nextTaskTick
pending' = S.fromList $ Task <$> RM.toList tasks
in case tasksValid of
Just e -> Just e
Nothing
| not nowMatch -> Just $ pack "has tasks for before now"
| pending /= pending' -> Just $ pack "inconsistent pending tasks"
| otherwise -> Nothing
checkTask :: Schedule t -> Task t -> Bool
checkTask sch (Task d) = RM.checkHandle (tasks sch) d
tickNow :: Schedule t -> Tick
tickNow = now
tickPrev :: Schedule t -> Tick
tickPrev = pred . now
ticksToIdle :: Schedule t -> Maybe TickDelta
ticksToIdle Schedule {..} = do
(m, _) <- M.lookupMin (RM.content tasks)
pure (fromIntegral (m - now))
taskStatus :: HasCallStack => Task t -> Schedule t -> TaskStatus t
taskStatus t@(Task d) Schedule {..} = if S.member t pending
then case RM.unqueue d tasks of
(Nothing , _) -> error "inconsistent pending tasks"
(Just (tick, tParams), _) -> TaskPending tick tParams
else case running of
Just (t', tParams) | t == t' -> TaskRunning tParams
_ -> TaskNotPending
after :: TickDelta -> t -> Schedule t -> (Task t, Schedule t)
after tDelta tParams s0@(Schedule now tasks0 pending0 _) =
let tick = now + toInteger tDelta
(d, tasks1) = RM.enqueue (tick, tParams) tasks0
pending1 = S.insert (Task d) pending0
in (Task d, s0 { tasks = tasks1, pending = pending1 })
cancel :: Task t -> Schedule t -> (Maybe t, Schedule t)
cancel (Task d) s0@(Schedule _ tasks0 pending0 _) = case RM.unqueue d tasks0 of
(Nothing, _) -> (Nothing, s0)
(Just (_, tParams), tasks1) ->
let pending1 = S.delete (Task d) pending0
in (Just tParams, s0 { tasks = tasks1, pending = pending1 })
cancel_ :: Task t -> Schedule t -> ((), Schedule t)
cancel_ t s = ((), snd $ cancel t s)
renew :: TickDelta -> Task t -> Schedule t -> (Maybe (Task t), Schedule t)
renew tDelta (Task d) s0 = case RM.unqueue d (tasks s0) of
(Nothing, _) -> (Nothing, s0)
(Just (_, tParams), tasks1) ->
first Just $ after tDelta tParams (s0 { tasks = tasks1 })
popOrTick :: HasCallStack => Schedule t -> (Maybe (Task t, t), Schedule t)
popOrTick s0@(Schedule now0 tasks0 pending0 running) = case running of
Just _ -> error "tried to pop tick while task was running"
Nothing -> case RM.dequeue now0 tasks0 of
(Nothing, _) -> (Nothing, s0 { now = succ now0 })
(Just (d, tParams), tasks1) ->
let pending1 = S.delete (Task d) pending0
in (Just (Task d, tParams), s0 { tasks = tasks1, pending = pending1 })
acquireTask :: HasCallStack => (Task t, t) -> Schedule t -> Schedule t
acquireTask k s = case running s of
Just _ -> error "tried to acquire on unreleased task"
_ -> s { running = Just k }
releaseTask :: HasCallStack => Task t -> Schedule t -> Schedule t
releaseTask t s = case running s of
Just (t', _) | t' == t -> s { running = Nothing }
_ -> error "tried to release on unacquired task"