module Events.Channels(
Channel,
newChannel,
) where
import Control.Concurrent
import Util.Computation(done)
import Util.Queue
import Events.Toggle
import Events.Events
newtype Channel a = Channel (MVar (Queue (Toggle,a,IO () -> IO ()),
Queue (Toggle,IO a -> IO ()),Int))
data Res a = None | Anticipated | Found a
cleanPar :: Int
cleanPar = 10
newChannel :: IO (Channel a)
newChannel =
do
mVar <- newMVar (emptyQ,emptyQ,0)
return (Channel mVar)
instance HasSend Channel where
send (Channel mVar) value = Event (
\ toggle continuation ->
do
(sQueue,rQueue,counter) <- takeMVar mVar
(rQueueOut,res) <- matchSend toggle rQueue
case res of
None ->
do
let
sQueue2 = insertQ sQueue (toggle,value,continuation)
(sQueue3,counter) <-
if counter>=cleanPar
then
do
sQueue3 <- cleanSends sQueue2
return (sQueue3,0)
else
return (sQueue2,counter+1)
putMVar mVar (sQueue3,rQueueOut,counter)
return(Awaiting done)
Anticipated ->
do
putMVar mVar (sQueue,rQueueOut,counter)
return Immediate
Found acontinuation ->
do
putMVar mVar (sQueue,rQueueOut,0)
continuation (return ())
acontinuation (return value)
return Immediate)
cleanSends :: Queue (Toggle,a,IO () -> IO ())
-> IO (Queue (Toggle,a,IO () -> IO()))
cleanSends queue =
case removeQ queue of
Nothing -> return emptyQ
Just (sendReg@(toggle,_,_),rest) ->
do
peek <- peekToggle toggle
if peek
then
return (insertAtEndQ rest sendReg)
else
cleanSends rest
matchSend :: Toggle -> Queue (Toggle,IO a -> IO ())
-> IO (Queue (Toggle,IO a -> IO ()),Res (IO a -> IO ()))
matchSend sendToggle queueIn =
case removeQ queueIn of
Nothing -> return (queueIn,None)
Just (rc@(receiveToggle,continuation),queueOut) ->
do
tog <- toggle2 sendToggle receiveToggle
case tog of
Nothing -> return (queueOut,Found continuation)
Just(True,True) ->
do
match2 <- matchSend sendToggle queueOut
case match2 of
(queueOut,None) ->
return (insertAtEndQ queueOut rc,None)
(queueOut,Anticipated) ->
return (queueOut,Anticipated)
(queueOut,found) ->
return (queueOut,found)
Just(True,False) -> matchSend sendToggle queueOut
Just(False,True) ->
return (insertAtEndQ queueOut rc,Anticipated)
Just(False,False) -> return (queueOut,Anticipated)
instance HasReceive Channel where
receive (Channel mVar) = Event (
\ toggle acontinuation ->
do
(sQueue,rQueue,counter) <- takeMVar mVar
(sQueueOut,res) <- matchReceive toggle sQueue
case res of
None ->
do
let
rQueue2 = insertQ rQueue (toggle,acontinuation)
(rQueue3,counter) <-
if counter>=cleanPar
then
do
rQueue3 <- cleanReceives rQueue2
return (rQueue3,0)
else
return (rQueue2,counter+1)
putMVar mVar (sQueueOut,rQueue3,counter)
return(Awaiting done)
Anticipated ->
do
putMVar mVar (sQueueOut,rQueue,counter)
return Immediate
Found (value,continuation) ->
do
putMVar mVar (sQueueOut,rQueue,counter)
continuation (return ())
acontinuation (return value)
return Immediate
)
matchReceive :: Toggle -> Queue (Toggle,a,IO () -> IO ())
-> IO (Queue (Toggle,a,IO () -> IO ()),Res (a,IO () -> IO ()))
matchReceive receiveToggle queueIn =
case removeQ queueIn of
Nothing -> return (queueIn,None)
Just (rc@(sendToggle,value,continuation),queueOut) ->
do
tog <- toggle2 receiveToggle sendToggle
case tog of
Nothing -> return (queueOut,Found (value,continuation))
Just(True,True) ->
do
match2 <- matchReceive receiveToggle queueOut
case match2 of
(queueOut,None) ->
return (insertAtEndQ queueOut rc,None)
(queueOut,Anticipated) ->
return (queueOut,Anticipated)
(queueOut,found) ->
return (queueOut,found)
Just(True,False) -> matchReceive receiveToggle queueOut
Just(False,True) ->
return (insertAtEndQ queueOut rc,Anticipated)
Just(False,False) -> return (queueOut,Anticipated)
cleanReceives :: Queue (Toggle,IO a -> IO ())
-> IO (Queue (Toggle,IO a -> IO ()))
cleanReceives queue =
case removeQ queue of
Nothing -> return emptyQ
Just (receiveReg@(toggle,_),rest) ->
do
peek <- peekToggle toggle
if peek
then
return (insertAtEndQ rest receiveReg)
else
cleanReceives rest