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

* Keep track of ordered list indexes and render them

* Rename some identifiers to clarify

12 files changed, 69 insertions, 45 deletions

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 7e10426a..9e39d98d 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -353,7 +353,7 @@ markupTag dflags = Markup {
   markupMathInline           = const $ str "<math>",
   markupMathDisplay          = const $ str "<math>",
   markupUnorderedList        = box (TagL 'u'),
-  markupOrderedList          = box (TagL 'o'),
+  markupOrderedList          = box (TagL 'o') . map snd,
   markupDefList              = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b),
   markupCodeBlock            = box TagPre,
   markupHyperlink            = \(Hyperlink url mLabel) -> box (TagInline "a") (fromMaybe (str url) mLabel),
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 7d019d6e..b045fa90 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -1260,7 +1260,7 @@ latexMarkup = Markup
   , markupPic                  = \p _ -> inlineElem (markupPic p)
   , markupMathInline           = \p _ -> inlineElem (markupMathInline p)
   , markupMathDisplay          = \p _ -> blockElem (markupMathDisplay p)
-  , markupOrderedList          = \p v -> blockElem (enumeratedList (map (\p' -> p' v empty) p))
+  , markupOrderedList          = \p v -> blockElem (enumeratedList (map (\(_, p') -> p' v empty) p))
   , markupDefList              = \l v -> blockElem (descriptionList (map (\(a,b) -> (a v empty, b v empty)) l))
   , markupCodeBlock            = \p _ -> blockElem (quote (verb (p Verb empty)))
   , markupHyperlink            = \(Hyperlink u l) v -> inlineElem (markupLink u (fmap (\x -> x v empty) l))
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
index 02d6dafd..91a5b120 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -57,7 +57,7 @@ parHtmlMarkup qual insertAnchors ppId = Markup {
   markupBold                 = strong,
   markupMonospaced           = thecode,
   markupUnorderedList        = unordList,
-  markupOrderedList          = ordList,
+  markupOrderedList          = makeOrdList,
   markupDefList              = defList,
   markupCodeBlock            = pre,
   markupHyperlink            = \(Hyperlink url mLabel)
@@ -112,6 +112,9 @@ parHtmlMarkup qual insertAnchors ppId = Markup {
         htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"]
         htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"]
 
+    makeOrdList :: HTML a => [(Int, a)] -> Html
+    makeOrdList items = olist << map (\(index, a) -> li ! [intAttr "value" index] << a) items
+
 -- | We use this intermediate type to transform the input 'Doc' tree
 -- in an arbitrary way before rendering, such as grouping some
 -- elements. This is effectively a hack to prevent the 'Doc' type
@@ -277,5 +280,5 @@ cleanup = overDoc (markup fmtUnParagraphLists)
     fmtUnParagraphLists :: DocMarkup (Wrap a) (Doc a)
     fmtUnParagraphLists = idMarkup {
       markupUnorderedList = DocUnorderedList . map unParagraph,
-      markupOrderedList   = DocOrderedList   . map unParagraph
+      markupOrderedList   = DocOrderedList   . map (\(index, a) -> (index, unParagraph a))
       }
diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs
index 92fb2e75..8b27a982 100644
--- a/haddock-api/src/Haddock/Interface/Json.hs
+++ b/haddock-api/src/Haddock/Interface/Json.hs
@@ -130,8 +130,10 @@ jsonDoc (DocUnorderedList xs) = jsonObject
 
 jsonDoc (DocOrderedList xs) = jsonObject
     [ ("tag", jsonString "DocOrderedList")
-    , ("documents", jsonArray (fmap jsonDoc xs))
+    , ("items", jsonArray (fmap jsonItem xs))
     ]
+  where
+    jsonItem (index, a) = jsonObject [("document", jsonDoc a), ("seq", jsonInt index)]
 
 jsonDoc (DocDefList xys) = jsonObject
     [ ("tag", jsonString "DocDefList")
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 14e1d92b..d769f0cc 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -84,6 +84,10 @@ processModuleHeader dflags pkgName gre safety mayStr = do
   where
     failure = (emptyHaddockModInfo, Nothing)
 
+traverseSnd :: (Traversable t, Applicative f) => (a -> f b) -> t (x, a) -> f (t (x, b))
+traverseSnd f = traverse (\(x, a) ->
+                             (\b -> (x, b)) <$> f a)
+
 -- | Takes a 'GlobalRdrEnv' which (hopefully) contains all the
 -- definitions and a parsed comment and we attempt to make sense of
 -- where the identifiers in the comment point to. We're in effect
@@ -146,7 +150,7 @@ rename dflags gre = rn
       DocBold doc -> DocBold <$> rn doc
       DocMonospaced doc -> DocMonospaced <$> rn doc
       DocUnorderedList docs -> DocUnorderedList <$> traverse rn docs
-      DocOrderedList docs -> DocOrderedList <$> traverse rn docs
+      DocOrderedList docs -> DocOrderedList <$> traverseSnd rn docs
       DocDefList list -> DocDefList <$> traverse (\(a, b) -> (,) <$> rn a <*> rn b) list
       DocCodeBlock doc -> DocCodeBlock <$> rn doc
       DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x)
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")
diff --git a/html-test/ref/Bug313.html b/html-test/ref/Bug313.html
index 9bb1e176..44a970b7 100644
--- a/html-test/ref/Bug313.html
+++ b/html-test/ref/Bug313.html
@@ -91,15 +91,15 @@
 	  ><p
 	    >Some text.</p
 	    ><ol
-	    ><li
+	    ><li value="1"
 	      >Item 1</li
-	      ><li
+	      ><li value="2"
 	      ><p
 		>Item 2</p
 		><pre
 		>Some code</pre
 		></li
-	      ><li
+	      ><li value="3"
 	      >Item 3</li
 	      ></ol
 	    ><p
@@ -117,15 +117,15 @@
 	  ><p
 	    >Some text.</p
 	    ><ol
-	    ><li
+	    ><li value="1"
 	      >Item 1</li
-	      ><li
+	      ><li value="2"
 	      ><p
 		>Item 2</p
 		><pre
 		>Some code</pre
 		></li
-	      ><li
+	      ><li value="3"
 	      >Item 3</li
 	      ></ol
 	    ><p
diff --git a/html-test/ref/Nesting.html b/html-test/ref/Nesting.html
index 59111338..5af30a4b 100644
--- a/html-test/ref/Nesting.html
+++ b/html-test/ref/Nesting.html
@@ -108,7 +108,7 @@
 		  ><p
 		    >easily go back</p
 		    ><ol
-		    ><li
+		    ><li value="1"
 		      >some indentation</li
 		      ></ol
 		    ></li
@@ -118,7 +118,7 @@
 		></li
 	      ></ul
 	    ><ol
-	    ><li
+	    ><li value="1"
 	      ><pre
 		>back at the top</pre
 		></li
@@ -285,11 +285,11 @@ with more of the indented list content.</p
 		    ><p
 		    >Even more content on a new line.</p
 		    ><ol
-		    ><li
+		    ><li value="1"
 		      ><p
 			>Different type of list</p
 			><ol
-			><li
+			><li value="2"
 			  >Deeper</li
 			  ></ol
 			><pre class="screen"
diff --git a/html-test/ref/Test.html b/html-test/ref/Test.html
index 10540c93..a4fdb391 100644
--- a/html-test/ref/Test.html
+++ b/html-test/ref/Test.html
@@ -1884,9 +1884,9 @@ using double quotes: <a href="#"
 	      >This is the next item (different kind of bullet)</li
 	      ></ul
 	    ><ol
-	    ><li
+	    ><li value="1"
 	      >This is an ordered list</li
-	      ><li
+	      ><li value="2"
 	      >This is the next item (different kind of bullet)</li
 	      ></ol
 	    ><dl