[Git][ghc/ghc][wip/ani/kill-SrcCodeOrigin] ErrCtxtMsg to CtOrigin

1 Mar 2026

Apoorv Ingle pushed to branch wip/ani/kill-SrcCodeOrigin at Glasgow Haskell Compiler / GHC


Commits:
ec201fd2 by Apoorv Ingle at 2026-03-01T14:24:33-06:00
ErrCtxtMsg to CtOrigin

- - - - -


10 changed files:

- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Types/ErrCtxt.hs
- compiler/GHC/Tc/Types/LclEnv.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Tc/Utils/Monad.hs


Changes:

=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -640,11 +640,12 @@ deriving instance Eq (IE GhcRn)
 deriving instance Eq (IE GhcTc)
 
 -- ---------------------------------------------------------------------
-
+-- TODO: I think we still need instances for StmtCtxt, ExprCtxt and PatCtxt ctors of ErrCtxtMsg
 instance Data ErrCtxtMsg where
   gunfold _ _ _ = error "no gunfold for ErrCtxtMsg"
   gfoldl _ _ _ = error "no goldl for ErrCtxtMsg"
-
+  toConstr = error "no toConstr for ErrCtxtMsg"
+  dataTypeOf = error "no dataTypeOf for ErrCtxtMsg"
 
 deriving instance Data XXExprGhcRn
 


=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -20,6 +20,7 @@ import GHC.Hs
 
 import GHC.Tc.Gen.Head
 import GHC.Tc.Errors.Types
+import GHC.Tc.Errors.Ppr
 import GHC.Tc.Utils.Monad
 import GHC.Tc.Utils.Unify
 import GHC.Tc.Utils.Instantiate
@@ -275,7 +276,7 @@ tcApp works like this:
 2. Use tcInferAppHead to infer the type of the function,
      as an (uninstantiated) TcSigmaType
    There are special cases for
-     HsVar, HsRecSel, and ExprWithTySig
+     HsVar, HsRecSel, and ExprWithTySig and XExpr
    Otherwise, delegate back to tcExpr, which
      infers an (instantiated) TcRhoType
 
@@ -2050,6 +2051,7 @@ mk_origin fun_lspan_arg rn_fun_arg rn_fun
   = return $ exprCtOrigin rn_fun_arg
   | otherwise
   = do { code_orig <- getSrcCodeOrigin
+       ; traceTc "mk_origin" (case (pprErrCtxtMsg <$> code_orig) of { Just e -> e; _ -> text "Nothing"})
        ; return $ srcCodeOriginCtOrigin rn_fun code_orig
        }
 


=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -213,7 +213,7 @@ mk_fail_block doFlav pat stmt e (Just (SyntaxExprRn fail_op)) =
 
           fail_op_expr :: DynFlags -> LPat GhcRn -> HsExpr GhcRn -> LHsExpr GhcRn
           fail_op_expr dflags pat@(L pat_lspan _) fail_op
-            = L pat_lspan $ mkExpandedPatRn doFlav (unLoc pat) stmt $ genHsApp fail_op (mk_fail_msg_expr dflags pat)
+            = L pat_lspan $ mkExpandedPatRn doFlav pat stmt $ genHsApp fail_op (mk_fail_msg_expr dflags pat)
 
           mk_fail_msg_expr :: DynFlags -> LPat GhcRn -> LHsExpr GhcRn
           mk_fail_msg_expr dflags pat
@@ -481,7 +481,7 @@ It stores the original statement (with location) and the expanded expression
 -}
 
 
-mkExpandedPatRn :: HsDoFlavour -> Pat GhcRn -> ExprLStmt GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
+mkExpandedPatRn :: HsDoFlavour -> LPat GhcRn -> ExprLStmt GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
 mkExpandedPatRn flav pat stmt e = XExpr $ ExpandedThingRn
                                    { xrn_orig = StmtErrCtxtPat (HsDoStmt flav) stmt pat
                                    , xrn_expanded = e}


=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -430,6 +430,7 @@ tcInferAppHead :: (HsExpr GhcRn, SrcSpan)
 --   * A bare identifier (just look it up)
 --     This case also covers a record selector HsRecSel
 --   * An expression with a type signature (e :: ty)
+--   * An XExpr where 'f' is actually an expanded out expression
 -- See Note [Application chains and heads] in GHC.Tc.Gen.App
 --
 -- Note that [] and (,,) are both HsVar:
@@ -452,6 +453,8 @@ tcInferAppHead_maybe :: HsExpr GhcRn
                      -> TcM (Maybe (HsExpr GhcTc, DeepSubsumptionFlag, TcSigmaType))
 -- See Note [Application chains and heads] in GHC.Tc.Gen.App
 -- Returns Nothing for a complicated head
+-- XExpr's although complicated needs to be looked through, useful for QL things when
+-- the argument is an XExpr
 tcInferAppHead_maybe fun = case fun of
       HsVar _ nm                  -> Just <$> with_get_ds (tcInferId nm)
       ExprWithTySig _ e hs_ty     -> Just <$> with_get_ds (tcExprWithSig e hs_ty)


=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -1,5 +1,4 @@
 {-# LANGUAGE PatternSynonyms            #-}
-
 {-
 (c) The University of Glasgow 2006-2012
 (c) The GRASP Project, Glasgow University, 1992-2002


=====================================
compiler/GHC/Tc/Types/ErrCtxt.hs
=====================================
@@ -340,7 +340,7 @@ data ErrCtxtMsg
   | DoStmtErrCtxt !HsStmtContextRn !(ExprLStmt GhcRn)
 
   -- | In patten of the do statement. (c.f. MonadFailErrors)
-  | StmtErrCtxtPat !HsStmtContextRn !(ExprLStmt GhcRn) (Pat GhcRn)
+  | StmtErrCtxtPat !HsStmtContextRn !(ExprLStmt GhcRn) (LPat GhcRn)
 
   -- | In an rebindable syntax expression.
   | SyntaxNameCtxt !(HsExpr GhcRn) !CtOrigin !TcType !SrcSpan


=====================================
compiler/GHC/Tc/Types/LclEnv.hs
=====================================
@@ -211,11 +211,12 @@ setLclEnvSrcCodeOrigin ec = modifyLclCtxt (setLclCtxtSrcCodeOrigin ec)
 -- See Note [ErrCtxtStack Manipulation]
 setLclCtxtSrcCodeOrigin :: ErrCtxt -> TcLclCtxt -> TcLclCtxt
 setLclCtxtSrcCodeOrigin ec lclCtxt
-  | ecs@(MkErrCtxt ExpansionCodeCtxt _ : _) <- tcl_err_ctxt lclCtxt
-  , MkErrCtxt ExpansionCodeCtxt ExprCtxt{} <- ec
-  = lclCtxt { tcl_err_ctxt =  ec : ecs }
-  | MkErrCtxt ExpansionCodeCtxt _ : ecs <- tcl_err_ctxt lclCtxt
-  , MkErrCtxt ExpansionCodeCtxt _ <- ec
+  -- | ecs@(MkErrCtxt ExpansionCodeCtxt _ : _) <- tcl_err_ctxt lclCtxt
+  -- , MkErrCtxt ExpansionCodeCtxt ExprCtxt{} <- ec
+  -- = lclCtxt { tcl_err_ctxt =  ec : ecs }
+  -- never stack 2 statement error contexts on top of each other
+  | MkErrCtxt _ DoStmtErrCtxt{} : ecs <- tcl_err_ctxt lclCtxt
+  , MkErrCtxt _ DoStmtErrCtxt{} <- ec
   = lclCtxt { tcl_err_ctxt =  ec : ecs }
   | otherwise
   = lclCtxt { tcl_err_ctxt = ec : tcl_err_ctxt lclCtxt }


=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -455,7 +455,7 @@ data CtOrigin
       -- `ty1` to `ty2`.
 
   | DefaultOrigin       -- Typechecking a default decl
-  | DoStmtOrigin            -- Arising from a do expression
+  | DoStmtOrigin            -- Arising from a do statement
   | DoPatOrigin (LPat GhcRn) -- Arising from a failable pattern in
                              -- a do expression
   | MCompOrigin         -- Arising from a monad comprehension
@@ -690,12 +690,22 @@ exprCtOrigin e@(HsIf {})          = ExpansionOrigin (ExprCtxt e)
 exprCtOrigin e@(HsProjection _ _) = ExpansionOrigin (ExprCtxt e)
 exprCtOrigin e@(RecordUpd{})      = ExpansionOrigin (ExprCtxt e)
 exprCtOrigin e@(HsGetField{})     = ExpansionOrigin (ExprCtxt e)
-exprCtOrigin (XExpr (ExpandedThingRn o _)) = ExpansionOrigin o
+exprCtOrigin (XExpr (ExpandedThingRn o _)) = errCtxtCtOrigin o
 exprCtOrigin (XExpr (HsRecSelRn f))  = OccurrenceOfRecSel $ L (getLoc $ foLabel f) (foExt f)
 
 srcCodeOriginCtOrigin :: HsExpr GhcRn -> Maybe ErrCtxtMsg -> CtOrigin
 srcCodeOriginCtOrigin e Nothing = exprCtOrigin e
-srcCodeOriginCtOrigin _ (Just o) = ExpansionOrigin o
+srcCodeOriginCtOrigin _ (Just o) = errCtxtCtOrigin o
+
+
+errCtxtCtOrigin :: ErrCtxtMsg -> CtOrigin
+errCtxtCtOrigin (ExprCtxt e) = exprCtOrigin e
+errCtxtCtOrigin (FunAppCtxt (FunAppCtxtExpr _ e) _) = exprCtOrigin e
+errCtxtCtOrigin (StmtErrCtxt{}) = DoStmtOrigin
+errCtxtCtOrigin (DoStmtErrCtxt{}) = DoStmtOrigin
+errCtxtCtOrigin (StmtErrCtxtPat _ _ p) = DoPatOrigin p
+errCtxtCtOrigin _ = Shouldn'tHappenOrigin "errCtxtCtOrigin"
+
 
 -- | Extract a suitable CtOrigin from a MatchGroup
 matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin
@@ -731,6 +741,8 @@ pprCtOrigin (ExpansionOrigin o)
       what = case o of
         StmtErrCtxt{} ->
           text "a do statement"
+        DoStmtErrCtxt{} ->
+          text "a do statement"
         StmtErrCtxtPat _ _ p ->
           text "a do statement" $$
              text "with the failable pattern" <+> quotes (ppr p)
@@ -744,6 +756,7 @@ pprCtOrigin (ExpansionOrigin o)
         ExprCtxt (HsProjection _ p) -> text "the record selector" <+>
              quotes (ppr ((FieldLabelStrings $ fmap noLocA p)))
         ExprCtxt e -> text "the expression" <+> (ppr e)
+        RecordUpdCtxt{} -> text "a record update"
         _ -> text "shouldn't happen ExpansionOrigin pprCtOrigin"
 
 pprCtOrigin (GivenSCOrigin sk d blk)


=====================================
compiler/GHC/Tc/Utils/Instantiate.hs
=====================================
@@ -52,7 +52,6 @@ import GHC.Core.FamInstEnv
 import GHC.Core ( isOrphan ) -- For the Coercion constructor
 import GHC.Core.Type
 import GHC.Core.TyCo.Ppr ( debugPprType )
-import GHC.Core.TyCo.Tidy ( tidyType )
 import GHC.Core.Class( Class )
 import GHC.Core.Coercion.Axiom
 


=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -1330,27 +1330,28 @@ addLExprCtxt lspan e thing_inside
   = setSrcSpan lspan $ add_expr_ctxt e thing_inside
   | otherwise   -- no op in generated code
   = thing_inside
+    where
+       add_expr_ctxt :: HsExpr GhcRn -> TcRn a -> TcRn a
+       add_expr_ctxt e thing_inside
+         = case e of
+             -- The HsHole special case addresses situations like
+             --    f x = _
+             -- when we don't want to say "In the expression: _",
+             -- because it is mentioned in the error message itself
+             HsHole{} -> thing_inside
+
+             -- There is a special case for expressions with signatures to avoid having too verbose
+             -- error context. So here we flip the ErrCtxt state to expanded if the expression is expanded.
+             -- c.f. RecordDotSyntaxFail9
+             ExprWithTySig _ (L _ e') _
+               | XExpr (ExpandedThingRn o _) <- e' -> addExpansionErrCtxt o thing_inside
+
+             -- Flip error ctxt into expansion mode
+             XExpr (ExpandedThingRn o _) -> addExpansionErrCtxt o thing_inside
+
+             _ -> addErrCtxt (ExprCtxt e) thing_inside
+

--- | !Caution!: Users should not call add_expr_ctxt, they ought to use addLExprCtxt
-add_expr_ctxt :: HsExpr GhcRn -> TcRn a -> TcRn a
-add_expr_ctxt e thing_inside
-  = case e of
-      HsHole{} -> thing_inside
-   -- The HsHole special case addresses situations like
-   --    f x = _
-   -- when we don't want to say "In the expression: _",
-   -- because it is mentioned in the error message itself
-
-      ExprWithTySig _ (L _ e') _
-        | XExpr (ExpandedThingRn o _) <- e' -> addExpansionErrCtxt o thing_inside
-   -- There is a special case for expressions with signatures to avoid having too verbose
-   -- error context. So here we flip the ErrCtxt state to expanded if the expression is expanded.
-   -- c.f. RecordDotSyntaxFail9
-
-      XExpr (ExpandedThingRn o _) -> addExpansionErrCtxt o thing_inside
-   -- Flip error ctxt into expansion mode
-
-      _ -> addErrCtxt (ExprCtxt e) thing_inside
 
 
 getErrCtxt :: TcM [ErrCtxt]



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ec201fd2f14a2ff83fcca19c2e51ee96...
You're receiving this email because of your account on gitlab.haskell.org.

    

Apoorv Ingle (＠ani)

tags

participants (1)