module Control.Concurrent.Priority.Schedule
(Schedule(..))
where
import Control.Concurrent.Priority.Room
import Control.Concurrent.Priority.Queue
import Control.Concurrent.STM
import Control.Monad
import Data.List
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,BaseRoomContext c,BaseRoomContextData c ~ ()) => BaseRoomContext (Schedule p c) where
type BaseRoomContextData (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,BaseRoomContext c,BaseRoomContextData 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)
instance (BaseRoomContext (Schedule p c)) => RoomContext (Schedule p c) where
type Base (Schedule p c) = Schedule p c
baseContext = id