Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: da6e83b0 by Apoorv Ingle at 2025-06-24T00:17:51-05:00 rename HsThingRn to SrcCodeOrigin - - - - - 7 changed files: - compiler/GHC/Hs.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Monad.hs Changes: ===================================== compiler/GHC/Hs.hs ===================================== @@ -150,16 +150,8 @@ data HsParsedModule = HsParsedModule { -- them change (#3589) } --- All the various located syntax things that sets the user context code in TcLclEnv --- data SrcCodeOrigin = --- ExprThing (HsExpr GhcRn) --- | PatThing (LPat GhcRn) --- | StmtThing (ExprLStmt GhcRn) HsDoFlavour - --- I'm a looking at a generated thing or am I a user written thing? -data SrcCodeCtxt = UserCode | GeneratedCode HsThingRn - --- mkSrcCodeOrigin :: HsThingRn -> SrcCodeOrigin --- mkSrcCodeOrigin (OrigExpr e) = ExprThing e --- mkSrcCodeOrigin (OrigPat p) = PatThing p --- mkSrcCodeOrigin (OrigStmt s f) = StmtThing e f +-- Used in TcLclCtxt.tcl_in_gen_code to mark if the current expression +-- is a user generated code or a compiler generated expansion of some user written code +data SrcCodeCtxt + = UserCode + | GeneratedCode SrcCodeOrigin ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -672,12 +672,13 @@ type instance XXExpr GhcTc = XXExprGhcTc -- | The different source constructs that we use to instantiate the "original" field -- in an `XXExprGhcRn original expansion` -- See Note [Handling overloaded and rebindable constructs] in `GHC.Rename.Expr` -data HsThingRn = OrigExpr (HsExpr GhcRn) -- ^ The source, user written, expression - | OrigStmt (ExprLStmt GhcRn) HsDoFlavour -- ^ which kind of do-block did this statement come from - | OrigPat (LPat GhcRn) -- ^ Used for failable patterns that trigger MonadFail constraints +data SrcCodeOrigin + = OrigExpr (HsExpr GhcRn) -- ^ The source, user written, expression + | OrigStmt (ExprLStmt GhcRn) HsDoFlavour -- ^ which kind of do-block did this statement come from + | OrigPat (LPat GhcRn) -- ^ Used for failable patterns that trigger MonadFail constraints data XXExprGhcRn - = ExpandedThingRn { xrn_orig :: HsThingRn -- The original source thing to be used for error messages + = ExpandedThingRn { xrn_orig :: SrcCodeOrigin -- The original source thing to be used for error messages , xrn_expanded :: HsExpr GhcRn -- The compiler generated expanded thing } @@ -718,7 +719,7 @@ data XXExprGhcTc | ExpandedThingTc -- See Note [Rebindable syntax and XXExprGhcRn] -- See Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do` - { xtc_orig :: HsThingRn -- The original user written thing + { xtc_orig :: SrcCodeOrigin -- The original user written thing , xtc_expanded :: HsExpr GhcTc } -- The expanded typechecked expression | ConLikeTc -- Result of typechecking a data-con @@ -752,10 +753,10 @@ mkExpandedExprTc :: HsExpr GhcRn -- ^ source expression -> HsExpr GhcTc -- ^ expanded typechecked expression -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn' -mkExpandedExprTc oExpr eExpr = XExpr (ExpandedThingTc (OrigExpr oExpr) eExpr) +mkExpandedExprTc oExpr eExpr = mkExpandedTc (OrigExpr oExpr) eExpr mkExpandedTc - :: HsThingRn -- ^ source do statement + :: SrcCodeOrigin -- ^ source, user written do statement/expression -> HsExpr GhcTc -- ^ expanded typechecked expression -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn' mkExpandedTc o e = XExpr (ExpandedThingTc o e) @@ -1020,7 +1021,7 @@ ppr_expr (XExpr x) = case ghcPass @p of GhcRn -> ppr x GhcTc -> ppr x -instance Outputable HsThingRn where +instance Outputable SrcCodeOrigin where ppr thing = case thing of OrigExpr x -> ppr_builder "<OrigExpr>:" x @@ -1087,7 +1088,7 @@ ppr_infix_expr_tc (HsTick {}) = Nothing ppr_infix_expr_tc (HsBinTick {}) = Nothing ppr_infix_expr_tc (HsRecSelTc f) = Just (pprInfixOcc f) -ppr_infix_hs_expansion :: HsThingRn -> Maybe SDoc +ppr_infix_hs_expansion :: SrcCodeOrigin -> Maybe SDoc ppr_infix_hs_expansion (OrigExpr e) = ppr_infix_expr e ppr_infix_hs_expansion _ = Nothing @@ -1195,7 +1196,7 @@ hsExprNeedsParens prec = go go_x_rn (PopErrCtxt a) = hsExprNeedsParens prec a go_x_rn (HsRecSelRn{}) = False - hsExpandedNeedsParens :: HsThingRn -> Bool + hsExpandedNeedsParens :: SrcCodeOrigin -> Bool hsExpandedNeedsParens (OrigExpr e) = hsExprNeedsParens prec e hsExpandedNeedsParens _ = False @@ -1248,7 +1249,7 @@ isAtomicHsExpr (XExpr x) go_x_rn (PopErrCtxt a) = isAtomicHsExpr a go_x_rn (HsRecSelRn{}) = True - isAtomicExpandedThingRn :: HsThingRn -> Bool + isAtomicExpandedThingRn :: SrcCodeOrigin -> Bool isAtomicExpandedThingRn (OrigExpr e) = isAtomicHsExpr e isAtomicExpandedThingRn _ = False ===================================== compiler/GHC/Hs/Instances.hs ===================================== @@ -591,7 +591,7 @@ deriving instance Eq (IE GhcTc) -- --------------------------------------------------------------------- -deriving instance Data HsThingRn +deriving instance Data SrcCodeOrigin deriving instance Data XXExprGhcRn deriving instance Data a => Data (WithUserRdr a) ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -611,7 +611,7 @@ addTickHsExpr (HsDo srcloc cxt (L l stmts)) ListComp -> Just $ BinBox QualBinBox _ -> Nothing --- addTickHsExpanded :: HsThingRn -> HsExpr GhcTc -> TM (HsExpr GhcTc) +-- addTickHsExpanded :: SrcCodeOrigin -> HsExpr GhcTc -> TM (HsExpr GhcTc) -- addTickHsExpanded o e = liftM (XExpr . ExpandedThingTc o) $ case o of -- -- We always want statements to get a tick, so we can step over each one. -- -- To avoid duplicates we blacklist SrcSpans we already inserted here. ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -5306,11 +5306,9 @@ pprArising :: CtLoc -> SDoc -- We've done special processing for TypeEq, KindEq, givens pprArising ct_loc | suppress_origin = empty - | in_generated_code = pprCtOrigin orig -- TODO ANI: maybe should go way | otherwise = pprCtOrigin orig where orig = ctLocOrigin ct_loc - in_generated_code = ctLocEnvInGeneratedCode (ctLocEnv ct_loc) suppress_origin | isGivenOrigin orig = True | otherwise = case orig of ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -763,18 +763,18 @@ exprCtOrigin (HsHole _) = Shouldn'tHappenOrigin "hole expression" exprCtOrigin (HsForAll {}) = Shouldn'tHappenOrigin "forall telescope" -- See Note [Types in terms] exprCtOrigin (HsQual {}) = Shouldn'tHappenOrigin "constraint context" -- See Note [Types in terms] exprCtOrigin (HsFunArr {}) = Shouldn'tHappenOrigin "function arrow" -- See Note [Types in terms] -exprCtOrigin (XExpr (ExpandedThingRn {})) = Shouldn'tHappenOrigin "XExpr ExpandedThingRn" +exprCtOrigin (XExpr (ExpandedThingRn o _)) = srcCodeOriginCtOrigin o exprCtOrigin (XExpr (PopErrCtxt e)) = exprCtOrigin e exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel (foExt f) -hsThingCtOrigin :: HsThingRn -> CtOrigin -hsThingCtOrigin (OrigExpr e) = exprCtOrigin e -hsThingCtOrigin (OrigStmt{}) = DoStmtOrigin -hsThingCtOrigin (OrigPat p) = DoPatOrigin p +srcCodeOriginCtOrigin :: SrcCodeOrigin -> CtOrigin +srcCodeOriginCtOrigin (OrigExpr e) = exprCtOrigin e +srcCodeOriginCtOrigin (OrigStmt{}) = DoStmtOrigin +srcCodeOriginCtOrigin (OrigPat p) = DoPatOrigin p srcCodeCtxtCtOrigin :: HsExpr GhcRn -> SrcCodeCtxt -> CtOrigin srcCodeCtxtCtOrigin e UserCode = exprCtOrigin e -srcCodeCtxtCtOrigin _ (GeneratedCode e) = hsThingCtOrigin e +srcCodeCtxtCtOrigin _ (GeneratedCode e) = srcCodeOriginCtOrigin e -- | Extract a suitable CtOrigin from a MatchGroup matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -990,9 +990,9 @@ getSrcCodeCtxt = getLclEnvSrcCodeCtxt <$> getLclEnv -- | Mark the inner computation as being done inside generated code. -- -- See Note [Error contexts in generated code] -setInGeneratedCode :: HsThingRn -> TcRn a -> TcRn a -setInGeneratedCode syntax_thing thing_inside = - updLclCtxt (setLclCtxtSrcCodeCtxt (GeneratedCode syntax_thing)) thing_inside +setInGeneratedCode :: SrcCodeOrigin -> TcRn a -> TcRn a +setInGeneratedCode scOrig thing_inside = + updLclCtxt (setLclCtxtSrcCodeCtxt (GeneratedCode scOrig)) thing_inside setSrcSpanA :: EpAnn ann -> TcRn a -> TcRn a setSrcSpanA l = setSrcSpan (locA l) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/da6e83b044e60a5a4bd8cf249582b217... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/da6e83b044e60a5a4bd8cf249582b217... You're receiving this email because of your account on gitlab.haskell.org.