[Git][ghc/ghc][wip/spj-apporv-Oct24] remove adhoc addthingCtxt and remove location from PopErrCtxt HsExprs

Apoorv Ingle (@ani) gitlab at gitlab.haskell.org
Tue Nov 26 08:35:23 UTC 2024



Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC


Commits:
3f5c3ae5 by Apoorv Ingle at 2024-11-26T00:34:32-08:00
remove adhoc addthingCtxt and remove location from PopErrCtxt HsExprs

- - - - -


6 changed files:

- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs


Changes:

=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -548,7 +548,7 @@ data XXExprGhcRn
                     }
 
   | PopErrCtxt                                     -- A hint for typechecker to pop
-    {-# UNPACK #-} !(LHsExpr GhcRn)                -- the top of the error context stack
+    {-# UNPACK #-} !(HsExpr GhcRn)                -- the top of the error context stack
                                                    -- Does not presist post renaming phase
                                                    -- See Part 3. of Note [Expanding HsDo with XXExprGhcRn]
                                                    -- in `GHC.Tc.Gen.Do`
@@ -945,7 +945,7 @@ ppr_infix_expr _ = Nothing
 
 ppr_infix_expr_rn :: XXExprGhcRn -> Maybe SDoc
 ppr_infix_expr_rn (ExpandedThingRn thing _) = ppr_infix_hs_expansion thing
-ppr_infix_expr_rn (PopErrCtxt (L _ a)) = ppr_infix_expr a
+ppr_infix_expr_rn (PopErrCtxt a)            = ppr_infix_expr a
 ppr_infix_expr_rn (HsRecSelRn f)            = Just (pprInfixOcc f)
 
 ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc
@@ -1062,7 +1062,7 @@ hsExprNeedsParens prec = go
 
     go_x_rn :: XXExprGhcRn -> Bool
     go_x_rn (ExpandedThingRn thing _ )   = hsExpandedNeedsParens thing
-    go_x_rn (PopErrCtxt (L _ a))         = hsExprNeedsParens prec a
+    go_x_rn (PopErrCtxt a)               = hsExprNeedsParens prec a
     go_x_rn (HsRecSelRn{})               = False
 
     hsExpandedNeedsParens :: HsThingRn -> Bool
@@ -1114,9 +1114,9 @@ isAtomicHsExpr (XExpr x)
     go_x_tc (HsRecSelTc{})            = True
 
     go_x_rn :: XXExprGhcRn -> Bool
-    go_x_rn (ExpandedThingRn thing _)    = isAtomicExpandedThingRn thing
-    go_x_rn (PopErrCtxt (L _ a))         = isAtomicHsExpr a
-    go_x_rn (HsRecSelRn{})            = True
+    go_x_rn (ExpandedThingRn thing _)   = isAtomicExpandedThingRn thing
+    go_x_rn (PopErrCtxt a)              = isAtomicHsExpr a
+    go_x_rn (HsRecSelRn{})              = True
 
     isAtomicExpandedThingRn :: HsThingRn -> Bool
     isAtomicExpandedThingRn (OrigExpr e) = isAtomicHsExpr e


=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1717,7 +1717,7 @@ repE e@(XExpr (ExpandedThingRn o x))
   | otherwise
   = notHandled (ThExpressionForm e)
 
-repE (XExpr (PopErrCtxt (L _ e))) = repE e
+repE (XExpr (PopErrCtxt e)) = repE e
 repE (XExpr (HsRecSelRn (FieldOcc _ (L _ x)))) = repE (HsVar noExtField (noLocA x))
 
 repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e)


=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -402,14 +402,14 @@ tcApp rn_expr exp_res_ty
        -- Step 2: Infer the type of `fun`, the head of the application
        ; (tc_fun, fun_sigma) <- tcInferAppHead fun
        ; let tc_head = (tc_fun, fun_ctxt)
-       ; traceTc "tcApp 1" (ppr rn_fun)
+
        -- Step 3: Instantiate the function type (taking a quick look at args)
        ; do_ql <- wantQuickLook rn_fun
        ; (inst_args, app_res_rho)
               <- setQLInstLevel do_ql $  -- See (TCAPP1) and (TCAPP2) in
                                          -- Note [tcApp: typechecking applications]
                  tcInstFun do_ql True tc_head fun_sigma rn_args
-       ; traceTc "tcApp 2" (ppr rn_fun)
+
        ; case do_ql of
             NoQL -> do { traceTc "tcApp:NoQL" (ppr rn_fun $$ ppr app_res_rho)
 
@@ -417,7 +417,7 @@ tcApp rn_expr exp_res_ty
                          -- See Note [Unify with expected type before typechecking arguments]
                        ; res_wrap <- checkResultTy rn_expr tc_head inst_args
                                                    app_res_rho exp_res_ty
-                       ; traceTc "tcApp valArgs" (ppr inst_args)
+
                          -- Step 4.2: typecheck the  arguments
                        ; tc_args <- tcValArgs NoQL inst_args
                          -- Step 4.3: wrap up


=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -95,7 +95,7 @@ expand_do_stmts doFlavour (stmt@(L _ (LetStmt _ bs)) : lstmts) =
 --    ------------------------------------------------
 --       let x = e ; stmts ~~> let x = e in stmts'xo
   do expand_stmts <- expand_do_stmts doFlavour lstmts
-     let expansion = genHsLet bs (genPopErrCtxtExpr expand_stmts)
+     let expansion = genHsLet bs (genPopErrCtxtExpr . unLoc $ expand_stmts)
      return $ mkExpandedStmtAt (noAnnSrcSpan generatedSrcSpan) stmt doFlavour expansion
 
 expand_do_stmts doFlavour (stmt@(L _loc (BindStmt xbsrn pat e)): lstmts)
@@ -108,7 +108,7 @@ expand_do_stmts doFlavour (stmt@(L _loc (BindStmt xbsrn pat e)): lstmts)
 --    -------------------------------------------------------
 --       pat <- e ; stmts   ~~> (>>=) e f
   = do expand_stmts <- expand_do_stmts doFlavour lstmts
-       failable_expr <- mk_failable_expr doFlavour pat (genPopErrCtxtExpr expand_stmts) fail_op
+       failable_expr <- mk_failable_expr doFlavour pat (genPopErrCtxtExpr . unLoc $ expand_stmts) fail_op
        let expansion = genHsExpApps bind_op  -- (>>=)
                        [ e
                        , failable_expr ]
@@ -126,7 +126,7 @@ expand_do_stmts doFlavour (stmt@(L _loc (BodyStmt _ e (SyntaxExprRn then_op) _))
   do expand_stmts_expr <- expand_do_stmts doFlavour lstmts
      let expansion = genHsExpApps then_op  -- (>>)
                      [ e
-                     , genPopErrCtxtExpr expand_stmts_expr ]
+                     , genPopErrCtxtExpr . unLoc $ expand_stmts_expr ]
      return $ mkExpandedStmtAt (noAnnSrcSpan generatedSrcSpan) stmt doFlavour expansion
 
 expand_do_stmts doFlavour
@@ -561,10 +561,10 @@ It stores the original statement (with location) and the expanded expression
 
 
 -- | Wrap a located expression with a `PopErrCtxt`
-mkPopErrCtxtExpr :: LHsExpr GhcRn -> HsExpr GhcRn
+mkPopErrCtxtExpr :: HsExpr GhcRn -> HsExpr GhcRn
 mkPopErrCtxtExpr a = XExpr (PopErrCtxt a)
 
-genPopErrCtxtExpr :: LHsExpr GhcRn -> LHsExpr GhcRn
+genPopErrCtxtExpr :: HsExpr GhcRn -> LHsExpr GhcRn
 genPopErrCtxtExpr a = wrapGenSpan $ mkPopErrCtxtExpr a
 
 -- | Build an expression using the extension constructor `XExpr`,


=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -709,35 +709,14 @@ tcExpr (SectionR {})       ty = pprPanic "tcExpr:SectionR"    (ppr ty)
 
 tcXExpr :: XXExprGhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
 
-tcXExpr (PopErrCtxt (L loc e)) res_ty
+tcXExpr (PopErrCtxt e) res_ty
   = popErrCtxt $ -- See Part 3 of Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`
-      setSrcSpanA loc $
       tcExpr e res_ty
 
 tcXExpr (ExpandedThingRn o@(OrigStmt stmt flav) e) res_ty
    = addThingCtxt o $
-      mkExpandedStmtTc stmt flav <$> tcExpr e res_ty
-{-
-tcXExpr xe@(ExpandedThingRn o e') res_ty
-  | OrigStmt ls@(L loc s) flav <- o
-  , HsLet x binds e <- e'
-  =  do { (binds', e') <-  setSrcSpanA loc $
-                           addStmtCtxt s flav $
-                           tcLocalBinds binds $
-                           tcMonoExprNC e res_ty -- NB: Do not call tcMonoExpr here as it adds
-                                                 -- a duplicate error context
-        ; return $ mkExpandedStmtTc ls flav (HsLet x binds' e')
-        }
-
-  | OrigStmt s@(L loc LastStmt{}) flav <- o
-  = setSrcSpanA loc $
-    addStmtCtxt (unLoc s) flav $
-    mkExpandedStmtTc s flav <$> tcApp e' res_ty
+       mkExpandedStmtTc stmt flav <$> tcExpr e res_ty
 
-  | OrigStmt ls@(L loc _) flav <- o
-  = setSrcSpanA loc $
-    mkExpandedStmtTc ls flav <$> tcApp (XExpr xe) res_ty
--}
 -- For record selection
 tcXExpr xe res_ty = tcApp (XExpr xe) res_ty
 


=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -555,10 +555,6 @@ tcInferAppHead_maybe fun
       _                         -> return Nothing
 
 addHeadCtxt :: AppCtxt -> TcM a -> TcM a
-addHeadCtxt (VAExpansion (OrigStmt (L loc stmt) flav) _ _) thing_inside =
-  do setSrcSpanA loc $
-       addStmtCtxt stmt flav
-         thing_inside
 addHeadCtxt fun_ctxt thing_inside
   | not (isGoodSrcSpan fun_loc)   -- noSrcSpan => no arguments
   = thing_inside                  -- => context is already set
@@ -1255,15 +1251,12 @@ mis-match in the number of value arguments.
 ********************************************************************* -}
 
 addThingCtxt :: HsThingRn -> TcRn a -> TcRn a
--- addThingCtxt (OrigExpr e) thing_inside = addExprCtxt e thing_inside
+
 addThingCtxt (OrigStmt (L loc stmt) flav) thing_inside = do
-  gen <- inGeneratedCode
-  if gen
-    then setSrcSpanA loc $ addStmtCtxt stmt flav $ setInGeneratedCode $ thing_inside
-         -- If we are in generated code, we need to set the error context at the correct
-         -- location and then switch context back into generated code to do the thing_inside
-         -- See Note [Rebindable syntax and XXExprGhcRn]
-    else addStmtCtxt stmt flav $ thing_inside
+  setSrcSpanA loc $
+    addStmtCtxt stmt flav $
+    thing_inside
+-- addThingCtxt (OrigExpr e) thing_inside = addExprCtxt e thing_inside
 addThingCtxt _ thing_inside = thing_inside
 
 addStmtCtxt :: ExprStmt GhcRn -> HsDoFlavour -> TcRn a -> TcRn a



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3f5c3ae5dba3f20abd7160a1986f478337caec42
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/20241126/2ab41a50/attachment-0001.html>


More information about the ghc-commits mailing list