Apoorv Ingle pushed to branch wip/ani/hie-spans at Glasgow Haskell Compiler / GHC Commits: eb8a3a6b by Apoorv Ingle at 2026-01-15T17:23:23-06:00 remove UnhelpfulGenerated from UnhelpfulSpanReason and into new datatype GeneratedSrcSpanDetails - - - - - 15 changed files: - compiler/GHC.hs - compiler/GHC/Hs/DocString.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Ext/Utils.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/SrcLoc.hs - compiler/GHC/Utils/Binary.hs - ghc/GHCi/UI.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -288,7 +288,7 @@ module GHC ( SrcLoc(..), RealSrcLoc, mkSrcLoc, noSrcLoc, srcLocFile, srcLocLine, srcLocCol, - SrcSpan(..), RealSrcSpan, + SrcSpan(..), RealSrcSpan, GeneratedSrcSpanDetails (..), mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan, srcSpanStart, srcSpanEnd, srcSpanFile, ===================================== compiler/GHC/Hs/DocString.hs ===================================== @@ -172,7 +172,7 @@ isEmptyDocString (GeneratedDocString x) = nullHDSC x docStringChunks :: HsDocString -> [LHsDocStringChunk] docStringChunks (MultiLineDocString _ (x:|xs)) = x:xs docStringChunks (NestedDocString _ x) = [x] -docStringChunks (GeneratedDocString x) = [L (UnhelpfulSpan UnhelpfulGenerated) x] +docStringChunks (GeneratedDocString x) = [L (GeneratedSrcSpan UnhelpfulGenerated) x] -- | Pretty print with decorators, exactly as the user wrote it pprHsDocString :: HsDocString -> SDoc ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -251,7 +251,7 @@ getUnlocatedEvBinds file = do let node = Node (mkSourcedNodeInfo org ni) spn [] ni = NodeInfo mempty [] $ M.fromList [mkNodeInfo e] in (xs,node:ys) - GeneratedSrcSpan spn + GeneratedSrcSpan (OrigSpan spn) | srcSpanFile spn == file -> let node = Node (mkSourcedNodeInfo org ni) spn [] ni = NodeInfo mempty [] $ M.fromList [mkNodeInfo e] @@ -424,7 +424,7 @@ getRealSpanA la = getRealSpan (locA la) getRealSpan :: SrcSpan -> Maybe Span getRealSpan (RealSrcSpan sp _) = Just sp -getRealSpan (GeneratedSrcSpan sp) = Just sp +getRealSpan (GeneratedSrcSpan (OrigSpan sp)) = Just sp getRealSpan _ = Nothing grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ EpAnn NoEpAnns) @@ -638,7 +638,7 @@ toHieCtxLocVar context span name' instance ToHie (Context (Located Var)) where toHie c = case c of C context (L (RealSrcSpan span _) name') -> toHieCtxLocVar context span name' - C context (L (GeneratedSrcSpan span) name') -> toHieCtxLocVar context span name' + C context (L (GeneratedSrcSpan (OrigSpan span)) name') -> toHieCtxLocVar context span name' C (EvidenceVarBind i _ sp) (L _ name) -> do addUnlocatedEvBind name (EvidenceVarBind i ModuleScope sp) pure [] ===================================== compiler/GHC/Iface/Ext/Utils.hs ===================================== @@ -322,7 +322,7 @@ getNameScopeAndBinding n asts = case nameSrcSpan n of scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets) let binding = foldMap (First . getBindSiteFromContext) (identInfo dets) return $ Just (scopes, getFirst binding) - GeneratedSrcSpan sp -> do -- @Maybe + GeneratedSrcSpan (OrigSpan sp) -> do -- @Maybe ast <- M.lookup (HiePath (srcSpanFile sp)) asts defNode <- selectLargestContainedBy sp ast getFirst $ foldMap First $ do -- @[] @@ -387,7 +387,7 @@ selectSmallestContaining sp node definedInAsts :: M.Map HiePath (HieAST a) -> Name -> Bool definedInAsts asts n = case nameSrcSpan n of RealSrcSpan sp _ -> M.member (HiePath (srcSpanFile sp)) asts - GeneratedSrcSpan sp -> M.member (HiePath (srcSpanFile sp)) asts + GeneratedSrcSpan (OrigSpan sp) -> M.member (HiePath (srcSpanFile sp)) asts _ -> False getEvidenceBindDeps :: ContextInfo -> [Name] @@ -538,7 +538,7 @@ locOnly (RealSrcSpan span _) = do org <- ask let e = mkSourcedNodeInfo org $ emptyNodeInfo pure [Node e span []] -locOnly (GeneratedSrcSpan span) = do +locOnly (GeneratedSrcSpan (OrigSpan span)) = do org <- ask let e = mkSourcedNodeInfo org $ emptyNodeInfo pure [Node e span []] @@ -551,7 +551,7 @@ locOnlyE _ = pure [] mkScope :: (HasLoc a) => a -> Scope mkScope a = case getHasLoc a of (RealSrcSpan sp _) -> LocalScope sp - (GeneratedSrcSpan sp) -> LocalScope sp + (GeneratedSrcSpan (OrigSpan sp)) -> LocalScope sp _ -> NoScope combineScopes :: Scope -> Scope -> Scope @@ -583,7 +583,7 @@ makeNode x spn = do org <- ask pure $ case spn of RealSrcSpan span _ -> [Node (mkSourcedNodeInfo org $ simpleNodeInfo cons typ) span []] - GeneratedSrcSpan span -> [Node (mkSourcedNodeInfo org $ simpleNodeInfo cons typ) span []] + GeneratedSrcSpan (OrigSpan span) -> [Node (mkSourcedNodeInfo org $ simpleNodeInfo cons typ) span []] _ -> [] where cons = mkFastString . show . toConstr $ x @@ -610,7 +610,7 @@ makeTypeNode x spn etyp = do pure $ case spn of RealSrcSpan span _ -> [Node (mkSourcedNodeInfo org $ NodeInfo (S.singleton (NodeAnnotation cons typ)) [etyp] M.empty) span []] - GeneratedSrcSpan span -> + GeneratedSrcSpan (OrigSpan span) -> [Node (mkSourcedNodeInfo org $ NodeInfo (S.singleton (NodeAnnotation cons typ)) [etyp] M.empty) span []] _ -> [] where ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -502,7 +502,7 @@ rnExpr (ExplicitList _ exps) then return (ExplicitList noExtField exps', fvs) else do { (from_list_n_name, fvs') <- lookupSyntaxName fromListNName - ; loc <- getRealSrcSpanM -- See Note [Source locations for implicit function calls] + ; loc <- getSrcSpanM -- See Note [Source locations for implicit function calls] ; let rn_list = ExplicitList noExtField exps' lit_n = mkIntegralLit (length exps) hs_lit = genHsIntegralLit lit_n ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -2166,7 +2166,7 @@ insertImportMap :: GlobalRdrElt -> ImportMap -> ImportMap insertImportMap gre@(GRE { gre_imp = imp_specs }) importMap | RealSrcSpan importSpan _ <- is_dloc best_imp_spec = importMap{im_imports = insertElem importSpan gre $ im_imports importMap} - | UnhelpfulSpan UnhelpfulGenerated <- is_dloc best_imp_spec = + | GeneratedSrcSpan{} <- is_dloc best_imp_spec = importMap{im_generatedImports = insertElem (moduleName $ is_mod best_imp_spec) gre $ im_generatedImports importMap} | otherwise = importMap where @@ -2187,7 +2187,7 @@ lookupImportMap (L srcSpan ImportDecl{ideclName = L _ modName}) importMap = -- should match logic in insertImportMap case locA srcSpan of RealSrcSpan realSrcSpan _ -> realSrcSpan `Map.lookup` im_imports importMap - UnhelpfulSpan UnhelpfulGenerated -> modName `Map.lookup` im_generatedImports importMap + GeneratedSrcSpan{} -> modName `Map.lookup` im_generatedImports importMap _ -> Nothing warnUnusedImport :: GlobalRdrEnv -> ImportDeclUsage -> RnM () @@ -2557,4 +2557,3 @@ addDupDeclErr gres@(gre :| _) checkConName :: RdrName -> TcRn () checkConName name = checkErr (isRdrDataCon name || isRdrTc name) (TcRnIllegalDataCon name) - ===================================== compiler/GHC/Rename/Utils.hs ===================================== @@ -701,8 +701,10 @@ wrapGenSpan :: (HasAnnotation an) => a -> GenLocated an a -- See Note [Rebindable syntax and XXExprGhcRn] wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x -wrapGenSpan' :: (HasAnnotation an) => RealSrcSpan -> a -> GenLocated an a -wrapGenSpan' s x = L (noAnnSrcSpan $ GeneratedSrcSpan s) x +wrapGenSpan' :: (HasAnnotation an) => SrcSpan -> a -> GenLocated an a +wrapGenSpan' s x = case s of + RealSrcSpan s _ -> L (noAnnSrcSpan $ GeneratedSrcSpan (OrigSpan s)) x + _ -> wrapGenSpan x wrapNoSpan :: (HasAnnotation an) => a -> GenLocated an a -- Wrap something in a "noSrcSpan" ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -1359,7 +1359,7 @@ expandRecordUpd :: LHsExpr GhcRn -- error context to push when typechecking -- the expanded code ) -expandRecordUpd record_expr possible_parents rbnds res_ty +expandRecordUpd record_expr@(L lspan _) possible_parents rbnds res_ty = do { -- STEP 0: typecheck the record_expr, the record to be updated. -- -- Until GHC proposal #366 is implemented, we still use the type of @@ -1527,7 +1527,7 @@ expandRecordUpd record_expr possible_parents rbnds res_ty ds_expr = HsLet noExtField let_binds (wrapGenSpan case_expr) case_expr :: HsExpr GhcRn - case_expr = HsCase RecUpd record_expr + case_expr = HsCase RecUpd (wrapGenSpan' (locA lspan) (unLoc record_expr)) $ mkMatchGroup (Generated OtherExpansion DoPmc) (wrapGenSpan matches) matches :: [LMatch GhcRn (LHsExpr GhcRn)] matches = map make_pat (NE.toList relevant_cons) ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -1482,7 +1482,7 @@ instance TH.Quasi TcM where ; r <- case l of RealSrcSpan s _ -> return s GeneratedSrcSpan l -> pprPanic "qLocation: generatedSrcSpan" - (ppr l) + (pprGeneratedSrcSpanDetails l) UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" (ppr l) ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) ===================================== compiler/GHC/Types/Hint/Ppr.hs ===================================== @@ -19,7 +19,7 @@ import GHC.Hs.Expr () -- instance Outputable import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Reader (RdrName,ImpDeclSpec (..), rdrNameOcc, rdrNameSpace) -import GHC.Types.SrcLoc (SrcSpan(..), srcSpanStartLine, UnhelpfulSpanReason(..)) +import GHC.Types.SrcLoc (SrcSpan(..), srcSpanStartLine, UnhelpfulSpanReason(..), pprGeneratedSrcSpanDetails) import GHC.Unit.Module.Imported (ImportedModsVal(..)) import GHC.Unit.Types import GHC.Utils.Outputable @@ -424,7 +424,7 @@ pprSimilarName mb_tried_ns (SimilarRdrName rdr_name _gre_info how_in_scope) LocallyBoundAt loc -> case loc of UnhelpfulSpan l -> parens (ppr l) - GeneratedSrcSpan{} -> parens (ppr UnhelpfulGenerated) + GeneratedSrcSpan ss -> parens (pprGeneratedSrcSpanDetails ss) RealSrcSpan l _ -> parens (text "line" <+> int (srcSpanStartLine l)) ImportedBy is -> parens (text "imported from" <+> ppr (moduleName $ is_mod is)) ===================================== compiler/GHC/Types/SrcLoc.hs ===================================== @@ -30,6 +30,7 @@ module GHC.Types.SrcLoc ( -- * SrcSpan RealSrcSpan, -- Abstract SrcSpan(..), + GeneratedSrcSpanDetails(..), UnhelpfulSpanReason(..), -- ** Constructing SrcSpan @@ -49,6 +50,8 @@ module GHC.Types.SrcLoc ( pprUserSpan, unhelpfulSpanFS, srcSpanToRealSrcSpan, + pprGeneratedSrcSpanDetails, + generatedSrcSpanDetailsFS, -- ** Unsafely deconstructing SrcSpan -- These are dubious exports, because they crash on some inputs @@ -387,17 +390,22 @@ instance Semigroup BufSpan where -- or a human-readable description of a location. data SrcSpan = RealSrcSpan !RealSrcSpan !(Strict.Maybe BufSpan) -- See Note [Why Maybe BufPos] - | GeneratedSrcSpan !RealSrcSpan -- Needed for HIE + | GeneratedSrcSpan !GeneratedSrcSpanDetails | UnhelpfulSpan !UnhelpfulSpanReason deriving (Eq, Show) -- Show is used by GHC.Parser.Lexer, because we -- derive Show for Token +-- Needed for HIE +data GeneratedSrcSpanDetails = + OrigSpan !RealSrcSpan -- this the span of the user written thing + | UnhelpfulGenerated + deriving (Eq, Show) + data UnhelpfulSpanReason = UnhelpfulNoLocationInfo | UnhelpfulWiredIn | UnhelpfulInteractive - | UnhelpfulGenerated | UnhelpfulOther !FastString deriving (Eq, Show) @@ -427,9 +435,13 @@ messages, constructing a SrcSpan without a BufSpan. instance ToJson SrcSpan where json (UnhelpfulSpan {} ) = JSNull --JSObject [( "type", "unhelpful")] - json (GeneratedSrcSpan {}) = JSNull + json (GeneratedSrcSpan d) = json d json (RealSrcSpan rss _) = json rss +instance ToJson GeneratedSrcSpanDetails where + json (UnhelpfulGenerated) = JSNull + json (OrigSpan s) = json s + instance ToJson RealSrcSpan where json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile)), ("start", start), @@ -446,13 +458,16 @@ instance NFData RealSrcSpan where instance NFData SrcSpan where rnf (RealSrcSpan a1 a2) = rnf a1 `seq` rnf a2 rnf (UnhelpfulSpan a1) = rnf a1 - rnf (GeneratedSrcSpan {}) = rnf UnhelpfulGenerated + rnf (GeneratedSrcSpan a1) = rnf a1 + +instance NFData GeneratedSrcSpanDetails where + rnf (OrigSpan s) = rnf s + rnf (UnhelpfulGenerated) = () instance NFData UnhelpfulSpanReason where rnf (UnhelpfulNoLocationInfo) = () rnf (UnhelpfulWiredIn) = () rnf (UnhelpfulInteractive) = () - rnf (UnhelpfulGenerated) = () rnf (UnhelpfulOther a1) = rnf a1 getBufSpan :: SrcSpan -> Strict.Maybe BufSpan @@ -465,10 +480,9 @@ noSrcSpan, generatedSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan noSrcSpan = UnhelpfulSpan UnhelpfulNoLocationInfo wiredInSrcSpan = UnhelpfulSpan UnhelpfulWiredIn interactiveSrcSpan = UnhelpfulSpan UnhelpfulInteractive -generatedSrcSpan = UnhelpfulSpan UnhelpfulGenerated +generatedSrcSpan = GeneratedSrcSpan UnhelpfulGenerated isGeneratedSrcSpan :: SrcSpan -> Bool -isGeneratedSrcSpan (UnhelpfulSpan UnhelpfulGenerated) = True isGeneratedSrcSpan (GeneratedSrcSpan{}) = True isGeneratedSrcSpan _ = False @@ -520,8 +534,8 @@ mkSrcSpan (RealSrcLoc loc1 mbpos1) (RealSrcLoc loc2 mbpos2) combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful combineSrcSpans l (UnhelpfulSpan _) = l -combineSrcSpans (GeneratedSrcSpan _) r = r -- this seems more useful -combineSrcSpans l (GeneratedSrcSpan _) = l +combineSrcSpans (GeneratedSrcSpan{}) r = r +combineSrcSpans l (GeneratedSrcSpan{}) = l combineSrcSpans (RealSrcSpan span1 mbspan1) (RealSrcSpan span2 mbspan2) | srcSpanFile span1 == srcSpanFile span2 = RealSrcSpan (combineRealSrcSpans span1 span2) (liftA2 combineBufSpans mbspan1 mbspan2) @@ -628,13 +642,13 @@ srcSpanEndCol RealSrcSpan'{ srcSpanECol=c } = c -- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable srcSpanStart :: SrcSpan -> SrcLoc srcSpanStart (UnhelpfulSpan r) = UnhelpfulLoc (unhelpfulSpanFS r) -srcSpanStart (GeneratedSrcSpan{}) = UnhelpfulLoc (unhelpfulSpanFS UnhelpfulGenerated) +srcSpanStart (GeneratedSrcSpan d) = UnhelpfulLoc (generatedSrcSpanDetailsFS d) srcSpanStart (RealSrcSpan s b) = RealSrcLoc (realSrcSpanStart s) (fmap bufSpanStart b) -- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable srcSpanEnd :: SrcSpan -> SrcLoc srcSpanEnd (UnhelpfulSpan r) = UnhelpfulLoc (unhelpfulSpanFS r) -srcSpanEnd (GeneratedSrcSpan{}) = UnhelpfulLoc (unhelpfulSpanFS UnhelpfulGenerated) +srcSpanEnd (GeneratedSrcSpan d) = UnhelpfulLoc (generatedSrcSpanDetailsFS d) srcSpanEnd (RealSrcSpan s b) = RealSrcLoc (realSrcSpanEnd s) (fmap bufSpanEnd b) realSrcSpanStart :: RealSrcSpan -> RealSrcLoc @@ -720,14 +734,19 @@ unhelpfulSpanFS r = case r of UnhelpfulNoLocationInfo -> fsLit "<no location info>" UnhelpfulWiredIn -> fsLit "<wired into compiler>" UnhelpfulInteractive -> fsLit "<interactive>" - UnhelpfulGenerated -> fsLit "<generated>" pprUnhelpfulSpanReason :: UnhelpfulSpanReason -> SDoc pprUnhelpfulSpanReason r = ftext (unhelpfulSpanFS r) +generatedSrcSpanDetailsFS :: GeneratedSrcSpanDetails -> FastString +generatedSrcSpanDetailsFS _ = fsLit "<generated>" + +pprGeneratedSrcSpanDetails :: GeneratedSrcSpanDetails -> SDoc +pprGeneratedSrcSpanDetails d = ftext (generatedSrcSpanDetailsFS d) + pprUserSpan :: Bool -> SrcSpan -> SDoc pprUserSpan _ (UnhelpfulSpan r) = pprUnhelpfulSpanReason r -pprUserSpan _ (GeneratedSrcSpan{}) = pprUnhelpfulSpanReason UnhelpfulGenerated +pprUserSpan _ (GeneratedSrcSpan d) = pprGeneratedSrcSpanDetails d pprUserSpan show_path (RealSrcSpan s _) = pprUserRealSpan show_path s pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc ===================================== compiler/GHC/Utils/Binary.hs ===================================== @@ -1912,8 +1912,7 @@ instance Binary UnhelpfulSpanReason where UnhelpfulNoLocationInfo -> putByte bh 0 UnhelpfulWiredIn -> putByte bh 1 UnhelpfulInteractive -> putByte bh 2 - UnhelpfulGenerated -> putByte bh 3 - UnhelpfulOther fs -> putByte bh 4 >> put_ bh fs + UnhelpfulOther fs -> putByte bh 3 >> put_ bh fs get bh = do h <- getByte bh @@ -1921,11 +1920,25 @@ instance Binary UnhelpfulSpanReason where 0 -> return UnhelpfulNoLocationInfo 1 -> return UnhelpfulWiredIn 2 -> return UnhelpfulInteractive - 3 -> return UnhelpfulGenerated _ -> UnhelpfulOther <$> get bh newtype BinSrcSpan = BinSrcSpan { unBinSrcSpan :: SrcSpan } +instance Binary GeneratedSrcSpanDetails where + put_ bh (OrigSpan ss) = do + putByte bh 0 + put_ bh $ BinSpan ss + + put_ bh UnhelpfulGenerated = do + putByte bh 1 + + get bh = do + h <- getByte bh + case h of + 0 -> do BinSpan ss <- get bh + return $ OrigSpan ss + _ -> do return UnhelpfulGenerated + -- See Note [Source Location Wrappers] instance Binary BinSrcSpan where put_ bh (BinSrcSpan (RealSrcSpan ss _sb)) = do @@ -1940,7 +1953,7 @@ instance Binary BinSrcSpan where put_ bh (BinSrcSpan (GeneratedSrcSpan ss)) = do putByte bh 2 - put_ bh $ BinSpan ss + put_ bh ss get bh = do h <- getByte bh @@ -1949,7 +1962,7 @@ instance Binary BinSrcSpan where return $ BinSrcSpan (RealSrcSpan ss Strict.Nothing) 1 -> do s <- get bh return $ BinSrcSpan (UnhelpfulSpan s) - _ -> do BinSpan ss <- get bh + _ -> do ss <- get bh return $ BinSrcSpan (GeneratedSrcSpan ss) ===================================== ghc/GHCi/UI.hs ===================================== @@ -2693,7 +2693,7 @@ parseSpanArg s = do -- while simply unpacking 'UnhelpfulSpan's showSrcSpan :: SrcSpan -> String showSrcSpan (UnhelpfulSpan s) = unpackFS (unhelpfulSpanFS s) -showSrcSpan (GeneratedSrcSpan _) = unpackFS (unhelpfulSpanFS UnhelpfulGenerated) +showSrcSpan (GeneratedSrcSpan d) = unpackFS (generatedSrcSpanDetailsFS d) showSrcSpan (RealSrcSpan spn _) = showRealSrcSpan spn -- | Variant of 'showSrcSpan' for 'RealSrcSpan's ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs ===================================== @@ -105,57 +105,13 @@ parse parserOpts sDocContext fpath bs = case unP (go False []) initState of parsePlainTok inPrag = do (bInit, lInit) <- lift getInput L sp tok <- tryP (Lexer.lexer False return) - (bEnd, _) <- lift getInput case sp of - UnhelpfulSpan _ -> pure ([], False) -- pretend the token never existed - RealSrcSpan rsp _ -> do - let typ = if inPrag then TkPragma else classify tok - RealSrcLoc lStart _ = srcSpanStart sp -- safe since @sp@ is real - (spaceBStr, bStart) = spanPosition lInit lStart bInit - inPragDef = inPragma inPrag tok - - (bEnd', inPrag') <- case tok of - -- Update internal line + file position if this is a LINE pragma - ITline_prag _ -> tryOrElse (bEnd, inPragDef) $ do - L _ (ITinteger (IL{il_value = line})) <- tryP wrappedLexer - L _ (ITstring _ file) <- tryP wrappedLexer - L spF ITclose_prag <- tryP wrappedLexer - - let newLoc = mkRealSrcLoc file (fromIntegral line - 1) (srcSpanEndCol spF) - (bEnd'', _) <- lift getInput - lift $ setInput (bEnd'', newLoc) - - pure (bEnd'', False) - - -- Update internal column position if this is a COLUMN pragma - ITcolumn_prag _ -> tryOrElse (bEnd, inPragDef) $ do - L _ (ITinteger (IL{il_value = col})) <- tryP wrappedLexer - L spF ITclose_prag <- tryP wrappedLexer - - let newLoc = mkRealSrcLoc (srcSpanFile spF) (srcSpanEndLine spF) (fromIntegral col) - (bEnd'', _) <- lift getInput - lift $ setInput (bEnd'', newLoc) - - pure (bEnd'', False) - _ -> pure (bEnd, inPragDef) - - let tokBStr = splitStringBuffer bStart bEnd' - plainTok = - T.Token - { tkType = typ - , tkValue = tokBStr - , tkSpan = rsp - } - spaceTok = - T.Token - { tkType = TkSpace - , tkValue = spaceBStr - , tkSpan = mkRealSrcSpan lInit lStart - } - - pure (plainTok : [spaceTok | not (BS.null spaceBStr)], inPrag') + RealSrcSpan rsp _ -> tryParse inPrag rsp bInit lInit sp tok + GeneratedSrcSpan (OrigSpan rsp) -> tryParse inPrag rsp bInit lInit sp tok + _ -> pure ([], False) -- pretend the token never existed - GeneratedSrcSpan rsp -> do + tryParse inPrag rsp bInit lInit sp tok = do + (bEnd, _) <- lift getInput let typ = if inPrag then TkPragma else classify tok RealSrcLoc lStart _ = srcSpanStart sp -- safe since @sp@ is real (spaceBStr, bStart) = spanPosition lInit lStart bInit ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs ===================================== @@ -53,7 +53,7 @@ module Haddock.Backends.Xhtml.Utils , collapseControl ) where -import GHC (Name, SrcSpan (..), srcSpanStartLine) +import GHC (Name, SrcSpan (..), GeneratedSrcSpanDetails (..), srcSpanStartLine) import GHC.Types.Name (getOccString, isValOcc, nameOccName) import GHC.Unit.Module (Module, ModuleName, moduleName, moduleNameString) import Text.XHtml hiding (name, p, quote, title) @@ -103,8 +103,10 @@ spliceURL' maybe_mod maybe_name maybe_loc = run case span_ of RealSrcSpan span__ _ -> show $ srcSpanStartLine span__ - GeneratedSrcSpan span__ -> - show $ srcSpanStartLine span__ + GeneratedSrcSpan sp -> + case sp of + OrigSpan span__ -> show $ srcSpanStartLine span__ + _ -> "" UnhelpfulSpan _ -> "" run "" = "" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eb8a3a6bca61feccd7d74736f8add8c3... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eb8a3a6bca61feccd7d74736f8add8c3... You're receiving this email because of your account on gitlab.haskell.org.