summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC/Hs/Expr.hs35
-rw-r--r--compiler/GHC/Hs/Utils.hs8
-rw-r--r--compiler/deSugar/Coverage.hs3
-rw-r--r--compiler/deSugar/DsExpr.hs26
-rw-r--r--compiler/hieFile/HieAst.hs2
-rw-r--r--compiler/rename/RnExpr.hs97
-rw-r--r--compiler/typecheck/TcHsSyn.hs14
-rw-r--r--compiler/typecheck/TcMatches.hs30
8 files changed, 156 insertions, 59 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
View Lorry Controller Status