[Git][ghc/ghc][wip/expand-do] look into XExprs in tcInferAppHead_maybe for infering the type to make T18324 typecheck and run

[Apoorv Ingle (@ani)]

Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC


Commits:
be6ecf94 by Apoorv Ingle at 2023-05-31T20:31:51-05:00
look into XExprs in tcInferAppHead_maybe for infering the type to make T18324 typecheck and run

- - - - -


6 changed files:

- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Match.hs
- testsuite/tests/typecheck/should_compile/all.T
- testsuite/tests/typecheck/should_compile/T18324.hs → testsuite/tests/typecheck/should_run/T18324.hs
- testsuite/tests/typecheck/should_run/all.T


Changes:

=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -217,7 +217,7 @@ tcExpr (XExpr (ExpandedStmt (HsExpanded stmt expr))) res_ty
                                     , text "res_ty" <+> ppr res_ty
                                     ])
         ; addErrCtxt (pprStmtInCtxt @Renamed @Renamed @Renamed (HsDoStmt (DoExpr Nothing)) (unLoc stmt)) $
-          tcApp (unLoc expr) res_ty
+          tcExpr (unLoc expr) res_ty
         }
 
 


=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -785,6 +785,8 @@ tcInferAppHead_maybe fun args
       HsOverLit _ lit           -> Just <$> tcInferOverLit lit
       HsUntypedSplice (HsUntypedSpliceTop _ e) _
                                 -> tcInferAppHead_maybe e args
+      XExpr (PopSrcSpan e)            -> tcInferAppHead_maybe (unLoc e) args
+      XExpr (ExpandedStmt (HsExpanded _ e)) -> tcInferAppHead_maybe (unLoc e) args
       _                         -> return Nothing
 
 addHeadCtxt :: AppCtxt -> TcM a -> TcM a


=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1235,10 +1235,9 @@ expand_do_stmts do_or_lc (stmt@(L loc (LetStmt _ bnds)) : lstmts) =
 --    ------------------------------------------------
 --       let x = e ; stmts ~~> let x = e in stmts'
   do expand_stmts <- expand_do_stmts do_or_lc lstmts
-     return $ L loc $ mkExpandedStmt stmt
-                             (wrapGenSpan (HsLet noExtField
-                                                      noHsTok bnds
-                                                      noHsTok expand_stmts))
+     return $ (wrapGenSpan (HsLet noExtField
+                             noHsTok bnds
+                             noHsTok $ L loc (mkPopSrcSpanExpr (L loc (mkExpandedStmt stmt expand_stmts)))))
 
 expand_do_stmts do_or_lc (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
   | SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn


=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -875,5 +875,3 @@ test('T23171', normal, compile, [''])
 test('T23192', normal, compile, [''])
 test('T23199', normal, compile, [''])
 test('T23156', normal, compile, [''])
-# Tests for expanding do before typechecking (Impredicative)
-test('T18324', normal, compile, [''])


=====================================
testsuite/tests/typecheck/should_compile/T18324.hs → testsuite/tests/typecheck/should_run/T18324.hs
=====================================
@@ -16,5 +16,5 @@ foo2 = do { x <- t ; return (p x) }
 
 blah x y = return (3::Int)
 
-main = do x <- foo1
+main = do x <- foo2
           putStrLn $ show x


=====================================
testsuite/tests/typecheck/should_run/all.T
=====================================
@@ -163,3 +163,5 @@ test('T19397M4', extra_files(['T19397S.hs']), compile_and_run, ['-main-is foo'])
 test('T19667', normal, compile_and_run, ['-fhpc'])
 test('T20768', normal, compile_and_run, [''])
 test('T22510', normal, compile_and_run, [''])
+# Tests for expanding do before typechecking (Impredicative)
+test('T18324', normal, compile_and_run, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/be6ecf94873df437026961022a31ec7068fabfc5

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/be6ecf94873df437026961022a31ec7068fabfc5
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/20230531/1161c009/attachment-0001.html>