{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-----------------------------------------------------------------------------
    reactive-banana
------------------------------------------------------------------------------}
module Reactive.Banana.Prim.Mid.Combinators where

import Control.Monad
    ( join )
import Control.Monad.IO.Class
    ( liftIO )

import Reactive.Banana.Prim.Mid.Plumbing
    ( newPulse, newLatch, cachedLatch
    , dependOn, keepAlive, changeParent
    , getValueL
    , readPulseP, readLatchP, readLatchFutureP, liftBuildP,
    )
import qualified Reactive.Banana.Prim.Mid.Plumbing
    ( pureL )
import Reactive.Banana.Prim.Mid.Types
    ( Latch, Future, Pulse, Build, EvalP )

debug :: String -> a -> a
-- debug s = trace s
debug :: forall a. String -> a -> a
debug String
_ = forall a. a -> a
id

{-----------------------------------------------------------------------------
    Combinators - basic
------------------------------------------------------------------------------}
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
p1 = do
    Pulse b
p2 <- forall a. String -> EvalP (Maybe a) -> Build (Pulse a)
newPulse String
"mapP" ({-# SCC mapP #-} forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Pulse a -> EvalP (Maybe a)
readPulseP Pulse a
p1)
    Pulse b
p2 forall child parent. Pulse child -> Pulse parent -> Build ()
`dependOn` Pulse a
p1
    forall (m :: * -> *) a. Monad m => a -> m a
return Pulse b
p2

-- | Tag a 'Pulse' with future values of a 'Latch'.
--
-- This is in contrast to 'applyP' which applies the current value
-- of a 'Latch' to a pulse.
tagFuture :: Latch a -> Pulse b -> Build (Pulse (Future a))
tagFuture :: forall a b. Latch a -> Pulse b -> Build (Pulse (Future a))
tagFuture Latch a
x Pulse b
p1 = do
    Pulse (Future a)
p2 <- forall a. String -> EvalP (Maybe a) -> Build (Pulse a)
newPulse String
"tagFuture" forall a b. (a -> b) -> a -> b
$
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Latch a -> EvalP (Future a)
readLatchFutureP Latch a
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Pulse a -> EvalP (Maybe a)
readPulseP Pulse b
p1
    Pulse (Future a)
p2 forall child parent. Pulse child -> Pulse parent -> Build ()
`dependOn` Pulse b
p1
    forall (m :: * -> *) a. Monad m => a -> m a
return Pulse (Future a)
p2

filterJustP :: Pulse (Maybe a) -> Build (Pulse a)
filterJustP :: forall a. Pulse (Maybe a) -> Build (Pulse a)
filterJustP Pulse (Maybe a)
p1 = do
    Pulse a
p2 <- forall a. String -> EvalP (Maybe a) -> Build (Pulse a)
newPulse String
"filterJustP" ({-# SCC filterJustP #-} forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Pulse a -> EvalP (Maybe a)
readPulseP Pulse (Maybe a)
p1)
    Pulse a
p2 forall child parent. Pulse child -> Pulse parent -> Build ()
`dependOn` Pulse (Maybe a)
p1
    forall (m :: * -> *) a. Monad m => a -> m a
return Pulse a
p2

unsafeMapIOP :: forall a b. (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
p1 = do
        Pulse b
p2 <- forall a. String -> EvalP (Maybe a) -> Build (Pulse a)
newPulse String
"unsafeMapIOP"
            ({-# SCC unsafeMapIOP #-} Maybe a -> RWSIOT BuildR (EvalPW, BuildW) Vault IO (Maybe b)
eval forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Pulse a -> EvalP (Maybe a)
readPulseP Pulse a
p1)
        Pulse b
p2 forall child parent. Pulse child -> Pulse parent -> Build ()
`dependOn` Pulse a
p1
        forall (m :: * -> *) a. Monad m => a -> m a
return Pulse b
p2
    where
    eval :: Maybe a -> EvalP (Maybe b)
    eval :: Maybe a -> RWSIOT BuildR (EvalPW, BuildW) Vault IO (Maybe b)
eval (Just a
x) = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (a -> IO b
f a
x)
    eval Maybe a
Nothing  = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

mergeWithP
  :: (a -> Maybe c)
  -> (b -> Maybe c)
  -> (a -> b -> Maybe c)
  -> Pulse a
  -> Pulse b
  -> Build (Pulse c)
mergeWithP :: forall a c b.
(a -> Maybe c)
-> (b -> Maybe c)
-> (a -> b -> Maybe c)
-> Pulse a
-> Pulse b
-> Build (Pulse c)
mergeWithP a -> Maybe c
f b -> Maybe c
g a -> b -> Maybe c
h Pulse a
px Pulse b
py = do
  Pulse c
p <- forall a. String -> EvalP (Maybe a) -> Build (Pulse a)
newPulse String
"mergeWithP"
       ({-# SCC mergeWithP #-} Maybe a -> Maybe b -> Maybe c
eval forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Pulse a -> EvalP (Maybe a)
readPulseP Pulse a
px forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Pulse a -> EvalP (Maybe a)
readPulseP Pulse b
py)
  Pulse c
p forall child parent. Pulse child -> Pulse parent -> Build ()
`dependOn` Pulse a
px
  Pulse c
p forall child parent. Pulse child -> Pulse parent -> Build ()
`dependOn` Pulse b
py
  forall (m :: * -> *) a. Monad m => a -> m a
return Pulse c
p
  where
    eval :: Maybe a -> Maybe b -> Maybe c
eval Maybe a
Nothing  Maybe b
Nothing  = forall a. Maybe a
Nothing
    eval (Just a
x) Maybe b
Nothing  = a -> Maybe c
f a
x
    eval Maybe a
Nothing  (Just b
y) = b -> Maybe c
g b
y
    eval (Just a
x) (Just b
y) = a -> b -> Maybe c
h a
x b
y

-- See note [LatchRecursion]
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)
f Pulse a
x = do
    Pulse b
p <- forall a. String -> EvalP (Maybe a) -> Build (Pulse a)
newPulse String
"applyP"
        ({-# SCC applyP #-} forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Latch a -> EvalP a
readLatchP Latch (a -> b)
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Pulse a -> EvalP (Maybe a)
readPulseP Pulse a
x)
    Pulse b
p forall child parent. Pulse child -> Pulse parent -> Build ()
`dependOn` Pulse a
x
    forall (m :: * -> *) a. Monad m => a -> m a
return Pulse b
p

pureL :: a -> Latch a
pureL :: forall a. a -> Latch a
pureL = forall a. a -> Latch a
Reactive.Banana.Prim.Mid.Plumbing.pureL

-- specialization of   mapL f = applyL (pureL f)
mapL :: (a -> b) -> Latch a -> Latch b
mapL :: forall a b. (a -> b) -> Latch a -> Latch b
mapL a -> b
f Latch a
lx = forall a. EvalL a -> Latch a
cachedLatch ({-# SCC mapL #-} a -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Latch a -> EvalL a
getValueL Latch a
lx)

applyL :: Latch (a -> b) -> Latch a -> Latch b
applyL :: forall a b. Latch (a -> b) -> Latch a -> Latch b
applyL Latch (a -> b)
lf Latch a
lx = forall a. EvalL a -> Latch a
cachedLatch
    ({-# SCC applyL #-} forall a. Latch a -> EvalL a
getValueL Latch (a -> b)
lf forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Latch a -> EvalL a
getValueL Latch a
lx)

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
    (Pulse a -> Build ()
updateOn, Latch a
x) <- forall a. a -> Build (Pulse a -> Build (), Latch a)
newLatch a
a
    Pulse a
p2 <- forall a. String -> EvalP (Maybe a) -> Build (Pulse a)
newPulse String
"accumL" forall a b. (a -> b) -> a -> b
$ do
      a
a <- forall a. Latch a -> EvalP a
readLatchP Latch a
x
      Maybe (a -> a)
f <- forall a. Pulse a -> EvalP (Maybe a)
readPulseP Pulse (a -> a)
p1
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a -> a
g -> a -> a
g a
a) Maybe (a -> a)
f
    Pulse a
p2 forall child parent. Pulse child -> Pulse parent -> Build ()
`dependOn` Pulse (a -> a)
p1
    Pulse a -> Build ()
updateOn Pulse a
p2
    forall (m :: * -> *) a. Monad m => a -> m a
return (Latch a
x,Pulse a
p2)

-- specialization of accumL
stepperL :: a -> Pulse a -> Build (Latch a)
stepperL :: forall a. a -> Pulse a -> Build (Latch a)
stepperL a
a Pulse a
p = do
    (Pulse a -> Build ()
updateOn, Latch a
x) <- forall a. a -> Build (Pulse a -> Build (), Latch a)
newLatch a
a
    Pulse a -> Build ()
updateOn Pulse a
p
    forall (m :: * -> *) a. Monad m => a -> m a
return Latch a
x

{-----------------------------------------------------------------------------
    Combinators - dynamic event switching
------------------------------------------------------------------------------}
switchL :: Latch a -> Pulse (Latch a) -> Build (Latch a)
switchL :: forall a. Latch a -> Pulse (Latch a) -> Build (Latch a)
switchL Latch a
l Pulse (Latch a)
pl = mdo
    Latch (Latch a)
x <- forall a. a -> Pulse a -> Build (Latch a)
stepperL Latch a
l Pulse (Latch a)
pl
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. EvalL a -> Latch a
cachedLatch forall a b. (a -> b) -> a -> b
$ forall a. Latch a -> EvalL a
getValueL Latch (Latch a)
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Latch a -> EvalL a
getValueL

executeP :: forall a b. Pulse (b -> Build a) -> b -> Build (Pulse a)
executeP :: forall a b. Pulse (b -> Build a) -> b -> Build (Pulse a)
executeP Pulse (b -> Build a)
p1 b
b = do
        Pulse a
p2 <- forall a. String -> EvalP (Maybe a) -> Build (Pulse a)
newPulse String
"executeP" ({-# SCC executeP #-} Maybe (b -> Build a)
-> RWSIOT BuildR (EvalPW, BuildW) Vault IO (Maybe a)
eval forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Pulse a -> EvalP (Maybe a)
readPulseP Pulse (b -> Build a)
p1)
        Pulse a
p2 forall child parent. Pulse child -> Pulse parent -> Build ()
`dependOn` Pulse (b -> Build a)
p1
        forall (m :: * -> *) a. Monad m => a -> m a
return Pulse a
p2
    where
    eval :: Maybe (b -> Build a) -> EvalP (Maybe a)
    eval :: Maybe (b -> Build a)
-> RWSIOT BuildR (EvalPW, BuildW) Vault IO (Maybe a)
eval (Just b -> Build a
x) = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Build a -> EvalP a
liftBuildP (b -> Build a
x b
b)
    eval Maybe (b -> Build a)
Nothing  = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

switchP :: Pulse a -> Pulse (Pulse a) -> Build (Pulse a)
switchP :: forall a. Pulse a -> Pulse (Pulse a) -> Build (Pulse a)
switchP Pulse a
p Pulse (Pulse a)
pp = do
    -- track the latest Pulse in a Latch
    Latch (Pulse a)
lp <- forall a. a -> Pulse a -> Build (Latch a)
stepperL Pulse a
p Pulse (Pulse a)
pp

    -- fetch the latest Pulse value
    Pulse a
pout <- forall a. String -> EvalP (Maybe a) -> Build (Pulse a)
newPulse String
"switchP_out" (forall a. Pulse a -> EvalP (Maybe a)
readPulseP forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Latch a -> EvalP a
readLatchP Latch (Pulse a)
lp)

    let -- switch the Pulse `pout` to a new parent,
        -- keeping track of the new dependencies.
        switch :: RWSIOT BuildR (EvalPW, BuildW) Vault IO (Maybe a)
switch = do
            Maybe (Pulse a)
mnew <- forall a. Pulse a -> EvalP (Maybe a)
readPulseP Pulse (Pulse a)
pp
            case Maybe (Pulse a)
mnew of
                Maybe (Pulse a)
Nothing  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                Just Pulse a
new -> forall a. Build a -> EvalP a
liftBuildP forall a b. (a -> b) -> a -> b
$ Pulse a
pout forall child parent. Pulse child -> Pulse parent -> Build ()
`changeParent` Pulse a
new
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

    Pulse ()
pin <- forall a. String -> EvalP (Maybe a) -> Build (Pulse a)
newPulse String
"switchP_in" forall {a}. RWSIOT BuildR (EvalPW, BuildW) Vault IO (Maybe a)
switch :: Build (Pulse ())
    Pulse ()
pin  forall child parent. Pulse child -> Pulse parent -> Build ()
`dependOn` Pulse (Pulse a)
pp
    
    Pulse a
pout forall child parent. Pulse child -> Pulse parent -> Build ()
`dependOn` Pulse a
p       -- initial dependency
    Pulse a
pout forall child parent. Pulse child -> Pulse parent -> Build ()
`keepAlive` Pulse ()
pin    -- keep switches happening
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Pulse a
pout