-----------------------------------------------------------------------------
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RecordWildCards       #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Render
-- Copyright   :  (C) 2016-2025 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <code@dmj.io>
-- Stability   :  experimental
-- Portability :  non-portable
----------------------------------------------------------------------------
module Miso.Render
  ( -- *** Classes
    ToHtml (..)
    -- *** Combinator
  , HTML
  ) where
----------------------------------------------------------------------------
import           Data.Aeson
import           Data.ByteString.Builder
import qualified Data.ByteString.Lazy as L
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as M
import qualified Network.HTTP.Media as M
import           Servant.API (Accept (..), MimeRender (..))
----------------------------------------------------------------------------
import           Miso.String hiding (intercalate)
import           Miso.Types
----------------------------------------------------------------------------
-- | HTML MimeType used for servant APIs
--
-- > type Home = "home" :> Get '[HTML] (Component model action)
--
data HTML
----------------------------------------------------------------------------
-- | @text/html;charset=utf-8@
instance Accept HTML where
  contentTypes :: Proxy HTML -> NonEmpty MediaType
contentTypes Proxy HTML
_ =
    ByteString
"text" ByteString -> ByteString -> MediaType
M.// ByteString
"html" MediaType -> (ByteString, ByteString) -> MediaType
M./: (ByteString
"charset", ByteString
"utf-8") MediaType -> [MediaType] -> NonEmpty MediaType
forall a. a -> [a] -> NonEmpty a
NE.:|
      [ByteString
"text" ByteString -> ByteString -> MediaType
M.// ByteString
"html"]
----------------------------------------------------------------------------
-- | Class for rendering HTML
class ToHtml a where
  toHtml :: a -> L.ByteString
----------------------------------------------------------------------------
-- | Render a @Component@ to a @L.ByteString@
instance ToHtml (Component model action) where
  toHtml :: Component model action -> ByteString
toHtml = Component model action -> ByteString
forall model action. Component model action -> ByteString
renderComponent
----------------------------------------------------------------------------
-- | Render a @View@ to a @L.ByteString@
instance ToHtml (View a) where
  toHtml :: View a -> ByteString
toHtml = View a -> ByteString
forall a. View a -> ByteString
renderView
----------------------------------------------------------------------------
-- | Render a @[View]@ to a @L.ByteString@
instance ToHtml [View a] where
  toHtml :: [View a] -> ByteString
toHtml = (View a -> ByteString) -> [View a] -> ByteString
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap View a -> ByteString
forall a. View a -> ByteString
renderView
----------------------------------------------------------------------------
-- | Render HTML from a servant API
instance ToHtml a => MimeRender HTML a where
  mimeRender :: Proxy HTML -> a -> ByteString
mimeRender Proxy HTML
_ = a -> ByteString
forall a. ToHtml a => a -> ByteString
toHtml
----------------------------------------------------------------------------
renderView :: View a -> L.ByteString
renderView :: forall a. View a -> ByteString
renderView = Builder -> ByteString
toLazyByteString (Builder -> ByteString)
-> (View a -> Builder) -> View a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. View a -> Builder
forall a. View a -> Builder
renderBuilder
----------------------------------------------------------------------------
renderComponent :: Component model action -> L.ByteString
renderComponent :: forall model action. Component model action -> ByteString
renderComponent (Component Maybe Key
_ Text
_ App {model
[CSS]
[Sub action]
Maybe action
Maybe Text
Map Text Capture
LogLevel
model -> View action
action -> Effect model action
model :: model
update :: action -> Effect model action
view :: model -> View action
subs :: [Sub action]
events :: Map Text Capture
styles :: [CSS]
initialAction :: Maybe action
mountPoint :: Maybe Text
logLevel :: LogLevel
logLevel :: forall model action. App model action -> LogLevel
mountPoint :: forall model action. App model action -> Maybe Text
initialAction :: forall model action. App model action -> Maybe action
styles :: forall model action. App model action -> [CSS]
events :: forall model action. App model action -> Map Text Capture
subs :: forall model action. App model action -> [Sub action]
view :: forall model action. App model action -> model -> View action
update :: forall model action.
App model action -> action -> Effect model action
model :: forall model action. App model action -> model
..}) = View action -> ByteString
forall a. View a -> ByteString
renderView (model -> View action
view model
model)
----------------------------------------------------------------------------
intercalate :: Builder -> [Builder] -> Builder
intercalate :: Builder -> [Builder] -> Builder
intercalate Builder
_ [] = Builder
""
intercalate Builder
_ [Builder
x] = Builder
x
intercalate Builder
sep (Builder
x:[Builder]
xs) =
  [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
  [ Builder
x
  , Builder
sep
  , Builder -> [Builder] -> Builder
intercalate Builder
sep [Builder]
xs
  ]
----------------------------------------------------------------------------
renderBuilder :: View a -> Builder
renderBuilder :: forall a. View a -> Builder
renderBuilder (Text Text
"")    = Text -> Builder
forall a. FromMisoString a => Text -> a
fromMisoString Text
" "
renderBuilder (Text Text
s)     = Text -> Builder
forall a. FromMisoString a => Text -> a
fromMisoString Text
s
renderBuilder (TextRaw Text
"") = Text -> Builder
forall a. FromMisoString a => Text -> a
fromMisoString Text
" "
renderBuilder (TextRaw Text
s)  = Text -> Builder
forall a. FromMisoString a => Text -> a
fromMisoString Text
s
renderBuilder (Node NS
_ Text
"doctype" Maybe Key
_ [] []) = Builder
"<!doctype html>"
renderBuilder (Node NS
_ Text
tag Maybe Key
_ [Attribute a]
attrs [View a]
children) =
  [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
  [ Builder
"<"
  , Text -> Builder
forall a. FromMisoString a => Text -> a
fromMisoString Text
tag
  , [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [ Builder
" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> [Builder] -> Builder
intercalate Builder
" " (Attribute a -> Builder
forall action. Attribute action -> Builder
renderAttrs (Attribute a -> Builder) -> [Attribute a] -> [Builder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Attribute a]
attrs)
            | Capture -> Capture
not ([Attribute a] -> Capture
forall a. [a] -> Capture
forall (t :: * -> *) a. Foldable t => t a -> Capture
Prelude.null [Attribute a]
attrs)
            ]
  , Builder
">"
  , [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
      [ (View a -> Builder) -> [View a] -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap View a -> Builder
forall a. View a -> Builder
renderBuilder ([View a] -> [View a]
forall a. [View a] -> [View a]
collapseSiblingTextNodes [View a]
children)
      , Builder
"</" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
forall a. FromMisoString a => Text -> a
fromMisoString Text
tag Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
">"
      ]
    | Text
tag Text -> [Text] -> Capture
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Capture
`notElem` [Text
"img", Text
"input", Text
"br", Text
"hr", Text
"meta", Text
"link"]
    ]
  ]
renderBuilder (Embed [Attribute a]
attributes (SomeComponent (Component Maybe Key
_ Text
mount App {model
[CSS]
[Sub action]
Maybe action
Maybe Text
Map Text Capture
LogLevel
model -> View action
action -> Effect model action
logLevel :: forall model action. App model action -> LogLevel
mountPoint :: forall model action. App model action -> Maybe Text
initialAction :: forall model action. App model action -> Maybe action
styles :: forall model action. App model action -> [CSS]
events :: forall model action. App model action -> Map Text Capture
subs :: forall model action. App model action -> [Sub action]
view :: forall model action. App model action -> model -> View action
update :: forall model action.
App model action -> action -> Effect model action
model :: forall model action. App model action -> model
model :: model
update :: action -> Effect model action
view :: model -> View action
subs :: [Sub action]
events :: Map Text Capture
styles :: [CSS]
initialAction :: Maybe action
mountPoint :: Maybe Text
logLevel :: LogLevel
..}))) =
  [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
  [ String -> Builder
stringUtf8 String
"<div data-component-id=\""
  , Text -> Builder
forall a. FromMisoString a => Text -> a
fromMisoString Text
mount
  , Builder
"\" "
  , Builder -> [Builder] -> Builder
intercalate Builder
" " (Attribute a -> Builder
forall action. Attribute action -> Builder
renderAttrs (Attribute a -> Builder) -> [Attribute a] -> [Builder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Attribute a]
attributes)
  , Builder
">"
  , View action -> Builder
forall a. View a -> Builder
renderBuilder (model -> View action
view model
model)
  , Builder
"</div>"
  ]
----------------------------------------------------------------------------
renderAttrs :: Attribute action -> Builder
renderAttrs :: forall action. Attribute action -> Builder
renderAttrs (Property Text
key Value
value) =
  [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
  [ Text -> Builder
forall a. FromMisoString a => Text -> a
fromMisoString Text
key
  , String -> Builder
stringUtf8 String
"=\""
  , Value -> Builder
toHtmlFromJSON Value
value
  , String -> Builder
stringUtf8 String
"\""
  ]
renderAttrs (Event Sink action -> Object -> LogLevel -> Map Text Capture -> JSM ()
_) = Builder
forall a. Monoid a => a
mempty
renderAttrs (Styles Map Text Text
styles) =
  [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
  [ Builder
"style"
  , String -> Builder
stringUtf8 String
"=\""
  , [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
      [ Text -> Builder
forall a. FromMisoString a => Text -> a
fromMisoString Text
k
      , Char -> Builder
charUtf8 Char
':'
      , Text -> Builder
forall a. FromMisoString a => Text -> a
fromMisoString Text
v
      , Char -> Builder
charUtf8 Char
';'
      ]
    | (Text
k,Text
v) <- Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
M.toList Map Text Text
styles
    ]
  , String -> Builder
stringUtf8 String
"\""
  ]
----------------------------------------------------------------------------
-- | The browser can't distinguish between multiple text nodes
-- and a single text node. So it will always parse a single text node
-- this means we must collapse adjacent text nodes during hydration.
collapseSiblingTextNodes :: [View a] -> [View a]
collapseSiblingTextNodes :: forall a. [View a] -> [View a]
collapseSiblingTextNodes [] = []
collapseSiblingTextNodes (Text Text
x : Text Text
y : [View a]
xs) =
  [View a] -> [View a]
forall a. [View a] -> [View a]
collapseSiblingTextNodes (Text -> View a
forall action. Text -> View action
Text (Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
y) View a -> [View a] -> [View a]
forall a. a -> [a] -> [a]
: [View a]
xs)
collapseSiblingTextNodes (View a
x:[View a]
xs) =
  View a
x View a -> [View a] -> [View a]
forall a. a -> [a] -> [a]
: [View a] -> [View a]
forall a. [View a] -> [View a]
collapseSiblingTextNodes [View a]
xs
----------------------------------------------------------------------------
-- | Helper for turning JSON into Text
-- Object, Array and Null are kind of non-sensical here
toHtmlFromJSON :: Value -> Builder
toHtmlFromJSON :: Value -> Builder
toHtmlFromJSON (String Text
t)   = Text -> Builder
forall a. FromMisoString a => Text -> a
fromMisoString (Text -> Text
forall str. ToMisoString str => str -> Text
ms Text
t)
toHtmlFromJSON (Number Scientific
t)   = Text -> Builder
forall a. FromMisoString a => Text -> a
fromMisoString (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ String -> Text
forall str. ToMisoString str => str -> Text
ms (Scientific -> String
forall a. Show a => a -> String
show Scientific
t)
toHtmlFromJSON (Bool Capture
True)  = Builder
"true"
toHtmlFromJSON (Bool Capture
False) = Builder
"false"
toHtmlFromJSON Value
Null         = Builder
"null"
toHtmlFromJSON (Object Object
o)   = Text -> Builder
forall a. FromMisoString a => Text -> a
fromMisoString (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ String -> Text
forall str. ToMisoString str => str -> Text
ms (Object -> String
forall a. Show a => a -> String
show Object
o)
toHtmlFromJSON (Array Array
a)    = Text -> Builder
forall a. FromMisoString a => Text -> a
fromMisoString (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ String -> Text
forall str. ToMisoString str => str -> Text
ms (Array -> String
forall a. Show a => a -> String
show Array
a)
----------------------------------------------------------------------------