{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}

-- | GuardedEvents implements guarded events for channels.
module Events.GuardedChannels(
   GuardedChannel,
      -- parameterised on the guard and the value,
      --
      -- instance of HasSend, HasListen (and hence automatically HasReceive)

   GQ,VQ, -- Type abbreviations, used in the next declaration.
   newGuardedChannel,
      -- :: HasGuardedChannel guardQueue valueQueue guard value
      -- => GQ guardQueue value -> VQ valueQueue
      --    IO GuardedChannel guard value
      -- the guardQueue and valueQueue are not read, and just provide
      -- the types to use.

   sneak,
      -- :: ( .. context .. )
      -- => GuardedChannel guard value
      -- -> GuardedEvent guard (Maybe value)
   replace,
      -- :: ( .. context .. )
      -- => GuardedChannel guard value -> value
      -- -> GuardedEvent guard (Maybe value)

   -- Classes the user should instance to construct different sorts of
   -- queue.  Actually you only need to instance HasEmpty, HasRemove and
   -- HasAdd, since the others just
   HasEmpty(..),
   HasRemove(..),
   HasAdd(..),

   CanSendX,
   HasGuardedChannel,
   ) where

import Control.Concurrent

import Util.Computation (done)

import Events.Toggle

import Events.Events
import Events.GuardedEvents

-- ---------------------------------------------------------------
-- Guarded Channels and their creation.
-- ---------------------------------------------------------------

data GuardedChannel guard value =
   forall guardQueue valueQueue .
      HasGuardedChannel guardQueue valueQueue guard value
   => GuardedChannel (MVar (Contents guardQueue valueQueue value))

data Contents guardQueue valueQueue value =
   Contents !(guardQueue (GuardInfo value)) !(valueQueue ValueInfo)

-- GuardInfo and ValueInfo give toggles + continuations
type GuardInfo value = ToggledData (IO value -> IO ())
type ValueInfo = ToggledData (IO () -> IO ())

type GQ guardQueue value = guardQueue (GuardInfo value)
type VQ valueQueue = valueQueue ValueInfo

newGuardedChannel :: HasGuardedChannel guardQueue valueQueue guard value
   => GQ guardQueue value -> VQ valueQueue
   -> IO (GuardedChannel guard value)
newGuardedChannel :: GQ guardQueue value
-> VQ valueQueue -> IO (GuardedChannel guard value)
newGuardedChannel
      (GQ guardQueue value
_ :: guardQueue (GuardInfo value)) (VQ valueQueue
_ :: valueQueue ValueInfo) =
   do
      (GQ guardQueue value
emptyGuardQueue :: guardQueue (GuardInfo value)) <- IO (GQ guardQueue value)
forall (xQueue :: * -> *) xData.
HasEmpty xQueue =>
IO (xQueue xData)
newEmpty
      (VQ valueQueue
emptyValueQueue :: valueQueue ValueInfo) <- IO (VQ valueQueue)
forall (xQueue :: * -> *) xData.
HasEmpty xQueue =>
IO (xQueue xData)
newEmpty
      MVar (Contents guardQueue valueQueue value)
mVar <- Contents guardQueue valueQueue value
-> IO (MVar (Contents guardQueue valueQueue value))
forall a. a -> IO (MVar a)
newMVar (GQ guardQueue value
-> VQ valueQueue -> Contents guardQueue valueQueue value
forall (guardQueue :: * -> *) (valueQueue :: * -> *) value.
guardQueue (GuardInfo value)
-> valueQueue ValueInfo -> Contents guardQueue valueQueue value
Contents GQ guardQueue value
emptyGuardQueue VQ valueQueue
emptyValueQueue)
      GuardedChannel guard value -> IO (GuardedChannel guard value)
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar (Contents guardQueue valueQueue value)
-> GuardedChannel guard value
forall guard value (guardQueue :: * -> *) (valueQueue :: * -> *).
HasGuardedChannel guardQueue valueQueue guard value =>
MVar (Contents guardQueue valueQueue value)
-> GuardedChannel guard value
GuardedChannel MVar (Contents guardQueue valueQueue value)
mVar)

-- ---------------------------------------------------------------
-- Implementing the channel events
-- ---------------------------------------------------------------

instance HasListen GuardedChannel where
   listen :: GuardedChannel guard a -> GuardedEvent guard a
listen (GuardedChannel MVar (Contents guardQueue valueQueue a)
mVar) =
      (guard -> Event a) -> guard -> GuardedEvent guard a
forall guard a. (guard -> Event a) -> guard -> GuardedEvent guard a
GuardedEvent
         (\ guard
guard -> (Toggle -> (IO a -> IO ()) -> IO Result) -> Event a
forall a. (Toggle -> (IO a -> IO ()) -> IO Result) -> Event a
Event (
            \ Toggle
toggle IO a -> IO ()
guardContinuation ->
               do
                  (Contents guardQueue (GuardInfo a)
guardQueue valueQueue ValueInfo
valueQueue) <- MVar (Contents guardQueue valueQueue a)
-> IO (Contents guardQueue valueQueue a)
forall a. MVar a -> IO a
takeMVar MVar (Contents guardQueue valueQueue a)
mVar
                  (guardQueue (GuardInfo a)
guardQueue2,valueQueue ValueInfo
valueQueue2,SendResult a (IO () -> IO ())
sendResult) <- guardQueue (GuardInfo a)
-> valueQueue ValueInfo
-> Toggle
-> guard
-> (IO a -> IO ())
-> IO
     (guardQueue (GuardInfo a), valueQueue ValueInfo,
      SendResult a (IO () -> IO ()))
forall (xQueue :: * -> *) (yQueue :: * -> *) x y xContinuation
       yContinuation.
CanSendX xQueue yQueue x y =>
xQueue (ToggledData xContinuation)
-> yQueue (ToggledData yContinuation)
-> Toggle
-> x
-> xContinuation
-> IO
     (xQueue (ToggledData xContinuation),
      yQueue (ToggledData yContinuation), SendResult y yContinuation)
sendX
                     guardQueue (GuardInfo a)
guardQueue valueQueue ValueInfo
valueQueue Toggle
toggle guard
guard IO a -> IO ()
guardContinuation
                  MVar (Contents guardQueue valueQueue a)
-> Contents guardQueue valueQueue a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Contents guardQueue valueQueue a)
mVar (guardQueue (GuardInfo a)
-> valueQueue ValueInfo -> Contents guardQueue valueQueue a
forall (guardQueue :: * -> *) (valueQueue :: * -> *) value.
guardQueue (GuardInfo value)
-> valueQueue ValueInfo -> Contents guardQueue valueQueue value
Contents guardQueue (GuardInfo a)
guardQueue2 valueQueue ValueInfo
valueQueue2)
                  -- Now perform the continuations if any and return.
                  case SendResult a (IO () -> IO ())
sendResult of
                     SendResult a (IO () -> IO ())
Anticipated -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
Immediate
                     Queued IO ()
invalidate -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> Result
Awaiting IO ()
invalidate)
                     Matched a
value IO () -> IO ()
valueContinuation ->
                        do
                           IO () -> IO ()
valueContinuation (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                           IO a -> IO ()
guardContinuation (a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
value)
                           Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
Immediate
               )
            )
         guard
forall guard. Guard guard => guard
nullGuard

instance Guard guard => HasReceive (GuardedChannel guard) where
   receive :: GuardedChannel guard a -> Event a
receive = GuardedEvent guard a -> Event a
forall (eventType :: * -> *) a.
HasEvent eventType =>
eventType a -> Event a
toEvent (GuardedEvent guard a -> Event a)
-> (GuardedChannel guard a -> GuardedEvent guard a)
-> GuardedChannel guard a
-> Event a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GuardedChannel guard a -> GuardedEvent guard a
forall (chan :: * -> * -> *) guard a.
(HasListen chan, Guard guard) =>
chan guard a -> GuardedEvent guard a
listen

instance HasSend (GuardedChannel guard) where
   send :: GuardedChannel guard a -> a -> Event ()
send (GuardedChannel MVar (Contents guardQueue valueQueue a)
mVar :: GuardedChannel guard value)
      (a
value :: value)  =
      (Toggle -> (IO () -> IO ()) -> IO Result) -> Event ()
forall a. (Toggle -> (IO a -> IO ()) -> IO Result) -> Event a
Event (
         \ Toggle
toggle IO () -> IO ()
valueContinuation ->
            do
               (Contents guardQueue (GuardInfo a)
guardQueue valueQueue ValueInfo
valueQueue) <- MVar (Contents guardQueue valueQueue a)
-> IO (Contents guardQueue valueQueue a)
forall a. MVar a -> IO a
takeMVar MVar (Contents guardQueue valueQueue a)
mVar
               (valueQueue ValueInfo
valueQueue2,guardQueue (GuardInfo a)
guardQueue2,SendResult guard (IO a -> IO ())
sendResult)
                  <- valueQueue ValueInfo
-> guardQueue (GuardInfo a)
-> Toggle
-> a
-> (IO () -> IO ())
-> IO
     (valueQueue ValueInfo, guardQueue (GuardInfo a),
      SendResult guard (IO a -> IO ()))
forall (xQueue :: * -> *) (yQueue :: * -> *) x y xContinuation
       yContinuation.
CanSendX xQueue yQueue x y =>
xQueue (ToggledData xContinuation)
-> yQueue (ToggledData yContinuation)
-> Toggle
-> x
-> xContinuation
-> IO
     (xQueue (ToggledData xContinuation),
      yQueue (ToggledData yContinuation), SendResult y yContinuation)
sendX valueQueue ValueInfo
valueQueue guardQueue (GuardInfo a)
guardQueue Toggle
toggle a
value IO () -> IO ()
valueContinuation
               MVar (Contents guardQueue valueQueue a)
-> Contents guardQueue valueQueue a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Contents guardQueue valueQueue a)
mVar (guardQueue (GuardInfo a)
-> valueQueue ValueInfo -> Contents guardQueue valueQueue a
forall (guardQueue :: * -> *) (valueQueue :: * -> *) value.
guardQueue (GuardInfo value)
-> valueQueue ValueInfo -> Contents guardQueue valueQueue value
Contents guardQueue (GuardInfo a)
guardQueue2 valueQueue ValueInfo
valueQueue2)
               -- Now perform the continuations if any and return.
               case SendResult guard (IO a -> IO ())
sendResult of
                  SendResult guard (IO a -> IO ())
Anticipated -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
Immediate
                  Queued IO ()
invalidate -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> Result
Awaiting IO ()
invalidate)
                  Matched (guard
guard :: guard) IO a -> IO ()
guardContinuation ->
                        do
                           IO () -> IO ()
valueContinuation (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                           IO a -> IO ()
guardContinuation (a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
value)
                           Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
Immediate
         )

atomicUpdate :: Guard guard => (value -> value) -> GuardedChannel guard value
   -> GuardedEvent guard (Maybe value)
-- atomicUpdate updateFn
-- is like listen except (a) it doesn't wait, instead returning
-- Nothing if it can't match immediately; (b) if it can match immediately,
-- it computes a new value and puts it back into the queue (at the end),
-- without leaving a gap, so that even if someone attempts to poll the
-- channel at this moment they won't see a point when it's empty;
-- it also returns the original value.
atomicUpdate :: (value -> value)
-> GuardedChannel guard value -> GuardedEvent guard (Maybe value)
atomicUpdate value -> value
updateFn (GuardedChannel MVar (Contents guardQueue valueQueue value)
mVar :: GuardedChannel guard value) =
   (guard -> Event (Maybe value))
-> guard -> GuardedEvent guard (Maybe value)
forall guard a. (guard -> Event a) -> guard -> GuardedEvent guard a
GuardedEvent (
      \ (guard
guard :: guard) -> (Toggle -> (IO (Maybe value) -> IO ()) -> IO Result)
-> Event (Maybe value)
forall a. (Toggle -> (IO a -> IO ()) -> IO Result) -> Event a
Event (
         \ Toggle
toggle IO (Maybe value) -> IO ()
guardContinuation ->
            do
               (Contents guardQueue (GuardInfo value)
guardQueue valueQueue ValueInfo
valueQueue) <- MVar (Contents guardQueue valueQueue value)
-> IO (Contents guardQueue valueQueue value)
forall a. MVar a -> IO a
takeMVar MVar (Contents guardQueue valueQueue value)
mVar
               (guardQueue (GuardInfo value)
guardQueue2,valueQueue ValueInfo
valueQueue2,
                     SendResult value (IO () -> IO ())
sendResult :: (SendResult value (IO () -> IO ())))
                  <- guardQueue (GuardInfo value)
-> valueQueue ValueInfo
-> Toggle
-> guard
-> (IO value -> IO ())
-> IO
     (guardQueue (GuardInfo value), valueQueue ValueInfo,
      SendResult value (IO () -> IO ()))
forall (xQueue :: * -> *) (yQueue :: * -> *) x y xContinuation
       yContinuation.
CanSendX xQueue yQueue x y =>
xQueue (ToggledData xContinuation)
-> yQueue (ToggledData yContinuation)
-> Toggle
-> x
-> xContinuation
-> IO
     (xQueue (ToggledData xContinuation),
      yQueue (ToggledData yContinuation), SendResult y yContinuation)
sendX guardQueue (GuardInfo value)
guardQueue valueQueue ValueInfo
valueQueue Toggle
toggle guard
guard
                     (\ IO value
valueAct -> IO (Maybe value) -> IO ()
guardContinuation
                        (IO value
valueAct IO value -> (value -> IO (Maybe value)) -> IO (Maybe value)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe value -> IO (Maybe value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe value -> IO (Maybe value))
-> (value -> Maybe value) -> value -> IO (Maybe value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. value -> Maybe value
forall a. a -> Maybe a
Just)))
               case SendResult value (IO () -> IO ())
sendResult of
                  SendResult value (IO () -> IO ())
Anticipated ->
                     do
                        MVar (Contents guardQueue valueQueue value)
-> Contents guardQueue valueQueue value -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Contents guardQueue valueQueue value)
mVar (guardQueue (GuardInfo value)
-> valueQueue ValueInfo -> Contents guardQueue valueQueue value
forall (guardQueue :: * -> *) (valueQueue :: * -> *) value.
guardQueue (GuardInfo value)
-> valueQueue ValueInfo -> Contents guardQueue valueQueue value
Contents guardQueue (GuardInfo value)
guardQueue2 valueQueue ValueInfo
valueQueue2)
                        Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
Immediate
                  Queued IO ()
invalidate ->
                     do
                        MVar (Contents guardQueue valueQueue value)
-> Contents guardQueue valueQueue value -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Contents guardQueue valueQueue value)
mVar (guardQueue (GuardInfo value)
-> valueQueue ValueInfo -> Contents guardQueue valueQueue value
forall (guardQueue :: * -> *) (valueQueue :: * -> *) value.
guardQueue (GuardInfo value)
-> valueQueue ValueInfo -> Contents guardQueue valueQueue value
Contents guardQueue (GuardInfo value)
guardQueue2 valueQueue ValueInfo
valueQueue2)
                        -- force the event to happen anyway
                        Bool
resultNothing <- Toggle -> IO Bool
toggle1 Toggle
toggle
                        if Bool
resultNothing
                           then
                              do
                                 IO ()
invalidate
                                 IO (Maybe value) -> IO ()
guardContinuation (Maybe value -> IO (Maybe value)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe value
forall a. Maybe a
Nothing)
                           else
                              IO ()
forall (m :: * -> *). Monad m => m ()
done
                        Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
Immediate
                  Matched value
value IO () -> IO ()
valueContinuation ->
                     do
                        let newValue :: value
newValue = value -> value
updateFn value
value
                        Toggle
toggle' <- IO Toggle
newToggle
                        (valueQueue ValueInfo
valueQueue3,guardQueue (GuardInfo value)
guardQueue3,
                           SendResult guard (IO value -> IO ())
sendResult :: SendResult guard (IO value -> IO()))
                           <- valueQueue ValueInfo
-> guardQueue (GuardInfo value)
-> Toggle
-> value
-> (IO () -> IO ())
-> IO
     (valueQueue ValueInfo, guardQueue (GuardInfo value),
      SendResult guard (IO value -> IO ()))
forall (xQueue :: * -> *) (yQueue :: * -> *) x y xContinuation
       yContinuation.
CanSendX xQueue yQueue x y =>
xQueue (ToggledData xContinuation)
-> yQueue (ToggledData yContinuation)
-> Toggle
-> x
-> xContinuation
-> IO
     (xQueue (ToggledData xContinuation),
      yQueue (ToggledData yContinuation), SendResult y yContinuation)
sendX valueQueue ValueInfo
valueQueue2 guardQueue (GuardInfo value)
guardQueue2 Toggle
toggle' value
newValue
                              (\ IO ()
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                        MVar (Contents guardQueue valueQueue value)
-> Contents guardQueue valueQueue value -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Contents guardQueue valueQueue value)
mVar (guardQueue (GuardInfo value)
-> valueQueue ValueInfo -> Contents guardQueue valueQueue value
forall (guardQueue :: * -> *) (valueQueue :: * -> *) value.
guardQueue (GuardInfo value)
-> valueQueue ValueInfo -> Contents guardQueue valueQueue value
Contents guardQueue (GuardInfo value)
guardQueue3 valueQueue ValueInfo
valueQueue3)
                        -- execute all the continuations we have, and return.
                        IO () -> IO ()
valueContinuation (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                        IO (Maybe value) -> IO ()
guardContinuation (Maybe value -> IO (Maybe value)
forall (m :: * -> *) a. Monad m => a -> m a
return (value -> Maybe value
forall a. a -> Maybe a
Just value
value))
                        case SendResult guard (IO value -> IO ())
sendResult of
                           Queued IO ()
invalidate -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
Immediate
                           -- We never invalidate this event.
                           Matched (guard
guard :: guard) IO value -> IO ()
guardContinuation ->
                              do
                                 IO value -> IO ()
guardContinuation (value -> IO value
forall (m :: * -> *) a. Monad m => a -> m a
return value
newValue)
                                 Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
Immediate
                           -- Anticipated should be impossible here.
            )
         )
      guard
forall guard. Guard guard => guard
nullGuard



sneak :: Guard guard => GuardedChannel guard value
   -> GuardedEvent guard (Maybe value)
sneak :: GuardedChannel guard value -> GuardedEvent guard (Maybe value)
sneak GuardedChannel guard value
guardedChannel = (value -> value)
-> GuardedChannel guard value -> GuardedEvent guard (Maybe value)
forall guard value.
Guard guard =>
(value -> value)
-> GuardedChannel guard value -> GuardedEvent guard (Maybe value)
atomicUpdate value -> value
forall a. a -> a
id GuardedChannel guard value
guardedChannel

replace :: Guard guard => GuardedChannel guard value -> value
   -> GuardedEvent guard (Maybe value)
replace :: GuardedChannel guard value
-> value -> GuardedEvent guard (Maybe value)
replace GuardedChannel guard value
guardedChannel value
newValue = (value -> value)
-> GuardedChannel guard value -> GuardedEvent guard (Maybe value)
forall guard value.
Guard guard =>
(value -> value)
-> GuardedChannel guard value -> GuardedEvent guard (Maybe value)
atomicUpdate (value -> value -> value
forall a b. a -> b -> a
const value
newValue) GuardedChannel guard value
guardedChannel

-- ---------------------------------------------------------------
-- The classes the user should instance.
-- ---------------------------------------------------------------

class HasEmpty xQueue where
   newEmpty :: IO (xQueue xData)

class HasRemove yQueue x y where
   remove :: yQueue yData -> x ->
      IO (Maybe (y,yData,IO (yQueue yData)),yQueue yData)
   -- remove yQueue x attempts to match an x with a value in yQueue.
   -- It returns a pair.
   -- If there is no match, we get (Nothing,newQueue)
   -- If there is a match, we get (Just(y,yData,restoreQueue),newQueue)
   -- where newQueue is the queue with the match removed, and
   -- restoreQueue is an action which restores the queue to the way it
   -- was before.

class HasAdd xQueue x where
   add :: xQueue xData -> x -> xData -> IO (xQueue xData,IO ())

class (HasRemove yQueue x y,HasAdd xQueue x) =>
   CanSendX xQueue yQueue x y

instance (HasRemove yQueue x y,HasAdd xQueue x) =>
   CanSendX xQueue yQueue x y

class (Guard guard,HasEmpty guardQueue,HasEmpty valueQueue,
   CanSendX guardQueue valueQueue guard value,
   CanSendX valueQueue guardQueue value guard)
   => HasGuardedChannel guardQueue valueQueue guard value

instance (Guard guard,HasEmpty guardQueue,HasEmpty valueQueue,
   CanSendX guardQueue valueQueue guard value,
   CanSendX valueQueue guardQueue value guard)
   => HasGuardedChannel guardQueue valueQueue guard value

-- ---------------------------------------------------------------
-- Implementing searching for matching events.
-- ---------------------------------------------------------------

data ToggledData continuation = ToggledData !Toggle continuation

data SendResult y yContinuation =
      Matched y yContinuation
      -- the event has been matched with this y + Continuation.
   |  Queued (IO ())
      -- the event has been queued; the supplied action may be used to
      -- cancel it, once the toggle for this synchronisation has been
      -- toggled by someone.
   |  Anticipated
      -- The toggle for the synchronisation has already been toggled by
      -- someone else.

sendX :: (CanSendX xQueue yQueue x y)
   => xQueue (ToggledData xContinuation) -> yQueue (ToggledData yContinuation)
   -> Toggle -> x -> xContinuation
   -> IO (xQueue (ToggledData xContinuation),
         yQueue (ToggledData yContinuation),(SendResult y yContinuation))
sendX :: xQueue (ToggledData xContinuation)
-> yQueue (ToggledData yContinuation)
-> Toggle
-> x
-> xContinuation
-> IO
     (xQueue (ToggledData xContinuation),
      yQueue (ToggledData yContinuation), SendResult y yContinuation)
sendX xQueue (ToggledData xContinuation)
xQueue yQueue (ToggledData yContinuation)
yQueue Toggle
xToggle x
x xContinuation
xContinuation =
   do
      (Maybe
  (y, ToggledData yContinuation,
   IO (yQueue (ToggledData yContinuation)))
match,yQueue (ToggledData yContinuation)
yQueue2) <- yQueue (ToggledData yContinuation)
-> x
-> IO
     (Maybe
        (y, ToggledData yContinuation,
         IO (yQueue (ToggledData yContinuation))),
      yQueue (ToggledData yContinuation))
forall (yQueue :: * -> *) x y yData.
HasRemove yQueue x y =>
yQueue yData
-> x -> IO (Maybe (y, yData, IO (yQueue yData)), yQueue yData)
remove yQueue (ToggledData yContinuation)
yQueue x
x
      case Maybe
  (y, ToggledData yContinuation,
   IO (yQueue (ToggledData yContinuation)))
match of
         Maybe
  (y, ToggledData yContinuation,
   IO (yQueue (ToggledData yContinuation)))
Nothing ->
         -- no matching event.  Add x to xQueue.
            do
               (xQueue (ToggledData xContinuation)
xQueue2,IO ()
invalidate) <-
                  xQueue (ToggledData xContinuation)
-> x
-> ToggledData xContinuation
-> IO (xQueue (ToggledData xContinuation), IO ())
forall (xQueue :: * -> *) x xData.
HasAdd xQueue x =>
xQueue xData -> x -> xData -> IO (xQueue xData, IO ())
add xQueue (ToggledData xContinuation)
xQueue x
x (Toggle -> xContinuation -> ToggledData xContinuation
forall continuation.
Toggle -> continuation -> ToggledData continuation
ToggledData Toggle
xToggle xContinuation
xContinuation)

               (xQueue (ToggledData xContinuation),
 yQueue (ToggledData yContinuation), SendResult y yContinuation)
-> IO
     (xQueue (ToggledData xContinuation),
      yQueue (ToggledData yContinuation), SendResult y yContinuation)
forall (m :: * -> *) a. Monad m => a -> m a
return (xQueue (ToggledData xContinuation)
xQueue2,yQueue (ToggledData yContinuation)
yQueue2,IO () -> SendResult y yContinuation
forall y yContinuation. IO () -> SendResult y yContinuation
Queued IO ()
invalidate)
         Just (y
y,ToggledData Toggle
yToggle yContinuation
yContinuation,IO (yQueue (ToggledData yContinuation))
getYQueue0) ->
         -- matching event found.  Attempt to handle it
            do
               Maybe (Bool, Bool)
toggled <- Toggle -> Toggle -> IO (Maybe (Bool, Bool))
toggle2 Toggle
xToggle Toggle
yToggle
               case Maybe (Bool, Bool)
toggled of
                  Maybe (Bool, Bool)
Nothing -> -- toggle successful
                     (xQueue (ToggledData xContinuation),
 yQueue (ToggledData yContinuation), SendResult y yContinuation)
-> IO
     (xQueue (ToggledData xContinuation),
      yQueue (ToggledData yContinuation), SendResult y yContinuation)
forall (m :: * -> *) a. Monad m => a -> m a
return (xQueue (ToggledData xContinuation)
xQueue,yQueue (ToggledData yContinuation)
yQueue2,y -> yContinuation -> SendResult y yContinuation
forall y yContinuation.
y -> yContinuation -> SendResult y yContinuation
Matched y
y yContinuation
yContinuation)
                  Just (Bool
True,Bool
False) ->
                     -- toggle failed because the matching event has been
                     -- done.  Repeat with remaining queue.
                     xQueue (ToggledData xContinuation)
-> yQueue (ToggledData yContinuation)
-> Toggle
-> x
-> xContinuation
-> IO
     (xQueue (ToggledData xContinuation),
      yQueue (ToggledData yContinuation), SendResult y yContinuation)
forall (xQueue :: * -> *) (yQueue :: * -> *) x y xContinuation
       yContinuation.
CanSendX xQueue yQueue x y =>
xQueue (ToggledData xContinuation)
-> yQueue (ToggledData yContinuation)
-> Toggle
-> x
-> xContinuation
-> IO
     (xQueue (ToggledData xContinuation),
      yQueue (ToggledData yContinuation), SendResult y yContinuation)
sendX xQueue (ToggledData xContinuation)
xQueue yQueue (ToggledData yContinuation)
yQueue2 Toggle
xToggle x
x xContinuation
xContinuation
                  Just (Bool
False,Bool
True) ->
                     -- toggle failed because the event we are synchronising
                     -- on has been done.  So put the item back on the yQueue
                     -- and return
                     do
                        yQueue (ToggledData yContinuation)
yQueue0 <- IO (yQueue (ToggledData yContinuation))
getYQueue0
                        (xQueue (ToggledData xContinuation),
 yQueue (ToggledData yContinuation), SendResult y yContinuation)
-> IO
     (xQueue (ToggledData xContinuation),
      yQueue (ToggledData yContinuation), SendResult y yContinuation)
forall (m :: * -> *) a. Monad m => a -> m a
return (xQueue (ToggledData xContinuation)
xQueue,yQueue (ToggledData yContinuation)
yQueue0,SendResult y yContinuation
forall y yContinuation. SendResult y yContinuation
Anticipated)
                  Just (Bool
False,Bool
False) ->
                     -- both of the above . . .
                     (xQueue (ToggledData xContinuation),
 yQueue (ToggledData yContinuation), SendResult y yContinuation)
-> IO
     (xQueue (ToggledData xContinuation),
      yQueue (ToggledData yContinuation), SendResult y yContinuation)
forall (m :: * -> *) a. Monad m => a -> m a
return (xQueue (ToggledData xContinuation)
xQueue,yQueue (ToggledData yContinuation)
yQueue2,SendResult y yContinuation
forall y yContinuation. SendResult y yContinuation
Anticipated)
                  Just (Bool
True,Bool
True) ->
                     -- toggle failed because we are synchronising
                     -- a send and listen operation on the same channel.
                     do
                        (matchRest :: (xQueue (ToggledData xContinuation),
 yQueue (ToggledData yContinuation), SendResult y yContinuation)
matchRest @ (xQueue (ToggledData xContinuation)
xQueue3,yQueue (ToggledData yContinuation)
yQueue3,SendResult y yContinuation
success)) <-
                           xQueue (ToggledData xContinuation)
-> yQueue (ToggledData yContinuation)
-> Toggle
-> x
-> xContinuation
-> IO
     (xQueue (ToggledData xContinuation),
      yQueue (ToggledData yContinuation), SendResult y yContinuation)
forall (xQueue :: * -> *) (yQueue :: * -> *) x y xContinuation
       yContinuation.
CanSendX xQueue yQueue x y =>
xQueue (ToggledData xContinuation)
-> yQueue (ToggledData yContinuation)
-> Toggle
-> x
-> xContinuation
-> IO
     (xQueue (ToggledData xContinuation),
      yQueue (ToggledData yContinuation), SendResult y yContinuation)
sendX xQueue (ToggledData xContinuation)
xQueue yQueue (ToggledData yContinuation)
yQueue2 Toggle
xToggle x
x xContinuation
xContinuation
                        case SendResult y yContinuation
success of
                           Queued IO ()
_ ->
                              -- the xToggle event was added to xQueue3,
                              -- so put the event we just rejected back on
                              -- the yQueue
                              do
                                 yQueue (ToggledData yContinuation)
yQueue0 <- IO (yQueue (ToggledData yContinuation))
getYQueue0
                                 (xQueue (ToggledData xContinuation),
 yQueue (ToggledData yContinuation), SendResult y yContinuation)
-> IO
     (xQueue (ToggledData xContinuation),
      yQueue (ToggledData yContinuation), SendResult y yContinuation)
forall (m :: * -> *) a. Monad m => a -> m a
return (xQueue (ToggledData xContinuation)
xQueue3,yQueue (ToggledData yContinuation)
yQueue0,SendResult y yContinuation
success)
                           SendResult y yContinuation
_ ->
                              -- Otherwise the containing synchronisation has
                              -- been satisfied, and thus the original matched
                              -- event, which is also part of that
                              -- synchronisation, can be thrown away.  This is
                              -- good, because otherwise I don't know what
                              -- we'd do with it.
                              (xQueue (ToggledData xContinuation),
 yQueue (ToggledData yContinuation), SendResult y yContinuation)
-> IO
     (xQueue (ToggledData xContinuation),
      yQueue (ToggledData yContinuation), SendResult y yContinuation)
forall (m :: * -> *) a. Monad m => a -> m a
return (xQueue (ToggledData xContinuation),
 yQueue (ToggledData yContinuation), SendResult y yContinuation)
matchRest