diff options
| author | Josef Svenningsson <josefs@fb.com> | 2019-04-29 17:29:35 -0700 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2019-10-28 09:20:34 -0400 |
| commit | 6635a3f67d8e8ebafeccfdce35490601039fe216 (patch) | |
| tree | b8ee8130325706dab4036acc3025a5e1c2057841 /compiler/GHC/Hs/Expr.hs | |
| parent | 90d06fd04d7efeae337a6902887a5f67393755d7 (diff) | |
| download | haskell-6635a3f67d8e8ebafeccfdce35490601039fe216.tar.gz | |
Fix #15344: use fail when desugaring applicative-do
Applicative-do has a bug where it fails to use the monadic fail method
when desugaring patternmatches which can fail. See #15344.
This patch fixes that problem. It required more rewiring than I had expected.
Applicative-do happens mostly in the renamer; that's where decisions about
scheduling are made. This schedule is then carried through the typechecker and
into the desugarer which performs the actual translation. Fixing this bug
required sending information about the fail method from the renamer, through
the type checker and into the desugarer. Previously, the desugarer didn't
have enough information to actually desugar pattern matches correctly.
As a side effect, we also fix #16628, where GHC wouldn't catch missing
MonadFail instances with -XApplicativeDo.
Diffstat (limited to 'compiler/GHC/Hs/Expr.hs')
| -rw-r--r-- | compiler/GHC/Hs/Expr.hs | 35 |
1 files changed, 22 insertions, 13 deletions
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index a3ad2bcada..91c532d2d9 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -1906,18 +1906,27 @@ type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtCon -- | Applicative Argument data ApplicativeArg idL = ApplicativeArgOne -- A single statement (BindStmt or BodyStmt) - (XApplicativeArgOne idL) - (LPat idL) -- WildPat if it was a BodyStmt (see below) - (LHsExpr idL) - Bool -- True <=> was a BodyStmt - -- False <=> was a BindStmt - -- See Note [Applicative BodyStmt] - + { xarg_app_arg_one :: (XApplicativeArgOne idL) + , app_arg_pattern :: (LPat idL) -- WildPat if it was a BodyStmt (see below) + , arg_expr :: (LHsExpr idL) + , is_body_stmt :: Bool -- True <=> was a BodyStmt + -- False <=> was a BindStmt + -- See Note [Applicative BodyStmt] + , fail_operator :: (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 + -- if the pattern match can't fail + } | ApplicativeArgMany -- do { stmts; return vars } - (XApplicativeArgMany idL) - [ExprLStmt idL] -- stmts - (HsExpr idL) -- return (v1,..,vn), or just (v1,..,vn) - (LPat idL) -- (v1,...,vn) + { xarg_app_arg_many :: (XApplicativeArgMany idL) + , app_stmts :: [ExprLStmt idL] -- stmts + , final_expr :: (HsExpr idL) -- return (v1,..,vn), or just (v1,..,vn) + , bv_pattern :: (LPat idL) -- (v1,...,vn) + } | XApplicativeArg (XXApplicativeArg idL) type instance XApplicativeArgOne (GhcPass _) = NoExtField @@ -2144,7 +2153,7 @@ pprStmt (ApplicativeStmt _ args mb_join) flattenStmt stmt = [ppr stmt] flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc] - flattenArg (_, ApplicativeArgOne _ pat expr isBody) + flattenArg (_, ApplicativeArgOne _ pat expr isBody _) | isBody = -- See Note [Applicative BodyStmt] [ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr :: ExprStmt (GhcPass idL))] @@ -2164,7 +2173,7 @@ pprStmt (ApplicativeStmt _ args mb_join) else text "join" <+> parens ap_expr pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc - pp_arg (_, ApplicativeArgOne _ pat expr isBody) + pp_arg (_, ApplicativeArgOne _ pat expr isBody _) | isBody = -- See Note [Applicative BodyStmt] ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr :: ExprStmt (GhcPass idL)) |