Commit c2f76b5f authored by cgibbard's avatar cgibbard Committed by Jonathan DK Gibbons

Change the fail operator argument of BindStmt to be a Maybe

Don't use noSyntaxExpr for it. There is no good way to defensively case
on that, nor is it clear one ought to do so.

(cherry picked from commit 5db93f50)
parent f6f03d94
......@@ -1753,8 +1753,8 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
(LPat idL)
body
(SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind in Stmts]
(SyntaxExpr idR) -- The fail operator
-- The fail operator is noSyntaxExpr
(Maybe (SyntaxExpr idR)) -- The fail operator
-- The fail operator is Nothing
-- if the pattern match can't fail
-- | 'ApplicativeStmt' represents an applicative expression built with
......@@ -1921,13 +1921,14 @@ data ApplicativeArg idL
, is_body_stmt :: Bool -- True <=> was a BodyStmt
-- False <=> was a BindStmt
-- See Note [Applicative BodyStmt]
, fail_operator :: (SyntaxExpr idL) -- The fail operator
, fail_operator :: Maybe (SyntaxExpr idL) -- The fail operator
-- The fail operator is needed if this is a BindStmt
-- where the pattern can fail. E.g.:
-- (Just a) <- stmt
-- The fail operator will be invoked if the pattern
-- match fails.
-- The fail operator is noSyntaxExpr
-- It is also used for guards in MonadComprehensions.
-- The fail operator is Nothing
-- if the pattern match can't fail
}
| ApplicativeArgMany -- do { stmts; return vars }
......@@ -2166,7 +2167,7 @@ pprStmt (ApplicativeStmt _ args mb_join)
[ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr
:: ExprStmt (GhcPass idL))]
| otherwise =
[ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr
[ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr Nothing
:: ExprStmt (GhcPass idL))]
flattenArg (_, ApplicativeArgMany _ stmts _ _) =
concatMap flattenStmt stmts
......@@ -2186,7 +2187,7 @@ pprStmt (ApplicativeStmt _ args mb_join)
ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr
:: ExprStmt (GhcPass idL))
| otherwise =
ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr
ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr Nothing
:: ExprStmt (GhcPass idL))
pp_arg (_, ApplicativeArgMany _ stmts return pat) =
ppr pat <+>
......
......@@ -317,8 +317,8 @@ mkLastStmt body = LastStmt noExtField body False noSyntaxExpr
mkBodyStmt body
= BodyStmt noExtField body noSyntaxExpr noSyntaxExpr
mkBindStmt pat body
= BindStmt noExtField pat body noSyntaxExpr noSyntaxExpr
mkTcBindStmt pat body = BindStmt unitTy pat body noSyntaxExpr noSyntaxExpr
= BindStmt noExtField pat body noSyntaxExpr Nothing
mkTcBindStmt pat body = BindStmt unitTy pat body noSyntaxExpr Nothing
-- don't use placeHolderTypeTc above, because that panics during zonking
emptyRecStmt' :: forall idL idR body.
......
......@@ -718,7 +718,7 @@ addTickStmt _isGuard (BindStmt x pat e bind fail) = do
(addTickLPat pat)
(addTickLHsExprRHS e)
(addTickSyntaxExpr hpcSrcSpan bind)
(addTickSyntaxExpr hpcSrcSpan fail)
(mapM (addTickSyntaxExpr hpcSrcSpan) fail)
addTickStmt isGuard (BodyStmt x e bind' guard') = do
liftM3 (BodyStmt x)
(addTick isGuard e)
......@@ -774,7 +774,7 @@ addTickApplicativeArg isGuard (op, arg) =
<$> addTickLPat pat
<*> addTickLHsExpr expr
<*> pure isBody
<*> addTickSyntaxExpr hpcSrcSpan fail
<*> mapM (addTickSyntaxExpr hpcSrcSpan) fail
addTickArg (ApplicativeArgMany x stmts ret pat) =
(ApplicativeArgMany x)
<$> addTickLStmts isGuard stmts
......
......@@ -928,7 +928,7 @@ dsDo stmts
do_arg (ApplicativeArgOne _ pat expr _ fail_op) =
((pat, fail_op), dsLExpr expr)
do_arg (ApplicativeArgMany _ stmts ret pat) =
((pat, noSyntaxExpr), dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
((pat, Nothing), dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
do_arg (XApplicativeArg nec) = noExtCon nec
; rhss' <- sequence rhss
......@@ -962,7 +962,7 @@ dsDo stmts
where
new_bind_stmt = cL loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats)
mfix_app bind_op
noSyntaxExpr -- Tuple cannot fail
Nothing -- Tuple cannot fail
tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids
tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case
......@@ -989,19 +989,28 @@ dsDo stmts
go _ (TransStmt {}) _ = panic "dsDo TransStmt"
go _ (XStmtLR nec) _ = noExtCon nec
dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
dsHandleMonadicFailure :: 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 fail_op =
case shareFailureHandler match of
MatchResult_Unfailable body -> body
MatchResult_Failable body -> do
dflags <- getDynFlags
fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
fail_expr <- dsSyntaxExpr fail_op [fail_msg]
body fail_expr
mk_fail_msg :: HasSrcSpan e => DynFlags -> e -> String
dsHandleMonadicFailure pat match m_fail_op
| matchCanFail match = 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]
extractMatchResult match fail_expr
| otherwise =
extractMatchResult match (error "It can't fail")
mk_fail_msg :: DynFlags -> Located e -> String
mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
showPpr dflags (getLoc pat)
......
module DsExpr where
import GhcPrelude ( Maybe )
import GHC.Hs ( HsExpr, LHsExpr, LHsLocalBinds, LPat, SyntaxExpr )
import DsMonad ( DsM, MatchResult )
import CoreSyn ( CoreExpr )
......@@ -9,4 +12,4 @@ dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> Maybe (SyntaxExpr GhcTc) -> DsM CoreExpr
......@@ -591,7 +591,7 @@ dsMcStmt (ParStmt bind_ty blocks mzip_op bind_op) stmts_rest
mkBoxedTupleTy [t1,t2]))
exps_w_tys
; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest }
; dsMcBindStmt pat rhs bind_op Nothing bind_ty stmts_rest }
where
ds_inner (ParStmtBlock _ stmts bndrs return_op)
= do { exp <- dsInnerMonadComp stmts bndrs return_op
......@@ -615,7 +615,7 @@ matchTuple ids body
dsMcBindStmt :: LPat GhcTc
-> CoreExpr -- ^ the desugared rhs of the bind statement
-> SyntaxExpr GhcTc
-> SyntaxExpr GhcTc
-> Maybe (SyntaxExpr GhcTc)
-> Type -- ^ S in (>>=) :: Q -> (R -> S) -> T
-> [ExprLStmt GhcTc]
-> DsM CoreExpr
......
......@@ -1684,7 +1684,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ fail_op
, is_body_stmt = False
, fail_operator = fail_op}]
False tail'
stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ fail_op),_))
stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ guard_op),_))
tail _tail_fvs
| (False,tail') <- needJoin monad_names tail
= mkApplicativeStmt ctxt
......@@ -1693,7 +1693,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ fail_op),_)
, app_arg_pattern = nlWildPatName
, arg_expr = rhs
, is_body_stmt = True
, fail_operator = fail_op}] False tail'
, fail_operator = Just guard_op}] False tail'
stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =
return (s : tail, emptyNameSet)
......@@ -1729,7 +1729,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
, app_arg_pattern = nlWildPatName
, arg_expr = exp
, is_body_stmt = True
, fail_operator = fail_op
, fail_operator = Just fail_op
}, emptyFVs)
stmtTreeArg ctxt tail_fvs tree = do
let stmts = flattenStmtTree tree
......@@ -2148,16 +2148,16 @@ badIpBinds what binds
monadFailOp :: LPat GhcPs
-> HsStmtContext Name
-> RnM (SyntaxExpr GhcRn, FreeVars)
-> RnM (Maybe (SyntaxExpr GhcRn), FreeVars)
monadFailOp pat ctxt
-- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.)
-- we should not need to fail.
| isIrrefutableHsPat pat = return (noSyntaxExpr, emptyFVs)
| isIrrefutableHsPat pat = return (Nothing, emptyFVs)
-- For non-monadic contexts (e.g. guard patterns, list
-- comprehensions, etc.) we should not need to fail. See Note
-- [Failing pattern matches in Stmts]
| not (isMonadFailStmtContext ctxt) = return (noSyntaxExpr, emptyFVs)
| not (isMonadFailStmtContext ctxt) = return (Nothing, emptyFVs)
| otherwise = getMonadFailOp
......@@ -2185,11 +2185,12 @@ So, in this case, we synthesize the function
(rather than plain 'fail') for the 'fail' operation. This is done in
'getMonadFailOp'.
-}
getMonadFailOp :: RnM (SyntaxExpr GhcRn, FreeVars) -- Syntax expr fail op
getMonadFailOp :: RnM (Maybe (SyntaxExpr GhcRn), FreeVars) -- Syntax expr fail op
getMonadFailOp
= do { xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags
; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags
; reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings
; (fail, fvs) <- reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings
; return (Just fail, fvs)
}
where
reallyGetMonadFailOp rebindableSyntax overloadedStrings
......
......@@ -1253,7 +1253,9 @@ zonkStmt env zBody (BindStmt bind_ty pat body bind_op fail_op)
; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty
; new_body <- zBody env1 body
; (env2, new_pat) <- zonkPat env1 pat
; (_, new_fail) <- zonkSyntaxExpr env1 fail_op
; new_fail <- case fail_op of
Nothing -> return Nothing
Just f -> fmap (Just . snd) (zonkSyntaxExpr env1 f)
; return ( env2
, BindStmt new_bind_ty new_pat new_body new_bind new_fail) }
......@@ -1296,7 +1298,10 @@ zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join)
zonk_arg env (ApplicativeArgOne x pat expr isBody fail_op)
= do { new_expr <- zonkLExpr env expr
; (_, new_fail) <- zonkSyntaxExpr env fail_op
; new_fail <- forM fail_op $ \old_fail ->
do { (_, fail') <- zonkSyntaxExpr env old_fail
; return fail'
}
; return (ApplicativeArgOne x pat new_expr isBody new_fail) }
zonk_arg env (ApplicativeArgMany x stmts ret pat)
= do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts
......
......@@ -572,7 +572,9 @@ tcMcStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside
; return (rhs', pat', thing, new_res_ty) }
-- If (but only if) the pattern can fail, typecheck the 'fail' operator
; fail_op' <- tcMonadFailOp (MCompPatOrigin pat) pat' fail_op new_res_ty
; fail_op' <- fmap join . forM fail_op $ \fail ->
tcMonadFailOp (MCompPatOrigin pat) pat' fail new_res_ty
; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) }
......@@ -832,7 +834,8 @@ tcDoStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside
; return (rhs', pat', new_res_ty, thing) }
-- If (but only if) the pattern can fail, typecheck the 'fail' operator
; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op new_res_ty
; fail_op' <- fmap join . forM fail_op $ \fail ->
tcMonadFailOp (DoPatOrigin pat) pat' fail new_res_ty
; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) }
......@@ -928,16 +931,17 @@ tcMonadFailOp :: CtOrigin
-> LPat GhcTcId
-> SyntaxExpr GhcRn -- The fail op
-> TcType -- Type of the whole do-expression
-> TcRn (SyntaxExpr GhcTcId) -- Typechecked fail op
-- Get a 'fail' operator expression, to use if the pattern
-- match fails. If the pattern is irrefutatable, just return
-- noSyntaxExpr; it won't be used
-> TcRn (Maybe (SyntaxExpr GhcTcId)) -- Typechecked fail op
-- Get a 'fail' operator expression, to use if the pattern match fails.
-- This won't be used in cases where we've already determined the pattern
-- match can't fail (so the fail op is Nothing), however, it seems that the
-- isIrrefutableHsPat test is still required here for some reason I haven't
-- yet determined.
tcMonadFailOp orig pat fail_op res_ty
| isIrrefutableHsPat pat
= return noSyntaxExpr
= return Nothing
| otherwise
= snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy]
= Just . snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy]
(mkCheckExpType res_ty) $ \_ -> return ())
{-
......@@ -1026,7 +1030,8 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
do { rhs' <- tcMonoExprNC rhs (mkCheckExpType exp_ty)
; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
return ()
; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op body_ty
; fail_op' <- fmap join . forM fail_op $ \fail ->
tcMonadFailOp (DoPatOrigin pat) pat' fail body_ty
; return (ApplicativeArgOne
{ app_arg_pattern = pat'
......
......@@ -2084,7 +2084,7 @@ tcUserStmt (dL->L loc (BodyStmt _ expr _ _))
(cL loc (VarPat noExtField (cL loc fresh_it)))
(nlHsApp ghciStep rn_expr)
(mkRnSyntaxExpr bindIOName)
noSyntaxExpr
Nothing
-- [; print it]
print_it = cL loc $ BodyStmt noExtField
......
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