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.

1 files changed, 85 insertions, 12 deletions

diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index 42d38c23e9..d3f72fff47 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -1492,12 +1492,45 @@ dsDo {(arg_1 | ... | arg_n); stmts} expr =
      <*> ...
      <*> argexpr(arg_n)
 
+= Relevant modules in the rest of the compiler =
+
+ApplicativeDo touches a few phases in the compiler:
+
+* Renamer: The journey begins here in the renamer, where do-blocks are
+  scheduled as outlined above and transformed into applicative
+  combinators.  However, the code is still represented as a do-block
+  with special forms of applicative statements. This allows us to
+  recover the original do-block when e.g.  printing type errors, where
+  we don't want to show any of the applicative combinators since they
+  don't exist in the source code.
+  See ApplicativeStmt and ApplicativeArg in HsExpr.
+
+* Typechecker: ApplicativeDo passes through the typechecker much like any
+  other form of expression. The only crux is that the typechecker has to
+  be aware of the special ApplicativeDo statements in the do-notation, and
+  typecheck them appropriately.
+  Relevant module: TcMatches
+
+* Desugarer: Any do-block which contains applicative statements is desugared
+  as outlined above, to use the Applicative combinators.
+  Relevant module: DsExpr
+
 -}
 
 -- | The 'Name's of @return@ and @pure@. These may not be 'returnName' and
 -- 'pureName' due to @RebindableSyntax@.
 data MonadNames = MonadNames { return_name, pure_name :: Name }
 
+instance Outputable MonadNames where
+  ppr (MonadNames {return_name=return_name,pure_name=pure_name}) =
+    hcat
+    [text "MonadNames { return_name = "
+    ,ppr return_name
+    ,text ", pure_name = "
+    ,ppr pure_name
+    ,text "}"
+    ]
+
 -- | rearrange a list of statements using ApplicativeDoStmt.  See
 -- Note [ApplicativeDo].
 rearrangeForApplicativeDo
@@ -1640,16 +1673,27 @@ stmtTreeToStmts
 -- In the spec, but we do it here rather than in the desugarer,
 -- because we need the typechecker to typecheck the <$> form rather than
 -- the bind form, which would give rise to a Monad constraint.
-stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ _), _))
+stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ fail_op), _))
                 tail _tail_fvs
   | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail
   -- See Note [ApplicativeDo and strict patterns]
-  = mkApplicativeStmt ctxt [ApplicativeArgOne noExtField pat rhs False] False tail'
-stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_))
+  = mkApplicativeStmt ctxt [ApplicativeArgOne
+                            { xarg_app_arg_one = noExtField
+                            , app_arg_pattern  = pat
+                            , arg_expr         = rhs
+                            , is_body_stmt     = False
+                            , fail_operator    = fail_op}]
+                      False tail'
+stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ fail_op),_))
                 tail _tail_fvs
   | (False,tail') <- needJoin monad_names tail
   = mkApplicativeStmt ctxt
-      [ApplicativeArgOne noExtField nlWildPatName rhs True] False tail'
+      [ApplicativeArgOne
+       { xarg_app_arg_one = noExtField
+       , app_arg_pattern  = nlWildPatName
+       , arg_expr         = rhs
+       , is_body_stmt     = True
+       , fail_operator    = fail_op}] False tail'
 
 stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =
   return (s : tail, emptyNameSet)
@@ -1663,14 +1707,30 @@ stmtTreeToStmts monad_names ctxt (StmtTreeBind before after) tail tail_fvs = do
 stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
    pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees
    let (stmts', fvss) = unzip pairs
-   let (need_join, tail') = needJoin monad_names tail
+   let (need_join, tail') =
+         if any hasStrictPattern trees
+         then (True, tail)
+         else needJoin monad_names tail
+
    (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail'
    return (stmts, unionNameSets (fvs:fvss))
  where
-   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ _), _))
-     = return (ApplicativeArgOne noExtField pat exp False, emptyFVs)
-   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) =
-     return (ApplicativeArgOne noExtField nlWildPatName exp True, emptyFVs)
+   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ fail_op), _))
+     = return (ApplicativeArgOne
+               { xarg_app_arg_one = noExtField
+               , app_arg_pattern  = pat
+               , arg_expr         = exp
+               , is_body_stmt     = False
+               , fail_operator    = fail_op
+               }, emptyFVs)
+   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ fail_op), _)) =
+     return (ApplicativeArgOne
+             { xarg_app_arg_one = noExtField
+             , app_arg_pattern  = nlWildPatName
+             , arg_expr         = exp
+             , is_body_stmt     = True
+             , fail_operator    = fail_op
+             }, emptyFVs)
    stmtTreeArg ctxt tail_fvs tree = do
      let stmts = flattenStmtTree tree
          pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)
@@ -1684,9 +1744,15 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
         if | L _ ApplicativeStmt{} <- last stmts' ->
              return (unLoc tup, emptyNameSet)
            | otherwise -> do
-             (ret,fvs) <- lookupStmtNamePoly ctxt returnMName
-             return (HsApp noExtField (noLoc ret) tup, fvs)
-     return ( ApplicativeArgMany noExtField stmts' mb_ret pat
+             ret <- lookupSyntaxName' returnMName
+             let expr = HsApp noExtField (noLoc (HsVar noExtField (noLoc ret))) tup
+             return (expr, emptyFVs)
+     return ( ApplicativeArgMany
+              { xarg_app_arg_many = noExtField
+              , app_stmts         = stmts'
+              , final_expr        = mb_ret
+              , bv_pattern        = pat
+              }
             , fvs1 `plusFV` fvs2)
 
 
@@ -1790,6 +1856,13 @@ isStrictPattern lpat =
     SplicePat{}     -> True
     _otherwise -> panic "isStrictPattern"
 
+hasStrictPattern :: ExprStmtTree -> Bool
+hasStrictPattern (StmtTreeOne (L _ (BindStmt _ pat _ _ _), _)) = isStrictPattern pat
+hasStrictPattern (StmtTreeOne _) = False
+hasStrictPattern (StmtTreeBind a b) = hasStrictPattern a || hasStrictPattern b
+hasStrictPattern (StmtTreeApplicative trees) = any hasStrictPattern trees
+
+
 isLetStmt :: LStmt a b -> Bool
 isLetStmt (L _ LetStmt{}) = True
 isLetStmt _ = False