{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Glazier.React.Reactor
( AsReactor
, MonadReactor
, ReactorCmd(..)
, ModelState
, mkReactId
, setRender
, mkSubject
, mkSubject'
, withMkSubject
, bookSubjectCleanup
, getModel
, getElementalRef
, rerender
, tickModel
, tickModelThen
, domTrigger
, domTrigger_
, trigger
, trigger_
, onMounted
, onRendered
, onNextRendered
, onTicked
) where
import Control.Also
import Control.DeepSeq
import Control.Lens
import Control.Monad.Delegate
import Control.Monad.Reader
import Control.Monad.State.Strict
import Control.Monad.Trans.Maybe
import Data.Diverse.Lens
import qualified GHCJS.Types as J
import Glazier.Command
import Glazier.React.Entity
import Glazier.React.EventTarget
import Glazier.React.Notice
import Glazier.React.ReactId
import Glazier.React.ReadIORef
import Glazier.React.Subject
import Glazier.React.Widget
import Glazier.React.Window
import qualified JavaScript.Extras as JE
type AsReactor cmd =
( AsFacet [cmd] cmd
, AsFacet (ReactorCmd cmd) cmd
)
type MonadReactor p s cmd m =
( AsReactor cmd
, MonadReader (Entity p s) m
, MonadCommand cmd m
)
type ModelState s = StateT s ReadIORef
data ReactorCmd cmd where
MkReactId :: J.JSString -> (ReactId -> cmd) -> ReactorCmd cmd
SetRender :: Subject s -> Window s () -> ReactorCmd cmd
MkSubject :: Widget cmd s s () -> s -> (Subject s -> cmd) -> ReactorCmd cmd
BookSubjectCleanup :: Subject s -> ReactorCmd cmd
GetModel :: Subject s -> (s -> cmd) -> ReactorCmd cmd
GetElementalRef ::
Subject s
-> ReactId
-> (EventTarget -> cmd)
-> ReactorCmd cmd
Rerender :: Subject s -> ReactorCmd cmd
TickModel :: Subject s -> ModelState s cmd -> ReactorCmd cmd
RegisterDOMListener :: NFData a
=> Subject s
-> JE.JSRep
-> J.JSString
-> (JE.JSRep -> MaybeT IO a)
-> (a -> cmd)
-> ReactorCmd cmd
RegisterReactListener :: NFData a
=> Subject s
-> ReactId
-> J.JSString
-> (JE.JSRep -> MaybeT IO a)
-> (a -> cmd)
-> ReactorCmd cmd
RegisterMountedListener ::
Subject s
-> cmd
-> ReactorCmd cmd
RegisterRenderedListener ::
Subject s
-> cmd
-> ReactorCmd cmd
RegisterNextRenderedListener ::
Subject s
-> cmd
-> ReactorCmd cmd
RegisterTickedListener ::
Subject s
-> cmd
-> ReactorCmd cmd
instance Show (ReactorCmd cmd) where
showsPrec p (MkReactId s _) = showParen (p >= 11) $
showString "MkReactId " . shows s
showsPrec _ (SetRender _ _ ) = showString "SetRender"
showsPrec _ (MkSubject _ _ _) = showString "MkSubject"
showsPrec _ (BookSubjectCleanup _) = showString "BookSubjectCleanup"
showsPrec _ (GetModel _ _) = showString "GetModel"
showsPrec _ (GetElementalRef _ _ _) = showString "GetElementalRef"
showsPrec _ (Rerender _) = showString "Rerender"
showsPrec _ (TickModel _ _) = showString "TickModel"
showsPrec _ (RegisterDOMListener _ _ _ _ _) = showString "RegisterDOMListener"
showsPrec _ (RegisterReactListener _ _ _ _ _) = showString "RegisterReactListener"
showsPrec _ (RegisterMountedListener _ _) = showString "RegisterMountedListener"
showsPrec _ (RegisterRenderedListener _ _) = showString "RegisterRenderedListener"
showsPrec _ (RegisterNextRenderedListener _ _) = showString "RegisterNextRenderedListener"
showsPrec _ (RegisterTickedListener _ _) = showString "RegisterTickedListener"
mkReactId :: (AsReactor cmd, MonadCommand cmd m)
=> J.JSString -> m ReactId
mkReactId n = delegate $ \fire -> do
f <- codify fire
exec' $ MkReactId n f
setRender :: (AsReactor cmd, MonadCommand cmd m)
=> Subject s -> Window s () -> m ()
setRender sbj win = exec' $ SetRender sbj win
mkSubject :: (AsReactor cmd, MonadCommand cmd m)
=> Widget cmd s s a -> s -> m (Either a (Subject s))
mkSubject wid s = delegate $ \fire -> do
f <- codify fire
let wid' = wid >>= (instruct . f . Left)
exec' $ MkSubject wid' s (f . Right)
mkSubject' :: (AsReactor cmd, MonadCommand cmd m)
=> Widget cmd s s () -> s -> m (Subject s)
mkSubject' gad s = delegate $ \fire -> do
f <- codify fire
exec' $ MkSubject gad s f
withMkSubject :: (AsReactor cmd, MonadCommand cmd m)
=> Widget cmd s s a -> s -> (Subject s -> m ()) -> m a
withMkSubject wid s k = delegate $ \fire -> do
f <- codify fire
k' <- codify k
let wid' = wid >>= (instruct . f)
exec' $ MkSubject wid' s k'
bookSubjectCleanup ::
(MonadReactor p allS cmd m)
=> Subject s -> m ()
bookSubjectCleanup sbj = exec' $ BookSubjectCleanup sbj
rerender :: (MonadReactor p s cmd m) => m ()
rerender = do
sbj <- view _subject
exec' $ Rerender sbj
getModel :: (MonadReactor p s cmd m) => m s
getModel = delegate $ \k -> do
Entity sbj slf <- ask
let k' s = case preview slf s of
Nothing -> pure ()
Just s' -> k s'
c <- codify k'
exec' $ GetModel sbj c
getElementalRef :: (MonadReactor p s cmd m) => ReactId -> m EventTarget
getElementalRef ri = delegate $ \k -> do
sbj <- view _subject
c <- codify k
exec' $ GetElementalRef sbj ri c
tickModel :: (MonadReactor p s cmd m) => ModelState s () -> m ()
tickModel m = do
Entity sbj slf <- ask
let m' = zoom slf m
exec' $ TickModel sbj (command_ <$> m')
tickModelThen :: (Also m a, MonadReactor p s cmd m) => ModelState s (m a) -> m a
tickModelThen m = do
Entity sbj slf <- ask
delegate $ \fire -> do
let m' = getAls <$> zoom slf (Als <$> m)
f n = n >>= fire
f' <- codify f
exec' $ TickModel sbj (f' <$> m')
domTrigger ::
( NFData a
, MonadReactor p s cmd m
)
=> JE.JSRep
-> J.JSString
-> (JE.JSRep -> MaybeT IO a)
-> m a
domTrigger j n goStrict = delegate $ \goLazy -> do
Entity sbj _ <- ask
goLazy' <- codify goLazy
exec' $ RegisterDOMListener sbj j n goStrict goLazy'
domTrigger_ ::
( MonadReactor p s cmd m
)
=> JE.JSRep
-> J.JSString
-> a
-> m a
domTrigger_ j n a = do
domTrigger j n (const $ pure ())
pure a
doTrigger ::
( NFData a
, MonadReactor p s cmd m
)
=> ReactId
-> J.JSString
-> (JE.JSRep -> MaybeT IO a)
-> m a
doTrigger ri n goStrict = delegate $ \goLazy -> do
Entity sbj _ <- ask
goLazy' <- codify goLazy
exec' $ RegisterReactListener sbj ri n goStrict goLazy'
trigger ::
( NFData a
, MonadReactor p s cmd m
)
=> ReactId
-> J.JSString
-> (Notice -> MaybeT IO a)
-> m a
trigger ri n goStrict = doTrigger ri n $ handlesNotice goStrict
where
handlesNotice :: (Notice -> MaybeT IO a) -> (JE.JSRep -> MaybeT IO a)
handlesNotice k j = MaybeT (pure $ JE.fromJSR j) >>= k
trigger_ ::
( MonadReactor p s cmd m
)
=> ReactId
-> J.JSString
-> a
-> m a
trigger_ ri n a = do
doTrigger ri n (const $ pure ())
pure a
onMounted ::
MonadReactor p s cmd m
=> m a
-> m a
onMounted m = do
sbj <- view _subject
delegate $ \fire -> do
c <- codify' (m >>= fire)
exec' $ RegisterMountedListener sbj c
onRendered ::
MonadReactor p s cmd m
=> m a
-> m a
onRendered m = do
sbj <- view _subject
delegate $ \fire -> do
c <- codify' (m >>= fire)
exec' $ RegisterRenderedListener sbj c
onNextRendered ::
MonadReactor p s cmd m
=> m a -> m a
onNextRendered m = do
sbj <- view _subject
delegate $ \fire -> do
c <- codify' (m >>= fire)
exec' $ RegisterNextRenderedListener sbj c
onTicked ::
MonadReactor p s cmd m
=> m a
-> m a
onTicked m = do
sbj <- view _subject
delegate $ \fire -> do
c <- codify' (m >>= fire)
exec' $ RegisterTickedListener sbj c