{-# LANGUAGE RecordWildCards, RecursiveDo #-}
module Reactive.Threepenny.PulseLatch (
    Pulse, newPulse, addHandler,
    neverP, mapP, filterJustP, unionWithP, unsafeMapIOP,
    
    Latch,
    pureL, mapL, applyL, accumL, applyP,
    readLatch,
    
    -- * Internal
    test, test_recursion1
    ) where


import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.RWS     as Monad

import Data.IORef

import qualified Data.HashMap.Strict as Map
import qualified Data.Vault.Strict   as Vault
import           Data.Unique.Really

import Reactive.Threepenny.Monads
import Reactive.Threepenny.Types

{-----------------------------------------------------------------------------
    Pulse
------------------------------------------------------------------------------}
-- Turn evaluation action into pulse that caches the value.
cacheEval :: EvalP (Maybe a) -> Build (Pulse a)
cacheEval :: forall a. EvalP (Maybe a) -> Build (Pulse a)
cacheEval EvalP (Maybe a)
e = do
    Key (Maybe a)
key <- IO (Key (Maybe a))
forall a. IO (Key a)
Vault.newKey
    Pulse a -> Build (Pulse a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pulse a -> Build (Pulse a)) -> Pulse a -> Build (Pulse a)
forall a b. (a -> b) -> a -> b
$ Pulse
        { addHandlerP :: ((Unique, Priority), Handler) -> Build (IO ())
addHandlerP = \((Unique, Priority), Handler)
_ -> IO () -> Build (IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
        , evalP :: EvalP (Maybe a)
evalP       = do
            Values
vault <- RWST () () Values IO Values
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
Monad.get
            case Key (Maybe a) -> Values -> Maybe (Maybe a)
forall a. Key a -> Values -> Maybe a
Vault.lookup Key (Maybe a)
key Values
vault of
                Just Maybe a
a  -> Maybe a -> EvalP (Maybe a)
forall a. a -> RWST () () Values IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
a
                Maybe (Maybe a)
Nothing -> do
                    Maybe a
a <- EvalP (Maybe a)
e
                    Values -> RWST () () Values IO ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
s -> RWST r w s m ()
Monad.put (Values -> RWST () () Values IO ())
-> Values -> RWST () () Values IO ()
forall a b. (a -> b) -> a -> b
$ Key (Maybe a) -> Maybe a -> Values -> Values
forall a. Key a -> a -> Values -> Values
Vault.insert Key (Maybe a)
key Maybe a
a Values
vault
                    Maybe a -> EvalP (Maybe a)
forall a. a -> RWST () () Values IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
a
        }

-- Add a dependency to a pulse, for the sake of keeping track of dependencies.
dependOn :: Pulse a -> Pulse b -> Pulse a
dependOn :: forall a b. Pulse a -> Pulse b -> Pulse a
dependOn Pulse a
p Pulse b
q = Pulse a
p { addHandlerP = \((Unique, Priority), Handler)
h -> IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>) (IO () -> IO () -> IO ()) -> Build (IO ()) -> IO (IO () -> IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pulse a -> ((Unique, Priority), Handler) -> Build (IO ())
forall a. Pulse a -> ((Unique, Priority), Handler) -> Build (IO ())
addHandlerP Pulse a
p ((Unique, Priority), Handler)
h IO (IO () -> IO ()) -> Build (IO ()) -> Build (IO ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pulse b -> ((Unique, Priority), Handler) -> Build (IO ())
forall a. Pulse a -> ((Unique, Priority), Handler) -> Build (IO ())
addHandlerP Pulse b
q ((Unique, Priority), Handler)
h }

-- Execute an action when the pulse occurs
whenPulse :: Pulse a -> (a -> IO ()) -> Handler
whenPulse :: forall a. Pulse a -> (a -> IO ()) -> Handler
whenPulse Pulse a
p a -> IO ()
f = do
    Maybe a
ma <- Pulse a -> EvalP (Maybe a)
forall a. Pulse a -> EvalP (Maybe a)
evalP Pulse a
p
    case Maybe a
ma of
        Just a
a  -> IO () -> Handler
forall a. a -> RWST () () Values IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO ()
f a
a)
        Maybe a
Nothing -> IO () -> Handler
forall a. a -> RWST () () Values IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> Handler) -> IO () -> Handler
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

{-----------------------------------------------------------------------------
    Interface to the outside world.
------------------------------------------------------------------------------}
-- | Create a new pulse and a function to trigger it.
newPulse :: Build (Pulse a, a -> IO ())
newPulse :: forall a. Build (Pulse a, a -> IO ())
newPulse = do
    Key (Maybe a)
key         <- IO (Key (Maybe a))
forall a. IO (Key a)
Vault.newKey
    IORef (HashMap (Unique, Priority) Handler)
handlersRef <- HashMap (Unique, Priority) Handler
-> IO (IORef (HashMap (Unique, Priority) Handler))
forall a. a -> IO (IORef a)
newIORef HashMap (Unique, Priority) Handler
forall k v. HashMap k v
Map.empty      -- map of handlers
    
    let
        -- add handler to map
        addHandlerP :: ((Unique, Priority), Handler) -> Build (IO ())
        addHandlerP :: ((Unique, Priority), Handler) -> Build (IO ())
addHandlerP ((Unique, Priority)
uid,Handler
m) = do
            IORef (HashMap (Unique, Priority) Handler)
-> (HashMap (Unique, Priority) Handler
    -> HashMap (Unique, Priority) Handler)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (HashMap (Unique, Priority) Handler)
handlersRef ((Unique, Priority)
-> Handler
-> HashMap (Unique, Priority) Handler
-> HashMap (Unique, Priority) Handler
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert (Unique, Priority)
uid Handler
m)
            IO () -> Build (IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> Build (IO ())) -> IO () -> Build (IO ())
forall a b. (a -> b) -> a -> b
$ IORef (HashMap (Unique, Priority) Handler)
-> (HashMap (Unique, Priority) Handler
    -> HashMap (Unique, Priority) Handler)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (HashMap (Unique, Priority) Handler)
handlersRef ((Unique, Priority)
-> HashMap (Unique, Priority) Handler
-> HashMap (Unique, Priority) Handler
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
Map.delete (Unique, Priority)
uid)
        
        -- evaluate all handlers attached to this input pulse
        fireP :: a -> IO ()
fireP a
a = do
            let pulses :: Values
pulses = Key (Maybe a) -> Maybe a -> Values -> Values
forall a. Key a -> a -> Values -> Values
Vault.insert Key (Maybe a)
key (a -> Maybe a
forall a. a -> Maybe a
Just a
a) (Values -> Values) -> Values -> Values
forall a b. (a -> b) -> a -> b
$ Values
Vault.empty
            HashMap (Unique, Priority) Handler
handlers <- IORef (HashMap (Unique, Priority) Handler)
-> IO (HashMap (Unique, Priority) Handler)
forall a. IORef a -> IO a
readIORef IORef (HashMap (Unique, Priority) Handler)
handlersRef
            ([IO ()]
ms, Values
_)  <- Values -> EvalP [IO ()] -> IO ([IO ()], Values)
forall a. Values -> EvalP a -> IO (a, Values)
runEvalP Values
pulses (EvalP [IO ()] -> IO ([IO ()], Values))
-> EvalP [IO ()] -> IO ([IO ()], Values)
forall a b. (a -> b) -> a -> b
$ [Handler] -> EvalP [IO ()]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Handler] -> EvalP [IO ()]) -> [Handler] -> EvalP [IO ()]
forall a b. (a -> b) -> a -> b
$ 
                   [Handler
m | ((Unique
_,Priority
DoLatch),Handler
m) <- HashMap (Unique, Priority) Handler
-> [((Unique, Priority), Handler)]
forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap (Unique, Priority) Handler
handlers]
                [Handler] -> [Handler] -> [Handler]
forall a. [a] -> [a] -> [a]
++ [Handler
m | ((Unique
_,Priority
DoIO   ),Handler
m) <- HashMap (Unique, Priority) Handler
-> [((Unique, Priority), Handler)]
forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap (Unique, Priority) Handler
handlers]  
            [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [IO ()]
ms
        
        evalP :: RWST r () Values IO (Maybe a)
evalP = Maybe (Maybe a) -> Maybe a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe a) -> Maybe a)
-> (Values -> Maybe (Maybe a)) -> Values -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key (Maybe a) -> Values -> Maybe (Maybe a)
forall a. Key a -> Values -> Maybe a
Vault.lookup Key (Maybe a)
key (Values -> Maybe a)
-> RWST r () Values IO Values -> RWST r () Values IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST r () Values IO Values
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
Monad.get

    (Pulse a, a -> IO ()) -> Build (Pulse a, a -> IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pulse {EvalP (Maybe a)
((Unique, Priority), Handler) -> Build (IO ())
forall {r}. RWST r () Values IO (Maybe a)
addHandlerP :: ((Unique, Priority), Handler) -> Build (IO ())
evalP :: EvalP (Maybe a)
addHandlerP :: ((Unique, Priority), Handler) -> Build (IO ())
evalP :: forall {r}. RWST r () Values IO (Maybe a)
..}, a -> IO ()
fireP)

-- | Register a handler to be executed whenever a pulse occurs.
addHandler :: Pulse a -> (a -> IO ()) -> Build (IO ())
addHandler :: forall a. Pulse a -> (a -> IO ()) -> Build (IO ())
addHandler Pulse a
p a -> IO ()
f = do
    Unique
uid <- IO Unique
newUnique
    Pulse a -> ((Unique, Priority), Handler) -> Build (IO ())
forall a. Pulse a -> ((Unique, Priority), Handler) -> Build (IO ())
addHandlerP Pulse a
p ((Unique
uid, Priority
DoIO), Pulse a -> (a -> IO ()) -> Handler
forall a. Pulse a -> (a -> IO ()) -> Handler
whenPulse Pulse a
p a -> IO ()
f)

-- | Read the value of a 'Latch' at a particular moment in Build.
readLatch :: Latch a -> Build a
readLatch :: forall a. Latch a -> Build a
readLatch = Latch a -> EvalL a
forall a. Latch a -> Build a
readL

{-----------------------------------------------------------------------------
    Pulse and Latch
    Public API
------------------------------------------------------------------------------}
-- | Create a new pulse that never occurs.
neverP :: Pulse a
neverP :: forall a. Pulse a
neverP = Pulse
    { addHandlerP :: ((Unique, Priority), Handler) -> Build (IO ())
addHandlerP = Build (IO ()) -> ((Unique, Priority), Handler) -> Build (IO ())
forall a b. a -> b -> a
const (Build (IO ()) -> ((Unique, Priority), Handler) -> Build (IO ()))
-> Build (IO ()) -> ((Unique, Priority), Handler) -> Build (IO ())
forall a b. (a -> b) -> a -> b
$ IO () -> Build (IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
    , evalP :: EvalP (Maybe a)
evalP       = Maybe a -> EvalP (Maybe a)
forall a. a -> RWST () () Values IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    }

-- | Map a function over pulses.
mapP :: (a -> b) -> Pulse a -> Build (Pulse b)
mapP :: forall a b. (a -> b) -> Pulse a -> Build (Pulse b)
mapP a -> b
f Pulse a
p = (Pulse b -> Pulse a -> Pulse b
forall a b. Pulse a -> Pulse b -> Pulse a
`dependOn` Pulse a
p) (Pulse b -> Pulse b) -> IO (Pulse b) -> IO (Pulse b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EvalP (Maybe b) -> IO (Pulse b)
forall a. EvalP (Maybe a) -> Build (Pulse a)
cacheEval (Maybe b -> EvalP (Maybe b)
forall a. a -> RWST () () Values IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe b -> EvalP (Maybe b))
-> (Maybe a -> Maybe b) -> Maybe a -> EvalP (Maybe b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> Maybe a -> Maybe b
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Maybe a -> EvalP (Maybe b))
-> RWST () () Values IO (Maybe a) -> EvalP (Maybe b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Pulse a -> RWST () () Values IO (Maybe a)
forall a. Pulse a -> EvalP (Maybe a)
evalP Pulse a
p)

-- | Map an IO function over pulses. Is only executed once.
unsafeMapIOP :: (a -> IO b) -> Pulse a -> Build (Pulse b)
unsafeMapIOP :: forall a b. (a -> IO b) -> Pulse a -> Build (Pulse b)
unsafeMapIOP a -> IO b
f Pulse a
p = (Pulse b -> Pulse a -> Pulse b
forall a b. Pulse a -> Pulse b -> Pulse a
`dependOn` Pulse a
p) (Pulse b -> Pulse b) -> IO (Pulse b) -> IO (Pulse b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EvalP (Maybe b) -> IO (Pulse b)
forall a. EvalP (Maybe a) -> Build (Pulse a)
cacheEval (Maybe (IO b) -> EvalP (Maybe b)
forall a. Maybe (IO a) -> EvalP (Maybe a)
traverse' (Maybe (IO b) -> EvalP (Maybe b))
-> (Maybe a -> Maybe (IO b)) -> Maybe a -> EvalP (Maybe b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> IO b) -> Maybe a -> Maybe (IO b)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> IO b
f (Maybe a -> EvalP (Maybe b))
-> RWST () () Values IO (Maybe a) -> EvalP (Maybe b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Pulse a -> RWST () () Values IO (Maybe a)
forall a. Pulse a -> EvalP (Maybe a)
evalP Pulse a
p)
    where
    traverse' :: Maybe (IO a) -> EvalP (Maybe a)
    traverse' :: forall a. Maybe (IO a) -> EvalP (Maybe a)
traverse' Maybe (IO a)
Nothing  = Maybe a -> RWST () () Values IO (Maybe a)
forall a. a -> RWST () () Values IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    traverse' (Just IO a
m) = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a)
-> RWST () () Values IO a -> RWST () () Values IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a -> RWST () () Values IO a
forall (m :: * -> *) a. Monad m => m a -> RWST () () Values m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO a
m

-- | Filter occurrences. Only keep those of the form 'Just'.
filterJustP :: Pulse (Maybe a) -> Build (Pulse a)
filterJustP :: forall a. Pulse (Maybe a) -> Build (Pulse a)
filterJustP Pulse (Maybe a)
p = (Pulse a -> Pulse (Maybe a) -> Pulse a
forall a b. Pulse a -> Pulse b -> Pulse a
`dependOn` Pulse (Maybe a)
p) (Pulse a -> Pulse a) -> IO (Pulse a) -> IO (Pulse a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EvalP (Maybe a) -> IO (Pulse a)
forall a. EvalP (Maybe a) -> Build (Pulse a)
cacheEval (Maybe a -> EvalP (Maybe a)
forall a. a -> RWST () () Values IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> EvalP (Maybe a))
-> (Maybe (Maybe a) -> Maybe a)
-> Maybe (Maybe a)
-> EvalP (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Maybe a) -> Maybe a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe a) -> EvalP (Maybe a))
-> RWST () () Values IO (Maybe (Maybe a)) -> EvalP (Maybe a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Pulse (Maybe a) -> RWST () () Values IO (Maybe (Maybe a))
forall a. Pulse a -> EvalP (Maybe a)
evalP Pulse (Maybe a)
p)

-- | Pulse that occurs when either of the pulses occur.
-- Combines values with the indicated function when both occur.
unionWithP :: (a -> a -> a) -> Pulse a -> Pulse a -> Build (Pulse a)
unionWithP :: forall a. (a -> a -> a) -> Pulse a -> Pulse a -> Build (Pulse a)
unionWithP a -> a -> a
f Pulse a
p Pulse a
q = (Pulse a -> Pulse a -> Pulse a
forall a b. Pulse a -> Pulse b -> Pulse a
`dependOn` Pulse a
q) (Pulse a -> Pulse a) -> (Pulse a -> Pulse a) -> Pulse a -> Pulse a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pulse a -> Pulse a -> Pulse a
forall a b. Pulse a -> Pulse b -> Pulse a
`dependOn` Pulse a
p) (Pulse a -> Pulse a) -> IO (Pulse a) -> IO (Pulse a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EvalP (Maybe a) -> IO (Pulse a)
forall a. EvalP (Maybe a) -> Build (Pulse a)
cacheEval EvalP (Maybe a)
eval
    where
    eval :: EvalP (Maybe a)
eval = do
        Maybe a
x <- Pulse a -> EvalP (Maybe a)
forall a. Pulse a -> EvalP (Maybe a)
evalP Pulse a
p
        Maybe a
y <- Pulse a -> EvalP (Maybe a)
forall a. Pulse a -> EvalP (Maybe a)
evalP Pulse a
q
        Maybe a -> EvalP (Maybe a)
forall a. a -> RWST () () Values IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> EvalP (Maybe a)) -> Maybe a -> EvalP (Maybe a)
forall a b. (a -> b) -> a -> b
$ case (Maybe a
x,Maybe a
y) of
            (Maybe a
Nothing, Maybe a
Nothing) -> Maybe a
forall a. Maybe a
Nothing
            (Just a
a , Maybe a
Nothing) -> a -> Maybe a
forall a. a -> Maybe a
Just a
a
            (Maybe a
Nothing, Just a
a ) -> a -> Maybe a
forall a. a -> Maybe a
Just a
a
            (Just a
a1, Just a
a2) -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ a -> a -> a
f a
a1 a
a2

-- | Apply the current latch value whenever the pulse occurs.
applyP :: Latch (a -> b) -> Pulse a -> Build (Pulse b)
applyP :: forall a b. Latch (a -> b) -> Pulse a -> Build (Pulse b)
applyP Latch (a -> b)
l Pulse a
p = (Pulse b -> Pulse a -> Pulse b
forall a b. Pulse a -> Pulse b -> Pulse a
`dependOn` Pulse a
p) (Pulse b -> Pulse b) -> IO (Pulse b) -> IO (Pulse b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EvalP (Maybe b) -> IO (Pulse b)
forall a. EvalP (Maybe a) -> Build (Pulse a)
cacheEval EvalP (Maybe b)
eval
    where
    eval :: EvalP (Maybe b)
eval = do
        a -> b
f <- IO (a -> b) -> RWST () () Values IO (a -> b)
forall (m :: * -> *) a. Monad m => m a -> RWST () () Values m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (a -> b) -> RWST () () Values IO (a -> b))
-> IO (a -> b) -> RWST () () Values IO (a -> b)
forall a b. (a -> b) -> a -> b
$ Latch (a -> b) -> IO (a -> b)
forall a. Latch a -> Build a
readL Latch (a -> b)
l
        Maybe a
a <- Pulse a -> EvalP (Maybe a)
forall a. Pulse a -> EvalP (Maybe a)
evalP Pulse a
p
        Maybe b -> EvalP (Maybe b)
forall a. a -> RWST () () Values IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe b -> EvalP (Maybe b)) -> Maybe b -> EvalP (Maybe b)
forall a b. (a -> b) -> a -> b
$ a -> b
f (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
a

-- | Accumulate values in a latch.
accumL :: a -> Pulse (a -> a) -> Build (Latch a, Pulse a)
accumL :: forall a. a -> Pulse (a -> a) -> Build (Latch a, Pulse a)
accumL a
a Pulse (a -> a)
p1 = do
    -- IORef to hold the current latch value
    IORef a
latch <- a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef a
a
    let l1 :: Latch a
l1 = Latch { readL :: EvalL a
readL = IORef a -> EvalL a
forall a. IORef a -> IO a
readIORef IORef a
latch }

    -- calculate new pulse from old value
    let l2 :: Latch ((a -> c) -> c)
l2 = (a -> (a -> c) -> c) -> Latch a -> Latch ((a -> c) -> c)
forall a b. (a -> b) -> Latch a -> Latch b
mapL (((a -> c) -> a -> c) -> a -> (a -> c) -> c
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> c) -> a -> c
forall a b. (a -> b) -> a -> b
($)) Latch a
l1
    Pulse a
p2 <- Latch ((a -> a) -> a) -> Pulse (a -> a) -> Build (Pulse a)
forall a b. Latch (a -> b) -> Pulse a -> Build (Pulse b)
applyP Latch ((a -> a) -> a)
forall {c}. Latch ((a -> c) -> c)
l2 Pulse (a -> a)
p1

    -- register handler to update latch
    Unique
uid <- IO Unique
newUnique
    let handler :: Handler
handler = Pulse a -> (a -> IO ()) -> Handler
forall a. Pulse a -> (a -> IO ()) -> Handler
whenPulse Pulse a
p2 ((a -> IO ()) -> Handler) -> (a -> IO ()) -> Handler
forall a b. (a -> b) -> a -> b
$ (IORef a -> a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef a
latch (a -> IO ()) -> a -> IO ()
forall a b. (a -> b) -> a -> b
$!)
    Build (IO ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Build (IO ()) -> IO ()) -> Build (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Pulse a -> ((Unique, Priority), Handler) -> Build (IO ())
forall a. Pulse a -> ((Unique, Priority), Handler) -> Build (IO ())
addHandlerP Pulse a
p2 ((Unique
uid, Priority
DoLatch), Handler
handler)
    
    (Latch a, Pulse a) -> Build (Latch a, Pulse a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Latch a
l1,Pulse a
p2)

-- | Latch whose value stays constant.
pureL :: a -> Latch a
pureL :: forall a. a -> Latch a
pureL a
a = Latch { readL :: EvalL a
readL = a -> EvalL a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a }

-- | Map a function over latches.
--
-- Evaluated only when needed, result is not cached.
mapL :: (a -> b) -> Latch a -> Latch b
mapL :: forall a b. (a -> b) -> Latch a -> Latch b
mapL a -> b
f Latch a
l = Latch { readL :: EvalL b
readL = a -> b
f (a -> b) -> IO a -> EvalL b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Latch a -> IO a
forall a. Latch a -> Build a
readL Latch a
l } 

-- | Apply two current latch values
--
-- Evaluated only when needed, result is not cached.
applyL :: Latch (a -> b) -> Latch a -> Latch b
applyL :: forall a b. Latch (a -> b) -> Latch a -> Latch b
applyL Latch (a -> b)
l1 Latch a
l2 = Latch { readL :: EvalL b
readL = Latch (a -> b) -> EvalL (a -> b)
forall a. Latch a -> Build a
readL Latch (a -> b)
l1 EvalL (a -> b) -> IO a -> EvalL b
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Latch a -> IO a
forall a. Latch a -> Build a
readL Latch a
l2 }

{-----------------------------------------------------------------------------
    Test
------------------------------------------------------------------------------}
test :: IO (Int -> IO ())
test :: IO (Int -> IO ())
test = do
    (Pulse Int
p1, Int -> IO ()
fire) <- Build (Pulse Int, Int -> IO ())
forall a. Build (Pulse a, a -> IO ())
newPulse
    Pulse (Int -> Int)
p2     <- (Int -> Int -> Int) -> Pulse Int -> Build (Pulse (Int -> Int))
forall a b. (a -> b) -> Pulse a -> Build (Pulse b)
mapP Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Pulse Int
p1
    (Latch Int
l1,Pulse Int
_) <- Int -> Pulse (Int -> Int) -> Build (Latch Int, Pulse Int)
forall a. a -> Pulse (a -> a) -> Build (Latch a, Pulse a)
accumL Int
0 Pulse (Int -> Int)
p2
    let l2 :: Latch (b -> Int)
l2 =  (Int -> b -> Int) -> Latch Int -> Latch (b -> Int)
forall a b. (a -> b) -> Latch a -> Latch b
mapL Int -> b -> Int
forall a b. a -> b -> a
const Latch Int
l1
    Pulse Int
p3     <- Latch (Int -> Int) -> Pulse Int -> Build (Pulse Int)
forall a b. Latch (a -> b) -> Pulse a -> Build (Pulse b)
applyP Latch (Int -> Int)
forall {b}. Latch (b -> Int)
l2 Pulse Int
p1
    Build (IO ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Build (IO ()) -> IO ()) -> Build (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Pulse Int -> (Int -> IO ()) -> Build (IO ())
forall a. Pulse a -> (a -> IO ()) -> Build (IO ())
addHandler Pulse Int
p3 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 :: Build (IO ())
test_recursion1 = mdo
    (Pulse ()
p1, () -> IO ()
fire) <- Build (Pulse (), () -> IO ())
forall a. Build (Pulse a, a -> IO ())
newPulse
    Pulse Int
p2      <- Latch (() -> Int) -> Pulse () -> Build (Pulse Int)
forall a b. Latch (a -> b) -> Pulse a -> Build (Pulse b)
applyP Latch (() -> Int)
l2 Pulse ()
p1
    Pulse (Int -> Int)
p3      <- (Int -> Int -> Int) -> Pulse Int -> Build (Pulse (Int -> Int))
forall a b. (a -> b) -> Pulse a -> Build (Pulse b)
mapP ((Int -> Int) -> Int -> Int -> Int
forall a b. a -> b -> a
const (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) Pulse Int
p2
    ~(Latch Int
l1,Pulse Int
_) <- Int -> Pulse (Int -> Int) -> Build (Latch Int, Pulse Int)
forall a. a -> Pulse (a -> a) -> Build (Latch a, Pulse a)
accumL (Int
0::Int) Pulse (Int -> Int)
p3
    let l2 :: Latch (b -> Int)
l2  =  (Int -> b -> Int) -> Latch Int -> Latch (b -> Int)
forall a b. (a -> b) -> Latch a -> Latch b
mapL Int -> b -> Int
forall a b. a -> b -> a
const Latch Int
l1
    Build (IO ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Build (IO ()) -> IO ()) -> Build (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Pulse Int -> (Int -> IO ()) -> Build (IO ())
forall a. Pulse a -> (a -> IO ()) -> Build (IO ())
addHandler Pulse Int
p2 Int -> IO ()
forall a. Show a => a -> IO ()
print
    IO () -> Build (IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> Build (IO ())) -> IO () -> Build (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
fire ()