Apoorv Ingle pushed to branch wip/ani/hie-spans at Glasgow Haskell Compiler / GHC
Commits:
-
80fe6958
by Apoorv Ingle at 2025-12-22T01:16:15-06:00
-
803c6615
by Apoorv Ingle at 2025-12-22T01:23:40-06:00
4 changed files:
- compiler/GHC.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Runtime/Debugger/Breakpoints.hs
- compiler/GHC/Tc/Gen/Splice.hs
Changes:
| ... | ... | @@ -1637,12 +1637,14 @@ showRichTokenStream ts = go startLoc ts "" |
| 1637 | 1637 | where sourceFile = getFile $ map (getLoc . fst) ts
|
| 1638 | 1638 | getFile [] = panic "showRichTokenStream: No source file found"
|
| 1639 | 1639 | getFile (UnhelpfulSpan _ : xs) = getFile xs
|
| 1640 | + getFile (GeneratedSrcSpan _ : xs) = getFile xs
|
|
| 1640 | 1641 | getFile (RealSrcSpan s _ : _) = srcSpanFile s
|
| 1641 | 1642 | startLoc = mkRealSrcLoc sourceFile 1 1
|
| 1642 | 1643 | go _ [] = id
|
| 1643 | 1644 | go loc ((L span _, str):ts)
|
| 1644 | 1645 | = case span of
|
| 1645 | 1646 | UnhelpfulSpan _ -> go loc ts
|
| 1647 | + GeneratedSrcSpan _ -> go loc ts
|
|
| 1646 | 1648 | RealSrcSpan s _
|
| 1647 | 1649 | | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++)
|
| 1648 | 1650 | . (str ++)
|
| ... | ... | @@ -424,6 +424,7 @@ getRealSpanA la = getRealSpan (locA la) |
| 424 | 424 | |
| 425 | 425 | getRealSpan :: SrcSpan -> Maybe Span
|
| 426 | 426 | getRealSpan (RealSrcSpan sp _) = Just sp
|
| 427 | +getRealSpan (GeneratedSrcSpan sp) = Just sp
|
|
| 427 | 428 | getRealSpan _ = Nothing
|
| 428 | 429 | |
| 429 | 430 | grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ EpAnn NoEpAnns)
|
| ... | ... | @@ -440,6 +441,9 @@ bindingsOnly (C c n : xs) = do |
| 440 | 441 | RealSrcSpan span _ -> Node (mkSourcedNodeInfo org nodeinfo) span [] : rest
|
| 441 | 442 | where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)
|
| 442 | 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}
|
|
| 443 | 447 | _ -> rest
|
| 444 | 448 | |
| 445 | 449 | concatM :: Monad m => [m [a]] -> m [a]
|
| ... | ... | @@ -636,6 +640,29 @@ instance ToHie (Context (Located Var)) where |
| 636 | 640 | (S.singleton context)))
|
| 637 | 641 | span
|
| 638 | 642 | []]
|
| 643 | + C context (L (GeneratedSrcSpan span) name')
|
|
| 644 | + | varUnique name' == mkBuiltinUnique 1 -> pure []
|
|
| 645 | + -- `mkOneRecordSelector` makes a field var using this unique, which we ignore
|
|
| 646 | + | otherwise -> do
|
|
| 647 | + m <- lift $ gets name_remapping
|
|
| 648 | + org <- ask
|
|
| 649 | + let name = case lookupNameEnv m (varName name') of
|
|
| 650 | + Just var -> var
|
|
| 651 | + Nothing-> name'
|
|
| 652 | + ty = case isDataConId_maybe name' of
|
|
| 653 | + Nothing -> varType name'
|
|
| 654 | + Just dc -> dataConWrapperType dc
|
|
| 655 | + -- insert the entity info for the name into the entity_infos map
|
|
| 656 | + insertEntityInfo (varName name) $ idEntityInfo name
|
|
| 657 | + insertEntityInfo (varName name') $ idEntityInfo name'
|
|
| 658 | + pure
|
|
| 659 | + [Node
|
|
| 660 | + (mkSourcedNodeInfo org $ NodeInfo S.empty [] $
|
|
| 661 | + M.singleton (Right $ varName name)
|
|
| 662 | + (IdentifierDetails (Just ty)
|
|
| 663 | + (S.singleton context)))
|
|
| 664 | + span
|
|
| 665 | + []]
|
|
| 639 | 666 | C (EvidenceVarBind i _ sp) (L _ name) -> do
|
| 640 | 667 | addUnlocatedEvBind name (EvidenceVarBind i ModuleScope sp)
|
| 641 | 668 | pure []
|
| ... | ... | @@ -663,6 +690,26 @@ instance ToHie (Context (Located Name)) where |
| 663 | 690 | (S.singleton context)))
|
| 664 | 691 | span
|
| 665 | 692 | []]
|
| 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 | + []]
|
|
| 666 | 713 | _ -> pure []
|
| 667 | 714 | |
| 668 | 715 | instance ToHie (Context (Located (WithUserRdr Name))) where
|
| 1 | - |
|
| 2 | 1 | -- | GHC API debugger module for finding and setting breakpoints.
|
| 3 | 2 | --
|
| 4 | 3 | -- This module is user facing and is at least used by `GHCi` and `ghc-debugger`
|
| ... | ... | @@ -86,6 +85,7 @@ leftmostLargestRealSrcSpan = on compare realSrcSpanStart S.<> on (flip compare) |
| 86 | 85 | -- | Returns the span of the largest tick containing the srcspan given
|
| 87 | 86 | enclosingTickSpan :: TickArray -> SrcSpan -> RealSrcSpan
|
| 88 | 87 | enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"
|
| 88 | +enclosingTickSpan _ (GeneratedSrcSpan _) = panic "generatedSrcSpan UnhelpfulSpan"
|
|
| 89 | 89 | enclosingTickSpan ticks (RealSrcSpan src _) =
|
| 90 | 90 | assert (inRange (bounds ticks) line) $
|
| 91 | 91 | List.minimumBy leftmostLargestRealSrcSpan $ enclosing_spans
|
| ... | ... | @@ -295,4 +295,3 @@ getCurrentBreakModule = do |
| 295 | 295 | return $ Just $ getBreakSourceMod ibi brks
|
| 296 | 296 | ix ->
|
| 297 | 297 | Just <$> getHistoryModule hug (resumeHistory r !! (ix-1)) |
| 298 | - |
| ... | ... | @@ -1480,9 +1480,11 @@ instance TH.Quasi TcM where |
| 1480 | 1480 | qLocation = do { m <- getModule
|
| 1481 | 1481 | ; l <- getSrcSpanM
|
| 1482 | 1482 | ; r <- case l of
|
| 1483 | + RealSrcSpan s _ -> return s
|
|
| 1484 | + GeneratedSrcSpan l -> pprPanic "qLocation: generatedSrcSpan"
|
|
| 1485 | + (ppr l)
|
|
| 1483 | 1486 | UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
|
| 1484 | 1487 | (ppr l)
|
| 1485 | - RealSrcSpan s _ -> return s
|
|
| 1486 | 1488 | ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)
|
| 1487 | 1489 | , TH.loc_module = moduleNameString (moduleName m)
|
| 1488 | 1490 | , TH.loc_package = unitString (moduleUnit m)
|