[Git][ghc/ghc][wip/expand-do] 2 commits: Pop error context while checking do expansion generated GRHSs inside HsLam so...
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Fri Jul 21 01:15:46 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
574faca8 by Apoorv Ingle at 2023-07-19T17:10:13-05:00
Pop error context while checking do expansion generated GRHSs inside HsLam so that we do not print the previous statement error context
- - - - -
4230daa7 by Apoorv Ingle at 2023-07-20T20:14:10-05:00
make template haskell happy
- - - - -
10 changed files:
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Match.hs
- + testsuite/tests/typecheck/should_fail/DoExpansion1.hs
- + testsuite/tests/typecheck/should_fail/DoExpansion1.stderr
- + testsuite/tests/typecheck/should_fail/DoExpansion2.hs
- + testsuite/tests/typecheck/should_fail/DoExpansion2.stderr
- + testsuite/tests/typecheck/should_fail/DoExpansion3.hs
- + testsuite/tests/typecheck/should_fail/DoExpansion3.stderr
- testsuite/tests/typecheck/should_fail/all.T
Changes:
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -204,14 +204,15 @@ tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
-- - ones understood by GHC.Tc.Gen.Head.tcInferAppHead_maybe
-- See Note [Application chains and heads] in GHC.Tc.Gen.App
tcExpr e@(HsVar {}) res_ty = tcApp e res_ty
-tcExpr e@(HsApp {}) res_ty = tcApp e res_ty
+tcExpr e@(HsApp {}) res_ty = do traceTc "tcExpr" (text "hsApp")
+ tcApp e res_ty
tcExpr e@(OpApp {}) res_ty = tcApp e res_ty
tcExpr e@(HsAppType {}) res_ty = tcApp e res_ty
tcExpr e@(ExprWithTySig {}) res_ty = tcApp e res_ty
tcExpr e@(HsRecSel {}) res_ty = tcApp e res_ty
tcExpr e@(XExpr (ExpandedExpr {})) res_ty
- = do { traceTc "tcExpr" (text "calling tcApp for expanded Expr")
+ = do { traceTc "tcExpr" (text "ExpandedExpr")
; tcApp e res_ty
}
@@ -476,11 +477,11 @@ tcExpr (HsMultiIf _ alts) res_ty
; return (HsMultiIf res_ty alts') }
where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
-tcExpr hsDo@(HsDo _ doFlav@(DoExpr{}) ss@(L _ stmts)) res_ty
+tcExpr hsDo@(HsDo _ doFlav@(DoExpr{}) ss@(L loc stmts)) res_ty
= do { isApplicativeDo <- xoptM LangExt.ApplicativeDo
; if isApplicativeDo
then tcDoStmts doFlav ss res_ty
- else do { (L loc expanded_expr) <- expandDoStmts doFlav stmts
+ else do { (L _ expanded_expr) <- expandDoStmts doFlav stmts
-- Do expansion on the fly
-- ; let expanded_do_expr = mkExpandedExpr hsDo (unLoc expanded_expr)
; traceTc "tcDoStmts hsDo" (vcat [ ppr hsDo
@@ -488,7 +489,7 @@ tcExpr hsDo@(HsDo _ doFlav@(DoExpr{}) ss@(L _ stmts)) res_ty
])
; setSrcSpanA loc $
-- addExprCtxt (text "tcExpr") hsDo $
- tcExpr expanded_expr res_ty
+ (\ x -> XExpr (ExpansionExpr (HsExpanded hsDo x))) <$> (tcExpr expanded_expr res_ty)
}
}
@@ -504,7 +505,7 @@ tcExpr hsDo@(HsDo _ doFlav@(MDoExpr{}) ss@(L loc stmts)) res_ty
])
; setSrcSpanA loc $
-- addExprCtxt (text "tcExpr") hsDo $
- tcExpr expanded_expr res_ty
+ (\ x -> XExpr (ExpansionExpr (HsExpanded hsDo x))) <$> (tcExpr expanded_expr res_ty)
}
}
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -345,7 +345,7 @@ splitHsApps e = -- maybeShiftCtxt $
go (XExpr (ExpandedStmt (HsExpanded stmt fun))) _ args
= go fun (VAExpansionStmt stmt)
- (EWrap (EExpandStmt stmt) : args)
+ (EWrap (EExpandStmt stmt) : args)
-- See Note [Desugar OpApp in the typechecker]
go e@(OpApp _ arg1 (L l op) arg2) _ args
@@ -1514,7 +1514,7 @@ mis-match in the number of value arguments.
addStmtCtxt :: SDoc -> ExprLStmt GhcRn -> TcRn a -> TcRn a
addStmtCtxt _ stmt thing_inside
- = addErrCtxt ( {-doc <+>-}
+ = addErrCtxt ({-doc <+>-}
pprStmtInCtxt (HsDoStmt (DoExpr Nothing)) (unLoc stmt)) thing_inside
where
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -256,7 +256,11 @@ tcMatch ctxt pat_tys rhs_ty match
match@(Match { m_pats = pats, m_grhss = grhss })
= add_match_ctxt match $
do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $
- tcGRHSs ctxt grhss rhs_ty
+ maybeErrPopCtxt (mc_what ctxt) $ -- we are likely in a do expansion generated match
+ -- pop the previous context as it is
+ -- the one for previous statement context
+ do { traceTc "tcMatch" (ppr pats)
+ ; tcGRHSs ctxt grhss rhs_ty }
; return (Match { m_ext = noAnn
, m_ctxt = mc_what ctxt, m_pats = pats'
, m_grhss = grhss' }) }
@@ -269,6 +273,9 @@ tcMatch ctxt pat_tys rhs_ty match
StmtCtxt (HsDoStmt{}) -> thing_inside -- this is an expanded do stmt
_ -> addErrCtxt (pprMatchInCtxt match) thing_inside
+ maybeErrPopCtxt (StmtCtxt (HsDoStmt{})) thing_inside = do traceTc "tcMatch popErrCtxt" empty
+ popErrCtxt thing_inside
+ maybeErrPopCtxt _ thing_inside = thing_inside
-------------
tcGRHSs :: AnnoBody body
=> TcMatchCtxt body -> GRHSs GhcRn (LocatedA (body GhcRn)) -> ExpRhoType
@@ -1223,13 +1230,13 @@ expand_do_stmts _ (stmt@(L _ (ParStmt {})):_) =
expand_do_stmts _ (stmt@(L _ (ApplicativeStmt _ _ _)): _) =
pprPanic "expand_do_stmts: Applicative Stmt" $ ppr stmt
-expand_do_stmts _ [stmt@(L _ (LastStmt _ b@(L b_loc body) _ ret_expr))]
+expand_do_stmts _ [stmt@(L loc (LastStmt _ (L _ body) _ ret_expr))]
-- 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 $ L b_loc (mkPopErrCtxtExpr $ L b_loc (mkExpandedStmt stmt body))
+ return $ L loc (mkPopErrCtxtExpr $ L loc (mkExpandedStmt stmt body))
| SyntaxExprRn ret <- ret_expr
--
@@ -1238,9 +1245,8 @@ expand_do_stmts _ [stmt@(L _ (LastStmt _ b@(L b_loc body) _ ret_expr))]
-- to make T18324 work
= do traceTc "expand_do_stmts last" (ppr ret_expr)
return $ wrapGenSpan (mkPopErrCtxtExpr $
- L b_loc (mkExpandedStmt stmt (
- genHsApp (wrapGenSpan ret) b)))
-
+ wrapGenSpan (mkExpandedStmt stmt (
+ genHsApp (wrapGenSpan ret) (L loc body))))
expand_do_stmts do_or_lc (stmt@(L loc (LetStmt _ bs)) : lstmts) =
-- stmts ~~> stmts'
@@ -1250,7 +1256,7 @@ expand_do_stmts do_or_lc (stmt@(L loc (LetStmt _ bs)) : lstmts) =
return $ wrapGenSpan (mkPopErrCtxtExpr $
L loc (mkExpandedStmt stmt (genHsLet bs $ expand_stmts)))
-expand_do_stmts do_or_lc (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
+expand_do_stmts do_or_lc (stmt@(L _ (BindStmt xbsrn pat e)): lstmts)
| SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
, fail_op <- xbsrn_failOp xbsrn =
-- the pattern binding pat can fail
@@ -1265,14 +1271,13 @@ expand_do_stmts do_or_lc (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
expr <- mk_failable_lexpr_tcm pat
expand_stmts
fail_op
- return $ wrapGenSpan (mkPopErrCtxtExpr $ L loc (wrapGenSpan (mkExpandedStmt stmt (
- (wrapGenSpan bind_op) -- (>>=)
- `genHsApp` e))
- `genHsApp`
- expr))
+ return $ wrapGenSpan (mkPopErrCtxtExpr $ (wrapGenSpan (mkExpandedStmt stmt (
+ (wrapGenSpan ((wrapGenSpan bind_op) -- (>>=)
+ `genHsApp` e))
+ `genHsApp` expr))))
| otherwise = pprPanic "expand do: shouldn't happen" (text "stmt" <+> ppr stmt)
-expand_do_stmts do_or_lc (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _)) : lstmts) =
+expand_do_stmts do_or_lc (stmt@(L _ (BodyStmt _ e (SyntaxExprRn then_op) _)) : lstmts) =
-- See Note [BodyStmt]
-- stmts ~~> stmts'
-- ----------------------------------------------
@@ -1280,7 +1285,7 @@ expand_do_stmts do_or_lc (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _)) :
do -- isRebindableOn <- xoptM LangExt.RebindableSyntax
-- let spanWrap = if isRebindableOn then noLocA else wrapGenSpan
expand_stmts <- expand_do_stmts do_or_lc lstmts
- return $ wrapGenSpan (mkPopErrCtxtExpr $ L loc ((L loc (mkExpandedStmt stmt (
+ return $ wrapGenSpan (mkPopErrCtxtExpr $ wrapGenSpan ((wrapGenSpan (mkExpandedStmt stmt (
(wrapGenSpan then_op) -- (>>)
`genHsApp` e)))
`genHsApp`
=====================================
testsuite/tests/typecheck/should_fail/DoExpansion1.hs
=====================================
@@ -0,0 +1,32 @@
+module DoExpansion1 where
+
+
+-- Ensure that >> expansions work okay
+
+qqqqq1 :: IO ()
+qqqqq1 = putStrLn 1 >> putStrLn "q2" >> putStrLn "q3" -- this should error as "In the first argument to >>"
+
+
+qqqqq2 :: IO ()
+qqqqq2 = (putStrLn "q1" >> putStrLn 2) >> putStrLn "q3" -- this should error as "In first argument to >>
+ -- In second argument to >>"
+
+qqqqq3 :: IO ()
+qqqqq3 = putStrLn "q1" >> (putStrLn "q2" >> putStrLn 3) -- this should error as "In second argument to >>
+ -- In second argument to >>"
+
+rrrr1 :: IO ()
+rrrr1 = do putStrLn 1 -- this should error as "In the stmt of a do block"
+ putStrLn "r2"
+ putStrLn "r3"
+
+rrrr2 :: IO ()
+rrrr2 = do putStrLn "r1"
+ putStrLn 2 -- this should error as "In the stmt of a do block"
+ putStrLn "r3"
+
+
+rrrr3 :: IO ()
+rrrr3 = do putStrLn "r1"
+ putStrLn "r2"
+ putStrLn 3 -- this should error as "In the stmt of a do block"
=====================================
testsuite/tests/typecheck/should_fail/DoExpansion1.stderr
=====================================
@@ -0,0 +1,48 @@
+
+DoExpansion1.hs:7:19: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefault)]
+ • No instance for ‘Num String’ arising from the literal ‘1’
+ • In the first argument of ‘putStrLn’, namely ‘1’
+ In the first argument of ‘(>>)’, namely ‘putStrLn 1’
+ In the first argument of ‘(>>)’, namely
+ ‘putStrLn 1 >> putStrLn "q2"’
+
+DoExpansion1.hs:11:37: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefault)]
+ • No instance for ‘Num String’ arising from the literal ‘2’
+ • In the first argument of ‘putStrLn’, namely ‘2’
+ In the second argument of ‘(>>)’, namely ‘putStrLn 2’
+ In the first argument of ‘(>>)’, namely
+ ‘(putStrLn "q1" >> putStrLn 2)’
+
+DoExpansion1.hs:15:54: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefault)]
+ • No instance for ‘Num String’ arising from the literal ‘3’
+ • In the first argument of ‘putStrLn’, namely ‘3’
+ In the second argument of ‘(>>)’, namely ‘putStrLn 3’
+ In the second argument of ‘(>>)’, namely
+ ‘(putStrLn "q2" >> putStrLn 3)’
+
+DoExpansion1.hs:19:21: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefault)]
+ • No instance for ‘Num String’ arising from the literal ‘1’
+ • In the first argument of ‘putStrLn’, namely ‘1’
+ In a stmt of a 'do' block: putStrLn 1
+ In the expression:
+ do putStrLn 1
+ putStrLn "r2"
+ putStrLn "r3"
+
+DoExpansion1.hs:25:21: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefault)]
+ • No instance for ‘Num String’ arising from the literal ‘2’
+ • In the first argument of ‘putStrLn’, namely ‘2’
+ In a stmt of a 'do' block: putStrLn 2
+ In the expression:
+ do putStrLn "r1"
+ putStrLn 2
+ putStrLn "r3"
+
+DoExpansion1.hs:32:21: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefault)]
+ • No instance for ‘Num String’ arising from the literal ‘3’
+ • In the first argument of ‘putStrLn’, namely ‘3’
+ In a stmt of a 'do' block: putStrLn 3
+ In the expression:
+ do putStrLn "r1"
+ putStrLn "r2"
+ putStrLn 3
=====================================
testsuite/tests/typecheck/should_fail/DoExpansion2.hs
=====================================
@@ -0,0 +1,28 @@
+module DoExpansion2 where
+
+
+-- make sure all the (>>=) expansion works okay
+
+getVal :: Int -> IO String
+getVal _ = return "x"
+
+ffff1, ffff2, ffff3, ffff4, ffff5 :: IO Int
+
+
+ffff1 = do x <- getChar
+ return (x + 1) -- should error here
+
+ffff2 = do x <- (getVal 3) -- should error here
+ return x
+
+ffff3 = do x <- getChar
+ y <- getChar
+ return (x + y) -- should error here
+
+ffff4 = do Just x <- getChar -- should error here
+ return x
+
+
+ffff5 = do x <- getChar -- should error here
+ Just x <- getChar
+ return x
=====================================
testsuite/tests/typecheck/should_fail/DoExpansion2.stderr
=====================================
@@ -0,0 +1,63 @@
+
+DoExpansion2.hs:13:20: warning: [GHC-83865] [-Wdeferred-type-errors]
+ • Couldn't match expected type ‘Int’ with actual type ‘Char’
+ • In the first argument of ‘(+)’, namely ‘x’
+ In the first argument of ‘return’, namely ‘(x + 1)’
+ In a stmt of a 'do' block: return (x + 1)
+ |
+13 | return (x + 1) -- should error here
+ | ^
+
+DoExpansion2.hs:16:19: warning: [GHC-83865] [-Wdeferred-type-errors]
+ • Couldn't match type ‘[Char]’ with ‘Int’
+ Expected: Int
+ Actual: String
+ • In the first argument of ‘return’, namely ‘x’
+ In a stmt of a 'do' block: return x
+ In the expression:
+ do x <- (getVal 3)
+ return x
+ |
+16 | return x
+ | ^
+
+DoExpansion2.hs:20:20: warning: [GHC-83865] [-Wdeferred-type-errors]
+ • Couldn't match expected type ‘Int’ with actual type ‘Char’
+ • In the first argument of ‘(+)’, namely ‘x’
+ In the first argument of ‘return’, namely ‘(x + y)’
+ In a stmt of a 'do' block: return (x + y)
+ |
+20 | return (x + y) -- should error here
+ | ^
+
+DoExpansion2.hs:20:24: warning: [GHC-83865] [-Wdeferred-type-errors]
+ • Couldn't match expected type ‘Int’ with actual type ‘Char’
+ • In the second argument of ‘(+)’, namely ‘y’
+ In the first argument of ‘return’, namely ‘(x + y)’
+ In a stmt of a 'do' block: return (x + y)
+ |
+20 | return (x + y) -- should error here
+ | ^
+
+DoExpansion2.hs:22:12: warning: [GHC-83865] [-Wdeferred-type-errors]
+ • Couldn't match expected type ‘Char’ with actual type ‘Maybe Int’
+ • In the pattern: Just x
+ In a stmt of a 'do' block: Just x <- getChar
+ In the expression:
+ do Just x <- getChar
+ return x
+ |
+22 | ffff4 = do Just x <- getChar -- should error here
+ | ^^^^^^
+
+DoExpansion2.hs:27:12: warning: [GHC-83865] [-Wdeferred-type-errors]
+ • Couldn't match expected type ‘Char’ with actual type ‘Maybe Int’
+ • In the pattern: Just x
+ In a stmt of a 'do' block: Just x <- getChar
+ In the expression:
+ do x <- getChar
+ Just x <- getChar
+ return x
+ |
+27 | Just x <- getChar
+ | ^^^^^^
=====================================
testsuite/tests/typecheck/should_fail/DoExpansion3.hs
=====================================
@@ -0,0 +1,33 @@
+module DoExpansion2 where
+
+
+-- make sure all the (>>=) expansion works okay
+
+getVal :: Int -> IO String
+getVal _ = return "x"
+
+gggg1, gggg2, gggg3, gggg4, gggg5 :: IO Int
+
+
+gggg1 = do let x = 1
+ let y = 2
+ putStrLn x -- should error here
+ return (x + 1)
+
+gggg2 = do let x = 1
+ y = getChar 2 -- should error here
+ z = 3
+ return x
+
+gggg3 = do x <- getChar
+ let y = 2
+ z <- getChar
+ return (x + y) -- should error here
+
+gggg4 = do Just x <- getChar -- should error here
+ return x
+
+
+gggg5 = do x <- getChar -- should error here
+ Just x <- getChar
+ return x
=====================================
testsuite/tests/typecheck/should_fail/DoExpansion3.stderr
=====================================
@@ -0,0 +1,55 @@
+
+DoExpansion3.hs:15:20: warning: [GHC-83865] [-Wdeferred-type-errors]
+ • Couldn't match type ‘[Char]’ with ‘Int’
+ Expected: Int
+ Actual: String
+ • In the first argument of ‘(+)’, namely ‘x’
+ In the first argument of ‘return’, namely ‘(x + 1)’
+ In a stmt of a 'do' block: return (x + 1)
+ |
+15 | return (x + 1)
+ | ^
+
+DoExpansion3.hs:18:20: warning: [GHC-83865] [-Wdeferred-type-errors]
+ • Couldn't match expected type: t0 -> t
+ with actual type: IO Char
+ • The function ‘getChar’ is applied to one value argument,
+ but its type ‘IO Char’ has none
+ In the expression: getChar 2
+ In an equation for ‘y’: y = getChar 2
+ • Relevant bindings include y :: t (bound at DoExpansion3.hs:18:16)
+ |
+18 | y = getChar 2 -- should error here
+ | ^^^^^^^^^
+
+DoExpansion3.hs:25:20: warning: [GHC-83865] [-Wdeferred-type-errors]
+ • Couldn't match expected type ‘Int’ with actual type ‘Char’
+ • In the first argument of ‘(+)’, namely ‘x’
+ In the first argument of ‘return’, namely ‘(x + y)’
+ In a stmt of a 'do' block: return (x + y)
+ |
+25 | return (x + y) -- should error here
+ | ^
+
+DoExpansion3.hs:27:12: warning: [GHC-83865] [-Wdeferred-type-errors]
+ • Couldn't match expected type ‘Char’ with actual type ‘Maybe Int’
+ • In the pattern: Just x
+ In a stmt of a 'do' block: Just x <- getChar
+ In the expression:
+ do Just x <- getChar
+ return x
+ |
+27 | gggg4 = do Just x <- getChar -- should error here
+ | ^^^^^^
+
+DoExpansion3.hs:32:12: warning: [GHC-83865] [-Wdeferred-type-errors]
+ • Couldn't match expected type ‘Char’ with actual type ‘Maybe Int’
+ • In the pattern: Just x
+ In a stmt of a 'do' block: Just x <- getChar
+ In the expression:
+ do x <- getChar
+ Just x <- getChar
+ return x
+ |
+32 | Just x <- getChar
+ | ^^^^^^
=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -699,3 +699,8 @@ test('VisFlag5', normal, compile_fail, [''])
test('T22684', normal, compile_fail, [''])
test('T23514a', normal, compile_fail, [''])
test('T22478c', normal, compile_fail, [''])
+
+# all the various do expansion fail messages
+test('DoExpansion1', normal, compile, ['-fdefer-type-errors'])
+test('DoExpansion2', normal, compile, ['-fdefer-type-errors'])
+test('DoExpansion3', normal, compile, ['-fdefer-type-errors'])
\ No newline at end of file
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/86a237307a8801d46651f1c72363ff92a364b772...4230daa7126321aaa700a38b0555a379d4b022cb
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/86a237307a8801d46651f1c72363ff92a364b772...4230daa7126321aaa700a38b0555a379d4b022cb
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/20230720/83e20cf4/attachment-0001.html>
More information about the ghc-commits
mailing list