diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs index ee6c2fe599d0b51ebe8593b55a146401d044e263..6b22d661875934904c9c713001f372e82dee2a1c 100644 --- a/compiler/GHC/Tc/Gen/App.hs +++ b/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 diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs index 576d27d1a36e1d70792fbc51e19e42c8c1b997bb..83ff2e511914d1c0f7f512ee8de0dcee7dbcc454 100644 --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/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 diff --git a/testsuite/tests/typecheck/should_run/T24411.hs b/testsuite/tests/typecheck/should_run/T24411.hs new file mode 100644 index 0000000000000000000000000000000000000000..367eb3dd3a83281ddaca03a637719f3e8efba9ce --- /dev/null +++ b/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 diff --git a/testsuite/tests/typecheck/should_run/T24411.stdout b/testsuite/tests/typecheck/should_run/T24411.stdout new file mode 100644 index 0000000000000000000000000000000000000000..6c72082ed05e8485020f5f3ee280d58c1c372c22 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T24411.stdout @@ -0,0 +1,2 @@ +(True,3) +(True,3) diff --git a/testsuite/tests/typecheck/should_run/all.T b/testsuite/tests/typecheck/should_run/all.T index 1d17069549278f775cd174b7155d60a9e73fb6e4..5d33c00809fc5fea5a3de5cf50c780f9571a6a70 100755 --- a/testsuite/tests/typecheck/should_run/all.T +++ b/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, [''])