Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 11b5f135 by Apoorv Ingle at 2025-07-21T10:16:02-05:00 remove locations from orig payload - - - - - 4 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/Do.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -674,11 +674,11 @@ type instance XXExpr GhcTc = XXExprGhcTc -- See Note [Handling overloaded and rebindable constructs] in `GHC.Rename.Expr` 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 + | OrigStmt (ExprStmt GhcRn) HsDoFlavour -- ^ which kind of do-block did this statement come from + | OrigPat (Pat GhcRn) -- ^ Used for failable patterns that trigger MonadFail constraints data XXExprGhcRn - = ExpandedThingRn { xrn_orig :: SrcCodeOrigin -- 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 } @@ -706,7 +706,7 @@ mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn { xrn_orig = OrigExpr oExpr -- and the two components of the expansion: original do stmt and -- expanded expression mkExpandedStmt - :: ExprLStmt GhcRn -- ^ source statement + :: ExprStmt GhcRn -- ^ source statement -> HsDoFlavour -- ^ source statement do flavour -> HsExpr GhcRn -- ^ expanded expression -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn' ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -659,23 +659,26 @@ addTickHsExpr (HsDo srcloc cxt (L l stmts)) _ -> Nothing 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. - OrigStmt (L pos _) _ -> do_tick_black pos - _ -> skip - where - skip = addTickHsExpr e - do_tick_black pos = do - d <- getDensity - case d of - TickForCoverage -> tick_it_black pos - TickForBreakPoints -> tick_it_black pos - _ -> skip - tick_it_black pos = - unLoc <$> allocTickBox (ExpBox False) False False (locA pos) - (withBlackListed (locA pos) $ - addTickHsExpr e) +addTickHsExpanded o e = liftM (XExpr . ExpandedThingTc o) $ addTickHsExpr e + + + -- 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. + -- OrigStmt (L pos _) _ -> do_tick_black pos + -- _ -> skip + -- where + -- skip = addTickHsExpr e + -- do_tick_black pos = do + -- d <- getDensity + -- case d of + -- TickForCoverage -> tick_it_black pos + -- TickForBreakPoints -> tick_it_black pos + -- _ -> skip + -- tick_it_black pos = + -- unLoc <$> allocTickBox (ExpBox False) False False (locA pos) + -- (withBlackListed (locA pos) $ + -- addTickHsExpr e) addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc) addTickTupArg (Present x e) = do { e' <- addTickLHsExpr e ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -7239,7 +7239,7 @@ pprTyConInstFlavour pprErrCtxtMsg :: ErrCtxtMsg -> SDoc pprErrCtxtMsg = \case ExprCtxt expr - | XExpr (ExpandedThingRn (OrigStmt (L _ stmt) flav) _) <- expr + | XExpr (ExpandedThingRn (OrigStmt stmt flav) _) <- expr -> hang (text "In a stmt of" <+> pprAStmtContext @(LIdP GhcRn) (HsDoStmt flav) <> colon) 2 (ppr_stmt stmt) | otherwise ===================================== compiler/GHC/Tc/Gen/Do.hs ===================================== @@ -214,7 +214,7 @@ mk_fail_block doFlav pat e (Just (SyntaxExprRn fail_op)) = fail_op_expr :: DynFlags -> LPat GhcRn -> HsExpr GhcRn -> HsExpr GhcRn fail_op_expr dflags pat fail_op - = mkExpandedPatRn pat $ genHsApp fail_op (mk_fail_msg_expr dflags pat) + = mkExpandedPatRn (unLoc pat) $ genHsApp fail_op (mk_fail_msg_expr dflags pat) mk_fail_msg_expr :: DynFlags -> LPat GhcRn -> LHsExpr GhcRn mk_fail_msg_expr dflags pat @@ -489,5 +489,5 @@ mkPopErrCtxtExpr a = XExpr (PopErrCtxt a) genPopErrCtxtExpr :: LHsExpr GhcRn -> LHsExpr GhcRn genPopErrCtxtExpr (L loc a) = L loc (mkPopErrCtxtExpr a) -mkExpandedPatRn :: LPat GhcRn -> HsExpr GhcRn -> HsExpr GhcRn +mkExpandedPatRn :: Pat GhcRn -> HsExpr GhcRn -> HsExpr GhcRn mkExpandedPatRn pat e = XExpr (ExpandedThingRn (OrigPat pat) e) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/11b5f135c6c7407850c26dff4a029e7a... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/11b5f135c6c7407850c26dff4a029e7a... You're receiving this email because of your account on gitlab.haskell.org.