{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}

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

-- | Require that all 'RoomConstraint's be satisfied when acquiring a 'Room'.  This is the default.
data DefaultRoomContext u = Default

-- | Don't check any 'RoomConstraint's when acquiring a 'Room'.
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

-- | Rules for calling 'claim_'.  The two major contexts are 'DefaultRoomContext', which uses 'RoomConstraint's to
-- determine which 'Room's are available, and 'UnconstrainedRoomContext', which does not place any constraints on any 'Room'.
class BaseRoomContext c where
    type BaseRoomContextData c :: *
    -- | Should approve a some claims before entering a critical section, as described by 'claim_'.
    approveClaimsEntering :: c -> [Claim (UserData c)] -> STM (BaseRoomContextData c)
    -- | Should approve a some claims before exiting a critical section, as described by 'claim_'.
    approveClaimsExiting :: c -> [Claim (UserData c)] -> STM (BaseRoomContextData c)
    -- | A waiting transaction, as described by 'claim_'.
    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

-- | An indirect reference to a 'BaseRoomContext'.
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

-- | Temporarily 'Acquire', and then release, or 'Release', and then acquire, some 'Room's for the duration of a critical section.
-- A simple example where a room might be used to prevent interleaving of 'stdout':
--
-- > room <- newRoom (MaxThreads 1)
-- > forkIO $ claim Acquire room $ putStrLn "Hello World!"
-- > forkIO $ claim Acquire room $ putStrLn "Foo!  Bar!"
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