From c31c156422785751e33c9a7a4f021ac8da77d364 Mon Sep 17 00:00:00 2001
From: Iñaki García Etxebarria <git@inaki.blueleaf.cc>
Date: Wed, 31 Jul 2019 16:28:00 +0100
Subject: Add support for labeled module references

Support a markdown-style way of annotating module references. For instance

-- | [label]("Module.Name#anchor")

will create a link that points to the same place as the module
reference "Module.Name#anchor" but the text displayed on the link will
be "label".
---
 haddock-api/src/Haddock/Backends/Hoogle.hs          |  2 +-
 haddock-api/src/Haddock/Backends/LaTeX.hs           |  7 ++++++-
 haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs | 15 ++++++++-------
 haddock-api/src/Haddock/Backends/Xhtml/Names.hs     |  9 ++++++---
 4 files changed, 21 insertions(+), 12 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends')

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 58809f73..9a304030 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -325,7 +325,7 @@ markupTag dflags = Markup {
   markupAppend               = (++),
   markupIdentifier           = box (TagInline "a") . str . out dflags,
   markupIdentifierUnchecked  = box (TagInline "a") . str . showWrapped (out dflags . snd),
-  markupModule               = box (TagInline "a") . str,
+  markupModule               = \(ModLink m label) -> box (TagInline "a") (fromMaybe (str m) label),
   markupWarning              = box (TagInline "i"),
   markupEmphasis             = box (TagInline "i"),
   markupBold                 = box (TagInline "b"),
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index df81fd6e..2371695f 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -1210,7 +1210,12 @@ latexMarkup = Markup
   , markupAppend               = \l r v -> l v . r v
   , markupIdentifier           = \i v -> inlineElem (markupId v (fmap occName i))
   , markupIdentifierUnchecked  = \i v -> inlineElem (markupId v (fmap snd i))
-  , markupModule               = \m _ -> inlineElem (let (mdl,_ref) = break (=='#') m in (tt (text mdl)))
+  , markupModule               =
+      \(ModLink m mLabel) v ->
+        case mLabel of
+          Just lbl -> inlineElem . tt $ lbl v empty
+          Nothing -> inlineElem (let (mdl,_ref) = break (=='#') m
+                                 in (tt (text mdl)))
   , markupWarning              = \p v -> p v
   , markupEmphasis             = \p v -> inlineElem (emph (p v empty))
   , markupBold                 = \p v -> inlineElem (bold (p v empty))
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
index 378d0559..7670b193 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -44,13 +44,14 @@ parHtmlMarkup qual insertAnchors ppId = Markup {
   markupAppend               = (+++),
   markupIdentifier           = thecode . ppId insertAnchors,
   markupIdentifierUnchecked  = thecode . ppUncheckedLink qual,
-  markupModule               = \m -> let (mdl,ref) = break (=='#') m
-                                         -- Accomodate for old style
-                                         -- foo\#bar anchors
-                                         mdl' = case reverse mdl of
-                                           '\\':_ -> init mdl
-                                           _ -> mdl
-                                     in ppModuleRef (mkModuleName mdl') ref,
+  markupModule               = \(ModLink m lbl) ->
+                                 let (mdl,ref) = break (=='#') m
+                                       -- Accomodate for old style
+                                       -- foo\#bar anchors
+                                     mdl' = case reverse mdl of
+                                              '\\':_ -> init mdl
+                                              _ -> mdl
+                                 in ppModuleRef lbl (mkModuleName mdl') ref,
   markupWarning              = thediv ! [theclass "warning"],
   markupEmphasis             = emphasize,
   markupBold                 = strong,
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
index 8553cdfb..b324fa38 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
@@ -186,9 +186,12 @@ ppModule mdl = anchor ! [href (moduleUrl mdl)]
                << toHtml (moduleString mdl)
 
 
-ppModuleRef :: ModuleName -> String -> Html
-ppModuleRef mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)]
-                      << toHtml (moduleNameString mdl)
+ppModuleRef :: Maybe Html -> ModuleName -> String -> Html
+ppModuleRef Nothing mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)]
+                              << toHtml (moduleNameString mdl)
+ppModuleRef (Just lbl) mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)]
+                                 << lbl
+
     -- NB: The ref parameter already includes the '#'.
     -- This function is only called from markupModule expanding a
     -- DocModule, which doesn't seem to be ever be used.
-- 
cgit v1.2.3