[Git][ghc/ghc][wip/expand-do] disable expansion if applicative do is enabled

[Apoorv Ingle (@ani)]

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


Commits:
b70012d2 by Apoorv Ingle at 2023-06-22T11:52:13-05:00
disable expansion if applicative do is enabled

- - - - -


4 changed files:

- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Match.hs
- + compiler/GHC/Tc/Utils/.#Monad.hs


Changes:

=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -326,7 +326,8 @@ tcApp :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
 tcApp rn_expr exp_res_ty
   | (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps rn_expr
   = do { traceTc "tcApp {" $
-           vcat [ text "rn_fun:" <+> ppr rn_fun
+           vcat [ text "rn_expr:" <+> ppr rn_expr
+                , text "rn_fun:" <+> ppr rn_fun
                 , text "rn_args:" <+> ppr rn_args
                 , text "fun_ctxt:" <+> ppr fun_ctxt
                 , text "fun_ctxt loc" <+> ppr (appCtxtLoc fun_ctxt)


=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -89,6 +89,8 @@ import GHC.Utils.Outputable as Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
 
+import qualified GHC.LanguageExtensions as LangExt
+
 import Control.Monad
 import qualified Data.List.NonEmpty as NE
 
@@ -429,26 +431,34 @@ tcExpr (HsMultiIf _ alts) res_ty
        ; return (HsMultiIf res_ty alts') }
   where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
 
-tcExpr hsDo@(HsDo _ doFlav@(DoExpr{}) (L _ stmts)) res_ty
-  = do { expanded_expr <- expandDoStmts doFlav stmts
+tcExpr hsDo@(HsDo _ doFlav@(DoExpr{}) ss@(L _ stmts)) res_ty
+  = do { isApplicativeDo <- xoptM LangExt.ApplicativeDo
+       ; if isApplicativeDo
+         then tcDoStmts doFlav ss res_ty
+         else do { expanded_expr <- expandDoStmts doFlav stmts
                                                -- Do expansion on the fly
-       ; let expanded_do_expr = mkExpandedExpr hsDo (unLoc expanded_expr)
-       ; traceTc "tcDoStmts " (vcat [ text "hsDo:" <+> ppr hsDo
-                                    , text "expr:" <+> ppr expanded_expr
-                                    ])
-       ; -- addExprCtxt hsDo $
-         tcExpr expanded_do_expr res_ty
+                 ; let expanded_do_expr = mkExpandedExpr hsDo (unLoc expanded_expr)
+                 ; traceTc "tcDoStmts " (vcat [ text "hsDo:" <+> ppr hsDo
+                                              , text "expr:" <+> ppr expanded_expr
+                                              ])
+                 ; -- addExprCtxt hsDo $
+                   tcExpr expanded_do_expr res_ty
+                 }
        }
 
-tcExpr hsDo@(HsDo _ doFlav@(MDoExpr{}) (L _ stmts)) res_ty
-  = do { expanded_expr <- expandDoStmts doFlav stmts
+tcExpr hsDo@(HsDo _ doFlav@(MDoExpr{}) ss@(L _ stmts)) res_ty
+  = do { isApplicativeDo <- xoptM LangExt.ApplicativeDo
+       ; if isApplicativeDo
+         then tcDoStmts doFlav ss res_ty
+         else do { expanded_expr <- expandDoStmts doFlav stmts
                                                -- Do expansion on the fly
-       ; let expanded_do_expr = mkExpandedExpr hsDo (unLoc expanded_expr)
-       ; traceTc "tcDoStmts " (vcat [ text "hsDo:" <+> ppr hsDo
-                                    , text "expr:" <+> ppr expanded_expr
-                                    ])
-       ; -- addExprCtxt hsDo $
-         tcExpr expanded_do_expr res_ty
+                 ; let expanded_do_expr = mkExpandedExpr hsDo (unLoc expanded_expr)
+                 ; traceTc "tcDoStmts " (vcat [ text "hsDo:" <+> ppr hsDo
+                                              , text "expr:" <+> ppr expanded_expr
+                                              ])
+                 ; -- addExprCtxt hsDo $
+                   tcExpr expanded_do_expr res_ty
+                 }
        }
 
 tcExpr (HsDo _ do_or_lc stmts) res_ty


=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -320,11 +320,16 @@ tcDoStmts ListComp (L l stmts) res_ty
                             (mkCheckExpType elt_ty)
         ; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) }
 
-tcDoStmts (DoExpr _) ss _
-  = pprPanic "tcDoStmts DoExpr" (ppr ss)
+tcDoStmts doExpr@(DoExpr _) (L l stmts) res_ty
+  = do  { stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty
+        ; res_ty <- readExpType res_ty
+        ; return (HsDo res_ty doExpr (L l stmts')) }
+
 
-tcDoStmts (MDoExpr _) ss _
-  = pprPanic "tcDoStmts MDoExpr" (ppr ss)
+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 MonadComp (L l stmts) res_ty
   = do  { stmts' <- tcStmts (HsDoStmt MonadComp) tcMcStmt stmts res_ty


=====================================
compiler/GHC/Tc/Utils/.#Monad.hs
=====================================
@@ -0,0 +1 @@
+aningle at CS-M030.1455
\ No newline at end of file



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b70012d2eb5ed82af123a83664f79b5845c586d8
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/20230622/3e62db7f/attachment-0001.html>