[Git][ghc/ghc][master] Enable mdo statements to use HsExpansions

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
9f987235 by Apoorv Ingle at 2024-02-08T06:39:42-05:00
Enable mdo statements to use HsExpansions
Fixes: #24411
Added test T24411 for regression

- - - - -


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
=====================================
@@ -791,6 +791,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
=====================================
@@ -364,10 +364,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 _ 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/9f987235c8f20df55b9b16c8f9e0232288c9faeb

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9f987235c8f20df55b9b16c8f9e0232288c9faeb
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/20240208/0ac7fda4/attachment-0001.html>