diff options
Diffstat (limited to 'haddock-api/src/Haddock')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hoogle.hs | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/LaTeX.hs | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs | 7 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Json.hs | 4 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/LexParseRn.hs | 6 |
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) |