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.

16 files changed, 390 insertions, 68 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 {})         = []
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index 6138c26ec2..6dd6d37a9a 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -769,11 +769,12 @@ addTickApplicativeArg
 addTickApplicativeArg isGuard (op, arg) =
   liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
  where
-  addTickArg (ApplicativeArgOne x pat expr isBody) =
+  addTickArg (ApplicativeArgOne x pat expr isBody fail) =
     (ApplicativeArgOne x)
       <$> addTickLPat pat
       <*> addTickLHsExpr expr
       <*> pure isBody
+      <*> addTickSyntaxExpr hpcSrcSpan fail
   addTickArg (ApplicativeArgMany x stmts ret pat) =
     (ApplicativeArgMany x)
       <$> addTickLStmts isGuard stmts
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 8d6ddf03e1..cfb799e05f 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -37,7 +37,6 @@ import GHC.Hs
 import TcType
 import TcEvidence
 import TcRnMonad
-import TcHsSyn
 import Type
 import CoreSyn
 import CoreUtils
@@ -924,25 +923,26 @@ dsDo stmts
              let
                (pats, rhss) = unzip (map (do_arg . snd) args)
 
-               do_arg (ApplicativeArgOne _ pat expr _) =
-                 (pat, dsLExpr expr)
+               do_arg (ApplicativeArgOne _ pat expr _ fail_op) =
+                 ((pat, fail_op), dsLExpr expr)
                do_arg (ApplicativeArgMany _ stmts ret pat) =
-                 (pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
+                 ((pat, noSyntaxExpr), dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
                do_arg (XApplicativeArg nec) = noExtCon nec
 
-               arg_tys = map hsPatType pats
-
            ; rhss' <- sequence rhss
 
-           ; let body' = noLoc $ HsDo body_ty DoExpr (noLoc stmts)
+           ; body' <- dsLExpr $ noLoc $ HsDo body_ty DoExpr (noLoc stmts)
 
-           ; let fun = cL noSrcSpan $ HsLam noExtField $
-                   MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats
-                                                       body']
-                      , mg_ext = MatchGroupTc arg_tys body_ty
-                      , mg_origin = Generated }
+           ; let match_args (pat, fail_op) (vs,body)
+                   = do { var   <- selectSimpleMatchVarL pat
+                        ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
+                                   body_ty (cantFailMatchResult body)
+                        ; match_code <- handle_failure pat match fail_op
+                        ; return (var:vs, match_code)
+                        }
 
-           ; fun' <- dsLExpr fun
+           ; (vars, body) <- foldrM match_args ([],body') pats
+           ; let fun' = mkLams vars body
            ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r]
            ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss')
            ; case mb_join of
diff --git a/compiler/hieFile/HieAst.hs b/compiler/hieFile/HieAst.hs
index 52f8c59a4d..ca91056e06 100644
--- a/compiler/hieFile/HieAst.hs
+++ b/compiler/hieFile/HieAst.hs
@@ -1177,7 +1177,7 @@ instance ( a ~ GhcPass p
          , Data (StmtLR a a (Located (HsExpr a)))
          , Data (HsLocalBinds a)
          ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where
-  toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM
+  toHie (RS sc (ApplicativeArgOne _ pat expr _ _)) = concatM
     [ toHie $ PS Nothing sc NoScope pat
     , toHie expr
     ]
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
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index 8ae3a8dc18..744af979b1 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -1260,17 +1260,18 @@ zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join)
   = do  { (env1, new_mb_join)   <- zonk_join env mb_join
         ; (env2, new_args)      <- zonk_args env1 args
         ; new_body_ty           <- zonkTcTypeToTypeX env2 body_ty
-        ; return (env2, ApplicativeStmt new_body_ty new_args new_mb_join) }
+        ; return ( env2
+                 , ApplicativeStmt new_body_ty new_args new_mb_join) }
   where
     zonk_join env Nothing  = return (env, Nothing)
     zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j
 
-    get_pat (_, ApplicativeArgOne _ pat _ _) = pat
+    get_pat (_, ApplicativeArgOne _ pat _ _ _) = pat
     get_pat (_, ApplicativeArgMany _ _ _ pat) = pat
     get_pat (_, XApplicativeArg nec) = noExtCon nec
 
-    replace_pat pat (op, ApplicativeArgOne x _ a isBody)
-      = (op, ApplicativeArgOne x pat a isBody)
+    replace_pat pat (op, ApplicativeArgOne x _ a isBody fail_op)
+      = (op, ApplicativeArgOne x pat a isBody fail_op)
     replace_pat pat (op, ApplicativeArgMany x a b _)
       = (op, ApplicativeArgMany x a b pat)
     replace_pat _ (_, XApplicativeArg nec) = noExtCon nec
@@ -1290,9 +1291,10 @@ zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join)
            ; return (env2, (new_op, new_arg) : new_args) }
     zonk_args_rev env [] = return (env, [])
 
-    zonk_arg env (ApplicativeArgOne x pat expr isBody)
+    zonk_arg env (ApplicativeArgOne x pat expr isBody fail_op)
       = do { new_expr <- zonkLExpr env expr
-           ; return (ApplicativeArgOne x pat new_expr isBody) }
+           ; (_, new_fail) <- zonkSyntaxExpr env fail_op
+           ; 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
            ; new_ret           <- zonkExpr env1 ret
diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs
index 139f729fea..82985ecf84 100644
--- a/compiler/typecheck/TcMatches.hs
+++ b/compiler/typecheck/TcMatches.hs
@@ -12,6 +12,7 @@ TcMatches: Typecheck some @Matches@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
                    TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker,
@@ -991,7 +992,7 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
 
       -- Typecheck each ApplicativeArg separately
       -- See Note [ApplicativeDo and constraints]
-      ; args' <- mapM goArg (zip3 args pat_tys exp_tys)
+      ; args' <- mapM (goArg body_ty) (zip3 args pat_tys exp_tys)
 
       -- Bring into scope all the things bound by the args,
       -- and typecheck the thing_inside
@@ -1011,18 +1012,30 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
            ; ops' <- goOps t_i ops
            ; return (op' : ops') }
 
-    goArg :: (ApplicativeArg GhcRn, Type, Type)
+    goArg :: Type -> (ApplicativeArg GhcRn, Type, Type)
           -> TcM (ApplicativeArg GhcTcId)
 
-    goArg (ApplicativeArgOne x pat rhs isBody, pat_ty, exp_ty)
+    goArg body_ty (ApplicativeArgOne
+                    { app_arg_pattern = pat
+                    , arg_expr        = rhs
+                    , fail_operator   = fail_op
+                    , ..
+                    }, pat_ty, exp_ty)
       = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $
         addErrCtxt (pprStmtInCtxt ctxt (mkBindStmt pat rhs))   $
         do { rhs' <- tcMonoExprNC rhs (mkCheckExpType exp_ty)
            ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
                           return ()
-           ; return (ApplicativeArgOne x pat' rhs' isBody) }
+           ; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op body_ty
 
-    goArg (ApplicativeArgMany x stmts ret pat, pat_ty, exp_ty)
+           ; return (ApplicativeArgOne
+                      { app_arg_pattern = pat'
+                      , arg_expr        = rhs'
+                      , fail_operator   = fail_op'
+                      , .. }
+                    ) }
+
+    goArg _body_ty (ApplicativeArgMany x stmts ret pat, pat_ty, exp_ty)
       = do { (stmts', (ret',pat')) <-
                 tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $
                 \res_ty  -> do
@@ -1033,14 +1046,13 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
                   }
            ; return (ApplicativeArgMany x stmts' ret' pat') }
 
-    goArg (XApplicativeArg nec, _, _) = noExtCon nec
+    goArg _body_ty (XApplicativeArg nec, _, _) = noExtCon nec
 
     get_arg_bndrs :: ApplicativeArg GhcTcId -> [Id]
-    get_arg_bndrs (ApplicativeArgOne _ pat _ _)  = collectPatBinders pat
-    get_arg_bndrs (ApplicativeArgMany _ _ _ pat) = collectPatBinders pat
+    get_arg_bndrs (ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat
+    get_arg_bndrs (ApplicativeArgMany { bv_pattern =  pat }) = collectPatBinders pat
     get_arg_bndrs (XApplicativeArg nec)          = noExtCon nec
 
-
 {- Note [ApplicativeDo and constraints]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 An applicative-do is supposed to take place in parallel, so
diff --git a/testsuite/tests/ado/T13242a.stderr b/testsuite/tests/ado/T13242a.stderr
index f31307df50..22804add1c 100644
--- a/testsuite/tests/ado/T13242a.stderr
+++ b/testsuite/tests/ado/T13242a.stderr
@@ -11,7 +11,7 @@ T13242a.hs:10:5: error:
            _ <- return 'a'
            _ <- return 'b'
            return (x == x)
-      In an equation for ‘test’:
+    • In an equation for ‘test’:
           test
             = do A x <- undefined
                  _ <- return 'a'
@@ -32,15 +32,10 @@ T13242a.hs:13:11: error:
         ...plus 21 others
         ...plus six instances involving out-of-scope types
         (use -fprint-potential-instances to see them all)
-    • In a stmt of a 'do' block: return (x == x)
+    • In the first argument of ‘return’, namely ‘(x == x)’
+      In a stmt of a 'do' block: return (x == x)
       In the expression:
         do A x <- undefined
            _ <- return 'a'
            _ <- return 'b'
            return (x == x)
-      In an equation for ‘test’:
-          test
-            = do A x <- undefined
-                 _ <- return 'a'
-                 _ <- return 'b'
-                 return (x == x)
diff --git a/testsuite/tests/ado/T15344.hs b/testsuite/tests/ado/T15344.hs
new file mode 100644
index 0000000000..3956423ef6
--- /dev/null
+++ b/testsuite/tests/ado/T15344.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE ApplicativeDo #-}
+
+f :: Maybe (Maybe Int) -> Maybe Int -> Maybe Int
+f mgs mid = do
+    _ <- mid
+    (Just moi) <- mgs
+    pure (moi + 42)
+
+main :: IO ()
+main = print (f (Just Nothing) (Just 2))
diff --git a/testsuite/tests/ado/T15344.stdout b/testsuite/tests/ado/T15344.stdout
new file mode 100644
index 0000000000..4a584e4989
--- /dev/null
+++ b/testsuite/tests/ado/T15344.stdout
@@ -0,0 +1 @@
+Nothing
diff --git a/testsuite/tests/ado/T16628.hs b/testsuite/tests/ado/T16628.hs
new file mode 100644
index 0000000000..8508c19e7f
--- /dev/null
+++ b/testsuite/tests/ado/T16628.hs
@@ -0,0 +1,14 @@
+-- Bug.hs
+{-# LANGUAGE ApplicativeDo #-}
+module Main where
+
+import Data.Functor.Identity
+
+f :: Identity () -> Identity [Int] -> Identity Int
+f i0 i1 = do
+    _ <- i0
+    [x] <- i1
+    pure (x + 42)
+
+main :: IO ()
+main = print $ f (Identity ()) (Identity [])
diff --git a/testsuite/tests/ado/T16628.stderr b/testsuite/tests/ado/T16628.stderr
new file mode 100644
index 0000000000..6ea95f1754
--- /dev/null
+++ b/testsuite/tests/ado/T16628.stderr
@@ -0,0 +1,15 @@
+
+T16628.hs:10:5:
+   No instance for (MonadFail Identity)
+        arising from a do statement
+        with the failable pattern ‘[x]’
+     In a stmt of a 'do' block: [x] <- i1
+      In the expression:
+        do _ <- i0
+           [x] <- i1
+           pure (x + 42)
+      In an equation for ‘f’:
+          f i0 i1
+            = do _ <- i0
+                 [x] <- i1
+                 pure (x + 42)
diff --git a/testsuite/tests/ado/ado001.stdout b/testsuite/tests/ado/ado001.stdout
index 365860f55e..6f56cceaa0 100644
--- a/testsuite/tests/ado/ado001.stdout
+++ b/testsuite/tests/ado/ado001.stdout
@@ -9,4 +9,4 @@ a; ((b | c) | d)
 ((a | (b; c)) | d) | e
 ((a | b); (c | d)) | e
 a | b
-a | (b; c)
+(a | (b; c))
diff --git a/testsuite/tests/ado/ado008.hs b/testsuite/tests/ado/ado008.hs
new file mode 100644
index 0000000000..b72930496f
--- /dev/null
+++ b/testsuite/tests/ado/ado008.hs
@@ -0,0 +1,187 @@
+{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, ApplicativeDo,
+             RebindableSyntax  #-}
+{- This module is mostly a copy of ado001 but tests that all those
+   functions work when we have RebindableSyntax enabled
+-}
+module Main where
+
+import Prelude hiding (return, (>>=), pure, (<*>), fmap)
+import Text.PrettyPrint as PP
+
+(a:b:c:d:e:f:g:h:_) = map (\c -> doc [c]) ['a'..]
+
+-- a | b
+test1 :: M ()
+test1 = do
+  x1 <- a
+  x2 <- b
+  const (return ()) (x1,x2)
+
+-- no parallelism
+test2 :: M ()
+test2 = do
+  x1 <- a
+  x2 <- const g x1
+  const (return ()) (x1,x2)
+
+-- a | (b;g) | e
+test3 :: M ()
+test3 = do
+  x1 <- a
+  x2 <- b
+  x3 <- const g x2
+  x4 <- e
+  return () `const` (x1,x2,x3,x4)
+
+-- (a ; (b | g)) | c
+-- or
+-- ((a | b); g) | c
+test4 :: M ()
+test4 = do
+  x1 <- a
+  x2 <- b
+  x3 <- const g x1
+  x4 <- c
+  return () `const` (x2,x3,x4)
+
+-- (a | b | c); (g | h)
+test5 :: M ()
+test5 = do
+  x1 <- a
+  x2 <- b
+  x3 <- c
+  x4 <- const g x1
+  x5 <- const h x3
+  return () `const` (x3,x4,x5)
+
+-- b/c in parallel, e/f in parallel
+-- a; (b | (c; (d; (e | (f; g)))))
+test6 :: M ()
+test6 = do
+  x1 <- a
+  x2 <- const b x1
+  x3 <- const c x1
+  x4 <- const d x3
+  x5 <- const e x4
+  x6 <- const f x4
+  x7 <- const g x6
+  return () `const` (x1,x2,x3,x4,x5,x6,x7)
+
+-- (a | b); (c | d)
+test7 :: M ()
+test7 = do
+  x1 <- a
+  x2 <- b
+  x3 <- const c x1
+  x4 <- const d x2
+  return () `const` (x3,x4)
+
+-- a; (b | c | d)
+--
+-- alternative (but less good):
+-- ((a;b) | c); d
+test8 :: M ()
+test8 = do
+  x1 <- a
+  x2 <- const b x1
+  x3 <- c
+  x4 <- const d x1
+  return () `const` (x2,x3,x4)
+
+-- test that Lets don't get in the way
+-- ((a | (b; c)) | d) | e
+test9 :: M ()
+test9 = do
+  x1 <- a
+  let x = doc "x"  -- this shouldn't get in the way of grouping a/b
+  x2 <- b
+  x3 <- const c x2
+  x4 <- d
+  x5 <- e
+  let y = doc "y"
+  return ()
+
+-- ((a | b) ; (c | d)) | e
+test10 :: M ()
+test10 = do
+  x1 <- a
+  x2 <- b
+  let z1 = (x1,x2)
+  x3 <- const c x1
+  let z2 = (x1,x2)
+  x4 <- const d z1
+  x5 <- e
+  return (const () (x3,x4,x5))
+
+-- (a | b)
+-- This demonstrated a bug in RnExpr.segments (#11612)
+test11 :: M ()
+test11 = do
+  x1 <- a
+  let x2 = x1
+  x3 <- b
+  let x4 = c
+      x5 = x4
+  return (const () (x1,x2,x3,x4))
+
+-- (a | (b ; c))
+-- The strict pattern match forces (b;c), but a can still be parallel (#13875)
+test12 :: M ()
+test12 = do
+  x1 <- a
+  () <- b
+  x2 <- c
+  return (const () (x1,x2))
+
+main = mapM_ run
+ [ test1
+ , test2
+ , test3
+ , test4
+ , test5
+ , test6
+ , test7
+ , test8
+ , test9
+ , test10
+ , test11
+ , test12
+ ]
+
+-- Testing code, prints out the structure of a monad/applicative expression
+
+newtype M a = M (Bool -> (Maybe Doc, a))
+
+maybeParen True d = parens d
+maybeParen _ d = d
+
+run :: M a -> IO ()
+run (M m) = print d where (Just d,_) = m False
+
+fmap f m = m >>= (return . f)
+
+join :: M (M a) -> M a
+join x =  x >>= id
+
+pure a = M $ \_ -> (Nothing, a)
+
+M f <*> M a = M $ \p ->
+  let (Just d1, f') = f True
+      (Just d2, a') = a True
+  in
+      (Just (maybeParen p (d1 <+> char '|' <+> d2)), f' a')
+
+return = pure
+
+M m >>= k = M $ \p ->
+  let (d1, a) = m True
+      (d2, b) = case k a of M f -> f True
+  in
+  case (d1,d2) of
+    (Nothing,Nothing) -> (Nothing, b)
+    (Just d, Nothing) -> (Just d, b)
+    (Nothing, Just d) -> (Just d, b)
+    (Just d1, Just d2) -> (Just (maybeParen p (d1 PP.<> semi <+> d2)), b)
+
+doc :: String -> M ()
+doc d = M $ \_ -> (Just (text d), ())
diff --git a/testsuite/tests/ado/all.T b/testsuite/tests/ado/all.T
index 866e414da8..634aae2314 100644
--- a/testsuite/tests/ado/all.T
+++ b/testsuite/tests/ado/all.T
@@ -5,6 +5,7 @@ test('ado004', normalise_version('base','ghc-prim','integer-gmp'), compile, ['']
 test('ado005', normal, compile_fail, [''])
 test('ado006', normal, compile, [''])
 test('ado007', normal, compile, [''])
+test('ado008', normal, compile, [''])
 test('T11607', normal, compile_and_run, [''])
 test('ado-optimal', normal, compile_and_run, [''])
 test('T12490', normal, compile, [''])
@@ -12,3 +13,5 @@ test('T13242', normal, compile, [''])
 test('T13242a', normal, compile_fail, [''])
 test('T13875', normal, compile_and_run, [''])
 test('T14163', normal, compile_and_run, [''])
+test('T15344', normal, compile_and_run, [''])
+test('T16628', normal, compile_fail, [''])