[Git][ghc/ghc][wip/expansions-appdo] 2 commits: enrich error messages with stmt info for visibile type patterns in app-do

[Apoorv Ingle (@ani)]

Apoorv Ingle pushed to branch wip/expansions-appdo at Glasgow Haskell Compiler / GHC


Commits:
9076c79a by Apoorv Ingle at 2024-05-27T10:44:03-05:00
enrich error messages with stmt info for visibile type patterns in app-do

- - - - -
67c1f299 by Apoorv Ingle at 2024-05-27T14:33:27-05:00
accept break029

- - - - -


6 changed files:

- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Expr.hs
- − testsuite/tests/ado/expand-ado1.hs
- testsuite/tests/ghci.debugger/scripts/break029.stdout


Changes:

=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -536,7 +536,7 @@ mkExpandedPatRn
   -> Maybe  (HsDoFlavour, ExprLStmt GhcRn) -- ^ pattern statement origin
   -> HsExpr GhcRn             -- ^ expanded expression
   -> HsExpr GhcRn             -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedPatRn oPat stmt eExpr = XExpr (ExpandedThingRn (OrigPat oPat stmt) eExpr TcExpr)
+mkExpandedPatRn oPat mb_stmt_info eExpr = XExpr (ExpandedThingRn (OrigPat oPat mb_stmt_info) eExpr TcExpr)
 
 -- | Build an expression using the extension constructor `XExpr`,
 --   and the two components of the expansion: original do stmt and


=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -723,7 +723,9 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
     -- Rule IARG from Fig 4 of the QL paper:
     go1 delta acc so_far fun_ty
         (eva@(EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt }) : rest_args)
-      = do { let herald = ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg)
+      = do { let herald = case fun_ctxt of
+                             VAExpansion (OrigStmt{}) _ _ -> ExpectedFunTySyntaxOp DoOrigin tc_fun
+                             _ ->  ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg)
            ; (wrap, arg_ty, res_ty) <-
                 -- NB: matchActualFunTy does the rep-poly check.
                 -- For example, suppose we have f :: forall r (a::TYPE r). a -> Int


=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -94,7 +94,7 @@ expand_do_stmts flav [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_expr))]
    --               return e  ~~> return e
    -- to make T18324 work
    = do let expansion = genHsApp ret (L body_loc body)
-        return $ mkExpandedStmtPopAt loc stmt flav TcApp expansion
+        return $ mkExpandedStmtPopAt loc stmt flav TcExpr expansion
 
 expand_do_stmts doFlavour (stmt@(L loc (LetStmt _ bs)) : lstmts) =
 -- See  Note [Expanding HsDo with XXExprGhcRn] Equation (3) below
@@ -103,7 +103,7 @@ expand_do_stmts doFlavour (stmt@(L loc (LetStmt _ bs)) : lstmts) =
 --       let x = e ; stmts ~~> let x = e in stmts'
   do expand_stmts <- expand_do_stmts doFlavour lstmts
      let expansion = genHsLet bs expand_stmts
-     return $ mkExpandedStmtPopAt loc stmt doFlavour TcApp expansion
+     return $ mkExpandedStmtPopAt loc stmt doFlavour TcExpr expansion
 
 expand_do_stmts doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
   | SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
@@ -272,7 +272,11 @@ mk_failable_expr doFlav mb_stmt_info lpat@(L loc pat) expr fail_op =
                                           -- the pattern is irrefutable
        then case pat of
               (WildPat{}) -> return $ genHsLamDoExp doFlav [L noSrcSpanA pat] expr
-              _ -> return $ genHsLamDoExp doFlav [lpat] expr
+              _ -> return $ case mb_stmt_info of
+                              Nothing -> genHsLamDoExp doFlav [lpat] expr
+                              Just (f, s) -> wrapGenSpan (mkExpandedStmt s f TcExpr
+                                                           (unLoc $ (genHsLamDoExp f [lpat]
+                                                                      $ wrapGenSpan (mkPopErrCtxtExpr expr))))
        else L loc <$> mk_fail_block doFlav mb_stmt_info lpat expr fail_op
      }
 


=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -90,7 +90,6 @@ import GHC.Utils.Panic
 
 import Control.Monad
 import qualified Data.List.NonEmpty as NE
-import qualified GHC.LanguageExtensions as LangExt
 
 {-
 ************************************************************************


=====================================
testsuite/tests/ado/expand-ado1.hs deleted
=====================================
@@ -1,32 +0,0 @@
-{-# LANGUAGE ApplicativeDo,ScopedTypeVariables #-}
-module Test where
-
--- Test that type errors aren't affected by ApplicativeDo
-rrrr1 :: IO Int
-rrrr1 = do
-  x <- getChar
-  y <- getChar 'a' -- type error
-  return (x,y)
-
-
-
-rrrr2 :: IO Int
-rrrr2 = do
-  x <- getChar
-  y <- getChar 'a' -- type error
-  print (x,y)
-
--- g :: IO (Int,Int)
--- g = do
---   x <- getChar
---   y <- getChar
---   return (y,x)
-
--- h :: IO (Int,Int)
--- h = do
---   x1 <- getChar
---   x2 <- getChar
---   x3 <- const (return ()) x1
---   x4 <- getChar
---   x5 <- getChar x4
---   return (x2,x4)


=====================================
testsuite/tests/ghci.debugger/scripts/break029.stdout
=====================================
@@ -1,10 +1,10 @@
 Stopped in Main.f, break029.hs:(4,7)-(6,16)
 _result :: IO Int = _
 x :: Int = 3
-Stopped in Main.f, break029.hs:5:8-21
-_result :: IO Int = _
-x :: Int = 3
 Stopped in Main.f, break029.hs:6:3-16
 _result :: Int = _
 y :: Int = _
+Stopped in Main.f, break029.hs:6:11-15
+_result :: Int = _
+y :: Int = _
 4



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8e7fd9c08c8503094e4e72885315074899cca979...67c1f2990b0edbda1bae36018740b01f29a65974

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8e7fd9c08c8503094e4e72885315074899cca979...67c1f2990b0edbda1bae36018740b01f29a65974
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/20240527/a1a3567b/attachment-0001.html>