[Git][ghc/ghc][wip/expansions-appdo] fix for 1 failing testcase 4 remain
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Mon May 27 05:41:36 UTC 2024
Apoorv Ingle pushed to branch wip/expansions-appdo at Glasgow Haskell Compiler / GHC
Commits:
4b491840 by Apoorv Ingle at 2024-05-27T00:41:07-05:00
fix for 1 failing testcase 4 remain
- - - - -
8 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/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/Utils/Unify.hs
- testsuite/tests/ado/T13242a.stderr
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -528,10 +528,10 @@ mkExpandedStmt
mkExpandedStmt oStmt flav eExpr = XExpr (ExpandedThingRn (OrigStmt oStmt flav) eExpr)
mkExpandedPatRn
- :: LPat GhcRn -- ^ source pattern
- -> Maybe (HsDoFlavour, ExprLStmt GhcRn) -- ^ pattern statement origin
- -> HsExpr GhcRn -- ^ expanded expression
- -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
+ :: LPat GhcRn -- ^ source pattern
+ -> Maybe (HsDoFlavour, ExprLStmt GhcRn) -- ^ pattern statement origin
+ -> HsExpr GhcRn -- ^ expanded expression
+ -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
mkExpandedPatRn oPat stmt eExpr = XExpr (ExpandedThingRn (OrigPat oPat stmt) eExpr)
-- | Build an expression using the extension constructor `XExpr`,
@@ -1736,7 +1736,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
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -824,7 +824,7 @@ dsDo ctx stmts
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)]))
+ ((pat, Nothing), dsDo ctx (stmts ++ [noLocA $ mkLastStmt ret]))
; rhss' <- sequence rhss
=====================================
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'
@@ -721,9 +723,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
-- Rule IARG from Fig 4 of the QL paper:
go1 delta acc so_far fun_ty
(eva@(EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt }) : rest_args)
- = do { let herald = case fun_ctxt of
- VAExpansion (OrigStmt{}) _ _ -> ExpectedFunTySyntaxOp DoOrigin tc_fun
- _ -> ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg)
+ = do { let herald = ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg)
; (wrap, arg_ty, res_ty) <-
-- NB: matchActualFunTy does the rep-poly check.
-- For example, suppose we have f :: forall r (a::TYPE r). a -> Int
@@ -731,9 +731,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,21 +795,26 @@ addArgCtxt :: AppCtxt -> LHsExpr GhcRn
addArgCtxt ctxt (L arg_loc arg) thing_inside
= do { in_generated_code <- inGeneratedCode
; case ctxt of
+ 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
- | XExpr{} <- arg, in_generated_code
- -> thing_inside -- AppDo case for <*>'s second argument, the ctxt will be set by addHeadCtxt
-
VAExpansion (OrigStmt (L _ stmt@(BindStmt {})) flav) _ loc
| isGeneratedSrcSpan (locA arg_loc) -- This arg is the second argument to generated (>>=)
-> setSrcSpan loc $
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 flav $
thing_inside
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -22,7 +22,7 @@ module GHC.Tc.Gen.Do (expandDoStmts) where
import GHC.Prelude
import GHC.Rename.Utils ( wrapGenSpan, genHsExpApps, genHsApp, genHsLet, genLHsApp,
- genHsLamDoExp, genHsCaseAltDoExp, genWildPat )
+ genHsLamDoExp, genHsCaseAltDoExp )
import GHC.Tc.Utils.Monad
import GHC.Tc.Gen.Pat
import GHC.Tc.Utils.TcMType
@@ -86,20 +86,14 @@ expand_do_stmts flav [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_expr))]
-- 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 appDo <- xoptM LangExt.ApplicativeDo
- if appDo
- then do traceTc "expand_do_stmts last no pop" (ppr $ (L body_loc body))
- return $ mkExpandedStmtAt loc stmt flav body
- else do traceTc "expand_do_stmts last pop" (ppr $ (L body_loc body))
- return $ mkExpandedStmtPopAt loc stmt flav body
+ = return $ mkExpandedStmtPopAt loc stmt flav 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)
+ = do let expansion = genHsApp ret (L body_loc body)
return $ mkExpandedStmtPopAt loc stmt flav expansion
expand_do_stmts doFlavour (stmt@(L loc (LetStmt _ bs)) : lstmts) =
@@ -190,8 +184,7 @@ expand_do_stmts doFlavour
-- NB: LazyPat because we do not want to eagerly evaluate the pattern
-- and potentially loop forever
-
-expand_do_stmts doFlavour ((L loc (XStmtLR (ApplicativeStmt _ args mb_join))): lstmts) =
+expand_do_stmts doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join))): lstmts) =
-- See Note [Applicative BodyStmt]
--
-- stmts ~~> stmts'
@@ -201,13 +194,16 @@ expand_do_stmts doFlavour ((L loc (XStmtLR (ApplicativeStmt _ args mb_join))): l
-- Very similar to HsToCore.Expr.dsDo
-- args are [(<$>, e1), (<*>, e2), .., ]
- do { expr' <- expand_do_stmts doFlavour lstmts
+ do { xexpr' <- expand_do_stmts doFlavour lstmts
-- extracts pats and arg bodies (rhss) from args
+ ; let xexpr = case xexpr' of
+ L _ (XExpr (PopErrCtxt e)) -> e
+ _ -> xexpr'
; (pats_can_fail, rhss) <- unzip <$> mapM (do_arg . snd) args
-- add blocks for failable patterns
- ; body_with_fails <- foldrM match_args expr' (zip pats_can_fail rhss)
+ ; 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)
@@ -231,18 +227,18 @@ expand_do_stmts doFlavour ((L loc (XStmtLR (ApplicativeStmt _ args mb_join))): l
, arg_expr = (L rhs_loc rhs)
, is_body_stmt = is_body_stmt
}) =
- do let xx_stmt = mkExpandedStmtAt rhs_loc stmt doFlavour rhs
- traceTc "do_arg" (text "OneArg" <+> vcat [ppr pat, ppr xx_stmt])
+ do let xx_expr = mkExpandedStmtAt rhs_loc stmt doFlavour rhs
+ traceTc "do_arg" (text "OneArg" <+> vcat [ppr pat, ppr xx_expr])
return ((pat, mb_fail_op)
- , xx_stmt)
+ , 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 { expr <- expand_do_stmts ctxt $ stmts ++ [L ret_loc $ mkLastStmt ret]
- ; traceTc "do_arg" (text "ManyArg" <+> vcat [ppr pat, ppr expr])
+ do { xx_expr <- expandDoStmts ctxt $ stmts ++ [L ret_loc $ mkLastStmt ret]
+ ; traceTc "do_arg" (text "ManyArg" <+> vcat [ppr pat, ppr xx_expr])
; return ((pat, Nothing)
- , expr) }
+ , wrapGenSpan 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
@@ -265,17 +261,19 @@ expand_do_stmts _ stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr
-- checks the pattern `pat`for irrefutability which decides if we need to wrap it with a fail block
mk_failable_expr :: HsDoFlavour -> Maybe (HsDoFlavour, ExprLStmt GhcRn)
-> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
-mk_failable_expr doFlav mb_stmt_info pat@(L loc _) expr fail_op =
+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 mb_stmt_info pat expr fail_op
+ then case pat of
+ (WildPat{}) -> return $ genHsLamDoExp doFlav [L noSrcSpanA pat] expr
+ _ -> return $ genHsLamDoExp doFlav [lpat] expr
+ else L loc <$> mk_fail_block doFlav mb_stmt_info lpat expr fail_op
}
-- makes the fail block with a given fail_op
@@ -289,7 +287,7 @@ mk_fail_block doFlav mb_stmt_info 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
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -90,7 +90,6 @@ import GHC.Utils.Panic
import Control.Monad
import qualified Data.List.NonEmpty as NE
-import qualified GHC.LanguageExtensions as LangExt
{-
************************************************************************
@@ -729,14 +728,9 @@ tcXExpr xe@(ExpandedThingRn o e') res_ty
-- `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 s) flav <- o
+ | OrigStmt ls@(L loc _) flav <- o
= setSrcSpanA loc $
- do appDo <- xoptM LangExt.ApplicativeDo
- if appDo
- then addStmtCtxt s flav $
- mkExpandedStmtTc ls flav <$> tcExpr e' res_ty
-
- else mkExpandedStmtTc ls flav <$> tcApp (XExpr xe) res_ty
+ mkExpandedStmtTc ls flav <$> tcApp (XExpr xe) res_ty
tcXExpr xe res_ty = tcApp (XExpr xe) res_ty
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -323,7 +323,7 @@ splitHsApps e = go e (top_ctxt 0 e) []
= 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]
@@ -1607,6 +1607,7 @@ addExprCtxt e thing_inside
= case e of
HsUnboundVar {} -> thing_inside
XExpr (ExpandedThingRn (OrigStmt stmt flav) _) -> addStmtCtxt (unLoc stmt) flav thing_inside
+ -- XExpr (PopErrCtxt (L _ e)) -> addExprCtxt e thing_inside
_ -> addErrCtxt (exprCtxt e) thing_inside
-- The HsUnboundVar special case addresses situations like
-- f x = _
=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -133,8 +133,8 @@ matchActualFunTy
-- and NB: res_ty is an (uninstantiated) SigmaType
matchActualFunTy herald mb_thing err_info fun_ty
- = assertPpr (isRhoTy fun_ty) (ppr fun_ty) $
- go fun_ty
+ = do assertPpr (isRhoTy fun_ty) (ppr 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,
=====================================
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)
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4b4918406b042ddcfec7f0933da0b61d8f2ceae9
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4b4918406b042ddcfec7f0933da0b61d8f2ceae9
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/20240527/9e299a2c/attachment-0001.html>
More information about the ghc-commits
mailing list