[Git][ghc/ghc][wip/expand-mdo] Enable mdo statements to use HsExpansions

[Apoorv Ingle (@ani)]

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


Commits:
67afcff9 by Apoorv Ingle at 2024-02-05T14:32:37-06:00
Enable mdo statements to use HsExpansions
Fixes: #24411

- - - - -


5 changed files:

- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Match.hs
- + testsuite/tests/typecheck/should_run/T24411.hs
- + testsuite/tests/typecheck/should_run/T24411.stdout
- testsuite/tests/typecheck/should_run/all.T


Changes:

=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -788,6 +788,9 @@ addArgCtxt :: AppCtxt -> LHsExpr GhcRn
 --    b. Or, we are typechecking the second argument which would be a generated lambda
 --       so we set the location to be whatever the location in the context is
 --  See Note [Expanding HsDo with XXExprGhcRn] in GHC.Tc.Gen.Do
+-- For future: we need a cleaner way of doing this bit of adding the right error context.
+-- There is a delicate dance of looking at source locations and reconstructing
+-- whether the piece of code is a `do`-expanded code or some other expanded code.
 addArgCtxt ctxt (L arg_loc arg) thing_inside
   = do { in_generated_code <- inGeneratedCode
        ; case ctxt of


=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -386,10 +386,9 @@ tcDoStmts doExpr@(DoExpr _) ss@(L l stmts) res_ty
                   ; mkExpandedExprTc (HsDo noExtField doExpr ss) <$> tcExpr (unLoc expanded_expr) res_ty }
         }
 
-tcDoStmts mDoExpr@(MDoExpr _) (L l stmts) res_ty
-  = do  { stmts' <- tcStmts (HsDoStmt mDoExpr) tcDoStmt stmts res_ty
-        ; res_ty <- readExpType res_ty
-        ; return (HsDo res_ty mDoExpr (L l stmts')) }
+tcDoStmts mDoExpr@(MDoExpr _) ss@(L 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  }
 
 tcDoStmts MonadComp (L l stmts) res_ty
   = do  { stmts' <- tcStmts (HsDoStmt MonadComp) tcMcStmt stmts res_ty


=====================================
testsuite/tests/typecheck/should_run/T24411.hs
=====================================
@@ -0,0 +1,18 @@
+{-# LANGUAGE ImpredicativeTypes, RecursiveDo #-}
+
+type Id = forall a. a -> a
+
+t :: IO Id
+t = return id
+
+p :: Id -> (Bool, Int)
+p f = (f True, f 3)
+
+foo1 = t >>= \x -> return (p x)
+
+foo2 = mdo { x <- t ; return (p x) }
+
+main = do x <- foo2
+          y <- foo1
+          putStrLn $ show x
+          putStrLn $ show y


=====================================
testsuite/tests/typecheck/should_run/T24411.stdout
=====================================
@@ -0,0 +1,2 @@
+(True,3)
+(True,3)


=====================================
testsuite/tests/typecheck/should_run/all.T
=====================================
@@ -176,3 +176,4 @@ test('T23761b', normal, compile_and_run, [''])
 test('T18324', normal, compile_and_run, [''])
 test('T15598', normal, compile_and_run, [''])
 test('T22086', normal, compile_and_run, [''])
+test('T24411', normal, compile_and_run, [''])



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/67afcff9c949908f1876837b4a6539735cb84cc5
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/20240205/9d56e510/attachment-0001.html>