Schedule.hs

{-# LANGUAGE TypeFamilies, UndecidableInstances #-}

module PrioritySync.Internal.Schedule
    (Schedule(..))
    where

import PrioritySync.Internal.UserData
import PrioritySync.Internal.Room
import PrioritySync.Internal.Queue
import PrioritySync.Internal.ClaimContext
import PrioritySync.Internal.RoomGroup
import Control.Concurrent.STM
import Control.Monad
import Data.List

-- | Schedule a task to run from a prioritized 'Queue'.  The task will wait until it arrives at (or, with failover, near) the top of queue.  Typical usage:
--
-- > Schedule q 2 room1
--
-- Only the rooms inside the 'Schedule' declaration are claimed with scheduling.  If access to a room doesn't need to be prioritized, it can be set outside
-- the schedule:
--
-- > (Schedule q 2 room1,room2)
--
data Schedule p c = Schedule (Queue p) p c

type instance UserData (Schedule p c) = UserData c

instance (RoomGroup c) => RoomGroup (Schedule p c) where
    roomsOf (Schedule _ _ c) = roomsOf c

instance (Ord p,RoomGroup c,ClaimContext c,ClaimHandle c ~ ()) => ClaimContext (Schedule p c) where
    type ClaimHandle (Schedule p c) = Maybe (TaskHandle p)
    approveClaimsEntering = scheduleClaims approveClaimsEntering
    approveClaimsExiting = scheduleClaims approveClaimsExiting
    waitingAction (Schedule _ _ c) Nothing = waitingAction c ()
    waitingAction (Schedule _ _ c) (Just task) = 
        flip unless retry . or =<< mapM (\m -> m >> return True `orElse` return False) [pullFromTop task >> return (), waitingAction c ()]

scheduleClaims :: (Ord p,RoomGroup c,ClaimContext c,ClaimHandle c ~ ()) => 
    (c -> [Claim (UserData c)] -> STM ()) -> Schedule p c -> [Claim (UserData c)] -> STM (Maybe (TaskHandle p))
scheduleClaims approveClaimsX (Schedule _ _ c) cs | null (intersect (map claimedRoom cs) $ roomsOf c) = approveClaimsX c cs >> return Nothing
scheduleClaims approveClaimsX (Schedule q p c) cs = liftM Just $ putTask q p (approveClaimsX c cs)