120 lines
5.9 KiB
Haskell
120 lines
5.9 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module HTML (compileToHTML) where
|
|
|
|
import Data.Char (isAlphaNum, toLower)
|
|
import Data.Maybe (fromMaybe)
|
|
import qualified Data.Text as T
|
|
import IR
|
|
|
|
escapeChar :: Char -> T.Text
|
|
escapeChar '<' = "<"
|
|
escapeChar '>' = ">"
|
|
escapeChar '"' = """
|
|
escapeChar '\'' = "'"
|
|
escapeChar '&' = "&"
|
|
escapeChar c = T.singleton c
|
|
|
|
-- not effiecient, main optimization would be to have unpack go to
|
|
-- some haskell vector or array impl rather than the list impl
|
|
escapeText :: T.Text -> T.Text
|
|
escapeText = T.concat . map escapeChar . T.unpack
|
|
|
|
genHeaderId :: Heading -> T.Text
|
|
genHeaderId header =
|
|
T.concat
|
|
[ " id=\"",
|
|
T.map (toLower . textSub) $
|
|
T.strip $
|
|
T.filter (\c -> isAlphaNum c || c == ' ') $
|
|
serializeInlineToHTML header.text,
|
|
"\" "
|
|
]
|
|
where
|
|
textSub ' ' = '-'
|
|
textSub c = c
|
|
|
|
tshow :: (Show s) => s -> T.Text
|
|
tshow = T.pack . show
|
|
|
|
compileToHTML :: Document -> T.Text
|
|
compileToHTML (Doc elements) = T.concat $ map elementToHTML elements
|
|
|
|
elementsToHTML :: [Element] -> T.Text
|
|
elementsToHTML = T.concat . map elementToHTML
|
|
|
|
spaceSep :: [T.Text] -> T.Text
|
|
spaceSep = T.intercalate " "
|
|
|
|
elementToHTML :: Element -> T.Text
|
|
elementToHTML (Heading header attrs) = T.concat ["<h", tshow header.level, headerAttrs header attrs, ">", serializeInlineToHTML header.text, "</h", tshow header.level, ">"]
|
|
--
|
|
elementToHTML (Code code_block attrs) = T.concat ["<pre class=\"sourceCode ", language, "\" ", handleAttrs attrs, "><code class=\"sourceCode ", language, "\">", escapeText code_block.code, "</code>", "</pre>"]
|
|
where
|
|
language = fromMaybe "" code_block.language
|
|
elementToHTML (BlockQuote (Q elems) attrs) = T.concat ["<blockquote ", handleAttrs attrs, ">", elementsToHTML elems, "</blockquote>"]
|
|
elementToHTML (List (L {list_type = Ordered {start_number, style}, items}) attrs) = spaceSep ["<ol", maybe "" handleStart start_number, maybe "" handleStyle style, ">", generateLiElems items, "</ol>"]
|
|
elementToHTML (List (L {list_type = Unordered {style}, items}) attrs) = spaceSep ["<ul", maybe "" handleStyle style, ">", generateLiElems items, "</ul>"]
|
|
elementToHTML (HTML (HTMLTag {html_content})) = html_content
|
|
elementToHTML (Paragraph (P snippets) attrs) = spaceSep ["<p", handleAttrs attrs, ">", serializeInlineToHTML snippets, "</p>"]
|
|
elementToHTML (Transparent snippets) = serializeInlineToHTML snippets
|
|
elementToHTML (HorizontalRule attrs) = "<hr " <> handleAttrs attrs <> ">"
|
|
elementToHTML (Table _ _) = error "TODO"
|
|
elementToHTML (Container _ _) = error "TODO"
|
|
elementToHTML (Footnote _ _) = error "TODO"
|
|
elementToHTML (DescriptionList _ _) = error "TODO"
|
|
elementToHTML (RawBlock _ _) = error "TODO"
|
|
elementToHTML (TaskList _ _) = error "TODO"
|
|
|
|
handleStyle :: T.Text -> T.Text
|
|
handleStyle style = T.concat ["type=\"", style, "\""]
|
|
|
|
handleStart :: Int -> T.Text
|
|
handleStart start = T.concat ["start=\"", T.show start, "\""]
|
|
|
|
handleAttrs :: Attrs -> T.Text
|
|
handleAttrs Attrs {attrId, attrClasses, attrKV} =
|
|
spaceSep
|
|
[ maybe "" (\id -> "id=\"" <> id <> "\"") attrId,
|
|
"class=\"" <> T.intercalate " " attrClasses <> "\"",
|
|
T.intercalate " " $ map (\(key, val) -> key <> "=\"" <> val <> "\"") attrKV
|
|
]
|
|
|
|
headerAttrs :: Heading -> Attrs -> T.Text
|
|
headerAttrs header Attrs {attrId, attrClasses, attrKV} =
|
|
spaceSep
|
|
-- id is overcomplicated due to header having id logic written I don't wanna bother with
|
|
[ maybe (genHeaderId header) (\id -> "id=\"" <> id <> "\"") attrId,
|
|
"class=\"" <> T.intercalate " " attrClasses <> "\"",
|
|
T.intercalate " " $ map (\(key, val) -> key <> "=\"" <> val <> "\"") attrKV
|
|
]
|
|
|
|
generateLiElems :: [ListItem] -> T.Text
|
|
generateLiElems [] = ""
|
|
generateLiElems (element : remainder) =
|
|
T.concat
|
|
[ "<li>",
|
|
elementsToHTML element.content,
|
|
"</li>",
|
|
generateLiElems remainder
|
|
]
|
|
|
|
serializeInlineToHTML :: [InlineText] -> T.Text
|
|
serializeInlineToHTML [] = ""
|
|
serializeInlineToHTML (Text t : remaining) = escapeText t <> serializeInlineToHTML remaining
|
|
serializeInlineToHTML ((Bold elems attrs) : remaining) = spaceSep ["<b", handleAttrs attrs, ">", serializeInlineToHTML elems, "</b>", serializeInlineToHTML remaining]
|
|
serializeInlineToHTML ((Italic elems attrs) : remaining) = spaceSep ["<i", handleAttrs attrs, ">", serializeInlineToHTML elems, "</i>", serializeInlineToHTML remaining]
|
|
serializeInlineToHTML ((Crossed elems attrs) : remaining) = spaceSep ["<s", handleAttrs attrs, ">", serializeInlineToHTML elems, "</s>", serializeInlineToHTML remaining]
|
|
serializeInlineToHTML ((InlineCode code attrs) : remaining) = spaceSep ["<code", handleAttrs attrs, ">", escapeText code, "</code>", serializeInlineToHTML remaining]
|
|
serializeInlineToHTML (Link {linkText, url, title, misc_attrs} : remaining) = T.concat ["<a href=\"", url, "\" ", handleAttrs misc_attrs, maybe "" (\t -> T.concat [" title=\"", escapeText t, "\""]) title, ">", serializeInlineToHTML linkText, "</a>", serializeInlineToHTML remaining]
|
|
serializeInlineToHTML (Image {altText, url, title, misc_attrs} : remaining) = T.concat ["<img src=\"", url, "\" alt=\"", escapeText altText, "\" ", maybe "" (\t -> T.concat ["title=\"", escapeText t, "\" "]) title, handleAttrs misc_attrs, ">", serializeInlineToHTML remaining]
|
|
serializeInlineToHTML (HTMLInline {inline_html_content} : remaining) = inline_html_content <> serializeInlineToHTML remaining
|
|
serializeInlineToHTML ((Superscript _ _) : remaining) = error "TODO"
|
|
serializeInlineToHTML ((Subscript _ _) : remaining) = error "TODO"
|
|
serializeInlineToHTML ((Highlighted _ _) : remaining) = error "TODO"
|
|
serializeInlineToHTML ((Insert _ _) : remaining) = error "TODO"
|
|
serializeInlineToHTML ((Math _ _) : remaining) = error "TODO"
|
|
serializeInlineToHTML ((FootnoteReference {}) : remaining) = error "TODO"
|
|
serializeInlineToHTML ((Symbol _) : remaining) = error "TODO"
|
|
serializeInlineToHTML ((RawInline _ _) : remaining) = error "TODO"
|
|
serializeInlineToHTML ((Span _ _) : remaining) = error "TODO"
|