Render.hs

-- |
-- Module      : Slab.Render
-- Description : Render an AST to HTML
--
-- @Slab.Render@ transforms an evaluated syntax tree to HTML. In practice this
-- can be @blaze-html@'s @Html@, or @Text@ and lazy @ByteString@.
module Slab.Render
  ( prettyHtmls
  , renderHtmls
  , renderHtmlsUtf8
  , renderBlocks
  , extractTexts
  ) where

import Data.ByteString.Lazy qualified as BSL
import Data.String (fromString)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Slab.Syntax qualified as Syntax
import Text.Blaze.Html.Renderer.Pretty qualified as Pretty (renderHtml)
import Text.Blaze.Html.Renderer.Text (renderHtml)
import Text.Blaze.Html.Renderer.Utf8 qualified as Utf8 (renderHtml)
import Text.Blaze.Html5 (Html, (!))
import Text.Blaze.Html5 qualified as H
import Text.Blaze.Html5.Attributes qualified as A
import Text.Blaze.Internal qualified as I
import Text.Blaze.Svg11 qualified as S

--------------------------------------------------------------------------------
prettyHtmls :: [Html] -> Text
prettyHtmls = T.pack . concat . map Pretty.renderHtml

renderHtmls :: [Html] -> TL.Text
renderHtmls = TL.concat . map renderHtml

renderHtmlsUtf8 :: [Html] -> BSL.ByteString
renderHtmlsUtf8 = BSL.concat . map Utf8.renderHtml

--------------------------------------------------------------------------------
renderBlocks :: [Syntax.Block] -> [H.Html]
renderBlocks = map renderBlock

renderBlock :: Syntax.Block -> H.Html
renderBlock Syntax.BlockDoctype = H.docType
renderBlock (Syntax.BlockElem name mdot attrs children) =
  mAddAttrs $
    mAddId $
      mAddClass $
        renderElem name $
          mconcat $
            if mdot == Syntax.HasDot
              then [renderTexts children]
              else map renderBlock children
 where
  mAddId :: H.Html -> H.Html
  mAddId e =
    case idNames of
      Nothing -> e
      Just names -> e ! A.id (H.toValue names)
  idNames = Syntax.idNamesFromAttrs' attrs
  mAddClass :: H.Html -> H.Html
  mAddClass e =
    if classNames == []
      then e
      else e ! A.class_ (H.toValue classNames')
  classNames = Syntax.classNamesFromAttrs attrs
  classNames' :: Text
  classNames' = T.intercalate " " classNames

  mAddAttrs :: H.Html -> H.Html
  mAddAttrs =
    flip (foldl (\e (a, b) -> e ! H.customAttribute (fromString $ T.unpack a) (H.toValue b))) attrs'
  attrs' = Syntax.namesFromAttrs attrs
renderBlock (Syntax.BlockText _ []) =
  H.preEscapedText "\n" -- This allows to force some whitespace.
renderBlock (Syntax.BlockText _ t) =
  let s = renderTemplate t
   in if s == T.empty
        then H.preEscapedText "\n" -- This allows to force some whitespace.
        else H.preEscapedText s -- TODO
renderBlock (Syntax.BlockInclude (Just "escape-html") _ (Just nodes)) =
  escapeTexts nodes
renderBlock (Syntax.BlockInclude _ _ (Just nodes)) = mapM_ renderBlock nodes
renderBlock (Syntax.BlockInclude _ path Nothing) = H.stringComment $ "include " <> path
renderBlock (Syntax.BlockFragmentDef _ _ _ _) = mempty
renderBlock (Syntax.BlockFragmentCall _ _ _ _ nodes) = mapM_ renderBlock nodes
renderBlock (Syntax.BlockFor _ _ _ nodes) = mapM_ renderBlock nodes
renderBlock (Syntax.BlockComment b content) =
  case b of
    Syntax.PassthroughComment -> H.textComment content
    Syntax.NormalComment -> mempty
renderBlock (Syntax.BlockFilter "escape-html" content) =
  H.text content
renderBlock (Syntax.BlockFilter name _) = error $ "Unknown filter name " <> T.unpack name
renderBlock (Syntax.BlockRawElem content children) = do
  H.preEscapedText content -- TODO Construct a proper tag ?
  mapM_ renderBlock children
renderBlock (Syntax.BlockDefault _ nodes) = mapM_ renderBlock nodes
renderBlock (Syntax.BlockImport _ (Just nodes) _) = mapM_ renderBlock nodes
renderBlock (Syntax.BlockRun _ _ (Just nodes)) = mapM_ renderBlock nodes
renderBlock (Syntax.BlockRun cmd _ _) = H.textComment $ "run " <> cmd
renderBlock (Syntax.BlockImport path Nothing _) = H.stringComment $ "extends " <> path
renderBlock (Syntax.BlockAssignVars _) = mempty
renderBlock (Syntax.BlockIf _ as bs) = do
  -- The evaluation code transforms a BlockIf into a BlockList, so this should
  -- not be called.
  mapM_ renderBlock as
  mapM_ renderBlock bs
renderBlock (Syntax.BlockList nodes) =
  mapM_ renderBlock nodes
renderBlock (Syntax.BlockCode (Syntax.SingleQuoteString s))
  | s == T.empty = mempty
  | otherwise = H.text s -- Should be already escaped in the AST ?
renderBlock (Syntax.BlockCode (Syntax.Variable s)) =
  H.textComment $ "code variable " <> s
renderBlock (Syntax.BlockCode (Syntax.Int i)) =
  H.string $ show i
renderBlock (Syntax.BlockCode (Syntax.Object _)) =
  H.text "<Object>"
renderBlock (Syntax.BlockCode (Syntax.Block x)) = renderBlock x
renderBlock (Syntax.BlockCode c) = error $ "renderBlock called on BlockCode " <> show c

renderTexts :: [Syntax.Block] -> H.Html
renderTexts = H.preEscapedText . extractTexts

escapeTexts :: [Syntax.Block] -> H.Html
escapeTexts = H.text . extractTexts

extractTexts :: [Syntax.Block] -> Text
extractTexts = T.intercalate "\n" . map extractText

extractText :: Syntax.Block -> Text
extractText = f
 where
  f Syntax.BlockDoctype = error "extractTexts called on a BlockDoctype"
  f (Syntax.BlockElem _ _ _ _) = error "extractTexts called on a BlockElem"
  f (Syntax.BlockText _ [Syntax.Lit s]) = s
  f (Syntax.BlockText _ _) = error "extractTexts called on unevaluated BlockText"
  f (Syntax.BlockInclude _ _ _) = error "extractTexts called on a BlockInclude"
  f (Syntax.BlockFragmentDef _ _ _ _) = error "extractTexts called on a BlockFragmentDef"
  f (Syntax.BlockFragmentCall _ _ _ _ _) = error "extractTexts called on a BlockFragmentCall"
  f (Syntax.BlockFor _ _ _ _) = error "extractTexts called on a BlockFor"
  f (Syntax.BlockComment _ _) = error "extractTexts called on a BlockComment"
  f (Syntax.BlockFilter _ _) = error "extractTexts called on a BlockFilter"
  f (Syntax.BlockRawElem _ _) = error "extractTexts called on a BlockRawElem"
  f (Syntax.BlockDefault _ _) = error "extractTexts called on a BlockDefault"
  f (Syntax.BlockImport _ _ _) = error "extractTexts called on a BlockImport"
  f (Syntax.BlockRun _ _ _) = error "extractTexts called on a BlockRun"
  f (Syntax.BlockAssignVars _) = error "extractTexts called on a BlockAssignVars"
  f (Syntax.BlockIf _ _ _) = error "extractTexts called on a BlockIf"
  f (Syntax.BlockList _) = error "extractTexts called on a BlockList"
  f (Syntax.BlockCode _) = error "extractTexts called on a BlockCode"

-- After evaluation, we should have only reduced values (e.g. no variables).
renderTemplate :: [Syntax.Inline] -> Text
renderTemplate inlines =
  let t = map renderInline inlines
   in T.concat t

renderInline :: Syntax.Inline -> Text
renderInline = \case
  Syntax.Lit s -> s
  Syntax.Place code -> do
    case code of
      Syntax.SingleQuoteString s -> s
      Syntax.Bool x -> T.pack $ show x
      Syntax.Int x -> T.pack $ show x
      Syntax.Block b -> TL.toStrict . renderHtml $ renderBlock b
      x -> error $ "renderInline: unhandled value: " <> show x

renderElem :: Syntax.Elem -> Html -> Html
renderElem = \case
  Syntax.Html -> H.html
  Syntax.Body -> H.body
  Syntax.Div -> H.div
  Syntax.Span -> H.span
  Syntax.Br -> const H.br
  Syntax.Hr -> const H.hr
  Syntax.H1 -> H.h1
  Syntax.H2 -> H.h2
  Syntax.H3 -> H.h3
  Syntax.H4 -> H.h4
  Syntax.H5 -> H.h5
  Syntax.H6 -> H.h6
  Syntax.Header -> H.header
  Syntax.Head -> H.head
  Syntax.Meta -> const H.meta
  Syntax.Main -> H.main
  Syntax.Link -> const H.link
  Syntax.A -> H.a
  Syntax.P -> H.p
  Syntax.Em -> H.em
  Syntax.Ul -> H.ul
  Syntax.Li -> H.li
  Syntax.Title -> H.title
  Syntax.Table -> H.table
  Syntax.Thead -> H.thead
  Syntax.Tbody -> H.tbody
  Syntax.Tr -> H.tr
  Syntax.Td -> H.td
  Syntax.Dl -> H.dl
  Syntax.Dt -> H.dt
  Syntax.Dd -> H.dd
  Syntax.Footer -> H.footer
  Syntax.Figure -> H.figure
  Syntax.Form -> H.form
  Syntax.Label -> H.label
  Syntax.Blockquote -> H.blockquote
  Syntax.Button -> H.button
  Syntax.Figcaption -> H.figcaption
  Syntax.Audio -> H.audio
  Syntax.Script -> H.script
  Syntax.Style -> H.style
  Syntax.Small -> H.small
  Syntax.Source -> const H.source
  Syntax.Pre -> H.pre
  Syntax.Code -> H.code
  Syntax.Img -> const H.img
  Syntax.IFrame -> H.iframe
  Syntax.Input -> const H.input
  Syntax.I -> H.i
  Syntax.Svg -> S.svg
  Syntax.Textarea -> H.textarea
  Syntax.Canvas -> H.canvas
  Syntax.Elem name -> I.customParent (H.textTag name)