Remove the MonadFail P instance

There were two issues with this instance:

* its existence meant that a pattern match failure in the P monad would
  produce a user-visible parse error, but the error message would not be
  helpful to the user

* due to the MFP migration strategy, we had to use CPP in Lexer.x,
  and that created issues for #17750

Updates haddock submodule.

4 files changed, 11 insertions, 27 deletions

diff --git a/compiler/GHC/Cmm/Monad.hs b/compiler/GHC/Cmm/Monad.hs
index 6b8d00a118..eccaf72676 100644
--- a/compiler/GHC/Cmm/Monad.hs
+++ b/compiler/GHC/Cmm/Monad.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE CPP #-}
-
 -----------------------------------------------------------------------------
 -- A Parser monad with access to the 'DynFlags'.
 --
@@ -12,12 +10,12 @@
 module GHC.Cmm.Monad (
     PD(..)
   , liftP
+  , failMsgPD
   ) where
 
 import GhcPrelude
 
 import Control.Monad
-import qualified Control.Monad.Fail as MonadFail
 
 import DynFlags
 import Lexer
@@ -33,16 +31,13 @@ instance Applicative PD where
 
 instance Monad PD where
   (>>=) = thenPD
-#if !MIN_VERSION_base(4,13,0)
-  fail = MonadFail.fail
-#endif
-
-instance MonadFail.MonadFail PD where
-  fail = failPD
 
 liftP :: P a -> PD a
 liftP (P f) = PD $ \_ s -> f s
 
+failMsgPD :: String -> PD a
+failMsgPD = liftP . failMsgP
+
 returnPD :: a -> PD a
 returnPD = liftP . return
 
@@ -52,8 +47,5 @@ thenPD :: PD a -> (a -> PD b) -> PD b
                 POk s1 a         -> unPD (k a) d s1
                 PFailed s1 -> PFailed s1
 
-failPD :: String -> PD a
-failPD = liftP . fail
-
 instance HasDynFlags PD where
    getDynFlags = PD $ \d s -> POk s d
diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y
index ed2d95a283..2e6762e68a 100644
--- a/compiler/GHC/Cmm/Parser.y
+++ b/compiler/GHC/Cmm/Parser.y
@@ -902,7 +902,7 @@ getLit _ = panic "invalid literal" -- TODO messy failure
 nameToMachOp :: FastString -> PD (Width -> MachOp)
 nameToMachOp name =
   case lookupUFM machOps name of
-        Nothing -> fail ("unknown primitive " ++ unpackFS name)
+        Nothing -> failMsgPD ("unknown primitive " ++ unpackFS name)
         Just m  -> return m
 
 exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr)
@@ -1056,12 +1056,12 @@ parseSafety :: String -> PD Safety
 parseSafety "safe"   = return PlaySafe
 parseSafety "unsafe" = return PlayRisky
 parseSafety "interruptible" = return PlayInterruptible
-parseSafety str      = fail ("unrecognised safety: " ++ str)
+parseSafety str      = failMsgPD ("unrecognised safety: " ++ str)
 
 parseCmmHint :: String -> PD ForeignHint
 parseCmmHint "ptr"    = return AddrHint
 parseCmmHint "signed" = return SignedHint
-parseCmmHint str      = fail ("unrecognised hint: " ++ str)
+parseCmmHint str      = failMsgPD ("unrecognised hint: " ++ str)
 
 -- labels are always pointers, so we might as well infer the hint
 inferCmmHint :: CmmExpr -> ForeignHint
@@ -1088,7 +1088,7 @@ happyError = PD $ \_ s -> unP srcParseFail s
 stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ())
 stmtMacro fun args_code = do
   case lookupUFM stmtMacros fun of
-    Nothing -> fail ("unknown macro: " ++ unpackFS fun)
+    Nothing -> failMsgPD ("unknown macro: " ++ unpackFS fun)
     Just fcode -> return $ do
         args <- sequence args_code
         code (fcode args)
@@ -1189,7 +1189,7 @@ foreignCall conv_string results_code expr_code args_code safety ret
   = do  conv <- case conv_string of
           "C" -> return CCallConv
           "stdcall" -> return StdCallConv
-          _ -> fail ("unknown calling convention: " ++ conv_string)
+          _ -> failMsgPD ("unknown calling convention: " ++ conv_string)
         return $ do
           dflags <- getDynFlags
           results <- sequence results_code
@@ -1265,7 +1265,7 @@ primCall
         -> PD (CmmParse ())
 primCall results_code name args_code
   = case lookupUFM callishMachOps name of
-        Nothing -> fail ("unknown primitive " ++ unpackFS name)
+        Nothing -> failMsgPD ("unknown primitive " ++ unpackFS name)
         Just f  -> return $ do
                 results <- sequence results_code
                 args <- sequence args_code
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 98c422bd4d..bee441362f 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -41,7 +41,6 @@
 -- Alex "Haskell code fragment top"
 
 {
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiWayIf #-}
@@ -57,7 +56,7 @@ module Lexer (
    allocateComments,
    MonadP(..),
    getRealSrcLoc, getPState, withThisPackage,
-   failLocMsgP, srcParseFail,
+   failMsgP, failLocMsgP, srcParseFail,
    getErrorMessages, getMessages,
    popContext, pushModuleContext, setLastToken, setSrcLoc,
    activeContext, nextIsEOF,
@@ -74,7 +73,6 @@ import GhcPrelude
 
 -- base
 import Control.Monad
-import Control.Monad.Fail as MonadFail
 import Data.Bits
 import Data.Char
 import Data.List
@@ -2154,12 +2152,6 @@ instance Applicative P where
 
 instance Monad P where
   (>>=) = thenP
-#if !MIN_VERSION_base(4,13,0)
-  fail = MonadFail.fail
-#endif
-
-instance MonadFail.MonadFail P where
-  fail = failMsgP
 
 returnP :: a -> P a
 returnP a = a `seq` (P $ \s -> POk s a)
diff --git a/utils/haddock b/utils/haddock
-Subproject d838d08f0ac0173dc704d51191b1c1976964b6f
+Subproject 40591606251693956d9729ab3a15c7244d7fc2a