Commit 40d917fb authored by Vladislav Zavialov's avatar Vladislav Zavialov Committed by Marge Bot

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.
parent d7029cc0
{-# 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
......@@ -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
......
......@@ -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)
......
Subproject commit d838d08f0ac0173dc704d51191b1c1976964b6f1
Subproject commit 40591606251693956d9729ab3a15c7244d7fc2a4
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment