[Git][ghc/ghc][wip/expansions-appdo] 11 commits: make applicative do work with expansions, possibly badly
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Mon May 27 05:28:35 UTC 2024
Apoorv Ingle pushed to branch wip/expansions-appdo at Glasgow Haskell Compiler / GHC
Commits:
11385ec7 by Apoorv Ingle at 2024-05-27T00:28:07-05:00
make applicative do work with expansions, possibly badly
Fixes: #24406
enable the flow
renaming do_or_lc to doFlavour and debugging error contexts
testcases
- - - - -
5fa01dbc by Apoorv Ingle at 2024-05-27T00:28:07-05:00
make sure app do expression statements location is mapped correctly
- - - - -
585f4e6e by Apoorv Ingle at 2024-05-27T00:28:07-05:00
add flavour into OrigStmt to guide better error messages about qualified do.
- - - - -
102f817c by Apoorv Ingle at 2024-05-27T00:28:07-05:00
add stmt and do flav info in OrigPat to improve error messages
- - - - -
468c413e by Apoorv Ingle at 2024-05-27T00:28:07-05:00
accepting some test cases ado003 and ado002 also fix for #16135
- - - - -
6477658d by Apoorv Ingle at 2024-05-27T00:28:07-05:00
make applicative breakpoint work
- - - - -
56d19881 by Apoorv Ingle at 2024-05-27T00:28:07-05:00
make join unlocated
- - - - -
6b884136 by Apoorv Ingle at 2024-05-27T00:28:07-05:00
fix rebase conflicts
- - - - -
297ebf06 by Apoorv Ingle at 2024-05-27T00:28:07-05:00
in GHC.Tc.Gen.Do.mk_apps pull out the XExpr annotation outside the op application
- - - - -
93c623b7 by Apoorv Ingle at 2024-05-27T00:28:07-05:00
some pesky appdo testcases remain
- - - - -
9cc406fe by Apoorv Ingle at 2024-05-27T00:28:07-05:00
fix for 1 failing testcase 4 remain
- - - - -
22 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Ticks.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/ado002.stderr
- testsuite/tests/ado/ado003.stderr
- testsuite/tests/ado/ado004.stderr
- testsuite/tests/ado/all.T
- + testsuite/tests/ado/expand-ado1.hs
- testsuite/tests/determinism/determ021/determ021.stdout
- testsuite/tests/ghci.debugger/scripts/break029.stdout
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -476,8 +476,8 @@ 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)
+ | 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
@@ -522,15 +522,17 @@ mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn (OrigExpr oExpr) eExpr)
-- expanded expression
mkExpandedStmt
:: ExprLStmt GhcRn -- ^ source statement
+ -> HsDoFlavour
-> HsExpr GhcRn -- ^ expanded expression
-> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedStmt oStmt eExpr = XExpr (ExpandedThingRn (OrigStmt oStmt) eExpr)
+mkExpandedStmt oStmt flav eExpr = XExpr (ExpandedThingRn (OrigStmt oStmt flav) eExpr)
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 stmt eExpr = XExpr (ExpandedThingRn (OrigPat oPat stmt) eExpr)
-- | Build an expression using the extension constructor `XExpr`,
-- and the two components of the expansion: original do stmt and
@@ -538,17 +540,19 @@ mkExpandedPatRn oPat eExpr = XExpr (ExpandedThingRn (OrigPat oPat) eExpr)
mkExpandedStmtAt
:: SrcSpanAnnA -- ^ Location for the expansion expression
-> ExprLStmt GhcRn -- ^ source statement
+ -> HsDoFlavour
-> HsExpr GhcRn -- ^ expanded expression
-> LHsExpr GhcRn -- ^ suitably wrapped located 'XXExprGhcRn'
-mkExpandedStmtAt loc oStmt eExpr = L loc $ mkExpandedStmt oStmt eExpr
+mkExpandedStmtAt loc oStmt flav eExpr = L loc $ mkExpandedStmt oStmt flav eExpr
-- | Wrap the expanded version of the expression with a pop.
mkExpandedStmtPopAt
:: SrcSpanAnnA -- ^ Location for the expansion statement
-> ExprLStmt GhcRn -- ^ source statement
+ -> HsDoFlavour
-> HsExpr GhcRn -- ^ expanded expression
-> LHsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedStmtPopAt loc oStmt eExpr = mkPopErrCtxtExprAt loc $ mkExpandedStmtAt loc oStmt eExpr
+mkExpandedStmtPopAt loc oStmt flav eExpr = mkPopErrCtxtExprAt loc $ mkExpandedStmtAt loc oStmt flav eExpr
data XXExprGhcTc
@@ -593,9 +597,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,12 +841,12 @@ 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 (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
@@ -1852,7 +1857,7 @@ 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/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
=====================================
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
@@ -775,7 +775,7 @@ addTickApplicativeArg isGuard (op, arg) =
addTickArg (ApplicativeArgMany x stmts ret pat ctxt) =
(ApplicativeArgMany x)
<$> addTickLStmts isGuard stmts
- <*> (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) ret))
+ <*> addTickLHsExpr ret
<*> addTickLPat pat
<*> pure ctxt
=====================================
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
@@ -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,28 +795,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 }
{- *********************************************************************
* *
=====================================
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,14 +53,14 @@ 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 :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (HsExpr GhcRn)
expandDoStmts doFlav stmts = do expanded_expr <- expand_do_stmts doFlav stmts
case expanded_expr of
- L _ (XExpr (PopErrCtxt e)) -> return e
+ L _ (XExpr (PopErrCtxt e)) -> return $ unLoc 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
+ _ -> return $ unLoc expanded_expr
-- | The main work horse for expanding do block statements into applications of binds and thens
-- See Note [Expanding HsDo with XXExprGhcRn]
@@ -80,39 +80,32 @@ 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 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 $ 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)
- return $ mkExpandedStmtPopAt loc stmt expansion
+ = do let expansion = genHsApp ret (L body_loc body)
+ return $ mkExpandedStmtPopAt loc stmt flav expansion
-expand_do_stmts do_or_lc (stmt@(L loc (LetStmt _ bs)) : lstmts) =
+expand_do_stmts 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 doFlavour lstmts
let expansion = genHsLet bs expand_stmts
- return $ mkExpandedStmtPopAt loc stmt expansion
+ return $ mkExpandedStmtPopAt loc stmt doFlavour expansion
-expand_do_stmts do_or_lc (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
+expand_do_stmts 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 +114,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 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 $ mkExpandedStmtPopAt loc stmt doFlavour 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 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 doFlavour lstmts
let expansion = genHsExpApps then_op -- (>>)
[ e
, expand_stmts_expr ]
- return $ mkExpandedStmtPopAt loc stmt expansion
+ return $ mkExpandedStmtPopAt loc stmt doFlavour 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 +156,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 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 +177,109 @@ 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 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 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 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 rhs_loc stmt doFlavour 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 <- expandDoStmts ctxt $ stmts ++ [L ret_loc $ mkLastStmt ret]
+ ; traceTc "do_arg" (text "ManyArg" <+> vcat [ppr pat, ppr xx_expr])
+ ; return ((pat, Nothing)
+ , 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
+ 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 $ 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
-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 +287,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
=====================================
@@ -711,26 +711,26 @@ tcXExpr (PopErrCtxt (L loc e)) res_ty
tcExpr e res_ty
tcXExpr xe@(ExpandedThingRn o e') res_ty
- | OrigStmt ls@(L loc s at LetStmt{}) <- o
+ | 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
+ | OrigStmt ls@(L loc s at LastStmt{}) flav <- o
= setSrcSpanA loc $
- addStmtCtxt s $
- mkExpandedStmtTc ls <$> tcExpr e' res_ty
+ addStmtCtxt s flav $
+ mkExpandedStmtTc ls flav <$> 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 _) flav <- o
= setSrcSpanA loc $
- mkExpandedStmtTc ls <$> 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
=====================================
@@ -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
@@ -322,14 +323,14 @@ 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]
(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,8 @@ 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
+ -- 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/Gen/Match.hs
=====================================
@@ -82,9 +82,6 @@ import Control.Arrow ( second )
import qualified Data.List.NonEmpty as NE
import Data.Maybe (mapMaybe)
-import qualified GHC.LanguageExtensions as LangExt
-
-
{-
************************************************************************
* *
@@ -353,20 +350,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
@@ -1155,7 +1148,7 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
= do { (stmts', (ret',pat')) <-
tcStmtsAndThen (HsDoStmt ctxt) tcDoStmt stmts (mkCheckExpType exp_ty) $
\res_ty -> do
- { ret' <- tcExpr ret res_ty
+ { ret' <- tcMonoExprNC ret res_ty
; (pat', _) <- tcCheckPat (StmtCtxt (HsDoStmt ctxt)) pat (unrestricted pat_ty) $
return ()
; return (ret', pat')
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -752,8 +752,8 @@ 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
+ | 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
=====================================
@@ -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,
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -1453,7 +1453,7 @@ zonkStmt _zBody (XStmtLR (ApplicativeStmt body_ty args mb_join))
; 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
+ do { new_ret <- zonkLExpr ret
; return (ApplicativeArgMany x new_stmts new_ret pat ctxt) }
-------------------------------------------------------------------------
=====================================
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/ado002.stderr
=====================================
@@ -24,30 +24,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 +64,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,15 +82,17 @@ 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)
- In the expression:
- do x1 <- getChar
- x2 <- getChar
- x3 <- const (return ()) x1
- x4 <- getChar
- x5 <- getChar x4
- 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
=====================================
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,5 @@ 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'])
=====================================
testsuite/tests/ado/expand-ado1.hs
=====================================
@@ -0,0 +1,32 @@
+{-# LANGUAGE ApplicativeDo,ScopedTypeVariables #-}
+module Test where
+
+-- Test that type errors aren't affected by ApplicativeDo
+rrrr1 :: IO Int
+rrrr1 = do
+ x <- getChar
+ y <- getChar 'a' -- type error
+ return (x,y)
+
+
+
+rrrr2 :: IO Int
+rrrr2 = do
+ x <- getChar
+ y <- getChar 'a' -- type error
+ print (x,y)
+
+-- g :: IO (Int,Int)
+-- g = do
+-- x <- getChar
+-- y <- getChar
+-- return (y,x)
+
+-- h :: IO (Int,Int)
+-- h = do
+-- x1 <- getChar
+-- x2 <- getChar
+-- x3 <- const (return ()) x1
+-- x4 <- getChar
+-- x5 <- getChar x4
+-- return (x2,x4)
=====================================
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
=====================================
@@ -4,7 +4,7 @@ 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:11-15
+Stopped in Main.f, break029.hs:6:3-16
_result :: Int = _
y :: Int = _
4
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cfddecd28638caee93197be09d4280ed4aa07e15...9cc406fe0cab5887bf6f8e9f3772525aa5c4a276
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cfddecd28638caee93197be09d4280ed4aa07e15...9cc406fe0cab5887bf6f8e9f3772525aa5c4a276
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/caf58f33/attachment-0001.html>
More information about the ghc-commits
mailing list