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 more cases - - - - - 803c6615 by Apoorv Ingle at 2025-12-22T01:23:40-06:00 more cases for GeneratedSrcSpan Fixes T23540 - - - - - 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: ===================================== compiler/GHC.hs ===================================== @@ -1637,12 +1637,14 @@ showRichTokenStream ts = go startLoc ts "" where sourceFile = getFile $ map (getLoc . fst) ts getFile [] = panic "showRichTokenStream: No source file found" getFile (UnhelpfulSpan _ : xs) = getFile xs + getFile (GeneratedSrcSpan _ : xs) = getFile xs getFile (RealSrcSpan s _ : _) = srcSpanFile s startLoc = mkRealSrcLoc sourceFile 1 1 go _ [] = id go loc ((L span _, str):ts) = case span of UnhelpfulSpan _ -> go loc ts + GeneratedSrcSpan _ -> go loc ts RealSrcSpan s _ | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++) . (str ++) ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -424,6 +424,7 @@ getRealSpanA la = getRealSpan (locA la) getRealSpan :: SrcSpan -> Maybe Span getRealSpan (RealSrcSpan sp _) = Just sp +getRealSpan (GeneratedSrcSpan sp) = Just sp getRealSpan _ = Nothing grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ EpAnn NoEpAnns) @@ -440,6 +441,9 @@ 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] @@ -636,6 +640,29 @@ instance ToHie (Context (Located Var)) where (S.singleton context))) span []] + C context (L (GeneratedSrcSpan span) name') + | varUnique 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 (varName name') of + Just var -> var + Nothing-> name' + ty = case isDataConId_maybe name' of + Nothing -> varType name' + Just dc -> dataConWrapperType dc + -- insert the entity info for the name into the entity_infos map + insertEntityInfo (varName name) $ idEntityInfo name + insertEntityInfo (varName name') $ idEntityInfo name' + pure + [Node + (mkSourcedNodeInfo org $ NodeInfo S.empty [] $ + M.singleton (Right $ varName name) + (IdentifierDetails (Just ty) + (S.singleton context))) + span + []] C (EvidenceVarBind i _ sp) (L _ name) -> do addUnlocatedEvBind name (EvidenceVarBind i ModuleScope sp) pure [] @@ -663,6 +690,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 + []] _ -> pure [] instance ToHie (Context (Located (WithUserRdr Name))) where ===================================== compiler/GHC/Runtime/Debugger/Breakpoints.hs ===================================== @@ -1,4 +1,3 @@ - -- | GHC API debugger module for finding and setting breakpoints. -- -- 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) -- | Returns the span of the largest tick containing the srcspan given enclosingTickSpan :: TickArray -> SrcSpan -> RealSrcSpan enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan" +enclosingTickSpan _ (GeneratedSrcSpan _) = panic "generatedSrcSpan UnhelpfulSpan" enclosingTickSpan ticks (RealSrcSpan src _) = assert (inRange (bounds ticks) line) $ List.minimumBy leftmostLargestRealSrcSpan $ enclosing_spans @@ -295,4 +295,3 @@ getCurrentBreakModule = do return $ Just $ getBreakSourceMod ibi brks ix -> Just <$> getHistoryModule hug (resumeHistory r !! (ix-1)) - ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -1480,9 +1480,11 @@ instance TH.Quasi TcM where qLocation = do { m <- getModule ; l <- getSrcSpanM ; r <- case l of + RealSrcSpan s _ -> return s + GeneratedSrcSpan l -> pprPanic "qLocation: generatedSrcSpan" + (ppr l) UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" (ppr l) - RealSrcSpan s _ -> return s ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) , TH.loc_module = moduleNameString (moduleName m) , TH.loc_package = unitString (moduleUnit m) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b4c72787d6b48e1e0ea29f95a465389... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b4c72787d6b48e1e0ea29f95a465389... You're receiving this email because of your account on gitlab.haskell.org.