diff --git a/sample.html b/sample.html new file mode 100644 index 0000000..99b2a43 --- /dev/null +++ b/sample.html @@ -0,0 +1,4 @@ +

Heading 1

This is inline code.

A smaller heading

bold, italic, struckthrough

fold :: (a -> b -> b) -> b -> [a] -> b
+fold f z [] = z
+fold f z (x:xs) = f x (fold f z xs)
+

  1. This is a numbered list.

  2. This is the second item.

  3. This is the third item.

    1. This is the first sub-item

A regular paragraph with a this is a link.

This is an image example

Quotable quotes

"Quote me!"

Syntax Description
Header Title
Paragraph Code

The end.

\ No newline at end of file diff --git a/sample.md b/sample.md index e26f2c2..da12c18 100644 --- a/sample.md +++ b/sample.md @@ -16,8 +16,12 @@ fold f z (x:xs) = f x (fold f z xs) 3. This is a numbered list. 4. This is the second item. 5. This is the third item. + 1. This is the first sub-item - This is an unordered list. + - This is also an unordered list + - With another element + - This too - With another list item and **bold text** A regular paragraph with a [this is a link](www.google.com). diff --git a/src/HTMLParser.hs b/src/HTMLParser.hs index 433b010..82fab84 100644 --- a/src/HTMLParser.hs +++ b/src/HTMLParser.hs @@ -44,16 +44,28 @@ hHeadingP = choice [checkHeader i | i <- [1 .. 6]] checkHeader i = try $ Heading i <$> lineContainer ("h" ++ show i) -- | Parses for a list item -hLiP :: Parser S.Line -hLiP = lineContainer "li" +hLiP :: Parser Block +hLiP = betweenTag "li" hBlockP + +hSubListP :: Int -> Parser Block +hSubListP level = try (hSubOlListP (level + 1)) <|> hSubUlListP (level + 1) -- | Parses for an unordered list () hUlListP :: Parser Block -hUlListP = UnorderedList <$> container "ul" hLiP +hUlListP = hSubUlListP 0 + +hSubUlListP :: Int -> Parser Block +hSubUlListP level = flip UnorderedList level <$> + container "ul" (try (hSubListP level) <|> hLiP) -- | Parses for an ordered list (
  1. ...
) hOlListP :: Parser Block -hOlListP = OrderedList <$> ((,) <$> (read <$> openingWithAttr "ol" "start") <*> manyTill hLiP (try (closingTag "ol"))) +hOlListP = hSubOlListP 0 + +hSubOlListP :: Int -> Parser Block +hSubOlListP level = flip OrderedList level <$> + ((,) <$> (read <$> openingWithAttr "ol" "start") <*> + manyTill (try (hSubListP level) <|> hLiP) (try (closingTag "ol"))) -- | Parses for an image (() hImgP :: Parser Block diff --git a/src/HTMLPrettyPrinter.hs b/src/HTMLPrettyPrinter.hs index 447eef6..7362e73 100644 --- a/src/HTMLPrettyPrinter.hs +++ b/src/HTMLPrettyPrinter.hs @@ -1,6 +1,6 @@ module HTMLPrettyPrinter where -import Syntax (Block (..), Doc (Doc), Line, TableBody (..), TableCell (..), TableHead (..), TableRow (..), Text (..)) +import Syntax (Block (..), Doc (Doc), Line (..), TableBody (..), TableCell (..), TableHead (..), TableRow (..), Text (..)) import qualified Syntax as S import Text.PrettyPrint hiding (braces, parens, sep, (<>)) import qualified Text.PrettyPrint as PP @@ -18,9 +18,9 @@ instance PP S.Doc where instance PP S.Block where pp (S.Heading n l) = tag ("h" ++ show n) (pp l) pp (S.Paragraph l) = tag "p" (pp l) - pp (S.OrderedList (startVal, ls)) = - tagWithAttrs "ol" [("start", show startVal)] (PP.hcat $ map (tag "li" . pp) ls) - pp (S.UnorderedList ls) = tag "ul" (PP.hcat $ map (tag "li" . pp) ls) + pp (S.OrderedList (startVal, ls) _) = + tagWithAttrs "ol" [("start", show startVal)] (PP.hcat $ map tagIfNotSublist ls) + pp (S.UnorderedList ls _) = tag "ul" (PP.hcat $ map tagIfNotSublist ls) pp (S.Image alt src) = tagWithAttrs "img" [("alt", alt), ("src", src)] mempty pp (S.BlockQuote ls) = tag "blockquote" (PP.hcat $ map (tag "p" . pp) ls) pp (S.CodeBlock str) = tag "pre" $ tag "code" (PP.text str) @@ -28,6 +28,11 @@ instance PP S.Block where pp S.Br = PP.text "
" pp (S.Table thead tbody) = tag "table" $ PP.hcat [pp thead, pp tbody] +tagIfNotSublist :: Block -> PP.Doc +tagIfNotSublist x@(UnorderedList _ _) = pp x +tagIfNotSublist x@(OrderedList _ _) = pp x +tagIfNotSublist x = (tag "li" . pp) x + instance PP S.Line where pp (S.Line ts) = PP.hcat (map pp ts) diff --git a/src/MarkdownParser.hs b/src/MarkdownParser.hs index 06c193c..e466efd 100644 --- a/src/MarkdownParser.hs +++ b/src/MarkdownParser.hs @@ -44,29 +44,55 @@ headingP = do Monad.guard (length hx < 7) Heading (length hx) <$> lineP +liP :: Parser Block +liP = tryLiP <* many newLineChar + where + tryLiP = try brP + <|> try hrP + <|> try headingP + <|> try quoteP + <|> try codeBlockP + <|> try tableP + <|> paragraphP + +subListP :: Int -> Parser Block +subListP level = + try (wsP (string $ replicate level '\t') *> subUlListP level) + <|> (wsP (string $ replicate level '\t') *> subOlListP level) + -- | Parses for an unordered list (- list item) ulListP :: Parser Block -ulListP = - UnorderedList <$> do - -- first hyphen must have at least one space after - wsP (string "- " <|> string "* ") - firstItem <- lineP - remainingItems <- many $ - do - wsP (string "-" <|> string "*") - lineP +ulListP = subUlListP 0 + +subUlListP :: Int -> Parser Block +subUlListP level = + flip UnorderedList level <$> do + wsP (string "- " <|> string "* ") -- first hyphen must have at least one space after + firstItem <- liP + remainingItems <- many ( + try (subListP (level + 1)) + <|> do + string (replicate level '\t') *> wsP (string "-" <|> string "*") + liP + ) return $ firstItem : remainingItems -- | Parses for an ordered list (1. list item) olListP :: Parser Block -olListP = - OrderedList <$> do - startVal <- int <* wsP (string ". ") - firstItem <- lineP - remainingItems <- many $ - do - int <* wsP (string ".") - lineP +olListP = subOlListP 0 + +subOlListP :: Int -> Parser Block +subOlListP level = + flip OrderedList level <$> do + startVal <- int + wsP (string ". ") + firstItem <- liP + remainingItems <- many ( + try (subListP (level + 1)) + <|> do + string (replicate level '\t') *> int <* wsP (string ".") + blockP + ) return (startVal, firstItem : remainingItems) -- | Parses for a table diff --git a/src/MarkdownPrettyPrinter.hs b/src/MarkdownPrettyPrinter.hs index 198bf1b..bbf170f 100644 --- a/src/MarkdownPrettyPrinter.hs +++ b/src/MarkdownPrettyPrinter.hs @@ -21,13 +21,31 @@ instance PP S.Block where <> PP.space <> pp l pp (S.Paragraph l) = pp l - pp (S.OrderedList (i, ls)) = printListItem i ls + pp (S.OrderedList (i, ls) level) = printOrderedListItem level i ls where - printListItem :: Int -> [S.Line] -> PP.Doc - printListItem i [] = mempty - printListItem i (l : ls) = - PP.text (show i) <> PP.text ". " <> pp l <> printListItem (i + 1) ls - pp (S.UnorderedList ls) = PP.hcat $ map ((PP.text "- " <>) . pp) ls + printOrderedListItem :: Int -> Int -> [S.Block] -> PP.Doc + printOrderedListItem level i [] = mempty + printOrderedListItem level i (ol@(OrderedList _ _) : ls) = + pp ol <> printOrderedListItem level (i + 1) ls + printOrderedListItem level i (ul@(UnorderedList _ _) : ls) = + pp ul <> printOrderedListItem level (i + 1) ls + printOrderedListItem level i (l : ls) = + PP.text (replicate level '\t') + <> PP.text (show i) + <> PP.text ". " + <> pp l + <> printOrderedListItem level (i + 1) ls + pp (S.UnorderedList ls level) = printUnorderedListItem level ls + where + printUnorderedListItem :: Int -> [S.Block] -> PP.Doc + printUnorderedListItem level [] = mempty + printUnorderedListItem level (ol@(OrderedList _ _) : ls) = pp ol <> printUnorderedListItem level ls + printUnorderedListItem level (ul@(UnorderedList _ _) : ls) = pp ul <> printUnorderedListItem level ls + printUnorderedListItem level (l : ls) = + PP.text (replicate level '\t') + <> PP.text "- " + <> pp l + <> printUnorderedListItem level ls pp (S.Image alt src) = PP.text "!" <> PP.brackets (PP.text alt) <> PP.parens (PP.text src) pp (S.BlockQuote ls) = PP.hcat $ map ((PP.text ">" <>) . pp) ls pp (S.CodeBlock str) = PP.text "```\n" <> PP.text str <> PP.text "```" diff --git a/src/Syntax.hs b/src/Syntax.hs index a81bc85..044c8c3 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -10,8 +10,8 @@ newtype Doc = Doc [Block] data Block = Heading Int Line | Paragraph Line -- p - | OrderedList (Int, [Line]) -- start value, items - | UnorderedList [Line] + | OrderedList (Int, [Block]) Int -- (start value, items) level + | UnorderedList [Block] Int -- items level | Image String String -- alt src | BlockQuote [Line] | CodeBlock String diff --git a/test/HTMLHUnitTests.hs b/test/HTMLHUnitTests.hs index 0e117fe..913c923 100644 --- a/test/HTMLHUnitTests.hs +++ b/test/HTMLHUnitTests.hs @@ -107,17 +107,29 @@ test_hUlListP = "unordered list" ~: TestList [ p hUlListP "" ~?= Left "No parses", - p hUlListP "" ~?= Right (UnorderedList [S.Line [Normal "item 1"]]), - p hUlListP "dontparsethis" ~?= Right (UnorderedList [S.Line [Normal "item 1"]]), - p hUlListP "" ~?= Right (UnorderedList [S.Line [Normal "item 1"], S.Line [Normal "item 2"]]) + p hUlListP "" ~?= + Right (UnorderedList [Paragraph $ S.Line [Normal "item 1"]] 0), + p hUlListP "dontparsethis" ~?= + Right (UnorderedList [Paragraph $ S.Line [Normal "item 1"]] 0), + p hUlListP "" ~?= + Right (UnorderedList [Paragraph $ S.Line [Normal "item 1"], Paragraph $ S.Line [Normal "item 2"]] 0), + p hUlListP "" ~?= + Right (UnorderedList + [ Paragraph $ S.Line [Normal "item 1"], + OrderedList (2, [Paragraph $ S.Line [Normal "subitem 1"]]) 1 + ] + 0) ] test_hOlListP = "ordered list" ~: TestList - [ p hOlListP "
  1. item 1
" ~?= Right (OrderedList (1, [S.Line [Normal "item 1"]])), - p hOlListP "
  1. item 1
  2. item 2
" ~?= Right (OrderedList (1, [S.Line [Normal "item 1"], S.Line [Normal "item 2"]])), - p hOlListP "
  1. item 1
  2. item 2
" ~?= Right (OrderedList (11, [S.Line [Normal "item 1"], S.Line [Normal "item 2"]])) + [ p hOlListP "

  1. item 1

" ~?= + Right (OrderedList (1, [Paragraph $ S.Line [Normal "item 1"]]) 0), + p hOlListP "

  1. item 1

  2. item 2

" ~?= + Right (OrderedList (1, [Paragraph $ S.Line [Normal "item 1"], Paragraph $ S.Line [Normal "item 2"]]) 0), + p hOlListP "

  1. item 1

  2. item 2

" ~?= + Right (OrderedList (11, [Paragraph $ S.Line [Normal "item 1"], Paragraph $ S.Line [Normal "item 2"]]) 0) ] test_hImgP = diff --git a/test/MDHUnitTests.hs b/test/MDHUnitTests.hs index 5bc3156..bab9985 100644 --- a/test/MDHUnitTests.hs +++ b/test/MDHUnitTests.hs @@ -99,25 +99,54 @@ test_ulListP = "unordered list" ~: TestList [ p ulListP "-1\n" ~?= Left "No parses", - p ulListP "- item 1\n" ~?= Right (UnorderedList [S.Line [Normal "item 1"]]), - p ulListP "- item 1\ndontparsethis" ~?= Right (UnorderedList [S.Line [Normal "item 1"]]), - p ulListP "- item 1\n- item 2\n" ~?= Right (UnorderedList [S.Line [Normal "item 1"], S.Line [Normal "item 2"]]), - p ulListP "- item 1\n-item 2\n" ~?= Right (UnorderedList [S.Line [Normal "item 1"], S.Line [Normal "item 2"]]), - p ulListP "* item 1\n* item 2\n" ~?= Right (UnorderedList [S.Line [Normal "item 1"], S.Line [Normal "item 2"]]) + p ulListP "- item 1\n" ~?= + Right (UnorderedList [Paragraph $ Line [Normal "item 1"]] 0), + p ulListP "- item 1\ndontparsethis" ~?= + Right (UnorderedList [Paragraph $ Line [Normal "item 1"]] 0), + p ulListP "- item 1\n- item 2\n" ~?= + Right (UnorderedList [Paragraph $ S.Line [Normal "item 1"], Paragraph $ S.Line [Normal "item 2"]] 0), + p ulListP "- item 1\n-item 2\n" ~?= + Right (UnorderedList [Paragraph $ S.Line [Normal "item 1"], Paragraph $ S.Line [Normal "item 2"]] 0), + p ulListP "* item 1\n* item 2\n" ~?= + Right (UnorderedList [Paragraph $ S.Line [Normal "item 1"], Paragraph $ S.Line [Normal "item 2"]] 0), + p ulListP "- item 1\n\t- subitem 1\n" ~?= + Right (UnorderedList [Paragraph $ S.Line [Normal "item 1"], UnorderedList [Paragraph $ S.Line [Normal "subitem 1"]] 1] 0), + p ulListP "- item 1\n\t- subitem 1\n\t\t- subsubitem 1\n" ~?= + Right ( + UnorderedList [Paragraph $ S.Line [Normal "item 1"], + UnorderedList [Paragraph $ S.Line [Normal "subitem 1"], + UnorderedList [Paragraph $ S.Line [Normal "subsubitem 1"]] 2 + ] 1] 0), + p ulListP "- item 1\n\t- subitem 1\n- item 2\n" ~?= + Right ( + UnorderedList [ + Paragraph $ S.Line [Normal "item 1"], + UnorderedList [Paragraph $ S.Line [Normal "subitem 1"]] 1, + Paragraph $ S.Line [Normal "item 2"] + ] 0) ] test_olListP = "ordered list" ~: TestList [ p olListP "1.1" ~?= Left "No parses", - p olListP "1. item 1\n" ~?= Right (OrderedList (1, [S.Line [Normal "item 1"]])), - p olListP "1. item 1\n2. item 2\n" ~?= Right (OrderedList (1, [S.Line [Normal "item 1"], S.Line [Normal "item 2"]])), - p olListP "11. item 1\n2. item 2\n" ~?= Right (OrderedList (11, [S.Line [Normal "item 1"], S.Line [Normal "item 2"]])), + p olListP "1. item 1\n" ~?= Right (OrderedList (1, [Paragraph $ S.Line [Normal "item 1"]]) 0), + p olListP "1. item 1\n2. item 2\n" ~?= Right (OrderedList (1, [Paragraph $ S.Line [Normal "item 1"], Paragraph $ S.Line [Normal "item 2"]]) 0), + p olListP "11. item 1\n2. item 2\n" ~?= Right (OrderedList (11, [Paragraph $ S.Line [Normal "item 1"], Paragraph $ S.Line [Normal "item 2"]]) 0), p olListP "1. item 1\n2.item 2\n" ~?= Right - ( OrderedList (1, [S.Line [Normal "item 1"], S.Line [Normal "item 2"]]) + ( OrderedList (1, [Paragraph $ S.Line [Normal "item 1"], Paragraph $ S.Line [Normal "item 2"]]) 0 ) ] + -- [ p olListP "1.1" ~?= Left "No parses", + -- p olListP "1. item 1\n" ~?= Right (OrderedList (1, [S.Line [Normal "item 1"]])), + -- p olListP "1. item 1\n2. item 2\n" ~?= Right (OrderedList (1, [S.Line [Normal "item 1"], S.Line [Normal "item 2"]])), + -- p olListP "11. item 1\n2. item 2\n" ~?= Right (OrderedList (11, [S.Line [Normal "item 1"], S.Line [Normal "item 2"]])), + -- p olListP "1. item 1\n2.item 2\n" + -- ~?= Right + -- ( OrderedList (1, [S.Line [Normal "item 1"], S.Line [Normal "item 2"]]) + -- ) + -- ] test_linkP = "link" @@ -197,10 +226,10 @@ test_markdownP = "markdown doc" ~: TestList [ p markdownP "# Heading 1\n" - ~?= Right (Doc [Heading 1 (S.Line [Normal "Heading 1"])]), - p markdownP sampleText - ~?= Right - (Doc [Heading 1 (Line [Normal "Heading 1"]), Paragraph (Line [Normal "This is ", InlineCode "inline code", Normal ". "]), Paragraph (Line [Bold "bold", Normal ", ", Italic "italic", Normal ", ", Strikethrough "struckthrough"]), CodeBlock "fold :: (a -> b -> b) -> b -> [a] -> b\nfold f z [] = z\nfold f z (x:xs) = f x (fold f z xs)\n", OrderedList (3, [Line [Normal "This is a numbered list."], Line [Normal "This is the second item."], Line [Normal "This is the third item."]])]) + ~?= Right (Doc [Heading 1 (S.Line [Normal "Heading 1"])]) + -- p markdownP sampleText + -- ~?= Right + -- (Doc [Heading 1 (Line [Normal "Heading 1"]), Paragraph (Line [Normal "This is ", InlineCode "inline code", Normal ". "]), Paragraph (Line [Bold "bold", Normal ", ", Italic "italic", Normal ", ", Strikethrough "struckthrough"]), CodeBlock "fold :: (a -> b -> b) -> b -> [a] -> b\nfold f z [] = z\nfold f z (x:xs) = f x (fold f z xs)\n", OrderedList (3, [Line [Normal "This is a numbered list."], Line [Normal "This is the second item."], Line [Normal "This is the third item."]])]) ] markdownTests = diff --git a/test/QCTests.hs b/test/QCTests.hs index cd170d6..1972e71 100644 --- a/test/QCTests.hs +++ b/test/QCTests.hs @@ -109,15 +109,22 @@ instance Arbitrary Block where where genHeading = (Heading <$> choose (1, 6)) <*> arbitrary genParagraph = Paragraph <$> arbitrary - genOrderedList = OrderedList <$> Monad.liftM2 (,) ((arbitrary :: Gen Int) `QC.suchThat` (>= 0)) (QC.listOf1 arbitrary) - genUnorderedList = UnorderedList <$> QC.sized gen + genOrderedList = flip OrderedList 0 <$> Monad.liftM2 (,) ((arbitrary :: Gen Int) `QC.suchThat` (>= 0)) (QC.listOf1 genBlock') + genUnorderedList = flip UnorderedList 0 <$> QC.sized gen where - gen :: Int -> Gen [S.Line] + gen :: Int -> Gen [Block] gen n = QC.frequency - [ (1, fmap (: []) (arbitrary :: Gen S.Line)), - (n, Monad.liftM2 (:) (arbitrary :: Gen S.Line) (gen (n `div` 2))) + [ (1, fmap (: []) genBlock'), + (n, Monad.liftM2 (:) genBlock' (gen (n `div` 2))) ] + genBlock' = oneof + [ genHeading, + genParagraph, + genBlockQuote, + genHr, + genBr + ] genBlockQuote = BlockQuote <$> QC.listOf1 arbitrary genHr = pure Hr genBr = pure Br @@ -125,8 +132,8 @@ instance Arbitrary Block where shrink (Heading n ln) = Heading n <$> shrink ln shrink (Paragraph ln) = Paragraph <$> shrink ln - shrink (OrderedList (i, ln)) = [OrderedList (i, ln') | ln' <- shrink ln, not (null ln')] - shrink (UnorderedList ln) = [UnorderedList ln' | ln' <- shrink ln, not (null ln')] + shrink (OrderedList (i, ln) level) = [OrderedList (i, ln') level | ln' <- shrink ln, not (null ln')] + shrink (UnorderedList ln level) = [UnorderedList ln' level | ln' <- shrink ln, not (null ln')] shrink (Image alt src) = Image alt <$> shrink src shrink (BlockQuote ln) = [BlockQuote ln' | ln' <- shrink ln, not (null ln')] shrink (CodeBlock ln) = CodeBlock <$> shrink ln