Merge pull request #875 from harpocrates/feature/markup-in-hyperlinks

Inline markup in markdown-style links and images

20 files changed, 213 insertions, 59 deletions

diff --git a/CHANGES.md b/CHANGES.md
index 66703068..8240479f 100644
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -2,6 +2,8 @@
 
  * Make `--package-version` optional for `--hoogle` (#899)
 
+ * Support inline markup in markdown-style links (#875)
+
 ## Changes in version 2.21.0
 
  * Overhaul handling of data declarations in XHTML and LaTeX. Adds support for
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index eb93ade2..d6a6a12d 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -336,7 +336,7 @@ markupTag dflags = Markup {
   markupOrderedList          = box (TagL 'o'),
   markupDefList              = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b),
   markupCodeBlock            = box TagPre,
-  markupHyperlink            = \(Hyperlink url mLabel) -> (box (TagInline "a") . str) (fromMaybe url mLabel),
+  markupHyperlink            = \(Hyperlink url mLabel) -> box (TagInline "a") (fromMaybe (str url) mLabel),
   markupAName                = const $ str "",
   markupProperty             = box TagPre . str,
   markupExample              = box TagPre . str . unlines . map exampleToString,
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index d2baf69a..d5b2f325 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -1182,7 +1182,7 @@ parLatexMarkup ppId = Markup {
   markupOrderedList          = \p v -> enumeratedList (map ($v) p) $$ text "",
   markupDefList              = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l),
   markupCodeBlock            = \p _ -> quote (verb (p Verb)) $$ text "",
-  markupHyperlink            = \l _ -> markupLink l,
+  markupHyperlink            = \(Hyperlink u l) p -> markupLink u (fmap ($p) l),
   markupAName                = \_ _ -> empty,
   markupProperty             = \p _ -> quote $ verb $ text p,
   markupExample              = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e,
@@ -1202,8 +1202,8 @@ parLatexMarkup ppId = Markup {
     fixString Verb  s = s
     fixString Mono  s = latexMonoFilter s
 
-    markupLink (Hyperlink url mLabel) = case mLabel of
-      Just label -> text "\\href" <> braces (text url) <> braces (text label)
+    markupLink url mLabel = case mLabel of
+      Just label -> text "\\href" <> braces (text url) <> braces label
       Nothing    -> text "\\url"  <> braces (text url)
 
     -- Is there a better way of doing this? Just a space is an aribtrary choice.
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
index ed323a90..42643ed0 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -62,8 +62,8 @@ parHtmlMarkup qual insertAnchors ppId = Markup {
   markupHyperlink            = \(Hyperlink url mLabel)
                                -> if insertAnchors
                                   then anchor ! [href url]
-                                       << fromMaybe url mLabel
-                                  else toHtml $ fromMaybe url mLabel,
+                                       << fromMaybe (toHtml url) mLabel
+                                  else fromMaybe (toHtml url) mLabel,
   markupAName                = \aname
                                -> if insertAnchors
                                   then namedAnchor aname << ""
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 87face7c..4dff77ce 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -135,7 +135,7 @@ rename dflags gre = rn
       DocCodeBlock doc -> DocCodeBlock <$> rn doc
       DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x)
       DocModule str -> pure (DocModule str)
-      DocHyperlink l -> pure (DocHyperlink l)
+      DocHyperlink (Hyperlink u l) -> DocHyperlink . Hyperlink u <$> traverse rn l
       DocPic str -> pure (DocPic str)
       DocMathInline str -> pure (DocMathInline str)
       DocMathDisplay str -> pure (DocMathDisplay str)
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 30bd2b9a..e1d8dbe1 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 = 33
+binaryInterfaceVersion = 34
 
 binaryInterfaceVersionCompatibility :: [Word16]
 binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
@@ -434,7 +434,7 @@ instance Binary Example where
         result <- get bh
         return (Example expression result)
 
-instance Binary Hyperlink where
+instance Binary a => Binary (Hyperlink a) where
     put_ bh (Hyperlink url label) = do
         put_ bh url
         put_ bh label
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 6da45a3b..39df598a 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -467,7 +467,7 @@ instance NFData ModuleName where rnf x = seq x ()
 instance NFData id => NFData (Header id) where
   rnf (Header a b) = a `deepseq` b `deepseq` ()
 
-instance NFData Hyperlink where
+instance NFData id => NFData (Hyperlink id) where
   rnf (Hyperlink a b) = a `deepseq` b `deepseq` ()
 
 instance NFData Picture where
diff --git a/haddock-library/CHANGES.md b/haddock-library/CHANGES.md
index 0175b6af..971d8dc7 100644
--- a/haddock-library/CHANGES.md
+++ b/haddock-library/CHANGES.md
@@ -1,3 +1,7 @@
+## TBA
+
+ * Support inline markup in markdown-style links (#875)
+
 ## Changes in version 1.7.0
 
  * Make `Documentation.Haddock.Parser.Monad` an internal module
diff --git a/haddock-library/fixtures/Fixtures.hs b/haddock-library/fixtures/Fixtures.hs
index a4e4321f..72ea8525 100644
--- a/haddock-library/fixtures/Fixtures.hs
+++ b/haddock-library/fixtures/Fixtures.hs
@@ -146,8 +146,8 @@ instance (ToExpr mod, ToExpr id)  => ToExpr (DocH mod id)
 deriving instance Generic (Header id)
 instance ToExpr id => ToExpr (Header id)
 
-deriving instance Generic Hyperlink
-instance ToExpr Hyperlink
+deriving instance Generic (Hyperlink id)
+instance ToExpr id => ToExpr (Hyperlink id)
 
 deriving instance Generic Picture
 instance ToExpr Picture
diff --git a/haddock-library/fixtures/examples/link.parsed b/haddock-library/fixtures/examples/link.parsed
index 0e85338c..781dee87 100644
--- a/haddock-library/fixtures/examples/link.parsed
+++ b/haddock-library/fixtures/examples/link.parsed
@@ -1,5 +1,5 @@
 DocParagraph
   (DocHyperlink
      Hyperlink
-       {hyperlinkLabel = Just "link",
+       {hyperlinkLabel = Just (DocString "link"),
         hyperlinkUrl = "http://example.com"})
diff --git a/haddock-library/fixtures/examples/linkInline.parsed b/haddock-library/fixtures/examples/linkInline.parsed
index 43470d7b..fe771598 100644
--- a/haddock-library/fixtures/examples/linkInline.parsed
+++ b/haddock-library/fixtures/examples/linkInline.parsed
@@ -3,4 +3,5 @@ DocParagraph
      (DocString "Bla ")
      (DocHyperlink
         Hyperlink
-          {hyperlinkLabel = Just "link", hyperlinkUrl = "http://example.com"}))
+          {hyperlinkLabel = Just (DocString "link"),
+           hyperlinkUrl = "http://example.com"}))
diff --git a/haddock-library/fixtures/examples/linkInlineMarkup.input b/haddock-library/fixtures/examples/linkInlineMarkup.input
new file mode 100644
index 00000000..e2f4e405
--- /dev/null
+++ b/haddock-library/fixtures/examples/linkInlineMarkup.input
@@ -0,0 +1 @@
+Bla [link /emphasized/](http://example.com)
diff --git a/haddock-library/fixtures/examples/linkInlineMarkup.parsed b/haddock-library/fixtures/examples/linkInlineMarkup.parsed
new file mode 100644
index 00000000..39adab64
--- /dev/null
+++ b/haddock-library/fixtures/examples/linkInlineMarkup.parsed
@@ -0,0 +1,8 @@
+DocParagraph
+  (DocAppend
+     (DocString "Bla ")
+     (DocHyperlink
+        Hyperlink
+          {hyperlinkLabel = Just (DocAppend (DocString "link ")
+                                            (DocEmphasis (DocString "emphasized"))),
+           hyperlinkUrl = "http://example.com"}))
diff --git a/haddock-library/fixtures/examples/urlLabel.parsed b/haddock-library/fixtures/examples/urlLabel.parsed
index d7e3a76c..58d2a81a 100644
--- a/haddock-library/fixtures/examples/urlLabel.parsed
+++ b/haddock-library/fixtures/examples/urlLabel.parsed
@@ -1,5 +1,5 @@
 DocParagraph
   (DocHyperlink
      Hyperlink
-       {hyperlinkLabel = Just "some link",
+       {hyperlinkLabel = Just (DocString "some link"),
         hyperlinkUrl = "http://example.com/"})
diff --git a/haddock-library/src/Documentation/Haddock/Markup.hs b/haddock-library/src/Documentation/Haddock/Markup.hs
index da8edcd4..b44fef80 100644
--- a/haddock-library/src/Documentation/Haddock/Markup.hs
+++ b/haddock-library/src/Documentation/Haddock/Markup.hs
@@ -2,35 +2,38 @@
 module Documentation.Haddock.Markup (
     markup
   , idMarkup
+  , plainMarkup
   ) where
 
 import Documentation.Haddock.Types
 
+import Data.Maybe ( fromMaybe )
+
 markup :: DocMarkupH mod id a -> DocH mod id -> a
-markup m DocEmpty                    = markupEmpty m
-markup m (DocAppend d1 d2)           = markupAppend m (markup m d1) (markup m d2)
-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 (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)
-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 (DocDefList ds)             = markupDefList m (map (markupPair m) ds)
-markup m (DocCodeBlock d)            = markupCodeBlock m (markup m d)
-markup m (DocHyperlink l)            = markupHyperlink m l
-markup m (DocAName ref)              = markupAName m ref
-markup m (DocPic img)                = markupPic m img
-markup m (DocMathInline mathjax)     = markupMathInline m mathjax
-markup m (DocMathDisplay mathjax)    = markupMathDisplay m mathjax
-markup m (DocProperty p)             = markupProperty m p
-markup m (DocExamples e)             = markupExample m e
-markup m (DocHeader (Header l t))    = markupHeader m (Header l (markup m t))
-markup m (DocTable (Table h b))      = markupTable m (Table (map (fmap (markup m)) h) (map (fmap (markup m)) b))
+markup m DocEmpty                       = markupEmpty m
+markup m (DocAppend d1 d2)              = markupAppend m (markup m d1) (markup m d2)
+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 (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)
+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 (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))
+markup m (DocAName ref)                 = markupAName m ref
+markup m (DocPic img)                   = markupPic m img
+markup m (DocMathInline mathjax)        = markupMathInline m mathjax
+markup m (DocMathDisplay mathjax)       = markupMathDisplay m mathjax
+markup m (DocProperty p)                = markupProperty m p
+markup m (DocExamples e)                = markupExample m e
+markup m (DocHeader (Header l t))       = markupHeader m (Header l (markup m t))
+markup m (DocTable (Table h b))         = markupTable m (Table (map (fmap (markup m)) h) (map (fmap (markup m)) b))
 
 markupPair :: DocMarkupH mod id a -> (DocH mod id, DocH mod id) -> (a, a)
 markupPair m (a,b) = (markup m a, markup m b)
@@ -63,3 +66,34 @@ idMarkup = Markup {
   markupHeader               = DocHeader,
   markupTable                = DocTable
   }
+
+-- | Map a 'DocH' into a best estimate of an alternate string. The idea is to
+-- strip away any formatting while preserving as much of the actual text as
+-- possible.
+plainMarkup :: (mod -> String) -> (id -> String) -> DocMarkupH mod id String
+plainMarkup plainMod plainIdent = Markup {
+  markupEmpty                = "",
+  markupString               = id,
+  markupParagraph            = id,
+  markupAppend               = (<>),
+  markupIdentifier           = plainIdent,
+  markupIdentifierUnchecked  = plainMod,
+  markupModule               = id,
+  markupWarning              = id,
+  markupEmphasis             = id,
+  markupBold                 = id,
+  markupMonospaced           = id,
+  markupUnorderedList        = const "",
+  markupOrderedList          = const "",
+  markupDefList              = const "",
+  markupCodeBlock            = id,
+  markupHyperlink            = \(Hyperlink url lbl) -> fromMaybe url lbl,
+  markupAName                = id,
+  markupPic                  = \(Picture uri title) -> fromMaybe uri title,
+  markupMathInline           = id,
+  markupMathDisplay          = id,
+  markupProperty             = id,
+  markupExample              = const "",
+  markupHeader               = \(Header _ title) -> title,
+  markupTable                = const ""
+  }
diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs
index 46b7ad3e..f6c12d46 100644
--- a/haddock-library/src/Documentation/Haddock/Parser.hs
+++ b/haddock-library/src/Documentation/Haddock/Parser.hs
@@ -33,6 +33,7 @@ import           Data.Maybe (fromMaybe, mapMaybe)
 import           Data.Monoid
 import qualified Data.Set as Set
 import           Documentation.Haddock.Doc
+import           Documentation.Haddock.Markup ( markup, plainMarkup )
 import           Documentation.Haddock.Parser.Monad
 import           Documentation.Haddock.Parser.Util
 import           Documentation.Haddock.Types
@@ -107,7 +108,7 @@ overIdentifier f d = g d
     g (DocOrderedList x) = DocOrderedList $ fmap g x
     g (DocDefList x) = DocDefList $ fmap (\(y, z) -> (g y, g z)) x
     g (DocCodeBlock x) = DocCodeBlock $ g x
-    g (DocHyperlink x) = DocHyperlink x
+    g (DocHyperlink (Hyperlink u x)) = DocHyperlink (Hyperlink u (fmap g x))
     g (DocPic x) = DocPic x
     g (DocMathInline x) = DocMathInline x
     g (DocMathDisplay x) = DocMathDisplay x
@@ -301,13 +302,19 @@ mathInline = DocMathInline . T.unpack
 -- >>> parseString "\\[\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}\\]"
 -- DocMathDisplay "\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}"
 mathDisplay :: Parser (DocH mod a)
-mathDisplay = DocMathDisplay . T.unpack 
+mathDisplay = DocMathDisplay . T.unpack
               <$> ("\\[" *> takeUntil "\\]")
 
-markdownImage :: Parser (DocH mod a)
-markdownImage = fromHyperlink <$> ("!" *> linkParser)
+-- | Markdown image parser. As per the commonmark reference recommendation, the
+-- description text for an image converted to its a plain string representation.
+--
+-- >>> 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)
   where
-    fromHyperlink (Hyperlink url label) = DocPic (Picture url label)
+    fromHyperlink (Hyperlink u l) = Picture u (fmap (markup stringMarkup) l)
+    stringMarkup = plainMarkup (const "") (\(l,c,r) -> [l] <> c <> [r])
 
 -- | Paragraph parser, called by 'parseParas'.
 paragraph :: Parser (DocH mod Identifier)
@@ -784,22 +791,22 @@ codeblock =
           | isNewline && isSpace c = Just isNewline
           | otherwise = Just $ c == '\n'
 
-hyperlink :: Parser (DocH mod a)
+hyperlink :: Parser (DocH mod Identifier)
 hyperlink = choice' [ angleBracketLink, markdownLink, autoUrl ]
 
 angleBracketLink :: Parser (DocH mod a)
 angleBracketLink =
-    DocHyperlink . makeLabeled Hyperlink 
+    DocHyperlink . makeLabeled (\s -> Hyperlink s . fmap DocString)
     <$> disallowNewline ("<" *> takeUntil ">")
 
-markdownLink :: Parser (DocH mod a)
+markdownLink :: Parser (DocH mod Identifier)
 markdownLink = DocHyperlink <$> linkParser
 
-linkParser :: Parser Hyperlink
+linkParser :: Parser (Hyperlink (DocH mod Identifier))
 linkParser = flip Hyperlink <$> label <*> (whitespace *> url)
   where
-    label :: Parser (Maybe String)
-    label = Just . decode . T.strip <$> ("[" *> takeUntil "]")
+    label :: Parser (Maybe (DocH mod Identifier))
+    label = Just . parseParagraph . T.strip <$> ("[" *> takeUntil "]")
 
     whitespace :: Parser ()
     whitespace = skipHorizontalSpace <* optional ("\n" *> skipHorizontalSpace)
@@ -825,7 +832,7 @@ autoUrl = mkLink <$> url
       Just (xs,x) | x `elem` (",.!?" :: String) -> DocHyperlink (mkHyperlink xs) `docAppend` DocString [x]
       _ -> DocHyperlink (mkHyperlink s)
 
-    mkHyperlink :: Text -> Hyperlink
+    mkHyperlink :: Text -> Hyperlink (DocH mod a)
     mkHyperlink lnk = Hyperlink (T.unpack lnk) Nothing
 
 
diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs
index b5dea3d4..f8f7d353 100644
--- a/haddock-library/src/Documentation/Haddock/Types.hs
+++ b/haddock-library/src/Documentation/Haddock/Types.hs
@@ -65,10 +65,10 @@ overDocF f d = (\x -> d { _doc = x }) <$> f (_doc d)
 type Version = [Int]
 type Package = String
 
-data Hyperlink = Hyperlink
+data Hyperlink id = Hyperlink
   { hyperlinkUrl   :: String
-  , hyperlinkLabel :: Maybe String
-  } deriving (Eq, Show)
+  , hyperlinkLabel :: Maybe id
+  } deriving (Eq, Show, Functor, Foldable, Traversable)
 
 data Picture = Picture
   { pictureUri   :: String
@@ -118,7 +118,7 @@ data DocH mod id
   | DocOrderedList [DocH mod id]
   | DocDefList [(DocH mod id, DocH mod id)]
   | DocCodeBlock (DocH mod id)
-  | DocHyperlink Hyperlink
+  | DocHyperlink (Hyperlink (DocH mod id))
   | DocPic Picture
   | DocMathInline String
   | DocMathDisplay String
@@ -147,7 +147,7 @@ instance Bifunctor DocH where
   bimap f g (DocOrderedList docs) = DocOrderedList (map (bimap f g) 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 _ _ (DocHyperlink hyperlink) = DocHyperlink hyperlink
+  bimap f g (DocHyperlink (Hyperlink url lbl)) = DocHyperlink (Hyperlink url (fmap (bimap f g) lbl))
   bimap _ _ (DocPic picture) = DocPic picture
   bimap _ _ (DocMathInline s) = DocMathInline s
   bimap _ _ (DocMathDisplay s) = DocMathDisplay s
@@ -192,7 +192,7 @@ instance Bitraversable DocH where
   bitraverse f g (DocOrderedList docs) = DocOrderedList <$> traverse (bitraverse f g) docs
   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 _ _ (DocHyperlink hyperlink) = pure (DocHyperlink hyperlink)
+  bitraverse f g (DocHyperlink (Hyperlink url lbl)) = DocHyperlink <$> (Hyperlink url <$> traverse (bitraverse f g) lbl)
   bitraverse _ _ (DocPic picture) = pure (DocPic picture)
   bitraverse _ _ (DocMathInline s) = pure (DocMathInline s)
   bitraverse _ _ (DocMathDisplay s) = pure (DocMathDisplay s)
@@ -227,7 +227,7 @@ data DocMarkupH mod id a = Markup
   , markupOrderedList          :: [a] -> a
   , markupDefList              :: [(a,a)] -> a
   , markupCodeBlock            :: a -> a
-  , markupHyperlink            :: Hyperlink -> a
+  , markupHyperlink            :: Hyperlink a -> a
   , markupAName                :: String -> a
   , markupPic                  :: Picture -> a
   , markupMathInline           :: String -> a
diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs
index 0449c917..6269184a 100644
--- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs
+++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs
@@ -37,7 +37,7 @@ parseParas = overDoc Parse.toRegular . Parse.parseParas Nothing
 parseString :: String -> Doc String
 parseString = Parse.toRegular . Parse.parseString
 
-hyperlink :: String -> Maybe String -> Doc String
+hyperlink :: String -> Maybe (Doc String) -> Doc String
 hyperlink url = DocHyperlink . Hyperlink url
 
 main :: IO ()
@@ -202,6 +202,10 @@ spec = do
           "[some label]( url)" `shouldParseTo`
             "[some label]( url)"
 
+        it "allows inline markup in the label" $ do
+          "[something /emphasized/](url)" `shouldParseTo`
+            hyperlink "url" (Just ("something " <> DocEmphasis "emphasized"))
+
         context "when URL is on a separate line" $ do
           it "allows URL to be on a separate line" $ do
             "[some label]\n(url)" `shouldParseTo`
diff --git a/html-test/ref/Bug865.html b/html-test/ref/Bug865.html
new file mode 100644
index 00000000..6630a88d
--- /dev/null
+++ b/html-test/ref/Bug865.html
@@ -0,0 +1,84 @@
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+  ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+     /><title
+    >Bug865</title
+    ><link href="#" rel="stylesheet" type="text/css" title="Ocean"
+     /><link rel="stylesheet" type="text/css" href="#"
+     /><script src="haddock-bundle.min.js" async="async" type="text/javascript"
+    ></script
+    ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"
+    ></script
+    ></head
+  ><body
+  ><div id="package-header"
+    ><ul class="links" id="page-menu"
+      ><li
+	><a href="#"
+	  >Contents</a
+	  ></li
+	><li
+	><a href="#"
+	  >Index</a
+	  ></li
+	></ul
+      ><p class="caption empty"
+      ></p
+      ></div
+    ><div id="content"
+    ><div id="module-header"
+      ><table class="info"
+	><tr
+	  ><th
+	    >Safe Haskell</th
+	    ><td
+	    >Safe</td
+	    ></tr
+	  ></table
+	><p class="caption"
+	>Bug865</p
+	></div
+      ><div id="synopsis"
+      ><details id="syn"
+	><summary
+	  >Synopsis</summary
+	  ><ul class="details-toggle" data-details-id="syn"
+	  ><li class="src short"
+	    ><a href="#"
+	      >link</a
+	      > :: ()</li
+	    ></ul
+	  ></details
+	></div
+      ><div id="interface"
+      ><h1
+	>Documentation</h1
+	><div class="top"
+	><p class="src"
+	  ><a id="v:link" class="def"
+	    >link</a
+	    > :: () <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ><div class="doc"
+	  ><p
+	    >An emphasized link <a href="#"
+	      >yes <em
+		>this</em
+		> is emphasized while this is
+ <code
+		>monospaced</code
+		></a
+	      >. And here is an image:</p
+	    ><p
+	    ><img src="https://www.haskell.org/static/img/haskell-logo.svg" title="emphasis stripped"
+	       /></p
+	    ></div
+	  ></div
+	></div
+      ></div
+    ><div id="footer"
+    ></div
+    ></body
+  ></html
+>
\ No newline at end of file
diff --git a/html-test/src/Bug865.hs b/html-test/src/Bug865.hs
new file mode 100644
index 00000000..71a6add1
--- /dev/null
+++ b/html-test/src/Bug865.hs
@@ -0,0 +1,9 @@
+module Bug865 where
+
+-- | An emphasized link [yes /this/ is emphasized while this is
+-- @monospaced@](https://www.haskell.org/). And here is an image:
+--
+-- ![/emphasis/ stripped](https://www.haskell.org/static/img/haskell-logo.svg)
+--
+link :: ()
+link = ()