Merge pull request #1321 from Kleidukos/ghc-9.0

Merge ghc-9.0 into ghc-head

3 files changed, 49 insertions, 19 deletions

diff --git a/haddock-library/src/Documentation/Haddock/Markup.hs b/haddock-library/src/Documentation/Haddock/Markup.hs
index 365041ee..0919737f 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 a3bba38a..de336d45 100644
--- a/haddock-library/src/Documentation/Haddock/Parser.hs
+++ b/haddock-library/src/Documentation/Haddock/Parser.hs
@@ -72,7 +72,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
@@ -148,6 +148,7 @@ parseParagraph = snd . parse p
                                     , mathDisplay
                                     , mathInline
                                     , markdownImage
+                                    , markdownLink
                                     , hyperlink
                                     , bold
                                     , emphasis
@@ -242,7 +243,12 @@ 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 `maybeFollowedBy` anchor_) <* "\"")
+moduleName = DocModule . flip ModLink Nothing <$> ("\"" *> moduleNameString <* "\"")
+
+-- | A module name, optionally with an anchor
+--
+moduleNameString :: Parser String
+moduleNameString = modid `maybeFollowedBy` anchor_
   where
     modid = intercalate "." <$> conid `Parsec.sepBy1` "."
     anchor_ = (++)
@@ -250,13 +256,30 @@ moduleName = DocModule <$> ("\"" *> (modid `maybeFollowedBy` anchor_) <* "\"")
       <*> many (Parsec.satisfy (\c -> c /= '"' && not (isSpace c)))
 
     maybeFollowedBy pre suf = (\x -> maybe x (x ++)) <$> pre <*> optional suf
-
+    conid :: Parser String
     conid = (:)
       <$> Parsec.satisfy (\c -> isAlpha c && isUpper c)
       <*> many conChar
 
     conChar = Parsec.alphaNum <|> Parsec.char '_'
 
+-- | 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
+    markdownModuleName lbl = do
+      mn <- "(" *> skipHorizontalSpace *>
+            "\"" *> moduleNameString <* "\""
+            <* skipHorizontalSpace <* ")"
+      pure $ DocModule (ModLink mn (Just lbl))
+
+    markdownURL lbl = do
+      target <- markdownLinkTarget
+      pure $ DocHyperlink $ Hyperlink target (Just lbl)
+
 -- | Picture parser, surrounded by \<\< and \>\>. It's possible to specify
 -- a title for the picture.
 --
@@ -290,9 +313,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]
 
@@ -772,22 +797,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 12ccd28d..252eb425 100644
--- a/haddock-library/src/Documentation/Haddock/Types.hs
+++ b/haddock-library/src/Documentation/Haddock/Types.hs
@@ -73,6 +73,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
@@ -111,7 +116,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)
@@ -142,7 +148,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)
@@ -189,7 +195,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
@@ -234,7 +240,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