aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src
diff options
context:
space:
mode:
authorBen Simms <ben@bensimms.moe>2022-05-03 13:19:24 +0100
committerGitHub <noreply@github.com>2022-05-03 14:19:24 +0200
commit35c99f595c984f58d2fb4dc180c48a0eaf7df173 (patch)
treebae92ed5970738d031ef4fb84dc571c037e2ec40 /haddock-api/src
parentbc0f2d6c1bfd331a9426fa9a92288444178267b1 (diff)
Keep track of ordered list indexes and render them (#1407)
* Keep track of ordered list indexes and render them * Rename some identifiers to clarify
Diffstat (limited to 'haddock-api/src')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs7
-rw-r--r--haddock-api/src/Haddock/Interface/Json.hs4
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs6
5 files changed, 15 insertions, 6 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)