[Git][ghc/ghc][wip/expansions-appdo] some pesky appdo testcases remain

[Apoorv Ingle (@ani)]

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


Commits:
7c2ea776 by Apoorv Ingle at 2024-05-06T02:53:03-05:00
some pesky appdo testcases remain

- - - - -


4 changed files:

- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- testsuite/tests/ado/ado002.stderr


Changes:

=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -203,6 +203,7 @@ expand_do_stmts doFlavour ((L _ (ApplicativeStmt _ args mb_join)): lstmts) =
 -- args are [(<$>, e1), (<*>, e2), .., ]
   do { expr' <- expand_do_stmts doFlavour lstmts
      -- extracts pats and arg bodies (rhss) from args
+
      ; (pats_can_fail, rhss) <- unzip <$> mapM (do_arg . snd) args
 
      -- add blocks for failable patterns
@@ -231,7 +232,7 @@ expand_do_stmts doFlavour ((L _ (ApplicativeStmt _ args mb_join)): lstmts) =
             , is_body_stmt    = is_body_stmt
             }) =
       do let xx_stmt = mkExpandedStmtAt rhs_loc stmt doFlavour rhs
-         traceTc "do_arg" (text "OneArg" <+> ppr xx_stmt)
+         traceTc "do_arg" (text "OneArg" <+> vcat [ppr pat, ppr xx_stmt])
          return ((pat, mb_fail_op)
                 , xx_stmt)
         where stmt = if is_body_stmt
@@ -239,7 +240,7 @@ expand_do_stmts doFlavour ((L _ (ApplicativeStmt _ args mb_join)): lstmts) =
                       else (L rhs_loc (BindStmt xbsn pat (L rhs_loc rhs)))
     do_arg (ApplicativeArgMany _ stmts ret@(L ret_loc _) pat ctxt) =
       do { expr <- expand_do_stmts ctxt $ stmts ++ [L ret_loc $ mkLastStmt ret]
-         ; traceTc "do_arg" (text "ManyArg" <+> ppr expr)
+         ; traceTc "do_arg" (text "ManyArg" <+> vcat [ppr pat, ppr expr])
          ; return ((pat, Nothing)
                   , expr) }
 
@@ -252,12 +253,7 @@ expand_do_stmts doFlavour ((L _ (ApplicativeStmt _ args mb_join)): lstmts) =
     mk_apps :: LHsExpr GhcRn -> (SyntaxExprRn, LHsExpr GhcRn) -> LHsExpr GhcRn
     mk_apps l_expr (op, r_expr) =
       case op of
-        SyntaxExprRn op -> case r_expr of
-                             L loc (XExpr (ExpandedThingRn (OrigStmt (L l s) flav) e))
-                               -> wrapGenSpan $ XExpr (ExpandedThingRn (OrigStmt (L l s) flav)
-                                                  (genHsExpApps op [ l_expr
-                                                                   , L loc e ]))
-                             _  -> wrapGenSpan $ genHsExpApps op [ l_expr, r_expr ]
+        SyntaxExprRn op -> wrapGenSpan $ genHsExpApps op [ l_expr, r_expr ]
         NoSyntaxExprRn -> pprPanic "expand_do_stmts applicative op:" (ppr op)
 
     xbsn :: XBindStmtRn


=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -90,6 +90,7 @@ import GHC.Utils.Panic
 
 import Control.Monad
 import qualified Data.List.NonEmpty as NE
+import qualified GHC.LanguageExtensions as LangExt
 
 {-
 ************************************************************************
@@ -728,9 +729,14 @@ tcXExpr xe@(ExpandedThingRn o e') res_ty
                 -- `e` is the last statement's body expression
                 -- and not a HsApp of a generated (>>) or (>>=)
                 -- This improves error messages e.g. tests: DoExpansion1, DoExpansion2, DoExpansion3
-  | OrigStmt ls@(L loc _) flav <- o
+  | OrigStmt ls@(L loc s) flav <- o
   = setSrcSpanA loc $
-       mkExpandedStmtTc ls flav <$> tcApp (XExpr xe) res_ty
+    do appDo <- xoptM LangExt.ApplicativeDo
+       if appDo
+         then addStmtCtxt s flav $
+              mkExpandedStmtTc ls flav <$> tcExpr e' res_ty
+
+         else mkExpandedStmtTc ls flav <$> tcApp (XExpr xe) res_ty
 
 tcXExpr xe res_ty = tcApp (XExpr xe) res_ty
 


=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -243,7 +243,8 @@ appCtxtLoc (VACall _ _ l)    = l
 
 insideExpansion :: AppCtxt -> Bool
 insideExpansion (VAExpansion {}) = True
-insideExpansion (VACall {})      = False -- but what if the VACall has a generated context?
+insideExpansion (VACall _ _ src)   = isGeneratedSrcSpan src
+-- insideExpansion (VACall {})      = False -- but what if the VACall has a generated context?
 
 instance Outputable AppCtxt where
   ppr (VAExpansion e l _) = text "VAExpansion" <+> ppr e <+> ppr l


=====================================
testsuite/tests/ado/ado002.stderr
=====================================
@@ -96,4 +96,3 @@ ado002.hs:23:9: error: [GHC-83865]
     • The function ‘getChar’ is applied to one visible argument,
         but its type ‘IO Char’ has none
       In a stmt of a 'do' block: x5 <- getChar x4
-      In a stmt of a 'do' block: x4 <- getChar



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7c2ea7768df91c5374d8e08d0a408d82c079682a
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/20240506/f6f28966/attachment-0001.html>