module Control.Concurrent.Priority.RoomConstraint
(RoomConstraint(..),
MaxThreads(..),
approveClaims)
where
import Control.Concurrent.Priority.RoomCore
import Control.Concurrent.STM
import Control.Monad
import Data.Set as Set
class RoomConstraint u where
approveConstraint :: Claim a -> u -> STM ()
instance RoomConstraint () where
approveConstraint c () = approve c
instance RoomConstraint Bool where
approveConstraint c True = approve c
approveConstraint _ False = retry
newtype MaxThreads = MaxThreads Int
instance RoomConstraint MaxThreads where
approveConstraint c (MaxThreads n) =
do s <- liftM (Set.size . Set.insert (claimedThread c)) $ inUse $ claimedRoom c
approveConstraint c $ s <= n
instance (RoomConstraint u) => RoomConstraint (STM u) where
approveConstraint c actionSTM = approveConstraint c =<< actionSTM
instance (RoomConstraint a,RoomConstraint b) => RoomConstraint (a,b) where
approveConstraint c (a,b) =
do approveConstraint c a
approveConstraint c b
instance (RoomConstraint a,RoomConstraint b) => RoomConstraint (Either a b) where
approveConstraint c = either (approveConstraint c) (approveConstraint c)
instance (RoomConstraint a) => RoomConstraint (Maybe a) where
approveConstraint c = maybe (approveConstraint c ()) $ approveConstraint c
approveClaims :: (RoomConstraint u) => [Claim u] -> STM ()
approveClaims = mapM_ (\c -> approveConstraint c $ userData $ claimedRoom c)