{-# LANGUAGE RecursiveDo  #-}
module Reactive.Threepenny (
    -- * Synopsis
    -- | Functional reactive programming.

    -- * Types
    -- $intro
    Event, Behavior,

    -- * IO
    -- | Functions to connect events to the outside world.
    Handler, newEvent, register,
    currentValue,

    -- * Core Combinators
    -- | Minimal set of combinators for programming with 'Event' and 'Behavior'.
    module Control.Applicative,
    never, filterJust, unionWith,
    accumE, apply, stepper,
    -- $classes

    -- * Derived Combinators
    -- | Additional combinators that make programming
    -- with 'Event' and 'Behavior' convenient.
    -- ** Application
    (<@>), (<@),
    -- ** Filtering
    filterE, filterApply, whenE, split,
    -- ** Union
    unions, concatenate,
    -- ** Accumulation
    -- $accumulation
    accumB, mapAccum,

    -- * Additional Notes
    -- $recursion

    -- * Tidings
    Tidings, tidings, facts, rumors,

    -- * Internal
    -- | Functions reserved for special circumstances.
    -- Do not use unless you know what you're doing.
    onChange, unsafeMapIO, newEventsNamed,
    
    -- * Testing
    test, test_recursion1
    ) where

import Control.Applicative
import Control.Monad (void)
import Control.Monad.IO.Class
import Data.IORef
import qualified Data.Map as Map

import           Reactive.Threepenny.Memo       as Memo
import qualified Reactive.Threepenny.PulseLatch as Prim

type Pulse = Prim.Pulse
type Latch = Prim.Latch

{-----------------------------------------------------------------------------
    Types
------------------------------------------------------------------------------}
{- $intro

At its core, Functional Reactive Programming (FRP) is about two
data types 'Event' and 'Behavior' and the various ways to combine them.

-}

{-| @Event a@ represents a stream of events as they occur in time.
Semantically, you can think of @Event a@ as an infinite list of values
that are tagged with their corresponding time of occurence,

> type Event a = [(Time,a)]
-}
newtype Event    a = E { forall a. Event a -> Memo (Pulse a)
unE :: Memo (Pulse a) }

{-| @Behavior a@ represents a value that varies in time. Think of it as

> type Behavior a = Time -> a
-}
data    Behavior a = B { forall a. Behavior a -> Latch a
latch :: Latch a, forall a. Behavior a -> Event ()
changes :: Event () }

{-----------------------------------------------------------------------------
    IO
------------------------------------------------------------------------------}
-- | An /event handler/ is a function that takes an
-- /event value/ and performs some computation.
type Handler a = a -> IO ()

-- | Create a new event.
-- Also returns a function that triggers an event occurrence.
newEvent :: IO (Event a, Handler a)
newEvent :: forall a. IO (Event a, Handler a)
newEvent = do
    (Pulse a
p, Handler a
fire) <- Build (Pulse a, Handler a)
forall a. Build (Pulse a, a -> IO ())
Prim.newPulse
    (Event a, Handler a) -> IO (Event a, Handler a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Memo (Pulse a) -> Event a
forall a. Memo (Pulse a) -> Event a
E (Memo (Pulse a) -> Event a) -> Memo (Pulse a) -> Event a
forall a b. (a -> b) -> a -> b
$ Pulse a -> Memo (Pulse a)
forall a. a -> Memo a
fromPure Pulse a
p, Handler a
fire)


-- | Create a series of events with delayed initialization.
--
-- For each name, the initialization handler will be called
-- exactly once when the event is first "brought to life",
-- e.g. when an event handler is registered to it.
newEventsNamed :: Ord name
    => Handler (name, Event a, Handler a)   -- ^ Initialization procedure.
    -> IO (name -> Event a)                 -- ^ Series of events.
newEventsNamed :: forall name a.
Ord name =>
Handler (name, Event a, Handler a) -> IO (name -> Event a)
newEventsNamed Handler (name, Event a, Handler a)
initialize = do
    IORef (Map name (Pulse a))
eventsRef <- Map name (Pulse a) -> IO (IORef (Map name (Pulse a)))
forall a. a -> IO (IORef a)
newIORef Map name (Pulse a)
forall k a. Map k a
Map.empty
    (name -> Event a) -> IO (name -> Event a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((name -> Event a) -> IO (name -> Event a))
-> (name -> Event a) -> IO (name -> Event a)
forall a b. (a -> b) -> a -> b
$ \name
name -> Memo (Pulse a) -> Event a
forall a. Memo (Pulse a) -> Event a
E (Memo (Pulse a) -> Event a) -> Memo (Pulse a) -> Event a
forall a b. (a -> b) -> a -> b
$ IO (Pulse a) -> Memo (Pulse a)
forall a. IO a -> Memo a
memoize (IO (Pulse a) -> Memo (Pulse a)) -> IO (Pulse a) -> Memo (Pulse a)
forall a b. (a -> b) -> a -> b
$ do
        Map name (Pulse a)
events <- IORef (Map name (Pulse a)) -> IO (Map name (Pulse a))
forall a. IORef a -> IO a
readIORef IORef (Map name (Pulse a))
eventsRef
        case name -> Map name (Pulse a) -> Maybe (Pulse a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup name
name Map name (Pulse a)
events of
            Just Pulse a
p  -> Pulse a -> IO (Pulse a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Pulse a
p
            Maybe (Pulse a)
Nothing -> do
                (Pulse a
p, Handler a
fire) <- Build (Pulse a, Handler a)
forall a. Build (Pulse a, a -> IO ())
Prim.newPulse
                IORef (Map name (Pulse a)) -> Map name (Pulse a) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Map name (Pulse a))
eventsRef (Map name (Pulse a) -> IO ()) -> Map name (Pulse a) -> IO ()
forall a b. (a -> b) -> a -> b
$ name -> Pulse a -> Map name (Pulse a) -> Map name (Pulse a)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert name
name Pulse a
p Map name (Pulse a)
events
                Handler (name, Event a, Handler a)
initialize (name
name, Memo (Pulse a) -> Event a
forall a. Memo (Pulse a) -> Event a
E (Memo (Pulse a) -> Event a) -> Memo (Pulse a) -> Event a
forall a b. (a -> b) -> a -> b
$ Pulse a -> Memo (Pulse a)
forall a. a -> Memo a
fromPure Pulse a
p, Handler a
fire)
                Pulse a -> IO (Pulse a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Pulse a
p


-- | Register an event 'Handler' for an 'Event'.
-- All registered handlers will be called whenever the event occurs.
--
-- When registering an event handler, you will also be given an action
-- that unregisters this handler again.
--
-- > do unregisterMyHandler <- register event myHandler
--
-- FIXME: Unregistering event handlers does not work yet.
register :: Event a -> Handler a -> IO (IO ())
register :: forall a. Event a -> Handler a -> IO (IO ())
register Event a
e Handler a
h = do
    Pulse a
p <- Memo (Pulse a) -> IO (Pulse a)
forall a. Memo a -> IO a
at (Event a -> Memo (Pulse a)
forall a. Event a -> Memo (Pulse a)
unE Event a
e)     -- evaluate the memoized action
    Pulse a -> Handler a -> IO (IO ())
forall a. Pulse a -> (a -> IO ()) -> IO (IO ())
Prim.addHandler Pulse a
p Handler a
h

-- | Register an event 'Handler' for a 'Behavior'.
-- All registered handlers will be called whenever the behavior changes.
--
-- However, note that this is only an approximation,
-- as behaviors may change continuously.
-- Consequently, handlers should be idempotent.
onChange :: Behavior a -> Handler a -> IO ()
onChange :: forall a. Behavior a -> Handler a -> IO ()
onChange (B Latch a
l Event ()
e) Handler a
h = IO (IO ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    -- This works because latches are updated before the handlers are being called.
    Event () -> Handler () -> IO (IO ())
forall a. Event a -> Handler a -> IO (IO ())
register Event ()
e (\()
_ -> Handler a
h Handler a -> IO a -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Latch a -> IO a
forall a. Latch a -> Build a
Prim.readLatch Latch a
l)

-- | Read the current value of a 'Behavior'.
currentValue :: MonadIO m => Behavior a -> m a
currentValue :: forall (m :: * -> *) a. MonadIO m => Behavior a -> m a
currentValue (B Latch a
l Event ()
_) = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ Latch a -> IO a
forall a. Latch a -> Build a
Prim.readLatch Latch a
l


{-----------------------------------------------------------------------------
    Core Combinators
------------------------------------------------------------------------------}
instance Functor Event where
    fmap :: forall a b. (a -> b) -> Event a -> Event b
fmap a -> b
f Event a
e = Memo (Pulse b) -> Event b
forall a. Memo (Pulse a) -> Event a
E (Memo (Pulse b) -> Event b) -> Memo (Pulse b) -> Event b
forall a b. (a -> b) -> a -> b
$ (Pulse a -> IO (Pulse b)) -> Memo (Pulse a) -> Memo (Pulse b)
forall a b. (a -> IO b) -> Memo a -> Memo b
liftMemo1 ((a -> b) -> Pulse a -> IO (Pulse b)
forall a b. (a -> b) -> Pulse a -> Build (Pulse b)
Prim.mapP a -> b
f) (Event a -> Memo (Pulse a)
forall a. Event a -> Memo (Pulse a)
unE Event a
e)

unsafeMapIO :: (a -> IO b) -> Event a -> Event b
unsafeMapIO :: forall a b. (a -> IO b) -> Event a -> Event b
unsafeMapIO a -> IO b
f Event a
e = Memo (Pulse b) -> Event b
forall a. Memo (Pulse a) -> Event a
E (Memo (Pulse b) -> Event b) -> Memo (Pulse b) -> Event b
forall a b. (a -> b) -> a -> b
$ (Pulse a -> IO (Pulse b)) -> Memo (Pulse a) -> Memo (Pulse b)
forall a b. (a -> IO b) -> Memo a -> Memo b
liftMemo1 ((a -> IO b) -> Pulse a -> IO (Pulse b)
forall a b. (a -> IO b) -> Pulse a -> Build (Pulse b)
Prim.unsafeMapIOP a -> IO b
f) (Event a -> Memo (Pulse a)
forall a. Event a -> Memo (Pulse a)
unE Event a
e)

-- | Event that never occurs.
-- Think of it as @never = []@.
never :: Event a
never :: forall a. Event a
never = Memo (Pulse a) -> Event a
forall a. Memo (Pulse a) -> Event a
E (Memo (Pulse a) -> Event a) -> Memo (Pulse a) -> Event a
forall a b. (a -> b) -> a -> b
$ Pulse a -> Memo (Pulse a)
forall a. a -> Memo a
fromPure Pulse a
forall a. Pulse a
Prim.neverP

-- | Return all event occurrences that are 'Just' values, discard the rest.
-- Think of it as
--
-- > filterJust es = [(time,a) | (time,Just a) <- es]
filterJust :: Event (Maybe a) -> Event a
filterJust :: forall a. Event (Maybe a) -> Event a
filterJust Event (Maybe a)
e = Memo (Pulse a) -> Event a
forall a. Memo (Pulse a) -> Event a
E (Memo (Pulse a) -> Event a) -> Memo (Pulse a) -> Event a
forall a b. (a -> b) -> a -> b
$ (Pulse (Maybe a) -> IO (Pulse a))
-> Memo (Pulse (Maybe a)) -> Memo (Pulse a)
forall a b. (a -> IO b) -> Memo a -> Memo b
liftMemo1 Pulse (Maybe a) -> IO (Pulse a)
forall a. Pulse (Maybe a) -> Build (Pulse a)
Prim.filterJustP (Event (Maybe a) -> Memo (Pulse (Maybe a))
forall a. Event a -> Memo (Pulse a)
unE Event (Maybe a)
e)

-- | Merge two event streams of the same type.
-- In case of simultaneous occurrences, the event values are combined
-- with the binary function.
-- Think of it as
--
-- > unionWith f ((timex,x):xs) ((timey,y):ys)
-- >    | timex == timey = (timex,f x y) : unionWith f xs ys
-- >    | timex <  timey = (timex,x)     : unionWith f xs ((timey,y):ys)
-- >    | timex >  timey = (timey,y)     : unionWith f ((timex,x):xs) ys
unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a
unionWith :: forall a. (a -> a -> a) -> Event a -> Event a -> Event a
unionWith a -> a -> a
f Event a
e1 Event a
e2 = Memo (Pulse a) -> Event a
forall a. Memo (Pulse a) -> Event a
E (Memo (Pulse a) -> Event a) -> Memo (Pulse a) -> Event a
forall a b. (a -> b) -> a -> b
$ (Pulse a -> Pulse a -> IO (Pulse a))
-> Memo (Pulse a) -> Memo (Pulse a) -> Memo (Pulse a)
forall a b c. (a -> b -> IO c) -> Memo a -> Memo b -> Memo c
liftMemo2 ((a -> a -> a) -> Pulse a -> Pulse a -> IO (Pulse a)
forall a. (a -> a -> a) -> Pulse a -> Pulse a -> Build (Pulse a)
Prim.unionWithP a -> a -> a
f) (Event a -> Memo (Pulse a)
forall a. Event a -> Memo (Pulse a)
unE Event a
e1) (Event a -> Memo (Pulse a)
forall a. Event a -> Memo (Pulse a)
unE Event a
e2)

-- | Apply a time-varying function to a stream of events.
-- Think of it as
--
-- > apply bf ex = [(time, bf time x) | (time, x) <- ex]
apply :: Behavior (a -> b) -> Event a -> Event b
apply :: forall a b. Behavior (a -> b) -> Event a -> Event b
apply  Behavior (a -> b)
f Event a
x        = Memo (Pulse b) -> Event b
forall a. Memo (Pulse a) -> Event a
E (Memo (Pulse b) -> Event b) -> Memo (Pulse b) -> Event b
forall a b. (a -> b) -> a -> b
$ (Pulse a -> IO (Pulse b)) -> Memo (Pulse a) -> Memo (Pulse b)
forall a b. (a -> IO b) -> Memo a -> Memo b
liftMemo1 (\Pulse a
p -> Latch (a -> b) -> Pulse a -> IO (Pulse b)
forall a b. Latch (a -> b) -> Pulse a -> Build (Pulse b)
Prim.applyP (Behavior (a -> b) -> Latch (a -> b)
forall a. Behavior a -> Latch a
latch Behavior (a -> b)
f) Pulse a
p) (Event a -> Memo (Pulse a)
forall a. Event a -> Memo (Pulse a)
unE Event a
x)

infixl 4 <@>, <@

-- | Infix synonym for 'apply', similar to '<*>'.
(<@>) :: Behavior (a -> b) -> Event a -> Event b
<@> :: forall a b. Behavior (a -> b) -> Event a -> Event b
(<@>) = Behavior (a -> b) -> Event a -> Event b
forall a b. Behavior (a -> b) -> Event a -> Event b
apply

-- | Variant of 'apply' similar to '<*'
(<@) :: Behavior a -> Event b -> Event a
Behavior a
b <@ :: forall a b. Behavior a -> Event b -> Event a
<@ Event b
e = (a -> b -> a
forall a b. a -> b -> a
const (a -> b -> a) -> Behavior a -> Behavior (b -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior a
b) Behavior (b -> a) -> Event b -> Event a
forall a b. Behavior (a -> b) -> Event a -> Event b
<@> Event b
e

-- | The 'accumB' function is similar to a /strict/ left fold, 'foldl''.
-- It starts with an initial value and combines it with incoming events.
-- For example, think
--
-- > accumB "x" [(time1,(++"y")),(time2,(++"z"))]
-- >    = stepper "x" [(time1,"xy"),(time2,"xyz")]
--
-- Note that the value of the behavior changes \"slightly after\"
-- the events occur. This allows for recursive definitions.
accumB :: MonadIO m => a -> Event (a -> a) -> m (Behavior a)
accumB :: forall (m :: * -> *) a.
MonadIO m =>
a -> Event (a -> a) -> m (Behavior a)
accumB a
a Event (a -> a)
e = IO (Behavior a) -> m (Behavior a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Behavior a) -> m (Behavior a))
-> IO (Behavior a) -> m (Behavior a)
forall a b. (a -> b) -> a -> b
$ do
    (Latch a
l1,Pulse a
p1) <- a -> Pulse (a -> a) -> Build (Latch a, Pulse a)
forall a. a -> Pulse (a -> a) -> Build (Latch a, Pulse a)
Prim.accumL a
a (Pulse (a -> a) -> Build (Latch a, Pulse a))
-> IO (Pulse (a -> a)) -> Build (Latch a, Pulse a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Memo (Pulse (a -> a)) -> IO (Pulse (a -> a))
forall a. Memo a -> IO a
at (Event (a -> a) -> Memo (Pulse (a -> a))
forall a. Event a -> Memo (Pulse a)
unE Event (a -> a)
e)
    Pulse ()
p2      <- (a -> ()) -> Pulse a -> Build (Pulse ())
forall a b. (a -> b) -> Pulse a -> Build (Pulse b)
Prim.mapP (() -> a -> ()
forall a b. a -> b -> a
const ()) Pulse a
p1
    Behavior a -> IO (Behavior a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Behavior a -> IO (Behavior a)) -> Behavior a -> IO (Behavior a)
forall a b. (a -> b) -> a -> b
$ Latch a -> Event () -> Behavior a
forall a. Latch a -> Event () -> Behavior a
B Latch a
l1 (Memo (Pulse ()) -> Event ()
forall a. Memo (Pulse a) -> Event a
E (Memo (Pulse ()) -> Event ()) -> Memo (Pulse ()) -> Event ()
forall a b. (a -> b) -> a -> b
$ Pulse () -> Memo (Pulse ())
forall a. a -> Memo a
fromPure Pulse ()
p2)


-- | Construct a time-varying function from an initial value and
-- a stream of new values. Think of it as
--
-- > stepper x0 ex = return $ \time ->
-- >     last (x0 : [x | (timex,x) <- ex, timex < time])
--
-- Note that the smaller-than-sign in the comparison @timex < time@ means
-- that the value of the behavior changes \"slightly after\"
-- the event occurrences. This allows for recursive definitions.
stepper :: MonadIO m => a -> Event a -> m (Behavior a)
stepper :: forall (m :: * -> *) a. MonadIO m => a -> Event a -> m (Behavior a)
stepper a
a Event a
e = a -> Event (a -> a) -> m (Behavior a)
forall (m :: * -> *) a.
MonadIO m =>
a -> Event (a -> a) -> m (Behavior a)
accumB a
a (a -> a -> a
forall a b. a -> b -> a
const (a -> a -> a) -> Event a -> Event (a -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event a
e)

-- | The 'accumE' function accumulates a stream of events.
-- Example:
--
-- > accumE "x" [(time1,(++"y")),(time2,(++"z"))]
-- >    = return [(time1,"xy"),(time2,"xyz")]
--
-- Note that the output events are simultaneous with the input events,
-- there is no \"delay\" like in the case of 'accumB'.
accumE :: MonadIO m =>  a -> Event (a -> a) -> m (Event a)
accumE :: forall (m :: * -> *) a.
MonadIO m =>
a -> Event (a -> a) -> m (Event a)
accumE a
a Event (a -> a)
e = IO (Event a) -> m (Event a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Event a) -> m (Event a)) -> IO (Event a) -> m (Event a)
forall a b. (a -> b) -> a -> b
$ do
    Pulse a
p <- ((Latch a, Pulse a) -> Pulse a)
-> IO (Latch a, Pulse a) -> IO (Pulse a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Latch a, Pulse a) -> Pulse a
forall a b. (a, b) -> b
snd (IO (Latch a, Pulse a) -> IO (Pulse a))
-> (Pulse (a -> a) -> IO (Latch a, Pulse a))
-> Pulse (a -> a)
-> IO (Pulse a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Pulse (a -> a) -> IO (Latch a, Pulse a)
forall a. a -> Pulse (a -> a) -> Build (Latch a, Pulse a)
Prim.accumL a
a (Pulse (a -> a) -> IO (Pulse a))
-> IO (Pulse (a -> a)) -> IO (Pulse a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Memo (Pulse (a -> a)) -> IO (Pulse (a -> a))
forall a. Memo a -> IO a
at (Event (a -> a) -> Memo (Pulse (a -> a))
forall a. Event a -> Memo (Pulse a)
unE Event (a -> a)
e)
    Event a -> IO (Event a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Event a -> IO (Event a)) -> Event a -> IO (Event a)
forall a b. (a -> b) -> a -> b
$ Memo (Pulse a) -> Event a
forall a. Memo (Pulse a) -> Event a
E (Memo (Pulse a) -> Event a) -> Memo (Pulse a) -> Event a
forall a b. (a -> b) -> a -> b
$ Pulse a -> Memo (Pulse a)
forall a. a -> Memo a
fromPure Pulse a
p

instance Functor Behavior where
    fmap :: forall a b. (a -> b) -> Behavior a -> Behavior b
fmap a -> b
f ~(B Latch a
l Event ()
e) = Latch b -> Event () -> Behavior b
forall a. Latch a -> Event () -> Behavior a
B ((a -> b) -> Latch a -> Latch b
forall a b. (a -> b) -> Latch a -> Latch b
Prim.mapL a -> b
f Latch a
l) Event ()
e

instance Applicative Behavior where
    pure :: forall a. a -> Behavior a
pure a
a  = Latch a -> Event () -> Behavior a
forall a. Latch a -> Event () -> Behavior a
B (a -> Latch a
forall a. a -> Latch a
Prim.pureL a
a) Event ()
forall a. Event a
never
    ~(B Latch (a -> b)
lf Event ()
ef) <*> :: forall a b. Behavior (a -> b) -> Behavior a -> Behavior b
<*> ~(B Latch a
lx Event ()
ex) =
        Latch b -> Event () -> Behavior b
forall a. Latch a -> Event () -> Behavior a
B (Latch (a -> b) -> Latch a -> Latch b
forall a b. Latch (a -> b) -> Latch a -> Latch b
Prim.applyL Latch (a -> b)
lf Latch a
lx) ((() -> () -> ()) -> Event () -> Event () -> Event ()
forall a. (a -> a -> a) -> Event a -> Event a -> Event a
unionWith () -> () -> ()
forall a b. a -> b -> a
const Event ()
ef Event ()
ex)

{- $classes

/Further combinators that Haddock can't document properly./

> instance Applicative Behavior

'Behavior' is an applicative functor. In particular, we have the following functions.

> pure :: a -> Behavior a

The constant time-varying value. Think of it as @pure x = \\time -> x@.

> (<*>) :: Behavior (a -> b) -> Behavior a -> Behavior b

Combine behaviors in applicative style.
Think of it as @bf \<*\> bx = \\time -> bf time $ bx time@.

-}

{- $recursion

Recursion in the 'IO' monad is possible, but somewhat limited.
The main rule is that the sequence of IO actions must be known
in advance, only the values may be recursive.

Good:

> mdo
>     let e2 = apply (const <$> b) e1   -- applying a behavior is not an IO action
>     b <- accumB $ (+1) <$ e2

Bad:

> mdo
>     b <- accumB $ (+1) <$ e2          -- actions executed here could depend ...
>     let e2 = apply (const <$> b) e1   -- ... on this value

-}

{-----------------------------------------------------------------------------
    Derived Combinators
------------------------------------------------------------------------------}
-- | Return all event occurrences that fulfill the predicate, discard the rest.
filterE :: (a -> Bool) -> Event a -> Event a
filterE :: forall a. (a -> Bool) -> Event a -> Event a
filterE a -> Bool
p = Event (Maybe a) -> Event a
forall a. Event (Maybe a) -> Event a
filterJust (Event (Maybe a) -> Event a)
-> (Event a -> Event (Maybe a)) -> Event a -> Event a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe a) -> Event a -> Event (Maybe a)
forall a b. (a -> b) -> Event a -> Event b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
a -> if a -> Bool
p a
a then a -> Maybe a
forall a. a -> Maybe a
Just a
a else Maybe a
forall a. Maybe a
Nothing)

-- | Return all event occurrences that fulfill the time-varying predicate,
-- discard the rest. Generalization of 'filterE'.
filterApply :: Behavior (a -> Bool) -> Event a -> Event a
filterApply :: forall a. Behavior (a -> Bool) -> Event a -> Event a
filterApply Behavior (a -> Bool)
bp = ((Bool, a) -> a) -> Event (Bool, a) -> Event a
forall a b. (a -> b) -> Event a -> Event b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool, a) -> a
forall a b. (a, b) -> b
snd (Event (Bool, a) -> Event a)
-> (Event a -> Event (Bool, a)) -> Event a -> Event a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Bool, a) -> Bool) -> Event (Bool, a) -> Event (Bool, a)
forall a. (a -> Bool) -> Event a -> Event a
filterE (Bool, a) -> Bool
forall a b. (a, b) -> a
fst (Event (Bool, a) -> Event (Bool, a))
-> (Event a -> Event (Bool, a)) -> Event a -> Event (Bool, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Behavior (a -> (Bool, a)) -> Event a -> Event (Bool, a)
forall a b. Behavior (a -> b) -> Event a -> Event b
apply ((\a -> Bool
p a
a -> (a -> Bool
p a
a,a
a)) ((a -> Bool) -> a -> (Bool, a))
-> Behavior (a -> Bool) -> Behavior (a -> (Bool, a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior (a -> Bool)
bp)

-- | Return event occurrences only when the behavior is 'True'.
-- Variant of 'filterApply'.
whenE :: Behavior Bool -> Event a -> Event a
whenE :: forall a. Behavior Bool -> Event a -> Event a
whenE Behavior Bool
bf = Behavior (a -> Bool) -> Event a -> Event a
forall a. Behavior (a -> Bool) -> Event a -> Event a
filterApply (Bool -> a -> Bool
forall a b. a -> b -> a
const (Bool -> a -> Bool) -> Behavior Bool -> Behavior (a -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior Bool
bf)

-- | Split event occurrences according to a tag.
-- The 'Left' values go into the left component while the 'Right' values
-- go into the right component of the result.
split :: Event (Either a b) -> (Event a, Event b)
split :: forall a b. Event (Either a b) -> (Event a, Event b)
split Event (Either a b)
e = (Event (Maybe a) -> Event a
forall a. Event (Maybe a) -> Event a
filterJust (Event (Maybe a) -> Event a) -> Event (Maybe a) -> Event a
forall a b. (a -> b) -> a -> b
$ Either a b -> Maybe a
forall {a} {b}. Either a b -> Maybe a
fromLeft (Either a b -> Maybe a) -> Event (Either a b) -> Event (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event (Either a b)
e, Event (Maybe b) -> Event b
forall a. Event (Maybe a) -> Event a
filterJust (Event (Maybe b) -> Event b) -> Event (Maybe b) -> Event b
forall a b. (a -> b) -> a -> b
$ Either a b -> Maybe b
forall {a} {a}. Either a a -> Maybe a
fromRight (Either a b -> Maybe b) -> Event (Either a b) -> Event (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event (Either a b)
e)
    where
    fromLeft :: Either a b -> Maybe a
fromLeft  (Left  a
a) = a -> Maybe a
forall a. a -> Maybe a
Just a
a
    fromLeft  (Right b
_) = Maybe a
forall a. Maybe a
Nothing
    fromRight :: Either a a -> Maybe a
fromRight (Left  a
_) = Maybe a
forall a. Maybe a
Nothing
    fromRight (Right a
b) = a -> Maybe a
forall a. a -> Maybe a
Just a
b

-- | Collect simultaneous event occurrences in a list.
unions :: [Event a] -> Event [a]
unions :: forall a. [Event a] -> Event [a]
unions = (Event [a] -> Event [a] -> Event [a])
-> Event [a] -> [Event [a]] -> Event [a]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (([a] -> [a] -> [a]) -> Event [a] -> Event [a] -> Event [a]
forall a. (a -> a -> a) -> Event a -> Event a -> Event a
unionWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++)) Event [a]
forall a. Event a
never ([Event [a]] -> Event [a])
-> ([Event a] -> [Event [a]]) -> [Event a] -> Event [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event a -> Event [a]) -> [Event a] -> [Event [a]]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> [a]) -> Event a -> Event [a]
forall a b. (a -> b) -> Event a -> Event b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[]))

-- | Apply a list of functions in succession.
-- Useful in conjunction with 'unions'.
--
-- > concatenate [f,g,h] = f . g . h
concatenate :: [a -> a] -> (a -> a)
concatenate :: forall a. [a -> a] -> a -> a
concatenate = ((a -> a) -> (a -> a) -> a -> a) -> (a -> a) -> [a -> a] -> a -> a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) a -> a
forall a. a -> a
id

{- $accumulation

Note: All accumulation functions are strict in the accumulated value!
acc -> (x,acc) is the order used by 'unfoldr' and 'State'.

-}

-- | Efficient combination of 'accumE' and 'accumB'.
mapAccum :: MonadIO m => acc -> Event (acc -> (x,acc)) -> m (Event x, Behavior acc)
mapAccum :: forall (m :: * -> *) acc x.
MonadIO m =>
acc -> Event (acc -> (x, acc)) -> m (Event x, Behavior acc)
mapAccum acc
acc Event (acc -> (x, acc))
ef = do
    Event (x, acc)
e <- (x, acc) -> Event ((x, acc) -> (x, acc)) -> m (Event (x, acc))
forall (m :: * -> *) a.
MonadIO m =>
a -> Event (a -> a) -> m (Event a)
accumE (x
forall a. HasCallStack => a
undefined,acc
acc) (((acc -> (x, acc)) -> ((x, acc) -> acc) -> (x, acc) -> (x, acc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x, acc) -> acc
forall a b. (a, b) -> b
snd) ((acc -> (x, acc)) -> (x, acc) -> (x, acc))
-> Event (acc -> (x, acc)) -> Event ((x, acc) -> (x, acc))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event (acc -> (x, acc))
ef)
    Behavior acc
b <- acc -> Event acc -> m (Behavior acc)
forall (m :: * -> *) a. MonadIO m => a -> Event a -> m (Behavior a)
stepper acc
acc ((x, acc) -> acc
forall a b. (a, b) -> b
snd ((x, acc) -> acc) -> Event (x, acc) -> Event acc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event (x, acc)
e)
    (Event x, Behavior acc) -> m (Event x, Behavior acc)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((x, acc) -> x
forall a b. (a, b) -> a
fst ((x, acc) -> x) -> Event (x, acc) -> Event x
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event (x, acc)
e, Behavior acc
b)


{-----------------------------------------------------------------------------
    Tidings

    Data type for combining user events.
    See <http://apfelmus.nfshost.com/blog/2012/03/29-frp-three-principles-bidirectional-gui.html>
    for more information.
------------------------------------------------------------------------------}
-- | Data type representing a behavior ('facts')
-- and suggestions to change it ('rumors').
data Tidings a = T { forall a. Tidings a -> Behavior a
facts :: Behavior a, forall a. Tidings a -> Event a
rumors :: Event a }

-- | Smart constructor. Combine facts and rumors into 'Tidings'.
tidings :: Behavior a -> Event a -> Tidings a
tidings :: forall a. Behavior a -> Event a -> Tidings a
tidings Behavior a
b Event a
e = Behavior a -> Event a -> Tidings a
forall a. Behavior a -> Event a -> Tidings a
T Behavior a
b Event a
e

instance Functor Tidings where
    fmap :: forall a b. (a -> b) -> Tidings a -> Tidings b
fmap a -> b
f (T Behavior a
b Event a
e) = Behavior b -> Event b -> Tidings b
forall a. Behavior a -> Event a -> Tidings a
T ((a -> b) -> Behavior a -> Behavior b
forall a b. (a -> b) -> Behavior a -> Behavior b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Behavior a
b) ((a -> b) -> Event a -> Event b
forall a b. (a -> b) -> Event a -> Event b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Event a
e)

-- | The applicative instance combines 'rumors'
-- and uses 'facts' when some of the 'rumors' are not available.
instance Applicative Tidings where
    pure :: forall a. a -> Tidings a
pure a
x  = Behavior a -> Event a -> Tidings a
forall a. Behavior a -> Event a -> Tidings a
T (a -> Behavior a
forall a. a -> Behavior a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x) Event a
forall a. Event a
never
    Tidings (a -> b)
f <*> :: forall a b. Tidings (a -> b) -> Tidings a -> Tidings b
<*> Tidings a
x = ((a -> b) -> a -> b) -> (a -> b, a) -> b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
($) ((a -> b, a) -> b) -> Tidings (a -> b, a) -> Tidings b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tidings (a -> b) -> Tidings a -> Tidings (a -> b, a)
forall a b. Tidings a -> Tidings b -> Tidings (a, b)
pair Tidings (a -> b)
f Tidings a
x

pair :: Tidings a -> Tidings b -> Tidings (a,b)
pair :: forall a b. Tidings a -> Tidings b -> Tidings (a, b)
pair (T Behavior a
bx Event a
ex) (T Behavior b
by Event b
ey) = Behavior (a, b) -> Event (a, b) -> Tidings (a, b)
forall a. Behavior a -> Event a -> Tidings a
T Behavior (a, b)
b Event (a, b)
e
    where
    b :: Behavior (a, b)
b = (,) (a -> b -> (a, b)) -> Behavior a -> Behavior (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior a
bx Behavior (b -> (a, b)) -> Behavior b -> Behavior (a, b)
forall a b. Behavior (a -> b) -> Behavior a -> Behavior b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Behavior b
by
    ex' :: Event (a, b)
ex' = (a -> b -> (a, b)) -> b -> a -> (a, b)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) (b -> a -> (a, b)) -> Behavior b -> Behavior (a -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior b
by Behavior (a -> (a, b)) -> Event a -> Event (a, b)
forall a b. Behavior (a -> b) -> Event a -> Event b
<@> Event a
ex
    ey' :: Event (a, b)
ey' = (,) (a -> b -> (a, b)) -> Behavior a -> Behavior (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior a
bx Behavior (b -> (a, b)) -> Event b -> Event (a, b)
forall a b. Behavior (a -> b) -> Event a -> Event b
<@> Event b
ey
    e :: Event (a, b)
e = ((a, b) -> (a, b) -> (a, b))
-> Event (a, b) -> Event (a, b) -> Event (a, b)
forall a. (a -> a -> a) -> Event a -> Event a -> Event a
unionWith (\(a
x,b
_) (a
_,b
y) -> (a
x,b
y)) Event (a, b)
ex' Event (a, b)
ey'


{-----------------------------------------------------------------------------
    Test
------------------------------------------------------------------------------}
test :: IO (Int -> IO ())
test :: IO (Int -> IO ())
test = do
    (Event Int
e1,Int -> IO ()
fire) <- IO (Event Int, Int -> IO ())
forall a. IO (Event a, Handler a)
newEvent
    Event Int
e2 <- Int -> Event (Int -> Int) -> IO (Event Int)
forall (m :: * -> *) a.
MonadIO m =>
a -> Event (a -> a) -> m (Event a)
accumE Int
0 (Event (Int -> Int) -> IO (Event Int))
-> Event (Int -> Int) -> IO (Event Int)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) (Int -> Int -> Int) -> Event Int -> Event (Int -> Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event Int
e1
    IO ()
_  <- Event Int -> (Int -> IO ()) -> IO (IO ())
forall a. Event a -> Handler a -> IO (IO ())
register Event Int
e2 Int -> IO ()
forall a. Show a => a -> IO ()
print

    (Int -> IO ()) -> IO (Int -> IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int -> IO ()
fire

test_recursion1 :: IO (IO ())
test_recursion1 :: IO (IO ())
test_recursion1 = mdo
    (Event ()
e1, Handler ()
fire) <- IO (Event (), Handler ())
forall a. IO (Event a, Handler a)
newEvent
    let e2 :: Event Int
        e2 :: Event Int
e2 = Behavior (() -> Int) -> Event () -> Event Int
forall a b. Behavior (a -> b) -> Event a -> Event b
apply (Int -> () -> Int
forall a b. a -> b -> a
const (Int -> () -> Int) -> Behavior Int -> Behavior (() -> Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior Int
b) Event ()
e1
    Behavior Int
b  <- Int -> Event (Int -> Int) -> IO (Behavior Int)
forall (m :: * -> *) a.
MonadIO m =>
a -> Event (a -> a) -> m (Behavior a)
accumB Int
0 (Event (Int -> Int) -> IO (Behavior Int))
-> Event (Int -> Int) -> IO (Behavior Int)
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int -> Int) -> Event Int -> Event (Int -> Int)
forall a b. a -> Event b -> Event a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event Int
e2
    IO ()
_  <- Event Int -> (Int -> IO ()) -> IO (IO ())
forall a. Event a -> Handler a -> IO (IO ())
register Event Int
e2 Int -> IO ()
forall a. Show a => a -> IO ()
print

    IO () -> IO (IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ Handler ()
fire ()