module Control.Concurrent.Priority.Room
(Room,
newRoom,
inUse,
Claim,
claimedRoom,
claimedThread,
userData,
UserData,
RoomGroup(..),
RoomConstraint(..),
BaseRoomContext(..),
RoomContext(..),
MaxThreads(..),
ClaimMode(..),
DefaultRoomContext(..),
UnconstrainedRoomContext(..),
claim,
approveClaims)
where
import Control.Concurrent.Priority.RoomCore as RoomCore
import Control.Concurrent.Priority.RoomConstraint
import Control.Concurrent.STM
import Control.Monad
import Data.Map as Map
import Data.List as List
data DefaultRoomContext u = Default
data UnconstrainedRoomContext u = Unconstrained
type family UserData u :: *
type instance UserData (Room u) = u
type instance UserData [Room u] = u
type instance UserData (DefaultRoomContext u) = u
type instance UserData (UnconstrainedRoomContext u) = u
type instance UserData (c,m) = UserData c
class RoomGroup m where
roomsOf :: m -> [Room (UserData m)]
instance RoomGroup (Room u) where
roomsOf m = [m]
instance RoomGroup [Room u] where
roomsOf = id
instance RoomGroup (DefaultRoomContext u) where
roomsOf = const []
instance RoomGroup (UnconstrainedRoomContext u) where
roomsOf = const []
instance (UserData c ~ UserData m,RoomGroup c,RoomGroup m) => RoomGroup (c,m) where
roomsOf (c,m) = roomsOf c ++ roomsOf m
class BaseRoomContext c where
type BaseRoomContextData c :: *
approveClaimsEntering :: c -> [Claim (UserData c)] -> STM (BaseRoomContextData c)
approveClaimsExiting :: c -> [Claim (UserData c)] -> STM (BaseRoomContextData c)
waitingAction :: c -> (BaseRoomContextData c) -> STM ()
instance (RoomConstraint u) => BaseRoomContext (DefaultRoomContext u) where
type BaseRoomContextData (DefaultRoomContext u) = ()
approveClaimsEntering _ cs = approveClaims cs >> return ()
approveClaimsExiting _ cs = approveClaims cs >> return ()
waitingAction _ () = return ()
instance BaseRoomContext (UnconstrainedRoomContext u) where
type BaseRoomContextData (UnconstrainedRoomContext u) = ()
approveClaimsEntering _ cs = mapM_ approve cs >> return ()
approveClaimsExiting _ cs = mapM_ approve cs >> return ()
waitingAction _ _ = return ()
instance (BaseRoomContext c,Base m ~ DefaultRoomContext (UserData m)) => BaseRoomContext (c,m) where
type BaseRoomContextData (c,m) = BaseRoomContextData c
approveClaimsEntering = approveClaimsEntering . fst
approveClaimsExiting = approveClaimsExiting . fst
waitingAction = waitingAction . fst
class RoomContext c where
type Base c :: *
baseContext :: c -> Base c
instance (RoomConstraint u) => RoomContext (Room u) where
type Base (Room u) = DefaultRoomContext u
baseContext = const Default
instance (RoomConstraint u) => RoomContext [Room u] where
type Base [Room u] = DefaultRoomContext u
baseContext = const Default
instance (BaseRoomContext c,Base m ~ DefaultRoomContext (UserData m)) => RoomContext (c,m) where
type Base (c,m) = c
baseContext = fst
claim :: (RoomGroup c,RoomContext c,BaseRoomContext (Base c),UserData c ~ UserData (Base c)) => ClaimMode -> c -> IO a -> IO a
claim claim_mode c actionIO =
do let c' = baseContext c
room_context_data <- newTVarIO (error "claim: BaseRoomContextData not yet available (please report a bug against the priority package)")
claim_ (Map.fromList $ Prelude.map (flip (,) claim_mode) $ roomsOf c)
(\cs -> writeTVar room_context_data =<< approveClaimsEntering c' cs)
(\cs -> writeTVar room_context_data =<< approveClaimsExiting c' cs)
(waitingAction c' =<< readTVar room_context_data)
actionIO