Merge remote-tracking branch 'upstream/main'

2 files changed, 15 insertions, 10 deletions

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index d9a2e0cd..9f28d72a 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -10,14 +10,17 @@ import Data.List           ( isPrefixOf, isSuffixOf )
 
 import qualified Data.ByteString as BS
 
+import GHC.Platform
 import GHC.Types.SourceText
 import GHC.Driver.Session
+import GHC.Driver.Config.Diagnostic
 import GHC.Utils.Error     ( pprLocMsgEnvelope )
 import GHC.Data.FastString ( mkFastString )
-import GHC.Parser.Errors.Ppr ( pprError )
+import GHC.Parser.Errors.Ppr ()
+import qualified GHC.Types.Error as E
 import GHC.Parser.Lexer    as Lexer
                            ( P(..), ParseResult(..), PState(..), Token(..)
-                           , initParserState, lexer, mkParserOpts, getErrorMessages)
+                           , initParserState, lexer, mkParserOpts, getPsErrorMessages)
 import GHC.Data.Bag         ( bagToList )
 import GHC.Utils.Outputable ( text, ($$) )
 import GHC.Utils.Panic      ( panic )
@@ -40,7 +43,7 @@ parse
 parse dflags fpath bs = case unP (go False []) initState of
     POk _ toks -> reverse toks
     PFailed pst ->
-      let err:_ = bagToList (fmap pprError (getErrorMessages pst)) in
+      let err:_ = bagToList (E.getMessages $ getPsErrorMessages pst) in
       panic $ showSDoc dflags $
         text "Hyperlinker parse error:" $$ pprLocMsgEnvelope err
   where
@@ -48,8 +51,10 @@ parse dflags fpath bs = case unP (go False []) initState of
     initState = initParserState pflags buf start
     buf = stringBufferFromByteString bs
     start = mkRealSrcLoc (mkFastString fpath) 1 1
-    pflags = mkParserOpts   (warningFlags dflags)
-                            (extensionFlags dflags)
+    arch_os = platformArchOS (targetPlatform dflags)
+    pflags = mkParserOpts   (extensionFlags dflags)
+                            (initDiagOpts dflags)
+                            (supportedLanguagesAndExtensions arch_os)
                             (safeImportsOn dflags)
                             False -- lex Haddocks as comment tokens
                             True  -- produce comment tokens
@@ -233,6 +238,7 @@ classify tok =
     ITrequires             -> TkKeyword
 
     ITinline_prag       {} -> TkPragma
+    ITopaque_prag       {} -> TkPragma
     ITspec_prag         {} -> TkPragma
     ITspec_inline_prag  {} -> TkPragma
     ITsource_prag       {} -> TkPragma
@@ -263,6 +269,7 @@ classify tok =
     ITequal                -> TkGlyph
     ITlam                  -> TkGlyph
     ITlcase                -> TkGlyph
+    ITlcases               -> TkGlyph
     ITvbar                 -> TkGlyph
     ITlarrow            {} -> TkGlyph
     ITrarrow            {} -> TkGlyph
@@ -350,10 +357,7 @@ classify tok =
     ITeof                  -> TkUnknown
 
     ITlineComment       {} -> TkComment
-    ITdocCommentNext    {} -> TkComment
-    ITdocCommentPrev    {} -> TkComment
-    ITdocCommentNamed   {} -> TkComment
-    ITdocSection        {} -> TkComment
+    ITdocComment        {} -> TkComment
     ITdocOptions        {} -> TkComment
 
     -- The lexer considers top-level pragmas as comments (see `pragState` in
@@ -374,6 +378,7 @@ inPragma True _ = True
 inPragma False tok =
   case tok of
     ITinline_prag       {} -> True
+    ITopaque_prag       {} -> True
     ITspec_prag         {} -> True
     ITspec_inline_prag  {} -> True
     ITsource_prag       {} -> True
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index a8a51e5d..7fa5a443 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -142,7 +142,7 @@ richToken srcs details Token{..}
     contexts = concatMap (Set.elems . identInfo) . Map.elems . nodeIdentifiers $ details
 
     -- pick an arbitrary non-evidence identifier to hyperlink with
-    identDet = Map.lookupMin $ Map.filter notEvidence $ nodeIdentifiers $ details
+    identDet = Map.lookupMin $ Map.filter notEvidence $ nodeIdentifiers details
     notEvidence = not . any isEvidenceContext . identInfo
 
     -- If we have name information, we can make links