-----------------------------------------------------------------------------
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE CPP                   #-}
#ifdef SSR
{-# LANGUAGE RecordWildCards       #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Html.Render
-- Copyright   :  (C) 2016-2026 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <code@dmj.io>
-- Stability   :  experimental
-- Portability :  non-portable
--
-- = Overview
--
-- "Miso.Html.Render" provides the 'ToHtml' typeclass for serialising a
-- 'Miso.Types.View' tree to a lazy 'Data.ByteString.Lazy.ByteString' of
-- UTF-8 HTML. This is the foundation of miso's
-- <https://en.wikipedia.org/wiki/Server-side_scripting server-side rendering (SSR)>
-- support.
--
-- Instances are provided for both @'Miso.Types.View' m a@ (a single node)
-- and @['Miso.Types.View' m a]@ (a sequence of nodes).
--
-- = Quick start
--
-- @
-- import           "Miso.Html.Render" ('ToHtml', 'toHtml')
-- import qualified Data.ByteString.Lazy as L
--
-- renderPage :: Model -> L.ByteString
-- renderPage m = 'toHtml' (view m)
-- @
--
-- With @servant@, use @'toHtml'@ inside a @'Data.ByteString.Lazy.ByteString'@
-- or @OctetStream@ response, or wire it into a 'Miso.Html.Render.ToHtml' servant
-- MIME type.
--
-- = Rendering rules
--
-- * __'Miso.Types.VNode'__ — rendered as @\<tag attrs\>children\<\/tag\>@.
--   Self-closing elements (@\<br\/\>@, @\<img\/\>@, @\<input\/\>@, …) are
--   rendered without a closing tag.
-- * __'Miso.Types.VText'__ — rendered as a raw text string (no escaping
--   beyond what is already in the 'Miso.String.MisoString').
-- * __'Miso.Types.VComp'__ — recursively renders the sub-component's view
--   using its initial (or hydrated) model.
-- * __'Miso.Types.VFrag'__ — renders all children inline, no wrapper tag.
-- * __Event handlers__ (@'Miso.Types.On'@) — silently dropped; they have
--   no meaning in a static HTML string.
-- * __Boolean properties__ (@disabled@, @checked@, @required@, …) — rendered
--   as bare attribute names when @True@, omitted entirely when @False@.
-- * __Adjacent text nodes__ — collapsed into a single text node to match
--   browser parsing behaviour during hydration.
--
-- = SSR flag
--
-- When compiled with @-fssr@ the renderer calls the component's optional
-- @hydrateModel@ action to derive the initial model (e.g. by fetching from
-- a database), falling back to the static @model@ if the action throws.
--
-- = See also
--
-- * "Miso.Hydrate" — client-side hydration from server-rendered HTML
-- * "Miso.Html.Element" — element smart constructors
-- * "Miso.Html" — top-level HTML DSL re-export hub
-----------------------------------------------------------------------------
module Miso.Html.Render
  ( -- *** Classes
    ToHtml (..)
  ) where
----------------------------------------------------------------------------
import qualified Data.Set as S
import           Data.Set (Set)
import           Data.ByteString.Builder
import qualified Data.ByteString.Lazy as L
import qualified Data.Map.Strict as M
import           System.IO.Unsafe (unsafePerformIO)
#ifdef SSR
import           Control.Exception (SomeException, catch)
#endif
----------------------------------------------------------------------------
import           Data.IORef (readIORef)
import           GHC.StaticPtr
----------------------------------------------------------------------------
import           Miso.JSON
import           Miso.Runtime (globalContext)
import           Miso.String hiding (intercalate)
import qualified Miso.String as MS
import           Miso.Types
----------------------------------------------------------------------------
-- | Class for rendering HTML
class ToHtml a where
  toHtml :: a -> L.ByteString
----------------------------------------------------------------------------
-- | Render a @Miso.Types.View@ to a @L.ByteString@
instance ToHtml (View context model action) where
  toHtml :: View context model action -> ByteString
toHtml = View context model action -> ByteString
forall context model action.
View context model action -> ByteString
renderView
----------------------------------------------------------------------------
-- | Render a @[Miso.Types.View]@ to a @L.ByteString@
instance ToHtml [View context model action] where
  toHtml :: [View context model action] -> ByteString
toHtml = (View context model action -> ByteString)
-> [View context model action] -> 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 context model action -> ByteString
forall context model action.
View context model action -> ByteString
renderView
----------------------------------------------------------------------------
renderView :: View context model action -> L.ByteString
renderView :: forall context model action.
View context model action -> ByteString
renderView = Builder -> ByteString
toLazyByteString (Builder -> ByteString)
-> (View context model action -> Builder)
-> View context model action
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. View context model action -> Builder
forall context model action. View context model action -> 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
  ]
----------------------------------------------------------------------------
booleanProperties :: Set MisoString
booleanProperties :: Set MisoString
booleanProperties = [MisoString] -> Set MisoString
forall a. Ord a => [a] -> Set a
S.fromList
  [ MisoString
"allowfullscreen"
  , MisoString
"allowpaymentrequest"
  , MisoString
"allowusermedia"
  , MisoString
"async"
  , MisoString
"autofocus"
  , MisoString
"autoplay"
  , MisoString
"checked"
  , MisoString
"controls"
  , MisoString
"default"
  , MisoString
"defer"
  , MisoString
"disabled"
  , MisoString
"download"
  , MisoString
"formnovalidate"
  , MisoString
"hidden"
  , MisoString
"inert"
  , MisoString
"ismap"
  , MisoString
"itemscope"
  , MisoString
"loop"
  , MisoString
"multiple"
  , MisoString
"muted"
  , MisoString
"nomodule"
  , MisoString
"novalidate"
  , MisoString
"open"
  , MisoString
"playsinline"
  , MisoString
"readonly"
  , MisoString
"required"
  , MisoString
"reversed"
  , MisoString
"selected"
  , MisoString
"truespeed"
  ]
----------------------------------------------------------------------------
renderBuilder :: View context model action -> Builder
renderBuilder :: forall context model action. View context model action -> Builder
renderBuilder (VText Maybe Key
_ MisoString
"")    = MisoString -> Builder
forall a. FromMisoString a => MisoString -> a
fromMisoString MisoString
" "
renderBuilder (VText Maybe Key
_ MisoString
s)     = MisoString -> Builder
forall a. FromMisoString a => MisoString -> a
fromMisoString MisoString
s
renderBuilder (VNode Namespace
_ MisoString
"doctype" [] [] Set MisoString
_) = Builder
"<!doctype html>"
renderBuilder (VNode Namespace
ns MisoString
tag [Attribute model action]
attrs [View context model action]
children Set MisoString
_) = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
  [ Builder
"<"
  , MisoString -> Builder
forall a. FromMisoString a => MisoString -> a
fromMisoString MisoString
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 model action -> Builder
forall model action. Attribute model action -> Builder
renderAttrs (Attribute model action -> Builder)
-> [Attribute model action] -> [Builder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Attribute model action]
attrs)
            | Bool -> Bool
not ([Attribute model action] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
Prelude.null [Attribute model action]
attrs)
            ]
  , if MisoString
tag MisoString -> [MisoString] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [MisoString]
selfClosing then Builder
"/>" else Builder
">"
  , [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
      [ (View context model action -> Builder)
-> [View context model action] -> 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 context model action -> Builder
forall context model action. View context model action -> Builder
renderBuilder ([View context model action] -> [View context model action]
forall context model action.
[View context model action] -> [View context model action]
collapseSiblingTextNodes [View context model action]
children)
      , Builder
"</" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> MisoString -> Builder
forall a. FromMisoString a => MisoString -> a
fromMisoString MisoString
tag Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
">"
      ]
    | MisoString
tag MisoString -> [MisoString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [MisoString]
selfClosing
    ]
  ] where
      selfClosing :: [MisoString]
selfClosing = [MisoString]
htmls [MisoString] -> [MisoString] -> [MisoString]
forall a. Semigroup a => a -> a -> a
<> [MisoString]
svgs [MisoString] -> [MisoString] -> [MisoString]
forall a. Semigroup a => a -> a -> a
<> [MisoString]
mathmls
      htmls :: [MisoString]
htmls = [ MisoString
x
              | Namespace
ns Namespace -> Namespace -> Bool
forall a. Eq a => a -> a -> Bool
== Namespace
HTML
              , MisoString
x <- [ MisoString
"area", MisoString
"base", MisoString
"col", MisoString
"embed", MisoString
"img", MisoString
"input", MisoString
"br", MisoString
"hr", MisoString
"meta", MisoString
"link", MisoString
"param", MisoString
"source", MisoString
"track", MisoString
"wbr" ]
              ]
      svgs :: [MisoString]
svgs  = [ MisoString
x
              | Namespace
ns Namespace -> Namespace -> Bool
forall a. Eq a => a -> a -> Bool
== Namespace
SVG
              , MisoString
x <- [ MisoString
"circle", MisoString
"line", MisoString
"rect", MisoString
"path", MisoString
"ellipse", MisoString
"polygon", MisoString
"polyline", MisoString
"use", MisoString
"image"]
              ]
      mathmls :: [MisoString]
mathmls =
              [ MisoString
x
              | Namespace
ns Namespace -> Namespace -> Bool
forall a. Eq a => a -> a -> Bool
== Namespace
MATHML
              , MisoString
x <- [MisoString
"mglyph", MisoString
"mprescripts", MisoString
"none", MisoString
"maligngroup", MisoString
"malignmark" ]
              ]
renderBuilder (VComp SomeComponent context
someComp) =
  case SomeComponent context
someComp of
    SomeComponent Maybe Key
_key props
props Component context props model action
comp_ ->
      -- The app-global @context@ is read from 'globalContext'. For the common
      -- @context ~ ()@ case the 'Miso.Lens.view' ignores it, so the initial @undefined@ is
      -- never forced. But if a 'Miso.Lens.view' here inspects a non-trivial @context@,
      -- SSR must seed the cell with 'Miso.setContext' before serializing, or
      -- forcing @ctx@ raises an exception. See 'Miso.setContext' for details.
      let ctx :: a
ctx = IO a -> a
forall a. IO a -> a
unsafePerformIO (IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
forall context. IORef context
globalContext) in
#ifdef SSR
      renderBuilder (view comp_ ctx props (getInitialComponentModel comp_))
#else
      View context model action -> Builder
forall context model action. View context model action -> Builder
renderBuilder (Component context props model action
-> context -> props -> model -> View context model action
forall context props model action.
Component context props model action
-> context -> props -> model -> View context model action
view Component context props model action
comp_ context
forall {a}. a
ctx props
props (Component context props model action -> model
forall context props model action.
Component context props model action -> model
model Component context props model action
comp_))
#endif
renderBuilder (VCompStatic StaticPtr (SomeStaticComponent props context)
ptr props
props0) =
  case StaticPtr (SomeStaticComponent props context)
-> SomeStaticComponent props context
forall a. StaticPtr a -> a
deRefStaticPtr StaticPtr (SomeStaticComponent props context)
ptr of
   SomeStaticComponent props -> SomeComponent context
mk -> case props -> SomeComponent context
mk props
props0 of
    SomeComponent Maybe Key
_key props
props Component context props model action
comp_ ->
      -- The app-global @context@ is read from 'globalContext'. For the common
      -- @context ~ ()@ case the 'Miso.Lens.view' ignores it, so the initial @undefined@ is
      -- never forced. But if a 'Miso.Lens.view' here inspects a non-trivial @context@,
      -- SSR must seed the cell with 'Miso.setContext' before serializing, or
      -- forcing @ctx@ raises an exception. See 'Miso.setContext' for details.
      let ctx :: a
ctx = IO a -> a
forall a. IO a -> a
unsafePerformIO (IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
forall context. IORef context
globalContext) in
#ifdef SSR
      renderBuilder (view comp_ ctx props (getInitialComponentModel comp_))
#else
      View context model action -> Builder
forall context model action. View context model action -> Builder
renderBuilder (Component context props model action
-> context -> props -> model -> View context model action
forall context props model action.
Component context props model action
-> context -> props -> model -> View context model action
view Component context props model action
comp_ context
forall {a}. a
ctx props
props (Component context props model action -> model
forall context props model action.
Component context props model action -> model
model Component context props model action
comp_))
#endif
renderBuilder (VFrag Maybe Key
_ [View context model action]
kids) = (View context model action -> Builder)
-> [View context model action] -> 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 context model action -> Builder
forall context model action. View context model action -> Builder
renderBuilder [View context model action]
kids
----------------------------------------------------------------------------
renderAttrs :: Attribute model action -> Builder
renderAttrs :: forall model action. Attribute model action -> Builder
renderAttrs (ClassList [MisoString]
classes) =
  [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
  [ Builder
"class"
  , String -> Builder
stringUtf8 String
"=\""
  , MisoString -> Builder
forall a. FromMisoString a => MisoString -> a
fromMisoString ([MisoString] -> MisoString
MS.unwords [MisoString]
classes)
  , String -> Builder
stringUtf8 String
"\""
  ]
renderAttrs (Property MisoString
key (Bool Bool
enabled)) -- dmj: account for boolean properties
  | MisoString -> Set MisoString -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member MisoString
key Set MisoString
booleanProperties, Bool
enabled = MisoString -> Builder
forall a. FromMisoString a => MisoString -> a
fromMisoString MisoString
key
  | MisoString -> Set MisoString -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member MisoString
key Set MisoString
booleanProperties, Bool -> Bool
not Bool
enabled = Builder
forall a. Monoid a => a
mempty
  | Bool
otherwise = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
      [ MisoString -> Builder
forall a. FromMisoString a => MisoString -> a
fromMisoString MisoString
key
      , String -> Builder
stringUtf8 String
"=\""
      , Value -> Builder
toHtmlFromJSON (Bool -> Value
Bool Bool
enabled)
      , String -> Builder
stringUtf8 String
"\""
      ]
renderAttrs (Property MisoString
"key" Value
_) = Builder
forall a. Monoid a => a
mempty
renderAttrs (Property MisoString
key Value
value) =
  [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
  [ MisoString -> Builder
forall a. FromMisoString a => MisoString -> a
fromMisoString MisoString
key
  , String -> Builder
stringUtf8 String
"=\""
  , Value -> Builder
toHtmlFromJSON Value
value
  , String -> Builder
stringUtf8 String
"\""
  ]
renderAttrs (On model -> Sink action -> VTree -> LogLevel -> Events -> IO ()
_) = Builder
forall a. Monoid a => a
mempty
renderAttrs (OnStatic StaticPtr (EventHandler model action)
_) = Builder
forall a. Monoid a => a
mempty
renderAttrs (Styles Map MisoString MisoString
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
      [ MisoString -> Builder
forall a. FromMisoString a => MisoString -> a
fromMisoString MisoString
k
      , Char -> Builder
charUtf8 Char
':'
      , MisoString -> Builder
forall a. FromMisoString a => MisoString -> a
fromMisoString MisoString
v
      , Char -> Builder
charUtf8 Char
';'
      ]
    | (MisoString
k,MisoString
v) <- Map MisoString MisoString -> [(MisoString, MisoString)]
forall k a. Map k a -> [(k, a)]
M.toList Map MisoString MisoString
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 context model action] -> [View context model action]
collapseSiblingTextNodes :: forall context model action.
[View context model action] -> [View context model action]
collapseSiblingTextNodes [] = []
collapseSiblingTextNodes (VText Maybe Key
_ MisoString
x : VText Maybe Key
k MisoString
y : [View context model action]
xs) =
  [View context model action] -> [View context model action]
forall context model action.
[View context model action] -> [View context model action]
collapseSiblingTextNodes (Maybe Key -> MisoString -> View context model action
forall context model action.
Maybe Key -> MisoString -> View context model action
VText Maybe Key
k (MisoString
x MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
y) View context model action
-> [View context model action] -> [View context model action]
forall a. a -> [a] -> [a]
: [View context model action]
xs)
collapseSiblingTextNodes (View context model action
x:[View context model action]
xs) =
  View context model action
x View context model action
-> [View context model action] -> [View context model action]
forall a. a -> [a] -> [a]
: [View context model action] -> [View context model action]
forall context model action.
[View context model action] -> [View context model action]
collapseSiblingTextNodes [View context model action]
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 MisoString
t)   = MisoString -> Builder
forall a. FromMisoString a => MisoString -> a
fromMisoString (MisoString -> MisoString
forall str. ToMisoString str => str -> MisoString
ms MisoString
t)
toHtmlFromJSON (Number Double
t)   = MisoString -> Builder
forall a. FromMisoString a => MisoString -> a
fromMisoString (MisoString -> Builder) -> MisoString -> Builder
forall a b. (a -> b) -> a -> b
$ String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (Double -> String
forall a. Show a => a -> String
show Double
t)
toHtmlFromJSON (Bool Bool
True)  = Builder
"true"
toHtmlFromJSON (Bool Bool
False) = Builder
"false"
toHtmlFromJSON Value
Null         = Builder
"null"
toHtmlFromJSON (Object Map MisoString Value
o)   = MisoString -> Builder
forall a. FromMisoString a => MisoString -> a
fromMisoString (MisoString -> Builder) -> MisoString -> Builder
forall a b. (a -> b) -> a -> b
$ String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (Map MisoString Value -> String
forall a. Show a => a -> String
show Map MisoString Value
o)
toHtmlFromJSON (Array [Value]
a)    = MisoString -> Builder
forall a. FromMisoString a => MisoString -> a
fromMisoString (MisoString -> Builder) -> MisoString -> Builder
forall a b. (a -> b) -> a -> b
$ String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms ([Value] -> String
forall a. Show a => a -> String
show [Value]
a)
-----------------------------------------------------------------------------
#ifdef SSR
-- | Used for server-side model hydration, internally only in 'renderView'.
--
-- We use 'unsafePerformIO' here because @servant@'s 'MimeRender' is a pure function
-- yet we need to allow the users to hydrate in 'IO'.
--
getInitialComponentModel :: Component context props model action -> model
getInitialComponentModel Component {..} =
  case hydrateModel of
    Nothing -> model
    Just action -> unsafePerformIO $
      action `catch` (\(e :: SomeException) -> do
        putStrLn "Encountered exception during model hydration, falling back to default model"
        print e
        pure model)
----------------------------------------------------------------------------
#endif