From 35c99f595c984f58d2fb4dc180c48a0eaf7df173 Mon Sep 17 00:00:00 2001 From: Ben Simms Date: Tue, 3 May 2022 13:19:24 +0100 Subject: Keep track of ordered list indexes and render them (#1407) * Keep track of ordered list indexes and render them * Rename some identifiers to clarify --- haddock-api/src/Haddock/Backends/Hoogle.hs | 2 +- haddock-api/src/Haddock/Backends/LaTeX.hs | 2 +- .../src/Haddock/Backends/Xhtml/DocMarkup.hs | 7 ++-- haddock-api/src/Haddock/Interface/Json.hs | 4 ++- haddock-api/src/Haddock/Interface/LexParseRn.hs | 6 +++- .../src/Documentation/Haddock/Markup.hs | 2 +- .../src/Documentation/Haddock/Parser.hs | 18 ++++++++-- haddock-library/src/Documentation/Haddock/Types.hs | 11 ++++--- .../test/Documentation/Haddock/ParserSpec.hs | 38 +++++++++++----------- html-test/ref/Bug313.html | 12 +++---- html-test/ref/Nesting.html | 8 ++--- html-test/ref/Test.html | 4 +-- 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 "", markupMathDisplay = const $ str "", 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 @@ >

Some text.

  2. Item 1

  4. Item 2

    Some code
  6. Item 3

Some text.

  2. Item 1

  4. Item 2

    Some code
  6. Item 3

easily go back

  2. some indentation
  2. back at the top

    3. Even more content on a new line.

    2. Different type of list

      2. Deeper
      This is the next item (different kind of bullet)
      2. This is an ordered list
      4. This is the next item (different kind of bullet)