[Git][ghc/ghc][wip/expansions-appdo] Make ApplicativeDo work with HsExpansions
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Wed May 29 16:39:15 UTC 2024
Apoorv Ingle pushed to branch wip/expansions-appdo at Glasgow Haskell Compiler / GHC
Commits:
0dd8fb6b by Apoorv Ingle at 2024-05-28T15:19:25-05:00
Make ApplicativeDo work with HsExpansions
testcase added: T24406
Issues Fixed: #24406, #16135
Code Changes:
- Remove `XStmtLR GhcTc` as `XStmtLR GhcRn` is now compiled to `HsExpr GhcTc`
- The expanded statements are guided by `GHC.Hs.Expr.TcFunInfo` which is used to decide
if the `XExpr GhcRn` is to be typechecked using `tcApp` or `tcExpr`
- - - - -
30 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/GuardedRHSs.hs
- compiler/GHC/HsToCore/ListComp.hs
- compiler/GHC/HsToCore/Pmc/Desugar.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/GHC/Tc/Zonk/Type.hs
- testsuite/tests/ado/T13242a.stderr
- − testsuite/tests/ado/T16135.stderr
- + testsuite/tests/ado/T24406.hs
- testsuite/tests/ado/ado002.stderr
- testsuite/tests/ado/ado003.stderr
- testsuite/tests/ado/ado004.stderr
- testsuite/tests/ado/all.T
- testsuite/tests/determinism/determ021/determ021.stdout
- testsuite/tests/ghci.debugger/scripts/break029.stdout
- testsuite/tests/hiefile/should_run/T23540.stdout
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -473,11 +473,13 @@ type instance XXExpr GhcTc = XXExprGhcTc
* *
********************************************************************* -}
+data TCFunInfo = TcApp | TcExpr
+
-- | The different source constructs that we use to instantiate the "original" field
-- in an `XXExprGhcRn original expansion`
data HsThingRn = OrigExpr (HsExpr GhcRn)
- | OrigStmt (ExprLStmt GhcRn)
- | OrigPat (LPat GhcRn)
+ | OrigStmt (ExprLStmt GhcRn) HsDoFlavour -- ^ which kind of do-block did this statement come from
+ | OrigPat (LPat GhcRn) (Maybe (HsDoFlavour, ExprLStmt GhcRn))
isHsThingRnExpr, isHsThingRnStmt, isHsThingRnPat :: HsThingRn -> Bool
isHsThingRnExpr (OrigExpr{}) = True
@@ -491,7 +493,8 @@ isHsThingRnPat _ = False
data XXExprGhcRn
= ExpandedThingRn { xrn_orig :: HsThingRn -- The original source thing
- , xrn_expanded :: HsExpr GhcRn } -- The compiler generated expanded thing
+ , xrn_expanded :: HsExpr GhcRn -- The compiler generated expanded thing
+ , xrn_TCFunInfo :: TCFunInfo } -- A Hint to the type checker of how to proceed
| PopErrCtxt -- A hint for typechecker to pop
{-# UNPACK #-} !(LHsExpr GhcRn) -- the top of the error context stack
@@ -515,22 +518,25 @@ mkExpandedExpr
:: HsExpr GhcRn -- ^ source expression
-> HsExpr GhcRn -- ^ expanded expression
-> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn (OrigExpr oExpr) eExpr)
+mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn (OrigExpr oExpr) eExpr TcExpr)
-- | Build an expression using the extension constructor `XExpr`,
-- and the two components of the expansion: original do stmt and
-- expanded expression
mkExpandedStmt
:: ExprLStmt GhcRn -- ^ source statement
+ -> HsDoFlavour
+ -> TCFunInfo
-> HsExpr GhcRn -- ^ expanded expression
-> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedStmt oStmt eExpr = XExpr (ExpandedThingRn (OrigStmt oStmt) eExpr)
+mkExpandedStmt oStmt flav tc_fun eExpr = XExpr (ExpandedThingRn (OrigStmt oStmt flav) eExpr tc_fun)
mkExpandedPatRn
- :: LPat GhcRn -- ^ source pattern
- -> HsExpr GhcRn -- ^ expanded expression
- -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedPatRn oPat eExpr = XExpr (ExpandedThingRn (OrigPat oPat) eExpr)
+ :: LPat GhcRn -- ^ source pattern
+ -> Maybe (HsDoFlavour, ExprLStmt GhcRn) -- ^ pattern statement origin
+ -> HsExpr GhcRn -- ^ expanded expression
+ -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
+mkExpandedPatRn oPat mb_stmt_info eExpr = XExpr (ExpandedThingRn (OrigPat oPat mb_stmt_info) eExpr TcExpr)
-- | Build an expression using the extension constructor `XExpr`,
-- and the two components of the expansion: original do stmt and
@@ -538,17 +544,21 @@ mkExpandedPatRn oPat eExpr = XExpr (ExpandedThingRn (OrigPat oPat) eExpr)
mkExpandedStmtAt
:: SrcSpanAnnA -- ^ Location for the expansion expression
-> ExprLStmt GhcRn -- ^ source statement
+ -> HsDoFlavour
+ -> TCFunInfo
-> HsExpr GhcRn -- ^ expanded expression
-> LHsExpr GhcRn -- ^ suitably wrapped located 'XXExprGhcRn'
-mkExpandedStmtAt loc oStmt eExpr = L loc $ mkExpandedStmt oStmt eExpr
+mkExpandedStmtAt loc oStmt flav tcFun eExpr = L loc $ mkExpandedStmt oStmt flav tcFun eExpr
-- | Wrap the expanded version of the expression with a pop.
mkExpandedStmtPopAt
:: SrcSpanAnnA -- ^ Location for the expansion statement
-> ExprLStmt GhcRn -- ^ source statement
+ -> HsDoFlavour
+ -> TCFunInfo
-> HsExpr GhcRn -- ^ expanded expression
-> LHsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedStmtPopAt loc oStmt eExpr = mkPopErrCtxtExprAt loc $ mkExpandedStmtAt loc oStmt eExpr
+mkExpandedStmtPopAt loc oStmt flav tc_fun eExpr = mkPopErrCtxtExprAt loc $ mkExpandedStmtAt loc oStmt flav tc_fun eExpr
data XXExprGhcTc
@@ -593,9 +603,10 @@ mkExpandedExprTc oExpr eExpr = XExpr (ExpandedThingTc (OrigExpr oExpr) eExpr)
-- expanded typechecked expression.
mkExpandedStmtTc
:: ExprLStmt GhcRn -- ^ source do statement
+ -> HsDoFlavour
-> HsExpr GhcTc -- ^ expanded typechecked expression
-> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedStmtTc oStmt eExpr = XExpr (ExpandedThingTc (OrigStmt oStmt) eExpr)
+mkExpandedStmtTc oStmt flav eExpr = XExpr (ExpandedThingTc (OrigStmt oStmt flav) eExpr)
{- *********************************************************************
* *
@@ -836,13 +847,13 @@ instance Outputable HsThingRn where
ppr thing
= case thing of
OrigExpr x -> ppr_builder "<OrigExpr>:" x
- OrigStmt x -> ppr_builder "<OrigStmt>:" x
- OrigPat x -> ppr_builder "<OrigPat>:" x
+ OrigStmt x _ -> ppr_builder "<OrigStmt>:" x
+ OrigPat x _ -> ppr_builder "<OrigPat>:" x
where ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens (ppr x))) (ppr x)
instance Outputable XXExprGhcRn where
- ppr (ExpandedThingRn o e) = ifPprDebug (braces $ vcat [ppr o, ppr e]) (ppr o)
- ppr (PopErrCtxt e) = ifPprDebug (braces (text "<PopErrCtxt>" <+> ppr e)) (ppr e)
+ ppr (ExpandedThingRn o e _) = ifPprDebug (braces $ vcat [ppr o, text ";;" , ppr e]) (ppr o)
+ ppr (PopErrCtxt e) = ifPprDebug (braces (text "<PopErrCtxt>" <+> ppr e)) (ppr e)
instance Outputable XXExprGhcTc where
ppr (WrapExpr (HsWrap co_fn e))
@@ -882,7 +893,7 @@ ppr_infix_expr (XExpr x) = case ghcPass @p of
ppr_infix_expr _ = Nothing
ppr_infix_expr_rn :: XXExprGhcRn -> Maybe SDoc
-ppr_infix_expr_rn (ExpandedThingRn thing _) = ppr_infix_hs_expansion thing
+ppr_infix_expr_rn (ExpandedThingRn thing _ _) = ppr_infix_hs_expansion thing
ppr_infix_expr_rn (PopErrCtxt (L _ a)) = ppr_infix_expr a
ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc
@@ -993,7 +1004,7 @@ hsExprNeedsParens prec = go
go_x_tc (HsBinTick _ _ (L _ e)) = hsExprNeedsParens prec e
go_x_rn :: XXExprGhcRn -> Bool
- go_x_rn (ExpandedThingRn thing _) = hsExpandedNeedsParens thing
+ go_x_rn (ExpandedThingRn thing _ _) = hsExpandedNeedsParens thing
go_x_rn (PopErrCtxt (L _ a)) = hsExprNeedsParens prec a
hsExpandedNeedsParens :: HsThingRn -> Bool
@@ -1045,7 +1056,7 @@ isAtomicHsExpr (XExpr x)
go_x_tc (HsBinTick {}) = False
go_x_rn :: XXExprGhcRn -> Bool
- go_x_rn (ExpandedThingRn thing _) = isAtomicExpandedThingRn thing
+ go_x_rn (ExpandedThingRn thing _ _) = isAtomicExpandedThingRn thing
go_x_rn (PopErrCtxt (L _ a)) = isAtomicHsExpr a
isAtomicExpandedThingRn :: HsThingRn -> Bool
@@ -1568,7 +1579,7 @@ pprMatch (Match { m_pats = pats, m_ctxt = ctxt, m_grhss = grhss })
<+> pprInfixOcc fun
<+> pprParendLPat opPrec p2
_ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats)
-
+ StmtCtxt _ -> (char '\\', pats)
LamAlt LamSingle -> (char '\\', pats)
ArrowMatchCtxt (ArrowLamAlt LamSingle) -> (char '\\', pats)
LamAlt LamCases -> lam_cases_result
@@ -1609,6 +1620,7 @@ matchSeparator IfAlt = text "->"
matchSeparator ArrowMatchCtxt{} = text "->"
matchSeparator PatBindRhs = text "="
matchSeparator PatBindGuards = text "="
+matchSeparator (StmtCtxt (HsDoStmt{})) = text "->"
matchSeparator StmtCtxt{} = text "<-"
matchSeparator RecUpd = text "=" -- This can be printed by the pattern
matchSeparator PatSyn = text "<-" -- match checker trace
@@ -1690,7 +1702,7 @@ type instance XRecStmt (GhcPass _) GhcTc b = RecStmtTc
type instance XXStmtLR (GhcPass _) GhcPs b = DataConCantHappen
type instance XXStmtLR (GhcPass x) GhcRn b = ApplicativeStmt (GhcPass x) GhcRn
-type instance XXStmtLR (GhcPass x) GhcTc b = ApplicativeStmt (GhcPass x) GhcTc
+type instance XXStmtLR (GhcPass x) GhcTc b = DataConCantHappen
-- | 'ApplicativeStmt' represents an applicative expression built with
-- '<$>' and '<*>'. It is generated by the renamer, and is desugared into the
@@ -1731,7 +1743,7 @@ data ApplicativeArg idL
| ApplicativeArgMany -- do { stmts; return vars }
{ xarg_app_arg_many :: XApplicativeArgMany idL
, app_stmts :: [ExprLStmt idL] -- stmts
- , final_expr :: HsExpr idL -- return (v1,..,vn), or just (v1,..,vn)
+ , final_expr :: LHsExpr idL -- return (v1,..,vn), or just (v1,..,vn)
, bv_pattern :: LPat idL -- (v1,...,vn)
, stmt_context :: HsDoFlavour
-- ^ context of the do expression, used in pprArg
@@ -1796,7 +1808,6 @@ pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids
pprStmt (XStmtLR x) = case ghcPass :: GhcPass idR of
GhcRn -> pprApplicativeStmt x
- GhcTc -> pprApplicativeStmt x
where
pprApplicativeStmt :: (OutputableBndrId idL, OutputableBndrId idR) => ApplicativeStmt (GhcPass idL) (GhcPass idR) -> SDoc
@@ -1817,7 +1828,6 @@ pprStmt (XStmtLR x) = case ghcPass :: GhcPass idR of
flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc]
flattenStmt (L _ (XStmtLR x)) = case ghcPass :: GhcPass idL of
GhcRn | (ApplicativeStmt _ args _) <- x -> concatMap flattenArg args
- GhcTc | (ApplicativeStmt _ args _) <- x -> concatMap flattenArg args
flattenStmt stmt = [ppr stmt]
flattenArg :: (a, ApplicativeArg (GhcPass idL)) -> [SDoc]
@@ -1846,13 +1856,13 @@ instance (OutputableBndrId idL)
pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc
pprArg (ApplicativeArgOne _ pat expr isBody)
- | isBody = ppr expr -- See Note [Applicative BodyStmt]
- | otherwise = pprBindStmt pat expr
+ | isBody = whenPprDebug (text "[AppStmt]") <+> ppr expr -- See Note [Applicative BodyStmt]
+ | otherwise = whenPprDebug (text "[AppStmt]") <+> pprBindStmt pat expr
pprArg (ApplicativeArgMany _ stmts return pat ctxt) =
ppr pat <+>
text "<-" <+>
pprDo ctxt (stmts ++
- [noLocA (LastStmt noExtField (noLocA return) Nothing noSyntaxExpr)])
+ [noLocA (LastStmt noExtField return Nothing noSyntaxExpr)])
pprTransformStmt :: (OutputableBndrId p)
=> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -569,6 +569,7 @@ deriving instance Eq (IE GhcTc)
-- ---------------------------------------------------------------------
deriving instance Data HsThingRn
+deriving instance Data TCFunInfo
deriving instance Data XXExprGhcRn
deriving instance Data XXExprGhcTc
deriving instance Data XXPatGhcTc
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -1188,7 +1188,6 @@ collectStmtBinders flag = \case
RecStmt { recS_stmts = L _ ss } -> collectLStmtsBinders flag ss
XStmtLR x -> case ghcPass :: GhcPass idR of
GhcRn -> collectApplicativeStmtBndrs x
- GhcTc -> collectApplicativeStmtBndrs x
where
collectApplicativeStmtBndrs :: ApplicativeStmt (GhcPass idL) a -> [IdP (GhcPass idL)]
collectApplicativeStmtBndrs (ApplicativeStmt _ args _) = concatMap (collectArgBinders . snd) args
@@ -1777,7 +1776,6 @@ lStmtsImplicits = hs_lstmts
hs_stmt (BindStmt _ pat _) = lPatImplicits pat
hs_stmt (XStmtLR x) = case ghcPass :: GhcPass idR of
GhcRn -> hs_applicative_stmt x
- GhcTc -> hs_applicative_stmt x
hs_stmt (LetStmt _ binds) = hs_local_binds binds
hs_stmt (BodyStmt {}) = []
hs_stmt (LastStmt {}) = []
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -315,7 +315,7 @@ dsExpr (HsOverLit _ lit)
dsExpr e@(XExpr ext_expr_tc)
= case ext_expr_tc of
ExpandedThingTc o e
- | OrigStmt (L loc _) <- o
+ | OrigStmt (L loc _) _ <- o
-> putSrcSpanDsA loc $ dsExpr e
| otherwise -> dsExpr e
WrapExpr {} -> dsHsWrapped e
@@ -463,10 +463,10 @@ dsExpr (HsLet _ binds body) = do
-- because the interpretation of `stmts' depends on what sort of thing it is.
--
dsExpr (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty
-dsExpr (HsDo _ ctx at DoExpr{} (L _ stmts)) = dsDo ctx stmts
-dsExpr (HsDo _ ctx at GhciStmtCtxt (L _ stmts)) = dsDo ctx stmts
-dsExpr (HsDo _ ctx at MDoExpr{} (L _ stmts)) = dsDo ctx stmts
dsExpr (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts
+dsExpr (HsDo _ ctx at GhciStmtCtxt (L _ stmts)) = dsDo ctx stmts
+dsExpr (HsDo _ DoExpr{} (L _ stmts)) = pprPanic "shouldn't happen dsDo DoExpr" (ppr stmts)
+dsExpr (HsDo _ MDoExpr{} (L _ stmts)) = pprPanic "shouldn't happen dsDo MDoExpr" (ppr stmts)
dsExpr (HsIf _ guard_expr then_expr else_expr)
= do { pred <- dsLExpr guard_expr
@@ -815,38 +815,6 @@ dsDo ctx stmts
-- This LastStmt will be desugared with dsDo,
-- which ignores the return_op in the LastStmt,
-- so we must apply the return_op explicitly
-
- go _ (XStmtLR (ApplicativeStmt body_ty args mb_join)) stmts
- = do {
- let
- (pats, rhss) = unzip (map (do_arg . snd) args)
-
- do_arg (ApplicativeArgOne fail_op pat expr _) =
- ((pat, fail_op), dsLExpr expr)
- do_arg (ApplicativeArgMany _ stmts ret pat _) =
- ((pat, Nothing), dsDo ctx (stmts ++ [noLocA $ mkLastStmt (noLocA ret)]))
-
- ; rhss' <- sequence rhss
-
- ; body' <- dsLExpr $ noLocA $ HsDo body_ty ctx (noLocA stmts)
-
- ; let match_args (pat, fail_op) (vs,body)
- = putSrcSpanDs (getLocA pat) $
- do { var <- selectSimpleMatchVarL ManyTy pat
- ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat
- body_ty (cantFailMatchResult body)
- ; match_code <- dsHandleMonadicFailure ctx pat match fail_op
- ; return (var:vs, match_code)
- }
-
- ; (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
- Nothing -> return expr
- Just join_op -> dsSyntaxExpr join_op [expr] }
-
go _ (ParStmt {}) _ = panic "dsDo ParStmt"
go _ (TransStmt {}) _ = panic "dsDo TransStmt"
=====================================
compiler/GHC/HsToCore/GuardedRHSs.hs
=====================================
@@ -144,8 +144,6 @@ matchGuards (LastStmt {} : _) _ _ _ _ = panic "matchGuards LastStmt"
matchGuards (ParStmt {} : _) _ _ _ _ = panic "matchGuards ParStmt"
matchGuards (TransStmt {} : _) _ _ _ _ = panic "matchGuards TransStmt"
matchGuards (RecStmt {} : _) _ _ _ _ = panic "matchGuards RecStmt"
-matchGuards (XStmtLR ApplicativeStmt {} : _) _ _ _ _ =
- panic "matchGuards ApplicativeLastStmt"
{-
Should {\em fail} if @e@ returns @D@
=====================================
compiler/GHC/HsToCore/ListComp.hs
=====================================
@@ -257,9 +257,6 @@ deListComp (ParStmt _ stmtss_w_bndrs _ _ : quals) list
deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt"
-deListComp (XStmtLR ApplicativeStmt {} : _) _ =
- panic "deListComp ApplicativeStmt"
-
deBindComp :: LPat GhcTc
-> CoreExpr
-> [ExprStmt GhcTc]
@@ -352,8 +349,6 @@ dfListComp c_id n_id (BindStmt _ pat list1 : quals) = do
dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt"
dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt"
-dfListComp _ _ (XStmtLR ApplicativeStmt {} : _) =
- panic "dfListComp ApplicativeStmt"
dfBindComp :: Id -> Id -- 'c' and 'n'
-> (LPat GhcTc, CoreExpr)
@@ -580,7 +575,6 @@ dsMcStmt (ParStmt bind_ty blocks mzip_op bind_op) stmts_rest
= do { exp <- dsInnerMonadComp stmts bndrs return_op
; return (exp, mkBigCoreVarTupTy bndrs) }
-dsMcStmt stmt@(XStmtLR ApplicativeStmt {}) _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
dsMcStmt stmt@(RecStmt {}) _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr
=====================================
compiler/GHC/HsToCore/Pmc/Desugar.hs
=====================================
@@ -377,7 +377,6 @@ desugarGuard guard = case guard of
ParStmt {} -> panic "desugarGuard ParStmt"
TransStmt {} -> panic "desugarGuard TransStmt"
RecStmt {} -> panic "desugarGuard RecStmt"
- XStmtLR ApplicativeStmt{} -> panic "desugarGuard ApplicativeLastStmt"
-- | Desugar local bindings to a bunch of 'PmLet' guards.
-- Deals only with simple @let@ or @where@ bindings without any polymorphism,
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1685,7 +1685,7 @@ repE (HsProjection _ xs) = repProjection (fmap (field_label . unLoc . dfoLabel .
repE (HsEmbTy _ t) = do
t1 <- repLTy (hswc_body t)
rep2 typeEName [unC t1]
-repE e@(XExpr (ExpandedThingRn o x))
+repE e@(XExpr (ExpandedThingRn o x _))
| OrigExpr e <- o
= do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax
; if rebindable_on -- See Note [Quotation and rebindable syntax]
=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -611,7 +611,7 @@ addTickHsExpr (HsDo srcloc cxt (L l stmts))
_ -> Nothing
addTickHsExpanded :: HsThingRn -> HsExpr GhcTc -> TM (HsExpr GhcTc)
-addTickHsExpanded o@(OrigStmt (L pos LastStmt{})) e
+addTickHsExpanded o@(OrigStmt (L pos LastStmt{}) _) e
-- LastStmt always gets a tick for breakpoint and hpc coverage
= do d <- getDensity
case d of
@@ -752,33 +752,10 @@ addTickStmt isGuard stmt@(RecStmt {})
; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret'
, recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
-addTickStmt isGuard (XStmtLR (ApplicativeStmt body_ty args mb_join)) = do
- args' <- mapM (addTickApplicativeArg isGuard) args
- return (XStmtLR (ApplicativeStmt body_ty args' mb_join))
-
addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
| otherwise = addTickLHsExprRHS e
-addTickApplicativeArg
- :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
- -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
-addTickApplicativeArg isGuard (op, arg) =
- liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
- where
- addTickArg (ApplicativeArgOne m_fail pat expr isBody) =
- ApplicativeArgOne
- <$> mapM (addTickSyntaxExpr hpcSrcSpan) m_fail
- <*> addTickLPat pat
- <*> addTickLHsExpr expr
- <*> pure isBody
- addTickArg (ApplicativeArgMany x stmts ret pat ctxt) =
- (ApplicativeArgMany x)
- <$> addTickLStmts isGuard stmts
- <*> (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) ret))
- <*> addTickLPat pat
- <*> pure ctxt
-
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
-> TM (ParStmtBlock GhcTc GhcTc)
addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) =
@@ -967,8 +944,6 @@ addTickCmdStmt stmt@(RecStmt {})
; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret'
, recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
-addTickCmdStmt (XStmtLR (ApplicativeStmt{})) =
- panic "ToDo: addTickCmdStmt ApplicativeLastStmt"
-- Others should never happen in a command context.
addTickCmdStmt stmt = pprPanic "addTickHsCmd" (ppr stmt)
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1370,7 +1370,6 @@ instance ( ToHie (LocatedA (body (GhcPass p)))
]
XStmtLR x -> case hiePass @p of
HieRn -> extApplicativeStmt x
- HieTc -> extApplicativeStmt x
where
node = case hiePass @p of
HieTc -> makeNodeA stmt span
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -2221,12 +2221,12 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
(stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset
(mb_ret, fvs1) <-
if | L _ (XStmtLR ApplicativeStmt{}) <- last stmts' ->
- return (unLoc tup, emptyNameSet)
+ return (tup, emptyNameSet)
| otherwise -> do
-- Need 'pureAName' and not 'returnMName' here, so that it requires
-- 'Applicative' and not 'Monad' whenever possible (until #20540 is fixed).
(ret, _) <- lookupQualifiedDoExpr (HsDoStmt ctxt) pureAName
- let expr = HsApp noExtField (noLocA ret) tup
+ let expr = noLocA (HsApp noExtField (noLocA ret) tup)
return (expr, emptyFVs)
return ( ApplicativeArgMany
{ xarg_app_arg_many = noExtField
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -464,10 +464,12 @@ tcValArgs do_ql args
-- Now check the argument
; arg' <- tcScalingUsage mult $
- do { traceTc "tcEValArg" $
- vcat [ ppr ctxt
- , text "arg type:" <+> ppr arg_ty
- , text "arg:" <+> ppr arg ]
+ do { ingencode <- inGeneratedCode
+ ; traceTc "tcEValArg" $
+ vcat [ ppr ctxt
+ , text "arg type:" <+> ppr arg_ty
+ , text "arg:" <+> ppr arg
+ , ppr ingencode ]
; tcEValArg ctxt arg arg_ty }
; return (eva { eva_arg = ValArg arg'
@@ -537,7 +539,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
fun_orig
| VAExpansion (OrigStmt{}) _ _ <- fun_ctxt
= DoOrigin
- | VAExpansion (OrigPat pat) _ _ <- fun_ctxt
+ | VAExpansion (OrigPat pat _) _ _ <- fun_ctxt
= DoPatOrigin pat
| VAExpansion (OrigExpr e) _ _ <- fun_ctxt
= exprCtOrigin e
@@ -731,9 +733,8 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
-- representation; matchActualFunTy checks that when
-- taking apart the arrow type (a -> Int).
matchActualFunTy herald
- (Just $ HsExprTcThing tc_fun)
- (n_val_args, fun_sigma) fun_ty
-
+ (Just $ HsExprTcThing tc_fun)
+ (n_val_args, fun_sigma) fun_ty
; (delta', arg') <- if do_ql
then addArgCtxt ctxt arg $
-- Context needed for constraints
@@ -796,28 +797,37 @@ addArgCtxt :: AppCtxt -> LHsExpr GhcRn
addArgCtxt ctxt (L arg_loc arg) thing_inside
= do { in_generated_code <- inGeneratedCode
; case ctxt of
- VACall fun arg_no _ | not in_generated_code
+ VACall _ _ _
+ | XExpr (PopErrCtxt{}) <- arg
+ -> thing_inside
+ VACall _ _ _
+ | XExpr (ExpandedThingRn o _ _) <- arg
+ , isHsThingRnStmt o || isHsThingRnPat o
+ -> thing_inside
+
+ VACall fun arg_no _
+ | not in_generated_code
-> do setSrcSpanA arg_loc $
addErrCtxt (funAppCtxt fun arg arg_no) $
thing_inside
- VAExpansion (OrigStmt (L _ stmt@(BindStmt {}))) _ loc
+ VAExpansion (OrigStmt (L _ stmt@(BindStmt {})) flav) _ loc
| isGeneratedSrcSpan (locA arg_loc) -- This arg is the second argument to generated (>>=)
-> setSrcSpan loc $
- addStmtCtxt stmt $
+ addStmtCtxt stmt flav $
thing_inside
- | otherwise -- This arg is the first argument to generated (>>=)
+ | otherwise -- This arg is the first argument to generated (>>=)
-> setSrcSpanA arg_loc $
- addStmtCtxt stmt $
+ addStmtCtxt stmt flav $
thing_inside
- VAExpansion (OrigStmt (L loc stmt)) _ _
+ VAExpansion (OrigStmt (L loc stmt) flav) _ _
-> setSrcSpanA loc $
- addStmtCtxt stmt $
+ addStmtCtxt stmt flav $
thing_inside
_ -> setSrcSpanA arg_loc $
- addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated
- thing_inside }
+ addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated
+ thing_inside }
{- *********************************************************************
* *
@@ -943,7 +953,7 @@ expr_to_type earg =
| otherwise = not_in_scope
where occ = occName rdr
not_in_scope = failWith $ mkTcRnNotInScope rdr NotInScope
- go (L l (XExpr (ExpandedThingRn (OrigExpr orig) _))) =
+ go (L l (XExpr (ExpandedThingRn (OrigExpr orig) _ _))) =
-- Use the original, user-written expression (before expansion).
-- Example. Say we have vfun :: forall a -> blah
-- and the call vfun (Maybe [1,2,3])
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -21,8 +21,8 @@ module GHC.Tc.Gen.Do (expandDoStmts) where
import GHC.Prelude
-import GHC.Rename.Utils ( wrapGenSpan, genHsExpApps, genHsApp, genHsLet,
- genHsLamDoExp, genHsCaseAltDoExp, genWildPat )
+import GHC.Rename.Utils ( wrapGenSpan, genHsExpApps, genHsApp, genHsLet, genLHsApp,
+ genHsLamDoExp, genHsCaseAltDoExp )
import GHC.Tc.Utils.Monad
import GHC.Tc.Gen.Pat
import GHC.Tc.Utils.TcMType
@@ -53,66 +53,56 @@ import Data.List ((\\))
-- so that they can be typechecked.
-- See Note [Expanding HsDo with XXExprGhcRn] below for `HsDo` specific commentary
-- and Note [Handling overloaded and rebindable constructs] for high level commentary
-expandDoStmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
-expandDoStmts doFlav stmts = do expanded_expr <- expand_do_stmts doFlav stmts
- case expanded_expr of
- L _ (XExpr (PopErrCtxt e)) -> return e
- -- The first expanded stmt doesn't need a pop as
- -- it would otherwise pop the "In the expression do ... " from
- -- the error context
- _ -> return expanded_expr
+expandDoStmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (HsExpr GhcRn)
+expandDoStmts doFlav stmts = unLoc <$> expand_do_stmts False doFlav stmts
-- | The main work horse for expanding do block statements into applications of binds and thens
-- See Note [Expanding HsDo with XXExprGhcRn]
-expand_do_stmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
+expand_do_stmts :: Bool -> HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
-expand_do_stmts ListComp _ =
+expand_do_stmts _ ListComp _ =
pprPanic "expand_do_stmts: impossible happened. ListComp" empty
-- handeled by `GHC.Tc.Gen.Match.tcLcStmt`
-expand_do_stmts _ [] = pprPanic "expand_do_stmts: impossible happened. Empty stmts" empty
+expand_do_stmts _ _ [] = pprPanic "expand_do_stmts: impossible happened. Empty stmts" empty
-expand_do_stmts _ (stmt@(L _ (TransStmt {})):_) =
+expand_do_stmts _ _ (stmt@(L _ (TransStmt {})):_) =
pprPanic "expand_do_stmts: TransStmt" $ ppr stmt
-- handeled by `GHC.Tc.Gen.Match.tcLcStmt`
-expand_do_stmts _ (stmt@(L _ (ParStmt {})):_) =
+expand_do_stmts _ _ (stmt@(L _ (ParStmt {})):_) =
pprPanic "expand_do_stmts: ParStmt" $ ppr stmt
-- handeled by `GHC.Tc.Gen.Match.tcLcStmt`
-expand_do_stmts _ (stmt@(L _ (XStmtLR ApplicativeStmt{})): _) =
- pprPanic "expand_do_stmts: Applicative Stmt" $ ppr stmt
- -- Handeled by tcSyntaxOp see `GHC.Tc.Gen.Match.tcStmtsAndThen`
-
-
-expand_do_stmts _ [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_expr))]
+expand_do_stmts addPop flav [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_expr))]
-- See Note [Expanding HsDo with XXExprGhcRn] Equation (5) below
-- last statement of a list comprehension, needs to explicitly return it
-- See `checkLastStmt` and `Syntax.Expr.StmtLR.LastStmt`
| NoSyntaxExprRn <- ret_expr
-- Last statement is just body if we are not in ListComp context. See Syntax.Expr.LastStmt
- = do traceTc "expand_do_stmts last" (ppr ret_expr)
- return $ mkExpandedStmtPopAt loc stmt body
+ = return $ if addPop then mkExpandedStmtPopAt loc stmt flav TcExpr body
+ else mkExpandedStmtAt loc stmt flav TcExpr body
| SyntaxExprRn ret <- ret_expr
--
-- ------------------------------------------------
-- return e ~~> return e
-- to make T18324 work
- = do traceTc "expand_do_stmts last" (ppr ret_expr)
- let expansion = genHsApp ret (L body_loc body)
- return $ mkExpandedStmtPopAt loc stmt expansion
+ = do let expansion = genHsApp ret (L body_loc body)
+ return $ if addPop then mkExpandedStmtPopAt loc stmt flav TcExpr expansion
+ else mkExpandedStmtAt loc stmt flav TcExpr expansion
-expand_do_stmts do_or_lc (stmt@(L loc (LetStmt _ bs)) : lstmts) =
+expand_do_stmts addPop doFlavour (stmt@(L loc (LetStmt _ bs)) : lstmts) =
-- See Note [Expanding HsDo with XXExprGhcRn] Equation (3) below
-- stmts ~~> stmts'
-- ------------------------------------------------
-- let x = e ; stmts ~~> let x = e in stmts'
- do expand_stmts <- expand_do_stmts do_or_lc lstmts
+ do expand_stmts <- expand_do_stmts True doFlavour lstmts
let expansion = genHsLet bs expand_stmts
- return $ mkExpandedStmtPopAt loc stmt expansion
+ return $ if addPop then mkExpandedStmtPopAt loc stmt doFlavour TcExpr expansion
+ else mkExpandedStmtAt loc stmt doFlavour TcExpr expansion
-expand_do_stmts do_or_lc (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
+expand_do_stmts addPop doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
| SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
, fail_op <- xbsrn_failOp xbsrn
-- See Note [Expanding HsDo with XXExprGhcRn] Equation (2) below
@@ -121,29 +111,31 @@ expand_do_stmts do_or_lc (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
-- _ -> fail "Pattern match failure .."
-- -------------------------------------------------------
-- pat <- e ; stmts ~~> (>>=) e f
- = do expand_stmts <- expand_do_stmts do_or_lc lstmts
- failable_expr <- mk_failable_expr do_or_lc pat expand_stmts fail_op
+ = do expand_stmts <- expand_do_stmts True doFlavour lstmts
+ failable_expr <- mk_failable_expr doFlavour Nothing pat expand_stmts fail_op
let expansion = genHsExpApps bind_op -- (>>=)
[ e
, failable_expr ]
- return $ mkExpandedStmtPopAt loc stmt expansion
+ return $ if addPop then mkExpandedStmtPopAt loc stmt doFlavour TcApp expansion
+ else mkExpandedStmtAt loc stmt doFlavour TcApp expansion
| otherwise
= pprPanic "expand_do_stmts: The impossible happened, missing bind operator from renamer" (text "stmt" <+> ppr stmt)
-expand_do_stmts do_or_lc (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _)) : lstmts) =
+expand_do_stmts addPop doFlavour (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _)) : lstmts) =
-- See Note [BodyStmt] in Language.Haskell.Syntax.Expr
-- See Note [Expanding HsDo with XXExprGhcRn] Equation (1) below
-- stmts ~~> stmts'
-- ----------------------------------------------
-- e ; stmts ~~> (>>) e stmts'
- do expand_stmts_expr <- expand_do_stmts do_or_lc lstmts
+ do expand_stmts_expr <- expand_do_stmts True doFlavour lstmts
let expansion = genHsExpApps then_op -- (>>)
[ e
, expand_stmts_expr ]
- return $ mkExpandedStmtPopAt loc stmt expansion
+ return $ if addPop then mkExpandedStmtPopAt loc stmt doFlavour TcApp expansion
+ else mkExpandedStmtAt loc stmt doFlavour TcApp expansion
-expand_do_stmts do_or_lc
+expand_do_stmts _ doFlavour
((L loc (RecStmt { recS_stmts = L stmts_loc rec_stmts
, recS_later_ids = later_ids -- forward referenced local ids
, recS_rec_ids = local_ids -- ids referenced outside of the rec block
@@ -163,12 +155,12 @@ expand_do_stmts do_or_lc
-- -> do { rec_stmts
-- ; return (local_only_ids ++ later_ids) } ))
-- (\ [ local_only_ids ++ later_ids ] -> stmts')
- do expand_stmts <- expand_do_stmts do_or_lc lstmts
+ do expand_stmts <- expand_do_stmts True doFlavour lstmts
-- NB: No need to wrap the expansion with an ExpandedStmt
-- as we want to flatten the rec block statements into its parent do block anyway
return $ mkHsApps (wrapGenSpan bind_fun) -- (>>=)
[ (wrapGenSpan mfix_fun) `mkHsApp` mfix_expr -- (mfix (do block))
- , genHsLamDoExp do_or_lc [ mkBigLHsVarPatTup all_ids ] -- (\ x ->
+ , genHsLamDoExp doFlavour [ mkBigLHsVarPatTup all_ids ] -- (\ x ->
expand_stmts -- stmts')
]
where
@@ -184,33 +176,112 @@ expand_do_stmts do_or_lc
do_stmts :: XRec GhcRn [ExprLStmt GhcRn]
do_stmts = L stmts_loc $ rec_stmts ++ [return_stmt]
do_block :: LHsExpr GhcRn
- do_block = L loc $ HsDo noExtField do_or_lc do_stmts
+ do_block = L loc $ HsDo noExtField doFlavour do_stmts
mfix_expr :: LHsExpr GhcRn
- mfix_expr = genHsLamDoExp do_or_lc [ wrapGenSpan (LazyPat noExtField $ mkBigLHsVarPatTup all_ids) ]
+ mfix_expr = genHsLamDoExp doFlavour [ wrapGenSpan (LazyPat noExtField $ mkBigLHsVarPatTup all_ids) ]
$ do_block
-- NB: LazyPat because we do not want to eagerly evaluate the pattern
-- and potentially loop forever
-expand_do_stmts _ stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr stmts)
+expand_do_stmts addPop doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join))): lstmts) =
+-- See Note [Applicative BodyStmt]
+--
+-- stmts ~~> stmts'
+-- -------------------------------------------------------------------------
+-- [(fmap, \ x -> e1), (<*>, e2), (<*>, e3), .. ] ; stmts ~~> (\ x -> stmts') <$> e1 <*> e2 ...
+--
+-- Very similar to HsToCore.Expr.dsDo
+
+-- args are [(<$>, e1), (<*>, e2), .., ]
+ do { xexpr <- expand_do_stmts False doFlavour lstmts
+ -- extracts pats and arg bodies (rhss) from args
+
+ ; (pats_can_fail, rhss) <- unzip <$> mapM (do_arg . snd) args
+
+ -- add blocks for failable patterns
+ ; body_with_fails <- foldrM match_args xexpr (zip pats_can_fail rhss)
+
+ -- builds (body <$> e1 <*> e2 ...)
+ ; let expand_ado_expr = foldl mk_apps body_with_fails (zip (map fst args) rhss)
+
+ -- wrap the expanded expression with a `join` if needed
+ ; let final_expr = case mb_join of
+ Just (SyntaxExprRn join_op)
+ -> genLHsApp join_op expand_ado_expr
+ _ -> expand_ado_expr
+ ; traceTc "expand_do_stmts AppStmt" (vcat [ text "args:" <+> ppr args
+ , text "lstmts:" <+> ppr lstmts
+ , text "mb_join:" <+> ppr mb_join
+ , text "expansion:" <+> ppr final_expr])
+ ; return $ final_expr
+
+ }
+ where
+ do_arg :: ApplicativeArg GhcRn -> TcM ((LPat GhcRn, FailOperator GhcRn), LHsExpr GhcRn)
+ do_arg (ApplicativeArgOne
+ { xarg_app_arg_one = mb_fail_op
+ , app_arg_pattern = pat
+ , arg_expr = (L rhs_loc rhs)
+ , is_body_stmt = is_body_stmt
+ }) =
+ do let xx_expr = if addPop then mkExpandedStmtPopAt rhs_loc stmt doFlavour TcExpr rhs
+ else mkExpandedStmtAt rhs_loc stmt doFlavour TcExpr rhs
+ traceTc "do_arg" (text "OneArg" <+> vcat [ppr pat, ppr xx_expr])
+ return ((pat, mb_fail_op)
+ , xx_expr)
+ where stmt = if is_body_stmt
+ then (L rhs_loc (BodyStmt NoExtField (L rhs_loc rhs) NoSyntaxExprRn NoSyntaxExprRn))
+ else (L rhs_loc (BindStmt xbsn pat (L rhs_loc rhs)))
+ do_arg (ApplicativeArgMany _ stmts ret@(L ret_loc _) pat ctxt) =
+ do { xx_expr <- expand_do_stmts False ctxt $ stmts ++ [L ret_loc $ mkLastStmt ret]
+ ; traceTc "do_arg" (text "ManyArg" <+> vcat [ppr stmts, text "--", ppr xx_expr])
+ ; return ((pat, Nothing)
+ , xx_expr) }
+
+ match_args :: ((LPat GhcRn, FailOperator GhcRn), LHsExpr GhcRn) -> LHsExpr GhcRn -> TcM (LHsExpr GhcRn)
+ match_args ((pat, fail_op), stmt_expr) body = mk_failable_expr doFlavour stmt_ctxt pat body fail_op
+ where stmt_ctxt = case unLoc stmt_expr of
+ XExpr (ExpandedThingRn (OrigStmt s _) _ _) -> Just (doFlavour, s)
+ _ -> Nothing
+
+ mk_apps :: LHsExpr GhcRn -> (SyntaxExprRn, LHsExpr GhcRn) -> LHsExpr GhcRn
+ mk_apps l_expr (op, r_expr) =
+ case op of
+ SyntaxExprRn op -> wrapGenSpan $ genHsExpApps op [ l_expr, r_expr ]
+ NoSyntaxExprRn -> pprPanic "expand_do_stmts applicative op:" (ppr op)
+
+ xbsn :: XBindStmtRn
+ xbsn = XBindStmtRn NoSyntaxExprRn Nothing
+
+
+expand_do_stmts _ _ stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr stmts)
-- checks the pattern `pat`for irrefutability which decides if we need to wrap it with a fail block
-mk_failable_expr :: HsDoFlavour -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
-mk_failable_expr doFlav pat@(L loc _) expr fail_op =
+mk_failable_expr :: HsDoFlavour -> Maybe (HsDoFlavour, ExprLStmt GhcRn)
+ -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
+mk_failable_expr doFlav mb_stmt_info lpat@(L loc pat) expr fail_op =
do { is_strict <- xoptM LangExt.Strict
- ; irrf_pat <- isIrrefutableHsPatRnTcM is_strict pat
- ; traceTc "mk_failable_expr" (vcat [ text "pat:" <+> ppr pat
+ ; irrf_pat <- isIrrefutableHsPatRnTcM is_strict lpat
+ ; traceTc "mk_failable_expr" (vcat [ text "pat:" <+> ppr lpat
, text "isIrrefutable:" <+> ppr irrf_pat
])
; if irrf_pat -- don't wrap with fail block if
-- the pattern is irrefutable
- then return $ genHsLamDoExp doFlav [pat] expr
- else L loc <$> mk_fail_block doFlav pat expr fail_op
+ then case pat of
+ (WildPat{}) -> return $ genHsLamDoExp doFlav [L noSrcSpanA pat] expr
+ _ -> return $ case mb_stmt_info of
+ Nothing -> genHsLamDoExp doFlav [lpat] expr
+ Just (f, s) -> wrapGenSpan (mkExpandedStmt s f TcExpr
+ (unLoc $ (genHsLamDoExp f [lpat]
+ $ wrapGenSpan (mkPopErrCtxtExpr expr))))
+ else L loc <$> mk_fail_block doFlav mb_stmt_info lpat expr fail_op
}
-- makes the fail block with a given fail_op
-mk_fail_block :: HsDoFlavour -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (HsExpr GhcRn)
-mk_fail_block doFlav pat@(L ploc _) e (Just (SyntaxExprRn fail_op)) =
+mk_fail_block :: HsDoFlavour -> Maybe (HsDoFlavour, ExprLStmt GhcRn)
+ -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (HsExpr GhcRn)
+mk_fail_block doFlav mb_stmt_info pat@(L ploc _) e (Just (SyntaxExprRn fail_op)) =
do dflags <- getDynFlags
return $ HsLam noAnn LamCases $ mkMatchGroup (doExpansionOrigin doFlav) -- \
(wrapGenSpan [ genHsCaseAltDoExp doFlav pat e -- pat -> expr
@@ -218,22 +289,22 @@ mk_fail_block doFlav pat@(L ploc _) e (Just (SyntaxExprRn fail_op)) =
])
where
fail_alt_case :: DynFlags -> LPat GhcRn -> HsExpr GhcRn -> LMatch GhcRn (LHsExpr GhcRn)
- fail_alt_case dflags pat fail_op = genHsCaseAltDoExp doFlav genWildPat $
+ fail_alt_case dflags pat fail_op = genHsCaseAltDoExp doFlav (L ploc $ WildPat noExtField) $
L ploc (fail_op_expr dflags pat fail_op)
fail_op_expr :: DynFlags -> LPat GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
fail_op_expr dflags pat fail_op
- = mkExpandedPatRn pat $
+ = mkExpandedPatRn pat mb_stmt_info $
genHsApp fail_op (mk_fail_msg_expr dflags pat)
mk_fail_msg_expr :: DynFlags -> LPat GhcRn -> LHsExpr GhcRn
mk_fail_msg_expr dflags pat
= nlHsLit $ mkHsString $ showPpr dflags $
- text "Pattern match failure in" <+> pprHsDoFlavour (DoExpr Nothing)
+ text "Pattern match failure in" <+> pprHsDoFlavour doFlav
<+> text "at" <+> ppr (getLocA pat)
-mk_fail_block _ _ _ _ = pprPanic "mk_fail_block: impossible happened" empty
+mk_fail_block _ _ _ _ _ = pprPanic "mk_fail_block: impossible happened" empty
{- Note [Expanding HsDo with XXExprGhcRn]
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -710,27 +710,25 @@ tcXExpr (PopErrCtxt (L loc e)) res_ty
setSrcSpanA loc $
tcExpr e res_ty
-tcXExpr xe@(ExpandedThingRn o e') res_ty
- | OrigStmt ls@(L loc s at LetStmt{}) <- o
+tcXExpr xe@(ExpandedThingRn o e' tc_info) res_ty
+ | OrigStmt ls@(L loc s at LetStmt{}) flav <- o
, HsLet x binds e <- e'
= do { (binds', wrapper, e') <- setSrcSpanA loc $
- addStmtCtxt s $
+ addStmtCtxt s flav $
tcLocalBinds binds $
tcMonoExprNC e res_ty -- NB: Do not call tcMonoExpr here as it adds
-- a duplicate error context
- ; return $ mkExpandedStmtTc ls (HsLet x binds' (mkLHsWrap wrapper e'))
+ ; return $ mkExpandedStmtTc ls flav (HsLet x binds' (mkLHsWrap wrapper e'))
}
- | OrigStmt ls@(L loc s at LastStmt{}) <- o
- = setSrcSpanA loc $
- addStmtCtxt s $
- mkExpandedStmtTc ls <$> tcExpr e' res_ty
- -- It is important that we call tcExpr (and not tcApp) here as
- -- `e` is the last statement's body expression
- -- and not a HsApp of a generated (>>) or (>>=)
- -- This improves error messages e.g. tests: DoExpansion1, DoExpansion2, DoExpansion3
- | OrigStmt ls@(L loc _) <- o
+ | OrigStmt ls@(L loc s) flav <- o
+ , TcExpr <- tc_info
= setSrcSpanA loc $
- mkExpandedStmtTc ls <$> tcApp (XExpr xe) res_ty
+ addStmtCtxt s flav $
+ mkExpandedStmtTc ls flav <$> tcExpr e' res_ty
+ | OrigStmt ls@(L loc _) flav <- o
+ , TcApp <- tc_info
+ = setSrcSpanA loc $
+ mkExpandedStmtTc ls flav <$> tcApp (XExpr xe) res_ty
tcXExpr xe res_ty = tcApp (XExpr xe) res_ty
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -240,7 +240,8 @@ appCtxtLoc (VACall _ _ l) = l
insideExpansion :: AppCtxt -> Bool
insideExpansion (VAExpansion {}) = True
-insideExpansion (VACall {}) = False -- but what if the VACall has a generated context?
+insideExpansion (VACall _ _ src) = isGeneratedSrcSpan src
+-- insideExpansion (VACall {}) = False -- but what if the VACall has a generated context?
instance Outputable AppCtxt where
ppr (VAExpansion e l _) = text "VAExpansion" <+> ppr e <+> ppr l
@@ -292,7 +293,7 @@ splitHsApps e = go e (top_ctxt 0 e) []
top_ctxt n (HsPragE _ _ fun) = top_lctxt n fun
top_ctxt n (HsAppType _ fun _) = top_lctxt (n+1) fun
top_ctxt n (HsApp _ fun _) = top_lctxt (n+1) fun
- top_ctxt n (XExpr (ExpandedThingRn o _))
+ top_ctxt n (XExpr (ExpandedThingRn o _ _))
| OrigExpr fun <- o = VACall fun n noSrcSpan
top_ctxt n other_fun = VACall other_fun n noSrcSpan
@@ -317,19 +318,19 @@ splitHsApps e = go e (top_ctxt 0 e) []
HsQuasiQuote _ _ (L l _) -> set l ctxt -- l :: SrcAnn NoEpAnns
-- See Note [Looking through ExpandedThingRn]
- go (XExpr (ExpandedThingRn o e)) ctxt args
+ go (XExpr (ExpandedThingRn o e _)) ctxt args
| isHsThingRnExpr o
= go e (VAExpansion o (appCtxtLoc ctxt) (appCtxtLoc ctxt))
(EWrap (EExpand o) : args)
- | OrigStmt (L _ stmt) <- o -- so that we set `(>>)` as generated
+ | OrigStmt (L _ stmt) _ <- o -- so that we set `(>>)` as generated
, BodyStmt{} <- stmt -- and get the right unused bind warnings
= go e (VAExpansion o generatedSrcSpan generatedSrcSpan)
-- See Part 3. in Note [Expanding HsDo with XXExprGhcRn]
(EWrap (EExpand o) : args) -- in `GHC.Tc.Gen.Do`
- | OrigPat (L loc _) <- o -- so that we set the compiler generated fail context
+ | OrigPat (L loc _) _ <- o -- so that we set the compiler generated fail context
= go e (VAExpansion o (locA loc) (locA loc)) -- to be originating from a failable pattern
-- See Part 1. Wrinkle 2. of
(EWrap (EExpand o) : args) -- Note [Expanding HsDo with XXExprGhcRn]
@@ -893,17 +894,20 @@ tcInferAppHead_maybe fun
_ -> return Nothing
addHeadCtxt :: AppCtxt -> TcM a -> TcM a
-addHeadCtxt (VAExpansion (OrigStmt (L loc stmt)) _ _) thing_inside =
- do setSrcSpanA loc $
- addStmtCtxt stmt
+addHeadCtxt (VAExpansion (OrigStmt (L loc stmt) flav) _ _) thing_inside =
+ do traceTc "addHeadCtxt stmt" (ppr stmt)
+ setSrcSpanA loc $
+ addStmtCtxt stmt flav $
thing_inside
addHeadCtxt fun_ctxt thing_inside
| not (isGoodSrcSpan fun_loc) -- noSrcSpan => no arguments
= thing_inside -- => context is already set
| otherwise
= setSrcSpan fun_loc $
- do case fun_ctxt of
+ do traceTc "addHeadCtxt fun_loc" (ppr fun_ctxt)
+ case fun_ctxt of
VAExpansion (OrigExpr orig) _ _ -> addExprCtxt orig thing_inside
+ VAExpansion (OrigPat _ (Just (flav, stmt))) _ _ -> addStmtCtxt (unLoc stmt) flav $ thing_inside
_ -> thing_inside
where
fun_loc = appCtxtLoc fun_ctxt
@@ -1587,9 +1591,9 @@ mis-match in the number of value arguments.
* *
********************************************************************* -}
-addStmtCtxt :: ExprStmt GhcRn -> TcRn a -> TcRn a
-addStmtCtxt stmt thing_inside
- = do let err_doc = pprStmtInCtxt (HsDoStmt (DoExpr Nothing)) stmt
+addStmtCtxt :: ExprStmt GhcRn -> HsDoFlavour -> TcRn a -> TcRn a
+addStmtCtxt stmt flav thing_inside
+ = do let err_doc = pprStmtInCtxt (HsDoStmt flav) stmt
addErrCtxt err_doc thing_inside
where
pprStmtInCtxt :: HsStmtContextRn -> StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> SDoc
@@ -1602,6 +1606,7 @@ addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt e thing_inside
= case e of
HsUnboundVar {} -> thing_inside
+ XExpr (ExpandedThingRn (OrigStmt stmt flav) _ _) -> addStmtCtxt (unLoc stmt) flav thing_inside
_ -> addErrCtxt (exprCtxt e) thing_inside
-- The HsUnboundVar special case addresses situations like
-- f x = _
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -78,13 +78,9 @@ import GHC.Types.SrcLoc
import GHC.Types.Basic( VisArity, isDoExpansionGenerated )
import Control.Monad
-import Control.Arrow ( second )
import qualified Data.List.NonEmpty as NE
import Data.Maybe (mapMaybe)
-import qualified GHC.LanguageExtensions as LangExt
-
-
{-
************************************************************************
* *
@@ -353,20 +349,16 @@ tcDoStmts ListComp (L l stmts) res_ty
(mkCheckExpType elt_ty)
; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) }
-tcDoStmts doExpr@(DoExpr _) ss@(L l stmts) res_ty
- = do { isApplicativeDo <- xoptM LangExt.ApplicativeDo
- ; if isApplicativeDo
- then do { stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty
- ; res_ty <- readExpType res_ty
- ; return (HsDo res_ty doExpr (L l stmts')) }
- else do { expanded_expr <- expandDoStmts doExpr stmts
- -- Do expansion on the fly
- ; mkExpandedExprTc (HsDo noExtField doExpr ss) <$> tcExpr (unLoc expanded_expr) res_ty }
+tcDoStmts doExpr@(DoExpr _) ss@(L _ stmts) res_ty
+ = do { traceTc "tcDoStmts" $ text "original:" <+> ppr ss
+ ; expanded_expr <- expandDoStmts doExpr stmts -- Do expansion on the fly
+ ; traceTc "tcDoStmts" $ text "expansion:" <+> ppr expanded_expr
+ ; mkExpandedExprTc (HsDo noExtField doExpr ss) <$> tcExpr expanded_expr res_ty
}
tcDoStmts mDoExpr@(MDoExpr _) ss@(L _ stmts) res_ty
= do { expanded_expr <- expandDoStmts mDoExpr stmts -- Do expansion on the fly
- ; mkExpandedExprTc (HsDo noExtField mDoExpr ss) <$> tcExpr (unLoc expanded_expr) res_ty }
+ ; mkExpandedExprTc (HsDo noExtField mDoExpr ss) <$> tcExpr expanded_expr res_ty }
tcDoStmts MonadComp (L l stmts) res_ty
= do { stmts' <- tcStmts (HsDoStmt MonadComp) tcMcStmt stmts res_ty
@@ -997,18 +989,6 @@ tcDoStmt ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names
, recS_ret_ty = stmts_ty} }, thing)
}}
-tcDoStmt ctxt (XStmtLR (ApplicativeStmt _ pairs mb_join)) res_ty thing_inside
- = do { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $
- thing_inside . mkCheckExpType
- ; ((pairs', body_ty, thing), mb_join') <- case mb_join of
- Nothing -> (, Nothing) <$> tc_app_stmts res_ty
- Just join_op ->
- second Just <$>
- (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $
- \ [rhs_ty] [rhs_mult] -> tcScalingUsage rhs_mult $ tc_app_stmts (mkCheckExpType rhs_ty))
-
- ; return (XStmtLR $ ApplicativeStmt body_ty pairs' mb_join', thing) }
-
tcDoStmt _ stmt _ _
= pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
@@ -1084,87 +1064,6 @@ To achieve this we:
all branches. This step is done with bindLocalNames.
-}
-tcApplicativeStmts
- :: HsStmtContextRn
- -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
- -> ExpRhoType -- rhs_ty
- -> (TcRhoType -> TcM t) -- thing_inside
- -> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Type, t)
-
-tcApplicativeStmts ctxt pairs rhs_ty thing_inside
- = do { body_ty <- newFlexiTyVarTy liftedTypeKind
- ; let arity = length pairs
- ; ts <- replicateM (arity-1) $ newInferExpType
- ; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
- ; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
- ; let fun_ty = mkVisFunTysMany pat_tys body_ty
-
- -- NB. do the <$>,<*> operators first, we don't want type errors here
- -- i.e. goOps before goArgs
- -- See Note [Treat rebindable syntax first]
- ; let (ops, args) = unzip pairs
- ; ops' <- goOps fun_ty (zip3 ops (ts ++ [rhs_ty]) exp_tys)
-
- -- Typecheck each ApplicativeArg separately
- -- See Note [ApplicativeDo and constraints]
- ; 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
- -- See Note [ApplicativeDo and constraints]
- ; res <- tcExtendIdEnv (concatMap get_arg_bndrs args') $
- thing_inside body_ty
-
- ; return (zip ops' args', body_ty, res) }
- where
- goOps _ [] = return []
- goOps t_left ((op,t_i,exp_ty) : ops)
- = do { (_, op')
- <- tcSyntaxOp DoOrigin op
- [synKnownType t_left, synKnownType exp_ty] t_i $
- \ _ _ -> return ()
- ; t_i <- readExpType t_i
- ; ops' <- goOps t_i ops
- ; return (op' : ops') }
-
- goArg :: Type -> (ApplicativeArg GhcRn, Type, Type)
- -> TcM (ApplicativeArg GhcTc)
-
- goArg body_ty (ApplicativeArgOne
- { xarg_app_arg_one = fail_op
- , app_arg_pattern = pat
- , arg_expr = rhs
- , ..
- }, pat_ty, exp_ty)
- = setSrcSpan (combineSrcSpans (getLocA pat) (getLocA rhs)) $
- addErrCtxt (pprStmtInCtxt ctxt (mkRnBindStmt pat rhs)) $
- do { rhs' <- tcCheckMonoExprNC rhs exp_ty
- ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $
- return ()
- ; fail_op' <- fmap join . forM fail_op $ \fail ->
- tcMonadFailOp (DoPatOrigin pat) pat' fail body_ty
-
- ; return (ApplicativeArgOne
- { xarg_app_arg_one = fail_op'
- , app_arg_pattern = pat'
- , arg_expr = rhs'
- , .. }
- ) }
-
- goArg _body_ty (ApplicativeArgMany x stmts ret pat ctxt, pat_ty, exp_ty)
- = do { (stmts', (ret',pat')) <-
- tcStmtsAndThen (HsDoStmt ctxt) tcDoStmt stmts (mkCheckExpType exp_ty) $
- \res_ty -> do
- { ret' <- tcExpr ret res_ty
- ; (pat', _) <- tcCheckPat (StmtCtxt (HsDoStmt ctxt)) pat (unrestricted pat_ty) $
- return ()
- ; return (ret', pat')
- }
- ; return (ApplicativeArgMany x stmts' ret' pat' ctxt) }
-
- get_arg_bndrs :: ApplicativeArg GhcTc -> [Id]
- get_arg_bndrs (ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders CollNoDictBinders pat
- get_arg_bndrs (ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders CollNoDictBinders pat
{- Note [ApplicativeDo and constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -751,9 +751,9 @@ exprCtOrigin (HsUntypedSplice {}) = Shouldn'tHappenOrigin "TH untyped splice"
exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc"
exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression"
exprCtOrigin (HsEmbTy {}) = Shouldn'tHappenOrigin "type expression"
-exprCtOrigin (XExpr (ExpandedThingRn thing _)) | OrigExpr a <- thing = exprCtOrigin a
- | OrigStmt _ <- thing = DoOrigin
- | OrigPat p <- thing = DoPatOrigin p
+exprCtOrigin (XExpr (ExpandedThingRn thing _ _)) | OrigExpr a <- thing = exprCtOrigin a
+ | OrigStmt _ _ <- thing = DoOrigin
+ | OrigPat p _ <- thing = DoPatOrigin p
exprCtOrigin (XExpr (PopErrCtxt {})) = Shouldn'tHappenOrigin "PopErrCtxt"
-- | Extract a suitable CtOrigin from a MatchGroup
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -68,6 +68,7 @@ module GHC.Tc.Utils.Monad(
checkErr, checkErrAt,
addMessages,
discardWarnings, mkDetailedMessage,
+ dbgErrCtxt,
-- * Usage environment
tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage,
@@ -1230,7 +1231,7 @@ setErrCtxt ctxt = updLclEnv (setLclEnvErrCtxt ctxt)
-- do any tidying.
addErrCtxt :: SDoc -> TcM a -> TcM a
{-# INLINE addErrCtxt #-} -- Note [Inlining addErrCtxt]
-addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
+addErrCtxt msg thing_inside = dbgErrCtxt msg (addErrCtxtM (\env -> return (env, msg)) thing_inside)
-- | Add a message to the error context. This message may do tidying.
addErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, SDoc)) -> TcM a -> TcM a
@@ -1255,6 +1256,13 @@ pushCtxt :: ErrCtxt -> TcM a -> TcM a
{-# INLINE pushCtxt #-} -- Note [Inlining addErrCtxt]
pushCtxt ctxt = updLclEnv (updCtxt ctxt)
+dbgErrCtxt :: SDoc -> TcM a -> TcM a
+dbgErrCtxt msg thing_inside =
+ do errCtxt <- getErrCtxt
+ info <- mkErrInfo emptyTidyEnv errCtxt
+ traceTc "--Debug Error Context--" (vcat [ppr msg, text "----", ppr info, text "----"])
+ thing_inside
+
updCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv
-- Do not update the context if we are in generated code
-- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr
@@ -1263,8 +1271,8 @@ updCtxt ctxt env
| otherwise = addLclEnvErrCtxt ctxt env
popErrCtxt :: TcM a -> TcM a
-popErrCtxt thing_inside = updLclEnv (\env -> setLclEnvErrCtxt (pop $ getLclEnvErrCtxt env) env) $
- thing_inside
+popErrCtxt thing_inside = dbgErrCtxt (text "PopErrCtxt") $ updLclEnv (\env -> setLclEnvErrCtxt (pop $ getLclEnvErrCtxt env) env) $
+ thing_inside
where
pop [] = []
pop (_:msgs) = msgs
=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -134,7 +134,7 @@ matchActualFunTy
matchActualFunTy herald mb_thing err_info fun_ty
= assertPpr (isRhoTy fun_ty) (ppr fun_ty) $
- go fun_ty
+ go fun_ty
where
-- Does not allocate unnecessary meta variables: if the input already is
-- a function, we just take it apart. Not only is this efficient,
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -97,7 +97,6 @@ import GHC.Tc.Types.BasicTypes
import GHC.Data.Maybe
import GHC.Data.Bag
-import Control.Monad
import Control.Monad.Trans.Class ( lift )
import Data.Semigroup
@@ -1408,54 +1407,6 @@ zonkStmt zBody (BindStmt xbs pat body)
})
new_pat new_body }
--- Scopes: join > ops (in reverse order) > pats (in forward order)
--- > rest of stmts
-zonkStmt _zBody (XStmtLR (ApplicativeStmt body_ty args mb_join))
- = do { new_mb_join <- zonk_join mb_join
- ; new_args <- zonk_args args
- ; new_body_ty <- noBinders $ zonkTcTypeToTypeX body_ty
- ; return $ XStmtLR $ ApplicativeStmt new_body_ty new_args new_mb_join }
- where
- zonk_join Nothing = return Nothing
- zonk_join (Just j) = Just <$> zonkSyntaxExpr j
-
- get_pat :: (SyntaxExpr GhcTc, ApplicativeArg GhcTc) -> LPat GhcTc
- get_pat (_, ApplicativeArgOne _ pat _ _) = pat
- get_pat (_, ApplicativeArgMany _ _ _ pat _) = pat
-
- replace_pat :: LPat GhcTc
- -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
- -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
- replace_pat pat (op, ApplicativeArgOne fail_op _ a isBody)
- = (op, ApplicativeArgOne fail_op pat a isBody)
- replace_pat pat (op, ApplicativeArgMany x a b _ c)
- = (op, ApplicativeArgMany x a b pat c)
-
- zonk_args args
- = do { new_args_rev <- zonk_args_rev (reverse args)
- ; new_pats <- zonkPats (map get_pat args)
- ; return $ zipWithEqual "zonkStmt" replace_pat
- new_pats (reverse new_args_rev) }
-
- -- these need to go backward, because if any operators are higher-rank,
- -- later operators may introduce skolems that are in scope for earlier
- -- arguments
- zonk_args_rev ((op, arg) : args)
- = do { new_op <- zonkSyntaxExpr op
- ; new_arg <- noBinders $ zonk_arg arg
- ; new_args <- zonk_args_rev args
- ; return $ (new_op, new_arg) : new_args }
- zonk_args_rev [] = return []
-
- zonk_arg (ApplicativeArgOne fail_op pat expr isBody)
- = do { new_expr <- zonkLExpr expr
- ; new_fail <- forM fail_op $ don'tBind . zonkSyntaxExpr
- ; return (ApplicativeArgOne new_fail pat new_expr isBody) }
- zonk_arg (ApplicativeArgMany x stmts ret pat ctxt)
- = runZonkBndrT (zonkStmts zonkLExpr stmts) $ \ new_stmts ->
- do { new_ret <- zonkExpr ret
- ; return (ApplicativeArgMany x new_stmts new_ret pat ctxt) }
-
-------------------------------------------------------------------------
zonkRecFields :: HsRecordBinds GhcTc -> ZonkTcM (HsRecordBinds GhcTc)
zonkRecFields (HsRecFields flds dd)
=====================================
testsuite/tests/ado/T13242a.stderr
=====================================
@@ -1,13 +1,13 @@
-
T13242a.hs:10:5: error: [GHC-46956]
• Couldn't match expected type ‘a0’ with actual type ‘a’
- • because type variable ‘a’ would escape its scope
- This (rigid, skolem) type variable is bound by
- a pattern with constructor: A :: forall a. Eq a => a -> T,
- in a pattern binding in
- a 'do' block
- at T13242a.hs:10:3-5
- • In the expression:
+ because type variable ‘a’ would escape its scope
+ This (rigid, skolem) type variable is bound by
+ a pattern with constructor: A :: forall a. Eq a => a -> T,
+ in a pattern binding in
+ a 'do' block
+ at T13242a.hs:10:3-5
+ • In a stmt of a 'do' block: A x <- undefined
+ In the expression:
do A x <- undefined
_ <- return 'a'
_ <- return 'b'
@@ -29,7 +29,7 @@ T13242a.hs:13:13: error: [GHC-39999]
instance Eq Ordering -- Defined in ‘GHC.Classes’
instance Eq Integer -- Defined in ‘GHC.Num.Integer’
...plus 23 others
- ...plus five instances involving out-of-scope types
+ ...plus six instances involving out-of-scope types
(use -fprint-potential-instances to see them all)
• In a stmt of a 'do' block: return (x == x)
In the expression:
@@ -43,3 +43,4 @@ T13242a.hs:13:13: error: [GHC-39999]
_ <- return 'a'
_ <- return 'b'
return (x == x)
+
=====================================
testsuite/tests/ado/T16135.stderr deleted
=====================================
@@ -1,19 +0,0 @@
-T16135.hs:11:18: error: [GHC-83865]
- • Couldn't match type ‘a0’ with ‘a’
- Expected: f a0
- Actual: f a
- ‘a0’ is untouchable
- inside the constraints: Functor f
- bound by the type signature for:
- runf :: forall (f :: * -> *). Functor f => IO (T f)
- at T16135.hs:7:1-39
- ‘a’ is a rigid type variable bound by
- a pattern with constructor:
- MkT :: forall {k} (f :: k -> *) (a :: k). f a -> T f,
- in a pattern binding in
- a 'do' block
- at T16135.hs:10:5-10
- • In the first argument of ‘MkT’, namely ‘fa’
- In the second argument of ‘($)’, namely ‘MkT fa’
- In a stmt of a 'do' block: return $ MkT fa
- • Relevant bindings include fa :: f a (bound at T16135.hs:10:9)
=====================================
testsuite/tests/ado/T24406.hs
=====================================
@@ -0,0 +1,14 @@
+{-# LANGUAGE ImpredicativeTypes, ApplicativeDo #-}
+module T where
+
+t :: IO (forall a. a -> a)
+t = return id
+
+p :: (forall a. a -> a) -> (Bool, Int)
+p f = (f True, f 3)
+
+-- This typechecks (with QL)
+foo1 = t >>= \x -> return (p x)
+
+-- But this did not not type check:
+foo2 = do { x <- t ; return (p x) }
=====================================
testsuite/tests/ado/ado002.stderr
=====================================
@@ -1,4 +1,3 @@
-
ado002.hs:8:8: error: [GHC-83865]
• Couldn't match expected type: Char -> IO b0
with actual type: IO Char
@@ -24,30 +23,39 @@ ado002.hs:9:3: error: [GHC-83865]
y <- getChar 'a'
print (x, y)
-ado002.hs:15:11: error: [GHC-83865]
- • Couldn't match expected type ‘Int’ with actual type ‘Char’
- • In the expression: y
- In a stmt of a 'do' block: return (y, x)
+ado002.hs:13:8: error: [GHC-83865]
+ • Couldn't match type ‘Char’ with ‘Int’
+ Expected: IO Int
+ Actual: IO Char
+ • In a stmt of a 'do' block: x <- getChar
In the expression:
do x <- getChar
y <- getChar
return (y, x)
+ In an equation for ‘g’:
+ g = do x <- getChar
+ y <- getChar
+ return (y, x)
-ado002.hs:15:13: error: [GHC-83865]
- • Couldn't match expected type ‘Int’ with actual type ‘Char’
- • In the expression: x
- In a stmt of a 'do' block: return (y, x)
+ado002.hs:14:8: error: [GHC-83865]
+ • Couldn't match type ‘Char’ with ‘Int’
+ Expected: IO Int
+ Actual: IO Char
+ • In a stmt of a 'do' block: y <- getChar
In the expression:
do x <- getChar
y <- getChar
return (y, x)
+ In an equation for ‘g’:
+ g = do x <- getChar
+ y <- getChar
+ return (y, x)
-ado002.hs:23:9: error: [GHC-83865]
- • Couldn't match expected type: Char -> IO a0
- with actual type: IO Char
- • The function ‘getChar’ is applied to one visible argument,
- but its type ‘IO Char’ has none
- In a stmt of a 'do' block: x5 <- getChar x4
+ado002.hs:20:9: error: [GHC-83865]
+ • Couldn't match type ‘Char’ with ‘Int’
+ Expected: IO Int
+ Actual: IO Char
+ • In a stmt of a 'do' block: x2 <- getChar
In the expression:
do x1 <- getChar
x2 <- getChar
@@ -55,11 +63,17 @@ ado002.hs:23:9: error: [GHC-83865]
x4 <- getChar
x5 <- getChar x4
return (x2, x4)
+ In an equation for ‘h’:
+ h = do x1 <- getChar
+ x2 <- getChar
+ x3 <- const (return ()) x1
+ x4 <- getChar
+ x5 <- getChar x4
+ return (x2, x4)
-ado002.hs:24:11: error: [GHC-83865]
+ado002.hs:23:3: error: [GHC-83865]
• Couldn't match expected type ‘Int’ with actual type ‘Char’
- • In the expression: x2
- In a stmt of a 'do' block: return (x2, x4)
+ • In a stmt of a 'do' block: x4 <- getChar
In the expression:
do x1 <- getChar
x2 <- getChar
@@ -67,11 +81,20 @@ ado002.hs:24:11: error: [GHC-83865]
x4 <- getChar
x5 <- getChar x4
return (x2, x4)
+ In an equation for ‘h’:
+ h = do x1 <- getChar
+ x2 <- getChar
+ x3 <- const (return ()) x1
+ x4 <- getChar
+ x5 <- getChar x4
+ return (x2, x4)
-ado002.hs:24:14: error: [GHC-83865]
- • Couldn't match expected type ‘Int’ with actual type ‘Char’
- • In the expression: x4
- In a stmt of a 'do' block: return (x2, x4)
+ado002.hs:23:9: error: [GHC-83865]
+ • Couldn't match expected type: Char -> IO a0
+ with actual type: IO Char
+ • The function ‘getChar’ is applied to one visible argument,
+ but its type ‘IO Char’ has none
+ In a stmt of a 'do' block: x5 <- getChar x4
In the expression:
do x1 <- getChar
x2 <- getChar
@@ -79,3 +102,4 @@ ado002.hs:24:14: error: [GHC-83865]
x4 <- getChar
x5 <- getChar x4
return (x2, x4)
+
=====================================
testsuite/tests/ado/ado003.stderr
=====================================
@@ -1,7 +1,7 @@
-ado003.hs:7:3: error: [GHC-83865]
- • Couldn't match expected type ‘Int’ with actual type ‘Char’
- • In the pattern: 'a'
+ado003.hs:7:18: error: [GHC-83865]
+ • Couldn't match expected type ‘Char’ with actual type ‘Int’
+ • In the first argument of ‘return’, namely ‘(3 :: Int)’
In a stmt of a 'do' block: 'a' <- return (3 :: Int)
In the expression:
do x <- getChar
=====================================
testsuite/tests/ado/ado004.stderr
=====================================
@@ -8,24 +8,24 @@ TYPE SIGNATURES
test1c ::
forall (f :: * -> *). Applicative f => (Int -> f Int) -> f Int
test2 ::
- forall {f :: * -> *} {t} {b}.
- (Applicative f, Num t, Num b) =>
+ forall {f :: * -> *} {b} {t}.
+ (Applicative f, Num b, Num t) =>
(t -> f b) -> f b
test2a ::
- forall {f :: * -> *} {t} {b}.
- (Functor f, Num t, Num b) =>
+ forall {f :: * -> *} {b} {t}.
+ (Functor f, Num b, Num t) =>
(t -> f b) -> f b
test2b ::
forall {f :: * -> *} {t} {a}.
(Applicative f, Num t) =>
(t -> a) -> f a
test2c ::
- forall {f :: * -> *} {t} {b}.
- (Functor f, Num t, Num b) =>
+ forall {f :: * -> *} {b} {t}.
+ (Functor f, Num b, Num t) =>
(t -> f b) -> f b
test2d ::
- forall {f :: * -> *} {t} {b} {a}.
- (Functor f, Num t, Num b) =>
+ forall {f :: * -> *} {b} {t} {a}.
+ (Functor f, Num b, Num t) =>
(t -> f a) -> f b
test3 ::
forall {m :: * -> *} {t1} {t2} {a}.
@@ -44,4 +44,4 @@ TYPE SIGNATURES
(Monad m, Num (m a)) =>
(m a -> m (m a)) -> p -> m a
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [base-4.20.0.0]
=====================================
testsuite/tests/ado/all.T
=====================================
@@ -20,5 +20,6 @@ test('T15344', normal, compile_and_run, [''])
test('T16628', normal, compile_fail, [''])
test('T17835', normal, compile, [''])
test('T20540', normal, compile, [''])
-test('T16135', [when(compiler_debugged(),expect_broken(16135))], compile_fail, [''])
+test('T16135', [when(compiler_debugged(),expect_broken(16135))], compile, [''])
test('T22483', normal, compile, ['-Wall'])
+test('T24406', normal, compile, [''])
\ No newline at end of file
=====================================
testsuite/tests/determinism/determ021/determ021.stdout
=====================================
@@ -1,16 +1,16 @@
[1 of 1] Compiling A ( A.hs, A.o )
TYPE SIGNATURES
test2 ::
- forall {f :: * -> *} {t} {b}.
- (Applicative f, Num t, Num b) =>
+ forall {f :: * -> *} {b} {t}.
+ (Applicative f, Num b, Num t) =>
(t -> f b) -> f b
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [base-4.20.0.0]
[1 of 1] Compiling A ( A.hs, A.o )
TYPE SIGNATURES
test2 ::
- forall {f :: * -> *} {t} {b}.
- (Applicative f, Num t, Num b) =>
+ forall {f :: * -> *} {b} {t}.
+ (Applicative f, Num b, Num t) =>
(t -> f b) -> f b
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [base-4.20.0.0]
=====================================
testsuite/tests/ghci.debugger/scripts/break029.stdout
=====================================
@@ -1,9 +1,9 @@
Stopped in Main.f, break029.hs:(4,7)-(6,16)
_result :: IO Int = _
x :: Int = 3
-Stopped in Main.f, break029.hs:5:8-21
-_result :: IO Int = _
-x :: Int = 3
+Stopped in Main.f, break029.hs:6:3-16
+_result :: Int = _
+y :: Int = _
Stopped in Main.f, break029.hs:6:11-15
_result :: Int = _
y :: Int = _
=====================================
testsuite/tests/hiefile/should_run/T23540.stdout
=====================================
@@ -28,22 +28,6 @@ At point (15,8), we found:
==========================
At point (30,8), we found:
==========================
-┌
-│ $dMonad at T23540.hs:1:1, of type: Monad Identity
-│ is an evidence variable bound by a let, depending on: [$fMonadIdentity]
-│ with scope: ModuleScope
-│
-│ Defined at <no location info>
-└
-|
-`- ┌
- │ $fMonadIdentity at T23540.hs:25:10-23, of type: Monad Identity
- │ is an evidence variable bound by an instance of class Monad
- │ with scope: ModuleScope
- │
- │ Defined at T23540.hs:25:10
- └
-
==========================
At point (43,8), we found:
==========================
@@ -123,38 +107,6 @@ At point (49,14), we found:
==========================
At point (61,7), we found:
==========================
-┌
-│ $dApplicative at T23540.hs:1:1, of type: Applicative Identity'
-│ is an evidence variable bound by a let, depending on: [$fApplicativeIdentity']
-│ with scope: ModuleScope
-│
-│ Defined at <no location info>
-└
-|
-`- ┌
- │ $fApplicativeIdentity' at T23540.hs:56:10-30, of type: Applicative Identity'
- │ is an evidence variable bound by an instance of class Applicative
- │ with scope: ModuleScope
- │
- │ Defined at T23540.hs:56:10
- └
-
-┌
-│ $dFunctor at T23540.hs:1:1, of type: Functor Identity'
-│ is an evidence variable bound by a let, depending on: [$fFunctorIdentity']
-│ with scope: ModuleScope
-│
-│ Defined at <no location info>
-└
-|
-`- ┌
- │ $fFunctorIdentity' at T23540.hs:54:10-26, of type: Functor Identity'
- │ is an evidence variable bound by an instance of class Functor
- │ with scope: ModuleScope
- │
- │ Defined at T23540.hs:54:10
- └
-
==========================
At point (69,4), we found:
==========================
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0dd8fb6b8ed90ca35e8fc9f3b1f9d1b186e18d7e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0dd8fb6b8ed90ca35e8fc9f3b1f9d1b186e18d7e
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/20240529/59c4bafb/attachment-0001.html>
More information about the ghc-commits
mailing list