Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 9bc44eb4 by Apoorv Ingle at 2025-07-21T10:43:26-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 ===================================== @@ -75,7 +75,7 @@ expand_do_stmts _ (stmt@(L _ (XStmtLR ApplicativeStmt{})): _) = expand_do_stmts _ [] = pprPanic "expand_do_stmts: impossible happened. Empty stmts" empty -expand_do_stmts flav [stmt@(L sloc (LastStmt _ body@(L body_loc _) _ ret_expr))] +expand_do_stmts flav [L sloc stmt@(LastStmt _ body@(L body_loc _) _ ret_expr)] -- See Note [Expanding HsDo with XXExprGhcRn] Equation (5) below -- last statement of a list comprehension, needs to explicitly return it -- See `checkLastStmt` and `Syntax.Expr.StmtLR.LastStmt` @@ -90,7 +90,7 @@ expand_do_stmts flav [stmt@(L sloc (LastStmt _ body@(L body_loc _) _ ret_expr))] = do let expansion = L body_loc (genHsApp ret body) return $ L sloc (mkExpandedStmt stmt flav (HsPar noExtField expansion)) -expand_do_stmts doFlavour (stmt@(L loc (LetStmt _ bs)) : lstmts) = +expand_do_stmts doFlavour (L loc stmt@(LetStmt _ bs) : lstmts) = -- See Note [Expanding HsDo with XXExprGhcRn] Equation (3) below -- stmts ~~> stmts' -- ------------------------------------------------ @@ -99,7 +99,7 @@ expand_do_stmts doFlavour (stmt@(L loc (LetStmt _ bs)) : lstmts) = let expansion = genHsLet bs (genPopErrCtxtExpr expand_stmts_expr) return $ L loc (mkExpandedStmt stmt doFlavour expansion) -expand_do_stmts doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts) +expand_do_stmts doFlavour (L loc stmt@(BindStmt xbsrn pat e) : lstmts) | SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn , fail_op <- xbsrn_failOp xbsrn -- See Note [Expanding HsDo with XXExprGhcRn] Equation (2) below @@ -117,7 +117,7 @@ expand_do_stmts doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts) | otherwise = pprPanic "expand_do_stmts: The impossible happened, missing bind operator from renamer" (text "stmt" <+> ppr stmt) -expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _)) : lstmts) = +expand_do_stmts doFlavour (L loc stmt@(BodyStmt _ e (SyntaxExprRn then_op) _) : lstmts) = -- See Note [BodyStmt] in Language.Haskell.Syntax.Expr -- See Note [Expanding HsDo with XXExprGhcRn] Equation (1) below -- stmts ~~> stmts' @@ -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/9bc44eb4b3b222a44f7532e32b2596a8... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9bc44eb4b3b222a44f7532e32b2596a8... You're receiving this email because of your account on gitlab.haskell.org.