RoomConstraint.hs

module PrioritySync.Internal.RoomConstraint
    (RoomConstraint(..),
     MaxThreads(..),
     approveClaims)
    where

import PrioritySync.Internal.RoomCore
import Control.Concurrent.STM
import Control.Monad
import Data.Set as Set

class RoomConstraint u where
    -- | Should either 'approve' or 'retry' each claim.
    approveConstraint :: Claim a -> u -> STM ()

instance RoomConstraint () where
    approveConstraint c () = approve c

instance RoomConstraint Bool where -- this is pointless but means we support RoomConstraint (STM Bool)
    approveConstraint c True = approve c
    approveConstraint _ False = retry

-- | A maximum limit on the number of threads allowed to claim a room.
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

-- | 'approve' some claims according to their constraints.
approveClaims :: (RoomConstraint u) => [Claim u] -> STM ()
approveClaims = mapM_ (\c -> approveConstraint c $ userData $ claimedRoom c)