module Control.Concurrent.CHP.EventType (
Event, EventMap, EventSet, getEventTVar, getEventType, getEventTypeVal, getEventUnique, getEventPriority, newEvent, newEventPri,
Offer(signalValue, offerAction, eventsSet),
OfferSet(signalVar, offersSet, processId), makeOfferSet,
RecordedEventType(..),
SignalVar, SignalValue(..), addPoison, nullSignalValue, isNullSignal
) where
import Control.Arrow
import Data.Function (on)
import qualified Data.Map as Map
import Data.Unique
import Control.Concurrent
import Control.Concurrent.STM
import Control.Concurrent.CHP.Poison
import Control.Concurrent.CHP.ProcessId
type EventMap v = [(Event, v)]
type EventSet = [Event]
type OfferSetSet = [OfferSet]
data RecordedEventType
= ChannelComm String
| BarrierSync String
| ClockSync String deriving (Eq, Ord, Show)
getEventTypeVal :: RecordedEventType -> String
getEventTypeVal (ChannelComm s) = s
getEventTypeVal (BarrierSync s) = s
getEventTypeVal (ClockSync s) = s
data Event = Event {
getEventUnique :: Unique,
getEventPriority :: Int,
getEventType :: STM RecordedEventType,
getEventTVar :: TVar (WithPoison
(Int,
Integer,
OfferSetSet)
)}
instance Eq Event where
(==) = (==) `on` getEventUnique
instance Ord Event where
compare = compare `on` getEventUnique
instance Show Event where
show e = "Event " ++ show (hashUnique $ getEventUnique e)
newEvent :: STM RecordedEventType -> Int -> IO Event
newEvent t n
= do u <- newUnique
atomically $ do tv <- newTVar (NoPoison (n, 0, []))
return $ Event u 0 t tv
newEventPri :: STM RecordedEventType -> Int -> Int -> IO Event
newEventPri t n pri
= do u <- newUnique
atomically $ do tv <- newTVar (NoPoison (n, 0, []))
return $ Event u pri t tv
newtype SignalValue = Signal (WithPoison Int)
deriving (Eq, Show)
type SignalVar = TVar (Maybe (SignalValue, Map.Map Unique (Integer, RecordedEventType)))
addPoison :: SignalValue -> SignalValue
addPoison = const $ Signal PoisonItem
nullSignalValue :: SignalValue
nullSignalValue = Signal $ NoPoison (1)
isNullSignal :: SignalValue -> Bool
isNullSignal (Signal n) = n == NoPoison (1)
data Offer = Offer {signalValue :: SignalValue, offerAction :: STM (), eventsSet :: EventSet}
data OfferSet = OfferSet { signalVar :: SignalVar
, threadId :: ThreadId
, processId :: ProcessId
, offersSet :: [Offer]}
instance Eq OfferSet where
(==) = (==) `on` threadId
instance Ord OfferSet where
compare = compare `on` threadId
instance Show OfferSet where
show os = "OfferSet " ++ show (processId os, map (signalValue &&& eventsSet) $ offersSet os)
makeOfferSet :: SignalVar -> ProcessId -> ThreadId -> [((SignalValue, STM ()), EventSet)] -> OfferSet
makeOfferSet v pid tid = OfferSet v tid pid . map (uncurry (uncurry Offer))