Apoorv Ingle pushed to branch wip/ani/hie-spans at Glasgow Haskell Compiler / GHC
Commits:
-
6d4a3e14
by Apoorv Ingle at 2025-12-22T10:44:49-06:00
3 changed files:
Changes:
| ... | ... | @@ -441,9 +441,6 @@ bindingsOnly (C c n : xs) = do |
| 441 | 441 | RealSrcSpan span _ -> Node (mkSourcedNodeInfo org nodeinfo) span [] : rest
|
| 442 | 442 | where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)
|
| 443 | 443 | info = mempty{identInfo = S.singleton c}
|
| 444 | - GeneratedSrcSpan span -> Node (mkSourcedNodeInfo org nodeinfo) span [] : rest
|
|
| 445 | - where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)
|
|
| 446 | - info = mempty{identInfo = S.singleton c}
|
|
| 447 | 444 | _ -> rest
|
| 448 | 445 | |
| 449 | 446 | concatM :: Monad m => [m [a]] -> m [a]
|
| ... | ... | @@ -690,26 +687,26 @@ instance ToHie (Context (Located Name)) where |
| 690 | 687 | (S.singleton context)))
|
| 691 | 688 | span
|
| 692 | 689 | []]
|
| 693 | - C context (L (GeneratedSrcSpan span) name')
|
|
| 694 | - | nameUnique name' == mkBuiltinUnique 1 -> pure []
|
|
| 695 | - -- `mkOneRecordSelector` makes a field var using this unique, which we ignore
|
|
| 696 | - | otherwise -> do
|
|
| 697 | - m <- lift $ gets name_remapping
|
|
| 698 | - org <- ask
|
|
| 699 | - let name = case lookupNameEnv m name' of
|
|
| 700 | - Just var -> varName var
|
|
| 701 | - Nothing -> name'
|
|
| 702 | - -- insert the entity info for the name into the entity_infos map
|
|
| 703 | - lookupAndInsertEntityName name
|
|
| 704 | - lookupAndInsertEntityName name'
|
|
| 705 | - pure
|
|
| 706 | - [Node
|
|
| 707 | - (mkSourcedNodeInfo org $ NodeInfo S.empty [] $
|
|
| 708 | - M.singleton (Right name)
|
|
| 709 | - (IdentifierDetails Nothing
|
|
| 710 | - (S.singleton context)))
|
|
| 711 | - span
|
|
| 712 | - []]
|
|
| 690 | + -- C context (L (GeneratedSrcSpan span) name')
|
|
| 691 | + -- | nameUnique name' == mkBuiltinUnique 1 -> pure []
|
|
| 692 | + -- -- `mkOneRecordSelector` makes a field var using this unique, which we ignore
|
|
| 693 | + -- | otherwise -> do
|
|
| 694 | + -- m <- lift $ gets name_remapping
|
|
| 695 | + -- org <- ask
|
|
| 696 | + -- let name = case lookupNameEnv m name' of
|
|
| 697 | + -- Just var -> varName var
|
|
| 698 | + -- Nothing -> name'
|
|
| 699 | + -- -- insert the entity info for the name into the entity_infos map
|
|
| 700 | + -- lookupAndInsertEntityName name
|
|
| 701 | + -- lookupAndInsertEntityName name'
|
|
| 702 | + -- pure
|
|
| 703 | + -- [Node
|
|
| 704 | + -- (mkSourcedNodeInfo org $ NodeInfo S.empty [] $
|
|
| 705 | + -- M.singleton (Right name)
|
|
| 706 | + -- (IdentifierDetails Nothing
|
|
| 707 | + -- (S.singleton context)))
|
|
| 708 | + -- span
|
|
| 709 | + -- []]
|
|
| 713 | 710 | _ -> pure []
|
| 714 | 711 | |
| 715 | 712 | instance ToHie (Context (Located (WithUserRdr Name))) where
|
| ... | ... | @@ -1228,9 +1225,6 @@ instance HiePass p => ToHie (LocatedA (HsOverLit (GhcPass p))) where |
| 1228 | 1225 | |
| 1229 | 1226 | instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
|
| 1230 | 1227 | toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of
|
| 1231 | - HsVar _ (L loc var)
|
|
| 1232 | - | GeneratedSrcSpan _ <- locA loc
|
|
| 1233 | - -> [ toHie $ C Use (L loc var) ]
|
|
| 1234 | 1228 | HsVar _ (L _ var) ->
|
| 1235 | 1229 | [ toHie $ C Use (L mspan var)
|
| 1236 | 1230 | -- Patch up var location since typechecker removes it
|
| ... | ... | @@ -14,7 +14,7 @@ module GHC.Tc.Gen.Do (expandDoStmts) where |
| 14 | 14 | |
| 15 | 15 | import GHC.Prelude
|
| 16 | 16 | |
| 17 | -import GHC.Rename.Utils ( wrapGenSpan, genHsExpApps, genHsApp, genHsLet,
|
|
| 17 | +import GHC.Rename.Utils ( wrapGenSpan, wrapGenSpan', genHsExpApps, genHsApp, genHsLet,
|
|
| 18 | 18 | genHsLamDoExp, genHsCaseAltDoExp, genWildPat )
|
| 19 | 19 | import GHC.Rename.Env ( irrefutableConLikeRn )
|
| 20 | 20 | |
| ... | ... | @@ -121,11 +121,11 @@ expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ (L _e_lspan e) (SyntaxExprRn |
| 121 | 121 | -- ----------------------------------------------
|
| 122 | 122 | -- e ; stmts ~~> (>>) e stmts'
|
| 123 | 123 | do expand_stmts_expr <- expand_do_stmts doFlavour lstmts
|
| 124 | - let expansion = genHsExpApps then_op -- (>>)
|
|
| 124 | + let expansion = mkHsApp (wrapGenSpan' loc then_op) -- (>>)
|
|
| 125 | 125 | [ -- L e_lspan (mkExpandedStmt stmt doFlavour e)
|
| 126 | 126 | wrapGenSpan e
|
| 127 | 127 | , expand_stmts_expr ]
|
| 128 | - return $ L loc (mkExpandedStmt stmt doFlavour expansion)
|
|
| 128 | + return $ L loc (mkExpandedStmt stmt doFlavour (unLoc $ expansion))
|
|
| 129 | 129 | |
| 130 | 130 | expand_do_stmts doFlavour
|
| 131 | 131 | ((L loc (RecStmt { recS_stmts = L stmts_loc rec_stmts
|
| ... | ... | @@ -530,9 +530,10 @@ sortEpaComments cs = sortBy cmp cs |
| 530 | 530 | |
| 531 | 531 | -- | Makes a comment which originates from a specific keyword.
|
| 532 | 532 | mkKWComment :: String -> NoCommentsLocation -> Comment
|
| 533 | -mkKWComment kw (EpaSpan (RealSrcSpan ss mb)) = Comment kw (EpaSpan (RealSrcSpan ss mb)) ss (Just kw)
|
|
| 534 | -mkKWComment kw (EpaSpan (UnhelpfulSpan _)) = Comment kw (EpaDelta noSrcSpan (SameLine 0) NoComments) placeholderRealSpan (Just kw)
|
|
| 535 | 533 | mkKWComment kw (EpaDelta ss dp cs) = Comment kw (EpaDelta ss dp cs) placeholderRealSpan (Just kw)
|
| 534 | +mkKWComment kw (EpaSpan (RealSrcSpan ss mb)) = Comment kw (EpaSpan (RealSrcSpan ss mb)) ss (Just kw)
|
|
| 535 | +mkKWComment kw (EpaSpan _) = Comment kw (EpaDelta noSrcSpan (SameLine 0) NoComments) placeholderRealSpan (Just kw)
|
|
| 536 | + |
|
| 536 | 537 | |
| 537 | 538 | sortAnchorLocated :: [GenLocated EpaLocation a] -> [GenLocated EpaLocation a]
|
| 538 | 539 | sortAnchorLocated = sortBy (compare `on` (epaLocationRealSrcSpan . getLoc))
|