{-# 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
) where
import Control.Lens
import Control.Monad (void)
import Data.Foldable (traverse_)
import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
import GHC.Generics (Generic)
import Network.URI
import qualified Reflex.Dom.Builder.Class 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)