[Git][ghc/ghc][master] 3 commits: Change the fail operator argument of BindStmt to be a Maybe
Marge Bot
gitlab at gitlab.haskell.org
Sat Apr 18 17:20:09 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
a05348eb by Cale Gibbard at 2020-04-17T13:08:47-04:00
Change the fail operator argument of BindStmt to be a Maybe
Don't use noSyntaxExpr for it. There is no good way to defensively case
on that, nor is it clear one ought to do so.
- - - - -
79e27144 by John Ericson at 2020-04-17T13:08:47-04:00
Use trees that grow for rebindable operators for `<-` binds
Also add more documentation.
- - - - -
18bc16ed by Cale Gibbard at 2020-04-17T13:08:47-04:00
Use FailOperator in more places, define a couple datatypes (XBindStmtRn and XBindStmtTc) to help clarify the meaning of XBindStmt in the renamer and typechecker
- - - - -
20 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Arrows.hs
- compiler/GHC/HsToCore/Coverage.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Expr.hs-boot
- compiler/GHC/HsToCore/GuardedRHSs.hs
- compiler/GHC/HsToCore/ListComp.hs
- compiler/GHC/HsToCore/PmCheck.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Gen/Arrow.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Utils/Zonk.hs
- compiler/GHC/ThToHs.hs
- compiler/parser/Parser.y
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -1828,16 +1828,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]
- (SyntaxExpr idR) -- The fail operator
- -- The fail operator is noSyntaxExpr
- -- if the pattern match can't fail
- -- See Note [NoSyntaxExpr] (2)
-- | 'ApplicativeStmt' represents an applicative expression built with
-- '<$>' and '<*>'. It is generated by the renamer, and is desugared into the
@@ -1950,8 +1948,19 @@ 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 = XBindStmtRn
+type instance XBindStmt (GhcPass _) GhcTc b = XBindStmtTc
+
+data XBindStmtRn = XBindStmtRn
+ { xbsrn_bindOp :: SyntaxExpr GhcRn
+ , xbsrn_failOp :: FailOperator GhcRn
+ }
+
+data XBindStmtTc = XBindStmtTc
+ { xbstc_bindOp :: SyntaxExpr GhcTc
+ , xbstc_boundResultType :: Type -- If (>>=) :: Q -> (R -> S) -> T, this is S
+ , xbstc_failOp :: FailOperator GhcTc
+ }
type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExtField
type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExtField
@@ -1994,34 +2003,55 @@ 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)
- , 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
- -- See Note [NoSyntaxExpr] (2)
+ { 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]
}
| ApplicativeArgMany -- do { stmts; return vars }
- { xarg_app_arg_many :: (XApplicativeArgMany idL)
+ { 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)
+ , 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
+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
@@ -2212,7 +2242,7 @@ pprStmt (LastStmt _ expr m_dollar_stripped _)
Just False -> text "return"
Nothing -> 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))
@@ -2247,13 +2277,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 noSyntaxExpr
- :: ExprStmt (GhcPass idL))]
+ [ppr (BindStmt (panic "pprStmt") pat expr :: ExprStmt (GhcPass idL))]
flattenArg (_, ApplicativeArgMany _ stmts _ _) =
concatMap flattenStmt stmts
@@ -2273,13 +2302,12 @@ instance (OutputableBndrId idL)
ppr = pprArg
pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc
-pprArg (ApplicativeArgOne _ pat expr isBody _)
+pprArg (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))
+ ppr (BindStmt (panic "pprStmt") pat expr :: ExprStmt (GhcPass idL))
pprArg (ApplicativeArgMany _ stmts return pat) =
ppr pat <+>
text "<-" <+>
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -334,6 +334,9 @@ deriving instance Data PendingTcSplice
deriving instance Data SyntaxExprRn
deriving instance Data SyntaxExprTc
+deriving instance Data XBindStmtRn
+deriving instance Data XBindStmtTc
+
-- ---------------------------------------------------------------------
-- Data derivations from GHC.Hs.Lit ------------------------------------
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -69,7 +69,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,
@@ -259,10 +260,10 @@ mkLastStmt :: IsPass idR => 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 :: IsPass idR => (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))
@@ -320,9 +321,9 @@ mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = s
mkLastStmt body = LastStmt noExtField body Nothing noSyntaxExpr
mkBodyStmt body
= BodyStmt noExtField body noSyntaxExpr noSyntaxExpr
-mkBindStmt pat body
- = BindStmt noExtField pat body noSyntaxExpr noSyntaxExpr
-mkTcBindStmt pat body = BindStmt unitTy pat body noSyntaxExpr noSyntaxExpr
+mkPsBindStmt pat body = BindStmt noExtField pat body
+mkRnBindStmt pat body = BindStmt (XBindStmtRn { xbsrn_bindOp = noSyntaxExpr, xbsrn_failOp = Nothing }) pat body
+mkTcBindStmt pat body = BindStmt (XBindStmtTc { xbstc_bindOp = noSyntaxExpr, xbstc_boundResultType =unitTy, xbstc_failOp = Nothing }) pat body
-- don't use placeHolderTypeTc above, because that panics during zonking
emptyRecStmt' :: forall idL idR body. IsPass idR
@@ -1059,7 +1060,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 {}) = []
@@ -1349,7 +1350,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
=====================================
compiler/GHC/HsToCore/Arrows.hs
=====================================
@@ -866,7 +866,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)
=====================================
compiler/GHC/HsToCore/Coverage.hs
=====================================
@@ -709,12 +709,16 @@ 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)
+addTickStmt _isGuard (BindStmt xbs pat e) = do
+ liftM4 (\b f -> BindStmt $ XBindStmtTc
+ { xbstc_bindOp = b
+ , xbstc_boundResultType = xbstc_boundResultType xbs
+ , xbstc_failOp = f
+ })
+ (addTickSyntaxExpr hpcSrcSpan (xbstc_bindOp xbs))
+ (mapM (addTickSyntaxExpr hpcSrcSpan) (xbstc_failOp xbs))
(addTickLPat pat)
(addTickLHsExprRHS e)
- (addTickSyntaxExpr hpcSrcSpan bind)
- (addTickSyntaxExpr hpcSrcSpan fail)
addTickStmt isGuard (BodyStmt x e bind' guard') = do
liftM3 (BodyStmt x)
(addTick isGuard e)
@@ -763,12 +767,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
- <*> addTickSyntaxExpr hpcSrcSpan fail
addTickArg (ApplicativeArgMany x stmts ret pat) =
(ApplicativeArgMany x)
<$> addTickLStmts isGuard stmts
@@ -938,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)
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -933,24 +933,24 @@ dsDo stmts
= do { rest <- goL stmts
; dsLocalBinds binds rest }
- go _ (BindStmt res1_ty pat rhs bind_op fail_op) stmts
+ go _ (BindStmt xbs pat rhs) stmts
= do { body <- goL stmts
; rhs' <- dsLExpr rhs
; var <- selectSimpleMatchVarL pat
; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
- res1_ty (cantFailMatchResult body)
- ; match_code <- dsHandleMonadicFailure pat match fail_op
- ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
+ (xbstc_boundResultType xbs) (cantFailMatchResult body)
+ ; match_code <- dsHandleMonadicFailure pat match (xbstc_failOp xbs)
+ ; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] }
go _ (ApplicativeStmt body_ty args mb_join) stmts
= do {
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, noSyntaxExpr), dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
+ ((pat, Nothing), dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
; rhss' <- sequence rhss
@@ -981,9 +981,14 @@ 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
- noSyntaxExpr -- Tuple cannot fail
+ new_bind_stmt = L loc $ BindStmt
+ XBindStmtTc
+ { xbstc_bindOp = bind_op
+ , xbstc_boundResultType = bind_ty
+ , xbstc_failOp = 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
@@ -1009,17 +1014,26 @@ dsDo stmts
go _ (ParStmt {}) _ = panic "dsDo ParStmt"
go _ (TransStmt {}) _ = panic "dsDo TransStmt"
-dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
+dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> FailOperator GhcTc -> DsM CoreExpr
-- In a do expression, pattern-match failure just calls
-- the monadic 'fail' rather than throwing an exception
-dsHandleMonadicFailure pat match fail_op
- | matchCanFail match
- = do { dflags <- getDynFlags
- ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
- ; fail_expr <- dsSyntaxExpr fail_op [fail_msg]
- ; extractMatchResult match fail_expr }
- | otherwise
- = extractMatchResult match (error "It can't fail")
+dsHandleMonadicFailure pat match m_fail_op
+ | matchCanFail match = do
+ fail_op <- case m_fail_op of
+ -- Note that (non-monadic) list comprehension, pattern guards, etc could
+ -- have fallible bindings without an explicit failure op, but this is
+ -- handled elsewhere. See Note [Failing pattern matches in Stmts] the
+ -- breakdown of regular and special binds.
+ Nothing -> pprPanic "missing fail op" $
+ text "Pattern match:" <+> ppr pat <+>
+ text "is failable, and fail_expr was left unset"
+ Just fail_op -> pure fail_op
+ dflags <- getDynFlags
+ fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
+ fail_expr <- dsSyntaxExpr fail_op [fail_msg]
+ extractMatchResult match fail_expr
+ | otherwise =
+ extractMatchResult match (error "It can't fail")
mk_fail_msg :: DynFlags -> Located e -> String
mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
=====================================
compiler/GHC/HsToCore/Expr.hs-boot
=====================================
@@ -1,5 +1,5 @@
module GHC.HsToCore.Expr where
-import GHC.Hs ( HsExpr, LHsExpr, LHsLocalBinds, LPat, SyntaxExpr )
+import GHC.Hs ( HsExpr, LHsExpr, LHsLocalBinds, LPat, SyntaxExpr, FailOperator )
import GHC.HsToCore.Monad ( DsM, MatchResult )
import GHC.Core ( CoreExpr )
import GHC.Hs.Extension ( GhcTc)
@@ -9,4 +9,4 @@ dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
-dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
+dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> FailOperator GhcTc -> DsM CoreExpr
=====================================
compiler/GHC/HsToCore/GuardedRHSs.hs
=====================================
@@ -122,7 +122,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
match_var <- selectMatchVar upat
=====================================
compiler/GHC/HsToCore/ListComp.hs
=====================================
@@ -241,7 +241,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
@@ -349,7 +349,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
@@ -495,9 +495,9 @@ dsMcStmt (LetStmt _ binds) stmts
; dsLocalBinds binds rest }
-- [ .. | a <- m, stmts ]
-dsMcStmt (BindStmt bind_ty pat rhs bind_op fail_op) stmts
+dsMcStmt (BindStmt xbs pat rhs) stmts
= do { rhs' <- dsLExpr rhs
- ; dsMcBindStmt pat rhs' bind_op fail_op bind_ty stmts }
+ ; dsMcBindStmt pat rhs' (xbstc_bindOp xbs) (xbstc_failOp xbs) (xbstc_boundResultType xbs) stmts }
-- Apply `guard` to the `exp` expression
--
@@ -585,7 +585,7 @@ dsMcStmt (ParStmt bind_ty blocks mzip_op bind_op) stmts_rest
mkBoxedTupleTy [t1,t2]))
exps_w_tys
- ; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest }
+ ; dsMcBindStmt pat rhs bind_op Nothing bind_ty stmts_rest }
where
ds_inner :: ParStmtBlock GhcTc GhcTc -> DsM (CoreExpr, Type)
ds_inner (ParStmtBlock _ stmts bndrs return_op)
@@ -609,7 +609,7 @@ matchTuple ids body
dsMcBindStmt :: LPat GhcTc
-> CoreExpr -- ^ the desugared rhs of the bind statement
-> SyntaxExpr GhcTc
- -> SyntaxExpr GhcTc
+ -> Maybe (SyntaxExpr GhcTc)
-> Type -- ^ S in (>>=) :: Q -> (R -> S) -> T
-> [ExprLStmt GhcTc]
-> DsM CoreExpr
=====================================
compiler/GHC/HsToCore/PmCheck.hs
=====================================
@@ -660,7 +660,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"
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1613,7 +1613,7 @@ repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> MetaM ([GenSymBind], [Core (M TH.Stm
repLSts stmts = repSts (map unLoc stmts)
repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> MetaM ([GenSymBind], [Core (M TH.Stmt)])
-repSts (BindStmt _ p e _ _ : ss) =
+repSts (BindStmt _ p e : ss) =
do { e2 <- repLE e
; ss1 <- mkGenSyms (collectPatBinders p)
; addBinds ss1 $ do {
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1049,7 +1049,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
]
@@ -1174,7 +1174,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
]
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -573,7 +573,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
@@ -760,8 +760,11 @@ 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. So, for list comprehensions, the fail function is set to '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
@@ -812,7 +815,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
@@ -821,8 +824,8 @@ 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)
- , fv_expr )]
+ ; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op }
+ ; return (( [( L loc (BindStmt xbsrn pat' body'), fv_expr )]
, thing),
fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
-- fv_expr shouldn't really be filtered by the rnPatsAndThen
@@ -1077,11 +1080,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)
@@ -1144,7 +1147,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) <- lookupSyntax bindMName
@@ -1152,8 +1155,9 @@ 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
+ ; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op }
; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
- L loc (BindStmt noExtField pat' body' bind_op fail_op))] }
+ L loc (BindStmt xbsrn pat' body'))] }
rn_rec_stmt _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _)
= failWith (badIpBinds (text "an mdo expression") binds)
@@ -1645,27 +1649,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 xbs 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 = xbsrn_failOp xbs
, 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 _ _),_))
tail _tail_fvs
| (False,tail') <- needJoin monad_names tail
= mkApplicativeStmt ctxt
[ApplicativeArgOne
- { xarg_app_arg_one = noExtField
+ { xarg_app_arg_one = Nothing
, app_arg_pattern = nlWildPatName
, arg_expr = rhs
, is_body_stmt = True
- , fail_operator = noSyntaxExpr}] False tail'
+ }] False tail'
stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =
return (s : tail, emptyNameSet)
@@ -1688,21 +1692,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 xbs pat exp), _))
= return (ApplicativeArgOne
- { xarg_app_arg_one = noExtField
+ { xarg_app_arg_one = xbsrn_failOp xbs
, app_arg_pattern = pat
, arg_expr = exp
, is_body_stmt = False
- , fail_operator = fail_op
}, emptyFVs)
stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) =
return (ApplicativeArgOne
- { xarg_app_arg_one = noExtField
+ { xarg_app_arg_one = Nothing
, app_arg_pattern = nlWildPatName
, arg_expr = exp
, is_body_stmt = True
- , fail_operator = noSyntaxExpr
}, emptyFVs)
stmtTreeArg ctxt tail_fvs tree = do
let stmts = flattenStmtTree tree
@@ -1779,7 +1781,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
{-
@@ -1880,9 +1882,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 xbs 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 xbs 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
@@ -2127,16 +2129,16 @@ badIpBinds what binds
monadFailOp :: LPat GhcPs
-> HsStmtContext GhcRn
- -> RnM (SyntaxExpr GhcRn, FreeVars)
+ -> RnM (FailOperator GhcRn, FreeVars)
monadFailOp pat ctxt
-- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.)
-- we should not need to fail.
- | isIrrefutableHsPat pat = return (noSyntaxExpr, emptyFVs)
+ | 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]
- | not (isMonadFailStmtContext ctxt) = return (noSyntaxExpr, emptyFVs)
+ -- 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
@@ -2164,11 +2166,12 @@ So, in this case, we synthesize the function
(rather than plain 'fail') for the 'fail' operation. This is done in
'getMonadFailOp'.
-}
-getMonadFailOp :: RnM (SyntaxExpr GhcRn, FreeVars) -- Syntax expr fail op
+getMonadFailOp :: RnM (FailOperator GhcRn, FreeVars) -- Syntax expr fail op
getMonadFailOp
= do { xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags
; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags
- ; reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings
+ ; (fail, fvs) <- reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings
+ ; return (Just fail, fvs)
}
where
reallyGetMonadFailOp rebindableSyntax overloadedStrings
=====================================
compiler/GHC/Tc/Deriv/Generate.hs
=====================================
@@ -832,7 +832,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]))
@@ -1072,7 +1072,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
@@ -1081,7 +1081,7 @@ gen_Read_binds get_fixity loc tycon
-- Note the parens!
read_field lbl a =
[noLoc
- (mkBindStmt
+ (mkPsBindStmt
(nlVarPat a)
(nlHsApp
read_field
=====================================
compiler/GHC/Tc/Gen/Arrow.hs
=====================================
@@ -364,7 +364,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
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -415,7 +415,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)
@@ -449,7 +449,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) $
@@ -568,10 +568,10 @@ 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 xbsrn 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
+ <- tcSyntaxOp MCompOrigin (xbsrn_bindOp xbsrn)
[SynRho, SynFun SynAny SynRho] res_ty $
\ [rhs_ty, pat_ty, new_res_ty] ->
do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
@@ -581,9 +581,15 @@ tcMcStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside
; return (rhs', pat', thing, new_res_ty) }
-- If (but only if) the pattern can fail, typecheck the 'fail' operator
- ; fail_op' <- tcMonadFailOp (MCompPatOrigin pat) pat' fail_op new_res_ty
+ ; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail ->
+ tcMonadFailOp (MCompPatOrigin pat) pat' fail new_res_ty
- ; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) }
+ ; let xbstc = XBindStmtTc
+ { xbstc_bindOp = bind_op'
+ , xbstc_boundResultType = new_res_ty
+ , xbstc_failOp = fail_op'
+ }
+ ; return (BindStmt xbstc pat' rhs', thing) }
-- Boolean expressions.
--
@@ -825,14 +831,14 @@ 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 rhs bind_op fail_op) res_ty thing_inside
+tcDoStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside
= do { -- Deal with rebindable syntax:
-- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
-- This level of generality is needed for using do-notation
-- in full generality; see #1537
((rhs', pat', new_res_ty, thing), bind_op')
- <- tcSyntaxOp DoOrigin bind_op [SynRho, SynFun SynAny SynRho] res_ty $
+ <- tcSyntaxOp DoOrigin (xbsrn_bindOp xbsrn) [SynRho, SynFun SynAny SynRho] res_ty $
\ [rhs_ty, pat_ty, new_res_ty] ->
do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
; (pat', thing) <- tcPat (StmtCtxt ctxt) pat
@@ -841,9 +847,14 @@ tcDoStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside
; return (rhs', pat', new_res_ty, thing) }
-- If (but only if) the pattern can fail, typecheck the 'fail' operator
- ; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op new_res_ty
-
- ; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) }
+ ; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail ->
+ tcMonadFailOp (DoPatOrigin pat) pat' fail new_res_ty
+ ; let xbstc = XBindStmtTc
+ { xbstc_bindOp = bind_op'
+ , xbstc_boundResultType = new_res_ty
+ , xbstc_failOp = fail_op'
+ }
+ ; return (BindStmt xbstc pat' rhs', thing) }
tcDoStmt ctxt (ApplicativeStmt _ pairs mb_join) res_ty thing_inside
= do { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $
@@ -937,16 +948,17 @@ tcMonadFailOp :: CtOrigin
-> LPat GhcTcId
-> SyntaxExpr GhcRn -- The fail op
-> TcType -- Type of the whole do-expression
- -> TcRn (SyntaxExpr GhcTcId) -- Typechecked fail op
--- Get a 'fail' operator expression, to use if the pattern
--- match fails. If the pattern is irrefutatable, just return
--- noSyntaxExpr; it won't be used
+ -> TcRn (FailOperator GhcTcId) -- Typechecked fail op
+-- Get a 'fail' operator expression, to use if the pattern match fails.
+-- This won't be used in cases where we've already determined the pattern
+-- match can't fail (so the fail op is Nothing), however, it seems that the
+-- isIrrefutableHsPat test is still required here for some reason I haven't
+-- yet determined.
tcMonadFailOp orig pat fail_op res_ty
| isIrrefutableHsPat pat
- = return noSyntaxExpr
-
+ = return Nothing
| otherwise
- = snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy]
+ = Just . snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy]
(mkCheckExpType res_ty) $ \_ -> return ())
{-
@@ -1025,22 +1037,23 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
-> TcM (ApplicativeArg GhcTcId)
goArg body_ty (ApplicativeArgOne
- { app_arg_pattern = pat
- , arg_expr = rhs
- , fail_operator = fail_op
+ { xarg_app_arg_one = fail_op
+ , app_arg_pattern = pat
+ , arg_expr = rhs
, ..
}, pat_ty, exp_ty)
= setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $
- addErrCtxt (pprStmtInCtxt ctxt (mkBindStmt pat rhs)) $
+ addErrCtxt (pprStmtInCtxt ctxt (mkRnBindStmt pat rhs)) $
do { rhs' <- tcMonoExprNC rhs (mkCheckExpType exp_ty)
; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
return ()
- ; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op body_ty
+ ; fail_op' <- fmap join . forM fail_op $ \fail ->
+ tcMonadFailOp (DoPatOrigin pat) pat' fail body_ty
; return (ApplicativeArgOne
- { app_arg_pattern = pat'
+ { xarg_app_arg_one = fail_op'
+ , app_arg_pattern = pat'
, arg_expr = rhs'
- , fail_operator = fail_op'
, .. }
) }
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -2193,11 +2193,13 @@ tcUserStmt (L loc (BodyStmt _ expr _ _))
(NValBinds [(NonRecursive,unitBag the_bind)] [])
-- [it <- e]
- bind_stmt = L loc $ BindStmt noExtField
+ bind_stmt = L loc $ BindStmt
+ (XBindStmtRn
+ { xbsrn_bindOp = mkRnSyntaxExpr bindIOName
+ , xbsrn_failOp = Nothing
+ })
(L loc (VarPat noExtField (L loc fresh_it)))
(nlHsApp ghciStep rn_expr)
- (mkRnSyntaxExpr bindIOName)
- noSyntaxExpr
-- [; print it]
print_it = L loc $ BodyStmt noExtField
@@ -2327,8 +2329,8 @@ tcUserStmt rdr_stmt@(L loc _)
; ghciStep <- getGhciStepIO
; let gi_stmt
- | (L loc (BindStmt ty pat expr op1 op2)) <- rn_stmt
- = L loc $ BindStmt ty pat (nlHsApp ghciStep expr) op1 op2
+ | (L loc (BindStmt x pat expr)) <- rn_stmt
+ = L loc $ BindStmt x pat (nlHsApp ghciStep expr)
| otherwise = rn_stmt
; opt_pr_flag <- goptM Opt_PrintBindResult
=====================================
compiler/GHC/Tc/Utils/Zonk.hs
=====================================
@@ -1190,14 +1190,21 @@ 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)
- = do { (env1, new_bind) <- zonkSyntaxExpr env bind_op
- ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty
+zonkStmt env zBody (BindStmt xbs pat body)
+ = do { (env1, new_bind) <- zonkSyntaxExpr env (xbstc_bindOp xbs)
+ ; new_bind_ty <- zonkTcTypeToTypeX env1 (xbstc_boundResultType xbs)
; new_body <- zBody env1 body
; (env2, new_pat) <- zonkPat env1 pat
- ; (_, new_fail) <- zonkSyntaxExpr env1 fail_op
+ ; new_fail <- case xbstc_failOp xbs of
+ 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 (XBindStmtTc
+ { xbstc_bindOp = new_bind
+ , xbstc_boundResultType = new_bind_ty
+ , xbstc_failOp = new_fail
+ })
+ new_pat new_body) }
-- Scopes: join > ops (in reverse order) > pats (in forward order)
-- > rest of stmts
@@ -1212,14 +1219,14 @@ zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join)
zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j
get_pat :: (SyntaxExpr GhcTcId, ApplicativeArg GhcTcId) -> LPat GhcTcId
- get_pat (_, ApplicativeArgOne _ pat _ _ _) = pat
+ get_pat (_, ApplicativeArgOne _ pat _ _) = pat
get_pat (_, ApplicativeArgMany _ _ _ pat) = pat
replace_pat :: LPat GhcTcId
-> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
-> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
- 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)
@@ -1239,10 +1246,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) <- zonkSyntaxExpr env fail_op
- ; return (ApplicativeArgOne x pat new_expr isBody new_fail) }
+ ; new_fail <- forM fail_op $ \old_fail ->
+ do { (_, fail') <- zonkSyntaxExpr env old_fail
+ ; return 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
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -1147,7 +1147,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
=====================================
compiler/parser/Parser.y
=====================================
@@ -3292,7 +3292,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 }
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bfde3b76ac7f5a72eca012fe34ac1340a5ce2011...18bc16ed78dfa1fe9498c5ac1ca38e9f84267872
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bfde3b76ac7f5a72eca012fe34ac1340a5ce2011...18bc16ed78dfa1fe9498c5ac1ca38e9f84267872
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200418/609a5925/attachment-0001.html>
More information about the ghc-commits
mailing list