{-# LANGUAGE OverloadedStrings #-}

module Drasil.Data.Formats.HTML.Render
  ( renderHTML,
    HTMLRenderOptions (..),
    defaultHTMLRO,
  )
where

import Data.Map qualified as M
import Data.Text (Text)
import Data.Text qualified as T
import Drasil.Data.Formats.HTML.Core
  ( Attr (..),
    Cell (..),
    CustomTag (..),
    DItem (..),
    Format (..),
    HLevel (..),
    HTML (..),
    HTMLBody (..),
    HTMLHead (..),
    LItem (..),
    ListType (..),
    Row (..),
    TagType (..),
  )
import Prettyprinter
  ( Doc,
    angles,
    dquotes,
    equals,
    hcat,
    hsep,
    indent,
    pretty,
    space,
    vcat,
  )

data HTMLRenderOptions = HTMLRO
  { -- | What 'TagType' is each 'CustomTag'?
    HTMLRenderOptions -> Map CustomTag TagType
customElementTagTypes :: M.Map CustomTag TagType,
    -- | The number of spaces to use for each level of indentation.
    HTMLRenderOptions -> Int
indentationSize :: Int
  }

-- | Default 'HTMLRenderOptions' with standard indentation and no custom tags.
defaultHTMLRO :: HTMLRenderOptions
defaultHTMLRO :: HTMLRenderOptions
defaultHTMLRO = Map CustomTag TagType -> Int -> HTMLRenderOptions
HTMLRO Map CustomTag TagType
forall k a. Map k a
M.empty Int
2

-- | Render 'HTML' to a 'Doc'
renderHTML :: HTMLRenderOptions -> HTML -> Doc ann
renderHTML :: forall ann. HTMLRenderOptions -> HTML -> Doc ann
renderHTML HTMLRenderOptions
opt HTML
htmlTree =
  [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
    [ Doc ann
"<!DOCTYPE html>",
      HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlock
        HTMLRenderOptions
opt
        Text
"html"
        []
        [HTMLRenderOptions -> [HTMLHead] -> Doc ann
forall ann. HTMLRenderOptions -> [HTMLHead] -> Doc ann
renderHeadSec HTMLRenderOptions
opt [HTMLHead]
heads, HTMLRenderOptions -> [HTMLBody] -> Doc ann
forall ann. HTMLRenderOptions -> [HTMLBody] -> Doc ann
renderBodySec HTMLRenderOptions
opt [HTMLBody]
bodies]
    ]
  where
    HTML [HTMLHead]
heads [HTMLBody]
bodies = HTML -> HTML
normalizeHTML HTML
htmlTree

-- | Internal: Render the 'head' section
renderHeadSec :: HTMLRenderOptions -> [HTMLHead] -> Doc ann
renderHeadSec :: forall ann. HTMLRenderOptions -> [HTMLHead] -> Doc ann
renderHeadSec HTMLRenderOptions
opt [HTMLHead]
heads = HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlock HTMLRenderOptions
opt Text
"head" [] (HTMLRenderOptions -> HTMLHead -> Doc ann
forall ann. HTMLRenderOptions -> HTMLHead -> Doc ann
renderHead HTMLRenderOptions
opt (HTMLHead -> Doc ann) -> [HTMLHead] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [HTMLHead]
heads)

-- | Internal: Render the 'body' section
renderBodySec :: HTMLRenderOptions -> [HTMLBody] -> Doc ann
renderBodySec :: forall ann. HTMLRenderOptions -> [HTMLBody] -> Doc ann
renderBodySec HTMLRenderOptions
opt [HTMLBody]
bodies = HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlock HTMLRenderOptions
opt Text
"body" [] (HTMLRenderOptions -> HTMLBody -> Doc ann
forall ann. HTMLRenderOptions -> HTMLBody -> Doc ann
renderBody HTMLRenderOptions
opt (HTMLBody -> Doc ann) -> [HTMLBody] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [HTMLBody]
bodies)

-- | Internal: Render 'head' elements
renderHead :: HTMLRenderOptions -> HTMLHead -> Doc ann
renderHead :: forall ann. HTMLRenderOptions -> HTMLHead -> Doc ann
renderHead HTMLRenderOptions
_ (Link Text
relation Text
file [Attr]
attrs) =
  Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
angles (Doc ann
"link" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Attr] -> Doc ann
forall ann. [Attr] -> Doc ann
renderAttrs (Text -> Text -> Attr
Attr Text
"rel" Text
relation Attr -> [Attr] -> [Attr]
forall a. a -> [a] -> [a]
: Text -> Text -> Attr
Attr Text
"href" Text
file Attr -> [Attr] -> [Attr]
forall a. a -> [a] -> [a]
: [Attr]
attrs))
renderHead HTMLRenderOptions
_ (Title Text
txt) = Text -> [Attr] -> [Doc ann] -> Doc ann
forall ann. Text -> [Attr] -> [Doc ann] -> Doc ann
wrapLine Text
"title" [] [Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Text
escapeHTMLText Text
txt)]
renderHead HTMLRenderOptions
_ (Meta [Attr]
attrs) = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
angles (Doc ann
"meta" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Attr] -> Doc ann
forall ann. [Attr] -> Doc ann
renderAttrs [Attr]
attrs)
renderHead HTMLRenderOptions
opt (Script [Attr]
attrs Text
txt) = HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlock HTMLRenderOptions
opt Text
"script" [Attr]
attrs [Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
txt | Bool -> Bool
not (Text -> Bool
T.null Text
txt)]

-- | Internal: Render 'body' elements
renderBody :: HTMLRenderOptions -> HTMLBody -> Doc ann
renderBody :: forall ann. HTMLRenderOptions -> HTMLBody -> Doc ann
renderBody HTMLRenderOptions
opt (Div [Attr]
attrs [HTMLBody]
ch) = HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
renderBlock HTMLRenderOptions
opt Text
"div" [Attr]
attrs [HTMLBody]
ch
renderBody HTMLRenderOptions
opt (Paragraph [Attr]
attrs [HTMLBody]
ch) = HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
renderBlockInline HTMLRenderOptions
opt Text
"p" [Attr]
attrs [HTMLBody]
ch
renderBody HTMLRenderOptions
opt (List ListType
Unordered [Attr]
attrs [LItem]
items) = HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlock HTMLRenderOptions
opt Text
"ul" [Attr]
attrs (LItem -> Doc ann
renderIList (LItem -> Doc ann) -> [LItem] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LItem]
items)
  where
    renderIList :: LItem -> Doc ann
renderIList (LItem [Attr]
iAttrs [HTMLBody]
ch) = HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
renderLine HTMLRenderOptions
opt Text
"li" [Attr]
iAttrs [HTMLBody]
ch
renderBody HTMLRenderOptions
opt (List ListType
Ordered [Attr]
attrs [LItem]
items) = HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlock HTMLRenderOptions
opt Text
"ol" [Attr]
attrs (LItem -> Doc ann
renderIList (LItem -> Doc ann) -> [LItem] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LItem]
items)
  where
    renderIList :: LItem -> Doc ann
renderIList (LItem [Attr]
iAttrs [HTMLBody]
ch) = HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
renderBlockInline HTMLRenderOptions
opt Text
"li" [Attr]
iAttrs [HTMLBody]
ch
renderBody HTMLRenderOptions
opt (Section [Attr]
attrs [HTMLBody]
ch) = HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
renderBlock HTMLRenderOptions
opt Text
"section" [Attr]
attrs [HTMLBody]
ch
renderBody HTMLRenderOptions
opt (DescriptionList [Attr]
attrs [DItem]
items) = HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlock HTMLRenderOptions
opt Text
"dl" [Attr]
attrs (DItem -> Doc ann
renderDItem (DItem -> Doc ann) -> [DItem] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DItem]
items)
  where
    renderDItem :: DItem -> Doc ann
renderDItem (DTerm [Attr]
iAttrs [HTMLBody]
ch) = HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
renderLine HTMLRenderOptions
opt Text
"dt" [Attr]
iAttrs [HTMLBody]
ch
    renderDItem (DDetails [Attr]
iAttrs [HTMLBody]
ch) = HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
renderBlockInline HTMLRenderOptions
opt Text
"dd" [Attr]
iAttrs [HTMLBody]
ch
renderBody HTMLRenderOptions
opt (Table [Attr]
attrs [Row]
rows) = HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlock HTMLRenderOptions
opt Text
"table" [Attr]
attrs (Row -> Doc ann
renderRow (Row -> Doc ann) -> [Row] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Row]
rows)
  where
    renderRow :: Row -> Doc ann
renderRow (Row [Attr]
rAttrs [Cell]
cells) = HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlock HTMLRenderOptions
opt Text
"tr" [Attr]
rAttrs (Cell -> Doc ann
renderCell (Cell -> Doc ann) -> [Cell] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Cell]
cells)
    renderCell :: Cell -> Doc ann
renderCell (THeader [Attr]
cAttrs [HTMLBody]
ch) = HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
renderLine HTMLRenderOptions
opt Text
"th" [Attr]
cAttrs [HTMLBody]
ch
    renderCell (TData [Attr]
cAttrs [HTMLBody]
ch) = HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
renderLine HTMLRenderOptions
opt Text
"td" [Attr]
cAttrs [HTMLBody]
ch
renderBody HTMLRenderOptions
opt (Figure [Attr]
attrs [HTMLBody]
ch) = HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
renderBlock HTMLRenderOptions
opt Text
"figure" [Attr]
attrs [HTMLBody]
ch
renderBody HTMLRenderOptions
opt (FigCaption [Attr]
attrs [HTMLBody]
ch) = HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
renderLine HTMLRenderOptions
opt Text
"figcaption" [Attr]
attrs [HTMLBody]
ch
renderBody HTMLRenderOptions
opt (TextFormat Format
fmt [Attr]
attrs [HTMLBody]
ch) = HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
renderLine HTMLRenderOptions
opt (Format -> Text
fmtTag Format
fmt) [Attr]
attrs [HTMLBody]
ch
renderBody HTMLRenderOptions
opt (Heading HLevel
lvl [Attr]
attrs [HTMLBody]
ch) = HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
renderLine HTMLRenderOptions
opt (HLevel -> Text
headTag HLevel
lvl) [Attr]
attrs [HTMLBody]
ch
renderBody HTMLRenderOptions
opt (Anchor Text
url [Attr]
attrs [HTMLBody]
ch) = HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
renderLine HTMLRenderOptions
opt Text
"a" (Text -> Text -> Attr
Attr Text
"href" Text
url Attr -> [Attr] -> [Attr]
forall a. a -> [a] -> [a]
: [Attr]
attrs) [HTMLBody]
ch
renderBody HTMLRenderOptions
_ (Img Text
source Text
altTxt [Attr]
attrs) = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
angles (Doc ann
"img" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Attr] -> Doc ann
forall ann. [Attr] -> Doc ann
renderAttrs (Text -> Text -> Attr
Attr Text
"src" Text
source Attr -> [Attr] -> [Attr]
forall a. a -> [a] -> [a]
: Text -> Text -> Attr
Attr Text
"alt" Text
altTxt Attr -> [Attr] -> [Attr]
forall a. a -> [a] -> [a]
: [Attr]
attrs))
renderBody HTMLRenderOptions
_ (RawText Text
txt) = Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Text
escapeHTMLText Text
txt)
renderBody HTMLRenderOptions
opt (Custom (CT Text
tagName) [Attr]
attrs [HTMLBody]
ch)
  | Just TagType
Void <- CustomTag -> Map CustomTag TagType -> Maybe TagType
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Text -> CustomTag
CT Text
tagName) (HTMLRenderOptions -> Map CustomTag TagType
customElementTagTypes HTMLRenderOptions
opt) = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
angles (Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
tagName Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Attr] -> Doc ann
forall ann. [Attr] -> Doc ann
renderAttrs [Attr]
attrs Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" /")
  | Bool
otherwise = HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
renderBlock HTMLRenderOptions
opt Text
tagName [Attr]
attrs [HTMLBody]
ch
renderBody HTMLRenderOptions
_ (Comment Text
cmmnt) = Doc ann
"<!-- " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
cmmnt Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" -->"

-- | Internal: gets tag from text format
fmtTag :: Format -> Text
fmtTag :: Format -> Text
fmtTag Format
Bold = Text
"b"
fmtTag Format
Emphasis = Text
"em"
fmtTag Format
Subscript = Text
"sub"
fmtTag Format
Superscript = Text
"sup"
fmtTag Format
Span = Text
"span"

-- | Internal: gets tag from heading level
headTag :: HLevel -> Text
headTag :: HLevel -> Text
headTag HLevel
H1 = Text
"h1"
headTag HLevel
H2 = Text
"h2"
headTag HLevel
H3 = Text
"h3"
headTag HLevel
H4 = Text
"h4"
headTag HLevel
H5 = Text
"h5"
headTag HLevel
H6 = Text
"h6"

-- | Internal: Render the element and its children in the same line
renderLine :: HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
renderLine :: forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
renderLine HTMLRenderOptions
opt Text
tag [Attr]
attrs [HTMLBody]
ch = Text -> [Attr] -> [Doc ann] -> Doc ann
forall ann. Text -> [Attr] -> [Doc ann] -> Doc ann
wrapLine Text
tag [Attr]
attrs ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ HTMLRenderOptions -> HTMLBody -> Doc ann
forall ann. HTMLRenderOptions -> HTMLBody -> Doc ann
renderBody HTMLRenderOptions
opt (HTMLBody -> Doc ann) -> [HTMLBody] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [HTMLBody]
ch

-- | Internal: Render the children breaking lines
renderBlock :: HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
renderBlock :: forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
renderBlock HTMLRenderOptions
opt Text
tag [Attr]
attrs [HTMLBody]
ch = HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlock HTMLRenderOptions
opt Text
tag [Attr]
attrs ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ HTMLRenderOptions -> HTMLBody -> Doc ann
forall ann. HTMLRenderOptions -> HTMLBody -> Doc ann
renderBody HTMLRenderOptions
opt (HTMLBody -> Doc ann) -> [HTMLBody] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [HTMLBody]
ch

-- | Internal: Render the element as a block, but keep all children on a single indented line
renderBlockInline :: HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
renderBlockInline :: forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
renderBlockInline HTMLRenderOptions
_ Text
tag [Attr]
attrs [] = Text -> [Attr] -> [Doc ann] -> Doc ann
forall ann. Text -> [Attr] -> [Doc ann] -> Doc ann
wrapLine Text
tag [Attr]
attrs []
renderBlockInline HTMLRenderOptions
opt Text
tag [Attr]
attrs [HTMLBody]
ch = HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlockInline HTMLRenderOptions
opt Text
tag [Attr]
attrs (HTMLRenderOptions -> HTMLBody -> Doc ann
forall ann. HTMLRenderOptions -> HTMLBody -> Doc ann
renderBody HTMLRenderOptions
opt (HTMLBody -> Doc ann) -> [HTMLBody] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [HTMLBody]
ch)

-- | Internal: Wrap an element with tag and its children breaking lines
wrapBlock :: HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlock :: forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlock = ([Doc ann] -> Doc ann)
-> HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
forall ann.
([Doc ann] -> Doc ann)
-> HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlockWith [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat

-- | Internal: Wrap an element with tag and its children in the same line
wrapLine :: Text -> [Attr] -> [Doc ann] -> Doc ann
wrapLine :: forall ann. Text -> [Attr] -> [Doc ann] -> Doc ann
wrapLine Text
tag [Attr]
attrs [Doc ann]
docs =
  Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
angles (Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
tag Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Attr] -> Doc ann
forall ann. [Attr] -> Doc ann
renderAttrs [Attr]
attrs) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hcat [Doc ann]
docs Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
angles (Doc ann
"/" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
tag)

-- | Internal: Wrap an element with tags on separate lines, but children on the same line
wrapBlockInline :: HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlockInline :: forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlockInline = ([Doc ann] -> Doc ann)
-> HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
forall ann.
([Doc ann] -> Doc ann)
-> HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlockWith [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hcat

-- | Internal: Wraps block elements using a document combining function.
wrapBlockWith :: ([Doc ann] -> Doc ann) -> HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlockWith :: forall ann.
([Doc ann] -> Doc ann)
-> HTMLRenderOptions -> Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlockWith [Doc ann] -> Doc ann
catDocs HTMLRenderOptions
opt Text
tag [Attr]
attrs [Doc ann]
docs =
  [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
    [ Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
angles (Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
tag Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Attr] -> Doc ann
forall ann. [Attr] -> Doc ann
renderAttrs [Attr]
attrs),
      Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent (HTMLRenderOptions -> Int
indentationSize HTMLRenderOptions
opt) ([Doc ann] -> Doc ann
catDocs [Doc ann]
docs),
      Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
angles (Doc ann
"/" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
tag)
    ]

-- | Internal: Render attribute in the format 'key="value"'
renderAttrs :: [Attr] -> Doc ann
renderAttrs :: forall ann. [Attr] -> Doc ann
renderAttrs [] = Doc ann
forall a. Monoid a => a
mempty
renderAttrs [Attr]
attrs = Doc ann
forall ann. Doc ann
space Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep (Attr -> Doc ann
forall {ann}. Attr -> Doc ann
rAttr (Attr -> Doc ann) -> [Attr] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Attr]
attrs)
  where
    rAttr :: Attr -> Doc ann
rAttr (Attr Text
k Text
v) = Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
k Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall {a} {ann}. (Eq a, IsString a, Pretty a) => a -> Doc ann
rValue Text
v
    rValue :: a -> Doc ann
rValue a
value =
      case a
value of
        a
"" -> Doc ann
forall a. Monoid a => a
mempty
        a
_ -> Doc ann
forall ann. Doc ann
equals Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
dquotes (a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
value)

-- | Internal: Escapes a character for encoding in HTML
escapeHTMLText :: Text -> Text
escapeHTMLText :: Text -> Text
escapeHTMLText = (Char -> Text) -> Text -> Text
T.concatMap Char -> Text
escapeChar
  where
    escapeChar :: Char -> Text
escapeChar Char
'<'  = Text
"&lt;"
    escapeChar Char
'>'  = Text
"&gt;"
    escapeChar Char
'&'  = Text
"&amp;"
    escapeChar Char
'"'  = Text
"&quot;"
    escapeChar Char
'\'' = Text
"&#39;"
    escapeChar Char
c    = Char -> Text
T.singleton Char
c

-- | Internal: Normalizes the whole HTML tree at once
normalizeHTML :: HTML -> HTML
normalizeHTML :: HTML -> HTML
normalizeHTML (HTML [HTMLHead]
heads [HTMLBody]
bodies) = [HTMLHead] -> [HTMLBody] -> HTML
HTML [HTMLHead]
heads ([HTMLBody] -> [HTMLBody]
normalizeBody [HTMLBody]
bodies)

-- | Internal: Normalizes body elements, merging adjacent 'RawText'
normalizeBody :: [HTMLBody] -> [HTMLBody]
normalizeBody :: [HTMLBody] -> [HTMLBody]
normalizeBody [] = []
normalizeBody (RawText Text
a : RawText Text
b : [HTMLBody]
rest) = [HTMLBody] -> [HTMLBody]
normalizeBody (Text -> HTMLBody
RawText (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b) HTMLBody -> [HTMLBody] -> [HTMLBody]
forall a. a -> [a] -> [a]
: [HTMLBody]
rest)
normalizeBody (HTMLBody
x : [HTMLBody]
xs) = HTMLBody -> HTMLBody
normalizeNode HTMLBody
x HTMLBody -> [HTMLBody] -> [HTMLBody]
forall a. a -> [a] -> [a]
: [HTMLBody] -> [HTMLBody]
normalizeBody [HTMLBody]
xs

-- | Internal: Normalizes children from each node
normalizeNode :: HTMLBody -> HTMLBody
normalizeNode :: HTMLBody -> HTMLBody
normalizeNode (Div [Attr]
attrs [HTMLBody]
ch) = [Attr] -> [HTMLBody] -> HTMLBody
Div [Attr]
attrs ([HTMLBody] -> [HTMLBody]
normalizeBody [HTMLBody]
ch)
normalizeNode (Paragraph [Attr]
attrs [HTMLBody]
ch) = [Attr] -> [HTMLBody] -> HTMLBody
Paragraph [Attr]
attrs ([HTMLBody] -> [HTMLBody]
normalizeBody [HTMLBody]
ch)
normalizeNode (List ListType
t [Attr]
attrs [LItem]
items) = ListType -> [Attr] -> [LItem] -> HTMLBody
List ListType
t [Attr]
attrs (LItem -> LItem
normItem (LItem -> LItem) -> [LItem] -> [LItem]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LItem]
items)
  where
    normItem :: LItem -> LItem
normItem (LItem [Attr]
a [HTMLBody]
ch) = [Attr] -> [HTMLBody] -> LItem
LItem [Attr]
a ([HTMLBody] -> [HTMLBody]
normalizeBody [HTMLBody]
ch)
normalizeNode (DescriptionList [Attr]
attrs [DItem]
items) = [Attr] -> [DItem] -> HTMLBody
DescriptionList [Attr]
attrs (DItem -> DItem
normDItem (DItem -> DItem) -> [DItem] -> [DItem]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DItem]
items)
  where
    normDItem :: DItem -> DItem
normDItem (DTerm [Attr]
a [HTMLBody]
ch) = [Attr] -> [HTMLBody] -> DItem
DTerm [Attr]
a ([HTMLBody] -> [HTMLBody]
normalizeBody [HTMLBody]
ch)
    normDItem (DDetails [Attr]
a [HTMLBody]
ch) = [Attr] -> [HTMLBody] -> DItem
DDetails [Attr]
a ([HTMLBody] -> [HTMLBody]
normalizeBody [HTMLBody]
ch)
normalizeNode (Table [Attr]
attrs [Row]
rows) = [Attr] -> [Row] -> HTMLBody
Table [Attr]
attrs (Row -> Row
normRow (Row -> Row) -> [Row] -> [Row]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Row]
rows)
  where
    normRow :: Row -> Row
normRow (Row [Attr]
a [Cell]
cells) = [Attr] -> [Cell] -> Row
Row [Attr]
a (Cell -> Cell
normCell (Cell -> Cell) -> [Cell] -> [Cell]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Cell]
cells)
    normCell :: Cell -> Cell
normCell (THeader [Attr]
a [HTMLBody]
ch) = [Attr] -> [HTMLBody] -> Cell
THeader [Attr]
a ([HTMLBody] -> [HTMLBody]
normalizeBody [HTMLBody]
ch)
    normCell (TData [Attr]
a [HTMLBody]
ch) = [Attr] -> [HTMLBody] -> Cell
TData [Attr]
a ([HTMLBody] -> [HTMLBody]
normalizeBody [HTMLBody]
ch)
normalizeNode (Figure [Attr]
attrs [HTMLBody]
ch) = [Attr] -> [HTMLBody] -> HTMLBody
Figure [Attr]
attrs ([HTMLBody] -> [HTMLBody]
normalizeBody [HTMLBody]
ch)
normalizeNode (FigCaption [Attr]
attrs [HTMLBody]
ch) = [Attr] -> [HTMLBody] -> HTMLBody
FigCaption [Attr]
attrs ([HTMLBody] -> [HTMLBody]
normalizeBody [HTMLBody]
ch)
normalizeNode (TextFormat Format
fmt [Attr]
attrs [HTMLBody]
ch) = Format -> [Attr] -> [HTMLBody] -> HTMLBody
TextFormat Format
fmt [Attr]
attrs ([HTMLBody] -> [HTMLBody]
normalizeBody [HTMLBody]
ch)
normalizeNode (Heading HLevel
lvl [Attr]
attrs [HTMLBody]
ch) = HLevel -> [Attr] -> [HTMLBody] -> HTMLBody
Heading HLevel
lvl [Attr]
attrs ([HTMLBody] -> [HTMLBody]
normalizeBody [HTMLBody]
ch)
normalizeNode (Anchor Text
url [Attr]
attrs [HTMLBody]
ch) = Text -> [Attr] -> [HTMLBody] -> HTMLBody
Anchor Text
url [Attr]
attrs ([HTMLBody] -> [HTMLBody]
normalizeBody [HTMLBody]
ch)
normalizeNode (Custom CustomTag
ct [Attr]
attrs [HTMLBody]
ch) = CustomTag -> [Attr] -> [HTMLBody] -> HTMLBody
Custom CustomTag
ct [Attr]
attrs ([HTMLBody] -> [HTMLBody]
normalizeBody [HTMLBody]
ch)
normalizeNode HTMLBody
node = HTMLBody
node