[Git][ghc/ghc][wip/expansions-appdo] Make ApplicativeDo work with HsExpansions
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Mon Jul 15 14:55:03 UTC 2024
Apoorv Ingle pushed to branch wip/expansions-appdo at Glasgow Haskell Compiler / GHC
Commits:
8b41cec3 by Apoorv Ingle at 2024-07-15T09:19:57-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`
Note [Expanding HsDo with XXExprGhcRn] explains the change in more detail
- - - - -
28 changed files:
- compiler/GHC/Hs/Expr.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/Zonk/Type.hs
- testsuite/tests/ado/T13242a.stderr
- testsuite/tests/ado/T16135.hs
- − 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
=====================================
@@ -475,9 +475,12 @@ type instance XXExpr GhcTc = XXExprGhcTc
-- | 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)
+-- See Note [Handling overloaded and rebindable constructs] in `GHC.Rename.Expr`
+data HsThingRn = OrigExpr (HsExpr GhcRn) -- ^ The source, user written, expression
+ | OrigStmt (ExprLStmt GhcRn) HsDoFlavour -- ^ which kind of do-block did this statement come from
+ | OrigPat (LPat GhcRn) -- ^ The source, user written, pattern
+ HsDoFlavour -- ^ which kind of do-block did this statement come from
+ (Maybe (ExprLStmt GhcRn)) -- ^ Optional statement binding this pattern
isHsThingRnExpr, isHsThingRnStmt, isHsThingRnPat :: HsThingRn -> Bool
isHsThingRnExpr (OrigExpr{}) = True
@@ -490,8 +493,11 @@ isHsThingRnPat (OrigPat{}) = True
isHsThingRnPat _ = False
data XXExprGhcRn
- = ExpandedThingRn { xrn_orig :: HsThingRn -- The original source thing
- , xrn_expanded :: HsExpr GhcRn } -- The compiler generated expanded thing
+ = ExpandedThingRn { xrn_orig :: HsThingRn -- The original source thing to be used for error messages
+ , xrn_expanded :: HsExpr GhcRn -- The compiler generated expanded thing
+ , xrn_doTcApp :: Bool } -- A Hint to the type checker of how to proceed
+ -- True <=> use GHC.Tc.Gen.Expr.tcApp on xrn_expanded
+ -- False <=> use GHC.Tc.Gen.Expr.tcExpr on xrn_expanded
| PopErrCtxt -- A hint for typechecker to pop
{-# UNPACK #-} !(LHsExpr GhcRn) -- the top of the error context stack
@@ -515,41 +521,49 @@ 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 { xrn_orig = OrigExpr oExpr
+ , xrn_expanded = eExpr
+ , xrn_doTcApp = False })
-- | 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 -- ^ source statement do flavour
+ -> Bool -- ^ should this be type checked using tcApp?
-> HsExpr GhcRn -- ^ expanded expression
-> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedStmt oStmt eExpr = XExpr (ExpandedThingRn (OrigStmt oStmt) eExpr)
+mkExpandedStmt oStmt flav doTcApp eExpr = XExpr (ExpandedThingRn { xrn_orig = OrigStmt oStmt flav
+ , xrn_expanded = eExpr
+ , xrn_doTcApp = doTcApp})
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
+ -> HsDoFlavour -- ^ source statement do flavour
+ -> Maybe (ExprLStmt GhcRn) -- ^ pattern statement origin
+ -> HsExpr GhcRn -- ^ expanded expression
+ -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
+mkExpandedPatRn oPat flav mb_stmt eExpr = XExpr (ExpandedThingRn { xrn_orig = OrigPat oPat flav mb_stmt
+ , xrn_expanded = eExpr
+ , xrn_doTcApp = False})
-- | Build an expression using the extension constructor `XExpr`,
-- and the two components of the expansion: original do stmt and
--- expanded expression an associate with a provided location
+-- expanded expression and associate it with a provided location
mkExpandedStmtAt
- :: SrcSpanAnnA -- ^ Location for the expansion expression
+ :: Bool -- ^ Wrap this expansion with a pop?
+ -> SrcSpanAnnA -- ^ Location for the expansion expression
-> ExprLStmt GhcRn -- ^ source statement
+ -> HsDoFlavour -- ^ the flavour of the statement
+ -> Bool -- ^ should type check with tcApp?
-> HsExpr GhcRn -- ^ expanded expression
-> LHsExpr GhcRn -- ^ suitably wrapped located 'XXExprGhcRn'
-mkExpandedStmtAt loc oStmt eExpr = L loc $ mkExpandedStmt oStmt eExpr
-
--- | Wrap the expanded version of the expression with a pop.
-mkExpandedStmtPopAt
- :: SrcSpanAnnA -- ^ Location for the expansion statement
- -> ExprLStmt GhcRn -- ^ source statement
- -> HsExpr GhcRn -- ^ expanded expression
- -> LHsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedStmtPopAt loc oStmt eExpr = mkPopErrCtxtExprAt loc $ mkExpandedStmtAt loc oStmt eExpr
-
+mkExpandedStmtAt addPop loc oStmt flav doTcApp eExpr
+ | addPop
+ = mkPopErrCtxtExprAt loc (L loc $ mkExpandedStmt oStmt flav doTcApp eExpr)
+ | otherwise
+ = L loc $ mkExpandedStmt oStmt flav doTcApp eExpr
data XXExprGhcTc
= WrapExpr -- Type and evidence application and abstractions
@@ -593,9 +607,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)
{- *********************************************************************
* *
@@ -840,14 +855,14 @@ ppr_expr (XExpr x) = case ghcPass @p of
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
+ OrigExpr x -> ppr_builder "<OrigExpr>:" x
+ OrigStmt x _ -> ppr_builder "<OrigStmt>:" x
+ OrigPat x _ mb_stmt -> ifPprDebug (braces (text "<OrigPat>" <+> parens (ppr x) <+> parens (ppr mb_stmt))) (ppr 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))
@@ -887,7 +902,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
@@ -998,7 +1013,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
@@ -1050,7 +1065,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
@@ -1570,7 +1585,7 @@ pprMatch (Match { m_pats = L _ 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
@@ -1611,6 +1626,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
@@ -1670,7 +1686,7 @@ data XBindStmtTc = XBindStmtTc
type instance XApplicativeStmt (GhcPass _) GhcPs = NoExtField
type instance XApplicativeStmt (GhcPass _) GhcRn = NoExtField
-type instance XApplicativeStmt (GhcPass _) GhcTc = Type
+type instance XApplicativeStmt (GhcPass _) GhcTc = DataConCantHappen
type instance XBodyStmt (GhcPass _) GhcPs b = NoExtField
type instance XBodyStmt (GhcPass _) GhcRn b = NoExtField
@@ -1692,7 +1708,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
@@ -1733,7 +1749,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
@@ -1752,7 +1768,7 @@ type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = DataConCantHappen
type instance XApplicativeArgOne GhcPs = NoExtField
type instance XApplicativeArgOne GhcRn = FailOperator GhcRn
-type instance XApplicativeArgOne GhcTc = FailOperator GhcTc
+type instance XApplicativeArgOne GhcTc = DataConCantHappen
type instance XApplicativeArgMany (GhcPass _) = NoExtField
type instance XXApplicativeArg (GhcPass _) = DataConCantHappen
@@ -1798,7 +1814,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
@@ -1819,7 +1834,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]
@@ -1848,13 +1862,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/Utils.hs
=====================================
@@ -1187,7 +1187,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
@@ -1780,7 +1779,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
=====================================
@@ -314,7 +314,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
@@ -462,10 +462,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 res_ty ctx at DoExpr{} (L _ stmts)) = dsDo ctx stmts res_ty
-dsExpr (HsDo res_ty ctx at GhciStmtCtxt (L _ stmts)) = dsDo ctx stmts res_ty
-dsExpr (HsDo res_ty ctx at MDoExpr{} (L _ stmts)) = dsDo ctx stmts res_ty
dsExpr (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts
+dsExpr (HsDo res_ty ctx at GhciStmtCtxt (L _ stmts)) = dsDo ctx stmts res_ty
+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
@@ -822,37 +822,6 @@ dsDo ctx stmts res_ty
-- 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)]) res_ty)
-
- ; 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 body_ty 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
=====================================
@@ -372,7 +372,6 @@ desugarGuard guard = case guard of
ParStmt {} -> panic "desugarGuard ParStmt"
TransStmt {} -> panic "desugarGuard TransStmt"
RecStmt {} -> panic "desugarGuard RecStmt"
- XStmtLR ApplicativeStmt{} -> panic "desugarGuard ApplicativeLastStmt"
sequenceGrdDagMapM :: Applicative f => (a -> f GrdDag) -> [a] -> f GrdDag
sequenceGrdDagMapM f as = sequenceGrdDags <$> traverse f as
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1683,7 +1683,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
=====================================
@@ -610,7 +610,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
@@ -751,33 +751,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) =
@@ -966,8 +943,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
=====================================
@@ -1372,7 +1372,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
=====================================
@@ -194,8 +194,8 @@ but several have a little bit of special treatment:
(return (f x))))
See Note [Expanding HsDo with XXExprGhcRn] in `Ghc.Tc.Gen.Do` for more details.
- To understand why is this done in the typechecker and not in the renamer.
- See Note [Doing XXExprGhcRn in the Renamer vs Typechecker]
+ To understand why is this done in the typechecker and not in the renamer
+ see Note [Doing XXExprGhcRn in the Renamer vs Typechecker]
Note [Overloaded labels]
~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1964,15 +1964,10 @@ ApplicativeDo touches a few phases in the compiler:
don't exist in the source code.
See ApplicativeStmt and ApplicativeArg in HsExpr.
-* Typechecker: ApplicativeDo passes through the typechecker much like any
- other form of expression. The only crux is that the typechecker has to
- be aware of the special ApplicativeDo statements in the do-notation, and
- typecheck them appropriately.
- Relevant module: GHC.Tc.Gen.Match
-
-* Desugarer: Any do-block which contains applicative statements is desugared
- as outlined above, to use the Applicative combinators.
- Relevant module: GHC.HsToCore.Expr
+* Typechecker: All the ApplicativeDo statements are expanded on the fly
+ to its actual semantics (as shown above) with appropriate user syntax. The typechecker
+ then checks the syntax as any other form of expression.
+ Relevant module: GHC.Tc.Gen.Do , GHC.Tc.Gen.Match.tcStmts
-}
@@ -2222,12 +2217,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
=====================================
@@ -649,10 +649,10 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
; go 1 [] fun_sigma rn_args }
where
fun_orig = case fun_ctxt of
- VAExpansion (OrigStmt{}) _ _ -> DoOrigin
- VAExpansion (OrigPat pat) _ _ -> DoPatOrigin pat
- VAExpansion (OrigExpr e) _ _ -> exprCtOrigin e
- VACall e _ _ -> exprCtOrigin e
+ VAExpansion (OrigStmt{}) _ _ -> DoOrigin
+ VAExpansion (OrigPat pat _ _) _ _ -> DoPatOrigin pat
+ VAExpansion (OrigExpr e) _ _ -> exprCtOrigin e
+ VACall e _ _ -> exprCtOrigin e
-- These are the type variables which must be instantiated to concrete
-- types. See Note [Representation-polymorphic Ids with no binding]
@@ -845,6 +845,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
; return (mkScaled mult_ty arg_nu) }
+
-- Is the argument supposed to instantiate a forall?
--
-- In other words, given a function application `fn arg`,
@@ -897,23 +898,29 @@ 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 (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 $
@@ -1044,7 +1051,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])
@@ -2252,4 +2259,3 @@ rejectRepPolyNewtypes (fun,_) app_res_rho = case fun of
tcExprPrag :: HsPragE GhcRn -> HsPragE GhcTc
tcExprPrag (HsPragSCC x1 ann) = HsPragSCC x1 ann
-
=====================================
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.Utils.TcMType
@@ -52,66 +52,53 @@ 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 $ mkExpandedStmtAt addPop loc stmt flav False 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 $ mkExpandedStmtAt addPop loc stmt flav False 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 $ mkExpandedStmtAt addPop loc stmt doFlavour False 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
@@ -120,29 +107,29 @@ 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 $ mkExpandedStmtAt addPop loc stmt doFlavour True 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 $ mkExpandedStmtAt addPop loc stmt doFlavour True 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
@@ -162,12 +149,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
@@ -183,35 +170,115 @@ 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 = mkExpandedStmtAt addPop rhs_loc stmt doFlavour False rhs
+ traceTc "do_arg" (text "OneArg" <+> vcat [ppr pat, ppr xx_expr])
+ return ((pat, mb_fail_op)
+ , xx_expr)
+ where stmt = rebuild_stmt is_body_stmt rhs_loc rhs pat
+ 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 mb_stmt pat body fail_op
+ where mb_stmt = case unLoc stmt_expr of
+ XExpr (ExpandedThingRn (OrigStmt s _) _ _) -> Just s
+ XExpr (PopErrCtxt (L _ (XExpr (ExpandedThingRn (OrigStmt s _) _ _)))) -> Just 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)
+
+
+ rebuild_stmt is_body_stmt rhs_loc rhs pat = 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)))
+ 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 (ExprLStmt GhcRn) -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
+mk_failable_expr doFlav mb_stmt lpat@(L loc pat) expr fail_op =
do { is_strict <- xoptM LangExt.Strict
; rdrEnv <- getGlobalRdrEnv
; comps <- getCompleteMatchesTcM
- ; let irrf_pat = isIrrefutableHsPat is_strict (irrefutableConLikeRn rdrEnv comps) pat
+ ; let irrf_pat = isIrrefutableHsPat is_strict (irrefutableConLikeRn rdrEnv comps) lpat
; traceTc "mk_failable_expr" (vcat [ text "pat:" <+> ppr pat
, 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 of
+ Nothing -> genHsLamDoExp doFlav [lpat] expr
+ Just s -> wrapGenSpan (mkExpandedStmt s doFlav False
+ (unLoc $ (genHsLamDoExp doFlav [lpat]
+ $ wrapGenSpan (mkPopErrCtxtExpr expr))))
+ else L loc <$> mk_fail_block doFlav mb_stmt 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 (ExprLStmt GhcRn)
+ -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (HsExpr GhcRn)
+mk_fail_block doFlav mb_stmt 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
@@ -219,22 +286,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 doFlav mb_stmt $
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]
@@ -303,12 +370,29 @@ They capture the essence of statement expansions as implemented in `expand_do_st
(5) DO【 s 】 = s
+ (4) DO【 AppStmt s; ss 】
+ = APPSTMT【 (AppStmt s, ss) 】
+
+
RECDO【 _ 】 maps a sequence of recursively dependent monadic statements and converts it into an expression paired
with the variables that the rec finds a fix point of.
(6) RECDO【 ss 】 = (vars, mfix (\~vars -> (>>=) (DO【 ss 】) (return vars)))
where vars are all the variables free in ss
+ APPSTMT【 _ 】 expands the applicative statements as given in Note [ApplicativeDo] in GHC.Rename.Expr (dsDo)
+ The applicative statement is generated by GHC.Rename.Expr.postProcessStmtsForApplicativeDo
+
+
+ (7) APPSTMT 【 (AppStmt (s1 | s2 ... | sn), ss) 】
+ = join (\argpat (s1) .. argpat(sn) -> DO 【 ss 】)
+ <$> ‹ExpansionStmt s1› argexpr(arg_1)
+ <*> ...
+ <*> ‹PopErrCtxt› ‹ExpansionStmt s1› argexpr(arg_n)
+
+ where argpat (p <- s) = p
+ argexpr(p <- s) = s
+
For a concrete example, consider a `do`-block written by the user
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -714,27 +714,32 @@ 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' doTcApp) 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
+ , not doTcApp
+ = setSrcSpanA loc $
+ addStmtCtxt s flav $
+ mkExpandedStmtTc ls flav <$> tcExpr e' res_ty
+
+ | OrigStmt ls@(L loc _) flav <- o
+ , doTcApp
+ = setSrcSpanA loc $
+ mkExpandedStmtTc ls flav <$> tcApp (XExpr xe) res_ty
+
+ | OrigPat (L loc _) flav (Just s) <- o -- testcase T16628
= setSrcSpanA loc $
- mkExpandedStmtTc ls <$> tcApp (XExpr xe) res_ty
+ addStmtCtxt (unLoc s) flav $
+ tcApp (XExpr xe) res_ty
tcXExpr xe res_ty = tcApp (XExpr xe) res_ty
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -252,7 +252,7 @@ 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
instance Outputable QLFlag where
ppr DoQL = text "DoQL"
@@ -300,8 +300,8 @@ 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 _))
- | OrigExpr fun <- o = VACall fun n noSrcSpan
+ top_ctxt n (XExpr (ExpandedThingRn (OrigExpr fun) _ _))
+ = VACall fun n noSrcSpan
top_ctxt n other_fun = VACall other_fun n noSrcSpan
top_lctxt n (L _ fun) = top_ctxt n fun
@@ -325,25 +325,7 @@ 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
- | isHsThingRnExpr o
- = go e (VAExpansion o (appCtxtLoc ctxt) (appCtxtLoc ctxt))
- (EWrap (EExpand o) : args)
-
- | 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
- = 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]
- -- in `GHC.Tc.Gen.Do`
-
- | otherwise
+ go (XExpr (ExpandedThingRn o e _)) ctxt args
= go e (VAExpansion o (appCtxtLoc ctxt) (appCtxtLoc ctxt))
(EWrap (EExpand o) : args)
@@ -573,17 +555,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 _ flav (Just stmt)) _ _ -> addStmtCtxt (unLoc stmt) flav thing_inside
_ -> thing_inside
where
fun_loc = appCtxtLoc fun_ctxt
@@ -1267,9 +1252,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
@@ -1282,6 +1267,8 @@ addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt e thing_inside
= case e of
HsUnboundVar {} -> thing_inside
+ XExpr (PopErrCtxt (L l e)) -> popErrCtxt $ setSrcSpanA l $ addExprCtxt e $ 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
=====================================
@@ -77,7 +77,6 @@ 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)
@@ -352,22 +351,14 @@ 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 { expanded_expr <- expandDoStmts doExpr stmts -- Do expansion on the fly
+ ; 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
@@ -998,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)
@@ -1086,87 +1065,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/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
import Data.List.NonEmpty ( NonEmpty )
@@ -1409,54 +1408,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.hs
=====================================
@@ -1,5 +1,9 @@
{-# LANGUAGE ExistentialQuantification, ApplicativeDo #-}
+{- This testcase failed before we treated Do statements via HsExpansions
+ This test passes after #24406
+-}
+
module Bug where
data T f = forall a. MkT (f a)
=====================================
testsuite/tests/ado/T16135.stderr deleted
=====================================
@@ -1,22 +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 a stmt of a 'do' block: return $ MkT fa
- In the expression:
- do return ()
- MkT fa <- runf
- 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,6 +20,7 @@ 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', normal, compile, [''])
test('T22483', normal, compile, ['-Wall'])
test('OrPatStrictness', normal, compile_and_run, [''])
+test('T24406', normal, compile, [''])
=====================================
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/8b41cec365c19792007b0334d1b52ee4146946d1
--
This project does not include diff previews in email notifications.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8b41cec365c19792007b0334d1b52ee4146946d1
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/20240715/8a764d86/attachment-0001.html>
More information about the ghc-commits
mailing list