{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Glazier.React.Reactor.Exec
( ReactorEnv(..)
, mkReactorEnvIO
, startApp
, reactorBackgroundWork
, execReactorCmd
, execMkReactId
, execSetRender
, execMkSubject
, execBookSubjectCleanup
, execGetModel
, execGetElementalRef
, execRerender
, execTickModel
, execRegisterDOMListener
, execRegisterReactListener
, execRegisterMountedListener
, execRegisterRenderedListener
, execRegisterNextRenderedListener
, execRegisterTickedListener
) where
import Control.Concurrent
import Control.Concurrent.STM
import Control.DeepSeq
import Control.Lens
import Control.Lens.Misc
import Control.Monad.Delegate
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Maybe.Extras
import Control.Monad.Trans.RWS.Strict
import Control.Monad.Trans.State.Strict
import Data.Diverse.Lens
import qualified Data.DList as DL
import Data.Foldable
import Data.IORef
import qualified Data.JSString as J
import Data.Maybe
import Data.Typeable
import qualified GHCJS.Foreign.Callback as J
import qualified GHCJS.Foreign.Callback.Internal as J
import qualified GHCJS.Foreign.Export as J
import qualified GHCJS.Types as J
import Glazier.Command
import Glazier.React.Component
import Glazier.React.Entity
import Glazier.React.EventTarget
import Glazier.React.Gadget
import Glazier.React.Markup
import Glazier.React.ReactDOM
import Glazier.React.ReactId.Internal
import Glazier.React.Reactor
import Glazier.React.ReadIORef
import Glazier.React.Scene
import Glazier.React.Subject
import Glazier.React.Subject.Internal
import Glazier.React.Widget
import Glazier.React.Window
import qualified JavaScript.Extras as JE
#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,10,0)
import Data.Semigroup
#endif
data ReactorEnv = ReactorEnv
{ reactIdEnv :: MVar Int
, reactorBackgroundEnv :: TQueue (IO (IO ()))
}
makeLenses_ ''ReactorEnv
mkReactorEnvIO :: IO (ReactorEnv)
mkReactorEnvIO = ReactorEnv <$> (newMVar (0 :: Int)) <*> newTQueueIO
startApp ::
( MonadIO m
, MonadReader r m
, Has ReactorEnv r
, Typeable s
, AsReactor cmd
, AsFacet (IO cmd) cmd
)
=> (cmd -> m ()) -> Widget cmd s s () -> s -> JE.JSRep -> m ()
startApp executor wid s root = do
q <- view ((hasLens @ReactorEnv)._reactorBackgroundEnv)
liftIO $ void $ forkIO $ forever $ reactorBackgroundWork q
sbjVar <- liftIO $ newEmptyMVar
let setup = do
sbj <- mkSubject' wid s
exec' (command_ <$> (putMVar sbjVar sbj))
cs = (`execState` mempty) $ evalContT setup
traverse_ executor cs
liftIO $ do
sbj <- takeMVar sbjVar
markup <- unReadIORef $ (`execStateT` mempty) $ displaySubject sbj
e <- toElement markup
renderDOM e root
void $ J.export sbj
reactorBackgroundWork :: TQueue (IO (IO ())) -> IO ()
reactorBackgroundWork q = do
x <- atomically $ readTQueue q
y <- x
ys <- go (DL.singleton y)
fold ys
where
go zs = do
xs <- atomically $ flushTQueue q
case xs of
[] -> pure zs
xs' -> do
ys <- sequence xs'
go (zs <> DL.fromList ys)
execReactorCmd ::
( MonadUnliftIO m
, MonadReader r m
, AsReactor cmd
, Has ReactorEnv r
)
=> (cmd -> m ()) -> ReactorCmd cmd -> m ()
execReactorCmd executor c = case c of
MkReactId n k -> execMkReactId n >>= (executor . k)
SetRender sbj w -> execSetRender sbj w
MkSubject wid s k -> execMkSubject executor wid s >>= (executor . k)
GetModel sbj k -> execGetModel sbj >>= (executor . k)
GetElementalRef sbj ri k -> execGetElementalRef executor sbj ri k
Rerender sbj -> execRerender sbj
TickModel sbj tick -> execTickModel sbj tick >>= executor
BookSubjectCleanup sbj -> execBookSubjectCleanup sbj
RegisterDOMListener sbj j n goStrict goLazy -> execRegisterDOMListener executor sbj j n goStrict goLazy
RegisterReactListener sbj ri n goStrict goLazy -> execRegisterReactListener executor sbj ri n goStrict goLazy
RegisterMountedListener sbj k -> execRegisterMountedListener executor sbj k
RegisterRenderedListener sbj k -> execRegisterRenderedListener executor sbj k
RegisterNextRenderedListener sbj k -> execRegisterNextRenderedListener executor sbj k
RegisterTickedListener sbj k -> execRegisterTickedListener executor sbj k
execMkReactId ::
( MonadIO m
, Has ReactorEnv r
, MonadReader r m
)
=> J.JSString
-> m ReactId
execMkReactId n = do
v <- view ((hasLens @ReactorEnv)._reactIdEnv)
liftIO $ do
i <- takeMVar v
let i' = JE.safeIncrement i
putMVar v i'
pure . ReactId . J.append n . J.cons ':' . J.pack $ show i'
doRender :: IORef (Scene s) -> Window s () -> IO J.JSVal
doRender scnRef win = do
scn <- readIORef scnRef
(mrkup, _) <- unReadIORef (execRWST win scn mempty)
a <- JE.toJS <$> toElement mrkup
pure a
doRef :: IORef (Scene s) -> MVar (Scene s) -> J.JSVal -> IO ()
doRef scnRef scnVar j = do
scn <- takeMVar scnVar
let scn' = scn & _plan._componentRef .~ (JE.fromJS j)
atomicWriteIORef scnRef scn'
putMVar scnVar scn'
doRendered :: IORef (Scene s) -> MVar (Scene s) -> IO ()
doRendered scnRef scnVar = do
scn <- takeMVar scnVar
let scn' = scn & _plan._nextRenderedListener .~ mempty
nxt = scn ^. _plan._nextRenderedListener
cb = scn ^. _plan._renderedListener
atomicWriteIORef scnRef scn'
putMVar scnVar scn'
nxt
cb
doMounted :: IORef (Scene s) -> IO ()
doMounted scnRef = do
scn <- readIORef scnRef
scn ^. _plan._mountedListener
execSetRender :: MonadIO m => Subject s -> Window s () -> m ()
execSetRender sbj win = liftIO $ do
renderCb <- J.syncCallback' (doRender scnRef win)
renderLease <- liftIO $ newEmptyMVar
void $ mkWeakMVar renderLease $ J.releaseCallback renderCb
scn <- takeMVar scnVar
atomicWriteIORef rndrLeaseRef renderLease
let scn' = scn & _plan._shimCallbacks._shimRender .~ renderCb
atomicWriteIORef scnRef scn'
putMVar scnVar scn'
where
scnRef = sceneRef sbj
scnVar = sceneVar sbj
rndrLeaseRef = renderLeaseRef sbj
execMkSubject ::
( MonadIO m
, AsReactor cmd
, Has ReactorEnv r
, MonadReader r m
)
=> (cmd -> m ())
-> Widget cmd s s ()
-> s
-> m (Subject s)
execMkSubject executor wid s = do
ri <- execMkReactId (J.pack "plan")
(sbj, cs) <- liftIO $ do
let newPlan = Plan
ri
Nothing
(ShimCallbacks (J.Callback J.nullRef) (J.Callback J.nullRef) (J.Callback J.nullRef) (J.Callback J.nullRef))
mempty
mempty
mempty
mempty
mempty
mempty
mempty
False
False
scn = Scene newPlan s
scnRef <- newIORef scn
scnVar <- newEmptyMVar
otherCbLease <- newEmptyMVar
renderLease <- newEmptyMVar
rndrLeaseRef <- newIORef renderLease
renderCb <- J.syncCallback' (pure J.nullRef)
refCb <- J.syncCallback1 J.ContinueAsync (doRef scnRef scnVar)
mountedCb <- J.syncCallback J.ContinueAsync (doMounted scnRef)
renderedCb <- J.syncCallback J.ContinueAsync (doRendered scnRef scnVar)
void $ mkWeakMVar otherCbLease $ do
scn' <- readIORef scnRef
scn' ^. _plan._finalCleanup
traverse_ (traverse (J.releaseCallback . fst) . reactListeners) (scn' ^. _plan._elementals)
traverse_ (J.releaseCallback . fst) (scn' ^. _plan._domlListeners)
J.releaseCallback refCb
J.releaseCallback renderedCb
void $ mkWeakMVar renderLease $ J.releaseCallback renderCb
let sbj = Subject scnRef scnVar rndrLeaseRef otherCbLease
gad = runExceptT wid
gad' = gad `bindLeft` (exec' . SetRender sbj)
gad'' = (either id id) <$> gad'
tick = runGadget gad'' (Entity sbj id) pure
cs = execState tick mempty
scn' = scn & _plan._shimCallbacks .~ ShimCallbacks renderCb mountedCb renderedCb refCb
atomicWriteIORef scnRef scn'
putMVar scnVar scn'
pure (sbj, cs)
executor (command' $ DL.toList cs)
pure sbj
execBookSubjectCleanup ::
( MonadIO m
, MonadReader r m
, Has ReactorEnv r
)
=> Subject s -> m ()
execBookSubjectCleanup sbj = do
liftIO $ do
scn <- takeMVar scnVar
let cleanup = prolong sbj
scn' = scn & _plan._nextRenderedListener %~ (*> cleanup)
atomicWriteIORef scnRef scn'
putMVar scnVar scn'
execRerender sbj
where
scnRef = sceneRef sbj
scnVar = sceneVar sbj
execGetModel ::
MonadIO m
=> Subject s
-> m s
execGetModel sbj = liftIO . fmap model . readIORef $ sceneRef sbj
execRerender ::
( MonadIO m
, MonadReader r m
, Has ReactorEnv r
)
=> Subject s -> m ()
execRerender sbj = do
q <- view ((hasLens @ReactorEnv)._reactorBackgroundEnv)
liftIO $ do
scn <- takeMVar scnVar
if not (scn ^. _plan._rerenderRequired)
then do
let scn' = scn & _plan._rerenderRequired .~ True
atomicWriteIORef scnRef scn'
putMVar scnVar scn'
atomically $ writeTQueue q (pure (scheduleRerender sbj))
else putMVar scnVar scn
where
scnRef = sceneRef sbj
scnVar = sceneVar sbj
scheduleRerender :: Subject s -> IO ()
scheduleRerender sbj = do
scn <- takeMVar scnVar
if scn ^. _plan._rerenderRequired
then do
let scn' = scn & _plan._rerenderRequired .~ False
& _plan._tickedNotified .~ False
atomicWriteIORef scnRef scn'
putMVar scnVar scn'
case scn ^. _plan._componentRef of
Nothing -> pure ()
Just j -> rerenderShim j
else putMVar scnVar scn
where
scnRef = sceneRef sbj
scnVar = sceneVar sbj
execTickModel ::
( MonadIO m
, MonadReader r m
, Has ReactorEnv r
)
=> Subject s
-> ModelState s cmd
-> m cmd
execTickModel sbj tick = do
q <- view ((hasLens @ReactorEnv)._reactorBackgroundEnv)
liftIO $ do
scn <- takeMVar scnVar
let s = scn ^. _model
(c, s') <- unReadIORef $ runStateT tick s
let scn' = scn & _model .~ s'
atomicWriteIORef scnRef scn'
putMVar scnVar scn'
atomically $ writeTQueue q notifyTicked
pure c
where
scnRef = sceneRef sbj
scnVar = sceneVar sbj
notifyTicked = do
scn <- takeMVar scnVar
if not (scn ^. _plan._tickedNotified)
then do
let scn' = scn & _plan._tickedNotified .~ True
& _plan._rerenderRequired .~ True
cb = scn ^. _plan._tickedListener
atomicWriteIORef scnRef scn'
putMVar scnVar scn'
cb
pure (scheduleRerender sbj)
else do
putMVar scnVar scn
pure (pure ())
mkEventCallback ::
(MonadIO m)
=> IORef (J.JSVal -> IO (), IO ())
-> m (J.Callback (J.JSVal -> IO ()))
mkEventCallback hdlRef = do
liftIO $ J.syncCallback1 J.ContinueAsync $ \evt -> do
(preprocessor, postprocessor) <- readIORef hdlRef
preprocessor evt
postprocessor
mkEventHandler :: (NFData a) => (evt -> MaybeT IO a) -> IO (evt -> IO (), MaybeT IO a)
mkEventHandler goStrict = do
c <- newTQueueIO
let preprocess evt = (`evalMaybeT` ()) $ do
r <- goStrict evt
lift $ atomically $ writeTQueue c $!! r
postprocess = MaybeT $ atomically $ tryReadTQueue c
pure (preprocess, postprocess)
addEventHandler :: (NFData a)
=> (JE.JSRep -> MaybeT IO a)
-> (a -> IO ())
-> IORef (J.JSVal -> IO (), IO ())
-> IO ()
addEventHandler goStrict goLazy listenerRef = do
(preprocessor, postprocessor) <- mkEventHandler (goStrict . JE.toJSR)
let postprocessor' = (`evalMaybeT` ()) (postprocessor >>= (lift . goLazy))
atomicModifyIORef' listenerRef $ \hdl -> (hdl `mappendListener` (preprocessor, postprocessor'), ())
data Freshness = Existing | Fresh
execGetElementalRef ::
( MonadUnliftIO m
, MonadReader r m
, Has ReactorEnv r
)
=> (cmd -> m ())
-> Subject s
-> ReactId
-> (EventTarget -> cmd)
-> m ()
execGetElementalRef executor sbj ri k = do
UnliftIO u <- askUnliftIO
scn <- liftIO $ takeMVar scnVar
(refFreshness, pln) <- registerRefCoreListener sbj ri (plan scn)
let tryAgain = u $ execGetElementalRef executor sbj ri k
pln' = pln & _nextRenderedListener %~ (*> tryAgain)
scn' = scn & _plan .~ pln'
ret = pln ^? (_elementals.ix ri._elementalRef._Just)
doTryAgain = do
liftIO $ do
atomicWriteIORef scnRef scn'
putMVar scnVar scn'
execRerender sbj
case refFreshness of
Fresh -> doTryAgain
Existing -> case ret of
Nothing -> doTryAgain
Just ret' -> do
liftIO $ putMVar scnVar scn
executor . k $ ret'
where
scnRef = sceneRef sbj
scnVar = sceneVar sbj
registerRefCoreListener :: (MonadIO m)
=> Subject s
-> ReactId
-> Plan
-> m (Freshness, Plan)
registerRefCoreListener sbj ri pln = do
liftIO $ do
(freshness, eventHdl) <-
case pln ^. _elementals.at ri.to (fromMaybe (Elemental Nothing mempty))._reactListeners.at n of
Nothing -> do
listenerRef <- newIORef mempty
cb <- mkEventCallback listenerRef
addEventHandler (pure . JE.fromJSR) hdlRef listenerRef
pure (Fresh, (cb, listenerRef))
Just eventHdl -> pure (Existing, eventHdl)
let pln' = pln & _elementals.at ri %~ (Just . addElem . initElem)
initElem = fromMaybe (Elemental Nothing mempty)
addElem = _reactListeners.at n %~ addListener
addListener = Just . maybe eventHdl (const eventHdl)
case freshness of
Fresh -> pure (Fresh, pln')
Existing -> pure (Existing, pln)
where
n = J.pack "ref"
scnRef = sceneRef sbj
scnVar = sceneVar sbj
hdlRef x = do
scn <- takeMVar scnVar
let scn' = scn & _plan._elementals.ix ri._elementalRef .~ x
atomicWriteIORef scnRef scn'
putMVar scnVar scn'
execRegisterReactListener :: (NFData a, MonadUnliftIO m)
=> (cmd -> m ())
-> Subject s
-> ReactId
-> J.JSString
-> (JE.JSRep -> MaybeT IO a)
-> (a -> cmd)
-> m ()
execRegisterReactListener executor sbj ri n goStrict goLazy = do
UnliftIO u <- askUnliftIO
scn_ <- liftIO $ takeMVar scnVar
scn <- if (n == (J.pack "ref"))
then do
(refFreshness, pln) <- registerRefCoreListener sbj ri (plan scn_)
case refFreshness of
Existing -> pure scn_
Fresh -> pure (scn_ & _plan .~ pln)
else pure scn_
liftIO $ do
(freshness, eventHdl@(_, listenerRef)) <-
case scn ^. _plan._elementals.at ri.to (fromMaybe (Elemental Nothing mempty))._reactListeners.at n of
Nothing -> do
listenerRef <- newIORef mempty
cb <- mkEventCallback listenerRef
pure (Fresh, (cb, listenerRef))
Just eventHdl -> pure (Existing, eventHdl)
let scn' = case freshness of
Fresh -> scn & _plan._elementals.at ri %~ (Just . addElem . initElem)
Existing -> scn
initElem = fromMaybe (Elemental Nothing mempty)
addElem = _reactListeners.at n %~ addListener
addListener = Just . maybe eventHdl (const eventHdl)
addEventHandler goStrict (u . executor . goLazy) listenerRef
atomicWriteIORef scnRef scn'
putMVar scnVar scn'
where
scnRef = sceneRef sbj
scnVar = sceneVar sbj
mappendListener :: (J.JSVal -> IO (), IO ()) -> (J.JSVal -> IO (), IO ()) -> (J.JSVal -> IO (), IO ())
mappendListener (f1, g1) (f2, g2) = (\x -> f1 x *> f2 x, g1 *> g2)
execRegisterTickedListener :: (MonadUnliftIO m)
=> (cmd -> m ())
-> Subject s
-> cmd
-> m ()
execRegisterTickedListener executor sbj c = do
UnliftIO u <- askUnliftIO
let hdl = u $ executor c
liftIO $ do
scn <- takeMVar scnVar
let scn' = scn & _plan._tickedListener %~ (*> hdl)
atomicWriteIORef scnRef scn'
putMVar scnVar scn'
where
scnRef = sceneRef sbj
scnVar = sceneVar sbj
execRegisterMountedListener :: (MonadUnliftIO m)
=> (cmd -> m ())
-> Subject s
-> cmd
-> m ()
execRegisterMountedListener executor sbj c = do
UnliftIO u <- askUnliftIO
let hdl = u $ executor c
liftIO $ do
scn <- takeMVar scnVar
let scn' = scn & _plan._mountedListener %~ (*> hdl)
atomicWriteIORef scnRef scn'
putMVar scnVar scn'
where
scnRef = sceneRef sbj
scnVar = sceneVar sbj
execRegisterRenderedListener :: (MonadUnliftIO m)
=> (cmd -> m ())
-> Subject s
-> cmd
-> m ()
execRegisterRenderedListener executor sbj c = do
UnliftIO u <- askUnliftIO
let hdl = u $ executor c
liftIO $ do
scn <- takeMVar scnVar
let scn' = scn & _plan._renderedListener %~ (*> hdl)
atomicWriteIORef scnRef scn'
putMVar scnVar scn'
where
scnRef = sceneRef sbj
scnVar = sceneVar sbj
execRegisterNextRenderedListener :: (MonadUnliftIO m)
=> (cmd -> m ())
-> Subject s
-> cmd
-> m ()
execRegisterNextRenderedListener executor sbj c = do
UnliftIO u <- askUnliftIO
let hdl = u $ executor c
liftIO $ do
scn <- takeMVar scnVar
let scn' = scn & _plan._nextRenderedListener %~ (*> hdl)
atomicWriteIORef scnRef scn'
putMVar scnVar scn'
where
scnRef = sceneRef sbj
scnVar = sceneVar sbj
execRegisterDOMListener ::
( NFData a
, MonadUnliftIO m
, Has ReactorEnv r
, MonadReader r m
)
=> (cmd -> m ())
-> Subject s
-> JE.JSRep
-> J.JSString
-> (JE.JSRep -> MaybeT IO a)
-> (a -> cmd)
-> m ()
execRegisterDOMListener executor sbj j n goStrict goLazy = do
UnliftIO u <- askUnliftIO
ri <- execMkReactId n
liftIO $ do
scn <- takeMVar scnVar
listenerRef <- newIORef mempty
cb <- mkEventCallback listenerRef
addEventHandler goStrict (u . executor . goLazy) listenerRef
let scn' = scn & _plan._domlListeners.at ri .~ (Just (cb, listenerRef))
& _plan._finalCleanup %~ (*> removeDomListener j n cb)
atomicWriteIORef scnRef scn'
putMVar scnVar scn'
addDomListener j n cb
where
scnRef = sceneRef sbj
scnVar = sceneVar sbj
addDomListener :: JE.JSRep -> J.JSString -> J.Callback (J.JSVal -> IO ()) -> IO ()
addDomListener j n cb = js_addDomListener (JE.toJS j) n (JE.toJS cb)
removeDomListener :: JE.JSRep -> J.JSString -> J.Callback (J.JSVal -> IO ()) -> IO ()
removeDomListener j n cb = js_removeDomListener (JE.toJS j) n (JE.toJS cb)
#ifdef __GHCJS__
foreign import javascript unsafe
"if ($1 && $1['addEventListener']) { $1['addEventListener']($2, $3); }"
js_addDomListener :: J.JSVal -> J.JSString -> J.JSVal -> IO ()
foreign import javascript unsafe
"if ($1 && $1['removeEventListener']) { $1['removeEventListener']($2, $3); }"
js_removeDomListener :: J.JSVal -> J.JSString -> J.JSVal -> IO ()
#else
js_addDomListener :: J.JSVal -> J.JSString -> J.JSVal -> IO ()
js_addDomListener _ _ _ = pure mempty
js_removeDomListener :: J.JSVal -> J.JSString -> J.JSVal -> IO ()
js_removeDomListener _ _ _ = pure mempty
#endif