{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Glazier.React.Markup
( ReactMarkup(..)
, BranchParam(..)
, LeafParam(..)
, fromMarkup
, fromElement
, toElements
, toElement
, txt
, lf
, bh
, withMarkup
, modifyMarkup
, overSurfaceProperties
, overAllProperties
) where
import Control.Monad.State.Strict
import qualified Data.DList as DL
import qualified GHCJS.Types as J
import qualified Glazier.React.Element as Z
import qualified JavaScript.Extras as JE
data BranchParam = BranchParam
JE.JSRep
(DL.DList JE.Property)
(DL.DList ReactMarkup)
data LeafParam = LeafParam
JE.JSRep
(DL.DList JE.Property)
data ReactMarkup
= ElementMarkup Z.ReactElement
| TextMarkup J.JSString
| BranchMarkup BranchParam
| LeafMarkup LeafParam
fromMarkup :: ReactMarkup -> IO Z.ReactElement
fromMarkup (BranchMarkup (BranchParam n props xs)) = do
xs' <- sequenceA $ fromMarkup <$> (DL.toList xs)
Z.mkBranchElement n (DL.toList props) xs'
fromMarkup (LeafMarkup (LeafParam n props)) =
Z.mkLeafElement n (DL.toList props)
fromMarkup (TextMarkup str) = pure $ Z.textElement str
fromMarkup (ElementMarkup e) = pure e
fromElement :: MonadState (DL.DList ReactMarkup) m => Z.ReactElement -> m ()
fromElement e = modify' (`DL.snoc` ElementMarkup e)
toElements :: DL.DList ReactMarkup -> IO [Z.ReactElement]
toElements xs = sequenceA $ fromMarkup <$> DL.toList xs
toElement :: DL.DList ReactMarkup -> IO Z.ReactElement
toElement xs = toElements xs >>= Z.mkCombinedElements
txt :: MonadState (DL.DList ReactMarkup) m => J.JSString -> m ()
txt n = modify' (`DL.snoc` TextMarkup n)
lf :: (MonadState (DL.DList ReactMarkup) m)
=> JE.JSRep
-> (DL.DList JE.Property)
-> m ()
lf n props = modify' (`DL.snoc` LeafMarkup (LeafParam n props))
withMarkup :: MonadState (DL.DList ReactMarkup) m
=> (DL.DList ReactMarkup -> DL.DList ReactMarkup -> DL.DList ReactMarkup)
-> m a
-> m a
withMarkup f childs = do
s <- get
put mempty
a <- childs
childs' <- get
put s
modify' (f childs')
pure a
bh :: (MonadState (DL.DList ReactMarkup) m)
=> JE.JSRep
-> (DL.DList JE.Property)
-> m a
-> m a
bh n props = withMarkup (\childs' ms -> ms `DL.snoc` BranchMarkup (BranchParam n props childs'))
modifyMarkup :: MonadState (DL.DList ReactMarkup) m
=> (DL.DList ReactMarkup -> DL.DList ReactMarkup)
-> m a -> m a
modifyMarkup f = withMarkup (\childs' ms -> ms `DL.append` f childs')
overSurfaceProperties ::
(DL.DList JE.Property -> DL.DList JE.Property)
-> (DL.DList ReactMarkup -> DL.DList ReactMarkup)
overSurfaceProperties f childs = DL.fromList $ case DL.toList childs of
LeafMarkup (LeafParam j ps) : bs ->
LeafMarkup (LeafParam j (f ps)) : bs
BranchMarkup (BranchParam j ps as) : bs ->
BranchMarkup (BranchParam j (f ps) as) : bs
bs -> bs
overAllProperties ::
(DL.DList JE.Property -> DL.DList JE.Property)
-> (DL.DList ReactMarkup -> DL.DList ReactMarkup)
overAllProperties f childs = DL.fromList $ case DL.toList childs of
LeafMarkup (LeafParam j ps) : bs ->
LeafMarkup (LeafParam j (f ps)) : bs
BranchMarkup (BranchParam j ps as) : bs ->
BranchMarkup (BranchParam j (f ps) (overAllProperties f as)) : bs
bs -> bs