[Git][ghc/ghc][wip/expansions-appdo] 2 commits: make all error messages match
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Tue May 28 19:16:50 UTC 2024
Apoorv Ingle pushed to branch wip/expansions-appdo at Glasgow Haskell Compiler / GHC
Commits:
06273b79 by Apoorv Ingle at 2024-05-28T14:08:47-05:00
make all error messages match
- - - - -
5775afab by Apoorv Ingle at 2024-05-28T14:16:36-05:00
accepting T23540
- - - - -
5 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Utils/Unify.hs
- testsuite/tests/ado/ado002.stderr
- testsuite/tests/hiefile/should_run/T23540.stdout
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -1579,7 +1579,7 @@ pprMatch (Match { m_pats = pats, m_ctxt = ctxt, m_grhss = grhss })
<+> pprInfixOcc fun
<+> pprParendLPat opPrec p2
_ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats)
-
+ StmtCtxt _ -> (char '\\', pats)
LamAlt LamSingle -> (char '\\', pats)
ArrowMatchCtxt (ArrowLamAlt LamSingle) -> (char '\\', pats)
LamAlt LamCases -> lam_cases_result
@@ -1620,6 +1620,7 @@ matchSeparator IfAlt = text "->"
matchSeparator ArrowMatchCtxt{} = text "->"
matchSeparator PatBindRhs = text "="
matchSeparator PatBindGuards = text "="
+matchSeparator (StmtCtxt (HsDoStmt{})) = text "->"
matchSeparator StmtCtxt{} = text "<-"
matchSeparator RecUpd = text "=" -- This can be printed by the pattern
matchSeparator PatSyn = text "<-" -- match checker trace
@@ -1857,8 +1858,8 @@ 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 "<-" <+>
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -54,39 +54,34 @@ import Data.List ((\\))
-- 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 (HsExpr GhcRn)
-expandDoStmts doFlav stmts = do expanded_expr <- expand_do_stmts doFlav stmts
- case expanded_expr of
- 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 $ unLoc expanded_expr
+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 flav [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
- = return $ mkExpandedStmtPopAt loc stmt flav TcExpr body
+ = return $ if addPop then mkExpandedStmtPopAt loc stmt flav TcExpr body
+ else mkExpandedStmtAt loc stmt flav TcExpr body
| SyntaxExprRn ret <- ret_expr
--
@@ -94,18 +89,20 @@ expand_do_stmts flav [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_expr))]
-- return e ~~> return e
-- to make T18324 work
= do let expansion = genHsApp ret (L body_loc body)
- return $ mkExpandedStmtPopAt loc stmt flav TcExpr expansion
+ return $ if addPop then mkExpandedStmtPopAt loc stmt flav TcExpr expansion
+ else mkExpandedStmtAt loc stmt flav TcExpr expansion
-expand_do_stmts doFlavour (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 doFlavour lstmts
+ do expand_stmts <- expand_do_stmts True doFlavour lstmts
let expansion = genHsLet bs expand_stmts
- return $ mkExpandedStmtPopAt loc stmt doFlavour TcExpr expansion
+ return $ if addPop then mkExpandedStmtPopAt loc stmt doFlavour TcExpr expansion
+ else mkExpandedStmtAt loc stmt doFlavour TcExpr expansion
-expand_do_stmts doFlavour (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
@@ -114,29 +111,31 @@ expand_do_stmts doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
-- _ -> fail "Pattern match failure .."
-- -------------------------------------------------------
-- pat <- e ; stmts ~~> (>>=) e f
- = do expand_stmts <- expand_do_stmts doFlavour lstmts
+ = 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 doFlavour TcApp expansion
+ return $ if addPop then mkExpandedStmtPopAt loc stmt doFlavour TcApp expansion
+ else mkExpandedStmtAt loc stmt doFlavour TcApp expansion
| otherwise
= pprPanic "expand_do_stmts: The impossible happened, missing bind operator from renamer" (text "stmt" <+> ppr stmt)
-expand_do_stmts doFlavour (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 doFlavour lstmts
+ do expand_stmts_expr <- expand_do_stmts True doFlavour lstmts
let expansion = genHsExpApps then_op -- (>>)
[ e
, expand_stmts_expr ]
- return $ mkExpandedStmtPopAt loc stmt doFlavour TcApp expansion
+ return $ if addPop then mkExpandedStmtPopAt loc stmt doFlavour TcApp expansion
+ else mkExpandedStmtAt loc stmt doFlavour TcApp expansion
-expand_do_stmts doFlavour
+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
@@ -156,7 +155,7 @@ expand_do_stmts doFlavour
-- -> do { rec_stmts
-- ; return (local_only_ids ++ later_ids) } ))
-- (\ [ local_only_ids ++ later_ids ] -> stmts')
- do expand_stmts <- expand_do_stmts doFlavour 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) -- (>>=)
@@ -184,7 +183,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 _ (XStmtLR (ApplicativeStmt _ args mb_join))): lstmts) =
+expand_do_stmts addPop doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join))): lstmts) =
-- See Note [Applicative BodyStmt]
--
-- stmts ~~> stmts'
@@ -194,11 +193,8 @@ expand_do_stmts doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join))): lst
-- Very similar to HsToCore.Expr.dsDo
-- args are [(<$>, e1), (<*>, e2), .., ]
- do { xexpr' <- expand_do_stmts doFlavour lstmts
+ do { xexpr <- expand_do_stmts False 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
@@ -217,7 +213,8 @@ expand_do_stmts doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join))): lst
, text "lstmts:" <+> ppr lstmts
, text "mb_join:" <+> ppr mb_join
, text "expansion:" <+> ppr final_expr])
- ; return final_expr
+ ; return $ final_expr
+
}
where
do_arg :: ApplicativeArg GhcRn -> TcM ((LPat GhcRn, FailOperator GhcRn), LHsExpr GhcRn)
@@ -227,7 +224,8 @@ expand_do_stmts doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join))): lst
, arg_expr = (L rhs_loc rhs)
, is_body_stmt = is_body_stmt
}) =
- do let xx_expr = mkExpandedStmtAt rhs_loc stmt doFlavour TcExpr rhs
+ do let xx_expr = if addPop then mkExpandedStmtPopAt rhs_loc stmt doFlavour TcExpr rhs
+ else mkExpandedStmtAt rhs_loc stmt doFlavour TcExpr rhs
traceTc "do_arg" (text "OneArg" <+> vcat [ppr pat, ppr xx_expr])
return ((pat, mb_fail_op)
, xx_expr)
@@ -235,10 +233,10 @@ expand_do_stmts doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join))): lst
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])
+ 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)
- , wrapGenSpan xx_expr) }
+ , 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
@@ -256,7 +254,7 @@ expand_do_stmts doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join))): lst
xbsn = XBindStmtRn NoSyntaxExprRn Nothing
-expand_do_stmts _ stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr stmts)
+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 -> Maybe (HsDoFlavour, ExprLStmt GhcRn)
=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -133,7 +133,7 @@ matchActualFunTy
-- and NB: res_ty is an (uninstantiated) SigmaType
matchActualFunTy herald mb_thing err_info fun_ty
- = do assertPpr (isRhoTy fun_ty) (ppr fun_ty) $
+ = assertPpr (isRhoTy fun_ty) (ppr fun_ty) $
go fun_ty
where
-- Does not allocate unnecessary meta variables: if the input already is
=====================================
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
@@ -96,3 +95,11 @@ ado002.hs:23:9: error: [GHC-83865]
• 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
+ x3 <- const (return ()) x1
+ x4 <- getChar
+ x5 <- getChar x4
+ return (x2, x4)
+
=====================================
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/-/compare/67c1f2990b0edbda1bae36018740b01f29a65974...5775afabeab4d1180a88cd161905c40115ca95bb
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/67c1f2990b0edbda1bae36018740b01f29a65974...5775afabeab4d1180a88cd161905c40115ca95bb
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/20240528/7f0ac72d/attachment-0001.html>
More information about the ghc-commits
mailing list