module Slab.Render
  ( prettyHtmls
  , renderHtmls
  , renderBlocks
  ) where

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.Html5 (Html, (!))
import Text.Blaze.Html5 qualified as H
import Text.Blaze.Html5.Attributes qualified as A
import Text.Blaze.Svg11 qualified as S

--------------------------------------------------------------------------------
prettyHtmls :: [Html] -> Text
prettyHtmls :: [Html] -> Text
prettyHtmls = String -> Text
T.pack (String -> Text) -> ([Html] -> String) -> [Html] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> ([Html] -> [String]) -> [Html] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Html -> String) -> [Html] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Html -> String
Pretty.renderHtml

renderHtmls :: [Html] -> TL.Text
renderHtmls :: [Html] -> Text
renderHtmls = [Text] -> Text
TL.concat ([Text] -> Text) -> ([Html] -> [Text]) -> [Html] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Html -> Text) -> [Html] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Html -> Text
renderHtml

--------------------------------------------------------------------------------
renderBlocks :: [Syntax.Block] -> [H.Html]
renderBlocks :: [Block] -> [Html]
renderBlocks = (Block -> Html) -> [Block] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map Block -> Html
renderBlock

renderBlock :: Syntax.Block -> H.Html
renderBlock :: Block -> Html
renderBlock Block
Syntax.BlockDoctype = Html
H.docType
renderBlock (Syntax.BlockElem Elem
name TrailingSym
mdot [Attr]
attrs [Block]
children) =
  Html -> Html
mAddAttrs (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
    Html -> Html
mAddId (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
      Html -> Html
mAddClass (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
        Elem -> Html -> Html
renderElem Elem
name (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
          [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat ([Html] -> Html) -> [Html] -> Html
forall a b. (a -> b) -> a -> b
$
            if TrailingSym
mdot TrailingSym -> TrailingSym -> Bool
forall a. Eq a => a -> a -> Bool
== TrailingSym
Syntax.HasDot
              then [[Block] -> Html
renderTexts [Block]
children]
              else (Block -> Html) -> [Block] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map Block -> Html
renderBlock [Block]
children
 where
  mAddId :: H.Html -> H.Html
  mAddId :: Html -> Html
mAddId Html
e =
    if [Text]
idNames [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== []
      then Html
e
      else Html
e Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.id (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Text
idNames')
  idNames :: [Text]
idNames = [Attr] -> [Text]
Syntax.idNamesFromAttrs [Attr]
attrs
  idNames' :: Text
  idNames' :: Text
idNames' = Text -> [Text] -> Text
T.intercalate Text
"-" [Text]
idNames -- TODO Refuse multiple Ids in some kind of validation step after parsing ?
  mAddClass :: H.Html -> H.Html
  mAddClass :: Html -> Html
mAddClass Html
e =
    if [Text]
classNames [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== []
      then Html
e
      else Html
e Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Text
classNames')
  classNames :: [Text]
classNames = [Attr] -> [Text]
Syntax.classNamesFromAttrs [Attr]
attrs
  classNames' :: Text
  classNames' :: Text
classNames' = Text -> [Text] -> Text
T.intercalate Text
" " [Text]
classNames

  mAddAttrs :: H.Html -> H.Html
  mAddAttrs :: Html -> Html
mAddAttrs =
    (Html -> [(Text, Text)] -> Html) -> [(Text, Text)] -> Html -> Html
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Html -> (Text, Text) -> Html) -> Html -> [(Text, Text)] -> Html
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Html
e (Text
a, Text
b) -> Html
e Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! Tag -> AttributeValue -> Attribute
H.customAttribute (String -> Tag
forall a. IsString a => String -> a
fromString (String -> Tag) -> String -> Tag
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
a) (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Text
b))) [(Text, Text)]
attrs'
  attrs' :: [(Text, Text)]
attrs' = [Attr] -> [(Text, Text)]
Syntax.namesFromAttrs [Attr]
attrs
renderBlock (Syntax.BlockText TextSyntax
_ []) =
  Text -> Html
H.preEscapedText Text
"\n" -- This allows to force some whitespace.
renderBlock (Syntax.BlockText TextSyntax
_ [Syntax.Lit Text
s])
  | Text
s Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
T.empty = Text -> Html
H.preEscapedText Text
"\n" -- This allows to force some whitespace.
  | Bool
otherwise = Text -> Html
H.preEscapedText Text
s -- TODO
renderBlock (Syntax.BlockText TextSyntax
_ [Inline]
_) = String -> Html
forall a. HasCallStack => String -> a
error String
"Template is not rendered."
renderBlock (Syntax.BlockInclude (Just Text
"escape-html") String
_ (Just [Block]
nodes)) =
  [Block] -> Html
escapeTexts [Block]
nodes
renderBlock (Syntax.BlockInclude Maybe Text
_ String
_ (Just [Block]
nodes)) = (Block -> Html) -> [Block] -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Block -> Html
renderBlock [Block]
nodes
renderBlock (Syntax.BlockInclude Maybe Text
_ String
path Maybe [Block]
Nothing) = String -> Html
H.stringComment (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ String
"include " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
path
renderBlock (Syntax.BlockFragmentDef Text
_ [Text]
_ [Block]
_) = Html
forall a. Monoid a => a
mempty
renderBlock (Syntax.BlockFragmentCall Text
_ [Expr]
_ [Block]
nodes) = (Block -> Html) -> [Block] -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Block -> Html
renderBlock [Block]
nodes
renderBlock (Syntax.BlockFor Text
_ Maybe Text
_ Expr
_ [Block]
nodes) = (Block -> Html) -> [Block] -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Block -> Html
renderBlock [Block]
nodes
renderBlock (Syntax.BlockComment CommentType
b Text
content) =
  case CommentType
b of
    CommentType
Syntax.PassthroughComment -> Text -> Html
H.textComment Text
content
    CommentType
Syntax.NormalComment -> Html
forall a. Monoid a => a
mempty
renderBlock (Syntax.BlockFilter Text
"escape-html" Text
content) =
  Text -> Html
H.text Text
content
renderBlock (Syntax.BlockFilter Text
name Text
_) = String -> Html
forall a. HasCallStack => String -> a
error (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ String
"Unknown filter name " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
name
renderBlock (Syntax.BlockRawElem Text
content [Block]
children) = do
  Text -> Html
H.preEscapedText Text
content -- TODO Construct a proper tag ?
  (Block -> Html) -> [Block] -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Block -> Html
renderBlock [Block]
children
renderBlock (Syntax.BlockDefault Text
_ [Block]
nodes) = (Block -> Html) -> [Block] -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Block -> Html
renderBlock [Block]
nodes
renderBlock (Syntax.BlockImport String
_ (Just [Block]
nodes) [Block]
_) = (Block -> Html) -> [Block] -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Block -> Html
renderBlock [Block]
nodes
renderBlock (Syntax.BlockRun Text
_ (Just [Block]
nodes)) = (Block -> Html) -> [Block] -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Block -> Html
renderBlock [Block]
nodes
renderBlock (Syntax.BlockRun Text
cmd Maybe [Block]
_) = Text -> Html
H.textComment (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$ Text
"run " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cmd
renderBlock (Syntax.BlockImport String
path Maybe [Block]
Nothing [Block]
_) = String -> Html
H.stringComment (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ String
"extends " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
path
renderBlock (Syntax.BlockReadJson Text
_ String
_ Maybe Value
_) = Html
forall a. Monoid a => a
mempty
renderBlock (Syntax.BlockAssignVar Text
_ Expr
_) = Html
forall a. Monoid a => a
mempty
renderBlock (Syntax.BlockIf Expr
_ [Block]
as [Block]
bs) = do
  -- The evaluation code transforms a BlockIf into a BlockList, so this should
  -- not be called.
  (Block -> Html) -> [Block] -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Block -> Html
renderBlock [Block]
as
  (Block -> Html) -> [Block] -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Block -> Html
renderBlock [Block]
bs
renderBlock (Syntax.BlockList [Block]
nodes) =
  (Block -> Html) -> [Block] -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Block -> Html
renderBlock [Block]
nodes
renderBlock (Syntax.BlockCode (Syntax.SingleQuoteString Text
s))
  | Text
s Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
T.empty = Html
forall a. Monoid a => a
mempty
  | Bool
otherwise = Text -> Html
H.text Text
s -- Should be already escaped in the AST ?
renderBlock (Syntax.BlockCode (Syntax.Variable Text
s)) =
  Text -> Html
H.textComment (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$ Text
"code variable " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s
renderBlock (Syntax.BlockCode (Syntax.Int Int
i)) =
  String -> Html
H.string (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
i
renderBlock (Syntax.BlockCode (Syntax.Object [(Expr, Expr)]
_)) =
  Text -> Html
H.text Text
"<Object>"
renderBlock (Syntax.BlockCode Expr
c) = String -> Html
forall a. HasCallStack => String -> a
error (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ String
"renderBlock called on BlockCode " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Expr -> String
forall a. Show a => a -> String
show Expr
c

renderTexts :: [Syntax.Block] -> H.Html
renderTexts :: [Block] -> Html
renderTexts [Block]
xs = Text -> Html
H.preEscapedText Text
xs'
 where
  xs' :: Text
xs' = Text -> [Text] -> Text
T.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Block -> Text) -> [Block] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Block -> Text
extractText [Block]
xs

escapeTexts :: [Syntax.Block] -> H.Html
escapeTexts :: [Block] -> Html
escapeTexts [Block]
xs = Text -> Html
H.text Text
xs'
 where
  xs' :: Text
xs' = Text -> [Text] -> Text
T.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Block -> Text) -> [Block] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Block -> Text
extractText [Block]
xs

extractText :: Syntax.Block -> Text
extractText :: Block -> Text
extractText = Block -> Text
f
 where
  f :: Block -> Text
f Block
Syntax.BlockDoctype = String -> Text
forall a. HasCallStack => String -> a
error String
"extractTexts called on a BlockDoctype"
  f (Syntax.BlockElem Elem
_ TrailingSym
_ [Attr]
_ [Block]
_) = String -> Text
forall a. HasCallStack => String -> a
error String
"extractTexts called on a BlockElem"
  f (Syntax.BlockText TextSyntax
_ [Syntax.Lit Text
s]) = Text
s
  f (Syntax.BlockText TextSyntax
_ [Inline]
_) = String -> Text
forall a. HasCallStack => String -> a
error String
"extractTexts called on unevaluated BlockText"
  f (Syntax.BlockInclude Maybe Text
_ String
_ Maybe [Block]
_) = String -> Text
forall a. HasCallStack => String -> a
error String
"extractTexts called on a BlockInclude"
  f (Syntax.BlockFragmentDef Text
_ [Text]
_ [Block]
_) = String -> Text
forall a. HasCallStack => String -> a
error String
"extractTexts called on a BlockFragmentDef"
  f (Syntax.BlockFragmentCall Text
_ [Expr]
_ [Block]
_) = String -> Text
forall a. HasCallStack => String -> a
error String
"extractTexts called on a BlockFragmentCall"
  f (Syntax.BlockFor Text
_ Maybe Text
_ Expr
_ [Block]
_) = String -> Text
forall a. HasCallStack => String -> a
error String
"extractTexts called on a BlockFor"
  f (Syntax.BlockComment CommentType
_ Text
_) = String -> Text
forall a. HasCallStack => String -> a
error String
"extractTexts called on a BlockComment"
  f (Syntax.BlockFilter Text
_ Text
_) = String -> Text
forall a. HasCallStack => String -> a
error String
"extractTexts called on a BlockFilter"
  f (Syntax.BlockRawElem Text
_ [Block]
_) = String -> Text
forall a. HasCallStack => String -> a
error String
"extractTexts called on a BlockRawElem"
  f (Syntax.BlockDefault Text
_ [Block]
_) = String -> Text
forall a. HasCallStack => String -> a
error String
"extractTexts called on a BlockDefault"
  f (Syntax.BlockImport String
_ Maybe [Block]
_ [Block]
_) = String -> Text
forall a. HasCallStack => String -> a
error String
"extractTexts called on a BlockImport"
  f (Syntax.BlockRun Text
_ Maybe [Block]
_) = String -> Text
forall a. HasCallStack => String -> a
error String
"extractTexts called on a BlockRun"
  f (Syntax.BlockReadJson Text
_ String
_ Maybe Value
_) = String -> Text
forall a. HasCallStack => String -> a
error String
"extractTexts called on a BlockReadJson"
  f (Syntax.BlockAssignVar Text
_ Expr
_) = String -> Text
forall a. HasCallStack => String -> a
error String
"extractTexts called on a BlockAssignVar"
  f (Syntax.BlockIf Expr
_ [Block]
_ [Block]
_) = String -> Text
forall a. HasCallStack => String -> a
error String
"extractTexts called on a BlockIf"
  f (Syntax.BlockList [Block]
_) = String -> Text
forall a. HasCallStack => String -> a
error String
"extractTexts called on a BlockList"
  f (Syntax.BlockCode Expr
_) = String -> Text
forall a. HasCallStack => String -> a
error String
"extractTexts called on a BlockCode"

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