Keep track of ordered list indexes and render them (#1407)

* Keep track of ordered list indexes and render them

* Rename some identifiers to clarify

3 files changed, 23 insertions, 8 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