Apoorv Ingle pushed to branch wip/ani/hie-spans at Glasgow Haskell Compiler / GHC Commits: be288632 by Apoorv Ingle at 2025-12-22T10:55:13-06:00 wrap then_op with a generated src span - - - - - 3 changed files: - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Tc/Gen/Do.hs - utils/check-exact/Utils.hs Changes: ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -441,9 +441,6 @@ bindingsOnly (C c n : xs) = do RealSrcSpan span _ -> Node (mkSourcedNodeInfo org nodeinfo) span [] : rest where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info) info = mempty{identInfo = S.singleton c} - GeneratedSrcSpan span -> Node (mkSourcedNodeInfo org nodeinfo) span [] : rest - where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info) - info = mempty{identInfo = S.singleton c} _ -> rest concatM :: Monad m => [m [a]] -> m [a] @@ -690,26 +687,26 @@ instance ToHie (Context (Located Name)) where (S.singleton context))) span []] - C context (L (GeneratedSrcSpan span) name') - | nameUnique name' == mkBuiltinUnique 1 -> pure [] - -- `mkOneRecordSelector` makes a field var using this unique, which we ignore - | otherwise -> do - m <- lift $ gets name_remapping - org <- ask - let name = case lookupNameEnv m name' of - Just var -> varName var - Nothing -> name' - -- insert the entity info for the name into the entity_infos map - lookupAndInsertEntityName name - lookupAndInsertEntityName name' - pure - [Node - (mkSourcedNodeInfo org $ NodeInfo S.empty [] $ - M.singleton (Right name) - (IdentifierDetails Nothing - (S.singleton context))) - span - []] + -- C context (L (GeneratedSrcSpan span) name') + -- | nameUnique name' == mkBuiltinUnique 1 -> pure [] + -- -- `mkOneRecordSelector` makes a field var using this unique, which we ignore + -- | otherwise -> do + -- m <- lift $ gets name_remapping + -- org <- ask + -- let name = case lookupNameEnv m name' of + -- Just var -> varName var + -- Nothing -> name' + -- -- insert the entity info for the name into the entity_infos map + -- lookupAndInsertEntityName name + -- lookupAndInsertEntityName name' + -- pure + -- [Node + -- (mkSourcedNodeInfo org $ NodeInfo S.empty [] $ + -- M.singleton (Right name) + -- (IdentifierDetails Nothing + -- (S.singleton context))) + -- span + -- []] _ -> pure [] instance ToHie (Context (Located (WithUserRdr Name))) where @@ -1228,9 +1225,6 @@ instance HiePass p => ToHie (LocatedA (HsOverLit (GhcPass p))) where instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of - HsVar _ (L loc var) - | GeneratedSrcSpan _ <- locA loc - -> [ toHie $ C Use (L loc var) ] HsVar _ (L _ var) -> [ toHie $ C Use (L mspan var) -- Patch up var location since typechecker removes it ===================================== compiler/GHC/Tc/Gen/Do.hs ===================================== @@ -14,7 +14,7 @@ module GHC.Tc.Gen.Do (expandDoStmts) where import GHC.Prelude -import GHC.Rename.Utils ( wrapGenSpan, genHsExpApps, genHsApp, genHsLet, +import GHC.Rename.Utils ( wrapGenSpan, wrapGenSpan', genHsExpApps, genHsApp, genHsLet, genHsLamDoExp, genHsCaseAltDoExp, genWildPat ) import GHC.Rename.Env ( irrefutableConLikeRn ) @@ -114,18 +114,25 @@ 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 _ (L _e_lspan e) (SyntaxExprRn then_op) _)) : lstmts) = +expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ (L _e_lspan e) (SyntaxExprRn then_op) _)) : lstmts) -- See Note [BodyStmt] in Language.Haskell.Syntax.Expr -- See Note [Expanding HsDo with XXExprGhcRn] Equation (1) below -- stmts ~~> stmts' -- ---------------------------------------------- -- e ; stmts ~~> (>>) e stmts' - do expand_stmts_expr <- expand_do_stmts doFlavour lstmts - let expansion = genHsExpApps then_op -- (>>) - [ -- L e_lspan (mkExpandedStmt stmt doFlavour e) - wrapGenSpan e - , expand_stmts_expr ] - return $ L loc (mkExpandedStmt stmt doFlavour expansion) + | RealSrcSpan sp _ <- locA loc = + do expand_stmts_expr <- expand_do_stmts doFlavour lstmts + let expansion = mkHsApps (wrapGenSpan' sp then_op) -- (>>) + [ wrapGenSpan e + , expand_stmts_expr ] + return $ L loc (mkExpandedStmt stmt doFlavour (unLoc $ expansion)) + + | otherwise = + do expand_stmts_expr <- expand_do_stmts doFlavour lstmts + let expansion = genHsExpApps then_op -- (>>) + [ wrapGenSpan e + , expand_stmts_expr ] + return $ L loc (mkExpandedStmt stmt doFlavour expansion) expand_do_stmts doFlavour ((L loc (RecStmt { recS_stmts = L stmts_loc rec_stmts ===================================== utils/check-exact/Utils.hs ===================================== @@ -530,9 +530,10 @@ sortEpaComments cs = sortBy cmp cs -- | Makes a comment which originates from a specific keyword. mkKWComment :: String -> NoCommentsLocation -> Comment -mkKWComment kw (EpaSpan (RealSrcSpan ss mb)) = Comment kw (EpaSpan (RealSrcSpan ss mb)) ss (Just kw) -mkKWComment kw (EpaSpan (UnhelpfulSpan _)) = Comment kw (EpaDelta noSrcSpan (SameLine 0) NoComments) placeholderRealSpan (Just kw) mkKWComment kw (EpaDelta ss dp cs) = Comment kw (EpaDelta ss dp cs) placeholderRealSpan (Just kw) +mkKWComment kw (EpaSpan (RealSrcSpan ss mb)) = Comment kw (EpaSpan (RealSrcSpan ss mb)) ss (Just kw) +mkKWComment kw (EpaSpan _) = Comment kw (EpaDelta noSrcSpan (SameLine 0) NoComments) placeholderRealSpan (Just kw) + sortAnchorLocated :: [GenLocated EpaLocation a] -> [GenLocated EpaLocation a] sortAnchorLocated = sortBy (compare `on` (epaLocationRealSrcSpan . getLoc)) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/be2886327cfac70033c8cb9142eca013... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/be2886327cfac70033c8cb9142eca013... You're receiving this email because of your account on gitlab.haskell.org.