{-# LANGUAGE TypeFamilies, UndecidableInstances #-}

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

-- | Schedule a task to run from a prioritized 'Queue'.
--
-- Tasks that do not actually make claims against any of the 'Schedule's internal 'Room's will skip scheduling and the 'Room's will be claimed immediately using 'DefaultRoomContext'.  This is usually
-- what you want, in particular in the case where no rooms are actually being claimed, e.g. reentrant scheduling.
--
-- In other words:
--
-- Always wrong:
--
-- > (Schedule q 2 Default,[room1,room2])
--
-- Right:
--
-- > Schedule q 2 (Default,[room1,room2])
--
-- Alternately, if you only want to schedule access to @room1@, you can place @room1@ internally and @room2@ externally.  'Schedule' will be smart about when to schedule and when not to schedule:
--
-- > (Schedule q 2 (Default,room1), room2)
--
-- The 'Default' applies internally and externally to the 'Schedule'.  In the following example, 'Unconstrained' applies to both @room1@ and @room2@:
--
-- > (Schedule q 2 (Unconstrained,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,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