Support new parser types in GHC

This commit converts the lexers and all the parser machinery to use the
new parser types and diagnostics infrastructure. Furthermore, it cleans
up the way the parser code was emitting hints.

As a result of this systematic approach, the test output of the
`InfixAppPatErr` and `T984` tests have been changed. Previously they
would emit a `SuggestMissingDo` hint, but this was not at all helpful in
resolving the error, and it was even confusing by just looking at the
original program that triggered the errors.

Update haddock submodule

1 files changed, 96 insertions, 69 deletions

diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index f9494afa6a..10c9f2042f 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -75,6 +75,7 @@ module GHC.Parser.Lexer (
    commentToAnnotation,
    HdkComment(..),
    warnopt,
+   addPsMessage
   ) where
 
 import GHC.Prelude
@@ -101,17 +102,17 @@ import Data.Map (Map)
 import qualified Data.Map as Map
 
 -- compiler
-import GHC.Data.Bag
+import GHC.Utils.Error
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import GHC.Data.StringBuffer
 import GHC.Data.FastString
+import GHC.Types.Error hiding ( getErrorMessages, getMessages )
 import GHC.Types.Unique.FM
 import GHC.Data.Maybe
 import GHC.Data.OrdList
 import GHC.Utils.Misc ( readSignificandExponentPair, readHexSignificandExponentPair )
 
-import GHC.Types.Error ( GhcHint(..) )
 import GHC.Types.SrcLoc
 import GHC.Types.SourceText
 import GHC.Types.Basic ( InlineSpec(..), RuleMatchInfo(..))
@@ -121,7 +122,8 @@ import GHC.Parser.CharClass
 
 import GHC.Parser.Annotation
 import GHC.Driver.Flags
-import GHC.Parser.Errors
+import GHC.Parser.Errors.Types
+import GHC.Parser.Errors.Ppr ()
 }
 
 -- -----------------------------------------------------------------------------
@@ -362,7 +364,7 @@ $tab          { warnTab }
 }
 
 <0,option_prags> {
-  "{-#"  { warnThen Opt_WarnUnrecognisedPragmas PsWarnUnrecognisedPragma
+  "{-#"  { warnThen PsWarnUnrecognisedPragma
                     (nested_comment lexToken) }
 }
 
@@ -1143,7 +1145,8 @@ hopefully_open_brace span buf len
                  Layout prev_off _ : _ -> prev_off < offset
                  _                     -> True
       if isOK then pop_and open_brace span buf len
-              else addFatalError $ PsError PsErrMissingBlock [] (mkSrcSpanPs span)
+              else addFatalError $
+                     mkPlainErrorMsgEnvelope (mkSrcSpanPs span) PsErrMissingBlock
 
 pop_and :: Action -> Action
 pop_and act span buf len = do _ <- popLexState
@@ -1528,7 +1531,10 @@ docCommentEnd input commentAcc docType buf span = do
   commentEnd lexToken input commentAcc finalizeComment buf span
 
 errBrace :: AlexInput -> RealSrcSpan -> P a
-errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) (psRealLoc end) (PsError (PsErrLexer LexUnterminatedComment LexErrKind_EOF) [])
+errBrace (AI end _) span =
+  failLocMsgP (realSrcSpanStart span)
+              (psRealLoc end)
+              (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc (PsErrLexer LexUnterminatedComment LexErrKind_EOF))
 
 open_brace, close_brace :: Action
 open_brace span _str _len = do
@@ -1587,7 +1593,7 @@ varid span buf len =
           lambdaCase <- getBit LambdaCaseBit
           unless lambdaCase $ do
             pState <- getPState
-            addError $ PsError PsErrLambdaCase [] (mkSrcSpanPs (last_loc pState))
+            addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) PsErrLambdaCase
           return ITlcase
         _ -> return ITcase
       maybe_layout keyword
@@ -1619,8 +1625,7 @@ qconsym buf len = ITqconsym $! splitQualName buf len False
 varsym_prefix :: Action
 varsym_prefix = sym $ \span exts s ->
   let warnExtConflict errtok =
-        do { addWarning Opt_WarnOperatorWhitespaceExtConflict $
-               PsWarnOperatorWhitespaceExtConflict (mkSrcSpanPs span) errtok
+        do { addPsMessage (mkSrcSpanPs span) (PsWarnOperatorWhitespaceExtConflict errtok)
            ; return (ITvarsym s) }
   in
   if | s == fsLit "@" ->
@@ -1646,19 +1651,19 @@ varsym_prefix = sym $ \span exts s ->
      | s == fsLit "!" -> return ITbang
      | s == fsLit "~" -> return ITtilde
      | otherwise ->
-         do { addWarning Opt_WarnOperatorWhitespace $
-                PsWarnOperatorWhitespace (mkSrcSpanPs span) s
-                  OperatorWhitespaceOccurrence_Prefix
+         do { addPsMessage
+                (mkSrcSpanPs span)
+                (PsWarnOperatorWhitespace s OperatorWhitespaceOccurrence_Prefix)
             ; return (ITvarsym s) }
 
 -- See Note [Whitespace-sensitive operator parsing]
 varsym_suffix :: Action
 varsym_suffix = sym $ \span _ s ->
-  if | s == fsLit "@" -> failMsgP (PsError PsErrSuffixAT [])
+  if | s == fsLit "@" -> failMsgP (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrSuffixAT)
      | otherwise ->
-         do { addWarning Opt_WarnOperatorWhitespace $
-                PsWarnOperatorWhitespace (mkSrcSpanPs span) s
-                  OperatorWhitespaceOccurrence_Suffix
+         do { addPsMessage
+                (mkSrcSpanPs span)
+                (PsWarnOperatorWhitespace s OperatorWhitespaceOccurrence_Suffix)
             ; return (ITvarsym s) }
 
 -- See Note [Whitespace-sensitive operator parsing]
@@ -1668,9 +1673,9 @@ varsym_tight_infix = sym $ \span exts s ->
      | s == fsLit ".", OverloadedRecordDotBit `xtest` exts  -> return (ITproj False)
      | s == fsLit "." -> return ITdot
      | otherwise ->
-         do { addWarning Opt_WarnOperatorWhitespace $
-                PsWarnOperatorWhitespace (mkSrcSpanPs span) s
-                  OperatorWhitespaceOccurrence_TightInfix
+         do { addPsMessage
+                (mkSrcSpanPs span)
+                (PsWarnOperatorWhitespace s (OperatorWhitespaceOccurrence_TightInfix))
             ;  return (ITvarsym s) }
 
 -- See Note [Whitespace-sensitive operator parsing]
@@ -1726,7 +1731,8 @@ tok_integral itint transint transbuf translen (radix,char_to_int) span buf len =
   let src = lexemeToString buf len
   when ((not numericUnderscores) && ('_' `elem` src)) $ do
     pState <- getPState
-    addError $ PsError (PsErrNumUnderscores NumUnderscore_Integral) [] (mkSrcSpanPs (last_loc pState))
+    let msg = PsErrNumUnderscores NumUnderscore_Integral
+    addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg
   return $ L span $ itint (SourceText src)
        $! transint $ parseUnsignedInteger
        (offsetBytes transbuf buf) (subtract translen len) radix char_to_int
@@ -1767,7 +1773,8 @@ tok_frac drop f span buf len = do
   let src = lexemeToString buf (len-drop)
   when ((not numericUnderscores) && ('_' `elem` src)) $ do
     pState <- getPState
-    addError $ PsError (PsErrNumUnderscores NumUnderscore_Float) [] (mkSrcSpanPs (last_loc pState))
+    let msg = PsErrNumUnderscores NumUnderscore_Float
+    addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg
   return (L span $! (f $! src))
 
 tok_float, tok_primfloat, tok_primdouble :: String -> Token
@@ -1946,7 +1953,9 @@ lex_string_prag_comment mkTok span _buf _len
               = case alexGetChar i of
                   Just (c,i') | c == x    -> isString i' xs
                   _other -> False
-          err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span)) (psRealLoc end) (PsError (PsErrLexer LexUnterminatedOptions LexErrKind_EOF) [])
+          err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span))
+                                       (psRealLoc end)
+                                       (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer LexUnterminatedOptions LexErrKind_EOF)
 
 -- -----------------------------------------------------------------------------
 -- Strings & Chars
@@ -1983,7 +1992,8 @@ lex_string s = do
                 setInput i
                 when (any (> '\xFF') s') $ do
                   pState <- getPState
-                  let err = PsError PsErrPrimStringInvalidChar [] (mkSrcSpanPs (last_loc pState))
+                  let msg = PsErrPrimStringInvalidChar
+                  let err = mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg
                   addError err
                 return (ITprimstring (SourceText s') (unsafeMkByteString s'))
               _other ->
@@ -2246,7 +2256,7 @@ quasiquote_error :: RealSrcLoc -> P a
 quasiquote_error start = do
   (AI end buf) <- getInput
   reportLexError start (psRealLoc end) buf
-    (\k -> PsError (PsErrLexer LexUnterminatedQQ k) [])
+    (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc (PsErrLexer LexUnterminatedQQ k))
 
 -- -----------------------------------------------------------------------------
 -- Warnings
@@ -2256,9 +2266,9 @@ warnTab srcspan _buf _len = do
     addTabWarning (psRealSpan srcspan)
     lexToken
 
-warnThen :: WarningFlag -> (SrcSpan -> PsWarning) -> Action -> Action
-warnThen flag warning action srcspan buf len = do
-    addWarning flag (warning (RealSrcSpan (psRealSpan srcspan) Strict.Nothing))
+warnThen :: PsMessage -> Action -> Action
+warnThen warning action srcspan buf len = do
+    addPsMessage (RealSrcSpan (psRealSpan srcspan) Strict.Nothing) warning
     action srcspan buf len
 
 -- -----------------------------------------------------------------------------
@@ -2310,6 +2320,10 @@ warnopt f options = f `EnumSet.member` pWarningFlags options
 data ParserOpts = ParserOpts
   { pWarningFlags   :: EnumSet WarningFlag -- ^ enabled warning flags
   , pExtsBitmap     :: !ExtsBitmap -- ^ bitmap of permitted extensions
+  , pMakePsMessage  :: SrcSpan -> PsMessage -> MsgEnvelope PsMessage
+    -- ^ The function to be used to construct diagnostic messages.
+    -- The idea is to partially-apply 'mkParserMessage' upstream, to
+    -- avoid the dependency on the 'DynFlags' in the Lexer.
   }
 
 -- | Haddock comment as produced by the lexer. These are accumulated in
@@ -2324,10 +2338,9 @@ data HdkComment
 data PState = PState {
         buffer     :: StringBuffer,
         options    :: ParserOpts,
-        warnings   :: Bag PsWarning,
-        errors     :: Bag PsError,
-        tab_first  :: Strict.Maybe RealSrcSpan,
-                                         -- pos of first tab warning in the file
+        warnings   :: Messages PsMessage,
+        errors     :: Messages PsMessage,
+        tab_first  :: Strict.Maybe RealSrcSpan, -- pos of first tab warning in the file
         tab_count  :: !Word,             -- number of tab warnings in the file
         last_tk    :: Strict.Maybe (PsLocated Token), -- last non-comment token
         prev_loc   :: PsSpan,      -- pos of previous token, including comments,
@@ -2414,12 +2427,12 @@ thenP :: P a -> (a -> P b) -> P b
                 POk s1 a         -> (unP (k a)) s1
                 PFailed s1 -> PFailed s1
 
-failMsgP :: (SrcSpan -> PsError) -> P a
+failMsgP :: (SrcSpan -> MsgEnvelope PsMessage) -> P a
 failMsgP f = do
   pState <- getPState
   addFatalError (f (mkSrcSpanPs (last_loc pState)))
 
-failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> PsError) -> P a
+failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> MsgEnvelope PsMessage) -> P a
 failLocMsgP loc1 loc2 f =
   addFatalError (f (RealSrcSpan (mkRealSrcSpan loc1 loc2) Strict.Nothing))
 
@@ -2757,6 +2770,7 @@ data ExtBits
 mkParserOpts
   :: EnumSet WarningFlag        -- ^ warnings flags enabled
   -> EnumSet LangExt.Extension  -- ^ permitted language extensions enabled
+  -> (SrcSpan -> PsMessage -> MsgEnvelope PsMessage) -- ^ How to construct diagnostics
   -> Bool                       -- ^ are safe imports on?
   -> Bool                       -- ^ keeping Haddock comment tokens
   -> Bool                       -- ^ keep regular comment tokens
@@ -2768,11 +2782,12 @@ mkParserOpts
 
   -> ParserOpts
 -- ^ Given exactly the information needed, set up the 'ParserOpts'
-mkParserOpts warningFlags extensionFlags
+mkParserOpts warningFlags extensionFlags mkMessage
   safeImports isHaddock rawTokStream usePosPrags =
     ParserOpts {
-      pWarningFlags = warningFlags
-    , pExtsBitmap   = safeHaskellBit .|. langExtBits .|. optBits
+      pWarningFlags  = warningFlags
+    , pExtsBitmap    = safeHaskellBit .|. langExtBits .|. optBits
+    , pMakePsMessage = mkMessage
     }
   where
     safeHaskellBit = SafeHaskellBit `setBitIf` safeImports
@@ -2845,8 +2860,8 @@ initParserState options buf loc =
   PState {
       buffer        = buf,
       options       = options,
-      errors        = emptyBag,
-      warnings      = emptyBag,
+      errors        = emptyMessages,
+      warnings      = emptyMessages,
       tab_first     = Strict.Nothing,
       tab_count     = 0,
       last_tk       = Strict.Nothing,
@@ -2893,15 +2908,15 @@ class Monad m => MonadP m where
   --   to the accumulator and parsing continues. This allows GHC to report
   --   more than one parse error per file.
   --
-  addError :: PsError -> m ()
+  addError :: MsgEnvelope PsMessage -> m ()
 
   -- | Add a warning to the accumulator.
   --   Use 'getMessages' to get the accumulated warnings.
-  addWarning :: WarningFlag -> PsWarning -> m ()
+  addWarning :: MsgEnvelope PsMessage -> m ()
 
   -- | Add a fatal error. This will be the last error reported by the parser, and
   --   the parser will not produce any result, ending in a 'PFailed' state.
-  addFatalError :: PsError -> m a
+  addFatalError :: MsgEnvelope PsMessage -> m a
 
   -- | Check if a given flag is currently set in the bitmap.
   getBit :: ExtBits -> m Bool
@@ -2917,12 +2932,13 @@ class Monad m => MonadP m where
 
 instance MonadP P where
   addError err
-   = P $ \s -> POk s { errors = err `consBag` errors s} ()
+   = P $ \s -> POk s { errors = err `addMessage` errors s} ()
 
-  addWarning option w
-   = P $ \s -> if warnopt option (options s)
-                  then POk (s { warnings = w `consBag` warnings s }) ()
-                  else POk s ()
+  -- If the warning is meant to be suppressed, GHC will assign
+  -- a `SevIgnore` severity and the message will be discarded,
+  -- so we can simply add it no matter what.
+  addWarning w
+   = P $ \s -> POk (s { warnings = w `addMessage` warnings s }) ()
 
   addFatalError err =
     addError err >> P PFailed
@@ -2964,6 +2980,11 @@ getFinalCommentsFor _ = return emptyComments
 getEofPos :: P (Strict.Maybe (Strict.Pair RealSrcSpan RealSrcSpan))
 getEofPos = P $ \s@(PState { eof_pos = pos }) -> POk s pos
 
+addPsMessage :: SrcSpan -> PsMessage -> P ()
+addPsMessage srcspan msg = do
+  opts <- options <$> getPState
+  addWarning ((pMakePsMessage opts) srcspan msg)
+
 addTabWarning :: RealSrcSpan -> P ()
 addTabWarning srcspan
  = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} ->
@@ -2976,12 +2997,12 @@ addTabWarning srcspan
 
 -- | Get a bag of the errors that have been accumulated so far.
 --   Does not take -Werror into account.
-getErrorMessages :: PState -> Bag PsError
+getErrorMessages :: PState -> Messages PsMessage
 getErrorMessages p = errors p
 
 -- | Get the warnings and errors accumulated so far.
 --   Does not take -Werror into account.
-getMessages :: PState -> (Bag PsWarning, Bag PsError)
+getMessages :: PState -> (Messages PsMessage, Messages PsMessage)
 getMessages p =
   let ws = warnings p
       -- we add the tabulation warning on the fly because
@@ -2989,9 +3010,12 @@ getMessages p =
       ws' = case tab_first p of
         Strict.Nothing -> ws
         Strict.Just tf ->
-          PsWarnTab (RealSrcSpan tf Strict.Nothing) (tab_count p)
-                           `consBag` ws
+          let msg = mkMsg (RealSrcSpan tf Strict.Nothing) $
+                          (PsWarnTab (tab_count p))
+          in msg `addMessage` ws
   in (ws', errors p)
+  where
+    mkMsg = pMakePsMessage . options $ p
 
 getContext :: P [LayoutContext]
 getContext = P $ \s@PState{context=ctx} -> POk s ctx
@@ -3037,8 +3061,8 @@ srcParseErr
   -> StringBuffer       -- current buffer (placed just after the last token)
   -> Int                -- length of the previous token
   -> SrcSpan
-  -> PsError
-srcParseErr options buf len loc = PsError (PsErrParse token) suggests loc
+  -> MsgEnvelope PsMessage
+srcParseErr options buf len loc = mkPlainErrorMsgEnvelope loc (PsErrParse token details)
   where
    token = lexemeToString (offsetBytes (-len) buf) len
    pattern_ = decodePrevNChars 8 buf
@@ -3047,16 +3071,13 @@ srcParseErr options buf len loc = PsError (PsErrParse token) suggests loc
    mdoInLast100 = "mdo" `isInfixOf` last100
    th_enabled = ThQuotesBit `xtest` pExtsBitmap options
    ps_enabled = PatternSynonymsBit `xtest` pExtsBitmap options
-
-   sug c s = if c then Just s else Nothing
-   sug_th  = sug (not th_enabled && token == "$")          (SuggestExtension LangExt.TemplateHaskell) -- #7396
-   sug_rdo = sug (token == "<-" && mdoInLast100)           (SuggestExtension LangExt.RecursiveDo)
-   sug_do  = sug (token == "<-" && not mdoInLast100)       SuggestMissingDo
-   sug_let = sug (token == "=" && doInLast100)             SuggestLetInDo         -- #15849
-   sug_pat = sug (not ps_enabled && pattern_ == "pattern ") (SuggestExtension LangExt.PatternSynonyms) -- #12429
-   suggests
-         | null token = []
-         | otherwise  = catMaybes [sug_th, sug_rdo, sug_do, sug_let, sug_pat]
+   details = PsErrParseDetails {
+       ped_th_enabled      = th_enabled
+     , ped_do_in_last_100  = doInLast100
+     , ped_mdo_in_last_100 = mdoInLast100
+     , ped_pat_syn_enabled = ps_enabled
+     , ped_pattern_parsed  = pattern_ == "pattern "
+     }
 
 -- Report a parse failure, giving the span of the previous token as
 -- the location of the error.  This is the entry point for errors
@@ -3073,7 +3094,7 @@ lexError e = do
   loc <- getRealSrcLoc
   (AI end buf) <- getInput
   reportLexError loc (psRealLoc end) buf
-    (\k -> PsError (PsErrLexer e k) [])
+    (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer e k)
 
 -- -----------------------------------------------------------------------------
 -- This is the top-level function: called from the parser each time a
@@ -3188,8 +3209,9 @@ alternativeLayoutRuleToken t
              -- This next case is to handle a transitional issue:
              (ITwhere, ALRLayout _ col : ls, _)
               | newLine && thisCol == col && transitional ->
-                 do addWarning Opt_WarnAlternativeLayoutRuleTransitional
-                      $ PsWarnTransitionalLayout (mkSrcSpanPs thisLoc) TransLayout_Where
+                 do addPsMessage
+                      (mkSrcSpanPs thisLoc)
+                      (PsWarnTransitionalLayout TransLayout_Where)
                     setALRContext ls
                     setNextToken t
                     -- Note that we use lastLoc, as we may need to close
@@ -3198,8 +3220,9 @@ alternativeLayoutRuleToken t
              -- This next case is to handle a transitional issue:
              (ITvbar, ALRLayout _ col : ls, _)
               | newLine && thisCol == col && transitional ->
-                 do addWarning Opt_WarnAlternativeLayoutRuleTransitional
-                      $ PsWarnTransitionalLayout (mkSrcSpanPs thisLoc) TransLayout_Pipe
+                 do addPsMessage
+                      (mkSrcSpanPs thisLoc)
+                      (PsWarnTransitionalLayout TransLayout_Pipe)
                     setALRContext ls
                     setNextToken t
                     -- Note that we use lastLoc, as we may need to close
@@ -3322,7 +3345,7 @@ lexToken = do
         return (L span ITeof)
     AlexError (AI loc2 buf) ->
         reportLexError (psRealLoc loc1) (psRealLoc loc2) buf
-          (\k -> PsError (PsErrLexer LexError k) [])
+          (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer LexError k)
     AlexSkip inp2 _ -> do
         setInput inp2
         lexToken
@@ -3336,7 +3359,11 @@ lexToken = do
         if (isComment lt') then setLastComment lt else setLastTk lt
         return lt
 
-reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> (LexErrKind -> SrcSpan -> PsError) -> P a
+reportLexError :: RealSrcLoc
+               -> RealSrcLoc
+               -> StringBuffer
+               -> (LexErrKind -> SrcSpan -> MsgEnvelope PsMessage)
+               -> P a
 reportLexError loc1 loc2 buf f
   | atEnd buf = failLocMsgP loc1 loc2 (f LexErrKind_EOF)
   | otherwise =