module Events.GuardedChannels(
GuardedChannel,
GQ,VQ,
newGuardedChannel,
sneak,
replace,
HasEmpty(..),
HasRemove(..),
HasAdd(..),
CanSendX,
HasGuardedChannel,
) where
import Control.Concurrent
import Util.Computation (done)
import Events.Toggle
import Events.Events
import Events.GuardedEvents
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)
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
(_ :: guardQueue (GuardInfo value)) (_ :: valueQueue ValueInfo) =
do
(emptyGuardQueue :: guardQueue (GuardInfo value)) <- newEmpty
(emptyValueQueue :: valueQueue ValueInfo) <- newEmpty
mVar <- newMVar (Contents emptyGuardQueue emptyValueQueue)
return (GuardedChannel mVar)
instance HasListen GuardedChannel where
listen (GuardedChannel mVar) =
GuardedEvent
(\ guard -> Event (
\ toggle guardContinuation ->
do
(Contents guardQueue valueQueue) <- takeMVar mVar
(guardQueue2,valueQueue2,sendResult) <- sendX
guardQueue valueQueue toggle guard guardContinuation
putMVar mVar (Contents guardQueue2 valueQueue2)
case sendResult of
Anticipated -> return Immediate
Queued invalidate -> return (Awaiting invalidate)
Matched value valueContinuation ->
do
valueContinuation (return ())
guardContinuation (return value)
return Immediate
)
)
nullGuard
instance Guard guard => HasReceive (GuardedChannel guard) where
receive = toEvent . listen
instance HasSend (GuardedChannel guard) where
send (GuardedChannel mVar :: GuardedChannel guard value)
(value :: value) =
Event (
\ toggle valueContinuation ->
do
(Contents guardQueue valueQueue) <- takeMVar mVar
(valueQueue2,guardQueue2,sendResult)
<- sendX valueQueue guardQueue toggle value valueContinuation
putMVar mVar (Contents guardQueue2 valueQueue2)
case sendResult of
Anticipated -> return Immediate
Queued invalidate -> return (Awaiting invalidate)
Matched (guard :: guard) guardContinuation ->
do
valueContinuation (return ())
guardContinuation (return value)
return Immediate
)
atomicUpdate :: Guard guard => (value -> value) -> GuardedChannel guard value
-> GuardedEvent guard (Maybe value)
atomicUpdate updateFn (GuardedChannel mVar :: GuardedChannel guard value) =
GuardedEvent (
\ (guard :: guard) -> Event (
\ toggle guardContinuation ->
do
(Contents guardQueue valueQueue) <- takeMVar mVar
(guardQueue2,valueQueue2,
sendResult :: (SendResult value (IO () -> IO ())))
<- sendX guardQueue valueQueue toggle guard
(\ valueAct -> guardContinuation
(valueAct >>= (return . Just)))
case sendResult of
Anticipated ->
do
putMVar mVar (Contents guardQueue2 valueQueue2)
return Immediate
Queued invalidate ->
do
putMVar mVar (Contents guardQueue2 valueQueue2)
resultNothing <- toggle1 toggle
if resultNothing
then
do
invalidate
guardContinuation (return Nothing)
else
done
return Immediate
Matched value valueContinuation ->
do
let newValue = updateFn value
toggle' <- newToggle
(valueQueue3,guardQueue3,
sendResult :: SendResult guard (IO value -> IO()))
<- sendX valueQueue2 guardQueue2 toggle' newValue
(\ _ -> return ())
putMVar mVar (Contents guardQueue3 valueQueue3)
valueContinuation (return ())
guardContinuation (return (Just value))
case sendResult of
Queued invalidate -> return Immediate
Matched (guard :: guard) guardContinuation ->
do
guardContinuation (return newValue)
return Immediate
)
)
nullGuard
sneak :: Guard guard => GuardedChannel guard value
-> GuardedEvent guard (Maybe value)
sneak guardedChannel = atomicUpdate id guardedChannel
replace :: Guard guard => GuardedChannel guard value -> value
-> GuardedEvent guard (Maybe value)
replace guardedChannel newValue = atomicUpdate (const newValue) guardedChannel
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)
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
data ToggledData continuation = ToggledData !Toggle continuation
data SendResult y yContinuation =
Matched y yContinuation
| Queued (IO ())
| Anticipated
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 yQueue xToggle x xContinuation =
do
(match,yQueue2) <- remove yQueue x
case match of
Nothing ->
do
(xQueue2,invalidate) <-
add xQueue x (ToggledData xToggle xContinuation)
return (xQueue2,yQueue2,Queued invalidate)
Just (y,ToggledData yToggle yContinuation,getYQueue0) ->
do
toggled <- toggle2 xToggle yToggle
case toggled of
Nothing ->
return (xQueue,yQueue2,Matched y yContinuation)
Just (True,False) ->
sendX xQueue yQueue2 xToggle x xContinuation
Just (False,True) ->
do
yQueue0 <- getYQueue0
return (xQueue,yQueue0,Anticipated)
Just (False,False) ->
return (xQueue,yQueue2,Anticipated)
Just (True,True) ->
do
(matchRest @ (xQueue3,yQueue3,success)) <-
sendX xQueue yQueue2 xToggle x xContinuation
case success of
Queued _ ->
do
yQueue0 <- getYQueue0
return (xQueue3,yQueue0,success)
_ ->
return matchRest