app/HTML.hs

@@ -15,14 +15,14 @@ compileToHTML (Doc elements) = T.concat $ map elementToHTML elements
 elementToHTML :: Element -> T.Text
 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, "\">", code, "</code>"]
+elementToHTML (Code (C {language = m_language, code})) = T.concat ["<pre class=\"sourceCode ", language, "\"><code class=\"sourceCode ", language, "\">"]
   where
     language = fromMaybe "" m_language
 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 = Unordered, items})) = T.concat ["<ul>", generateLiElems items, "</ul>"]
-elementToHTML (HTML (HTMLTag {html_content})) = html_content
-elementToHTML (Paragraph (P snippets)) = T.concat ["<p>", serializeInlineToHTML snippets, "</p>"]
+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 (Paragraph (P snippets)) = serializeInlineToHTML snippets
 elementToHTML HorizontalRule = "<hr>"
 
 generateLiElems :: [ListItem] -> T.Text
@@ -34,16 +34,11 @@ generateLiElems (LI {content, children} : remainder) =
       -- if they aren't this is fucked
       serializeInlineToHTML content,
       T.concat $ map (elementToHTML . List) children,
-      "</li>",
-      generateLiElems remainder
+      "</li>"
     ]
 
 serializeInlineToHTML :: [InlineText] -> T.Text
 serializeInlineToHTML [] = ""
-serializeInlineToHTML (Text t : remaining) = t <> serializeInlineToHTML remaining
-serializeInlineToHTML (Bold elems : remaining) = T.concat ["<b>", serializeInlineToHTML elems, "</b>", serializeInlineToHTML remaining]
-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
+serializeInlineToHTML (Text t : rem) = t <> serializeInlineToHTML rem
+serializeInlineToHTML (Bold elems : rem) = T.concat ["<b>", serializeInlineToHTML elems, "</b>", serializeInlineToHTML rem]
+serializeInlineToHTML (Italic elems : rem) = T.concat ["<i>", serializeInlineToHTML elems, "</i>", serializeInlineToHTML rem]

app/IR.hs

@@ -3,7 +3,6 @@ module IR where
 import Data.Text
 
 newtype Document = Doc [Element]
-  deriving (Show)
 
 data Element
   = Heading Heading
@@ -13,7 +12,6 @@ data Element
   | HTML HTML
   | Paragraph Paragraph
   | HorizontalRule
-  deriving (Show)
 
 -- Removed: BlankLine
 
@@ -21,37 +19,34 @@ data Heading = H
   { level :: Int,
     text :: [InlineText]
   }
-  deriving (Show)
 
 data Code = C
   { language :: Maybe Text,
     code :: Text
   }
-  deriving (Show)
 
-data BlockQuote = Q [InlineText] deriving (Show)
+data BlockQuote = Q [InlineText]
 
 data ListItem = LI
   { content :: [InlineText], -- Flatten continuations into here
     children :: [List]
   }
-  deriving (Show)
 
-data ListType = Ordered | Unordered deriving (Show)
+data ListType = Ordered | Unordered
 
 data List = L
   { list_type :: ListType,
     items :: [ListItem]
   }
-  deriving (Show)
 
 data HTML
   = HTMLTag
-  { html_content :: Text
+  { tagName :: Text,
+    attributes :: [(Text, Maybe Text)],
+    html_content :: Text
   }
-  deriving (Show)
 
-newtype Paragraph = P [InlineText] deriving (Show)
+newtype Paragraph = P [InlineText]
 
 data InlineText
   = Text Text -- Combined Normal and Escaped
@@ -68,8 +63,10 @@ data InlineText
         url :: Text,
         title :: Maybe Text
       }
-  | HTMLInline {inline_html_content :: Text}
-  deriving (Show)
+  | HTMLInline
+      { inlineTagName :: Text,
+        inlineAttributes :: [(Text, Maybe Text)]
+      }
 
 -- for processing math
 -- https://hackage.haskell.org/package/typst-0.6.1/docs/Typst-Parse.html#v:parseTypst

app/Markdown.hs

@@ -2,11 +2,10 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 
--- (document, metadata)
-module Markdown where
+module Markdown (document, metadata) where
 
 import Control.Applicative (many, optional, some, (<|>))
-import Control.Monad (guard, void)
+import Control.Monad (guard, void, when)
 import Data.Char (isAlpha)
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -175,12 +174,37 @@ orderedListItem = do
 
 -- HTML Block
 htmlBlock :: Parser Element
-htmlBlock = do
-  char '<'
-  -- Capture the entire HTML block as raw text
-  rest <- manyTill anyChar (try $ char '>' >> lineEnding)
-  let content = '<' : rest
-  return $ HTML $ HTMLTag (T.pack content)
+htmlBlock = char '<' *> choice [try htmlCommentBlock, try htmlDeclarationBlock, htmlTagBlock]
+
+htmlCommentBlock :: Parser Element
+htmlCommentBlock = do
+  string "!--"
+  content <- manyTill anyChar (try $ string "-->")
+  lineEnding
+  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 = do
@@ -219,10 +243,10 @@ paragraphBlock = do
   notFollowedBy (string "```" <|> string "~~~")
   notFollowedBy (count 4 (char ' ' <|> char '\t'))
   notFollowedBy (count 3 (char '*') <|> count 3 (char '-') <|> count 3 (char '_'))
-  -- notFollowedBy (char '<')
+  notFollowedBy (char '<')
 
   content <- some inlineElement
-  lineEnding <|> eof
+  lineEnding
   pure $ Paragraph $ P content
 
 -- Inline Elements
@@ -329,10 +353,10 @@ image :: Parser InlineText
 image = do
   char '!'
   char '['
-  alt <- T.pack <$> many (noneOf "]\n\r")
+  alt <- some (notFollowedBy (char ']') >> inlineElementNoBracket)
   char ']'
   (url, title) <- linkDestination
-  return $ Image {altText = alt, url = url, title = title}
+  pure $ Image alt url title
 
 -- Link
 link :: Parser InlineText
@@ -383,9 +407,13 @@ titleParser =
 -- HTML Inline
 htmlInline :: Parser InlineText
 htmlInline = do
-  start <- char '<'
-  content <- manyTill anyChar (try $ char '>')
-  return $ HTMLInline (T.pack (start : content ++ ">"))
+  char '<'
+  name <- Markdown.tagName
+  attrs <- many (try $ wsParser >> attribute)
+  optional wsParser
+  _ <- option False (char '/' >> pure True)
+  char '>'
+  pure $ HTMLInline (T.pack name) attrs
 
 -- Escaped Character
 escapedChar :: Parser InlineText
@@ -400,14 +428,14 @@ plainText = Text . T.pack <$> some plainTextChar
 
 plainTextChar :: Parser Char
 plainTextChar = satisfy $ \c ->
-  (c `notElem` ("*_`[<\\\n\r" :: String)) && c >= ' '
+  (c `notElem` ("*_`[!<\\\n\r" :: String)) && c >= ' '
 
 plainTextNoAsterisk :: Parser InlineText
 plainTextNoAsterisk =
   Text . T.pack
     <$> some
       ( satisfy $ \c ->
-          (c `notElem` ("*_`[<\\\n\r" :: String)) && c >= ' '
+          (c `notElem` ("*_`[!<\\\n\r" :: String)) && c >= ' '
       )
 
 plainTextNoUnderscore :: Parser InlineText
@@ -415,7 +443,7 @@ plainTextNoUnderscore =
   Text . T.pack
     <$> some
       ( satisfy $ \c ->
-          not (c `elem` ("_*`[<\\\n\r" :: String)) && c >= ' '
+          not (c `elem` ("_*`[!<\\\n\r" :: String)) && c >= ' '
       )
 
 plainTextNoBracket :: Parser InlineText
@@ -423,7 +451,7 @@ plainTextNoBracket =
   Text . T.pack
     <$> some
       ( satisfy $ \c ->
-          not (c `elem` ("]_*`[<\\\n\r" :: String)) && c >= ' '
+          not (c `elem` ("]_*`[!<\\\n\r" :: String)) && c >= ' '
       )
 
 -- Helper Parsers

app/Utilities.hs

@@ -2,6 +2,8 @@ module Utilities where
 
 import Config
 import Control.Monad (filterM)
+import Data.Aeson (Result (Error, Success))
+import qualified Data.Aeson as A
 import Data.List (find)
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -15,6 +17,8 @@ import Development.Shake.FilePath ((<.>), (</>))
 import qualified Development.Shake.FilePath as FP
 import HTML
 import Markdown
+import Text.Pandoc (Block (Plain), Meta (..), MetaValue (..), Pandoc (..))
+import qualified Text.Pandoc as Pandoc
 import Text.Parsec hiding (Error)
 import Types
 
@@ -37,29 +41,79 @@ indexHtmlMarkdownSourcePath =
 markdownToHtml :: (FromJSON a) => FilePath -> Action (a, Text)
 markdownToHtml filePath = do
   content <- Shake.readFile' filePath
-  let (metadataText, document) = case parse (liftA2 (,) Markdown.metadata Markdown.document) filePath content of
-        Right (a, b) -> (a, b)
-        Left e -> error $ show e
-
-  let metadata = case decodeEither' $ encodeUtf8 metadataText of
-        Right m -> m
-        Left e -> error $ show e
+  let Right (metadataText, document) = parse (liftA2 (,) Markdown.metadata Markdown.document) filePath content
+  let Right metadata = decodeEither' $ encodeUtf8 metadataText
   pure (metadata, compileToHTML document)
 
+markdownToHtml_ filePath = do
+  content <- Shake.readFile' filePath
+  Shake.quietly . Shake.traced "Markdown to HTML" $ do
+    pandoc@(Pandoc meta _) <-
+      runPandoc . Pandoc.readMarkdown readerOptions . T.pack $ content
+    -- WARNING markdown needs to have no whitespace before/after dashes
+    -- print meta
+    meta' <- fromMeta meta
+    html <- runPandoc . Pandoc.writeHtml5String writerOptions $ pandoc
+    return (meta', html)
+  where
+    readerOptions =
+      Pandoc.def
+        { Pandoc.readerStandalone = True,
+          Pandoc.readerExtensions = Pandoc.enableExtension Pandoc.Ext_yaml_metadata_block Pandoc.pandocExtensions
+        }
+    writerOptions =
+      Pandoc.def {Pandoc.writerExtensions = Pandoc.pandocExtensions}
+    fromMeta (Meta meta) =
+      A.fromJSON . A.toJSON <$> traverse metaValueToJSON meta >>= \case
+        Success res -> pure res
+        Error err -> fail $ "json conversion error:" <> err
+    metaValueToJSON = \case
+      MetaMap m -> A.toJSON <$> traverse metaValueToJSON m
+      MetaList m -> A.toJSONList <$> traverse metaValueToJSON m
+      MetaBool m -> pure $ A.toJSON m
+      MetaString m -> pure $ A.toJSON $ T.strip m
+      MetaInlines m -> metaValueToJSON $ MetaBlocks [Plain m]
+      MetaBlocks m ->
+        fmap (A.toJSON . T.strip)
+          . runPandoc
+          . Pandoc.writePlain Pandoc.def
+          $ Pandoc mempty m
+
+runPandoc :: Pandoc.PandocIO b -> IO b
+runPandoc action =
+  Pandoc.runIO (Pandoc.setVerbosity Pandoc.ERROR >> action)
+    >>= either (fail . show) return
+
 now :: Action T.Text
 now = Shake.liftIO $ fmap (T.pack . iso8601Show) getCurrentTime
 
 markdownToPost :: FilePath -> Action Post
 markdownToPost path = do
   content <- Shake.readFile' path
-  -- TODO: error handling
-  let postData = case parse Markdown.metadata path content of
-        Right p -> p
-        Left e -> error $ show e
-  let post = case decodeEither' $ encodeUtf8 postData of
-        Right p -> p
-        Left e -> error $ show e
-  pure post
+  (Pandoc meta _) <-
+    Shake.liftIO . runPandoc . Pandoc.readMarkdown readerOptions . T.pack $ content
+  Shake.liftIO $ fromMeta meta
+  where
+    readerOptions =
+      Pandoc.def
+        { Pandoc.readerStandalone = True,
+          Pandoc.readerExtensions = Pandoc.enableExtension Pandoc.Ext_yaml_metadata_block Pandoc.pandocExtensions
+        }
+    fromMeta (Meta meta) =
+      A.fromJSON . A.toJSON <$> traverse metaValueToJSON meta >>= \case
+        Success res -> pure res
+        Error err -> fail $ "json conversion error:" <> err
+    metaValueToJSON = \case
+      MetaMap m -> A.toJSON <$> traverse metaValueToJSON m
+      MetaList m -> A.toJSONList <$> traverse metaValueToJSON m
+      MetaBool m -> pure $ A.toJSON m
+      MetaString m -> pure $ A.toJSON $ T.strip m
+      MetaInlines m -> metaValueToJSON $ MetaBlocks [Plain m]
+      MetaBlocks m ->
+        fmap (A.toJSON . T.strip)
+          . runPandoc
+          . Pandoc.writePlain Pandoc.def
+          $ Pandoc mempty m
 
 yamlToPost :: FilePath -> Action Post
 yamlToPost path = do

psb.cabal

@@ -35,7 +35,7 @@ executable psb
 
     -- Other library packages from which modules are imported.
     -- https://hackage.haskell.org/package/texmath
-    build-depends:    base >=4.17.2.1, mustache >=2.4.2,  shake >= 0.19.8, deriving-aeson >= 0.2.9, aeson, text, time, unordered-containers, yaml, parsec >= 3.1.18.0
+    build-depends:    base >=4.17.2.1, mustache >=2.4.2, pandoc >=3.2.1, shake >= 0.19.8, deriving-aeson >= 0.2.9, aeson, text, time, unordered-containers, yaml, parsec >= 3.1.18.0, typst >= 0.6.1, typst-symbols >= 0.1.7
 
     -- Directories containing source files.
     hs-source-dirs:   app