diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index d140829544c3a86da9f62d92c9e0bf89665208f4..d8fefe16601c733ac0c94e932421c88d52205f5a 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -768,16 +768,18 @@ 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
- addTickArg (ApplicativeArgMany x stmts ret pat) =
+ <*> addTickSyntaxExpr hpcSrcSpan fail
+ addTickArg (ApplicativeArgMany x stmts ret pat fail) =
(ApplicativeArgMany x)
<$> addTickLStmts isGuard stmts
<*> (unLoc <$> addTickLHsExpr (cL hpcSrcSpan ret))
<*> addTickLPat pat
+ <*> addTickSyntaxExpr hpcSrcSpan fail
addTickArg (XApplicativeArg _) = panic "addTickApplicativeArg"
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 89ca815ed53d7b4294152afc962e4113d2f82fe6..2a454fa3448337f19612bd9106d065b913bfc38a 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -37,7 +37,6 @@ import HsSyn
import TcType
import TcEvidence
import TcRnMonad
-import TcHsSyn
import Type
import CoreSyn
import CoreUtils
@@ -927,25 +926,39 @@ dsDo stmts
let
(pats, rhss) = unzip (map (do_arg . snd) args)
- do_arg (ApplicativeArgOne _ pat expr _) =
- (pat, dsLExpr expr)
- do_arg (ApplicativeArgMany _ stmts ret pat) =
- (pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
+ do_arg (ApplicativeArgOne _ pat expr _ fail_op) =
+ ((pat, fail_op), dsLExpr expr)
+ do_arg (ApplicativeArgMany _ stmts ret pat fail_op) =
+ ((pat, fail_op), dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
do_arg (XApplicativeArg _) = panic "dsDo"
- arg_tys = map hsLPatType pats
+-- arg_tys = map (hsLPatType . fst) pats
+{-
+ ; dflags <- getDynFlags
+
+ ; liftIO $ printSDoc PageMode dflags stdout (defaultDumpStyle dflags{dumpFlags = insert Opt_D_ppr_debug (dumpFlags dflags)})
+ (vcat [text "Desugar ApplicativeStmt"
+ ,debugPprType body_ty
+ ,hsep (map debugPprType arg_tys)
+ ,ppr mb_join
+ ,text ""
+ ])
+-}
; 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 noExt $
- 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 2ab2acbe3fa6bb355d0a0ea1f59ab92a6df69d2b..2dd3802aa5ab908cdf9a834c1cfc78081f42be24 100644
--- a/compiler/hieFile/HieAst.hs
+++ b/compiler/hieFile/HieAst.hs
@@ -1039,11 +1039,11 @@ 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
]
- toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM
+ toHie (RS sc (ApplicativeArgMany _ stmts _ pat _)) = concatM
[ toHie $ listScopes NoScope stmts
, toHie $ PS Nothing sc NoScope pat
]
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index b86f4a147d78805769dd830cdb89a6e992b63689..3c5e7b2352e2930d912469cb992dc641ee65bc57 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -1989,12 +1989,18 @@ data ApplicativeArg idL
Bool -- True <=> was a BodyStmt
-- False <=> was a BindStmt
-- See Note [Applicative BodyStmt]
+ (SyntaxExpr idL) -- The fail operator
+ -- 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)
+ (SyntaxExpr idL) -- The fail operator
+ -- The fail operator is noSyntaxExpr
+ -- if the pattern match can't fail
| XApplicativeArg (XXApplicativeArg idL)
type instance XApplicativeArgOne (GhcPass _) = NoExt
@@ -2221,14 +2227,14 @@ 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))]
| otherwise =
[ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr
:: ExprStmt (GhcPass idL))]
- flattenArg (_, ApplicativeArgMany _ stmts _ _) =
+ flattenArg (_, ApplicativeArgMany _ stmts _ _ _) =
concatMap flattenStmt stmts
flattenArg (_, XApplicativeArg _) = panic "flattenArg"
@@ -2241,14 +2247,14 @@ 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))
| otherwise =
ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr
:: ExprStmt (GhcPass idL))
- pp_arg (_, ApplicativeArgMany _ stmts return pat) =
+ pp_arg (_, ApplicativeArgMany _ stmts return pat _) =
ppr pat <+>
text "<-" <+>
ppr (HsDo (panic "pprStmt") DoExpr (noLoc
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index 531ff46ee40a7e88c0bbed3b8141b3c47920fa6f..b1649dfefe8b89e5b1e8811d15792f5b8933be20 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -1051,8 +1051,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 _ pat _ _ _) = collectPatBinders pat
+ collectArgBinders (_, ApplicativeArgMany _ _ _ pat _) = collectPatBinders pat
collectArgBinders _ = []
collectStmtBinders XStmtLR{} = panic "collectStmtBinders"
@@ -1353,8 +1353,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 _ pat _ _ _) = lPatImplicits pat
+ do_arg (_, ApplicativeArgMany _ stmts _ _ _) = hs_lstmts stmts
do_arg (_, XApplicativeArg _) = panic "lStmtsImplicits"
hs_stmt (LetStmt _ binds) = hs_local_binds (unLoc binds)
hs_stmt (BodyStmt {}) = []
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index dd38feb3672edc7f5b9075532cacf4e242ad9fae..c81453bf35bc0f7f2c9d6743f2f799eec0be2ee8 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -1519,6 +1519,16 @@ dsDo {(arg_1 | ... | arg_n); stmts} expr =
-- '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
@@ -1661,16 +1671,16 @@ 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 noExt pat rhs False] False tail'
-stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_))
+ = mkApplicativeStmt ctxt [ApplicativeArgOne noExt pat rhs False 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 noExt nlWildPatName rhs True] False tail'
+ [ApplicativeArgOne noExt nlWildPatName rhs True fail_op] False tail'
stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =
return (s : tail, emptyNameSet)
@@ -1684,14 +1694,29 @@ 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
+{-
+ dflags <- getDynFlags
+
+ liftIO $ printSDoc PageMode dflags stdout (defaultDumpStyle dflags)
+ (vcat [text "Rn.StmtTreeApplicative"
+ ,ppr trees
+ ,ppr tail
+ ,ppr monad_names
+ ,text ""
+ ])
+-}
+
(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 noExt pat exp False, emptyFVs)
- stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) =
- return (ApplicativeArgOne noExt nlWildPatName exp True, emptyFVs)
+ stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ fail_op), _))
+ = return (ApplicativeArgOne noExt pat exp False fail_op, emptyFVs)
+ stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ fail_op), _)) =
+ return (ApplicativeArgOne noExt nlWildPatName exp True fail_op, emptyFVs)
stmtTreeArg ctxt tail_fvs tree = do
let stmts = flattenStmtTree tree
pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)
@@ -1707,8 +1732,9 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
| otherwise -> do
(ret,fvs) <- lookupStmtNamePoly ctxt returnMName
return (HsApp noExt (noLoc ret) tup, fvs)
- return ( ApplicativeArgMany noExt stmts' mb_ret pat
- , fvs1 `plusFV` fvs2)
+ (fail_op, fvs3) <- getMonadFailOp
+ return ( ApplicativeArgMany noExt stmts' mb_ret pat fail_op
+ , fvs1 `plusFV` fvs2 `plusFV` fvs3)
-- | Divide a sequence of statements into segments, where no segment
@@ -1811,6 +1837,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 52783e72102474f68183abe8ff2d33bf2a46118f..4acff6a28aa5e6ae7fb8035166f6495e206d7d63 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -1257,19 +1257,20 @@ 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 (_, ApplicativeArgMany _ _ _ pat) = pat
+ get_pat (_, ApplicativeArgOne _ pat _ _ _) = pat
+ get_pat (_, ApplicativeArgMany _ _ _ pat _) = pat
get_pat (_, XApplicativeArg _) = panic "zonkStmt"
- replace_pat pat (op, ApplicativeArgOne x _ a isBody)
- = (op, ApplicativeArgOne x pat a isBody)
- replace_pat pat (op, ApplicativeArgMany x a b _)
- = (op, ApplicativeArgMany x a b pat)
+ 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 _ fail_op)
+ = (op, ApplicativeArgMany x a b pat fail_op)
replace_pat _ (_, XApplicativeArg _) = panic "zonkStmt"
zonk_args env args
@@ -1287,13 +1288,15 @@ 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) }
- zonk_arg env (ApplicativeArgMany x stmts ret pat)
+ ; (_, new_fail) <- zonkSyntaxExpr env fail_op
+ ; return (ApplicativeArgOne x pat new_expr isBody new_fail) }
+ zonk_arg env (ApplicativeArgMany x stmts ret pat fail_op)
= do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts
; new_ret <- zonkExpr env1 ret
- ; return (ApplicativeArgMany x new_stmts new_ret pat) }
+ ; (_, new_fail) <- zonkSyntaxExpr env1 fail_op
+ ; return (ApplicativeArgMany x new_stmts new_ret pat new_fail) }
zonk_arg _ (XApplicativeArg _) = panic "zonkStmt.XApplicativeArg"
zonkStmt _ _ (XStmtLR _) = panic "zonkStmt"
diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs
index 6b727ed5aaa36eb7ba4460a26d489d39c0912f24..e749da7eacc62624a58b5999314c2eaf2dc70a74 100644
--- a/compiler/typecheck/TcMatches.hs
+++ b/compiler/typecheck/TcMatches.hs
@@ -992,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
@@ -1012,35 +1012,39 @@ 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 x pat rhs isBody 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)
- = do { (stmts', (ret',pat')) <-
+ ; return (ApplicativeArgOne x pat' rhs' isBody fail_op') }
+
+ goArg body_ty (ApplicativeArgMany x stmts ret pat fail_op, pat_ty, exp_ty)
+ = do { (stmts', (ret',pat', fail_op')) <-
tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $
\res_ty -> do
{ L _ ret' <- tcMonoExprNC (noLoc ret) res_ty
; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
return ()
- ; return (ret', pat')
+ ; monad_ty_var <- newFlexiTyVarTy (liftedTypeKind `mkVisFunTy` liftedTypeKind)
+ ; let monad_type = mkAppTy monad_ty_var body_ty
+ ; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op monad_type
+ ; return (ret', pat', fail_op')
}
- ; return (ApplicativeArgMany x stmts' ret' pat') }
+ ; return (ApplicativeArgMany x stmts' ret' pat' fail_op') }
- goArg (XApplicativeArg _, _, _) = panic "tcApplicativeStmts"
+ goArg _ (XApplicativeArg _, _, _) = panic "tcApplicativeStmts"
get_arg_bndrs :: ApplicativeArg GhcTcId -> [Id]
- get_arg_bndrs (ApplicativeArgOne _ pat _ _) = collectPatBinders pat
- get_arg_bndrs (ApplicativeArgMany _ _ _ pat) = collectPatBinders pat
- get_arg_bndrs (XApplicativeArg _) = panic "tcApplicativeStmts"
-
+ get_arg_bndrs (ApplicativeArgOne _ pat _ _ _) = collectPatBinders pat
+ get_arg_bndrs (ApplicativeArgMany _ _ _ pat _) = collectPatBinders pat
+ get_arg_bndrs (XApplicativeArg _) = panic "tcApplicativeStmts"
{- Note [ApplicativeDo and constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/testsuite/tests/ado/T15344.hs b/testsuite/tests/ado/T15344.hs
new file mode 100644
index 0000000000000000000000000000000000000000..3956423ef6ea43288fa0dab83b5e68de9ba0ba0b
--- /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 0000000000000000000000000000000000000000..4a584e4989262b5560db8504e40e2dcb591c6edf
--- /dev/null
+++ b/testsuite/tests/ado/T15344.stdout
@@ -0,0 +1 @@
+Nothing
diff --git a/testsuite/tests/ado/all.T b/testsuite/tests/ado/all.T
index 866e414da8d361614e704e7e688e9051c18c6679..574367a6825e869470bd4e72f0396ce6b7adfca9 100644
--- a/testsuite/tests/ado/all.T
+++ b/testsuite/tests/ado/all.T
@@ -12,3 +12,4 @@ 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, [''])