Commit 6635a3f6 authored by Josef Svenningsson's avatar Josef Svenningsson Committed by Marge Bot

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.
parent 90d06fd0
Pipeline #11909 passed with stages
in 960 minutes and 43 seconds
...@@ -1906,18 +1906,27 @@ type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtCon ...@@ -1906,18 +1906,27 @@ type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtCon
-- | Applicative Argument -- | Applicative Argument
data ApplicativeArg idL data ApplicativeArg idL
= ApplicativeArgOne -- A single statement (BindStmt or BodyStmt) = ApplicativeArgOne -- A single statement (BindStmt or BodyStmt)
(XApplicativeArgOne idL) { xarg_app_arg_one :: (XApplicativeArgOne idL)
(LPat idL) -- WildPat if it was a BodyStmt (see below) , app_arg_pattern :: (LPat idL) -- WildPat if it was a BodyStmt (see below)
(LHsExpr idL) , arg_expr :: (LHsExpr idL)
Bool -- True <=> was a BodyStmt , is_body_stmt :: Bool -- True <=> was a BodyStmt
-- False <=> was a BindStmt -- False <=> was a BindStmt
-- See Note [Applicative BodyStmt] -- 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 } | ApplicativeArgMany -- do { stmts; return vars }
(XApplicativeArgMany idL) { xarg_app_arg_many :: (XApplicativeArgMany idL)
[ExprLStmt idL] -- stmts , app_stmts :: [ExprLStmt idL] -- stmts
(HsExpr idL) -- return (v1,..,vn), or just (v1,..,vn) , final_expr :: (HsExpr idL) -- return (v1,..,vn), or just (v1,..,vn)
(LPat idL) -- (v1,...,vn) , bv_pattern :: (LPat idL) -- (v1,...,vn)
}
| XApplicativeArg (XXApplicativeArg idL) | XApplicativeArg (XXApplicativeArg idL)
type instance XApplicativeArgOne (GhcPass _) = NoExtField type instance XApplicativeArgOne (GhcPass _) = NoExtField
...@@ -2144,7 +2153,7 @@ pprStmt (ApplicativeStmt _ args mb_join) ...@@ -2144,7 +2153,7 @@ pprStmt (ApplicativeStmt _ args mb_join)
flattenStmt stmt = [ppr stmt] flattenStmt stmt = [ppr stmt]
flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc] flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc]
flattenArg (_, ApplicativeArgOne _ pat expr isBody) flattenArg (_, ApplicativeArgOne _ pat expr isBody _)
| isBody = -- See Note [Applicative BodyStmt] | isBody = -- See Note [Applicative BodyStmt]
[ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr [ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr
:: ExprStmt (GhcPass idL))] :: ExprStmt (GhcPass idL))]
...@@ -2164,7 +2173,7 @@ pprStmt (ApplicativeStmt _ args mb_join) ...@@ -2164,7 +2173,7 @@ pprStmt (ApplicativeStmt _ args mb_join)
else text "join" <+> parens ap_expr else text "join" <+> parens ap_expr
pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc
pp_arg (_, ApplicativeArgOne _ pat expr isBody) pp_arg (_, ApplicativeArgOne _ pat expr isBody _)
| isBody = -- See Note [Applicative BodyStmt] | isBody = -- See Note [Applicative BodyStmt]
ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr
:: ExprStmt (GhcPass idL)) :: ExprStmt (GhcPass idL))
......
...@@ -1040,8 +1040,8 @@ collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmt ...@@ -1040,8 +1040,8 @@ collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmt
collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
collectStmtBinders (ApplicativeStmt _ args _) = concatMap collectArgBinders args collectStmtBinders (ApplicativeStmt _ args _) = concatMap collectArgBinders args
where where
collectArgBinders (_, ApplicativeArgOne _ pat _ _) = collectPatBinders pat collectArgBinders (_, ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat
collectArgBinders (_, ApplicativeArgMany _ _ _ pat) = collectPatBinders pat collectArgBinders (_, ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders pat
collectArgBinders _ = [] collectArgBinders _ = []
collectStmtBinders (XStmtLR nec) = noExtCon nec collectStmtBinders (XStmtLR nec) = noExtCon nec
...@@ -1344,8 +1344,8 @@ lStmtsImplicits = hs_lstmts ...@@ -1344,8 +1344,8 @@ lStmtsImplicits = hs_lstmts
-> [(SrcSpan, [Name])] -> [(SrcSpan, [Name])]
hs_stmt (BindStmt _ pat _ _ _) = lPatImplicits pat hs_stmt (BindStmt _ pat _ _ _) = lPatImplicits pat
hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args
where do_arg (_, ApplicativeArgOne _ pat _ _) = lPatImplicits pat where do_arg (_, ApplicativeArgOne { app_arg_pattern = pat }) = lPatImplicits pat
do_arg (_, ApplicativeArgMany _ stmts _ _) = hs_lstmts stmts do_arg (_, ApplicativeArgMany { app_stmts = stmts }) = hs_lstmts stmts
do_arg (_, XApplicativeArg nec) = noExtCon nec do_arg (_, XApplicativeArg nec) = noExtCon nec
hs_stmt (LetStmt _ binds) = hs_local_binds (unLoc binds) hs_stmt (LetStmt _ binds) = hs_local_binds (unLoc binds)
hs_stmt (BodyStmt {}) = [] hs_stmt (BodyStmt {}) = []
......
...@@ -769,11 +769,12 @@ addTickApplicativeArg ...@@ -769,11 +769,12 @@ addTickApplicativeArg
addTickApplicativeArg isGuard (op, arg) = addTickApplicativeArg isGuard (op, arg) =
liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg) liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
where where
addTickArg (ApplicativeArgOne x pat expr isBody) = addTickArg (ApplicativeArgOne x pat expr isBody fail) =
(ApplicativeArgOne x) (ApplicativeArgOne x)
<$> addTickLPat pat <$> addTickLPat pat
<*> addTickLHsExpr expr <*> addTickLHsExpr expr
<*> pure isBody <*> pure isBody
<*> addTickSyntaxExpr hpcSrcSpan fail
addTickArg (ApplicativeArgMany x stmts ret pat) = addTickArg (ApplicativeArgMany x stmts ret pat) =
(ApplicativeArgMany x) (ApplicativeArgMany x)
<$> addTickLStmts isGuard stmts <$> addTickLStmts isGuard stmts
......
...@@ -37,7 +37,6 @@ import GHC.Hs ...@@ -37,7 +37,6 @@ import GHC.Hs
import TcType import TcType
import TcEvidence import TcEvidence
import TcRnMonad import TcRnMonad
import TcHsSyn
import Type import Type
import CoreSyn import CoreSyn
import CoreUtils import CoreUtils
...@@ -924,25 +923,26 @@ dsDo stmts ...@@ -924,25 +923,26 @@ dsDo stmts
let let
(pats, rhss) = unzip (map (do_arg . snd) args) (pats, rhss) = unzip (map (do_arg . snd) args)
do_arg (ApplicativeArgOne _ pat expr _) = do_arg (ApplicativeArgOne _ pat expr _ fail_op) =
(pat, dsLExpr expr) ((pat, fail_op), dsLExpr expr)
do_arg (ApplicativeArgMany _ stmts ret pat) = 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 do_arg (XApplicativeArg nec) = noExtCon nec
arg_tys = map hsPatType pats
; rhss' <- sequence rhss ; 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 $ ; let match_args (pat, fail_op) (vs,body)
MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats = do { var <- selectSimpleMatchVarL pat
body'] ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
, mg_ext = MatchGroupTc arg_tys body_ty body_ty (cantFailMatchResult body)
, mg_origin = Generated } ; 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] ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r]
; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss') ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss')
; case mb_join of ; case mb_join of
......
...@@ -1177,7 +1177,7 @@ instance ( a ~ GhcPass p ...@@ -1177,7 +1177,7 @@ instance ( a ~ GhcPass p
, Data (StmtLR a a (Located (HsExpr a))) , Data (StmtLR a a (Located (HsExpr a)))
, Data (HsLocalBinds a) , Data (HsLocalBinds a)
) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where ) => 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 $ PS Nothing sc NoScope pat
, toHie expr , toHie expr
] ]
......
...@@ -1492,12 +1492,45 @@ dsDo {(arg_1 | ... | arg_n); stmts} expr = ...@@ -1492,12 +1492,45 @@ dsDo {(arg_1 | ... | arg_n); stmts} expr =
<*> ... <*> ...
<*> argexpr(arg_n) <*> 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 -- | The 'Name's of @return@ and @pure@. These may not be 'returnName' and
-- 'pureName' due to @RebindableSyntax@. -- 'pureName' due to @RebindableSyntax@.
data MonadNames = MonadNames { return_name, pure_name :: Name } 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 -- | rearrange a list of statements using ApplicativeDoStmt. See
-- Note [ApplicativeDo]. -- Note [ApplicativeDo].
rearrangeForApplicativeDo rearrangeForApplicativeDo
...@@ -1640,16 +1673,27 @@ stmtTreeToStmts ...@@ -1640,16 +1673,27 @@ stmtTreeToStmts
-- In the spec, but we do it here rather than in the desugarer, -- In the spec, but we do it here rather than in the desugarer,
-- because we need the typechecker to typecheck the <$> form rather than -- because we need the typechecker to typecheck the <$> form rather than
-- the bind form, which would give rise to a Monad constraint. -- 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 tail _tail_fvs
| not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail
-- See Note [ApplicativeDo and strict patterns] -- See Note [ApplicativeDo and strict patterns]
= mkApplicativeStmt ctxt [ApplicativeArgOne noExtField pat rhs False] False tail' = mkApplicativeStmt ctxt [ApplicativeArgOne
stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_)) { 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 tail _tail_fvs
| (False,tail') <- needJoin monad_names tail | (False,tail') <- needJoin monad_names tail
= mkApplicativeStmt ctxt = 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 = stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =
return (s : tail, emptyNameSet) return (s : tail, emptyNameSet)
...@@ -1663,14 +1707,30 @@ stmtTreeToStmts monad_names ctxt (StmtTreeBind before after) tail tail_fvs = do ...@@ -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 stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees
let (stmts', fvss) = unzip pairs 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' (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail'
return (stmts, unionNameSets (fvs:fvss)) return (stmts, unionNameSets (fvs:fvss))
where where
stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ _), _)) stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ fail_op), _))
= return (ApplicativeArgOne noExtField pat exp False, emptyFVs) = return (ApplicativeArgOne
stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) = { xarg_app_arg_one = noExtField
return (ApplicativeArgOne noExtField nlWildPatName exp True, emptyFVs) , 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 stmtTreeArg ctxt tail_fvs tree = do
let stmts = flattenStmtTree tree let stmts = flattenStmtTree tree
pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts) pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)
...@@ -1684,9 +1744,15 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do ...@@ -1684,9 +1744,15 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
if | L _ ApplicativeStmt{} <- last stmts' -> if | L _ ApplicativeStmt{} <- last stmts' ->
return (unLoc tup, emptyNameSet) return (unLoc tup, emptyNameSet)
| otherwise -> do | otherwise -> do
(ret,fvs) <- lookupStmtNamePoly ctxt returnMName ret <- lookupSyntaxName' returnMName
return (HsApp noExtField (noLoc ret) tup, fvs) let expr = HsApp noExtField (noLoc (HsVar noExtField (noLoc ret))) tup
return ( ApplicativeArgMany noExtField stmts' mb_ret pat return (expr, emptyFVs)
return ( ApplicativeArgMany
{ xarg_app_arg_many = noExtField
, app_stmts = stmts'
, final_expr = mb_ret
, bv_pattern = pat
}
, fvs1 `plusFV` fvs2) , fvs1 `plusFV` fvs2)
...@@ -1790,6 +1856,13 @@ isStrictPattern lpat = ...@@ -1790,6 +1856,13 @@ isStrictPattern lpat =
SplicePat{} -> True SplicePat{} -> True
_otherwise -> panic "isStrictPattern" _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 :: LStmt a b -> Bool
isLetStmt (L _ LetStmt{}) = True isLetStmt (L _ LetStmt{}) = True
isLetStmt _ = False isLetStmt _ = False
......
...@@ -1260,17 +1260,18 @@ zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join) ...@@ -1260,17 +1260,18 @@ zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join)
= do { (env1, new_mb_join) <- zonk_join env mb_join = do { (env1, new_mb_join) <- zonk_join env mb_join
; (env2, new_args) <- zonk_args env1 args ; (env2, new_args) <- zonk_args env1 args
; new_body_ty <- zonkTcTypeToTypeX env2 body_ty ; 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 where
zonk_join env Nothing = return (env, Nothing) zonk_join env Nothing = return (env, Nothing)
zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j 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 (_, ApplicativeArgMany _ _ _ pat) = pat
get_pat (_, XApplicativeArg nec) = noExtCon nec get_pat (_, XApplicativeArg nec) = noExtCon nec
replace_pat pat (op, ApplicativeArgOne x _ a isBody) replace_pat pat (op, ApplicativeArgOne x _ a isBody fail_op)
= (op, ApplicativeArgOne x pat a isBody) = (op, ApplicativeArgOne x pat a isBody fail_op)
replace_pat pat (op, ApplicativeArgMany x a b _) replace_pat pat (op, ApplicativeArgMany x a b _)
= (op, ApplicativeArgMany x a b pat) = (op, ApplicativeArgMany x a b pat)
replace_pat _ (_, XApplicativeArg nec) = noExtCon nec replace_pat _ (_, XApplicativeArg nec) = noExtCon nec
...@@ -1290,9 +1291,10 @@ zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join) ...@@ -1290,9 +1291,10 @@ zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join)
; return (env2, (new_op, new_arg) : new_args) } ; return (env2, (new_op, new_arg) : new_args) }
zonk_args_rev env [] = return (env, []) 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 = 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) zonk_arg env (ApplicativeArgMany x stmts ret pat)
= do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts
; new_ret <- zonkExpr env1 ret ; new_ret <- zonkExpr env1 ret
......
...@@ -12,6 +12,7 @@ TcMatches: Typecheck some @Matches@ ...@@ -12,6 +12,7 @@ TcMatches: Typecheck some @Matches@
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RecordWildCards #-}
module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda, module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker, TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker,
...@@ -991,7 +992,7 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside ...@@ -991,7 +992,7 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
-- Typecheck each ApplicativeArg separately -- Typecheck each ApplicativeArg separately
-- See Note [ApplicativeDo and constraints] -- 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, -- Bring into scope all the things bound by the args,
-- and typecheck the thing_inside -- and typecheck the thing_inside
...@@ -1011,18 +1012,30 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside ...@@ -1011,18 +1012,30 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
; ops' <- goOps t_i ops ; ops' <- goOps t_i ops
; return (op' : ops') } ; return (op' : ops') }
goArg :: (ApplicativeArg GhcRn, Type, Type) goArg :: Type -> (ApplicativeArg GhcRn, Type, Type)
-> TcM (ApplicativeArg GhcTcId) -> 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)) $ = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $
addErrCtxt (pprStmtInCtxt ctxt (mkBindStmt pat rhs)) $ addErrCtxt (pprStmtInCtxt ctxt (mkBindStmt pat rhs)) $
do { rhs' <- tcMonoExprNC rhs (mkCheckExpType exp_ty) do { rhs' <- tcMonoExprNC rhs (mkCheckExpType exp_ty)
; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
return () 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')) <- = do { (stmts', (ret',pat')) <-
tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $ tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $
\res_ty -> do \res_ty -> do
...@@ -1033,14 +1046,13 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside ...@@ -1033,14 +1046,13 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
} }
; return (ApplicativeArgMany x stmts' ret' pat') } ; 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 :: ApplicativeArg GhcTcId -> [Id]
get_arg_bndrs (ApplicativeArgOne _ pat _ _) = collectPatBinders pat get_arg_bndrs (ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat
get_arg_bndrs (ApplicativeArgMany _ _ _ pat) = collectPatBinders pat get_arg_bndrs (ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders pat
get_arg_bndrs (XApplicativeArg nec) = noExtCon nec get_arg_bndrs (XApplicativeArg nec) = noExtCon nec
{- Note [ApplicativeDo and constraints] {- Note [ApplicativeDo and constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
An applicative-do is supposed to take place in parallel, so An applicative-do is supposed to take place in parallel, so
......
...@@ -11,7 +11,7 @@ T13242a.hs:10:5: error: ...@@ -11,7 +11,7 @@ T13242a.hs:10:5: error:
_ <- return 'a' _ <- return 'a'
_ <- return 'b' _ <- return 'b'
return (x == x) return (x == x)
In an equation for ‘test’: In an equation for ‘test’:
test test
= do A x <- undefined = do A x <- undefined
_ <- return 'a' _ <- return 'a'
...@@ -32,15 +32,10 @@ T13242a.hs:13:11: error: ...@@ -32,15 +32,10 @@ T13242a.hs:13:11: error:
...plus 21 others ...plus 21 others
...plus six instances involving out-of-scope types ...plus six instances involving out-of-scope types
(use -fprint-potential-instances to see them all) (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: In the expression:
do A x <- undefined do A x <- undefined
_ <- return 'a' _ <- return 'a'
_ <- return 'b' _ <- return 'b'
return (x == x) return (x == x)
In an equation for ‘test’:
test
= do A x <- undefined
_ <- return 'a'
_ <- return 'b'
return (x == x)
{-# 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))
-- 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 [])
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)
...@@ -9,4 +9,4 @@ a; ((b | c) | d) ...@@ -9,4 +9,4 @@ a; ((b | c) | d)
((a | (b; c)) | d) | e ((a | (b; c)) | d) | e
((a | b); (c | d)) | e ((a | b); (c | d)) | e
a | b a | b
a | (b; c) (a | (b; c))
{-# 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