Commit 5db93f50 authored by cgibbard's avatar cgibbard Committed by John Ericson

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.
parent 63053481
......@@ -1767,8 +1767,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
......@@ -1935,13 +1935,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 }
......@@ -2180,7 +2181,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
......@@ -2200,7 +2201,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.
......
......@@ -707,7 +707,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)
......@@ -763,7 +763,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
......
......@@ -930,7 +930,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
......@@ -964,7 +964,7 @@ dsDo stmts
where
new_bind_stmt = L 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
......@@ -991,17 +991,26 @@ 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
| matchCanFail match
= do { 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")
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 " ++
......
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
......
......@@ -1683,7 +1683,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
......@@ -1692,7 +1692,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)
......@@ -1728,7 +1728,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
......@@ -2147,16 +2147,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
......@@ -2184,11 +2184,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
......
......@@ -1240,7 +1240,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) }
......@@ -1283,7 +1285,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 (L loc (BodyStmt _ expr _ _))
(L loc (VarPat noExtField (L loc fresh_it)))
(nlHsApp ghciStep rn_expr)
(mkRnSyntaxExpr bindIOName)
noSyntaxExpr
Nothing
-- [; print it]
print_it = L 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