From 2d6ec6b9e27f68b21794fdee69767da64b5493b5 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?I=C3=B1aki=20Garc=C3=ADa=20Etxebarria?=
 <git@inaki.blueleaf.cc>
Date: Wed, 31 Jul 2019 16:28:00 +0100
Subject: [PATCH 1/3] 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".
---
 doc/markup.rst                                |  5 ++
 haddock-api/src/Haddock/Backends/Hoogle.hs    |  2 +-
 haddock-api/src/Haddock/Backends/LaTeX.hs     |  7 +-
 .../src/Haddock/Backends/Xhtml/DocMarkup.hs   | 15 ++--
 .../src/Haddock/Backends/Xhtml/Names.hs       |  9 +-
 .../src/Haddock/Interface/LexParseRn.hs       |  2 +-
 haddock-api/src/Haddock/InterfaceFile.hs      | 11 ++-
 haddock-api/src/Haddock/Types.hs              |  3 +
 haddock-library/fixtures/Fixtures.hs          |  3 +
 .../src/Documentation/Haddock/Markup.hs       |  4 +-
 .../src/Documentation/Haddock/Parser.hs       | 63 ++++++++++----
 .../src/Documentation/Haddock/Types.hs        | 14 +++-
 .../test/Documentation/Haddock/ParserSpec.hs  | 82 +++++++++++++++++--
 13 files changed, 178 insertions(+), 42 deletions(-)

diff --git a/doc/markup.rst b/doc/markup.rst
index 56238855cc..50851c1171 100644
--- a/doc/markup.rst
+++ b/doc/markup.rst
@@ -968,6 +968,11 @@ is valid before turning it into a link but unlike with identifiers,
 whether the module is in scope isn't checked and will always be turned
 into a link.
 
+It is also possible to specify alternate text for the generated link
+using syntax analogous to that used for URLs: ::
+
+  -- | This is a reference to [the main module]("Module.Main").
+
 Itemized and Enumerated Lists
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 149f48159c..63c5bba553 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -336,7 +336,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 c62a931104..570c31612a 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -1202,7 +1202,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 1901cf05f7..2bac3471ad 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 6a0477478e..9729e8ad34 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.
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 0b40ed3cde..ef8c565843 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -148,7 +148,7 @@ rename dflags gre = rn
       DocDefList list -> DocDefList <$> traverse (\(a, b) -> (,) <$> rn a <*> rn b) list
       DocCodeBlock doc -> DocCodeBlock <$> rn doc
       DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x)
-      DocModule str -> pure (DocModule str)
+      DocModule (ModLink m l) -> DocModule . ModLink m <$> traverse rn l
       DocHyperlink (Hyperlink u l) -> DocHyperlink . Hyperlink u <$> traverse rn l
       DocPic str -> pure (DocPic str)
       DocMathInline str -> pure (DocMathInline str)
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 7645b1bbc8..7761aa00d0 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -83,7 +83,7 @@ binaryInterfaceMagic = 0xD0Cface
 --
 binaryInterfaceVersion :: Word16
 #if (__GLASGOW_HASKELL__ >= 807) && (__GLASGOW_HASKELL__ < 809)
-binaryInterfaceVersion = 35
+binaryInterfaceVersion = 36
 
 binaryInterfaceVersionCompatibility :: [Word16]
 binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
@@ -443,6 +443,15 @@ instance Binary a => Binary (Hyperlink a) where
         label <- get bh
         return (Hyperlink url label)
 
+instance Binary a => Binary (ModLink a) where
+    put_ bh (ModLink m label) = do
+        put_ bh m
+        put_ bh label
+    get bh = do
+        m <- get bh
+        label <- get bh
+        return (ModLink m label)
+
 instance Binary Picture where
     put_ bh (Picture uri title) = do
         put_ bh uri
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index a72247e62d..365284b6a0 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -498,6 +498,9 @@ instance NFData id => NFData (Header id) where
 instance NFData id => NFData (Hyperlink id) where
   rnf (Hyperlink a b) = a `deepseq` b `deepseq` ()
 
+instance NFData id => NFData (ModLink id) where
+  rnf (ModLink a b) = a `deepseq` b `deepseq` ()
+
 instance NFData Picture where
   rnf (Picture a b) = a `deepseq` b `deepseq` ()
 
diff --git a/haddock-library/fixtures/Fixtures.hs b/haddock-library/fixtures/Fixtures.hs
index 72ea85253a..101bce65d9 100644
--- a/haddock-library/fixtures/Fixtures.hs
+++ b/haddock-library/fixtures/Fixtures.hs
@@ -149,6 +149,9 @@ instance ToExpr id => ToExpr (Header id)
 deriving instance Generic (Hyperlink id)
 instance ToExpr id => ToExpr (Hyperlink id)
 
+deriving instance Generic (ModLink id)
+instance ToExpr id => ToExpr (ModLink id)
+
 deriving instance Generic Picture
 instance ToExpr Picture
 
diff --git a/haddock-library/src/Documentation/Haddock/Markup.hs b/haddock-library/src/Documentation/Haddock/Markup.hs
index 365041eed9..0919737f44 100644
--- a/haddock-library/src/Documentation/Haddock/Markup.hs
+++ b/haddock-library/src/Documentation/Haddock/Markup.hs
@@ -16,7 +16,7 @@ markup m (DocString s)                  = markupString m s
 markup m (DocParagraph d)               = markupParagraph m (markup m d)
 markup m (DocIdentifier x)              = markupIdentifier m x
 markup m (DocIdentifierUnchecked x)     = markupIdentifierUnchecked m x
-markup m (DocModule mod0)               = markupModule m mod0
+markup m (DocModule (ModLink mo l))     = markupModule m (ModLink mo (fmap (markup m) l))
 markup m (DocWarning d)                 = markupWarning m (markup m d)
 markup m (DocEmphasis d)                = markupEmphasis m (markup m d)
 markup m (DocBold d)                    = markupBold m (markup m d)
@@ -78,7 +78,7 @@ plainMarkup plainMod plainIdent = Markup {
   markupAppend               = (++),
   markupIdentifier           = plainIdent,
   markupIdentifierUnchecked  = plainMod,
-  markupModule               = id,
+  markupModule               = \(ModLink m lbl) -> fromMaybe m lbl,
   markupWarning              = id,
   markupEmphasis             = id,
   markupBold                 = id,
diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs
index 36c8bb5b3c..616546a2bb 100644
--- a/haddock-library/src/Documentation/Haddock/Parser.hs
+++ b/haddock-library/src/Documentation/Haddock/Parser.hs
@@ -73,7 +73,7 @@ overIdentifier f d = g d
     g (DocString x) = DocString x
     g (DocParagraph x) = DocParagraph $ g x
     g (DocIdentifierUnchecked x) = DocIdentifierUnchecked x
-    g (DocModule x) = DocModule x
+    g (DocModule (ModLink m x)) = DocModule (ModLink m (fmap g x))
     g (DocWarning x) = DocWarning $ g x
     g (DocEmphasis x) = DocEmphasis $ g x
     g (DocMonospaced x) = DocMonospaced $ g x
@@ -149,6 +149,7 @@ parseParagraph = snd . parse p
                                     , mathDisplay
                                     , mathInline
                                     , markdownImage
+                                    , markdownLink
                                     , hyperlink
                                     , bold
                                     , emphasis
@@ -243,12 +244,45 @@ monospace = DocMonospaced . parseParagraph
 -- Note that we allow '#' and '\' to support anchors (old style anchors are of
 -- the form "SomeModule\#anchor").
 moduleName :: Parser (DocH mod a)
-moduleName = DocModule <$> ("\"" *> modid <* "\"")
+moduleName = DocModule . flip ModLink Nothing <$> ("\"" *> moduleNameWithAnchor <* "\"")
+
+-- | A labeled link to an indentifier, module or url using markdown
+-- syntax.
+markdownLink :: Parser (DocH mod Identifier)
+markdownLink = do
+  lbl <- markdownLinkText
+  choice' [ markdownModuleName lbl, markdownURL lbl ]
   where
-    modid = intercalate "." <$> conid `Parsec.sepBy1` "."
+    markdownModuleName lbl = do
+      mn <- "(" *> skipHorizontalSpace *>
+            "\"" *> moduleNameWithAnchor <* "\""
+            <* skipHorizontalSpace <* ")"
+      pure $ DocModule (ModLink mn (Just lbl))
+
+    markdownURL lbl = do
+      target <- markdownLinkTarget
+      pure $ DocHyperlink $ Hyperlink target (Just lbl)
+
+-- | A module name, optionally with an anchor
+--
+moduleNameWithAnchor :: Parser String
+moduleNameWithAnchor = do
+  m <- modName
+  maybeAnchor <- Parsec.optionMaybe $ try $ do
+    hash <- string "#" <|> string "\\#"
+    an <- Parsec.many1 (conChar <|> Parsec.char ':')
+    return $ T.unpack hash ++ an
+  return $ case maybeAnchor of
+             Nothing -> m
+             Just l -> m ++ l
+  where
+    modName :: Parser String
+    modName = intercalate "." <$> conid `Parsec.sepBy1` "."
+
+    conid :: Parser String
     conid = (:)
       <$> Parsec.satisfy (\c -> isAlpha c && isUpper c)
-      <*> many (conChar <|> Parsec.oneOf "\\#")
+      <*> many conChar
 
     conChar = Parsec.alphaNum <|> Parsec.char '_'
 
@@ -285,9 +319,11 @@ mathDisplay = DocMathDisplay . T.unpack
 -- >>> parseString "![some /emphasis/ in a description](www.site.com)"
 -- DocPic (Picture "www.site.com" (Just "some emphasis in a description"))
 markdownImage :: Parser (DocH mod Identifier)
-markdownImage = DocPic . fromHyperlink <$> ("!" *> linkParser)
+markdownImage = do
+  text <- markup stringMarkup <$> ("!" *> markdownLinkText)
+  url <- markdownLinkTarget
+  pure $ DocPic (Picture url (Just text))
   where
-    fromHyperlink (Hyperlink u l) = Picture u (fmap (markup stringMarkup) l)
     stringMarkup = plainMarkup (const "") renderIdent
     renderIdent (Identifier ns l c r) = renderNs ns <> [l] <> c <> [r]
 
@@ -767,22 +803,21 @@ codeblock =
           | otherwise = Just $ c == '\n'
 
 hyperlink :: Parser (DocH mod Identifier)
-hyperlink = choice' [ angleBracketLink, markdownLink, autoUrl ]
+hyperlink = choice' [ angleBracketLink, autoUrl ]
 
 angleBracketLink :: Parser (DocH mod a)
 angleBracketLink =
     DocHyperlink . makeLabeled (\s -> Hyperlink s . fmap DocString)
     <$> disallowNewline ("<" *> takeUntil ">")
 
-markdownLink :: Parser (DocH mod Identifier)
-markdownLink = DocHyperlink <$> linkParser
+-- | The text for a markdown link, enclosed in square brackets.
+markdownLinkText :: Parser (DocH mod Identifier)
+markdownLinkText = parseParagraph . T.strip <$> ("[" *> takeUntil "]")
 
-linkParser :: Parser (Hyperlink (DocH mod Identifier))
-linkParser = flip Hyperlink <$> label <*> (whitespace *> url)
+-- | The target for a markdown link, enclosed in parenthesis.
+markdownLinkTarget :: Parser String
+markdownLinkTarget = whitespace *> url
   where
-    label :: Parser (Maybe (DocH mod Identifier))
-    label = Just . parseParagraph . T.strip <$> ("[" *> takeUntil "]")
-
     whitespace :: Parser ()
     whitespace = skipHorizontalSpace <* optional ("\n" *> skipHorizontalSpace)
 
diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs
index ba2f873c36..91d71369b6 100644
--- a/haddock-library/src/Documentation/Haddock/Types.hs
+++ b/haddock-library/src/Documentation/Haddock/Types.hs
@@ -70,6 +70,11 @@ data Hyperlink id = Hyperlink
   , hyperlinkLabel :: Maybe id
   } deriving (Eq, Show, Functor, Foldable, Traversable)
 
+data ModLink id = ModLink
+  { modLinkName   :: String
+  , modLinkLabel :: Maybe id
+  } deriving (Eq, Show, Functor, Foldable, Traversable)
+
 data Picture = Picture
   { pictureUri   :: String
   , pictureTitle :: Maybe String
@@ -108,7 +113,8 @@ data DocH mod id
   | DocIdentifier id
   | DocIdentifierUnchecked mod
   -- ^ A qualified identifier that couldn't be resolved.
-  | DocModule String
+  | DocModule (ModLink (DocH mod id))
+  -- ^ A link to a module, with an optional label.
   | DocWarning (DocH mod id)
   -- ^ This constructor has no counterpart in Haddock markup.
   | DocEmphasis (DocH mod id)
@@ -138,7 +144,7 @@ instance Bifunctor DocH where
   bimap f g (DocParagraph doc) = DocParagraph (bimap f g doc)
   bimap _ g (DocIdentifier i) = DocIdentifier (g i)
   bimap f _ (DocIdentifierUnchecked m) = DocIdentifierUnchecked (f m)
-  bimap _ _ (DocModule s) = DocModule s
+  bimap f g (DocModule (ModLink m lbl)) = DocModule (ModLink m (fmap (bimap f g) lbl))
   bimap f g (DocWarning doc) = DocWarning (bimap f g doc)
   bimap f g (DocEmphasis doc) = DocEmphasis (bimap f g doc)
   bimap f g (DocMonospaced doc) = DocMonospaced (bimap f g doc)
@@ -183,7 +189,7 @@ instance Bitraversable DocH where
   bitraverse f g (DocParagraph doc) = DocParagraph <$> bitraverse f g doc
   bitraverse _ g (DocIdentifier i) = DocIdentifier <$> g i
   bitraverse f _ (DocIdentifierUnchecked m) = DocIdentifierUnchecked <$> f m
-  bitraverse _ _ (DocModule s) = pure (DocModule s)
+  bitraverse f g (DocModule (ModLink m lbl)) = DocModule <$> (ModLink m <$> traverse (bitraverse f g) lbl)
   bitraverse f g (DocWarning doc) = DocWarning <$> bitraverse f g doc
   bitraverse f g (DocEmphasis doc) = DocEmphasis <$> bitraverse f g doc
   bitraverse f g (DocMonospaced doc) = DocMonospaced <$> bitraverse f g doc
@@ -228,7 +234,7 @@ data DocMarkupH mod id a = Markup
   , markupAppend               :: a -> a -> a
   , markupIdentifier           :: id -> a
   , markupIdentifierUnchecked  :: mod -> a
-  , markupModule               :: String -> a
+  , markupModule               :: ModLink a -> a
   , markupWarning              :: a -> a
   , markupEmphasis             :: a -> a
   , markupBold                 :: a -> a
diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs
index bc40a0a23b..95b68eebb7 100644
--- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs
+++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs
@@ -397,20 +397,20 @@ spec = do
     context "when parsing module strings" $ do
       it "should parse a module on its own" $ do
         "\"Module\"" `shouldParseTo`
-          DocModule "Module"
+          DocModule (ModLink "Module" Nothing)
 
       it "should parse a module inline" $ do
         "This is a \"Module\"." `shouldParseTo`
-          "This is a " <> DocModule "Module" <> "."
+          "This is a " <> DocModule (ModLink "Module" Nothing) <> "."
 
       it "can accept a simple module name" $ do
-        "\"Hello\"" `shouldParseTo` DocModule "Hello"
+        "\"Hello\"" `shouldParseTo` DocModule (ModLink "Hello" Nothing)
 
       it "can accept a module name with dots" $ do
-        "\"Hello.World\"" `shouldParseTo` DocModule "Hello.World"
+        "\"Hello.World\"" `shouldParseTo` DocModule (ModLink "Hello.World" Nothing)
 
       it "can accept a module name with unicode" $ do
-        "\"Hello.Worldλ\"" `shouldParseTo` DocModule "Hello.Worldλ"
+        "\"Hello.Worldλ\"" `shouldParseTo` DocModule (ModLink "Hello.Worldλ" Nothing)
 
       it "parses a module name with a trailing dot as regular quoted string" $ do
         "\"Hello.\"" `shouldParseTo` "\"Hello.\""
@@ -422,16 +422,82 @@ spec = do
         "\"Hello&[{}(=*)+]!\"" `shouldParseTo` "\"Hello&[{}(=*)+]!\""
 
       it "accepts a module name with unicode" $ do
-        "\"Foo.Barλ\"" `shouldParseTo` DocModule "Foo.Barλ"
+        "\"Foo.Barλ\"" `shouldParseTo` DocModule (ModLink "Foo.Barλ" Nothing)
 
       it "treats empty module name as regular double quotes" $ do
         "\"\"" `shouldParseTo` "\"\""
 
       it "accepts anchor reference syntax as DocModule" $ do
-        "\"Foo#bar\"" `shouldParseTo` DocModule "Foo#bar"
+        "\"Foo#bar\"" `shouldParseTo` DocModule (ModLink "Foo#bar" Nothing)
 
       it "accepts old anchor reference syntax as DocModule" $ do
-        "\"Foo\\#bar\"" `shouldParseTo` DocModule "Foo\\#bar"
+        "\"Foo\\#bar\"" `shouldParseTo` DocModule (ModLink "Foo\\#bar" Nothing)
+
+    context "when parsing labeled module links" $ do
+      it "parses a simple labeled module link" $ do
+        "[some label](\"Some.Module\")" `shouldParseTo`
+          DocModule (ModLink "Some.Module" (Just "some label"))
+
+      it "allows escaping in label" $ do
+        "[some\\] label](\"Some.Module\")" `shouldParseTo`
+          DocModule (ModLink "Some.Module" (Just "some] label"))
+
+      it "strips leading and trailing whitespace from label" $ do
+        "[  some label  ](\"Some.Module\")" `shouldParseTo`
+          DocModule (ModLink "Some.Module" (Just "some label"))
+
+      it "allows whitespace in module name link" $ do
+        "[some label]( \"Some.Module\"\t )" `shouldParseTo`
+          DocModule (ModLink "Some.Module" (Just "some label"))
+
+      it "allows inline markup in the label" $ do
+        "[something /emphasized/](\"Some.Module\")" `shouldParseTo`
+          DocModule (ModLink "Some.Module" (Just ("something " <> DocEmphasis "emphasized")))
+
+      it "should parse a labeled module on its own" $ do
+        "[label](\"Module\")" `shouldParseTo`
+          DocModule (ModLink "Module" (Just "label"))
+
+      it "should parse a labeled module inline" $ do
+        "This is a [label](\"Module\")." `shouldParseTo`
+          "This is a " <> DocModule (ModLink "Module" (Just "label")) <> "."
+
+      it "can accept a labeled module name with dots" $ do
+        "[label](\"Hello.World\")" `shouldParseTo` DocModule (ModLink "Hello.World" (Just "label"))
+
+      it "can accept a labeled module name with unicode" $ do
+        "[label](\"Hello.Worldλ\")" `shouldParseTo` DocModule (ModLink "Hello.Worldλ" (Just "label"))
+
+      it "parses a labeled module name with a trailing dot as a hyperlink" $ do
+        "[label](\"Hello.\")" `shouldParseTo`
+          hyperlink "\"Hello.\"" (Just "label")
+
+      it "parses a labeled module name with a space as a regular string" $ do
+        "[label](\"Hello World\")" `shouldParseTo` "[label](\"Hello World\")"
+
+      it "parses a module name with invalid characters as a hyperlink" $ do
+        "[label](\"Hello&[{}(=*+]!\")" `shouldParseTo`
+          hyperlink "\"Hello&[{}(=*+]!\"" (Just "label")
+
+      it "accepts a labeled module name with unicode" $ do
+        "[label](\"Foo.Barλ\")" `shouldParseTo`
+          DocModule (ModLink "Foo.Barλ" (Just "label"))
+
+      it "treats empty labeled module name as empty hyperlink" $ do
+        "[label](\"\")" `shouldParseTo`
+          hyperlink "\"\"" (Just "label")
+
+      it "accepts anchor reference syntax for labeled module name" $ do
+        "[label](\"Foo#bar\")" `shouldParseTo`
+          DocModule (ModLink "Foo#bar" (Just "label"))
+
+      it "accepts old anchor reference syntax for labeled module name" $ do
+        "[label](\"Foo\\#bar\")" `shouldParseTo`
+          DocModule (ModLink "Foo\\#bar" (Just "label"))
+
+      it "interprets empty label as a unlabeled module name" $ do
+        "[](\"Module.Name\")" `shouldParseTo`
+          "[](" <> DocModule (ModLink "Module.Name" Nothing) <> ")"
 
   describe "parseParas" $ do
     let infix 1 `shouldParseTo`

From a72ffd1ab5023017e5066512ebc0c03eb7acf9b3 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?I=C3=B1aki=20Garc=C3=ADa=20Etxebarria?=
 <git@inaki.blueleaf.cc>
Date: Sun, 19 Apr 2020 00:11:13 +0100
Subject: [PATCH 2/3] Adapt the JSon code to the new DocModule type

---
 haddock-api/src/Haddock/Interface/Json.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs
index 2cacabe1f0..360a54baed 100644
--- a/haddock-api/src/Haddock/Interface/Json.hs
+++ b/haddock-api/src/Haddock/Interface/Json.hs
@@ -98,9 +98,9 @@ jsonDoc (DocIdentifierUnchecked modName) = jsonObject
     , ("modName", jsonString (showModName modName))
     ]
 
-jsonDoc (DocModule s) = jsonObject
+jsonDoc (DocModule (ModLink m _l)) = jsonObject
     [ ("tag", jsonString "DocModule")
-    , ("string", jsonString s)
+    , ("string", jsonString m)
     ]
 
 jsonDoc (DocWarning x) = jsonObject

From 365bc3bb2574308c00dca786bc144a222ab57e4f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?I=C3=B1aki=20Garc=C3=ADa=20Etxebarria?=
 <git@inaki.blueleaf.cc>
Date: Fri, 15 Jan 2021 13:59:53 +0000
Subject: [PATCH 3/3] Dummy commit to trigger rebuild