Commit ebf6b7b6 authored by cgibbard's avatar cgibbard Committed by John Ericson

Add a new default language extension FallibleDo which when disabled allows the...

Add a new default language extension FallibleDo which when disabled allows the syntax translation in terms of MonadFail to be disabled altogether, handling failed patterns with calls to error instead.
parent e396f67f
Pipeline #13807 failed with stages
in 154 minutes
......@@ -56,6 +56,8 @@ import TyCoRep
import Type
import DsUtils (isTrueLHsExpr)
import Maybes
import EnumSet (EnumSet)
import qualified EnumSet
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad (when, forM_, zipWithM)
......@@ -1264,7 +1266,7 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) vars pm_result
flag_i = wopt Opt_WarnOverlappingPatterns dflags
flag_u = exhaustive dflags kind
flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag kind)
flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag (extensionFlags dflags) kind)
is_rec_upd = case kind of { RecUpd -> True; _ -> False }
-- See Note [Inaccessible warnings for record updates]
......@@ -1332,27 +1334,33 @@ allPmCheckWarnings =
-- | Check whether the exhaustiveness checker should run (exhaustiveness only)
exhaustive :: DynFlags -> HsMatchContext id -> Bool
exhaustive dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag
exhaustive dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag (extensionFlags dflags)
-- | Denotes whether an exhaustiveness check is supported, and if so,
-- via which 'WarningFlag' it's controlled.
-- Returns 'Nothing' if check is not supported.
exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag
exhaustiveWarningFlag (FunRhs {}) = Just Opt_WarnIncompletePatterns
exhaustiveWarningFlag CaseAlt = Just Opt_WarnIncompletePatterns
exhaustiveWarningFlag IfAlt = Just Opt_WarnIncompletePatterns
exhaustiveWarningFlag LambdaExpr = Just Opt_WarnIncompleteUniPatterns
exhaustiveWarningFlag PatBindRhs = Just Opt_WarnIncompleteUniPatterns
exhaustiveWarningFlag PatBindGuards = Just Opt_WarnIncompletePatterns
exhaustiveWarningFlag ProcExpr = Just Opt_WarnIncompleteUniPatterns
exhaustiveWarningFlag RecUpd = Just Opt_WarnIncompletePatternsRecUpd
exhaustiveWarningFlag ThPatSplice = Nothing
exhaustiveWarningFlag PatSyn = Nothing
exhaustiveWarningFlag ThPatQuote = Nothing
exhaustiveWarningFlag (StmtCtxt {}) = Nothing -- Don't warn about incomplete patterns
-- in list comprehensions, pattern guards
-- etc. They are often *supposed* to be
-- incomplete
exhaustiveWarningFlag :: EnumSet LangExt.Extension -> HsMatchContext id -> Maybe WarningFlag
exhaustiveWarningFlag exts = \case
(FunRhs {}) -> Just Opt_WarnIncompletePatterns
CaseAlt -> Just Opt_WarnIncompletePatterns
IfAlt -> Just Opt_WarnIncompletePatterns
LambdaExpr -> Just Opt_WarnIncompleteUniPatterns
PatBindRhs -> Just Opt_WarnIncompleteUniPatterns
PatBindGuards -> Just Opt_WarnIncompletePatterns
ProcExpr -> Just Opt_WarnIncompleteUniPatterns
RecUpd -> Just Opt_WarnIncompletePatternsRecUpd
ThPatSplice -> Nothing
PatSyn -> Nothing
ThPatQuote -> Nothing
(StmtCtxt DoExpr) | not (EnumSet.member LangExt.FallibleDo exts) ->
Just Opt_WarnIncompleteUniPatterns
(StmtCtxt MDoExpr) | not (EnumSet.member LangExt.FallibleDo exts) ->
Just Opt_WarnIncompleteUniPatterns
(StmtCtxt {}) -> Nothing
-- Don't warn about incomplete patterns
-- in list comprehensions, pattern guards
-- etc. They are often *supposed* to be
-- incomplete
-- True <==> singular
pprContext :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
......
......@@ -61,7 +61,7 @@ import Util
import Bag
import Outputable
import PatSyn
import qualified GHC.LanguageExtensions.Type as LangExt
import Control.Monad
{-
......@@ -919,7 +919,7 @@ dsDo stmts
; var <- selectSimpleMatchVarL pat
; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
res1_ty (cantFailMatchResult body)
; match_code <- dsHandleMonadicFailure pat match fail_op
; match_code <- dsHandleMonadicFailure res1_ty pat match fail_op
; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
go _ (ApplicativeStmt body_ty args mb_join) stmts
......@@ -941,7 +941,7 @@ dsDo stmts
= do { var <- selectSimpleMatchVarL pat
; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
body_ty (cantFailMatchResult body)
; match_code <- dsHandleMonadicFailure pat match fail_op
; match_code <- dsHandleMonadicFailure body_ty pat match fail_op
; return (var:vs, match_code)
}
......@@ -995,25 +995,26 @@ dsDo stmts
go _ (TransStmt {}) _ = panic "dsDo TransStmt"
go _ (XStmtLR nec) _ = noExtCon nec
dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> Maybe (SyntaxExpr GhcTc) -> DsM CoreExpr
dsHandleMonadicFailure :: Type -> LPat GhcTc -> MatchResult -> Maybe (SyntaxExpr GhcTc) -> DsM CoreExpr
-- In a do expression, pattern-match failure just calls
-- the monadic 'fail' rather than throwing an exception
dsHandleMonadicFailure pat match m_fail_op =
dsHandleMonadicFailure ty pat match m_fail_op =
case shareFailureHandler match of
MatchResult_Unfailable body -> body
MatchResult_Failable body -> do
fail_op <- case m_fail_op of
-- Note that (non-monadic) list comprehension, pattern guards, etc could
-- have fallible bindings without an explicit failure op, but this is
-- handled elsewhere. See Note [Failing pattern matches in Stmts] the
-- breakdown of regular and special binds.
Nothing -> pprPanic "missing fail op" $
text "Pattern match:" <+> ppr pat <+>
text "is failable, and fail_expr was left unset"
Just fail_op -> pure fail_op
dflags <- getDynFlags
fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
fail_expr <- dsSyntaxExpr fail_op [fail_msg]
fail_expr <- case m_fail_op of
-- Note that (non-monadic) list comprehension, pattern guards, etc could
-- have fallible bindings without either an explicit failure or
-- `-XNoFallibleDo`, but this is handled elsewhere. See Note [Failing
-- pattern matches in Stmts] the breakdown of regular and special binds.
Nothing -> do
let xNoFallibleDo = not $ xopt LangExt.FallibleDo dflags
MASSERT2(xNoFallibleDo, text "Pattern match:" <+> ppr pat <+> text "is failable, and fail_expr was left unset")
mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString (StmtCtxt (DoExpr :: HsStmtContext Name)))
Just fail_op -> do
fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
dsSyntaxExpr fail_op [fail_msg]
body fail_expr
mk_fail_msg :: DynFlags -> Located e -> String
......
......@@ -3,6 +3,7 @@ module DsExpr where
import GhcPrelude ( Maybe )
import GHC.Hs ( HsExpr, LHsExpr, LHsLocalBinds, LPat, SyntaxExpr )
import TcType ( Type )
import DsMonad ( DsM, MatchResult )
import CoreSyn ( CoreExpr )
import GHC.Hs.Extension ( GhcTc)
......@@ -12,4 +13,4 @@ dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> Maybe (SyntaxExpr GhcTc) -> DsM CoreExpr
dsHandleMonadicFailure :: Type -> LPat GhcTc -> MatchResult -> Maybe (SyntaxExpr GhcTc) -> DsM CoreExpr
......@@ -624,7 +624,7 @@ dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts
; var <- selectSimpleMatchVarL pat
; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
res1_ty (cantFailMatchResult body)
; match_code <- dsHandleMonadicFailure pat match fail_op
; match_code <- dsHandleMonadicFailure res1_ty pat match fail_op
; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
-- Desugar nested monad comprehensions, for example in `then..` constructs
......
......@@ -2315,7 +2315,8 @@ languageExtensions Nothing
-- NB: MonoPatBinds is no longer the default
languageExtensions (Just Haskell98)
= [LangExt.ImplicitPrelude,
= [LangExt.FallibleDo,
LangExt.ImplicitPrelude,
-- See Note [When is StarIsType enabled]
LangExt.StarIsType,
LangExt.CUSKs,
......@@ -2332,7 +2333,8 @@ languageExtensions (Just Haskell98)
]
languageExtensions (Just Haskell2010)
= [LangExt.ImplicitPrelude,
= [LangExt.FallibleDo,
LangExt.ImplicitPrelude,
-- See Note [When is StarIsType enabled]
LangExt.StarIsType,
LangExt.CUSKs,
......@@ -4459,6 +4461,7 @@ xFlagsDeps = [
flagSpec "ExplicitForAll" LangExt.ExplicitForAll,
flagSpec "ExplicitNamespaces" LangExt.ExplicitNamespaces,
flagSpec "ExtendedDefaultRules" LangExt.ExtendedDefaultRules,
flagSpec "FallibleDo" LangExt.FallibleDo,
flagSpec "FlexibleContexts" LangExt.FlexibleContexts,
flagSpec "FlexibleInstances" LangExt.FlexibleInstances,
flagSpec "ForeignFunctionInterface" LangExt.ForeignFunctionInterface,
......
......@@ -2186,26 +2186,25 @@ So, in this case, we synthesize the function
-}
getMonadFailOp :: RnM (Maybe (SyntaxExpr GhcRn), FreeVars) -- Syntax expr fail op
getMonadFailOp
= do { xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags
; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags
; (fail, fvs) <- reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings
; return (Just fail, fvs)
}
where
reallyGetMonadFailOp rebindableSyntax overloadedStrings
| rebindableSyntax && overloadedStrings = do
(failExpr, failFvs) <- lookupSyntaxName failMName
(fromStringExpr, fromStringFvs) <- lookupSyntaxName fromStringName
let arg_lit = fsLit "arg"
arg_name = mkSystemVarName (mkVarOccUnique arg_lit) arg_lit
arg_syn_expr = mkRnSyntaxExpr arg_name
let body :: LHsExpr GhcRn =
nlHsApp (noLoc $ syn_expr failExpr)
(nlHsApp (noLoc $ syn_expr fromStringExpr)
(noLoc $ syn_expr arg_syn_expr))
let failAfterFromStringExpr :: HsExpr GhcRn =
unLoc $ mkHsLam [noLoc $ VarPat noExtField $ noLoc arg_name] body
let failAfterFromStringSynExpr :: SyntaxExpr GhcRn =
mkSyntaxExpr failAfterFromStringExpr
return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs)
| otherwise = lookupSyntaxName failMName
= do xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags
xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags
xNoFallibleDo <- fmap (not . xopt LangExt.FallibleDo) getDynFlags
if | xNoFallibleDo -> return (Nothing, emptyFVs)
| xRebindableSyntax && xOverloadedStrings -> do
(failExpr, failFvs) <- lookupSyntaxName failMName
(fromStringExpr, fromStringFvs) <- lookupSyntaxName fromStringName
let arg_lit = fsLit "arg"
arg_name = mkSystemVarName (mkVarOccUnique arg_lit) arg_lit
arg_syn_expr = mkRnSyntaxExpr arg_name
let body :: LHsExpr GhcRn =
nlHsApp (noLoc $ syn_expr failExpr)
(nlHsApp (noLoc $ syn_expr fromStringExpr)
(noLoc $ syn_expr arg_syn_expr))
let failAfterFromStringExpr :: HsExpr GhcRn =
unLoc $ mkHsLam [noLoc $ VarPat noExtField $ noLoc arg_name] body
let failAfterFromStringSynExpr :: SyntaxExpr GhcRn =
mkSyntaxExpr failAfterFromStringExpr
return (Just failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs)
| otherwise -> do
(fail, fvs) <- lookupSyntaxName failMName
return (Just fail, fvs)
......@@ -143,4 +143,5 @@ data Extension
| ImportQualifiedPost
| CUSKs
| StandaloneKindSignatures
| FallibleDo
deriving (Eq, Enum, Show, Generic, Bounded)
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