Commit 18bc16ed authored by cgibbard's avatar cgibbard Committed by cgibbard
Browse files

Use FailOperator in more places, define a couple datatypes (XBindStmtRn and...

Use FailOperator in more places, define a couple datatypes (XBindStmtRn and XBindStmtTc) to help clarify the meaning of XBindStmt in the renamer and typechecker
parent 79e27144
Pipeline #18193 failed with stages
in 425 minutes and 5 seconds
......@@ -1948,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 = (SyntaxExpr GhcRn, FailOperator GhcRn)
type instance XBindStmt (GhcPass _) GhcTc b = (SyntaxExpr GhcTc, Type, FailOperator GhcTc)
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
......@@ -2011,7 +2022,7 @@ type FailOperator id = Maybe (SyntaxExpr id)
-- | Applicative Argument
data ApplicativeArg idL
= ApplicativeArgOne -- A single statement (BindStmt or BodyStmt)
{ xarg_app_arg_one :: (XApplicativeArgOne idL)
{ xarg_app_arg_one :: XApplicativeArgOne idL
-- ^ The fail operator, after renaming
--
-- The fail operator is needed if this is a BindStmt
......@@ -2022,17 +2033,18 @@ data ApplicativeArg idL
-- 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]
, 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)
......
......@@ -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 ------------------------------------
......
......@@ -322,8 +322,8 @@ mkLastStmt body = LastStmt noExtField body Nothing noSyntaxExpr
mkBodyStmt body
= BodyStmt noExtField body noSyntaxExpr noSyntaxExpr
mkPsBindStmt pat body = BindStmt noExtField pat body
mkRnBindStmt pat body = BindStmt (noSyntaxExpr, Nothing) pat body
mkTcBindStmt pat body = BindStmt (noSyntaxExpr, unitTy, Nothing) 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
......
......@@ -709,10 +709,14 @@ addTickStmt _isGuard (LastStmt x e noret ret) = do
(addTickLHsExpr e)
(pure noret)
(addTickSyntaxExpr hpcSrcSpan ret)
addTickStmt _isGuard (BindStmt (bind, ty, fail) pat e) = do
liftM4 (\b f -> BindStmt (b, ty, f))
(addTickSyntaxExpr hpcSrcSpan bind)
(mapM (addTickSyntaxExpr hpcSrcSpan) fail)
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)
addTickStmt isGuard (BodyStmt x e bind' guard') = do
......
......@@ -933,14 +933,14 @@ dsDo stmts
= do { rest <- goL stmts
; dsLocalBinds binds rest }
go _ (BindStmt (bind_op, res1_ty, fail_op) pat rhs) 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 {
......@@ -982,10 +982,11 @@ dsDo stmts
= goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' }
where
new_bind_stmt = L loc $ BindStmt
( bind_op
, bind_ty
, Nothing -- Tuple cannot fail
)
XBindStmtTc
{ xbstc_bindOp = bind_op
, xbstc_boundResultType = bind_ty
, xbstc_failOp = Nothing -- Tuple cannot fail
}
(mkBigLHsPatTupId later_pats)
mfix_app
......@@ -1013,7 +1014,7 @@ dsDo stmts
go _ (ParStmt {}) _ = panic "dsDo ParStmt"
go _ (TransStmt {}) _ = panic "dsDo TransStmt"
dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> Maybe (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 m_fail_op
......
module GHC.HsToCore.Expr where
import GhcPrelude ( Maybe )
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)
......@@ -10,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 -> Maybe (SyntaxExpr GhcTc) -> DsM CoreExpr
dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> FailOperator GhcTc -> DsM CoreExpr
......@@ -495,9 +495,9 @@ dsMcStmt (LetStmt _ binds) stmts
; dsLocalBinds binds rest }
-- [ .. | a <- m, stmts ]
dsMcStmt (BindStmt (bind_op, bind_ty, fail_op) pat rhs) 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
--
......
......@@ -762,7 +762,8 @@ 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 of 'BindStmt'
entirely. That said, it ought to be 'Nothing' for clarity.
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
......@@ -823,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 (bind_op, fail_op) pat' body')
, 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
......@@ -1154,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 (bind_op, fail_op) pat' body'))] }
L loc (BindStmt xbsrn pat' body'))] }
rn_rec_stmt _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _)
= failWith (badIpBinds (text "an mdo expression") binds)
......@@ -1647,12 +1649,12 @@ 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 (_, fail_op) pat rhs), _))
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 = fail_op
{ xarg_app_arg_one = xbsrn_failOp xbs
, app_arg_pattern = pat
, arg_expr = rhs
, is_body_stmt = False
......@@ -1690,9 +1692,9 @@ 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 (_, fail_op) pat exp), _))
stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt xbs pat exp), _))
= return (ApplicativeArgOne
{ xarg_app_arg_one = fail_op
{ xarg_app_arg_one = xbsrn_failOp xbs
, app_arg_pattern = pat
, arg_expr = exp
, is_body_stmt = 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 (bind_op, fail_op) pat body), 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 (bind_op, fail_op) pat body), 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,7 +2129,7 @@ badIpBinds what binds
monadFailOp :: LPat GhcPs
-> HsStmtContext GhcRn
-> RnM (Maybe (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.
......@@ -2164,7 +2166,7 @@ So, in this case, we synthesize the function
(rather than plain 'fail') for the 'fail' operation. This is done in
'getMonadFailOp'.
-}
getMonadFailOp :: RnM (Maybe (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
......
......@@ -568,10 +568,10 @@ tcMcStmt _ (LastStmt x body noret return_op) res_ty thing_inside
-- q :: a
--
tcMcStmt ctxt (BindStmt (bind_op, fail_op) pat rhs) 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,11 +581,15 @@ tcMcStmt ctxt (BindStmt (bind_op, fail_op) pat rhs) 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' <- fmap join . forM fail_op $ \fail ->
; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail ->
tcMonadFailOp (MCompPatOrigin pat) pat' fail new_res_ty
; return (BindStmt (bind_op', new_res_ty, fail_op') pat' rhs', 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.
--
......@@ -827,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 (bind_op, fail_op) pat rhs) 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
......@@ -843,10 +847,14 @@ tcDoStmt ctxt (BindStmt (bind_op, fail_op) pat rhs) 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' <- fmap join . forM fail_op $ \fail ->
; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail ->
tcMonadFailOp (DoPatOrigin pat) pat' fail new_res_ty
; return (BindStmt (bind_op', new_res_ty, fail_op') pat' rhs', thing) }
; 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 $
......@@ -940,7 +948,7 @@ tcMonadFailOp :: CtOrigin
-> LPat GhcTcId
-> SyntaxExpr GhcRn -- The fail op
-> TcType -- Type of the whole do-expression
-> TcRn (Maybe (SyntaxExpr GhcTcId)) -- Typechecked fail op
-> 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
......
......@@ -2194,7 +2194,10 @@ tcUserStmt (L loc (BodyStmt _ expr _ _))
-- [it <- e]
bind_stmt = L loc $ BindStmt
(mkRnSyntaxExpr bindIOName, Nothing)
(XBindStmtRn
{ xbsrn_bindOp = mkRnSyntaxExpr bindIOName
, xbsrn_failOp = Nothing
})
(L loc (VarPat noExtField (L loc fresh_it)))
(nlHsApp ghciStep rn_expr)
......
......@@ -1190,16 +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_op, bind_ty, fail_op) pat body)
= 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 <- case fail_op of
; new_fail <- case xbstc_failOp xbs of
Nothing -> return Nothing
Just f -> fmap (Just . snd) (zonkSyntaxExpr env1 f)
; return ( env2
, BindStmt (new_bind, new_bind_ty, new_fail) new_pat new_body) }
, 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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment