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

3 files changed, 26 insertions, 13 deletions

diff --git a/compiler/GHC/Cmm/Lexer.x b/compiler/GHC/Cmm/Lexer.x
index 85b06ea624..bf379ec7da 100644
--- a/compiler/GHC/Cmm/Lexer.x
+++ b/compiler/GHC/Cmm/Lexer.x
@@ -26,7 +26,9 @@ import GHC.Types.Unique.FM
 import GHC.Data.StringBuffer
 import GHC.Data.FastString
 import GHC.Parser.CharClass
-import GHC.Parser.Errors
+import GHC.Parser.Errors.Types
+import GHC.Parser.Errors.Ppr ()
+import GHC.Utils.Error
 import GHC.Utils.Misc
 --import TRACE
 
@@ -326,7 +328,9 @@ lexToken = do
     AlexEOF -> do let span = mkPsSpan loc1 loc1
                   liftP (setLastToken span 0)
                   return (L span CmmT_EOF)
-    AlexError (loc2,_) -> liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) (PsError PsErrCmmLexer [])
+    AlexError (loc2,_) ->
+      let msg srcLoc = mkPlainErrorMsgEnvelope srcLoc PsErrCmmLexer
+      in liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) msg
     AlexSkip inp2 _ -> do
         setInput inp2
         lexToken
diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y
index a83feff8cf..d182a6f714 100644
--- a/compiler/GHC/Cmm/Parser.y
+++ b/compiler/GHC/Cmm/Parser.y
@@ -239,7 +239,8 @@ import qualified GHC.Cmm.Parser.Monad as PD
 import GHC.Cmm.CallConv
 import GHC.Runtime.Heap.Layout
 import GHC.Parser.Lexer
-import GHC.Parser.Errors
+import GHC.Parser.Errors.Types
+import GHC.Parser.Errors.Ppr
 
 import GHC.Types.CostCentre
 import GHC.Types.ForeignCall
@@ -918,7 +919,7 @@ getLit _ = panic "invalid literal" -- TODO messy failure
 nameToMachOp :: FastString -> PD (Width -> MachOp)
 nameToMachOp name =
   case lookupUFM machOps name of
-        Nothing -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownPrimitive name)) []
+        Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownPrimitive name)
         Just m  -> return m
 
 exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr)
@@ -1083,12 +1084,14 @@ parseSafety :: String -> PD Safety
 parseSafety "safe"   = return PlaySafe
 parseSafety "unsafe" = return PlayRisky
 parseSafety "interruptible" = return PlayInterruptible
-parseSafety str      = failMsgPD $ PsError (PsErrCmmParser (CmmUnrecognisedSafety str)) []
+parseSafety str      = failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $
+                                              PsErrCmmParser (CmmUnrecognisedSafety str)
 
 parseCmmHint :: String -> PD ForeignHint
 parseCmmHint "ptr"    = return AddrHint
 parseCmmHint "signed" = return SignedHint
-parseCmmHint str      = failMsgPD $ PsError (PsErrCmmParser (CmmUnrecognisedHint str)) []
+parseCmmHint str      = failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $
+                                               PsErrCmmParser (CmmUnrecognisedHint str)
 
 -- labels are always pointers, so we might as well infer the hint
 inferCmmHint :: CmmExpr -> ForeignHint
@@ -1115,7 +1118,7 @@ happyError = PD $ \_ _ s -> unP srcParseFail s
 stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ())
 stmtMacro fun args_code = do
   case lookupUFM stmtMacros fun of
-    Nothing -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownMacro fun)) []
+    Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownMacro fun)
     Just fcode -> return $ do
         args <- sequence args_code
         code (fcode args)
@@ -1218,7 +1221,8 @@ foreignCall conv_string results_code expr_code args_code safety ret
   = do  conv <- case conv_string of
           "C"       -> return CCallConv
           "stdcall" -> return StdCallConv
-          _         -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownCConv conv_string)) []
+          _         -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $
+                                              PsErrCmmParser (CmmUnknownCConv conv_string)
         return $ do
           platform <- getPlatform
           results <- sequence results_code
@@ -1296,7 +1300,7 @@ primCall results_code name args_code
   = do
     platform <- PD.getPlatform
     case lookupUFM (callishMachOps platform) name of
-        Nothing -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownPrimitive name)) []
+        Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownPrimitive name)
         Just f  -> return $ do
                 results <- sequence results_code
                 args <- sequence args_code
@@ -1451,7 +1455,11 @@ initEnv profile = listToUFM [
   where platform = profilePlatform profile
 
 
-parseCmmFile :: DynFlags -> Module -> HomeUnit -> FilePath -> IO (Bag PsWarning, Bag PsError, Maybe (CmmGroup, [InfoProvEnt]))
+parseCmmFile :: DynFlags
+             -> Module
+             -> HomeUnit
+             -> FilePath
+             -> IO (Messages PsMessage, Messages PsMessage, Maybe (CmmGroup, [InfoProvEnt]))
 parseCmmFile dflags this_mod home_unit filename = do
   buf <- hGetStringBuffer filename
   let
@@ -1474,7 +1482,7 @@ parseCmmFile dflags this_mod home_unit filename = do
               return (cmm ++ cmm2, used_info)
             (cmm, _) = runC dflags no_module st fcode
             (warnings,errors) = getMessages pst
-        if not (isEmptyBag errors)
+        if not (isEmptyMessages errors)
          then return (warnings, errors, Nothing)
          else return (warnings, errors, Just cmm)
   where
diff --git a/compiler/GHC/Cmm/Parser/Monad.hs b/compiler/GHC/Cmm/Parser/Monad.hs
index 77124ad1b2..4a72780c2f 100644
--- a/compiler/GHC/Cmm/Parser/Monad.hs
+++ b/compiler/GHC/Cmm/Parser/Monad.hs
@@ -27,7 +27,8 @@ import Control.Monad
 
 import GHC.Driver.Session
 import GHC.Parser.Lexer
-import GHC.Parser.Errors
+import GHC.Parser.Errors.Types
+import GHC.Types.Error ( MsgEnvelope )
 import GHC.Types.SrcLoc
 import GHC.Unit.Types
 import GHC.Unit.Home
@@ -47,7 +48,7 @@ instance Monad PD where
 liftP :: P a -> PD a
 liftP (P f) = PD $ \_ _ s -> f s
 
-failMsgPD :: (SrcSpan -> PsError) -> PD a
+failMsgPD :: (SrcSpan -> MsgEnvelope PsMessage) -> PD a
 failMsgPD = liftP . failMsgP
 
 returnPD :: a -> PD a