diff options
author | Vladislav Zavialov <vlad.z.4096@gmail.com> | 2020-02-15 12:39:00 +0300 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-02-18 20:16:07 -0500 |
commit | 40d917fb3b99bdb63e7e39d517225d441aaf722d (patch) | |
tree | 484133ca5ed916a8d349548b1ebe5d6db317bf3f | |
parent | d7029cc09edc052c2f97effe33233c53340fcce0 (diff) | |
download | haskell-40d917fb3b99bdb63e7e39d517225d441aaf722d.tar.gz |
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.
-rw-r--r-- | compiler/GHC/Cmm/Monad.hs | 16 | ||||
-rw-r--r-- | compiler/GHC/Cmm/Parser.y | 12 | ||||
-rw-r--r-- | compiler/parser/Lexer.x | 10 | ||||
m--------- | utils/haddock | 0 |
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 |