module Events.Events(
Result(..),
Event(..),
HasEvent(..),
never,
always,
sync, poll,
(>>>=), (>>>),
(+>),
choose,
tryEV,
computeEvent,
wrapAbort,
noWait,
HasSend(..),
HasReceive(..),
sendIO,
receiveIO,
allowWhile,
Request(..),
request,
doRequest,
spawnEvent,
getAllQueued,
thenGetEvent,
thenEvent,
doneEvent,
syncNoWait
) where
import Control.Exception
import Control.Concurrent
import Control.Applicative
import Control.Monad
import Control.Monad.Fail
import Util.Computation
import Events.Toggle
import Events.Spawn
data Result = Immediate | Awaiting (IO ()) | AwaitingAlways (IO ())
newtype Event a = Event (Toggle -> (IO a -> IO ()) -> IO Result)
class HasEvent eventType where
toEvent :: eventType a -> Event a
instance HasEvent Event where
toEvent :: Event a -> Event a
toEvent = Event a -> Event a
forall a. a -> a
id
never :: Event a
never :: Event a
never = (Toggle -> (IO a -> IO ()) -> IO Result) -> Event a
forall a. (Toggle -> (IO a -> IO ()) -> IO Result) -> Event a
Event (\ Toggle
toggle IO a -> IO ()
aActSink -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> Result
Awaiting IO ()
forall (m :: * -> *). Monad m => m ()
done))
always :: IO a -> Event a
always :: IO a -> Event a
always IO a
aAction = (Toggle -> (IO a -> IO ()) -> IO Result) -> Event a
forall a. (Toggle -> (IO a -> IO ()) -> IO Result) -> Event a
Event (
\ Toggle
toggle IO a -> IO ()
aActSink ->
do
Toggle -> IO () -> IO ()
ifToggle Toggle
toggle (IO a -> IO ()
aActSink IO a
aAction)
Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
Immediate
)
(>>>=) :: Event a -> (a -> IO b) -> Event b
>>>= :: Event a -> (a -> IO b) -> Event b
(>>>=) (Event Toggle -> (IO a -> IO ()) -> IO Result
registerFn) a -> IO b
continuation = (Toggle -> (IO b -> IO ()) -> IO Result) -> Event b
forall a. (Toggle -> (IO a -> IO ()) -> IO Result) -> Event a
Event (
\ Toggle
toggle IO b -> IO ()
bActionSink ->
Toggle -> (IO a -> IO ()) -> IO Result
registerFn Toggle
toggle (
\ IO a
aAction ->
IO b -> IO ()
bActionSink (
do
a
a <- IO a
aAction
a -> IO b
continuation a
a
)
)
)
infixl 2 >>>=
(>>>) :: Event a -> IO b -> Event b
>>> :: Event a -> IO b -> Event b
(>>>) Event a
event IO b
continuation = Event a
event Event a -> (a -> IO b) -> Event b
forall a b. Event a -> (a -> IO b) -> Event b
>>>= (IO b -> a -> IO b
forall a b. a -> b -> a
const IO b
continuation)
infixl 2 >>>
{-# INLINE (>>>) #-}
(+>) :: Event a -> Event a -> Event a
+> :: Event a -> Event a -> Event a
(+>) (Event Toggle -> (IO a -> IO ()) -> IO Result
registerFn1) (Event Toggle -> (IO a -> IO ()) -> IO Result
registerFn2) = (Toggle -> (IO a -> IO ()) -> IO Result) -> Event a
forall a. (Toggle -> (IO a -> IO ()) -> IO Result) -> Event a
Event (
\ Toggle
toggle IO a -> IO ()
aActSink ->
do
Result
status1 <- Toggle -> (IO a -> IO ()) -> IO Result
registerFn1 Toggle
toggle IO a -> IO ()
aActSink
let
doSecond :: IO a -> IO Result
doSecond IO a
postAction1 =
do
let
doThird :: IO () -> m Result
doThird IO ()
postAction2 =Result -> m Result
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> Result
AwaitingAlways (
do
IO a
postAction1
IO ()
postAction2
))
Result
status2 <- Toggle -> (IO a -> IO ()) -> IO Result
registerFn2 Toggle
toggle IO a -> IO ()
aActSink
case Result
status2 of
Result
Immediate ->
do
IO a
postAction1
Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
Immediate
Awaiting IO ()
postAction2 -> IO () -> IO Result
forall (m :: * -> *). Monad m => IO () -> m Result
doThird IO ()
postAction2
AwaitingAlways IO ()
postAction2 -> IO () -> IO Result
forall (m :: * -> *). Monad m => IO () -> m Result
doThird IO ()
postAction2
case Result
status1 of
Result
Immediate -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
Immediate
Awaiting IO ()
postAction1 -> IO () -> IO Result
forall a. IO a -> IO Result
doSecond IO ()
postAction1
AwaitingAlways IO ()
postAction1 -> IO () -> IO Result
forall a. IO a -> IO Result
doSecond IO ()
postAction1
)
infixl 1 +>
choose :: [Event a] -> Event a
choose :: [Event a] -> Event a
choose [] = Event a
forall a. Event a
never
choose [Event a]
nonEmpty = (Event a -> Event a -> Event a) -> [Event a] -> Event a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Event a -> Event a -> Event a
forall a. Event a -> Event a -> Event a
(+>) [Event a]
nonEmpty
tryEV :: Event a -> Event (Either SomeException a)
tryEV :: Event a -> Event (Either SomeException a)
tryEV (Event Toggle -> (IO a -> IO ()) -> IO Result
registerFn) = (Toggle -> (IO (Either SomeException a) -> IO ()) -> IO Result)
-> Event (Either SomeException a)
forall a. (Toggle -> (IO a -> IO ()) -> IO Result) -> Event a
Event (
\ Toggle
toggle IO (Either SomeException a) -> IO ()
errorOraSink ->
Toggle -> (IO a -> IO ()) -> IO Result
registerFn Toggle
toggle (\ IO a
aAct ->
IO (Either SomeException a) -> IO ()
errorOraSink (IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
Control.Exception.try IO a
aAct)
)
)
computeEvent :: IO (Event a) -> Event a
computeEvent :: IO (Event a) -> Event a
computeEvent IO (Event a)
getEvent = (Toggle -> (IO a -> IO ()) -> IO Result) -> Event a
forall a. (Toggle -> (IO a -> IO ()) -> IO Result) -> Event a
Event (
\ Toggle
toggle IO a -> IO ()
aActSink ->
do
(Event Toggle -> (IO a -> IO ()) -> IO Result
registerFn) <- IO (Event a)
getEvent
Toggle -> (IO a -> IO ()) -> IO Result
registerFn Toggle
toggle IO a -> IO ()
aActSink
)
wrapAbort :: IO (Event a,IO ()) -> Event a
wrapAbort :: IO (Event a, IO ()) -> Event a
wrapAbort IO (Event a, IO ())
preAction =
IO (Event a) -> Event a
forall a. IO (Event a) -> Event a
computeEvent (
do
SimpleToggle
postDone <- IO SimpleToggle
newSimpleToggle
(Event Toggle -> (IO a -> IO ()) -> IO Result
registerFn,IO ()
postAction) <- IO (Event a, IO ())
preAction
let doAfter :: IO ()
doAfter = SimpleToggle -> IO () -> IO ()
ifSimpleToggle SimpleToggle
postDone IO ()
postAction
Event a -> IO (Event a)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Toggle -> (IO a -> IO ()) -> IO Result) -> Event a
forall a. (Toggle -> (IO a -> IO ()) -> IO Result) -> Event a
Event (
\ Toggle
toggle IO a -> IO ()
aActSink ->
do
Result
status <- Toggle -> (IO a -> IO ()) -> IO Result
registerFn Toggle
toggle
(\ IO a
aAct ->
do
SimpleToggle -> IO Bool
simpleToggle SimpleToggle
postDone
IO a -> IO ()
aActSink IO a
aAct
)
case Result
status of
Result
Immediate -> (IO ()
doAfter IO () -> IO Result -> IO Result
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
Immediate)
Awaiting IO ()
action -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> Result
Awaiting (IO ()
doAfter IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
action))
AwaitingAlways IO ()
action ->
Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> Result
AwaitingAlways (IO ()
doAfter IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
action))
))
)
sync :: Event a -> IO a
sync :: Event a -> IO a
sync (Event Toggle -> (IO a -> IO ()) -> IO Result
registerFn) =
do
Toggle
toggle <- IO Toggle
newToggle
MVar (IO a)
aActMVar <- IO (MVar (IO a))
forall a. IO (MVar a)
newEmptyMVar
Result
status <- Toggle -> (IO a -> IO ()) -> IO Result
registerFn Toggle
toggle (\ IO a
aAct -> MVar (IO a) -> IO a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (IO a)
aActMVar IO a
aAct)
IO a
aAct <- MVar (IO a) -> IO (IO a)
forall a. MVar a -> IO a
takeMVar MVar (IO a)
aActMVar
case Result
status of
AwaitingAlways IO ()
postAction -> IO ()
postAction
Result
_ -> IO ()
forall (m :: * -> *). Monad m => m ()
done
IO a
aAct
poll :: Event a -> IO (Maybe a)
poll :: Event a -> IO (Maybe a)
poll Event a
event =
Event (Maybe a) -> IO (Maybe a)
forall a. Event a -> IO a
sync (
(Event a
event Event a -> (a -> IO (Maybe a)) -> Event (Maybe a)
forall a b. Event a -> (a -> IO b) -> Event b
>>>= (\ a
a -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
a)))
Event (Maybe a) -> Event (Maybe a) -> Event (Maybe a)
forall a. Event a -> Event a -> Event a
+> (IO (Maybe a) -> Event (Maybe a)
forall a. IO a -> Event a
always (Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing))
)
noWait :: Event a -> Event ()
noWait :: Event a -> Event ()
noWait (Event Toggle -> (IO a -> IO ()) -> IO Result
registerFn) = (Toggle -> (IO () -> IO ()) -> IO Result) -> Event ()
forall a. (Toggle -> (IO a -> IO ()) -> IO Result) -> Event a
Event (
\ Toggle
toggle IO () -> IO ()
unitActSink ->
do
Toggle -> IO () -> IO ()
ifToggle Toggle
toggle (
do
Toggle
toggle' <- IO Toggle
newToggle
Toggle -> (IO a -> IO ()) -> IO Result
registerFn Toggle
toggle' (IO () -> IO a -> IO ()
forall a b. a -> b -> a
const IO ()
forall (m :: * -> *). Monad m => m ()
done)
IO () -> IO ()
unitActSink (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
IO ()
forall (m :: * -> *). Monad m => m ()
done
)
Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
Immediate
)
syncNoWait :: Event a -> IO ()
syncNoWait :: Event a -> IO ()
syncNoWait (Event Toggle -> (IO a -> IO ()) -> IO Result
registerFn) =
do
Toggle
toggle <- IO Toggle
newToggle
Toggle -> (IO a -> IO ()) -> IO Result
registerFn Toggle
toggle (IO () -> IO a -> IO ()
forall a b. a -> b -> a
const IO ()
forall (m :: * -> *). Monad m => m ()
done)
IO ()
forall (m :: * -> *). Monad m => m ()
done
{-# RULES
"syncNoWait" forall event . sync (noWait event) = syncNoWait event
"syncNoWait2"
forall event continuation . sync ((noWait event) >>>= continuation) =
(syncNoWait event >> continuation ())
#-}
class HasSend chan where
send :: chan a -> a -> Event ()
class HasReceive chan where
receive :: chan a -> Event a
sendIO :: HasSend chan => chan a -> a -> IO ()
sendIO :: chan a -> a -> IO ()
sendIO chan a
chan a
msg = Event () -> IO ()
forall a. Event a -> IO a
sync (chan a -> a -> Event ()
forall (chan :: * -> *) a. HasSend chan => chan a -> a -> Event ()
send chan a
chan a
msg)
receiveIO :: HasReceive chan => chan a -> IO a
receiveIO :: chan a -> IO a
receiveIO chan a
chan = Event a -> IO a
forall a. Event a -> IO a
sync (chan a -> Event a
forall (chan :: * -> *) a. HasReceive chan => chan a -> Event a
receive chan a
chan)
instance Monad Event where
>>= :: Event a -> (a -> Event b) -> Event b
(>>=) = Event a -> (a -> Event b) -> Event b
forall a b. Event a -> (a -> Event b) -> Event b
thenGetEvent
>> :: Event a -> Event b -> Event b
(>>) = Event a -> Event b -> Event b
forall a b. Event a -> Event b -> Event b
thenEvent
return :: a -> Event a
return = a -> Event a
forall a. a -> Event a
doneEvent
instance MonadFail Event where
fail :: String -> Event a
fail String
str = IO a -> Event a
forall a. IO a -> Event a
always (IOError -> IO a
forall a. IOError -> IO a
ioError (String -> IOError
userError String
str))
instance Applicative Event where
pure :: a -> Event a
pure = a -> Event a
forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: Event (a -> b) -> Event a -> Event b
(<*>) = Event (a -> b) -> Event a -> Event b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Functor Event where
fmap :: (a -> b) -> Event a -> Event b
fmap = (a -> b) -> Event a -> Event b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
thenGetEvent :: Event a -> (a -> Event b) -> Event b
thenGetEvent :: Event a -> (a -> Event b) -> Event b
thenGetEvent Event a
event1 a -> Event b
getEvent2 = Event a
event1 Event a -> (a -> IO b) -> Event b
forall a b. Event a -> (a -> IO b) -> Event b
>>>= (\ a
val -> Event b -> IO b
forall a. Event a -> IO a
sync(a -> Event b
getEvent2 a
val))
thenEvent :: Event a -> Event b -> Event b
thenEvent :: Event a -> Event b -> Event b
thenEvent Event a
event1 Event b
event2 = Event a
event1 Event a -> IO b -> Event b
forall a b. Event a -> IO b -> Event b
>>> (Event b -> IO b
forall a. Event a -> IO a
sync(Event b
event2))
doneEvent :: a -> Event a
doneEvent :: a -> Event a
doneEvent a
val = IO a -> Event a
forall a. IO a -> Event a
always (a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
val)
{-# INLINE thenGetEvent #-}
{-# INLINE thenEvent #-}
{-# INLINE doneEvent #-}
{-# RULES
"always1" forall action . sync (always action) = action
"always" forall action continuation .
(>>>=) (always action) continuation = always (action >>= continuation)
#-}
allowWhile :: Event () -> Event a -> Event a
allowWhile :: Event () -> Event a -> Event a
allowWhile Event ()
event1 Event a
event2 =
Event a
event2
Event a -> Event a -> Event a
forall a. Event a -> Event a -> Event a
+>(do
Event ()
event1
Event () -> Event a -> Event a
forall a. Event () -> Event a -> Event a
allowWhile Event ()
event1 Event a
event2
)
data Request a b = Request (a -> IO (Event b,IO ()))
request :: Request a b -> a -> IO b
request :: Request a b -> a -> IO b
request Request a b
rq a
a =
do
(Event b
event,IO ()
_) <- Request a b -> a -> IO (Event b, IO ())
forall a b. Request a b -> a -> IO (Event b, IO ())
doRequest Request a b
rq a
a
Event b -> IO b
forall a. Event a -> IO a
sync Event b
event
doRequest :: Request a b -> a -> IO (Event b,IO ())
doRequest :: Request a b -> a -> IO (Event b, IO ())
doRequest (Request a -> IO (Event b, IO ())
rqFn) a
request = a -> IO (Event b, IO ())
rqFn a
request
spawnEvent :: Event () -> IO (IO ())
spawnEvent :: Event () -> IO (IO ())
spawnEvent Event ()
reactor = IO () -> IO (IO ())
spawn (Event () -> IO ()
forall a. Event a -> IO a
sync Event ()
reactor)
getAllQueued :: Event a -> IO [a]
getAllQueued :: Event a -> IO [a]
getAllQueued Event a
event = Event a -> [a] -> IO [a]
forall a. Event a -> [a] -> IO [a]
gAQ Event a
event []
where
gAQ :: Event a -> [a] -> IO [a]
gAQ Event a
event [a]
acc =
do
Maybe a
maybeA <- Event a -> IO (Maybe a)
forall a. Event a -> IO (Maybe a)
poll Event a
event
case Maybe a
maybeA of
Maybe a
Nothing -> [a] -> IO [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
acc)
Just a
a -> Event a -> [a] -> IO [a]
gAQ Event a
event (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
acc)