[Git][ghc/ghc][wip/expand-do] set correct src spans to statement expansions
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Fri May 26 18:58:52 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
4ea7be30 by Apoorv Ingle at 2023-05-26T13:58:43-05:00
set correct src spans to statement expansions
- - - - -
7 changed files:
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Match.hs
- testsuite/tests/deSugar/should_compile/T3263-2.hs
- testsuite/tests/pmcheck/should_compile/DoubleMatch.hs
- testsuite/tests/pmcheck/should_compile/all.T
- testsuite/tests/rebindable/T18324.hs
Changes:
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -858,8 +858,7 @@ warnUnusedBindValue :: LHsExpr GhcTc -> LHsExpr GhcTc -> Type -> DsM ()
warnUnusedBindValue fun arg@(L loc _) arg_ty
| Just (l, f) <- fish_var fun
, f `hasKey` thenMClassOpKey -- it is a (>>)
- , isNoSrcSpan l || isGeneratedSrcSpan l -- it is compiler generated
- -- TODO: check why is isGeneratedSrcSpan false?
+ , isGeneratedSrcSpan l -- it is compiler generated (>>)
= do tracePm "warnUnusedBindValue" (vcat [ text "fun" <+> ppr fun
, text "loc" <+> ppr l
, text "locGen?" <+> ppr (isGeneratedSrcSpan l)
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -412,8 +412,8 @@ tcExpr (HsMultiIf _ alts) res_ty
tcExpr (XExpr (PopSrcSpan expr)) res_ty = popErrCtxt $ tcExpr (unLoc expr) res_ty
tcExpr (XExpr (ExpandedStmt (HsExpanded stmt expr))) res_ty
- = do { traceTc "tcDoStmts" (vcat [ text "stmt" <+> ppr stmt
- , text "expr" <+> ppr expr
+ = do { traceTc "tcDoStmts" (vcat [ text "stmt:" <+> ppr stmt
+ , text "expr:" <+> ppr expr
, text "res_ty" <+> ppr res_ty ])
; addErrCtxt (pprStmtInCtxt @Renamed @Renamed @Renamed (HsDoStmt (DoExpr Nothing)) (unLoc stmt)) $
tcExpr (unLoc expr) res_ty
@@ -423,7 +423,9 @@ tcExpr hsDo@(HsDo _ doFlav@(DoExpr{}) (L _ stmts)) res_ty
= do { expand_expr <- expandDoStmts doFlav stmts
-- Do expansion on the fly
; let expanded_do_expr = mkExpandedExpr hsDo (unLoc expand_expr)
- ; traceTc "tcDoStmts doExpr" (ppr expanded_do_expr)
+ ; traceTc "tcDoStmts " (vcat [ text "hsDo:" <+> ppr hsDo
+ , text "expr:" <+> ppr expand_expr
+ ])
; tcExpr expanded_do_expr res_ty
}
@@ -431,7 +433,9 @@ tcExpr hsDo@(HsDo _ doFlav@(MDoExpr{}) (L _ stmts)) res_ty
= do { expand_expr <- expandDoStmts doFlav stmts
-- Do expansion on the fly
; let expanded_do_expr = mkExpandedExpr hsDo (unLoc expand_expr)
- ; traceTc "tcDoStmts mDoExpr" (ppr expanded_do_expr)
+ ; traceTc "tcDoStmts " (vcat [ text "hsDo:" <+> ppr hsDo
+ , text "expr:" <+> ppr expand_expr
+ ])
; tcExpr expanded_do_expr res_ty
}
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1214,11 +1214,11 @@ expand_do_stmts _ [stmt@(L loc (LastStmt _ body _ ret_expr))]
-- ------------------------------------------------
-- return e ~~> return e
-- to make T18324 work
- = return $ genPopSrcSpanExpr $ mkExpandedStmtLExpr stmt
- (genPopSrcSpanExpr (L loc (genHsApp ret body)))
+ = return $ genPopSrcSpanExpr $ L loc $ mkExpandedStmt stmt
+ (genPopSrcSpanExpr (L loc (genHsApp ret body)))
-expand_do_stmts do_or_lc (stmt@(L _ (BindStmt xbsrn pat e)): lstmts)
+expand_do_stmts do_or_lc (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
| SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
, fail_op <- xbsrn_failOp xbsrn =
-- the pattern binding pat can fail
@@ -1229,11 +1229,10 @@ expand_do_stmts do_or_lc (stmt@(L _ (BindStmt xbsrn pat e)): lstmts)
-- pat <- e ; stmts ~~> (>>=) e f
do expand_stmts <- expand_do_stmts do_or_lc lstmts
expr <- mk_failable_lexpr_tcm pat expand_stmts fail_op
- return $ mkExpandedStmtLExpr stmt
- (mkHsApps (wrapGenSpan bind_op) -- (>>=)
- [ genPopSrcSpanExpr e
- , genPopSrcSpanExpr expr
- ])
+ return $ (mkHsApps (wrapGenSpan bind_op) -- (>>=)
+ [ L loc (mkExpandedStmt stmt $ (genPopSrcSpanExpr e))
+ , genPopSrcSpanExpr expr
+ ])
| otherwise = pprPanic "expand do: shouldn't happen" (text "stmt" <+> ppr stmt)
@@ -1248,23 +1247,22 @@ expand_do_stmts do_or_lc (stmt@(L _ (LetStmt _ bnds)) : lstmts) =
noHsTok (genPopSrcSpanExpr expand_stmts)))
-expand_do_stmts do_or_lc (stmt@(L _ (BodyStmt _ e (SyntaxExprRn f) _)) : lstmts) =
+expand_do_stmts do_or_lc (stmt@(L loc (BodyStmt _ e (SyntaxExprRn f) _)) : lstmts) =
-- See Note [BodyStmt]
-- stmts ~~> stmts'
-- ----------------------------------------------
-- e ; stmts ~~> (>>) e stmts'
do expand_stmts <- expand_do_stmts do_or_lc lstmts
- return $ mkExpandedStmtLExpr stmt
- (genPopSrcSpanExpr $ mkHsApps (wrapGenSpan f) -- (>>)
- [ genPopSrcSpanExpr e -- e
- , genPopSrcSpanExpr expand_stmts ]) -- stmts'
+ return $ (genPopSrcSpanExpr $ (mkHsApps (wrapGenSpan f) -- (>>)
+ [ L loc (mkExpandedStmt stmt $ (genPopSrcSpanExpr e)) -- e
+ , genPopSrcSpanExpr expand_stmts ])) -- stmts'
expand_do_stmts do_or_lc
- ((L _ (RecStmt { recS_stmts = rec_stmts
- , recS_later_ids = later_ids -- forward referenced local ids
- , recS_rec_ids = local_ids -- ids referenced outside of the rec block
- , recS_mfix_fn = SyntaxExprRn mfix_fun -- the `mfix` expr
- , recS_ret_fn = SyntaxExprRn return_fun -- the `return` expr
+ ((L do_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
+ , recS_mfix_fn = SyntaxExprRn mfix_fun -- the `mfix` expr
+ , recS_ret_fn = SyntaxExprRn return_fun -- the `return` expr
-- use it explicitly
-- at the end of expanded rec block
}))
@@ -1294,9 +1292,9 @@ expand_do_stmts do_or_lc
Nothing
(SyntaxExprRn return_fun)
do_stmts :: XRec GhcRn [ExprLStmt GhcRn]
- do_stmts = wrapGenSpan $ (unLoc rec_stmts) ++ [return_stmt]
+ do_stmts = L stmts_loc $ rec_stmts ++ [return_stmt]
do_block :: LHsExpr GhcRn
- do_block = wrapGenSpan $ HsDo noExtField (DoExpr Nothing) $ do_stmts
+ do_block = L do_loc $ HsDo noExtField (DoExpr Nothing) $ do_stmts
mfix_expr :: LHsExpr GhcRn
mfix_expr = mkHsLamDoExp [ wrapGenSpan (LazyPat noExtField $ mkBigLHsVarPatTup all_ids) ] $ do_block
-- LazyPat becuase we do not want to eagerly evaluate the pattern
@@ -1442,4 +1440,18 @@ join (<*>) (\ x -> \ 'a' -> return ()
\ _ -> fail ..)
getChar
return (3 :: Int)
+
+
+
+Impredicative types (T18324)
+
+t :: IO Id
+p :: Id -> (Bool, Int)
+foo2 = do { x <- t ; return (p x) }
+
+foo2 = do { x <- t ; return (p x) }
+ {Expansion: (>>=) t (\ x -> return (p x))}
+
+
+
-}
=====================================
testsuite/tests/deSugar/should_compile/T3263-2.hs
=====================================
@@ -14,14 +14,14 @@ t2 :: Monad m => m (m Int)
t2 = return (return 10)
-- No warning
-asdft3 :: Monad m => m (m Int)
-asdft3 = do
+t3 :: Monad m => m (m Int)
+t3 = do
return 10
return (return 10)
-- Warning
-asdft4 :: forall m. Monad m => m Int
-asdft4 = do
+t4 :: forall m. Monad m => m Int
+t4 = do
return (return 10 :: m Int)
return 10
@@ -41,7 +41,7 @@ t6 = mdo
unit :: ()
unit = ()
--- -- No warning
+-- No warning
t7 :: forall m. Monad m => m Int
t7 = do
return unit
=====================================
testsuite/tests/pmcheck/should_compile/DoubleMatch.hs
=====================================
@@ -16,27 +16,3 @@ doingThing handler = do
Handler1 -> 1
return action
return v
-
--- doingThing123 :: Handler -> IO Int
--- doingThing123 handler = (>>=)
--- (case handler of
--- Default -> return 0
--- _other_handler -> do
--- asdf <- return 1
--- let action = case handler of
--- Handler1 -> 1
--- return action)
--- (\v -> return v)
-
-
--- doingThing123 :: Handler -> IO Int
--- doingThing123 handler = (>>=)
--- (case handler of
--- Default -> return 0
--- _other_handler ->
--- (>>=)(return 1) (\asdf ->
--- let action = case handler of
--- Handler1 -> 1
--- in
--- return action))
--- (\v -> return v)
=====================================
testsuite/tests/pmcheck/should_compile/all.T
=====================================
@@ -160,7 +160,4 @@ test('EmptyCase007', [], compile, [overlapping_incomplete])
test('EmptyCase008', [], compile, [overlapping_incomplete])
test('EmptyCase009', [], compile, [overlapping_incomplete])
test('EmptyCase010', [], compile, [overlapping_incomplete])
-test('T19271', [], compile, [overlapping_incomplete])
-test('T21761', [], compile, [overlapping_incomplete])
-test('T22964', [], compile, [overlapping_incomplete])
test('DoubleMatch', normal, compile, [overlapping_incomplete])
=====================================
testsuite/tests/rebindable/T18324.hs
=====================================
@@ -18,6 +18,3 @@ blah x y = return (3::Int)
main = do x <- foo1
putStrLn $ show x
-
-
-
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4ea7be30c2d0c59182c8ba870e957e49fc88b686
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4ea7be30c2d0c59182c8ba870e957e49fc88b686
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/20230526/2974df73/attachment-0001.html>
More information about the ghc-commits
mailing list