-----------------------------------------------------------------------------
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE TypeFamilies          #-}
{-# 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' () () () a@ (a single
-- node) and @['Miso.Types.View' () () () a]@ (a sequence of nodes): a bare
-- 'Miso.Types.View' is static markup with no enclosing component and no
-- app-global @context@ to read, so its @context@, @props@ and @model@ are all
-- fixed to @()@. A component's view, or any subtree that reads @context@ \/
-- @props@ \/ @model@, is rendered with 'toHtmlWith'.
--
-- = Quick start
--
-- @
-- import           "Miso.Html.Render" ('ToHtml', 'toHtml', 'toHtmlWith')
-- import qualified Data.ByteString.Lazy as L
--
-- renderPage :: Model -> L.ByteString
-- renderPage m = 'toHtmlWith' () () m (view () () m)
--
-- staticPage :: L.ByteString
-- staticPage = 'toHtml' ('Miso.Html.Element.div_' [] [ "Hello, world!" ])
-- @
--
-- 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.
-- * __'Miso.Types.VContext'__ (ambient accessor, not a node) — applied to
--   the app-global @context@ (@()@ for a bare 'Miso.Types.View' under
--   'toHtml'; the value given to 'toHtmlWith' otherwise) and the result
--   rendered in its place.
-- * __'Miso.Types.VProps'__ (ambient accessor, not a node) — applied to the
--   @props@ of the enclosing component (@()@ for a bare 'Miso.Types.View'
--   under 'toHtml'; the value given to 'toHtmlWith' otherwise) and the
--   result rendered in its place.
-- * __'Miso.Types.VModel'__ (ambient accessor, not a node) — applied to the
--   initial (or hydrated) @model@ of the enclosing component (@()@ for a
--   bare 'Miso.Types.View' under 'toHtml'; the value given to 'toHtmlWith'
--   otherwise) and the result rendered in its place.
-- * __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 (..)
    -- *** Functions
  , toHtmlWith
  ) 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
#ifdef SSR
import           Control.Exception (SomeException, catch)
import           System.IO.Unsafe (unsafePerformIO)
#endif
----------------------------------------------------------------------------
import           GHC.StaticPtr
----------------------------------------------------------------------------
import           Miso.JSON
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@
--
-- Rendering never starts the runtime, so a bare 'View' has no component to
-- supply its @context@ or @props@; both are fixed to @()@ (the equality
-- constraints let a 'View' that is polymorphic in either still resolve this
-- instance). A 'Miso.Types.VContext' or 'Miso.Types.VProps' at this level
-- therefore sees @()@; one nested inside a mounted component sees that
-- component's real @props@ (and the same @context@). Use 'toHtmlWith' to
-- supply real values.
instance (context ~ (), props ~ (), model ~ ()) => ToHtml (View context props model action) where
  toHtml :: View context props model action -> ByteString
toHtml = View context props model action -> ByteString
View () () () action -> ByteString
forall action. View () () () action -> ByteString
renderView
----------------------------------------------------------------------------
-- | Render a @[Miso.Types.View]@ to a @L.ByteString@. Adjacent text nodes
-- are collapsed across the list, as they are among an element's children.
instance (context ~ (), props ~ (), model ~ ()) => ToHtml [View context props model action] where
  toHtml :: [View context props model action] -> ByteString
toHtml = Builder -> ByteString
toLazyByteString (Builder -> ByteString)
-> ([View context props model action] -> Builder)
-> [View context props model action]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (View () () () action -> Builder)
-> [View () () () 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 () () () action -> Builder
forall context props model action.
context
-> props -> model -> View context props model action -> Builder
renderBuilder () () ()) ([View () () () action] -> Builder)
-> ([View context props model action] -> [View () () () action])
-> [View context props model action]
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. context
-> props
-> model
-> [View context props model action]
-> [View context props model action]
forall context props model action.
context
-> props
-> model
-> [View context props model action]
-> [View context props model action]
collapseSiblingTextNodes () () ()
----------------------------------------------------------------------------
renderView :: View () () () action -> L.ByteString
renderView :: forall action. View () () () action -> ByteString
renderView = () -> () -> () -> View () () () action -> ByteString
forall context props model action.
context
-> props -> model -> View context props model action -> ByteString
toHtmlWith () () ()
----------------------------------------------------------------------------
-- | Render a 'View' to a @L.ByteString@, supplying the app-global @context@,
-- the @props@ and the @model@ that 'Miso.Types.VContext' \/
-- 'Miso.Types.VProps' \/ 'Miso.Types.VModel' accessors in it resolve against.
-- Mounted child components see the same @context@, and their own @props@ and
-- initial @model@.
--
-- This is the general form of 'toHtml', for a 'View' whose @context@, @props@
-- or @model@ type is not @()@ — e.g. a component's 'Miso.Types.view' applied
-- directly. The @view@ itself takes only the @model@; the @context@ and
-- @props@ given here are what its 'Miso.Types.VContext' \/
-- 'Miso.Types.VProps' accessors resolve against:
--
-- @
-- toHtmlWith ctx props model (view comp model)
-- @
--
-- @since 1.14.0.0
toHtmlWith :: context -> props -> model -> View context props model action -> L.ByteString
toHtmlWith :: forall context props model action.
context
-> props -> model -> View context props model action -> ByteString
toHtmlWith context
ctx props
props model
model_ = Builder -> ByteString
toLazyByteString (Builder -> ByteString)
-> (View context props model action -> Builder)
-> View context props model action
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. context
-> props -> model -> View context props model action -> Builder
forall context props model action.
context
-> props -> model -> View context props model action -> Builder
renderBuilder context
ctx props
props 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
  ]
----------------------------------------------------------------------------
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"
  ]
----------------------------------------------------------------------------
-- | Serialise a 'View' given the app-global @context@ and the @props@ of the
-- t'Component' it belongs to. Entering a @VComp@ \/ @VCompStatic@ keeps the
-- @context@ and switches to that child's @props@.
renderBuilder :: context -> props -> model -> View context props model action -> Builder
renderBuilder :: forall context props model action.
context
-> props -> model -> View context props model action -> Builder
renderBuilder context
_ props
_ model
_ (VText Maybe Key
_ MisoString
"")    = MisoString -> Builder
forall a. FromMisoString a => MisoString -> a
fromMisoString MisoString
" "
renderBuilder context
_ props
_ model
_ (VText Maybe Key
_ MisoString
s)     = MisoString -> Builder
forall a. FromMisoString a => MisoString -> a
fromMisoString MisoString
s
renderBuilder context
_ props
_ model
_ (VNode Namespace
_ MisoString
"doctype" [] [] Set MisoString
_) = Builder
"<!doctype html>"
renderBuilder context
ctx_ props
props_ model
model_ (VNode Namespace
ns MisoString
tag [Attribute model action]
attrs [View context props 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 props model action -> Builder)
-> [View context props 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 (context
-> props -> model -> View context props model action -> Builder
forall context props model action.
context
-> props -> model -> View context props model action -> Builder
renderBuilder context
ctx_ props
props_ model
model_) (context
-> props
-> model
-> [View context props model action]
-> [View context props model action]
forall context props model action.
context
-> props
-> model
-> [View context props model action]
-> [View context props model action]
collapseSiblingTextNodes context
ctx_ props
props_ model
model_ [View context props 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 context
ctx_ props
_ model
_ (VComp SomeComponent context
someComp) = context -> SomeComponent context -> Builder
forall context. context -> SomeComponent context -> Builder
renderComp context
ctx_ SomeComponent context
someComp
renderBuilder context
ctx_ props
_ model
_ (VCompStatic StaticPtr (SomeStaticComponent childProps context)
ptr childProps
props0) =
  case StaticPtr (SomeStaticComponent childProps context)
-> SomeStaticComponent childProps context
forall a. StaticPtr a -> a
deRefStaticPtr StaticPtr (SomeStaticComponent childProps context)
ptr of
    SomeStaticComponent Component context childProps model action
comp_ -> context -> SomeComponent context -> Builder
forall context. context -> SomeComponent context -> Builder
renderComp context
ctx_ (Maybe Key
-> childProps
-> Component context childProps model action
-> SomeComponent context
forall context model action props.
MountConstraints context props model action =>
Maybe Key
-> props
-> Component context props model action
-> SomeComponent context
SomeComponent Maybe Key
forall a. Maybe a
Nothing childProps
props0 Component context childProps model action
comp_)
renderBuilder context
ctx_ props
props_ model
model_ (VFrag Maybe Key
_ [View context props model action]
kids) =
  -- Collapse inside the fragment too: the client's hydration walk recurses
  -- into fragments before comparing text, so the server must match.
  (View context props model action -> Builder)
-> [View context props 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 (context
-> props -> model -> View context props model action -> Builder
forall context props model action.
context
-> props -> model -> View context props model action -> Builder
renderBuilder context
ctx_ props
props_ model
model_) (context
-> props
-> model
-> [View context props model action]
-> [View context props model action]
forall context props model action.
context
-> props
-> model
-> [View context props model action]
-> [View context props model action]
collapseSiblingTextNodes context
ctx_ props
props_ model
model_ [View context props model action]
kids)
renderBuilder context
ctx_ props
props_ model
model_ (VContext context -> View context props model action
f) = context
-> props -> model -> View context props model action -> Builder
forall context props model action.
context
-> props -> model -> View context props model action -> Builder
renderBuilder context
ctx_ props
props_ model
model_ (context -> View context props model action
f context
ctx_)
renderBuilder context
ctx_ props
props_ model
model_ (VProps props -> View context props model action
f) = context
-> props -> model -> View context props model action -> Builder
forall context props model action.
context
-> props -> model -> View context props model action -> Builder
renderBuilder context
ctx_ props
props_ model
model_ (props -> View context props model action
f props
props_)
renderBuilder context
ctx_ props
props_ model
model_ (VModel model -> View context props model action
f) = context
-> props -> model -> View context props model action -> Builder
forall context props model action.
context
-> props -> model -> View context props model action -> Builder
renderBuilder context
ctx_ props
props_ model
model_ (model -> View context props model action
f model
model_)
----------------------------------------------------------------------------
-- | Render a mounted child component: its 'view' applied to its initial (or
-- hydrated) @model@, rendered against the app-global @context@ and the
-- @props@ it was mounted with. The enclosing component's @props@ play no
-- part, which is why the @VComp@ \/ @VCompStatic@ arms of 'renderBuilder'
-- ignore theirs; the @context@ is shared by every component and is passed
-- straight through.
renderComp :: context -> SomeComponent context -> Builder
renderComp :: forall context. context -> SomeComponent context -> Builder
renderComp context
ctx (SomeComponent Maybe Key
_key props
props Component context props model action
comp_) =
#ifdef SSR
  let m = getInitialComponentModel comp_ in renderBuilder ctx props m (view comp_ m)
#else
  context
-> props -> model -> View context props model action -> Builder
forall context props model action.
context
-> props -> model -> View context props model action -> Builder
renderBuilder context
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_) (Component context props model action
-> model -> View context props model action
forall context props model action.
Component context props model action
-> model -> View context props model action
view Component context props model action
comp_ (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
----------------------------------------------------------------------------
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
  :: context
  -> props
  -> model
  -> [View context props model action]
  -> [View context props model action]
collapseSiblingTextNodes :: forall context props model action.
context
-> props
-> model
-> [View context props model action]
-> [View context props model action]
collapseSiblingTextNodes context
ctx_ props
props_ model
model_ = [View context props model action]
-> [View context props model action]
go
  where
    -- Look through the wrapper constructors, so a 'VProps' \/ 'VModel' \/
    -- 'VContext' that resolves to text is collapsed with its neighbours
    -- exactly as the client does after 'buildVTree' has resolved it.
    resolve :: View context props model action -> View context props model action
resolve (VProps props -> View context props model action
f) = View context props model action -> View context props model action
resolve (props -> View context props model action
f props
props_)
    resolve (VContext context -> View context props model action
f) = View context props model action -> View context props model action
resolve (context -> View context props model action
f context
ctx_)
    resolve (VModel model -> View context props model action
f) = View context props model action -> View context props model action
resolve (model -> View context props model action
f model
model_)
    resolve View context props model action
v = View context props model action
v

    -- Resolve *both* sides of a pair before deciding whether they merge —
    -- not just the head, as the single-pass version once did. Otherwise a
    -- literal 'VText' immediately followed by a wrapper resolving to text
    -- (or to empty text, which 'renderBuilder' renders as a lone space) is
    -- never recognised as adjacent, since the second element is only
    -- resolved on a later call, by which point the first has already been
    -- emitted.
    go :: [View context props model action]
-> [View context props model action]
go (View context props model action
x : View context props model action
y : [View context props model action]
xs)
      | VText Maybe Key
_ MisoString
a <- View context props model action -> View context props model action
resolve View context props model action
x, VText Maybe Key
k MisoString
b <- View context props model action -> View context props model action
resolve View context props model action
y = [View context props model action]
-> [View context props model action]
go (Maybe Key -> MisoString -> View context props model action
forall context props model action.
Maybe Key -> MisoString -> View context props model action
VText Maybe Key
k (MisoString
a MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
b) View context props model action
-> [View context props model action]
-> [View context props model action]
forall a. a -> [a] -> [a]
: [View context props model action]
xs)
      | Bool
otherwise = View context props model action
x View context props model action
-> [View context props model action]
-> [View context props model action]
forall a. a -> [a] -> [a]
: [View context props model action]
-> [View context props model action]
go (View context props model action
y View context props model action
-> [View context props model action]
-> [View context props model action]
forall a. a -> [a] -> [a]
: [View context props model action]
xs)
    go [View context props model action]
xs = [View context props 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