{-# LANGUAGE OverloadedStrings #-}
module Drasil.Data.Formats.HTML.Render (
renderHTML,
HTMLRenderOptions(..)
) where
import Prettyprinter (
Doc, hcat, hsep, indent, vcat, angles, dquotes, equals, space, pretty)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Map as M
import Drasil.Data.Formats.HTML.Core (
HTML(..), HTMLBody(..), HTMLHead(..), TagType(..), CustomTag(..),
Format(..), HLevel(..), Row(..), Cell(..), LItem(..), DItem(..), ListType(..),
Attr(..)
)
newtype HTMLRenderOptions = HTMLRO {
HTMLRenderOptions -> Map CustomTag TagType
customElementTagTypes :: M.Map CustomTag TagType
}
renderHTML :: HTMLRenderOptions -> HTML -> Doc ann
renderHTML :: forall ann. HTMLRenderOptions -> HTML -> Doc ann
renderHTML HTMLRenderOptions
opt(HTML [HTMLHead]
heads [HTMLBody]
bodies) =
[Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat [Doc ann
"<!DOCTYPE html>", Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
angles Doc ann
"html",
[HTMLHead] -> Doc ann
forall ann. [HTMLHead] -> Doc ann
renderHeadSec [HTMLHead]
heads,
HTMLRenderOptions -> [HTMLBody] -> Doc ann
forall ann. HTMLRenderOptions -> [HTMLBody] -> Doc ann
renderBodySec HTMLRenderOptions
opt [HTMLBody]
bodies,
Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
angles Doc ann
"/html"]
renderHeadSec :: [HTMLHead] -> Doc ann
renderHeadSec :: forall ann. [HTMLHead] -> Doc ann
renderHeadSec [HTMLHead]
heads = Text -> [Attr] -> [Doc ann] -> Doc ann
forall ann. Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlock Text
"head" [] ((HTMLHead -> Doc ann) -> [HTMLHead] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map HTMLHead -> Doc ann
forall ann. HTMLHead -> Doc ann
renderHead [HTMLHead]
heads)
renderBodySec :: HTMLRenderOptions -> [HTMLBody] -> Doc ann
renderBodySec :: forall ann. HTMLRenderOptions -> [HTMLBody] -> Doc ann
renderBodySec HTMLRenderOptions
opt [HTMLBody]
bodies = Text -> [Attr] -> [Doc ann] -> Doc ann
forall ann. Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlock Text
"body" [] ((HTMLBody -> Doc ann) -> [HTMLBody] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (HTMLRenderOptions -> HTMLBody -> Doc ann
forall ann. HTMLRenderOptions -> HTMLBody -> Doc ann
renderBody HTMLRenderOptions
opt) [HTMLBody]
bodies)
renderHead :: HTMLHead -> Doc ann
renderHead :: forall ann. HTMLHead -> Doc ann
renderHead (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 (Title Text
txt) = Text -> [Attr] -> [Doc ann] -> Doc ann
forall ann. Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlock 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 (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 (Script [Attr]
attrs Text
txt) = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
angles (Doc ann
"script" 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
<> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
txt 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
"/script"
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
renderLine HTMLRenderOptions
opt Text
"p" [Attr]
attrs [HTMLBody]
ch
renderBody HTMLRenderOptions
opt (List ListType
Unordered [Attr]
attrs [LItem]
items) = Text -> [Attr] -> [Doc ann] -> Doc ann
forall ann. Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlock Text
"ul" [Attr]
attrs ((LItem -> Doc ann) -> [LItem] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map LItem -> Doc ann
forall {ann}. LItem -> Doc ann
renderIList [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
renderBlock HTMLRenderOptions
opt Text
"li" [Attr]
iAttrs [HTMLBody]
ch
renderBody HTMLRenderOptions
opt (List ListType
Ordered [Attr]
attrs [LItem]
items) = Text -> [Attr] -> [Doc ann] -> Doc ann
forall ann. Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlock Text
"ol" [Attr]
attrs ((LItem -> Doc ann) -> [LItem] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map LItem -> Doc ann
forall {ann}. LItem -> Doc ann
renderIList [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
renderBlock HTMLRenderOptions
opt Text
"li" [Attr]
iAttrs [HTMLBody]
ch
renderBody HTMLRenderOptions
opt (DescriptionList [Attr]
attrs [DItem]
items) = Text -> [Attr] -> [Doc ann] -> Doc ann
forall ann. Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlock Text
"dl" [Attr]
attrs ((DItem -> Doc ann) -> [DItem] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map DItem -> Doc ann
forall {ann}. DItem -> Doc ann
renderDItem [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
renderBlock HTMLRenderOptions
opt Text
"dd" [Attr]
iAttrs [HTMLBody]
ch
renderBody HTMLRenderOptions
opt (Table [Attr]
attr [Row]
rows) = Text -> [Attr] -> [Doc ann] -> Doc ann
forall ann. Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlock Text
"table" [Attr]
attr ((Row -> Doc ann) -> [Row] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Row -> Doc ann
forall {ann}. Row -> Doc ann
renderRow [Row]
rows)
where renderRow :: Row -> Doc ann
renderRow (Row [Attr]
attrs [Cell]
cells) = Text -> [Attr] -> [Doc ann] -> Doc ann
forall ann. Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlock Text
"tr" [Attr]
attrs ((Cell -> Doc ann) -> [Cell] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Cell -> Doc ann
forall {ann}. Cell -> Doc ann
renderCell [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)
| 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
"-->"
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"
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"
renderLine :: HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
renderLine :: forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
renderLine HTMLRenderOptions
opt Text
tag [Attr]
attrs = Text -> [Attr] -> [Doc ann] -> Doc ann
forall ann. Text -> [Attr] -> [Doc ann] -> Doc ann
wrapLine Text
tag [Attr]
attrs ([Doc ann] -> Doc ann)
-> ([HTMLBody] -> [Doc ann]) -> [HTMLBody] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HTMLBody -> Doc ann) -> [HTMLBody] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (HTMLRenderOptions -> HTMLBody -> Doc ann
forall ann. HTMLRenderOptions -> HTMLBody -> Doc ann
renderBody HTMLRenderOptions
opt)
renderBlock :: HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
renderBlock :: forall ann.
HTMLRenderOptions -> Text -> [Attr] -> [HTMLBody] -> Doc ann
renderBlock HTMLRenderOptions
opt Text
tag [Attr]
attrs = Text -> [Attr] -> [Doc ann] -> Doc ann
forall ann. Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlock Text
tag [Attr]
attrs ([Doc ann] -> Doc ann)
-> ([HTMLBody] -> [Doc ann]) -> [HTMLBody] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HTMLBody -> Doc ann) -> [HTMLBody] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (HTMLRenderOptions -> HTMLBody -> Doc ann
forall ann. HTMLRenderOptions -> HTMLBody -> Doc ann
renderBody HTMLRenderOptions
opt)
wrapBlock :: Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlock :: forall ann. Text -> [Attr] -> [Doc ann] -> Doc ann
wrapBlock 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 Int
2 ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat [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) ]
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)
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) -> [Attr] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Attr -> Doc ann
forall {ann}. Attr -> Doc ann
rAttr [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)
escapeHTMLText :: Text -> Text
escapeHTMLText :: Text -> Text
escapeHTMLText = (Char -> Text) -> Text -> Text
T.concatMap Char -> Text
escapeChar
where
escapeChar :: Char -> Text
escapeChar Char
'<' = Text
"<"
escapeChar Char
'>' = Text
">"
escapeChar Char
'&' = Text
"&"
escapeChar Char
'"' = Text
"""
escapeChar Char
'\'' = Text
"'"
escapeChar Char
'/' = Text
"/"
escapeChar Char
c = Char -> Text
T.singleton Char
c