-----------------------------------------------------------------------------
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RecordWildCards       #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Html.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.Html.Render
  ( -- *** Classes
    ToHtml (..)
  ) where
----------------------------------------------------------------------------
import           Data.Aeson
import           Data.ByteString.Builder
import qualified Data.ByteString.Lazy as L
import qualified Data.Map.Strict as M
import           Unsafe.Coerce (unsafeCoerce)
----------------------------------------------------------------------------
import           Miso.String hiding (intercalate)
import           Miso.Types
----------------------------------------------------------------------------
-- | Class for rendering HTML
class ToHtml a where
  toHtml :: a -> L.ByteString
----------------------------------------------------------------------------
-- | Render a @View@ to a @L.ByteString@
instance ToHtml (View m a) where
  toHtml :: View m a -> ByteString
toHtml = View m a -> ByteString
forall m a. View m a -> ByteString
renderView
----------------------------------------------------------------------------
-- | Render a @[View]@ to a @L.ByteString@
instance ToHtml [View m a] where
  toHtml :: [View m a] -> ByteString
toHtml = (View m a -> ByteString) -> [View m 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 m a -> ByteString
forall m a. View m a -> ByteString
renderView
----------------------------------------------------------------------------
-- | Render a @Component parent model action@ to a @L.ByteString@
instance ToHtml (Component parent model action) where
  toHtml :: Component parent model action -> ByteString
toHtml Component {model
[Binding parent model]
[JS]
[CSS]
[Sub action]
Maybe action
Maybe MountPoint
Events
LogLevel
model -> View model action
action -> Effect parent model action
Value -> Maybe action
model :: model
update :: action -> Effect parent model action
view :: model -> View model action
subs :: [Sub action]
events :: Events
styles :: [CSS]
scripts :: [JS]
initialAction :: Maybe action
mountPoint :: Maybe MountPoint
logLevel :: LogLevel
mailbox :: Value -> Maybe action
bindings :: [Binding parent model]
bindings :: forall parent model action.
Component parent model action -> [Binding parent model]
mailbox :: forall parent model action.
Component parent model action -> Value -> Maybe action
logLevel :: forall parent model action.
Component parent model action -> LogLevel
mountPoint :: forall parent model action.
Component parent model action -> Maybe MountPoint
initialAction :: forall parent model action.
Component parent model action -> Maybe action
scripts :: forall parent model action. Component parent model action -> [JS]
styles :: forall parent model action. Component parent model action -> [CSS]
events :: forall parent model action. Component parent model action -> Events
subs :: forall parent model action.
Component parent model action -> [Sub action]
view :: forall parent model action.
Component parent model action -> model -> View model action
update :: forall parent model action.
Component parent model action
-> action -> Effect parent model action
model :: forall parent model action. Component parent model action -> model
..} = View model action -> ByteString
forall m a. View m a -> ByteString
renderView (model -> View model action
view model
model)
----------------------------------------------------------------------------
renderView :: View m a -> L.ByteString
renderView :: forall m a. View m a -> ByteString
renderView = Builder -> ByteString
toLazyByteString (Builder -> ByteString)
-> (View m a -> Builder) -> View m a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. View m a -> Builder
forall m a. View m a -> Builder
renderBuilder
----------------------------------------------------------------------------
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 m a -> Builder
renderBuilder :: forall m a. View m a -> Builder
renderBuilder (VText MountPoint
"")    = MountPoint -> Builder
forall a. FromMisoString a => MountPoint -> a
fromMisoString MountPoint
" "
renderBuilder (VText MountPoint
s)     = MountPoint -> Builder
forall a. FromMisoString a => MountPoint -> a
fromMisoString MountPoint
s
renderBuilder (VTextRaw MountPoint
"") = MountPoint -> Builder
forall a. FromMisoString a => MountPoint -> a
fromMisoString MountPoint
" "
renderBuilder (VTextRaw MountPoint
s)  = MountPoint -> Builder
forall a. FromMisoString a => MountPoint -> a
fromMisoString MountPoint
s
renderBuilder (VNode NS
_ MountPoint
"doctype" [] []) = Builder
"<!doctype html>"
renderBuilder (VNode NS
_ MountPoint
tag [Attribute a]
attrs [View m a]
children) =
  [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
  [ Builder
"<"
  , MountPoint -> Builder
forall a. FromMisoString a => MountPoint -> a
fromMisoString MountPoint
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)
            | Bool -> Bool
not ([Attribute a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
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 m a -> Builder) -> [View m 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 m a -> Builder
forall m a. View m a -> Builder
renderBuilder ([View m a] -> [View m a]
forall m a. [View m a] -> [View m a]
collapseSiblingTextNodes [View m a]
children)
      , Builder
"</" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> MountPoint -> Builder
forall a. FromMisoString a => MountPoint -> a
fromMisoString MountPoint
tag Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
">"
      ]
    | MountPoint
tag MountPoint -> [MountPoint] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [MountPoint
"img", MountPoint
"input", MountPoint
"br", MountPoint
"hr", MountPoint
"meta", MountPoint
"link"]
    ]
  ]
renderBuilder (VComp NS
ns MountPoint
tag [Attribute a]
attrs (SomeComponent Component {model
[Binding m model]
[JS]
[CSS]
[Sub action]
Maybe action
Maybe MountPoint
Events
LogLevel
model -> View model action
action -> Effect m model action
Value -> Maybe action
bindings :: forall parent model action.
Component parent model action -> [Binding parent model]
mailbox :: forall parent model action.
Component parent model action -> Value -> Maybe action
logLevel :: forall parent model action.
Component parent model action -> LogLevel
mountPoint :: forall parent model action.
Component parent model action -> Maybe MountPoint
initialAction :: forall parent model action.
Component parent model action -> Maybe action
scripts :: forall parent model action. Component parent model action -> [JS]
styles :: forall parent model action. Component parent model action -> [CSS]
events :: forall parent model action. Component parent model action -> Events
subs :: forall parent model action.
Component parent model action -> [Sub action]
view :: forall parent model action.
Component parent model action -> model -> View model action
update :: forall parent model action.
Component parent model action
-> action -> Effect parent model action
model :: forall parent model action. Component parent model action -> model
model :: model
update :: action -> Effect m model action
view :: model -> View model action
subs :: [Sub action]
events :: Events
styles :: [CSS]
scripts :: [JS]
initialAction :: Maybe action
mountPoint :: Maybe MountPoint
logLevel :: LogLevel
mailbox :: Value -> Maybe action
bindings :: [Binding m model]
..})) =
  View (ZonkAny 0) a -> Builder
forall m a. View m a -> Builder
renderBuilder (NS
-> MountPoint
-> [Attribute a]
-> [View (ZonkAny 0) a]
-> View (ZonkAny 0) a
forall model action.
NS
-> MountPoint
-> [Attribute action]
-> [View model action]
-> View model action
VNode NS
ns MountPoint
tag [Attribute a]
attrs [ View model action -> View (ZonkAny 0) a
forall a b. a -> b
unsafeCoerce (model -> View model action
view model
model) ])
  -- dmj: Just trust me bro moment.
  -- This is fine to do because we don't need the polymorphism here
  -- when monomorphizing to Builder. Release the skolems.
----------------------------------------------------------------------------
renderAttrs :: Attribute action -> Builder
renderAttrs :: forall action. Attribute action -> Builder
renderAttrs (Property MountPoint
key Value
value) =
  [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
  [ MountPoint -> Builder
forall a. FromMisoString a => MountPoint -> a
fromMisoString MountPoint
key
  , String -> Builder
stringUtf8 String
"=\""
  , Value -> Builder
toHtmlFromJSON Value
value
  , String -> Builder
stringUtf8 String
"\""
  ]
renderAttrs (Event Sink action -> VTree -> LogLevel -> Events -> JSM ()
_) = Builder
forall a. Monoid a => a
mempty
renderAttrs (Styles Map MountPoint MountPoint
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
      [ MountPoint -> Builder
forall a. FromMisoString a => MountPoint -> a
fromMisoString MountPoint
k
      , Char -> Builder
charUtf8 Char
':'
      , MountPoint -> Builder
forall a. FromMisoString a => MountPoint -> a
fromMisoString MountPoint
v
      , Char -> Builder
charUtf8 Char
';'
      ]
    | (MountPoint
k,MountPoint
v) <- Map MountPoint MountPoint -> [(MountPoint, MountPoint)]
forall k a. Map k a -> [(k, a)]
M.toList Map MountPoint MountPoint
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 m a] -> [View m a]
collapseSiblingTextNodes :: forall m a. [View m a] -> [View m a]
collapseSiblingTextNodes [] = []
collapseSiblingTextNodes (VText MountPoint
x : VText MountPoint
y : [View m a]
xs) =
  [View m a] -> [View m a]
forall m a. [View m a] -> [View m a]
collapseSiblingTextNodes (MountPoint -> View m a
forall model action. MountPoint -> View model action
VText (MountPoint
x MountPoint -> MountPoint -> MountPoint
forall a. Semigroup a => a -> a -> a
<> MountPoint
y) View m a -> [View m a] -> [View m a]
forall a. a -> [a] -> [a]
: [View m a]
xs)
collapseSiblingTextNodes (View m a
x:[View m a]
xs) =
  View m a
x View m a -> [View m a] -> [View m a]
forall a. a -> [a] -> [a]
: [View m a] -> [View m a]
forall m a. [View m a] -> [View m a]
collapseSiblingTextNodes [View m 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)   = MountPoint -> Builder
forall a. FromMisoString a => MountPoint -> a
fromMisoString (Text -> MountPoint
forall str. ToMisoString str => str -> MountPoint
ms Text
t)
toHtmlFromJSON (Number Scientific
t)   = MountPoint -> Builder
forall a. FromMisoString a => MountPoint -> a
fromMisoString (MountPoint -> Builder) -> MountPoint -> Builder
forall a b. (a -> b) -> a -> b
$ String -> MountPoint
forall str. ToMisoString str => str -> MountPoint
ms (Scientific -> String
forall a. Show a => a -> String
show Scientific
t)
toHtmlFromJSON (Bool Bool
True)  = Builder
"true"
toHtmlFromJSON (Bool Bool
False) = Builder
"false"
toHtmlFromJSON Value
Null         = Builder
"null"
toHtmlFromJSON (Object Object
o)   = MountPoint -> Builder
forall a. FromMisoString a => MountPoint -> a
fromMisoString (MountPoint -> Builder) -> MountPoint -> Builder
forall a b. (a -> b) -> a -> b
$ String -> MountPoint
forall str. ToMisoString str => str -> MountPoint
ms (Object -> String
forall a. Show a => a -> String
show Object
o)
toHtmlFromJSON (Array Array
a)    = MountPoint -> Builder
forall a. FromMisoString a => MountPoint -> a
fromMisoString (MountPoint -> Builder) -> MountPoint -> Builder
forall a b. (a -> b) -> a -> b
$ String -> MountPoint
forall str. ToMisoString str => str -> MountPoint
ms (Array -> String
forall a. Show a => a -> String
show Array
a)
----------------------------------------------------------------------------