aboutsummaryrefslogtreecommitdiff
path: root/haddock-library
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-library')
-rw-r--r--haddock-library/src/Documentation/Haddock/Markup.hs2
-rw-r--r--haddock-library/src/Documentation/Haddock/Parser.hs18
-rw-r--r--haddock-library/src/Documentation/Haddock/Types.hs11
-rw-r--r--haddock-library/test/Documentation/Haddock/ParserSpec.hs38
4 files changed, 42 insertions, 27 deletions
diff --git a/haddock-library/src/Documentation/Haddock/Markup.hs b/haddock-library/src/Documentation/Haddock/Markup.hs
index 0919737f..28c5c2ca 100644
--- a/haddock-library/src/Documentation/Haddock/Markup.hs
+++ b/haddock-library/src/Documentation/Haddock/Markup.hs
@@ -22,7 +22,7 @@ markup m (DocEmphasis d) = markupEmphasis m (markup m d)
markup m (DocBold d) = markupBold m (markup m d)
markup m (DocMonospaced d) = markupMonospaced m (markup m d)
markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds)
-markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds)
+markup m (DocOrderedList ds) = markupOrderedList m (map (\(index, a) -> (index, markup m a)) ds)
markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds)
markup m (DocCodeBlock d) = markupCodeBlock m (markup m d)
markup m (DocHyperlink (Hyperlink u l)) = markupHyperlink m (Hyperlink u (fmap (markup m) l))
diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs
index c6d7e59b..19c92721 100644
--- a/haddock-library/src/Documentation/Haddock/Parser.hs
+++ b/haddock-library/src/Documentation/Haddock/Parser.hs
@@ -78,7 +78,7 @@ overIdentifier f d = g d
g (DocMonospaced x) = DocMonospaced $ g x
g (DocBold x) = DocBold $ g x
g (DocUnorderedList x) = DocUnorderedList $ fmap g x
- g (DocOrderedList x) = DocOrderedList $ fmap g x
+ g (DocOrderedList x) = DocOrderedList $ fmap (\(index, a) -> (index, g a)) x
g (DocDefList x) = DocDefList $ fmap (\(y, z) -> (g y, g z)) x
g (DocCodeBlock x) = DocCodeBlock $ g x
g (DocHyperlink (Hyperlink u x)) = DocHyperlink (Hyperlink u (fmap g x))
@@ -577,10 +577,24 @@ unorderedList indent = DocUnorderedList <$> p
orderedList :: Text -> Parser (DocH mod Identifier)
orderedList indent = DocOrderedList <$> p
where
- p = (paren <|> dot) *> innerList indent p
+ p = do
+ index <- paren <|> dot
+ innerList' indent p index
dot = (decimal :: Parser Int) <* "."
paren = "(" *> decimal <* ")"
+-- | Like 'innerList' but takes the parsed index of the list item
+innerList' :: Text -> Parser [(Int, DocH mod Identifier)]
+ -> Int
+ -> Parser [(Int, DocH mod Identifier)]
+innerList' indent item index = do
+ c <- takeLine
+ (cs, items) <- more indent item
+ let contents = docParagraph . parseText . dropNLs . T.unlines $ c : cs
+ return $ case items of
+ Left p -> [(index, contents `docAppend` p)]
+ Right i -> (index, contents) : i
+
-- | Generic function collecting any further lines belonging to the
-- list entry and recursively collecting any further lists in the
-- same paragraph. Usually used as
diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs
index 22516864..d72ab4b4 100644
--- a/haddock-library/src/Documentation/Haddock/Types.hs
+++ b/haddock-library/src/Documentation/Haddock/Types.hs
@@ -124,7 +124,7 @@ data DocH mod id
| DocMonospaced (DocH mod id)
| DocBold (DocH mod id)
| DocUnorderedList [DocH mod id]
- | DocOrderedList [DocH mod id]
+ | DocOrderedList [(Int, DocH mod id)]
| DocDefList [(DocH mod id, DocH mod id)]
| DocCodeBlock (DocH mod id)
| DocHyperlink (Hyperlink (DocH mod id))
@@ -154,7 +154,7 @@ instance Bifunctor DocH where
bimap f g (DocMonospaced doc) = DocMonospaced (bimap f g doc)
bimap f g (DocBold doc) = DocBold (bimap f g doc)
bimap f g (DocUnorderedList docs) = DocUnorderedList (map (bimap f g) docs)
- bimap f g (DocOrderedList docs) = DocOrderedList (map (bimap f g) docs)
+ bimap f g (DocOrderedList docs) = DocOrderedList (map (\(index, a) -> (index, bimap f g a)) docs)
bimap f g (DocDefList docs) = DocDefList (map (bimap f g *** bimap f g) docs)
bimap f g (DocCodeBlock doc) = DocCodeBlock (bimap f g doc)
bimap f g (DocHyperlink (Hyperlink url lbl)) = DocHyperlink (Hyperlink url (fmap (bimap f g) lbl))
@@ -180,7 +180,7 @@ instance Bifoldable DocH where
bifoldr f g z (DocMonospaced doc) = bifoldr f g z doc
bifoldr f g z (DocBold doc) = bifoldr f g z doc
bifoldr f g z (DocUnorderedList docs) = foldr (flip (bifoldr f g)) z docs
- bifoldr f g z (DocOrderedList docs) = foldr (flip (bifoldr f g)) z docs
+ bifoldr f g z (DocOrderedList docs) = foldr (flip (bifoldr f g)) z (map snd docs)
bifoldr f g z (DocDefList docs) = foldr (\(l, r) acc -> bifoldr f g (bifoldr f g acc l) r) z docs
bifoldr f g z (DocCodeBlock doc) = bifoldr f g z doc
bifoldr f g z (DocHeader (Header _ title)) = bifoldr f g z title
@@ -201,7 +201,8 @@ instance Bitraversable DocH where
bitraverse f g (DocMonospaced doc) = DocMonospaced <$> bitraverse f g doc
bitraverse f g (DocBold doc) = DocBold <$> bitraverse f g doc
bitraverse f g (DocUnorderedList docs) = DocUnorderedList <$> traverse (bitraverse f g) docs
- bitraverse f g (DocOrderedList docs) = DocOrderedList <$> traverse (bitraverse f g) docs
+ bitraverse f g (DocOrderedList docs) = DocOrderedList <$> traverseSnd (bitraverse f g) docs
+ where traverseSnd f' = traverse (\(x, a) -> (\b -> (x, b)) <$> f' a)
bitraverse f g (DocDefList docs) = DocDefList <$> traverse (bitraverse (bitraverse f g) (bitraverse f g)) docs
bitraverse f g (DocCodeBlock doc) = DocCodeBlock <$> bitraverse f g doc
bitraverse f g (DocHyperlink (Hyperlink url lbl)) = DocHyperlink <$> (Hyperlink url <$> traverse (bitraverse f g) lbl)
@@ -246,7 +247,7 @@ data DocMarkupH mod id a = Markup
, markupBold :: a -> a
, markupMonospaced :: a -> a
, markupUnorderedList :: [a] -> a
- , markupOrderedList :: [a] -> a
+ , markupOrderedList :: [(Int,a)] -> a
, markupDefList :: [(a,a)] -> a
, markupCodeBlock :: a -> a
, markupHyperlink :: Hyperlink a -> a
diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs
index 9cf7c537..6e700050 100644
--- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs
+++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs
@@ -820,7 +820,7 @@ spec = do
it "can nest another type of list inside" $ do
"* foo\n\n 1. bar" `shouldParseTo`
DocUnorderedList [ DocParagraph "foo"
- <> DocOrderedList [DocParagraph "bar"]]
+ <> DocOrderedList [(1, DocParagraph "bar")]]
it "can nest a code block inside" $ do
"* foo\n\n @foo bar baz@" `shouldParseTo`
@@ -859,7 +859,7 @@ spec = do
DocUnorderedList [ DocParagraph "foo"
<> DocUnorderedList [ DocParagraph "bar" ]
]
- <> DocOrderedList [ DocParagraph "baz" ]
+ <> DocOrderedList [ (1, DocParagraph "baz") ]
it "allows arbitrary initial indent of a list" $ do
unlines
@@ -883,20 +883,20 @@ spec = do
DocDefList [ ("foo", "foov"
<> DocDefList [ ("bar", "barv") ])
]
- <> DocOrderedList [ DocParagraph "baz" ]
+ <> DocOrderedList [ (1, DocParagraph "baz") ]
it "list order is preserved in presence of nesting + extra text" $ do
"1. Foo\n\n > Some code\n\n2. Bar\n\nSome text"
`shouldParseTo`
- DocOrderedList [ DocParagraph "Foo" <> DocCodeBlock "Some code"
- , DocParagraph "Bar"
+ DocOrderedList [ (1, DocParagraph "Foo" <> DocCodeBlock "Some code")
+ , (2, DocParagraph "Bar")
]
<> DocParagraph (DocString "Some text")
"1. Foo\n\n2. Bar\n\nSome text"
`shouldParseTo`
- DocOrderedList [ DocParagraph "Foo"
- , DocParagraph "Bar"
+ DocOrderedList [ (1, DocParagraph "Foo")
+ , (2, DocParagraph "Bar")
]
<> DocParagraph (DocString "Some text")
@@ -980,9 +980,9 @@ spec = do
, " 3. three"
]
`shouldParseTo` DocOrderedList [
- DocParagraph "one"
- , DocParagraph "two"
- , DocParagraph "three"
+ (1, DocParagraph "one")
+ , (1, DocParagraph "two")
+ , (3, DocParagraph "three")
]
it "ignores empty lines between list items" $ do
@@ -992,12 +992,12 @@ spec = do
, "2. two"
]
`shouldParseTo` DocOrderedList [
- DocParagraph "one"
- , DocParagraph "two"
+ (1, DocParagraph "one")
+ , (2, DocParagraph "two")
]
it "accepts an empty list item" $ do
- "1." `shouldParseTo` DocOrderedList [DocParagraph DocEmpty]
+ "1." `shouldParseTo` DocOrderedList [(1, DocParagraph DocEmpty)]
it "accepts multi-line list items" $ do
unlines [
@@ -1007,12 +1007,12 @@ spec = do
, "more two"
]
`shouldParseTo` DocOrderedList [
- DocParagraph "point one\n more one"
- , DocParagraph "point two\nmore two"
+ (1, DocParagraph "point one\n more one")
+ , (1, DocParagraph "point two\nmore two")
]
it "accepts markup in list items" $ do
- "1. /foo/" `shouldParseTo` DocOrderedList [DocParagraph (DocEmphasis "foo")]
+ "1. /foo/" `shouldParseTo` DocOrderedList [(1, DocParagraph (DocEmphasis "foo"))]
it "requires empty lines between list and other paragraphs" $ do
unlines [
@@ -1022,7 +1022,7 @@ spec = do
, ""
, "baz"
]
- `shouldParseTo` DocParagraph "foo" <> DocOrderedList [DocParagraph "bar"] <> DocParagraph "baz"
+ `shouldParseTo` DocParagraph "foo" <> DocOrderedList [(1, DocParagraph "bar")] <> DocParagraph "baz"
context "when parsing definition lists" $ do
it "parses a simple list" $ do
@@ -1109,8 +1109,8 @@ spec = do
] `shouldParseTo`
DocUnorderedList [ DocParagraph "bullet"
, DocParagraph "different bullet"]
- <> DocOrderedList [ DocParagraph "ordered"
- , DocParagraph "different bullet"
+ <> DocOrderedList [ (1, DocParagraph "ordered")
+ , (2, DocParagraph "different bullet")
]
<> DocDefList [ ("cat", "kitten")
, ("pineapple", "fruit")