{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Reflex.Bulmex.Html
( htmlWidget
, HeadSettings(..)
, head_js
, head_css
, head_title
, HeadScript(..)
, script_uri
, script_is_async
, defScript
, defSettings
, writeReadDom
) where
import Control.Lens
import Control.Monad (void)
import Control.Monad (join)
import Data.Aeson
import Data.Aeson.Text
import qualified Data.ByteString.Lazy as LBS
import Data.Foldable (traverse_)
import qualified Data.Map.Strict as Map
import Data.Maybe
import qualified Data.Text as Text
import Data.Text.Encoding
import qualified Data.Text.Lazy as LText
import GHC.Generics (Generic)
import JSDOM
import JSDOM.Generated.Element
import JSDOM.Generated.NonElementParentNode
import Network.URI
import Reflex
import qualified Reflex.Dom.Builder.Class as Dom
import qualified Reflex.Dom.Prerender as Dom
import qualified Reflex.Dom.Widget as Dom
htmlWidget :: (Dom.DomBuilder t m) => HeadSettings -> m a -> m a
htmlWidget settings content =
Dom.el "html" $ do
void $ Dom.el "head" $ do headWidget settings
Dom.el "body" $ content
defSettings :: HeadSettings
defSettings =
HeadSettings {_head_js = mempty, _head_css = mempty, _head_title = mempty}
data HeadSettings = HeadSettings
{ _head_js :: [HeadScript]
, _head_css :: [URI]
, _head_title :: Text.Text
} deriving (Generic, Show)
head_js :: Lens' HeadSettings [HeadScript]
head_js = lens _head_js $ \x b -> x {_head_js = b}
head_css :: Lens' HeadSettings [URI]
head_css = lens _head_css $ \x b -> x {_head_css = b}
head_title :: Lens' HeadSettings Text.Text
head_title = lens _head_title $ \x b -> x {_head_title = b}
data HeadScript = HeadScript
{ _script_is_async :: Bool
, _script_uri :: URI
} deriving (Generic, Show)
defScript :: HeadScript
defScript = HeadScript {_script_is_async = True, _script_uri = nullURI}
script_uri :: Lens' HeadScript URI
script_uri = lens _script_uri $ \x b -> x {_script_uri = b}
script_is_async :: Lens' HeadScript Bool
script_is_async = lens _script_is_async $ \x b -> x {_script_is_async = b}
isasync :: (Text.Text, Text.Text)
isasync = ("async", "true")
scriptToMap :: HeadScript -> Map.Map Text.Text Text.Text
scriptToMap script =
Map.fromList $
if (script ^. script_is_async)
then [isasync, src]
else [src]
where
src = ("src", script ^. script_uri . to (Text.pack . show))
headWidget :: Dom.DomBuilder t m => HeadSettings -> m ()
headWidget settings = do
traverse_ (\attrlist -> Dom.elAttr "script" attrlist Dom.blank) $ settings ^..
head_js .
traversed .
to scriptToMap
void $ Dom.el "title" $ Dom.text $ settings ^. head_title
traverse_
(\href ->
Dom.elAttr
"link"
(Map.fromList
[("rel", "stylesheet"), ("href", href)])
Dom.blank) $
settings ^..
head_css .
traversed .
to (Text.pack . show)
writeReadDom ::
(FromJSON a, ToJSON a, Dom.DomBuilder t m, Dom.Prerender js t m)
=> Text.Text
-> a
-> m (Dynamic t a)
writeReadDom comelid serverState =
Dom.prerender
(do Dom.elAttr
"script"
(Map.fromList [("type", "application/json"), ("id", comelid)]) $
Dom.text $
LText.toStrict $
encodeToLazyText serverState
pure serverState) $ do
mayDoc <- currentDocument
mayEl' <- sequence $ (getElementById <$> mayDoc) <*> pure comelid
mayInner <- sequence $ getInnerHTML <$> join mayEl'
let result = (join $ decode . LBS.fromStrict . encodeUtf8 <$> mayInner)
pure $
fromMaybe
serverState
result