I think something crucial is using pandoc or I'm using an old psb version on the blog, I'm scared
This commit is contained in:
parent
bab574a9db
commit
06671b3b3b
4 changed files with 36 additions and 54 deletions
19
app/HTML.hs
19
app/HTML.hs
|
|
@ -15,14 +15,14 @@ compileToHTML (Doc elements) = T.concat $ map elementToHTML elements
|
||||||
elementToHTML :: Element -> T.Text
|
elementToHTML :: Element -> T.Text
|
||||||
elementToHTML (Heading (H {level, text})) = T.concat ["<h", tshow level, ">", serializeInlineToHTML text, "</h", tshow level, ">"]
|
elementToHTML (Heading (H {level, text})) = T.concat ["<h", tshow level, ">", serializeInlineToHTML text, "</h", tshow level, ">"]
|
||||||
--
|
--
|
||||||
elementToHTML (Code (C {language = m_language, code})) = T.concat ["<pre class=\"sourceCode ", language, "\"><code class=\"sourceCode ", language, "\">"]
|
elementToHTML (Code (C {language = m_language, code})) = T.concat ["<pre class=\"sourceCode ", language, "\"><code class=\"sourceCode ", language, "\">", code, "</code>"]
|
||||||
where
|
where
|
||||||
language = fromMaybe "" m_language
|
language = fromMaybe "" m_language
|
||||||
elementToHTML (BlockQuote (Q elems)) = T.concat ["<blockquote>", serializeInlineToHTML elems, "</blockquote>"]
|
elementToHTML (BlockQuote (Q elems)) = T.concat ["<blockquote>", serializeInlineToHTML elems, "</blockquote>"]
|
||||||
elementToHTML (List (L {list_type = Ordered, items})) = T.concat ["<ol>", generateLiElems items, "</ol>"]
|
elementToHTML (List (L {list_type = Ordered, items})) = T.concat ["<ol>", generateLiElems items, "</ol>"]
|
||||||
elementToHTML (List (L {list_type = Unordered, items})) = T.concat ["<ul>", generateLiElems items, "</ul>"]
|
elementToHTML (List (L {list_type = Unordered, items})) = T.concat ["<ul>", generateLiElems items, "</ul>"]
|
||||||
elementToHTML (HTML (HTMLTag {tagName, attributes, html_content})) = T.concat ["<", tagName, T.concat $ map (\(name, value) -> T.concat [name, "=", "\"", fromMaybe "" value, "\""]) attributes, ">", html_content, "</", tagName, ">"]
|
elementToHTML (HTML (HTMLTag {html_content})) = html_content
|
||||||
elementToHTML (Paragraph (P snippets)) = serializeInlineToHTML snippets
|
elementToHTML (Paragraph (P snippets)) = T.concat ["<p>", serializeInlineToHTML snippets, "</p>"]
|
||||||
elementToHTML HorizontalRule = "<hr>"
|
elementToHTML HorizontalRule = "<hr>"
|
||||||
|
|
||||||
generateLiElems :: [ListItem] -> T.Text
|
generateLiElems :: [ListItem] -> T.Text
|
||||||
|
|
@ -34,11 +34,16 @@ generateLiElems (LI {content, children} : remainder) =
|
||||||
-- if they aren't this is fucked
|
-- if they aren't this is fucked
|
||||||
serializeInlineToHTML content,
|
serializeInlineToHTML content,
|
||||||
T.concat $ map (elementToHTML . List) children,
|
T.concat $ map (elementToHTML . List) children,
|
||||||
"</li>"
|
"</li>",
|
||||||
|
generateLiElems remainder
|
||||||
]
|
]
|
||||||
|
|
||||||
serializeInlineToHTML :: [InlineText] -> T.Text
|
serializeInlineToHTML :: [InlineText] -> T.Text
|
||||||
serializeInlineToHTML [] = ""
|
serializeInlineToHTML [] = ""
|
||||||
serializeInlineToHTML (Text t : rem) = t <> serializeInlineToHTML rem
|
serializeInlineToHTML (Text t : remaining) = t <> serializeInlineToHTML remaining
|
||||||
serializeInlineToHTML (Bold elems : rem) = T.concat ["<b>", serializeInlineToHTML elems, "</b>", serializeInlineToHTML rem]
|
serializeInlineToHTML (Bold elems : remaining) = T.concat ["<b>", serializeInlineToHTML elems, "</b>", serializeInlineToHTML remaining]
|
||||||
serializeInlineToHTML (Italic elems : rem) = T.concat ["<i>", serializeInlineToHTML elems, "</i>", serializeInlineToHTML rem]
|
serializeInlineToHTML (Italic elems : remaining) = T.concat ["<i>", serializeInlineToHTML elems, "</i>", serializeInlineToHTML remaining]
|
||||||
|
serializeInlineToHTML (InlineCode code : remaining) = T.concat ["<code>", code, "</code>", serializeInlineToHTML remaining]
|
||||||
|
serializeInlineToHTML (Link {linkText, url, title} : remaining) = T.concat ["<a href=\"", url, "\" ", maybe "" (\t -> T.concat ["title=\"", t, "\""]) title, "\">", serializeInlineToHTML linkText, "</a>", serializeInlineToHTML remaining]
|
||||||
|
serializeInlineToHTML (Image {altText, url, title} : remaining) = T.concat ["<img src=\">", url, "\" alt=\"", altText, "\"", maybe "" (\t -> T.concat ["title=\"", t, "\""]) title, ">", serializeInlineToHTML remaining]
|
||||||
|
serializeInlineToHTML (HTMLInline {inline_html_content} : remaining) = inline_html_content <> serializeInlineToHTML remaining
|
||||||
|
|
|
||||||
|
|
@ -41,9 +41,7 @@ data List = L
|
||||||
|
|
||||||
data HTML
|
data HTML
|
||||||
= HTMLTag
|
= HTMLTag
|
||||||
{ tagName :: Text,
|
{ html_content :: Text
|
||||||
attributes :: [(Text, Maybe Text)],
|
|
||||||
html_content :: Text
|
|
||||||
}
|
}
|
||||||
|
|
||||||
newtype Paragraph = P [InlineText]
|
newtype Paragraph = P [InlineText]
|
||||||
|
|
@ -63,10 +61,7 @@ data InlineText
|
||||||
url :: Text,
|
url :: Text,
|
||||||
title :: Maybe Text
|
title :: Maybe Text
|
||||||
}
|
}
|
||||||
| HTMLInline
|
| HTMLInline {inline_html_content :: Text}
|
||||||
{ inlineTagName :: Text,
|
|
||||||
inlineAttributes :: [(Text, Maybe Text)]
|
|
||||||
}
|
|
||||||
|
|
||||||
-- for processing math
|
-- for processing math
|
||||||
-- https://hackage.haskell.org/package/typst-0.6.1/docs/Typst-Parse.html#v:parseTypst
|
-- https://hackage.haskell.org/package/typst-0.6.1/docs/Typst-Parse.html#v:parseTypst
|
||||||
|
|
|
||||||
|
|
@ -174,37 +174,13 @@ orderedListItem = do
|
||||||
|
|
||||||
-- HTML Block
|
-- HTML Block
|
||||||
htmlBlock :: Parser Element
|
htmlBlock :: Parser Element
|
||||||
htmlBlock = char '<' *> choice [try htmlCommentBlock, try htmlDeclarationBlock, htmlTagBlock]
|
htmlBlock = do
|
||||||
|
start <- getPosition
|
||||||
htmlCommentBlock :: Parser Element
|
char '<'
|
||||||
htmlCommentBlock = do
|
-- Capture the entire HTML block as raw text
|
||||||
string "!--"
|
rest <- manyTill anyChar (try $ char '>' >> lineEnding)
|
||||||
content <- manyTill anyChar (try $ string "-->")
|
let content = '<' : rest
|
||||||
lineEnding
|
return $ HTML $ HTMLTag (T.pack content)
|
||||||
pure $ HTML $ HTMLTag "!--" [] (T.pack content)
|
|
||||||
|
|
||||||
htmlDeclarationBlock :: Parser Element
|
|
||||||
htmlDeclarationBlock = do
|
|
||||||
char '!'
|
|
||||||
decl <- some (satisfy isAlpha)
|
|
||||||
rest <- many (noneOf ">\n\r")
|
|
||||||
char '>'
|
|
||||||
lineEnding
|
|
||||||
pure $ HTML $ HTMLTag (T.pack $ "!" ++ decl) [] (T.pack rest)
|
|
||||||
|
|
||||||
htmlTagBlock :: Parser Element
|
|
||||||
htmlTagBlock = do
|
|
||||||
name <- Markdown.tagName
|
|
||||||
attrs <- many (try $ wsParser >> attribute)
|
|
||||||
optional wsParser
|
|
||||||
selfClose <- option False (char '/' >> pure True)
|
|
||||||
char '>'
|
|
||||||
content <-
|
|
||||||
if selfClose
|
|
||||||
then pure ""
|
|
||||||
else manyTill anyChar (try $ string "</" >> string name >> char '>')
|
|
||||||
when (not selfClose) lineEnding
|
|
||||||
pure $ HTML $ HTMLTag (T.pack name) attrs (T.pack content)
|
|
||||||
|
|
||||||
tagName :: Parser String
|
tagName :: Parser String
|
||||||
tagName = do
|
tagName = do
|
||||||
|
|
@ -353,10 +329,10 @@ image :: Parser InlineText
|
||||||
image = do
|
image = do
|
||||||
char '!'
|
char '!'
|
||||||
char '['
|
char '['
|
||||||
alt <- some (notFollowedBy (char ']') >> inlineElementNoBracket)
|
alt <- T.pack <$> many (noneOf "]\n\r")
|
||||||
char ']'
|
char ']'
|
||||||
(url, title) <- linkDestination
|
(url, title) <- linkDestination
|
||||||
pure $ Image alt url title
|
return $ Image {altText = alt, url = url, title = title}
|
||||||
|
|
||||||
-- Link
|
-- Link
|
||||||
link :: Parser InlineText
|
link :: Parser InlineText
|
||||||
|
|
@ -407,13 +383,9 @@ titleParser =
|
||||||
-- HTML Inline
|
-- HTML Inline
|
||||||
htmlInline :: Parser InlineText
|
htmlInline :: Parser InlineText
|
||||||
htmlInline = do
|
htmlInline = do
|
||||||
char '<'
|
start <- char '<'
|
||||||
name <- Markdown.tagName
|
content <- manyTill anyChar (try $ char '>')
|
||||||
attrs <- many (try $ wsParser >> attribute)
|
return $ HTMLInline (T.pack (start : content ++ ">"))
|
||||||
optional wsParser
|
|
||||||
_ <- option False (char '/' >> pure True)
|
|
||||||
char '>'
|
|
||||||
pure $ HTMLInline (T.pack name) attrs
|
|
||||||
|
|
||||||
-- Escaped Character
|
-- Escaped Character
|
||||||
escapedChar :: Parser InlineText
|
escapedChar :: Parser InlineText
|
||||||
|
|
|
||||||
|
|
@ -41,10 +41,12 @@ indexHtmlMarkdownSourcePath =
|
||||||
markdownToHtml :: (FromJSON a) => FilePath -> Action (a, Text)
|
markdownToHtml :: (FromJSON a) => FilePath -> Action (a, Text)
|
||||||
markdownToHtml filePath = do
|
markdownToHtml filePath = do
|
||||||
content <- Shake.readFile' filePath
|
content <- Shake.readFile' filePath
|
||||||
|
-- TODO: error handling
|
||||||
let Right (metadataText, document) = parse (liftA2 (,) Markdown.metadata Markdown.document) filePath content
|
let Right (metadataText, document) = parse (liftA2 (,) Markdown.metadata Markdown.document) filePath content
|
||||||
let Right metadata = decodeEither' $ encodeUtf8 metadataText
|
let Right metadata = decodeEither' $ encodeUtf8 metadataText
|
||||||
pure (metadata, compileToHTML document)
|
pure (metadata, compileToHTML document)
|
||||||
|
|
||||||
|
markdownToHtml_ :: (FromJSON a) => FilePath -> Action (a, Text)
|
||||||
markdownToHtml_ filePath = do
|
markdownToHtml_ filePath = do
|
||||||
content <- Shake.readFile' filePath
|
content <- Shake.readFile' filePath
|
||||||
Shake.quietly . Shake.traced "Markdown to HTML" $ do
|
Shake.quietly . Shake.traced "Markdown to HTML" $ do
|
||||||
|
|
@ -89,6 +91,14 @@ now = Shake.liftIO $ fmap (T.pack . iso8601Show) getCurrentTime
|
||||||
|
|
||||||
markdownToPost :: FilePath -> Action Post
|
markdownToPost :: FilePath -> Action Post
|
||||||
markdownToPost path = do
|
markdownToPost path = do
|
||||||
|
content <- Shake.readFile' path
|
||||||
|
-- TODO: error handling
|
||||||
|
let Right postData = parse Markdown.metadata path content
|
||||||
|
let Right post = decodeEither' $ encodeUtf8 postData
|
||||||
|
pure post
|
||||||
|
|
||||||
|
markdownToPost_ :: FilePath -> Action Post
|
||||||
|
markdownToPost_ path = do
|
||||||
content <- Shake.readFile' path
|
content <- Shake.readFile' path
|
||||||
(Pandoc meta _) <-
|
(Pandoc meta _) <-
|
||||||
Shake.liftIO . runPandoc . Pandoc.readMarkdown readerOptions . T.pack $ content
|
Shake.liftIO . runPandoc . Pandoc.readMarkdown readerOptions . T.pack $ content
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue