Improved parser for horizontal rule and codeblock

src/MdToHTML.hs

@@ -40,6 +40,7 @@ data MdToken
   | Blockquote [MdToken]
   | UnordList [MdToken]
   | OrdList [MdToken]
+  | Checkbox Bool
   | Code MdToken
   | Table [[MdToken]]
   | Codeblock MdToken
@@ -66,6 +67,7 @@ instance Show MdToken where
   show (Blockquote tokens) = "<blockquote>" ++ concatMap show tokens ++ "</blockquote>"
   show (UnordList tokens) = "<ul>" ++ concatMap (prepend "<li>" . append "</li>" . show) tokens ++ "</ul>"
   show (OrdList tokens) = "<ol>" ++ concatMap (prepend "<li>" . append "</li>" . show) tokens ++ "</ol>"
+  show (Checkbox isChecked) = "<input type=\"checkbox\"" ++ (if isChecked then " checked=\"\"" else "") ++ " />"
   show (Code code) = "<code>" ++ strip (show code) ++ "</code>"
   show (Table (thead : tokenGrid)) = "<table><thead><tr>" ++ concatMap (\x -> "<th>" ++ rstrip (show x) ++ "</th>") thead ++ "</tr></thead>" ++ "<tbody>" ++ concatMap (\x -> "<tr>" ++ concatMap (\y -> "<td>" ++ rstrip (show y) ++ "</td>") x ++ "</tr>") tokenGrid ++ "</tbody></table>"
   show (Codeblock code) = "<pre><code>" ++ show code ++ "</code></pre>"
@@ -425,6 +427,15 @@ parseBlockquote = do
   let parsedQuotedLines = leftmostLongestParse (some (parseBlockquote <|> parsePara)) (init $ unlines quotedLines) -- unlines joins the lines together with a newline, and adds a trailing newline. init removes the trailing newline.
   return (Blockquote parsedQuotedLines)
 
+-- Parse a checkbox
+parseCheckbox :: Parser MdToken
+parseCheckbox = do
+  char '['
+  inside <- char ' ' <|> char 'x'
+  char ']'
+  space
+  return (if inside == 'x' then Checkbox True else Checkbox False)
+
 -- Parse a nested list item.
 parseListNested :: Parser MdToken
 parseListNested = do
@@ -460,9 +471,12 @@ parseOListLineItem = do
 parseListLineItemCommon :: Parser MdToken
 parseListLineItemCommon = do
   space
+  checkbox <- optional $ try parseCheckbox
   restOfLine <- manyTill parseListLineToken (void (char '\n') <|> eof)
   nestedList <- try parseListNested <|> return (Unit "")
-  return $ Line [Line restOfLine, nestedList]
+  case checkbox of
+    Just box -> return $ Line [box, Line restOfLine, nestedList]
+    Nothing -> return $ Line [Line restOfLine, nestedList]
 
 -- Parse an unordered list paragraph item.
 parseUListParaItem :: Parser MdToken
@@ -528,11 +542,15 @@ doubleNewlineText :: T.Text
 doubleNewlineText = T.pack "\n\n"
 
 parseHorizontalRule :: Parser MdToken
-parseHorizontalRule = string horizontalRuleText *> (void (string doubleNewlineText) <|> eof) *> return HorizontalRule
+parseHorizontalRule = parseHorizontalRuleLine *> (void (string doubleNewlineText) <|> eof) *> return HorizontalRule
+  where
+    parseHorizontalRuleLine = fallthroughParser (map (string . T.pack) ["---", "***", "___", "- - -", "* * *", "_ _ _"])
 
 parseCodeblock :: Parser MdToken
 parseCodeblock = do
-  string (T.pack "```\n")
+  string (T.pack "```")
+  _ <- many $ satisfy (/= '\n') -- Language name
+  char '\n'
   inside <- someTill anySingle (string (T.pack "\n```"))
   return $ Codeblock (Unit (concatMap escapeChar inside))