{-# 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 :: forall a. EvalP (Maybe a) -> Build (Pulse a)
cacheEval EvalP (Maybe a)
e = do
    Key (Maybe a)
key <- forall a. IO (Key a)
Vault.newKey
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Pulse
        { addHandlerP :: ((Unique, Priority), Handler) -> Build (IO ())
addHandlerP = \((Unique, Priority), Handler)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *) a. Monad m => a -> m a
return ())
        , evalP :: EvalP (Maybe a)
evalP       = do
            Values
vault <- forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
Monad.get
            case forall a. Key a -> Values -> Maybe a
Vault.lookup Key (Maybe a)
key Values
vault of
                Just Maybe a
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
                    forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
s -> RWST r w s m ()
Monad.put forall a b. (a -> b) -> a -> b
$ forall a. Key a -> a -> Values -> Values
Vault.insert Key (Maybe a)
key Maybe a
a Values
vault
                    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) -> Build (IO ())
addHandlerP = \((Unique, Priority), Handler)
h -> forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Pulse a -> ((Unique, Priority), Handler) -> Build (IO ())
addHandlerP Pulse a
p ((Unique, Priority), Handler)
h forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 <- forall a. Pulse a -> EvalP (Maybe a)
evalP Pulse a
p
    case Maybe a
ma of
        Just a
a  -> forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO ()
f a
a)
        Maybe a
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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         <- forall a. IO (Key a)
Vault.newKey
    IORef (HashMap (Unique, Priority) Handler)
handlersRef <- forall a. a -> IO (IORef a)
newIORef 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
            forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (HashMap (Unique, Priority) Handler)
handlersRef (forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert (Unique, Priority)
uid Handler
m)
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (HashMap (Unique, Priority) Handler)
handlersRef (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 = forall a. Key a -> a -> Values -> Values
Vault.insert Key (Maybe a)
key (forall a. a -> Maybe a
Just a
a) forall a b. (a -> b) -> a -> b
$ Values
Vault.empty
            HashMap (Unique, Priority) Handler
handlers <- forall a. IORef a -> IO a
readIORef IORef (HashMap (Unique, Priority) Handler)
handlersRef
            ([IO ()]
ms, Values
_)  <- forall a. Values -> EvalP a -> IO (a, Values)
runEvalP Values
pulses forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ 
                   [Handler
m | ((Unique
_,Priority
DoLatch),Handler
m) <- forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap (Unique, Priority) Handler
handlers]
                forall a. [a] -> [a] -> [a]
++ [Handler
m | ((Unique
_,Priority
DoIO   ),Handler
m) <- forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap (Unique, Priority) Handler
handlers]  
            forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [IO ()]
ms
        
        evalP :: RWST r () Values IO (Maybe a)
evalP = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Key a -> Values -> Maybe a
Vault.lookup Key (Maybe a)
key forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
Monad.get

    forall (m :: * -> *) a. Monad m => a -> m a
return (Pulse {((Unique, Priority), Handler) -> Build (IO ())
forall {r}. RWST r () Values IO (Maybe a)
evalP :: forall {r}. RWST r () Values IO (Maybe a)
addHandlerP :: ((Unique, Priority), Handler) -> Build (IO ())
evalP :: EvalP (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 :: forall a. Pulse a -> (a -> IO ()) -> Build (IO ())
addHandler Pulse a
p a -> IO ()
f = do
    Unique
uid <- IO Unique
newUnique
    forall a. Pulse a -> ((Unique, Priority), Handler) -> Build (IO ())
addHandlerP Pulse a
p ((Unique
uid, Priority
DoIO), 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 = 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 = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *) a. Monad m => a -> m a
return ())
    , evalP :: EvalP (Maybe a)
evalP       = forall (m :: * -> *) a. Monad m => a -> m a
return 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 = (forall a b. Pulse a -> Pulse b -> Pulse a
`dependOn` Pulse a
p) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. EvalP (Maybe a) -> Build (Pulse a)
cacheEval (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 = (forall a b. Pulse a -> Pulse b -> Pulse a
`dependOn` Pulse a
p) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. EvalP (Maybe a) -> Build (Pulse a)
cacheEval (forall a. Maybe (IO a) -> EvalP (Maybe a)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> IO b
f forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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  = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    traverse (Just IO a
m) = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = (forall a b. Pulse a -> Pulse b -> Pulse a
`dependOn` Pulse (Maybe a)
p) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. EvalP (Maybe a) -> Build (Pulse a)
cacheEval (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 = (forall a b. Pulse a -> Pulse b -> Pulse a
`dependOn` Pulse a
q) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. Pulse a -> Pulse b -> Pulse a
`dependOn` Pulse a
p) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. EvalP (Maybe a) -> Build (Pulse a)
cacheEval RWST () () Values IO (Maybe a)
eval
    where
    eval :: RWST () () Values IO (Maybe a)
eval = do
        Maybe a
x <- forall a. Pulse a -> EvalP (Maybe a)
evalP Pulse a
p
        Maybe a
y <- forall a. Pulse a -> EvalP (Maybe a)
evalP Pulse a
q
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case (Maybe a
x,Maybe a
y) of
            (Maybe a
Nothing, Maybe a
Nothing) -> forall a. Maybe a
Nothing
            (Just a
a , Maybe a
Nothing) -> forall a. a -> Maybe a
Just a
a
            (Maybe a
Nothing, Just a
a ) -> forall a. a -> Maybe a
Just a
a
            (Just a
a1, Just a
a2) -> forall a. a -> Maybe a
Just 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 = (forall a b. Pulse a -> Pulse b -> Pulse a
`dependOn` Pulse a
p) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. EvalP (Maybe a) -> Build (Pulse a)
cacheEval RWST () () Values IO (Maybe b)
eval
    where
    eval :: RWST () () Values IO (Maybe b)
eval = do
        a -> b
f <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Latch a -> Build a
readL Latch (a -> b)
l
        Maybe a
a <- forall a. Pulse a -> EvalP (Maybe a)
evalP Pulse a
p
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ a -> b
f 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 <- forall a. a -> IO (IORef a)
newIORef a
a
    let l1 :: Latch a
l1 = Latch { readL :: EvalL a
readL = forall a. IORef a -> IO a
readIORef IORef a
latch }

    -- calculate new pulse from old value
    let l2 :: Latch ((a -> c) -> c)
l2 = forall a b. (a -> b) -> Latch a -> Latch b
mapL (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
($)) Latch a
l1
    Pulse a
p2 <- forall a b. Latch (a -> b) -> Pulse a -> Build (Pulse b)
applyP 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 = forall a. Pulse a -> (a -> IO ()) -> Handler
whenPulse Pulse a
p2 forall a b. (a -> b) -> a -> b
$ (forall a. IORef a -> a -> IO ()
writeIORef IORef a
latch forall a b. (a -> b) -> a -> b
$!)
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. Pulse a -> ((Unique, Priority), Handler) -> Build (IO ())
addHandlerP Pulse a
p2 ((Unique
uid, Priority
DoLatch), Handler
handler)
    
    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 = 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall a. Latch a -> Build a
readL Latch (a -> b)
l1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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) <- forall a. Build (Pulse a, a -> IO ())
newPulse
    Pulse (Int -> Int)
p2     <- forall a b. (a -> b) -> Pulse a -> Build (Pulse b)
mapP forall a. Num a => a -> a -> a
(+) Pulse Int
p1
    (Latch Int
l1,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 =  forall a b. (a -> b) -> Latch a -> Latch b
mapL forall a b. a -> b -> a
const Latch Int
l1
    Pulse Int
p3     <- forall a b. Latch (a -> b) -> Pulse a -> Build (Pulse b)
applyP forall {b}. Latch (b -> Int)
l2 Pulse Int
p1
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. Pulse a -> (a -> IO ()) -> Build (IO ())
addHandler Pulse Int
p3 forall a. Show a => a -> IO ()
print
    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) <- forall a. Build (Pulse a, a -> IO ())
newPulse
    Pulse Int
p2      <- forall a b. Latch (a -> b) -> Pulse a -> Build (Pulse b)
applyP Latch (() -> Int)
l2 Pulse ()
p1
    Pulse (Int -> Int)
p3      <- forall a b. (a -> b) -> Pulse a -> Build (Pulse b)
mapP (forall a b. a -> b -> a
const (forall a. Num a => a -> a -> a
+Int
1)) Pulse Int
p2
    ~(Latch Int
l1,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  =  forall a b. (a -> b) -> Latch a -> Latch b
mapL forall a b. a -> b -> a
const Latch Int
l1
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. Pulse a -> (a -> IO ()) -> Build (IO ())
addHandler Pulse Int
p2 forall a. Show a => a -> IO ()
print
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ () -> IO ()
fire ()