Commit 6191c6b1 authored by John Ericson's avatar John Ericson

Use trees that grow for rebindable operators for `<-` binds

Also add more documentation.
parent 5db93f50
Pipeline #13781 failed with stages
in 476 minutes and 2 seconds
......@@ -1761,15 +1761,14 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLarrow'
-- For details on above see note [Api annotations] in ApiAnnotation
| BindStmt (XBindStmt idL idR body) -- Post typechecking,
-- result type of the function passed to bind;
-- that is, S in (>>=) :: Q -> (R -> S) -> T
| BindStmt (XBindStmt idL idR body)
-- ^ Post renaming has optional fail and bind / (>>=) operator.
-- Post typechecking, also has result type of the
-- function passed to bind; that is, S in (>>=)
-- :: Q -> (R -> S) -> T
-- See Note [The type of bind in Stmts]
(LPat idL)
body
(SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind in Stmts]
(Maybe (SyntaxExpr idR)) -- The fail operator
-- The fail operator is Nothing
-- if the pattern match can't fail
-- | 'ApplicativeStmt' represents an applicative expression built with
-- '<$>' and '<*>'. It is generated by the renamer, and is desugared into the
......@@ -1882,8 +1881,8 @@ data RecStmtTc =
type instance XLastStmt (GhcPass _) (GhcPass _) b = NoExtField
type instance XBindStmt (GhcPass _) GhcPs b = NoExtField
type instance XBindStmt (GhcPass _) GhcRn b = NoExtField
type instance XBindStmt (GhcPass _) GhcTc b = Type
type instance XBindStmt (GhcPass _) GhcRn b = (SyntaxExpr GhcRn, FailOperator GhcRn)
type instance XBindStmt (GhcPass _) GhcTc b = (SyntaxExpr GhcTc, Type, FailOperator GhcTc)
type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExtField
type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExtField
......@@ -1926,24 +1925,41 @@ data ParStmtBlock idL idR
type instance XParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtField
type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtCon
-- | The fail operator
--
-- This is used for `.. <-` "bind statments" in do notation, including
-- non-monadic "binds" in applicative.
--
-- The fail operator is 'Just expr' if it potentially fail monadically. if the
-- pattern match cannot fail, or shouldn't fail monadically (regular incomplete
-- pattern exception), it is 'Nothing'.
--
-- See Note [Monad fail : Rebindable syntax, overloaded strings] for the type of
-- expression in the 'Just' case, and why it is so.
--
-- See Note [Failing pattern matches in Stmts] for which contexts for
-- '@BindStmt@'s should use the monadic fail and which shouldn't.
type FailOperator id = Maybe (SyntaxExpr id)
-- | Applicative Argument
data ApplicativeArg idL
= ApplicativeArgOne -- A single statement (BindStmt or BodyStmt)
{ xarg_app_arg_one :: (XApplicativeArgOne idL)
-- ^ The fail operator, after renaming
--
-- 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.
-- It is also used for guards in MonadComprehensions.
-- The fail operator is Nothing
-- if the pattern match can't fail
, 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 :: Maybe (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.
-- It is also used for guards in MonadComprehensions.
-- The fail operator is Nothing
-- if the pattern match can't fail
}
| ApplicativeArgMany -- do { stmts; return vars }
{ xarg_app_arg_many :: (XApplicativeArgMany idL)
......@@ -1953,7 +1969,10 @@ data ApplicativeArg idL
}
| XApplicativeArg (XXApplicativeArg idL)
type instance XApplicativeArgOne (GhcPass _) = NoExtField
type instance XApplicativeArgOne GhcPs = NoExtField
type instance XApplicativeArgOne GhcRn = FailOperator GhcRn
type instance XApplicativeArgOne GhcTc = FailOperator GhcTc
type instance XApplicativeArgMany (GhcPass _) = NoExtField
type instance XXApplicativeArg (GhcPass _) = NoExtCon
......@@ -2141,7 +2160,7 @@ pprStmt (LastStmt _ expr ret_stripped _)
= whenPprDebug (text "[last]") <+>
(if ret_stripped then text "return" else empty) <+>
ppr expr
pprStmt (BindStmt _ pat expr _ _) = hsep [ppr pat, larrow, ppr expr]
pprStmt (BindStmt _ pat expr) = hsep [ppr pat, larrow, ppr expr]
pprStmt (LetStmt _ (L _ binds)) = hsep [text "let", pprBinds binds]
pprStmt (BodyStmt _ expr _ _) = ppr expr
pprStmt (ParStmt _ stmtss _ _) = sep (punctuate (text " | ") (map ppr stmtss))
......@@ -2176,13 +2195,12 @@ 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 Nothing
:: ExprStmt (GhcPass idL))]
[ppr (BindStmt (panic "pprStmt") pat expr :: ExprStmt (GhcPass idL))]
flattenArg (_, ApplicativeArgMany _ stmts _ _) =
concatMap flattenStmt stmts
flattenArg (_, XApplicativeArg nec) = noExtCon nec
......@@ -2196,13 +2214,12 @@ 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 Nothing
:: ExprStmt (GhcPass idL))
ppr (BindStmt (panic "pprStmt") pat expr :: ExprStmt (GhcPass idL))
pp_arg (_, ApplicativeArgMany _ stmts return pat) =
ppr pat <+>
text "<-" <+>
......
......@@ -67,7 +67,8 @@ module GHC.Hs.Utils(
nlHsAppTy, nlHsAppKindTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp,
-- * Stmts
mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkTcBindStmt,
mkTransformStmt, mkTransformByStmt, mkBodyStmt,
mkPsBindStmt, mkRnBindStmt, mkTcBindStmt,
mkLastStmt,
emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt,
emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt,
......@@ -256,10 +257,10 @@ mkLastStmt :: Located (bodyR (GhcPass idR))
-> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
mkBodyStmt :: Located (bodyR GhcPs)
-> StmtLR (GhcPass idL) GhcPs (Located (bodyR GhcPs))
mkBindStmt :: (XBindStmt (GhcPass idL) (GhcPass idR)
(Located (bodyR (GhcPass idR))) ~ NoExtField)
=> LPat (GhcPass idL) -> Located (bodyR (GhcPass idR))
-> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
mkPsBindStmt :: LPat GhcPs -> Located (bodyR GhcPs)
-> StmtLR GhcPs GhcPs (Located (bodyR GhcPs))
mkRnBindStmt :: LPat GhcRn -> Located (bodyR GhcRn)
-> StmtLR GhcRn GhcRn (Located (bodyR GhcRn))
mkTcBindStmt :: LPat GhcTc -> Located (bodyR GhcTc)
-> StmtLR GhcTc GhcTc (Located (bodyR GhcTc))
......@@ -316,9 +317,9 @@ mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = s
mkLastStmt body = LastStmt noExtField body False noSyntaxExpr
mkBodyStmt body
= BodyStmt noExtField body noSyntaxExpr noSyntaxExpr
mkBindStmt pat body
= BindStmt noExtField pat body noSyntaxExpr Nothing
mkTcBindStmt pat body = BindStmt unitTy pat body noSyntaxExpr Nothing
mkPsBindStmt pat body = BindStmt noExtField pat body
mkRnBindStmt pat body = BindStmt (noSyntaxExpr, Nothing) pat body
mkTcBindStmt pat body = BindStmt (noSyntaxExpr, unitTy, Nothing) pat body
-- don't use placeHolderTypeTc above, because that panics during zonking
emptyRecStmt' :: forall idL idR body.
......@@ -1044,7 +1045,7 @@ collectLStmtBinders = collectStmtBinders . unLoc
collectStmtBinders :: StmtLR (GhcPass idL) (GhcPass idR) body
-> [IdP (GhcPass idL)]
-- Id Binders for a Stmt... [but what about pattern-sig type vars]?
collectStmtBinders (BindStmt _ pat _ _ _) = collectPatBinders pat
collectStmtBinders (BindStmt _ pat _) = collectPatBinders pat
collectStmtBinders (LetStmt _ binds) = collectLocalBinders (unLoc binds)
collectStmtBinders (BodyStmt {}) = []
collectStmtBinders (LastStmt {}) = []
......@@ -1352,7 +1353,7 @@ lStmtsImplicits = hs_lstmts
hs_stmt :: StmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))
-> [(SrcSpan, [Name])]
hs_stmt (BindStmt _ pat _ _ _) = lPatImplicits pat
hs_stmt (BindStmt _ pat _) = lPatImplicits pat
hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args
where do_arg (_, ApplicativeArgOne { app_arg_pattern = pat }) = lPatImplicits pat
do_arg (_, ApplicativeArgMany { app_stmts = stmts }) = hs_lstmts stmts
......
......@@ -684,7 +684,7 @@ translateGuard :: FamInstEnvs -> GuardStmt GhcTc -> DsM GrdVec
translateGuard fam_insts guard = case guard of
BodyStmt _ e _ _ -> translateBoolGuard e
LetStmt _ binds -> translateLet (unLoc binds)
BindStmt _ p e _ _ -> translateBind fam_insts p e
BindStmt _ p e -> translateBind fam_insts p e
LastStmt {} -> panic "translateGuard LastStmt"
ParStmt {} -> panic "translateGuard ParStmt"
TransStmt {} -> panic "translateGuard TransStmt"
......
......@@ -1146,7 +1146,7 @@ cvtStmts = mapM cvtStmt
cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs))
cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkBodyStmt e' }
cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkPsBindStmt p' e' }
cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (text "a let binding") ds
; returnL $ LetStmt noExtField (noLoc ds') }
cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss
......
......@@ -702,12 +702,12 @@ addTickStmt _isGuard (LastStmt x e noret ret) = do
(addTickLHsExpr e)
(pure noret)
(addTickSyntaxExpr hpcSrcSpan ret)
addTickStmt _isGuard (BindStmt x pat e bind fail) = do
liftM4 (BindStmt x)
(addTickLPat pat)
(addTickLHsExprRHS e)
addTickStmt _isGuard (BindStmt (bind, ty, fail) pat e) = do
liftM4 (\b f -> BindStmt (b, ty, f))
(addTickSyntaxExpr hpcSrcSpan bind)
(mapM (addTickSyntaxExpr hpcSrcSpan) fail)
(addTickLPat pat)
(addTickLHsExprRHS e)
addTickStmt isGuard (BodyStmt x e bind' guard') = do
liftM3 (BodyStmt x)
(addTick isGuard e)
......@@ -758,12 +758,12 @@ addTickApplicativeArg
addTickApplicativeArg isGuard (op, arg) =
liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
where
addTickArg (ApplicativeArgOne x pat expr isBody fail) =
(ApplicativeArgOne x)
<$> addTickLPat pat
addTickArg (ApplicativeArgOne m_fail pat expr isBody) =
ApplicativeArgOne
<$> mapM (addTickSyntaxExpr hpcSrcSpan) m_fail
<*> addTickLPat pat
<*> addTickLHsExpr expr
<*> pure isBody
<*> mapM (addTickSyntaxExpr hpcSrcSpan) fail
addTickArg (ApplicativeArgMany x stmts ret pat) =
(ApplicativeArgMany x)
<$> addTickLStmts isGuard stmts
......@@ -942,12 +942,10 @@ addTickLCmdStmts' lstmts res
binders = collectLStmtsBinders lstmts
addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))
addTickCmdStmt (BindStmt x pat c bind fail) = do
liftM4 (BindStmt x)
addTickCmdStmt (BindStmt x pat c) = do
liftM2 (BindStmt x)
(addTickLPat pat)
(addTickLHsCmd c)
(return bind)
(return fail)
addTickCmdStmt (LastStmt x c noret ret) = do
liftM3 (LastStmt x)
(addTickLHsCmd c)
......
......@@ -867,7 +867,7 @@ dsCmdStmt ids local_vars out_ids (BodyStmt c_ty cmd _ _) env_ids = do
-- It would be simpler and more consistent to do this using second,
-- but that's likely to be defined in terms of first.
dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd _ _) env_ids = do
dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd) env_ids = do
let pat_ty = hsLPatType pat
(core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd
let pat_vars = mkVarSet (collectPatBinders pat)
......
......@@ -913,7 +913,7 @@ dsDo stmts
= do { rest <- goL stmts
; dsLocalBinds binds rest }
go _ (BindStmt res1_ty pat rhs bind_op fail_op) stmts
go _ (BindStmt (bind_op, res1_ty, fail_op) pat rhs) stmts
= do { body <- goL stmts
; rhs' <- dsLExpr rhs
; var <- selectSimpleMatchVarL pat
......@@ -927,7 +927,7 @@ dsDo stmts
let
(pats, rhss) = unzip (map (do_arg . snd) args)
do_arg (ApplicativeArgOne _ pat expr _ fail_op) =
do_arg (ApplicativeArgOne fail_op pat expr _) =
((pat, fail_op), dsLExpr expr)
do_arg (ApplicativeArgMany _ stmts ret pat) =
((pat, Nothing), dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
......@@ -962,9 +962,13 @@ dsDo stmts
, recS_ret_ty = body_ty} }) stmts
= goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' }
where
new_bind_stmt = L loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats)
mfix_app bind_op
Nothing -- Tuple cannot fail
new_bind_stmt = L loc $ BindStmt
( bind_op
, bind_ty
, Nothing -- Tuple cannot fail
)
(mkBigLHsPatTupId later_pats)
mfix_app
tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids
tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case
......
......@@ -119,7 +119,7 @@ matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do
-- so we can't desugar the bindings without the
-- body expression in hand
matchGuards (BindStmt _ pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do
matchGuards (BindStmt _ pat bind_rhs : stmts) ctx rhs rhs_ty = do
let upat = unLoc pat
dicts = collectEvVarsPat upat
match_var <- selectMatchVar upat
......
......@@ -242,7 +242,7 @@ deListComp (stmt@(TransStmt {}) : quals) list = do
(inner_list_expr, pat) <- dsTransStmt stmt
deBindComp pat inner_list_expr quals list
deListComp (BindStmt _ pat list1 _ _ : quals) core_list2 = do -- rule A' above
deListComp (BindStmt _ pat list1 : quals) core_list2 = do -- rule A' above
core_list1 <- dsLExprNoLP list1
deBindComp pat core_list1 quals core_list2
......@@ -353,7 +353,7 @@ dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do
-- Anyway, we bind the newly grouped list via the generic binding function
dfBindComp c_id n_id (pat, inner_list_expr) quals
dfListComp c_id n_id (BindStmt _ pat list1 _ _ : quals) = do
dfListComp c_id n_id (BindStmt _ pat list1 : quals) = do
-- evaluate the two lists
core_list1 <- dsLExpr list1
......@@ -501,7 +501,7 @@ dsMcStmt (LetStmt _ binds) stmts
; dsLocalBinds binds rest }
-- [ .. | a <- m, stmts ]
dsMcStmt (BindStmt bind_ty pat rhs bind_op fail_op) stmts
dsMcStmt (BindStmt (bind_op, bind_ty, fail_op) pat rhs) stmts
= do { rhs' <- dsLExpr rhs
; dsMcBindStmt pat rhs' bind_op fail_op bind_ty stmts }
......
......@@ -1502,7 +1502,7 @@ repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ])
repLSts stmts = repSts (map unLoc stmts)
repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ])
repSts (BindStmt _ p e _ _ : ss) =
repSts (BindStmt _ p e : ss) =
do { e2 <- repLE e
; ss1 <- mkGenSyms (collectPatBinders p)
; addBinds ss1 $ do {
......
......@@ -1038,7 +1038,7 @@ instance ( a ~ GhcPass p
LastStmt _ body _ _ ->
[ toHie body
]
BindStmt _ pat body _ _ ->
BindStmt _ pat body ->
[ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat
, toHie body
]
......@@ -1168,7 +1168,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
]
......
......@@ -3296,7 +3296,7 @@ stmt :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) }
qual :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) }
: bindpat '<-' exp { runECP_PV $3 >>= \ $3 ->
ams (sLL $1 $> $ mkBindStmt $1 $3)
ams (sLL $1 $> $ mkPsBindStmt $1 $3)
[mu AnnLarrow $2] }
| exp { runECP_PV $1 >>= \ $1 ->
return $ sL1 $1 $ mkBodyStmt $1 }
......
......@@ -585,7 +585,7 @@ methodNamesLStmt = methodNamesStmt . unLoc
methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesStmt (LastStmt _ cmd _ _) = methodNamesLCmd cmd
methodNamesStmt (BodyStmt _ cmd _ _) = methodNamesLCmd cmd
methodNamesStmt (BindStmt _ _ cmd _ _) = methodNamesLCmd cmd
methodNamesStmt (BindStmt _ _ cmd) = methodNamesLCmd cmd
methodNamesStmt (RecStmt { recS_stmts = stmts }) =
methodNamesStmts stmts `addOneFV` loopAName
methodNamesStmt (LetStmt {}) = emptyFVs
......@@ -773,8 +773,10 @@ Many things desugar to HsStmts including monadic things like `do` and `mdo`
statements, pattern guards, and list comprehensions (see 'HsStmtContext' for an
exhaustive list). How we deal with pattern match failure is context-dependent.
* In the case of list comprehensions and pattern guards we don't need any 'fail'
function; the desugarer ignores the fail function field of 'BindStmt' entirely.
* In the case of list comprehensions and pattern guards we don't need any
'fail' function; the desugarer ignores the fail function of 'BindStmt'
entirely. That said, it ought to be 'Nothing' for clarity.
* In the case of monadic contexts (e.g. monad comprehensions, do, and mdo
expressions) we want pattern match failure to be desugared to the appropriate
'fail' function (either that of Monad or MonadFail, depending on whether
......@@ -825,7 +827,7 @@ rnStmt ctxt rnBody (L loc (BodyStmt _ body _ _)) thing_inside
; return ( ([(L loc (BodyStmt noExtField body' then_op guard_op), fv_expr)]
, thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
rnStmt ctxt rnBody (L loc (BindStmt _ pat body _ _)) thing_inside
rnStmt ctxt rnBody (L loc (BindStmt _ pat body)) thing_inside
= do { (body', fv_expr) <- rnBody body
-- The binders do not scope over the expression
; (bind_op, fvs1) <- lookupStmtName ctxt bindMName
......@@ -834,7 +836,7 @@ rnStmt ctxt rnBody (L loc (BindStmt _ pat body _ _)) thing_inside
; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
{ (thing, fvs3) <- thing_inside (collectPatBinders pat')
; return (( [( L loc (BindStmt noExtField pat' body' bind_op fail_op)
; return (( [( L loc (BindStmt (bind_op, fail_op) pat' body')
, fv_expr )]
, thing),
fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
......@@ -1094,11 +1096,11 @@ rn_rec_stmt_lhs _ (L loc (BodyStmt _ body a b))
rn_rec_stmt_lhs _ (L loc (LastStmt _ body noret a))
= return [(L loc (LastStmt noExtField body noret a), emptyFVs)]
rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body a b))
rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body))
= do
-- should the ctxt be MDo instead?
(pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
return [(L loc (BindStmt noExtField pat' body a b), fv_pat)]
return [(L loc (BindStmt noExtField pat' body), fv_pat)]
rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))))
= failWith (badIpBinds (text "an mdo expression") binds)
......@@ -1165,7 +1167,7 @@ rn_rec_stmt rnBody _ (L loc (BodyStmt _ body _ _), _)
; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
L loc (BodyStmt noExtField body' then_op noSyntaxExpr))] }
rn_rec_stmt rnBody _ (L loc (BindStmt _ pat' body _ _), fv_pat)
rn_rec_stmt rnBody _ (L loc (BindStmt _ pat' body), fv_pat)
= do { (body', fv_expr) <- rnBody body
; (bind_op, fvs1) <- lookupSyntaxName bindMName
......@@ -1174,7 +1176,7 @@ rn_rec_stmt rnBody _ (L loc (BindStmt _ pat' body _ _), fv_pat)
; let bndrs = mkNameSet (collectPatBinders pat')
fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
L loc (BindStmt noExtField pat' body' bind_op fail_op))] }
L loc (BindStmt (bind_op, fail_op) pat' body'))] }
rn_rec_stmt _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _)
= failWith (badIpBinds (text "an mdo expression") binds)
......@@ -1672,27 +1674,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 _ fail_op), _))
stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt (_, fail_op) pat rhs), _))
tail _tail_fvs
| not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail
-- See Note [ApplicativeDo and strict patterns]
= mkApplicativeStmt ctxt [ApplicativeArgOne
{ xarg_app_arg_one = noExtField
{ xarg_app_arg_one = fail_op
, 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 _ guard_op),_))
tail _tail_fvs
| (False,tail') <- needJoin monad_names tail
= mkApplicativeStmt ctxt
[ApplicativeArgOne
{ xarg_app_arg_one = noExtField
{ xarg_app_arg_one = Just guard_op
, app_arg_pattern = nlWildPatName
, arg_expr = rhs
, is_body_stmt = True
, fail_operator = Just guard_op}] False tail'
}] False tail'
stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =
return (s : tail, emptyNameSet)
......@@ -1714,21 +1716,19 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
(stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail'
return (stmts, unionNameSets (fvs:fvss))
where
stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ fail_op), _))
stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt (_, fail_op) pat exp), _))
= return (ApplicativeArgOne
{ xarg_app_arg_one = noExtField
{ xarg_app_arg_one = fail_op
, 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
{ xarg_app_arg_one = Just fail_op
, app_arg_pattern = nlWildPatName
, arg_expr = exp
, is_body_stmt = True
, fail_operator = Just fail_op
}, emptyFVs)
stmtTreeArg ctxt tail_fvs tree = do
let stmts = flattenStmtTree tree
......@@ -1805,7 +1805,7 @@ segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)
pvars = mkNameSet (collectStmtBinders (unLoc stmt))
isStrictPatternBind :: ExprLStmt GhcRn -> Bool
isStrictPatternBind (L _ (BindStmt _ pat _ _ _)) = isStrictPattern pat
isStrictPatternBind (L _ (BindStmt _ pat _)) = isStrictPattern pat
isStrictPatternBind _ = False
{-
......@@ -1856,7 +1856,7 @@ isStrictPattern lpat =
_otherwise -> panic "isStrictPattern"
hasStrictPattern :: ExprStmtTree -> Bool
hasStrictPattern (StmtTreeOne (L _ (BindStmt _ pat _ _ _), _)) = isStrictPattern pat
hasStrictPattern (StmtTreeOne (L _ (BindStmt _ pat _), _)) = isStrictPattern pat
hasStrictPattern (StmtTreeOne _) = False
hasStrictPattern (StmtTreeBind a b) = hasStrictPattern a || hasStrictPattern b
hasStrictPattern (StmtTreeApplicative trees) = any hasStrictPattern trees
......@@ -1899,9 +1899,9 @@ slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
-- strict patterns though; splitSegments expects that if we return Just
-- then we have actually done some splitting. Otherwise it will go into
-- an infinite loop (#14163).
go lets indep bndrs ((L loc (BindStmt _ pat body bind_op fail_op), fvs): rest)
go lets indep bndrs ((L loc (BindStmt (bind_op, fail_op) pat body), fvs): rest)
| isEmptyNameSet (bndrs `intersectNameSet` fvs) && not (isStrictPattern pat)
= go lets ((L loc (BindStmt noExtField pat body bind_op fail_op), fvs) : indep)
= go lets ((L loc (BindStmt (bind_op, fail_op) pat body), fvs) : indep)
bndrs' rest
where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat)
-- If we encounter a LetStmt that doesn't depend on a BindStmt in this
......@@ -2154,8 +2154,8 @@ monadFailOp pat ctxt
| isIrrefutableHsPat pat = return (Nothing, emptyFVs)
-- For non-monadic contexts (e.g. guard patterns, list
-- comprehensions, etc.) we should not need to fail. See Note
-- [Failing pattern matches in Stmts]
-- comprehensions, etc.) we should not need to fail, or failure is handled in
-- a different way. See Note [Failing pattern matches in Stmts].
| not (isMonadFailStmtContext ctxt) = return (Nothing, emptyFVs)
| otherwise = getMonadFailOp
......
......@@ -368,7 +368,7 @@ tcArrDoStmt env _ (BodyStmt _ rhs _ _) res_ty thing_inside
; thing <- thing_inside res_ty
; return (BodyStmt elt_ty rhs' noSyntaxExpr noSyntaxExpr, thing) }
tcArrDoStmt env ctxt (BindStmt _ pat rhs _ _) res_ty thing_inside
tcArrDoStmt env ctxt (BindStmt _ pat rhs) res_ty thing_inside
= do { (rhs', pat_ty) <- tc_arr_rhs env rhs
; (pat', thing) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
thing_inside res_ty
......
......@@ -831,7 +831,7 @@ gen_Ix_binds loc tycon = do
where
stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
mk_qual a b c = noLoc $ mkPsBindStmt (nlVarPat c)
(nlHsApp (nlHsVar range_RDR)
(mkLHsVarTuple [a,b]))
......@@ -1071,7 +1071,7 @@ gen_Read_binds get_fixity loc tycon
data_con_str con = occNameString (getOccName con)
read_arg a ty = ASSERT( not (isUnliftedType ty) )
noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
noLoc (mkPsBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
-- When reading field labels we might encounter
-- a = 3
......@@ -1080,7 +1080,7 @@ gen_Read_binds get_fixity loc tycon
-- Note the parens!
read_field lbl a =
[noLoc
(mkBindStmt
(mkPsBindStmt
(nlVarPat a)
(nlHsApp
read_field
......
......@@ -1235,7 +1235,7 @@ zonkStmt env _ (LetStmt x (L l binds))
= do (env1, new_binds) <- zonkLocalBinds env binds
return (env1, LetStmt x (L l new_binds))
zonkStmt env zBody (BindStmt bind_ty pat body bind_op fail_op)
zonkStmt env zBody (BindStmt (bind_op, bind_ty, fail_op) pat body)
= do { (env1, new_bind) <- zonkSyntaxExpr env bind_op
; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty
; new_body <- zBody env1 body
......@@ -1244,7 +1244,7 @@ zonkStmt env zBody (BindStmt bind_ty pat body bind_op fail_op)
Nothing -> return Nothing
Just f -> fmap (Just . snd) (zonkSyntaxExpr env1 f)
; return ( env2
, BindStmt new_bind_ty new_pat new_body new_bind new_fail) }
, BindStmt (new_bind, new_bind_ty, new_fail) new_pat new_body) }
-- Scopes: join > ops (in reverse order) > pats (in forward order)
-- > rest of stmts
......@@ -1258,12 +1258,12 @@ zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join)
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 fail_op)
= (op, ApplicativeArgOne x pat a isBody fail_op)
replace_pat pat (op, ApplicativeArgOne fail_op _ a isBody)
= (op, ApplicativeArgOne fail_op pat a isBody)
replace_pat pat (op, ApplicativeArgMany x a b _)
= (op, ApplicativeArgMany x a b pat)
replace_pat _ (_, XApplicativeArg nec) = noExtCon nec
......@@ -1283,13 +1283,13 @@ 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 fail_op)
zonk_arg env (ApplicativeArgOne fail_op pat expr isBody)
= do { new_expr <- zonkLExpr env expr
; new_fail <- forM fail_op $ \old_fail ->
do { (_, fail') <- zonkSyntaxExpr env old_fail
; return fail'
}
; return (ApplicativeArgOne x pat new_expr isBody new_fail) }
; return (ApplicativeArgOne new_fail pat new_expr isBody) }
zonk_arg env (ApplicativeArgMany x stmts ret pat)
= do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts
; new_ret <- zonkExpr env1 ret
......
......@@ -405,7 +405,7 @@ tcGuardStmt _ (BodyStmt _ guard _ _) res_ty thing_inside
; thing <- thing_inside res_ty
; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) }
tcGuardStmt ctxt (BindStmt _ pat rhs _ _) res_ty thing_inside
tcGuardStmt ctxt (BindStmt _ pat rhs) res_ty thing_inside
= do { (rhs', rhs_ty) <- tcInferRhoNC rhs
-- Stmt has a context already
; (pat', thing) <- tcPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs)
......@@ -439,7 +439,7 @@ tcLcStmt _ _ (LastStmt x body noret _) elt_ty thing_inside
; return (LastStmt x body' noret noSyntaxExpr, thing) }
-- A generator, pat <- rhs
tcLcStmt m_tc ctxt (BindStmt _ pat rhs _ _) elt_ty thing_inside
tcLcStmt m_tc ctxt (BindStmt _ pat rhs) elt_ty thing_inside
= do { pat_ty <- newFlexiTyVarTy liftedTypeKind
; rhs' <- tcMonoExpr rhs (mkCheckExpType $ mkTyConApp m_tc [pat_ty])
; (pat', thing) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
......@@ -559,7 +559,7 @@ tcMcStmt _ (LastStmt x body noret return_op) res_ty thing_inside
-- q :: a
--
tcMcStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside
tcMcStmt ctxt (BindStmt (bind_op, fail_op) pat rhs) res_ty thing_inside
-- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
= do { ((rhs', pat', thing, new_res_ty), bind_op')
<- tcSyntaxOp MCompOrigin bind_op
......@@ -576,7 +576,7 @@ tcMcStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside
tcMonadFailOp (MCompPatOrigin pat) pat' fail new_res_ty
; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) }
; return (BindStmt (bind_op', new_res_ty, fail_op') pat' rhs', thing) }
-- Boolean expressions.
--
......@@ -818,7 +818,7 @@ tcDoStmt _ (LastStmt x body noret _) res_ty thing_inside
; thing <- thing_inside (panic "tcDoStmt: thing_inside")
; return (LastStmt x body' noret noSyntaxExpr, thing) }
tcDoStmt ctxt (BindStmt _ pat