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


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

import Data.IORef
import Data.Monoid (Endo(..))

import           Data.Hashable
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

type Map = Map.HashMap

{-----------------------------------------------------------------------------
    Pulse
------------------------------------------------------------------------------}
-- Turn evaluation action into pulse that caches the value.
cacheEval :: EvalP (Maybe a) -> Build (Pulse a)
cacheEval :: 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 (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 :: forall a.
(((Unique, Priority), Handler) -> Build (IO ()))
-> EvalP (Maybe a) -> Pulse a
Pulse
        { addHandlerP :: ((Unique, Priority), Handler) -> Build (IO ())
addHandlerP = \((Unique, Priority), Handler)
_ -> IO () -> Build (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
        , evalP :: EvalP (Maybe a)
evalP       = do
            Values
vault <- RWST () () Values BuildIO 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 (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 BuildIO ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
s -> RWST r w s m ()
Monad.put (Values -> RWST () () Values BuildIO ())
-> Values -> RWST () () Values BuildIO ()
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 (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 :: Pulse a -> Pulse b -> Pulse a
dependOn Pulse a
p Pulse b
q = Pulse a
p { addHandlerP :: ((Unique, Priority), Handler) -> Build (IO ())
addHandlerP = \((Unique, Priority), Handler)
h -> IO () -> IO () -> IO ()
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 (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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return (a -> IO ()
f a
a)
        Maybe a
Nothing -> IO () -> Handler
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> Handler) -> IO () -> Handler
forall a b. (a -> b) -> a -> b
$ () -> IO ()
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 :: 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 (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)
sequence ([Handler] -> EvalP [IO ()]) -> [Handler] -> EvalP [IO ()]
forall a b. (a -> b) -> a -> b
$ 
                   [Handler
m | ((_,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 | ((_,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 BuildIO (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 BuildIO Values
-> RWST r () Values BuildIO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST r () Values BuildIO 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 (m :: * -> *) a. Monad m => a -> m a
return (Pulse :: forall a.
(((Unique, Priority), Handler) -> Build (IO ()))
-> EvalP (Maybe a) -> Pulse a
Pulse {RWST () () Values BuildIO (Maybe a)
((Unique, Priority), Handler) -> Build (IO ())
forall r. RWST r () Values BuildIO (Maybe a)
evalP :: forall r. RWST r () Values BuildIO (Maybe a)
addHandlerP :: ((Unique, Priority), Handler) -> Build (IO ())
evalP :: RWST () () Values BuildIO (Maybe a)
addHandlerP :: ((Unique, Priority), Handler) -> Build (IO ())
..}, a -> IO ()
fireP)

-- | Register a handler to be executed whenever a pulse occurs.
addHandler :: Pulse a -> (a -> IO ()) -> Build (IO ())
addHandler :: 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 :: Latch a -> Build a
readLatch = Latch a -> Build a
forall a. Latch a -> EvalL a
readL

{-----------------------------------------------------------------------------
    Pulse and Latch
    Public API
------------------------------------------------------------------------------}
-- | Create a new pulse that never occurs.
neverP :: Pulse a
neverP :: Pulse a
neverP = Pulse :: forall a.
(((Unique, Priority), Handler) -> Build (IO ()))
-> EvalP (Maybe a) -> Pulse a
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 (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
    , evalP :: EvalP (Maybe a)
evalP       = Maybe a -> EvalP (Maybe 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 :: (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) -> Build (Pulse b) -> Build (Pulse b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EvalP (Maybe b) -> Build (Pulse b)
forall a. EvalP (Maybe a) -> Build (Pulse a)
cacheEval (Maybe b -> EvalP (Maybe b)
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Maybe a -> EvalP (Maybe b))
-> RWST () () Values BuildIO (Maybe a) -> EvalP (Maybe b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Pulse a -> RWST () () Values BuildIO (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 :: (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) -> Build (Pulse b) -> Build (Pulse b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EvalP (Maybe b) -> Build (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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> IO b
f (Maybe a -> EvalP (Maybe b))
-> RWST () () Values BuildIO (Maybe a) -> EvalP (Maybe b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Pulse a -> RWST () () Values BuildIO (Maybe a)
forall a. Pulse a -> EvalP (Maybe a)
evalP Pulse a
p)
    where
    traverse :: Maybe (IO a) -> EvalP (Maybe a)
    traverse :: Maybe (IO a) -> EvalP (Maybe a)
traverse Maybe (IO a)
Nothing  = Maybe a -> EvalP (Maybe 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 BuildIO a -> EvalP (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a -> RWST () () Values BuildIO 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 :: 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) -> Build (Pulse a) -> Build (Pulse a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EvalP (Maybe a) -> Build (Pulse a)
forall a. EvalP (Maybe a) -> Build (Pulse a)
cacheEval (Maybe a -> EvalP (Maybe 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 BuildIO (Maybe (Maybe a)) -> EvalP (Maybe a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Pulse (Maybe a) -> RWST () () Values BuildIO (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 :: (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) -> Build (Pulse a) -> Build (Pulse a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EvalP (Maybe a) -> Build (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 (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 :: 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) -> Build (Pulse b) -> Build (Pulse b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EvalP (Maybe b) -> Build (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 BuildIO (a -> b)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (a -> b) -> RWST () () Values BuildIO (a -> b))
-> IO (a -> b) -> RWST () () Values BuildIO (a -> b)
forall a b. (a -> b) -> a -> b
$ Latch (a -> b) -> IO (a -> b)
forall a. Latch a -> EvalL 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 (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 :: 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 :: forall a. EvalL a -> Latch a
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 (m :: * -> *) a. Monad m => a -> m a
return (Latch a
l1,Pulse a
p2)

-- | Latch whose value stays constant.
pureL :: a -> Latch a
pureL :: a -> Latch a
pureL a
a = Latch :: forall a. EvalL a -> Latch a
Latch { readL :: EvalL a
readL = a -> EvalL 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 :: (a -> b) -> Latch a -> Latch b
mapL a -> b
f Latch a
l = Latch :: forall a. EvalL a -> Latch a
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 -> EvalL 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 :: Latch (a -> b) -> Latch a -> Latch b
applyL Latch (a -> b)
l1 Latch a
l2 = Latch :: forall a. EvalL a -> Latch a
Latch { readL :: EvalL b
readL = Latch (a -> b) -> EvalL (a -> b)
forall a. Latch a -> EvalL a
readL Latch (a -> b)
l1 EvalL (a -> b) -> IO a -> EvalL b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Latch a -> IO a
forall a. Latch a -> EvalL 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 (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 (m :: * -> *) a. Monad m => a -> m a
return (IO () -> Build (IO ())) -> IO () -> Build (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
fire ()