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.

2 files changed, 26 insertions, 17 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))
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 5d54196af2..0126cd0bac 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -1040,8 +1040,8 @@ collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmt
 collectStmtBinders (RecStmt { recS_stmts = ss })     = collectLStmtsBinders ss
 collectStmtBinders (ApplicativeStmt _ args _) = concatMap collectArgBinders args
  where
-  collectArgBinders (_, ApplicativeArgOne _ pat _ _) = collectPatBinders pat
-  collectArgBinders (_, ApplicativeArgMany _ _ _ pat) = collectPatBinders pat
+  collectArgBinders (_, ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat
+  collectArgBinders (_, ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders pat
   collectArgBinders _ = []
 collectStmtBinders (XStmtLR nec) = noExtCon nec
 
@@ -1344,8 +1344,8 @@ lStmtsImplicits = hs_lstmts
             -> [(SrcSpan, [Name])]
     hs_stmt (BindStmt _ pat _ _ _) = lPatImplicits pat
     hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args
-      where do_arg (_, ApplicativeArgOne _ pat _ _) = lPatImplicits pat
-            do_arg (_, ApplicativeArgMany _ stmts _ _) = hs_lstmts stmts
+      where do_arg (_, ApplicativeArgOne { app_arg_pattern = pat }) = lPatImplicits pat
+            do_arg (_, ApplicativeArgMany { app_stmts = stmts }) = hs_lstmts stmts
             do_arg (_, XApplicativeArg nec) = noExtCon nec
     hs_stmt (LetStmt _ binds)     = hs_local_binds (unLoc binds)
     hs_stmt (BodyStmt {})         = []