[Git][ghc/ghc][wip/expand-do] PopSrcSpan should be followed by tcApp

Apoorv Ingle (@ani) gitlab at gitlab.haskell.org
Fri May 26 23:16:04 UTC 2023



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


Commits:
1ec58564 by Apoorv Ingle at 2023-05-26T18:15:54-05:00
PopSrcSpan should be followed by tcApp

- - - - -


9 changed files:

- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Match.hs
- testsuite/tests/rebindable/all.T
- + testsuite/tests/rebindable/pattern-fails
- testsuite/tests/rebindable/T18324.hs → testsuite/tests/typecheck/should_compile/T18324.hs
- testsuite/tests/typecheck/should_compile/all.T
- + testsuite/tests/typecheck/should_run/Typeable1


Changes:

=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -465,14 +465,10 @@ data XXExprGhcRn
   -- Should not presist post typechecking
   -- Note [Desugaring Do with HsExpansion] in GHC.Tc.Gen.Match
 
-
+-- | Wrap a located expression with a PopSrcExpr
 mkPopSrcSpanExpr :: LHsExpr GhcRn -> HsExpr GhcRn
 mkPopSrcSpanExpr a = XExpr (PopSrcSpan a)
 
--- | Generated location for PopSrcExpr
-genPopSrcSpanExpr :: LHsExpr GhcRn -> LHsExpr GhcRn
-genPopSrcSpanExpr = noLocA . mkPopSrcSpanExpr
-
 -- | Build a 'HsExpansion' out of an extension constructor,
 --   and the two components of the expansion: original and
 --   desugared expressions.
@@ -488,12 +484,6 @@ mkExpandedStmt
   -> HsExpr GhcRn           -- ^ suitably wrapped 'HsExpansion'
 mkExpandedStmt a b = XExpr (ExpandedStmt (HsExpanded a b))
 
-mkExpandedStmtLExpr
-  :: ExprLStmt GhcRn        -- ^ source statement
-  -> LHsExpr GhcRn          -- ^ expanded expression
-  -> LHsExpr GhcRn           -- ^ suitably wrapped 'HsExpansion'
-mkExpandedStmtLExpr a b = noLocA $ mkExpandedStmt a b
-
 data XXExprGhcTc
   = WrapExpr        -- Type and evidence application and abstractions
       {-# UNPACK #-} !(HsWrap HsExpr)


=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -858,7 +858,6 @@ warnUnusedBindValue :: LHsExpr GhcTc -> LHsExpr GhcTc -> Type -> DsM ()
 warnUnusedBindValue fun arg@(L loc _) arg_ty
   | Just (l, f) <- fish_var fun
   , f `hasKey` thenMClassOpKey -- it is a (>>)
-  , isGeneratedSrcSpan l -- it is compiler generated (>>)
   = do tracePm "warnUnusedBindValue" (vcat [ text "fun" <+> ppr fun
                                            , text "loc" <+> ppr l
                                            , text "locGen?" <+> ppr (isGeneratedSrcSpan l)
@@ -866,7 +865,9 @@ warnUnusedBindValue fun arg@(L loc _) arg_ty
                                            , text "arg" <+> ppr arg
                                            , text "arg_loc" <+> ppr loc
                                            ])
-       putSrcSpanDs (locA loc) $ warnDiscardedDoBindings arg arg_ty
+       when (isGeneratedSrcSpan l || isNoSrcSpan l -- it is compiler generated (>>)
+             ) $
+         putSrcSpanDs (locA loc) $ warnDiscardedDoBindings arg arg_ty
   where
     -- Retrieve the location info and the head of the application
     -- It is important that we /do not/ look through HsApp to avoid


=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -208,6 +208,7 @@ tcExpr e@(HsAppType {})          res_ty = tcApp e res_ty
 tcExpr e@(ExprWithTySig {})      res_ty = tcApp e res_ty
 tcExpr e@(HsRecSel {})           res_ty = tcApp e res_ty
 tcExpr e@(XExpr (ExpandedExpr {})) res_ty = tcApp e res_ty
+tcExpr (XExpr (PopSrcSpan e)) res_ty = popErrCtxt $ tcApp (unLoc e) res_ty
 
 tcExpr e@(HsOverLit _ lit) res_ty
   = do { mb_res <- tcShortCutLit lit res_ty
@@ -409,8 +410,6 @@ tcExpr (HsMultiIf _ alts) res_ty
        ; return (HsMultiIf res_ty alts') }
   where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
 
-tcExpr (XExpr (PopSrcSpan expr)) res_ty = popErrCtxt $ tcExpr (unLoc expr) res_ty
-
 tcExpr (XExpr (ExpandedStmt (HsExpanded stmt expr))) res_ty
   =  do { traceTc "tcDoStmts" (vcat [ text "stmt:" <+> ppr stmt
                                     , text "expr:" <+> ppr expr


=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1181,6 +1181,18 @@ checkArgCounts matchContext (MG { mg_alts = L _ (match1:matches) })
 *                                                                      *
 ************************************************************************
 -}
+
+
+-- | Generated location for PopSrcExpr
+genPopSrcSpanExpr :: LHsExpr GhcRn -> LHsExpr GhcRn
+genPopSrcSpanExpr = wrapGenSpan . mkPopSrcSpanExpr
+
+mkExpandedStmtLExpr
+  :: ExprLStmt GhcRn        -- ^ source statement
+  -> LHsExpr GhcRn          -- ^ expanded expression
+  -> LHsExpr GhcRn           -- ^ suitably wrapped 'HsExpansion'
+mkExpandedStmtLExpr a b = noLocA $ mkExpandedStmt a b
+
 expandDoStmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
 expandDoStmts = expand_do_stmts
 
@@ -1206,18 +1218,27 @@ expand_do_stmts _ [stmt@(L loc (LastStmt _ body _ ret_expr))]
   -- See `checkLastStmt` and `Syntax.Expr.StmtLR.LastStmt`
    | NoSyntaxExprRn <- ret_expr
    -- Last statement is just body if we are not in ListComp context. See Syntax.Expr.LastStmt
-   = return $ mkExpandedStmtLExpr stmt
-                              (genPopSrcSpanExpr body)
+   = return $ mkExpandedStmtLExpr stmt body
 
    | SyntaxExprRn ret <- ret_expr
    --
    --    ------------------------------------------------
    --               return e  ~~> return e
    -- to make T18324 work
-   = return $ genPopSrcSpanExpr $ L loc $ mkExpandedStmt stmt
-                                           (genPopSrcSpanExpr (L loc (genHsApp ret body)))
+   = return $ L loc (mkExpandedStmt stmt
+                        ((L loc (genHsApp ret body))))
 
 
+expand_do_stmts do_or_lc (stmt@(L loc (LetStmt _ bnds)) : lstmts) =
+--                      stmts ~~> stmts'
+--    ------------------------------------------------
+--       let x = e ; stmts ~~> let x = e in stmts'
+  do expand_stmts <- expand_do_stmts do_or_lc lstmts
+     return $ L loc $ mkExpandedStmt stmt
+                             (wrapGenSpan (HsLet noExtField
+                                                      noHsTok bnds
+                                                      noHsTok (genPopSrcSpanExpr expand_stmts)))
+
 expand_do_stmts do_or_lc (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
   | SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
   , fail_op              <- xbsrn_failOp xbsrn =
@@ -1229,33 +1250,22 @@ expand_do_stmts do_or_lc (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
 --       pat <- e ; stmts   ~~> (>>=) e f
       do expand_stmts <- expand_do_stmts do_or_lc lstmts
          expr <- mk_failable_lexpr_tcm pat expand_stmts fail_op
-         return $ (mkHsApps (wrapGenSpan bind_op)  -- (>>=)
-                    [ L loc (mkExpandedStmt stmt $ (genPopSrcSpanExpr e))
-                    , genPopSrcSpanExpr expr
-                    ])
+         return $ mkHsApps (wrapGenSpan bind_op)  -- (>>=)
+                    [ genPopSrcSpanExpr $ L loc (mkExpandedStmt stmt e)
+                    , expr
+                    ]
 
   | otherwise = pprPanic "expand do: shouldn't happen"  (text "stmt" <+> ppr  stmt)
 
-expand_do_stmts do_or_lc (stmt@(L _ (LetStmt _ bnds)) : lstmts) =
---                      stmts ~~> stmts'
---    ------------------------------------------------
---       let x = e ; stmts ~~> let x = e in stmts'
-  do expand_stmts <- expand_do_stmts do_or_lc lstmts
-     return $ mkExpandedStmtLExpr stmt
-                                 (wrapGenSpan (HsLet noExtField
-                                                      noHsTok bnds
-                                                      noHsTok (genPopSrcSpanExpr expand_stmts)))
-
-
 expand_do_stmts do_or_lc (stmt@(L loc (BodyStmt _ e (SyntaxExprRn f) _)) : lstmts) =
 -- See Note [BodyStmt]
 --              stmts ~~> stmts'
 --    ----------------------------------------------
 --      e ; stmts ~~> (>>) e stmts'
   do expand_stmts <- expand_do_stmts do_or_lc lstmts
-     return $ (genPopSrcSpanExpr $ (mkHsApps (wrapGenSpan f) -- (>>)
-                [ L loc (mkExpandedStmt stmt $ (genPopSrcSpanExpr e)) -- e
-                , genPopSrcSpanExpr expand_stmts ]))  -- stmts'
+     return $ (mkHsApps (wrapGenSpan f) -- (>>)
+                [ L loc (mkPopSrcSpanExpr $ L loc (mkExpandedStmt stmt e)) -- e
+                , genPopSrcSpanExpr expand_stmts ])  -- stmts'
 
 expand_do_stmts do_or_lc
   ((L do_loc (RecStmt { recS_stmts = L stmts_loc rec_stmts
@@ -1287,7 +1297,7 @@ expand_do_stmts do_or_lc
     all_ids = local_only_ids ++ later_ids   -- put local ids before return ids
 
     return_stmt  :: ExprLStmt GhcRn
-    return_stmt  = noLocA $ LastStmt noExtField
+    return_stmt  = wrapGenSpan $ LastStmt noExtField
                                      (mkBigLHsTup (map nlHsVar all_ids) noExtField)
                                      Nothing
                                      (SyntaxExprRn return_fun)
@@ -1300,7 +1310,7 @@ expand_do_stmts do_or_lc
                              -- LazyPat becuase we do not want to eagerly evaluate the pattern
                              -- and potentially loop forever
 
-expand_do_stmts do_or_lc (stmt@(L _ (ApplicativeStmt _ args mb_join)): lstmts) =
+expand_do_stmts do_or_lc ((L _ (ApplicativeStmt _ args mb_join)): lstmts) =
 -- See Note [Applicative BodyStmt]
 --
 --                  stmts ~~> stmts'
@@ -1318,30 +1328,29 @@ expand_do_stmts do_or_lc (stmt@(L _ (ApplicativeStmt _ args mb_join)): lstmts) =
      ; body_with_fails <- foldrM match_args expr' pats_can_fail
 
      -- builds (body <$> e1 <*> e2 ...)
-     ; let expand_ado_expr = genPopSrcSpanExpr $ foldl mk_apps body_with_fails (zip (map fst args) rhss)
+     ; let expand_ado_expr = foldl mk_apps body_with_fails (zip (map fst args) rhss)
 
      -- wrap the expanded expression with a `join` if needed
      ; case mb_join of
-         Nothing -> return $ mkExpandedStmtLExpr stmt expand_ado_expr
-         Just NoSyntaxExprRn -> return $ mkExpandedStmtLExpr stmt expand_ado_expr -- why can this happen?
+         Nothing -> return $ expand_ado_expr
+         Just NoSyntaxExprRn -> return $ expand_ado_expr -- why can this happen?
          Just (SyntaxExprRn join_op) ->
-           return $ mkExpandedStmtLExpr stmt
-                           ( mkHsApp (wrapGenSpan join_op) expand_ado_expr)
+           return $ mkHsApp (wrapGenSpan join_op) (genPopSrcSpanExpr $ expand_ado_expr)
      }
   where
     do_arg :: ApplicativeArg GhcRn -> TcM ((LPat GhcRn, FailOperator GhcRn), LHsExpr GhcRn)
     do_arg (ApplicativeArgOne mb_fail_op pat expr _) =
       return ((pat, mb_fail_op), expr)
     do_arg (ApplicativeArgMany _ stmts ret pat _) =
-      do { expr <- expand_do_stmts do_or_lc $ stmts ++ [noLocA $ mkLastStmt (wrapGenSpan ret)]
+      do { expr <- expand_do_stmts do_or_lc $ stmts ++ [wrapGenSpan $ mkLastStmt (wrapGenSpan ret)]
          ; return ((pat, Nothing), expr) }
 
     match_args :: (LPat GhcRn, FailOperator GhcRn) -> LHsExpr GhcRn -> TcM (LHsExpr GhcRn)
-    match_args (pat, fail_op) body = genPopSrcSpanExpr <$> mk_failable_lexpr_tcm pat body fail_op
+    match_args (pat, fail_op) body = mk_failable_lexpr_tcm pat body fail_op
 
     mk_apps l_expr (op, r_expr) =
       case op of
-        SyntaxExprRn op -> mkHsApps (wrapGenSpan op) [genPopSrcSpanExpr l_expr, genPopSrcSpanExpr r_expr]
+        SyntaxExprRn op -> mkHsApps (wrapGenSpan op) [l_expr, r_expr]
         NoSyntaxExprRn -> pprPanic "expand_do_stmts op:" (ppr op)
 
 expand_do_stmts _ stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr stmts)
@@ -1375,10 +1384,10 @@ mk_failable_lexpr_tcm pat lexpr fail_op =
 mk_fail_lexpr :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
 mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) =
   do  dflags <- getDynFlags
-      return $ noLocA (HsLam noExtField $ mkMatchGroup (Generated DoExpansion)    -- \
-                      (noLocA [ mkHsCaseAlt pat (genPopSrcSpanExpr lexpr)         --   pat -> expr
+      return $ wrapGenSpan (HsLam noExtField $ mkMatchGroup (Generated DoExpansion)    -- \
+                      (wrapGenSpan [ mkHsCaseAlt pat (genPopSrcSpanExpr lexpr)         --   pat -> expr
                               , mkHsCaseAlt nlWildPatName                         --   _   -> fail "fail pattern"
-                                (noLocA $ genHsApp fail_op (mk_fail_msg_expr dflags pat))
+                                (wrapGenSpan $ genHsApp fail_op (mk_fail_msg_expr dflags pat))
                               ]))
         where
           mk_fail_msg_expr :: DynFlags -> LPat GhcRn -> LHsExpr GhcRn


=====================================
testsuite/tests/rebindable/all.T
=====================================
@@ -42,8 +42,7 @@ test('T14670', expect_broken(14670), compile, [''])
 test('T19167', normal, compile, [''])
 test('T19918', normal, compile_and_run, [''])
 test('T20126', normal, compile_fail, [''])
-# Tests for desugaring do before typechecking
-test('T18324', normal, compile, [''])
+# Tests for expanding do before typechecking
 test('T23147', normal, compile, [''])
 test('pattern-fails', normal, compile_and_run, [''])
 test('simple-rec', normal, compile_and_run, [''])


=====================================
testsuite/tests/rebindable/pattern-fails
=====================================
Binary files /dev/null and b/testsuite/tests/rebindable/pattern-fails differ


=====================================
testsuite/tests/rebindable/T18324.hs → testsuite/tests/typecheck/should_compile/T18324.hs
=====================================


=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -875,3 +875,5 @@ test('T23171', normal, compile, [''])
 test('T23192', normal, compile, [''])
 test('T23199', normal, compile, [''])
 test('T23156', normal, compile, [''])
+# Tests for expanding do before typechecking (Impredicative)
+test('T18324', normal, compile, [''])


=====================================
testsuite/tests/typecheck/should_run/Typeable1
=====================================
Binary files /dev/null and b/testsuite/tests/typecheck/should_run/Typeable1 differ



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1ec5856450094529ea4e10cddefd645ac3902017
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/20230526/cb2fdea0/attachment-0001.html>


More information about the ghc-commits mailing list