djot-0.1.4: src/Djot/Html.hs
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE Strict #-}
module Djot.Html
( inlinesToByteString
, renderHtml
, RenderOptions(..)
)
where
import Djot.AST
import Data.Tuple (swap)
import Djot.Parse (strToUtf8)
import Djot.Options (RenderOptions(..))
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import Data.ByteString.Builder (Builder, byteString, word8, intDec)
import qualified Data.Sequence as Seq
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import Data.List (sort)
import Control.Monad.State
import qualified Data.Foldable as F
renderHtml :: RenderOptions -> Doc -> Builder
renderHtml opts doc = evalState
( (<>) <$> toBuilder (docBlocks doc)
<*> toNotes )
BState{ noteMap = docFootnotes doc
, noteRefs = mempty
, renderedNotes = mempty
, referenceMap = docReferences doc
<> docAutoReferences doc
, options = opts
}
toNotes :: State BState Builder
toNotes = do
st <- get
let noterefs = noteRefs st
let numnotes = M.size noterefs
let revnoterefs = sort $ map swap $ M.toList noterefs
let toNote (num, lab) =
let num' = B8.pack (show num)
in inTags "li" NoPos (Attr [("id", "fn" <> num')])
("\n" <> fromMaybe mempty (M.lookup lab (renderedNotes st)))
<> "\n"
if numnotes < 1
then pure mempty
else pure $
inTags "section" NoPos (Attr [("role", "doc-endnotes")])
("\n" <> singleTag "hr" NoPos mempty <> "\n" <>
inTags "ol" NoPos mempty ("\n" <> foldMap toNote revnoterefs) <> "\n")
<> "\n"
addBackref :: ByteString -> Blocks -> Blocks
addBackref num (Many bls) =
Many $
case Seq.viewr bls of
rest Seq.:> Node pos attr (Para ils) ->
rest Seq.|> Node pos attr (Para (ils <> backlink))
_ -> bls Seq.|> Node NoPos mempty (Para backlink)
where
backlink = Many $ Seq.singleton $
Node NoPos (Attr [("role", "doc-backlink")])
(Link (str (strToUtf8 "\8617\65038"))
(Direct ("#fnref" <> num)))
{-# INLINE escapeHtml #-}
escapeHtml :: ByteString -> Builder
escapeHtml bs =
if hasEscapable bs
then B.foldl' go mempty bs
else byteString bs
where
hasEscapable = B.any (\w -> w == 38 || w == 60 || w == 62)
go b 38 = b <> byteString "&"
go b 60 = b <> byteString "<"
go b 62 = b <> byteString ">"
go b c = b <> word8 c
{-# INLINE escapeHtmlAttribute #-}
escapeHtmlAttribute :: ByteString -> Builder
escapeHtmlAttribute bs =
if hasEscapable bs
then B.foldl' go mempty bs
else byteString bs
where
hasEscapable = B.any (\w -> w == 38 || w == 60 || w == 62 || w == 34)
go b 38 = b <> byteString "&"
go b 60 = b <> byteString "<"
go b 62 = b <> byteString ">"
go b 34 = b <> byteString """
go b c = b <> word8 c
data BState =
BState { noteMap :: NoteMap
, noteRefs :: M.Map ByteString Int
, renderedNotes :: M.Map ByteString Builder
, referenceMap :: ReferenceMap
, options :: RenderOptions
}
{-# SPECIALIZE toBuilder :: Blocks -> State BState Builder #-}
{-# SPECIALIZE toBuilder :: Inlines -> State BState Builder #-}
class ToBuilder a where
toBuilder :: a -> State BState Builder
instance ToBuilder Inlines where
toBuilder = fmap F.fold . mapM toBuilder . unMany
instance ToBuilder Blocks where
toBuilder = fmap F.fold . mapM toBuilder . unMany
instance ToBuilder (Node Block) where
toBuilder (Node pos attr bl) =
let addNl = (<> "\n") in
case bl of
Para ils -> addNl . inTags "p" pos attr <$> toBuilder ils
Heading lev ils ->
let tag = case lev of
1 -> "h1"
2 -> "h2"
3 -> "h3"
4 -> "h4"
5 -> "h5"
6 -> "h6"
_ -> "p"
in addNl . inTags tag pos attr <$> toBuilder ils
Section bls -> do
contents <- toBuilder bls
pure $ addNl $ inTags "section" pos attr $ "\n" <> contents
ThematicBreak -> pure $ addNl $ singleTag "hr" pos attr
BulletList listSpacing items ->
addNl . inTags "ul" pos attr . ("\n" <>) . mconcat <$> mapM toLi items
where
toLi bls = addNl . inTags "li" NoPos mempty . ("\n" <>) <$>
toItemContents listSpacing bls
OrderedList listAttr listSpacing items ->
addNl . inTags "ol" pos (Attr [("start", strToUtf8 (show start))
| start /= 1]
<> Attr [("type", typ) | typ /= "1"] <> attr)
. ("\n" <>) . mconcat <$> mapM toLi items
where
typ = case orderedListStyle listAttr of
Decimal -> "1"
LetterUpper -> "A"
LetterLower -> "a"
RomanUpper -> "I"
RomanLower -> "i"
start = orderedListStart listAttr
toLi bls = addNl . inTags "li" NoPos mempty . ("\n" <>)
<$> toItemContents listSpacing bls
DefinitionList listSpacing defs ->
addNl . inTags "dl" pos attr . ("\n" <>) . mconcat
<$> mapM (toDefinition listSpacing) defs
TaskList listSpacing items ->
addNl . inTags "ul" pos (Attr [("class", "task-list")] <> attr)
. ("\n" <>) . mconcat <$> mapM (toTaskListItem listSpacing) items
Div bls -> addNl . inTags "div" pos attr . ("\n" <>) <$> toBuilder bls
BlockQuote bls ->
addNl . inTags "blockquote" pos attr . ("\n" <>) <$> toBuilder bls
CodeBlock lang bs -> pure $
inTags "pre" pos attr (inTags "code" NoPos codeattr (escapeHtml bs))
<> "\n"
where
codeattr = if B.null lang
then mempty
else Attr [("class", "language-" <> lang)]
Table mbCaption rows -> do
rows' <- mapM toRow rows
capt <- case mbCaption of
Nothing -> pure mempty
Just (Caption bs) ->
addNl . inTags "caption" NoPos mempty
<$> case F.toList (unMany bs) of
[Node _pos at (Para ils)] | at == mempty
-> toBuilder ils
_ -> ("\n" <>) <$> toBuilder bs
pure $ addNl . inTags "table" pos attr . ("\n" <>) $ capt <> mconcat rows'
RawBlock (Format "html") bs -> pure $ byteString bs
RawBlock _ _ -> pure mempty
toRow :: [Cell] -> State BState Builder
toRow cells = (<> "\n") . inTags "tr" NoPos mempty . ("\n" <>) . mconcat
<$> mapM toCell cells
toCell :: Cell -> State BState Builder
toCell (Cell cellType align ils) =
(<> "\n") . inTags (if cellType == HeadCell
then "th"
else "td") NoPos attr <$> toBuilder ils
where
attr = Attr $ case align of
AlignDefault -> []
AlignLeft -> [("style", "text-align: left;")]
AlignRight -> [("style", "text-align: right;")]
AlignCenter -> [("style", "text-align: center;")]
toItemContents :: ListSpacing -> Blocks -> State BState Builder
toItemContents listSpacing = fmap F.fold . mapM go . unMany
where
go (Node pos attr bl) =
case bl of
Para ils
| listSpacing == Tight ->
if attr == mempty
then (<> "\n") <$> toBuilder ils
else (<> "\n") . inTags "span" pos attr <$> toBuilder ils
| otherwise -> toBuilder (Node pos attr bl)
_ -> toBuilder (Node pos attr bl)
toTaskListItem :: ListSpacing -> (TaskStatus, Blocks) -> State BState Builder
toTaskListItem listSpacing (status, bs) = do
body <- case Seq.viewl $ unMany bs of
Node pos attr (Para ils) Seq.:< rest ->
toItemContents listSpacing (Many
(Node pos attr
(Para (rawInline (Format "html") ("<label>" <> input) <>
ils <>
rawInline (Format "html") "</label>")) Seq.<| rest))
_ -> toBuilder $ rawBlock (Format "html") input <> bs
pure $ inTags "li" NoPos (Attr [("class", if status == Complete
then "checked"
else "unchecked")]) ("\n" <> body) <> "\n"
where
inputattr = " type=\"checkbox\"" <>
if status == Complete then " checked=\"\"" else ""
input = "<input" <> inputattr <> " />"
toDefinition :: ListSpacing -> (Inlines, Blocks) -> State BState Builder
toDefinition listSpacing (term, defn) = (<>) <$>
((<> "\n") . inTags "dt" NoPos mempty <$> toBuilder term) <*>
((<> "\n") . inTags "dd" NoPos mempty . ("\n" <>) <$> toItemContents listSpacing defn)
instance ToBuilder (Node Inline) where
toBuilder (Node pos attr il) =
case il of
Str bs -> case attr of
Attr [] | pos == NoPos -> pure $ escapeHtml bs
_ -> pure $ inTags "span" pos attr $ escapeHtml bs
SoftBreak -> do
opts <- gets options
pure $ word8 $ if preserveSoftBreaks opts then 10 else 32
HardBreak -> pure $ singleTag "br" NoPos attr <> "\n"
NonBreakingSpace -> pure $ byteString " "
Emph ils -> inTags "em" pos attr <$> toBuilder ils
Strong ils -> inTags "strong" pos attr <$> toBuilder ils
Highlight ils -> inTags "mark" pos attr <$> toBuilder ils
Insert ils -> inTags "ins" pos attr <$> toBuilder ils
Delete ils -> inTags "del" pos attr <$> toBuilder ils
Superscript ils -> inTags "sup" pos attr <$> toBuilder ils
Subscript ils -> inTags "sub" pos attr <$> toBuilder ils
Quoted SingleQuotes ils -> inSingleQuotes <$> toBuilder ils
Quoted DoubleQuotes ils -> inDoubleQuotes <$> toBuilder ils
Verbatim bs -> pure $ inTags "code" pos attr (escapeHtml bs)
Math DisplayMath bs -> pure $
inTags "span" pos (Attr [("class", "math display")] <> attr)
("\\[" <> escapeHtml bs <> "\\]")
Math InlineMath bs -> pure $
inTags "span" pos (Attr [("class", "math inline")] <> attr)
("\\(" <> escapeHtml bs <> "\\)")
Symbol bs -> pure $
inTags "span" pos (Attr [("class", "symbol")] <> attr)
(":" <> escapeHtml bs <> ":")
Span ils -> inTags "span" pos attr <$> toBuilder ils
Link ils target -> do
attr' <- case target of
Direct u -> pure $ Attr [("href", u)]
Reference label -> do
rm <- gets referenceMap
case lookupReference label rm of
Nothing -> pure mempty
Just (u, Attr as) -> pure $ Attr (("href",u):as)
inTags "a" pos (attr' <> attr) <$> toBuilder ils
Image ils target -> do
attr' <- case target of
Direct u -> pure $ Attr [("src", u)]
Reference label -> do
rm <- gets referenceMap
case lookupReference label rm of
Nothing -> pure $ Attr [("src", "")]
Just (u, Attr as) -> pure $ Attr (("src",u):as)
pure $ singleTag "img" pos
(Attr [("alt", inlinesToByteString ils)] <> attr' <> attr)
EmailLink email ->
toBuilder (Node pos attr (Link (str email) (Direct ("mailto:" <> email))))
UrlLink url -> toBuilder (Node pos attr (Link (str url) (Direct url)))
RawInline (Format "html") bs -> pure $ byteString bs
RawInline _ _ -> pure mempty
FootnoteReference label -> do
noterefs <- gets noteRefs
notemap <- gets noteMap
num <- case M.lookup label noterefs of
Just num -> pure num
Nothing -> do
let num = M.size noterefs + 1
modify $ \st -> st{ noteRefs = M.insert label num noterefs }
renderedNotesMap <- gets renderedNotes
case M.lookup label renderedNotesMap of
Just _ -> pure ()
Nothing -> do -- render the note and add to renderedNotes
let num' = B8.pack (show num)
rendered <- maybe (toBuilder $ addBackref num' (mempty :: Blocks))
(toBuilder . addBackref num') (lookupNote label notemap)
modify $ \st -> st{ renderedNotes =
M.insert label rendered (renderedNotes st) }
pure num
let num' = B8.pack $ show num
pure $ inTags "a" pos (Attr [("id", "fnref" <> num'),
("href", "#fn" <> num'),
("role", "doc-noteref")] <> attr) $
inTags "sup" pos mempty (escapeHtml num')
{-# INLINE inTags #-}
inTags :: ByteString -> Pos -> Attr -> Builder -> Builder
inTags tag pos attr contents =
"<" <> byteString tag <> posToBuilder pos
<> attrToBuilder attr <> ">" <> contents
<> "</" <> byteString tag <> ">"
{-# INLINE singleTag #-}
singleTag :: ByteString -> Pos -> Attr -> Builder
singleTag tag pos attr =
"<" <> byteString tag <> posToBuilder pos <> attrToBuilder attr <> ">"
{-# INLINE attrToBuilder #-}
attrToBuilder :: Attr -> Builder
attrToBuilder (Attr pairs) = foldMap go pairs
where
go (k,v) = " " <> byteString k <> "=\"" <> escapeHtmlAttribute v <> "\""
{-# INLINE posToBuilder #-}
posToBuilder :: Pos -> Builder
posToBuilder NoPos = mempty
posToBuilder (Pos sl sc el ec) =
" data-pos=\"" <> intDec sl <> ":" <> intDec sc <> "-" <>
intDec el <> ":" <> intDec ec <> "\""
inSingleQuotes :: Builder -> Builder
inSingleQuotes x =
byteString (strToUtf8 "\x2018") <> x <> byteString (strToUtf8 "\x2019")
inDoubleQuotes :: Builder -> Builder
inDoubleQuotes x =
byteString (strToUtf8 "\x201C") <> x <> byteString (strToUtf8 "\x201D")