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
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:
| ... | ... | @@ -288,7 +288,7 @@ module GHC ( |
| 288 | 288 | SrcLoc(..), RealSrcLoc,
|
| 289 | 289 | mkSrcLoc, noSrcLoc,
|
| 290 | 290 | srcLocFile, srcLocLine, srcLocCol,
|
| 291 | - SrcSpan(..), RealSrcSpan,
|
|
| 291 | + SrcSpan(..), RealSrcSpan, GeneratedSrcSpanDetails (..),
|
|
| 292 | 292 | mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
|
| 293 | 293 | srcSpanStart, srcSpanEnd,
|
| 294 | 294 | srcSpanFile,
|
| ... | ... | @@ -172,7 +172,7 @@ isEmptyDocString (GeneratedDocString x) = nullHDSC x |
| 172 | 172 | docStringChunks :: HsDocString -> [LHsDocStringChunk]
|
| 173 | 173 | docStringChunks (MultiLineDocString _ (x:|xs)) = x:xs
|
| 174 | 174 | docStringChunks (NestedDocString _ x) = [x]
|
| 175 | -docStringChunks (GeneratedDocString x) = [L (UnhelpfulSpan UnhelpfulGenerated) x]
|
|
| 175 | +docStringChunks (GeneratedDocString x) = [L (GeneratedSrcSpan UnhelpfulGenerated) x]
|
|
| 176 | 176 | |
| 177 | 177 | -- | Pretty print with decorators, exactly as the user wrote it
|
| 178 | 178 | pprHsDocString :: HsDocString -> SDoc
|
| ... | ... | @@ -251,7 +251,7 @@ getUnlocatedEvBinds file = do |
| 251 | 251 | let node = Node (mkSourcedNodeInfo org ni) spn []
|
| 252 | 252 | ni = NodeInfo mempty [] $ M.fromList [mkNodeInfo e]
|
| 253 | 253 | in (xs,node:ys)
|
| 254 | - GeneratedSrcSpan spn
|
|
| 254 | + GeneratedSrcSpan (OrigSpan spn)
|
|
| 255 | 255 | | srcSpanFile spn == file ->
|
| 256 | 256 | let node = Node (mkSourcedNodeInfo org ni) spn []
|
| 257 | 257 | ni = NodeInfo mempty [] $ M.fromList [mkNodeInfo e]
|
| ... | ... | @@ -424,7 +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 | +getRealSpan (GeneratedSrcSpan (OrigSpan sp)) = Just sp
|
|
| 428 | 428 | getRealSpan _ = Nothing
|
| 429 | 429 | |
| 430 | 430 | grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ EpAnn NoEpAnns)
|
| ... | ... | @@ -638,7 +638,7 @@ toHieCtxLocVar context span name' |
| 638 | 638 | instance ToHie (Context (Located Var)) where
|
| 639 | 639 | toHie c = case c of
|
| 640 | 640 | C context (L (RealSrcSpan span _) name') -> toHieCtxLocVar context span name'
|
| 641 | - C context (L (GeneratedSrcSpan span) name') -> toHieCtxLocVar context span name'
|
|
| 641 | + C context (L (GeneratedSrcSpan (OrigSpan span)) name') -> toHieCtxLocVar context span name'
|
|
| 642 | 642 | C (EvidenceVarBind i _ sp) (L _ name) -> do
|
| 643 | 643 | addUnlocatedEvBind name (EvidenceVarBind i ModuleScope sp)
|
| 644 | 644 | pure []
|
| ... | ... | @@ -322,7 +322,7 @@ getNameScopeAndBinding n asts = case nameSrcSpan n of |
| 322 | 322 | scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets)
|
| 323 | 323 | let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)
|
| 324 | 324 | return $ Just (scopes, getFirst binding)
|
| 325 | - GeneratedSrcSpan sp -> do -- @Maybe
|
|
| 325 | + GeneratedSrcSpan (OrigSpan sp) -> do -- @Maybe
|
|
| 326 | 326 | ast <- M.lookup (HiePath (srcSpanFile sp)) asts
|
| 327 | 327 | defNode <- selectLargestContainedBy sp ast
|
| 328 | 328 | getFirst $ foldMap First $ do -- @[]
|
| ... | ... | @@ -387,7 +387,7 @@ selectSmallestContaining sp node |
| 387 | 387 | definedInAsts :: M.Map HiePath (HieAST a) -> Name -> Bool
|
| 388 | 388 | definedInAsts asts n = case nameSrcSpan n of
|
| 389 | 389 | RealSrcSpan sp _ -> M.member (HiePath (srcSpanFile sp)) asts
|
| 390 | - GeneratedSrcSpan sp -> M.member (HiePath (srcSpanFile sp)) asts
|
|
| 390 | + GeneratedSrcSpan (OrigSpan sp) -> M.member (HiePath (srcSpanFile sp)) asts
|
|
| 391 | 391 | _ -> False
|
| 392 | 392 | |
| 393 | 393 | getEvidenceBindDeps :: ContextInfo -> [Name]
|
| ... | ... | @@ -538,7 +538,7 @@ locOnly (RealSrcSpan span _) = do |
| 538 | 538 | org <- ask
|
| 539 | 539 | let e = mkSourcedNodeInfo org $ emptyNodeInfo
|
| 540 | 540 | pure [Node e span []]
|
| 541 | -locOnly (GeneratedSrcSpan span) = do
|
|
| 541 | +locOnly (GeneratedSrcSpan (OrigSpan span)) = do
|
|
| 542 | 542 | org <- ask
|
| 543 | 543 | let e = mkSourcedNodeInfo org $ emptyNodeInfo
|
| 544 | 544 | pure [Node e span []]
|
| ... | ... | @@ -551,7 +551,7 @@ locOnlyE _ = pure [] |
| 551 | 551 | mkScope :: (HasLoc a) => a -> Scope
|
| 552 | 552 | mkScope a = case getHasLoc a of
|
| 553 | 553 | (RealSrcSpan sp _) -> LocalScope sp
|
| 554 | - (GeneratedSrcSpan sp) -> LocalScope sp
|
|
| 554 | + (GeneratedSrcSpan (OrigSpan sp)) -> LocalScope sp
|
|
| 555 | 555 | _ -> NoScope
|
| 556 | 556 | |
| 557 | 557 | combineScopes :: Scope -> Scope -> Scope
|
| ... | ... | @@ -583,7 +583,7 @@ makeNode x spn = do |
| 583 | 583 | org <- ask
|
| 584 | 584 | pure $ case spn of
|
| 585 | 585 | RealSrcSpan span _ -> [Node (mkSourcedNodeInfo org $ simpleNodeInfo cons typ) span []]
|
| 586 | - GeneratedSrcSpan span -> [Node (mkSourcedNodeInfo org $ simpleNodeInfo cons typ) span []]
|
|
| 586 | + GeneratedSrcSpan (OrigSpan span) -> [Node (mkSourcedNodeInfo org $ simpleNodeInfo cons typ) span []]
|
|
| 587 | 587 | _ -> []
|
| 588 | 588 | where
|
| 589 | 589 | cons = mkFastString . show . toConstr $ x
|
| ... | ... | @@ -610,7 +610,7 @@ makeTypeNode x spn etyp = do |
| 610 | 610 | pure $ case spn of
|
| 611 | 611 | RealSrcSpan span _ ->
|
| 612 | 612 | [Node (mkSourcedNodeInfo org $ NodeInfo (S.singleton (NodeAnnotation cons typ)) [etyp] M.empty) span []]
|
| 613 | - GeneratedSrcSpan span ->
|
|
| 613 | + GeneratedSrcSpan (OrigSpan span) ->
|
|
| 614 | 614 | [Node (mkSourcedNodeInfo org $ NodeInfo (S.singleton (NodeAnnotation cons typ)) [etyp] M.empty) span []]
|
| 615 | 615 | _ -> []
|
| 616 | 616 | where
|
| ... | ... | @@ -502,7 +502,7 @@ rnExpr (ExplicitList _ exps) |
| 502 | 502 | then return (ExplicitList noExtField exps', fvs)
|
| 503 | 503 | else
|
| 504 | 504 | do { (from_list_n_name, fvs') <- lookupSyntaxName fromListNName
|
| 505 | - ; loc <- getRealSrcSpanM -- See Note [Source locations for implicit function calls]
|
|
| 505 | + ; loc <- getSrcSpanM -- See Note [Source locations for implicit function calls]
|
|
| 506 | 506 | ; let rn_list = ExplicitList noExtField exps'
|
| 507 | 507 | lit_n = mkIntegralLit (length exps)
|
| 508 | 508 | hs_lit = genHsIntegralLit lit_n
|
| ... | ... | @@ -2166,7 +2166,7 @@ insertImportMap :: GlobalRdrElt -> ImportMap -> ImportMap |
| 2166 | 2166 | insertImportMap gre@(GRE { gre_imp = imp_specs }) importMap
|
| 2167 | 2167 | | RealSrcSpan importSpan _ <- is_dloc best_imp_spec =
|
| 2168 | 2168 | importMap{im_imports = insertElem importSpan gre $ im_imports importMap}
|
| 2169 | - | UnhelpfulSpan UnhelpfulGenerated <- is_dloc best_imp_spec =
|
|
| 2169 | + | GeneratedSrcSpan{} <- is_dloc best_imp_spec =
|
|
| 2170 | 2170 | importMap{im_generatedImports = insertElem (moduleName $ is_mod best_imp_spec) gre $ im_generatedImports importMap}
|
| 2171 | 2171 | | otherwise = importMap
|
| 2172 | 2172 | where
|
| ... | ... | @@ -2187,7 +2187,7 @@ lookupImportMap (L srcSpan ImportDecl{ideclName = L _ modName}) importMap = |
| 2187 | 2187 | -- should match logic in insertImportMap
|
| 2188 | 2188 | case locA srcSpan of
|
| 2189 | 2189 | RealSrcSpan realSrcSpan _ -> realSrcSpan `Map.lookup` im_imports importMap
|
| 2190 | - UnhelpfulSpan UnhelpfulGenerated -> modName `Map.lookup` im_generatedImports importMap
|
|
| 2190 | + GeneratedSrcSpan{} -> modName `Map.lookup` im_generatedImports importMap
|
|
| 2191 | 2191 | _ -> Nothing
|
| 2192 | 2192 | |
| 2193 | 2193 | warnUnusedImport :: GlobalRdrEnv -> ImportDeclUsage -> RnM ()
|
| ... | ... | @@ -2557,4 +2557,3 @@ addDupDeclErr gres@(gre :| _) |
| 2557 | 2557 | checkConName :: RdrName -> TcRn ()
|
| 2558 | 2558 | checkConName name
|
| 2559 | 2559 | = checkErr (isRdrDataCon name || isRdrTc name) (TcRnIllegalDataCon name) |
| 2560 | - |
| ... | ... | @@ -701,8 +701,10 @@ wrapGenSpan :: (HasAnnotation an) => a -> GenLocated an a |
| 701 | 701 | -- See Note [Rebindable syntax and XXExprGhcRn]
|
| 702 | 702 | wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x
|
| 703 | 703 | |
| 704 | -wrapGenSpan' :: (HasAnnotation an) => RealSrcSpan -> a -> GenLocated an a
|
|
| 705 | -wrapGenSpan' s x = L (noAnnSrcSpan $ GeneratedSrcSpan s) x
|
|
| 704 | +wrapGenSpan' :: (HasAnnotation an) => SrcSpan -> a -> GenLocated an a
|
|
| 705 | +wrapGenSpan' s x = case s of
|
|
| 706 | + RealSrcSpan s _ -> L (noAnnSrcSpan $ GeneratedSrcSpan (OrigSpan s)) x
|
|
| 707 | + _ -> wrapGenSpan x
|
|
| 706 | 708 | |
| 707 | 709 | wrapNoSpan :: (HasAnnotation an) => a -> GenLocated an a
|
| 708 | 710 | -- Wrap something in a "noSrcSpan"
|
| ... | ... | @@ -1359,7 +1359,7 @@ expandRecordUpd :: LHsExpr GhcRn |
| 1359 | 1359 | -- error context to push when typechecking
|
| 1360 | 1360 | -- the expanded code
|
| 1361 | 1361 | )
|
| 1362 | -expandRecordUpd record_expr possible_parents rbnds res_ty
|
|
| 1362 | +expandRecordUpd record_expr@(L lspan _) possible_parents rbnds res_ty
|
|
| 1363 | 1363 | = do { -- STEP 0: typecheck the record_expr, the record to be updated.
|
| 1364 | 1364 | --
|
| 1365 | 1365 | -- Until GHC proposal #366 is implemented, we still use the type of
|
| ... | ... | @@ -1527,7 +1527,7 @@ expandRecordUpd record_expr possible_parents rbnds res_ty |
| 1527 | 1527 | ds_expr = HsLet noExtField let_binds (wrapGenSpan case_expr)
|
| 1528 | 1528 | |
| 1529 | 1529 | case_expr :: HsExpr GhcRn
|
| 1530 | - case_expr = HsCase RecUpd record_expr
|
|
| 1530 | + case_expr = HsCase RecUpd (wrapGenSpan' (locA lspan) (unLoc record_expr))
|
|
| 1531 | 1531 | $ mkMatchGroup (Generated OtherExpansion DoPmc) (wrapGenSpan matches)
|
| 1532 | 1532 | matches :: [LMatch GhcRn (LHsExpr GhcRn)]
|
| 1533 | 1533 | matches = map make_pat (NE.toList relevant_cons)
|
| ... | ... | @@ -1482,7 +1482,7 @@ instance TH.Quasi TcM where |
| 1482 | 1482 | ; r <- case l of
|
| 1483 | 1483 | RealSrcSpan s _ -> return s
|
| 1484 | 1484 | GeneratedSrcSpan l -> pprPanic "qLocation: generatedSrcSpan"
|
| 1485 | - (ppr l)
|
|
| 1485 | + (pprGeneratedSrcSpanDetails l)
|
|
| 1486 | 1486 | UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
|
| 1487 | 1487 | (ppr l)
|
| 1488 | 1488 | ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)
|
| ... | ... | @@ -19,7 +19,7 @@ import GHC.Hs.Expr () -- instance Outputable |
| 19 | 19 | import GHC.Types.Id
|
| 20 | 20 | import GHC.Types.Name
|
| 21 | 21 | import GHC.Types.Name.Reader (RdrName,ImpDeclSpec (..), rdrNameOcc, rdrNameSpace)
|
| 22 | -import GHC.Types.SrcLoc (SrcSpan(..), srcSpanStartLine, UnhelpfulSpanReason(..))
|
|
| 22 | +import GHC.Types.SrcLoc (SrcSpan(..), srcSpanStartLine, UnhelpfulSpanReason(..), pprGeneratedSrcSpanDetails)
|
|
| 23 | 23 | import GHC.Unit.Module.Imported (ImportedModsVal(..))
|
| 24 | 24 | import GHC.Unit.Types
|
| 25 | 25 | import GHC.Utils.Outputable
|
| ... | ... | @@ -424,7 +424,7 @@ pprSimilarName mb_tried_ns (SimilarRdrName rdr_name _gre_info how_in_scope) |
| 424 | 424 | LocallyBoundAt loc ->
|
| 425 | 425 | case loc of
|
| 426 | 426 | UnhelpfulSpan l -> parens (ppr l)
|
| 427 | - GeneratedSrcSpan{} -> parens (ppr UnhelpfulGenerated)
|
|
| 427 | + GeneratedSrcSpan ss -> parens (pprGeneratedSrcSpanDetails ss)
|
|
| 428 | 428 | RealSrcSpan l _ -> parens (text "line" <+> int (srcSpanStartLine l))
|
| 429 | 429 | ImportedBy is ->
|
| 430 | 430 | parens (text "imported from" <+> ppr (moduleName $ is_mod is))
|
| ... | ... | @@ -30,6 +30,7 @@ module GHC.Types.SrcLoc ( |
| 30 | 30 | -- * SrcSpan
|
| 31 | 31 | RealSrcSpan, -- Abstract
|
| 32 | 32 | SrcSpan(..),
|
| 33 | + GeneratedSrcSpanDetails(..),
|
|
| 33 | 34 | UnhelpfulSpanReason(..),
|
| 34 | 35 | |
| 35 | 36 | -- ** Constructing SrcSpan
|
| ... | ... | @@ -49,6 +50,8 @@ module GHC.Types.SrcLoc ( |
| 49 | 50 | pprUserSpan,
|
| 50 | 51 | unhelpfulSpanFS,
|
| 51 | 52 | srcSpanToRealSrcSpan,
|
| 53 | + pprGeneratedSrcSpanDetails,
|
|
| 54 | + generatedSrcSpanDetailsFS,
|
|
| 52 | 55 | |
| 53 | 56 | -- ** Unsafely deconstructing SrcSpan
|
| 54 | 57 | -- These are dubious exports, because they crash on some inputs
|
| ... | ... | @@ -387,17 +390,22 @@ instance Semigroup BufSpan where |
| 387 | 390 | -- or a human-readable description of a location.
|
| 388 | 391 | data SrcSpan =
|
| 389 | 392 | RealSrcSpan !RealSrcSpan !(Strict.Maybe BufSpan) -- See Note [Why Maybe BufPos]
|
| 390 | - | GeneratedSrcSpan !RealSrcSpan -- Needed for HIE
|
|
| 393 | + | GeneratedSrcSpan !GeneratedSrcSpanDetails
|
|
| 391 | 394 | | UnhelpfulSpan !UnhelpfulSpanReason
|
| 392 | 395 | |
| 393 | 396 | deriving (Eq, Show) -- Show is used by GHC.Parser.Lexer, because we
|
| 394 | 397 | -- derive Show for Token
|
| 395 | 398 | |
| 399 | +-- Needed for HIE
|
|
| 400 | +data GeneratedSrcSpanDetails =
|
|
| 401 | + OrigSpan !RealSrcSpan -- this the span of the user written thing
|
|
| 402 | + | UnhelpfulGenerated
|
|
| 403 | + deriving (Eq, Show)
|
|
| 404 | + |
|
| 396 | 405 | data UnhelpfulSpanReason
|
| 397 | 406 | = UnhelpfulNoLocationInfo
|
| 398 | 407 | | UnhelpfulWiredIn
|
| 399 | 408 | | UnhelpfulInteractive
|
| 400 | - | UnhelpfulGenerated
|
|
| 401 | 409 | | UnhelpfulOther !FastString
|
| 402 | 410 | deriving (Eq, Show)
|
| 403 | 411 | |
| ... | ... | @@ -427,9 +435,13 @@ messages, constructing a SrcSpan without a BufSpan. |
| 427 | 435 | |
| 428 | 436 | instance ToJson SrcSpan where
|
| 429 | 437 | json (UnhelpfulSpan {} ) = JSNull --JSObject [( "type", "unhelpful")]
|
| 430 | - json (GeneratedSrcSpan {}) = JSNull
|
|
| 438 | + json (GeneratedSrcSpan d) = json d
|
|
| 431 | 439 | json (RealSrcSpan rss _) = json rss
|
| 432 | 440 | |
| 441 | +instance ToJson GeneratedSrcSpanDetails where
|
|
| 442 | + json (UnhelpfulGenerated) = JSNull
|
|
| 443 | + json (OrigSpan s) = json s
|
|
| 444 | + |
|
| 433 | 445 | instance ToJson RealSrcSpan where
|
| 434 | 446 | json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile)),
|
| 435 | 447 | ("start", start),
|
| ... | ... | @@ -446,13 +458,16 @@ instance NFData RealSrcSpan where |
| 446 | 458 | instance NFData SrcSpan where
|
| 447 | 459 | rnf (RealSrcSpan a1 a2) = rnf a1 `seq` rnf a2
|
| 448 | 460 | rnf (UnhelpfulSpan a1) = rnf a1
|
| 449 | - rnf (GeneratedSrcSpan {}) = rnf UnhelpfulGenerated
|
|
| 461 | + rnf (GeneratedSrcSpan a1) = rnf a1
|
|
| 462 | + |
|
| 463 | +instance NFData GeneratedSrcSpanDetails where
|
|
| 464 | + rnf (OrigSpan s) = rnf s
|
|
| 465 | + rnf (UnhelpfulGenerated) = ()
|
|
| 450 | 466 | |
| 451 | 467 | instance NFData UnhelpfulSpanReason where
|
| 452 | 468 | rnf (UnhelpfulNoLocationInfo) = ()
|
| 453 | 469 | rnf (UnhelpfulWiredIn) = ()
|
| 454 | 470 | rnf (UnhelpfulInteractive) = ()
|
| 455 | - rnf (UnhelpfulGenerated) = ()
|
|
| 456 | 471 | rnf (UnhelpfulOther a1) = rnf a1
|
| 457 | 472 | |
| 458 | 473 | getBufSpan :: SrcSpan -> Strict.Maybe BufSpan
|
| ... | ... | @@ -465,10 +480,9 @@ noSrcSpan, generatedSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan |
| 465 | 480 | noSrcSpan = UnhelpfulSpan UnhelpfulNoLocationInfo
|
| 466 | 481 | wiredInSrcSpan = UnhelpfulSpan UnhelpfulWiredIn
|
| 467 | 482 | interactiveSrcSpan = UnhelpfulSpan UnhelpfulInteractive
|
| 468 | -generatedSrcSpan = UnhelpfulSpan UnhelpfulGenerated
|
|
| 483 | +generatedSrcSpan = GeneratedSrcSpan UnhelpfulGenerated
|
|
| 469 | 484 | |
| 470 | 485 | isGeneratedSrcSpan :: SrcSpan -> Bool
|
| 471 | -isGeneratedSrcSpan (UnhelpfulSpan UnhelpfulGenerated) = True
|
|
| 472 | 486 | isGeneratedSrcSpan (GeneratedSrcSpan{}) = True
|
| 473 | 487 | isGeneratedSrcSpan _ = False
|
| 474 | 488 | |
| ... | ... | @@ -520,8 +534,8 @@ mkSrcSpan (RealSrcLoc loc1 mbpos1) (RealSrcLoc loc2 mbpos2) |
| 520 | 534 | combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan
|
| 521 | 535 | combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful
|
| 522 | 536 | combineSrcSpans l (UnhelpfulSpan _) = l
|
| 523 | -combineSrcSpans (GeneratedSrcSpan _) r = r -- this seems more useful
|
|
| 524 | -combineSrcSpans l (GeneratedSrcSpan _) = l
|
|
| 537 | +combineSrcSpans (GeneratedSrcSpan{}) r = r
|
|
| 538 | +combineSrcSpans l (GeneratedSrcSpan{}) = l
|
|
| 525 | 539 | combineSrcSpans (RealSrcSpan span1 mbspan1) (RealSrcSpan span2 mbspan2)
|
| 526 | 540 | | srcSpanFile span1 == srcSpanFile span2
|
| 527 | 541 | = RealSrcSpan (combineRealSrcSpans span1 span2) (liftA2 combineBufSpans mbspan1 mbspan2)
|
| ... | ... | @@ -628,13 +642,13 @@ srcSpanEndCol RealSrcSpan'{ srcSpanECol=c } = c |
| 628 | 642 | -- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable
|
| 629 | 643 | srcSpanStart :: SrcSpan -> SrcLoc
|
| 630 | 644 | srcSpanStart (UnhelpfulSpan r) = UnhelpfulLoc (unhelpfulSpanFS r)
|
| 631 | -srcSpanStart (GeneratedSrcSpan{}) = UnhelpfulLoc (unhelpfulSpanFS UnhelpfulGenerated)
|
|
| 645 | +srcSpanStart (GeneratedSrcSpan d) = UnhelpfulLoc (generatedSrcSpanDetailsFS d)
|
|
| 632 | 646 | srcSpanStart (RealSrcSpan s b) = RealSrcLoc (realSrcSpanStart s) (fmap bufSpanStart b)
|
| 633 | 647 | |
| 634 | 648 | -- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable
|
| 635 | 649 | srcSpanEnd :: SrcSpan -> SrcLoc
|
| 636 | 650 | srcSpanEnd (UnhelpfulSpan r) = UnhelpfulLoc (unhelpfulSpanFS r)
|
| 637 | -srcSpanEnd (GeneratedSrcSpan{}) = UnhelpfulLoc (unhelpfulSpanFS UnhelpfulGenerated)
|
|
| 651 | +srcSpanEnd (GeneratedSrcSpan d) = UnhelpfulLoc (generatedSrcSpanDetailsFS d)
|
|
| 638 | 652 | srcSpanEnd (RealSrcSpan s b) = RealSrcLoc (realSrcSpanEnd s) (fmap bufSpanEnd b)
|
| 639 | 653 | |
| 640 | 654 | realSrcSpanStart :: RealSrcSpan -> RealSrcLoc
|
| ... | ... | @@ -720,14 +734,19 @@ unhelpfulSpanFS r = case r of |
| 720 | 734 | UnhelpfulNoLocationInfo -> fsLit "<no location info>"
|
| 721 | 735 | UnhelpfulWiredIn -> fsLit "<wired into compiler>"
|
| 722 | 736 | UnhelpfulInteractive -> fsLit "<interactive>"
|
| 723 | - UnhelpfulGenerated -> fsLit "<generated>"
|
|
| 724 | 737 | |
| 725 | 738 | pprUnhelpfulSpanReason :: UnhelpfulSpanReason -> SDoc
|
| 726 | 739 | pprUnhelpfulSpanReason r = ftext (unhelpfulSpanFS r)
|
| 727 | 740 | |
| 741 | +generatedSrcSpanDetailsFS :: GeneratedSrcSpanDetails -> FastString
|
|
| 742 | +generatedSrcSpanDetailsFS _ = fsLit "<generated>"
|
|
| 743 | + |
|
| 744 | +pprGeneratedSrcSpanDetails :: GeneratedSrcSpanDetails -> SDoc
|
|
| 745 | +pprGeneratedSrcSpanDetails d = ftext (generatedSrcSpanDetailsFS d)
|
|
| 746 | + |
|
| 728 | 747 | pprUserSpan :: Bool -> SrcSpan -> SDoc
|
| 729 | 748 | pprUserSpan _ (UnhelpfulSpan r) = pprUnhelpfulSpanReason r
|
| 730 | -pprUserSpan _ (GeneratedSrcSpan{}) = pprUnhelpfulSpanReason UnhelpfulGenerated
|
|
| 749 | +pprUserSpan _ (GeneratedSrcSpan d) = pprGeneratedSrcSpanDetails d
|
|
| 731 | 750 | pprUserSpan show_path (RealSrcSpan s _) = pprUserRealSpan show_path s
|
| 732 | 751 | |
| 733 | 752 | pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc
|
| ... | ... | @@ -1912,8 +1912,7 @@ instance Binary UnhelpfulSpanReason where |
| 1912 | 1912 | UnhelpfulNoLocationInfo -> putByte bh 0
|
| 1913 | 1913 | UnhelpfulWiredIn -> putByte bh 1
|
| 1914 | 1914 | UnhelpfulInteractive -> putByte bh 2
|
| 1915 | - UnhelpfulGenerated -> putByte bh 3
|
|
| 1916 | - UnhelpfulOther fs -> putByte bh 4 >> put_ bh fs
|
|
| 1915 | + UnhelpfulOther fs -> putByte bh 3 >> put_ bh fs
|
|
| 1917 | 1916 | |
| 1918 | 1917 | get bh = do
|
| 1919 | 1918 | h <- getByte bh
|
| ... | ... | @@ -1921,11 +1920,25 @@ instance Binary UnhelpfulSpanReason where |
| 1921 | 1920 | 0 -> return UnhelpfulNoLocationInfo
|
| 1922 | 1921 | 1 -> return UnhelpfulWiredIn
|
| 1923 | 1922 | 2 -> return UnhelpfulInteractive
|
| 1924 | - 3 -> return UnhelpfulGenerated
|
|
| 1925 | 1923 | _ -> UnhelpfulOther <$> get bh
|
| 1926 | 1924 | |
| 1927 | 1925 | newtype BinSrcSpan = BinSrcSpan { unBinSrcSpan :: SrcSpan }
|
| 1928 | 1926 | |
| 1927 | +instance Binary GeneratedSrcSpanDetails where
|
|
| 1928 | + put_ bh (OrigSpan ss) = do
|
|
| 1929 | + putByte bh 0
|
|
| 1930 | + put_ bh $ BinSpan ss
|
|
| 1931 | + |
|
| 1932 | + put_ bh UnhelpfulGenerated = do
|
|
| 1933 | + putByte bh 1
|
|
| 1934 | + |
|
| 1935 | + get bh = do
|
|
| 1936 | + h <- getByte bh
|
|
| 1937 | + case h of
|
|
| 1938 | + 0 -> do BinSpan ss <- get bh
|
|
| 1939 | + return $ OrigSpan ss
|
|
| 1940 | + _ -> do return UnhelpfulGenerated
|
|
| 1941 | + |
|
| 1929 | 1942 | -- See Note [Source Location Wrappers]
|
| 1930 | 1943 | instance Binary BinSrcSpan where
|
| 1931 | 1944 | put_ bh (BinSrcSpan (RealSrcSpan ss _sb)) = do
|
| ... | ... | @@ -1940,7 +1953,7 @@ instance Binary BinSrcSpan where |
| 1940 | 1953 | |
| 1941 | 1954 | put_ bh (BinSrcSpan (GeneratedSrcSpan ss)) = do
|
| 1942 | 1955 | putByte bh 2
|
| 1943 | - put_ bh $ BinSpan ss
|
|
| 1956 | + put_ bh ss
|
|
| 1944 | 1957 | |
| 1945 | 1958 | get bh = do
|
| 1946 | 1959 | h <- getByte bh
|
| ... | ... | @@ -1949,7 +1962,7 @@ instance Binary BinSrcSpan where |
| 1949 | 1962 | return $ BinSrcSpan (RealSrcSpan ss Strict.Nothing)
|
| 1950 | 1963 | 1 -> do s <- get bh
|
| 1951 | 1964 | return $ BinSrcSpan (UnhelpfulSpan s)
|
| 1952 | - _ -> do BinSpan ss <- get bh
|
|
| 1965 | + _ -> do ss <- get bh
|
|
| 1953 | 1966 | return $ BinSrcSpan (GeneratedSrcSpan ss)
|
| 1954 | 1967 | |
| 1955 | 1968 |
| ... | ... | @@ -2693,7 +2693,7 @@ parseSpanArg s = do |
| 2693 | 2693 | -- while simply unpacking 'UnhelpfulSpan's
|
| 2694 | 2694 | showSrcSpan :: SrcSpan -> String
|
| 2695 | 2695 | showSrcSpan (UnhelpfulSpan s) = unpackFS (unhelpfulSpanFS s)
|
| 2696 | -showSrcSpan (GeneratedSrcSpan _) = unpackFS (unhelpfulSpanFS UnhelpfulGenerated)
|
|
| 2696 | +showSrcSpan (GeneratedSrcSpan d) = unpackFS (generatedSrcSpanDetailsFS d)
|
|
| 2697 | 2697 | showSrcSpan (RealSrcSpan spn _) = showRealSrcSpan spn
|
| 2698 | 2698 | |
| 2699 | 2699 | -- | Variant of 'showSrcSpan' for 'RealSrcSpan's
|
| ... | ... | @@ -105,57 +105,13 @@ parse parserOpts sDocContext fpath bs = case unP (go False []) initState of |
| 105 | 105 | parsePlainTok inPrag = do
|
| 106 | 106 | (bInit, lInit) <- lift getInput
|
| 107 | 107 | L sp tok <- tryP (Lexer.lexer False return)
|
| 108 | - (bEnd, _) <- lift getInput
|
|
| 109 | 108 | case sp of
|
| 110 | - UnhelpfulSpan _ -> pure ([], False) -- pretend the token never existed
|
|
| 111 | - RealSrcSpan rsp _ -> do
|
|
| 112 | - let typ = if inPrag then TkPragma else classify tok
|
|
| 113 | - RealSrcLoc lStart _ = srcSpanStart sp -- safe since @sp@ is real
|
|
| 114 | - (spaceBStr, bStart) = spanPosition lInit lStart bInit
|
|
| 115 | - inPragDef = inPragma inPrag tok
|
|
| 116 | - |
|
| 117 | - (bEnd', inPrag') <- case tok of
|
|
| 118 | - -- Update internal line + file position if this is a LINE pragma
|
|
| 119 | - ITline_prag _ -> tryOrElse (bEnd, inPragDef) $ do
|
|
| 120 | - L _ (ITinteger (IL{il_value = line})) <- tryP wrappedLexer
|
|
| 121 | - L _ (ITstring _ file) <- tryP wrappedLexer
|
|
| 122 | - L spF ITclose_prag <- tryP wrappedLexer
|
|
| 123 | - |
|
| 124 | - let newLoc = mkRealSrcLoc file (fromIntegral line - 1) (srcSpanEndCol spF)
|
|
| 125 | - (bEnd'', _) <- lift getInput
|
|
| 126 | - lift $ setInput (bEnd'', newLoc)
|
|
| 127 | - |
|
| 128 | - pure (bEnd'', False)
|
|
| 129 | - |
|
| 130 | - -- Update internal column position if this is a COLUMN pragma
|
|
| 131 | - ITcolumn_prag _ -> tryOrElse (bEnd, inPragDef) $ do
|
|
| 132 | - L _ (ITinteger (IL{il_value = col})) <- tryP wrappedLexer
|
|
| 133 | - L spF ITclose_prag <- tryP wrappedLexer
|
|
| 134 | - |
|
| 135 | - let newLoc = mkRealSrcLoc (srcSpanFile spF) (srcSpanEndLine spF) (fromIntegral col)
|
|
| 136 | - (bEnd'', _) <- lift getInput
|
|
| 137 | - lift $ setInput (bEnd'', newLoc)
|
|
| 138 | - |
|
| 139 | - pure (bEnd'', False)
|
|
| 140 | - _ -> pure (bEnd, inPragDef)
|
|
| 141 | - |
|
| 142 | - let tokBStr = splitStringBuffer bStart bEnd'
|
|
| 143 | - plainTok =
|
|
| 144 | - T.Token
|
|
| 145 | - { tkType = typ
|
|
| 146 | - , tkValue = tokBStr
|
|
| 147 | - , tkSpan = rsp
|
|
| 148 | - }
|
|
| 149 | - spaceTok =
|
|
| 150 | - T.Token
|
|
| 151 | - { tkType = TkSpace
|
|
| 152 | - , tkValue = spaceBStr
|
|
| 153 | - , tkSpan = mkRealSrcSpan lInit lStart
|
|
| 154 | - }
|
|
| 155 | - |
|
| 156 | - pure (plainTok : [spaceTok | not (BS.null spaceBStr)], inPrag')
|
|
| 109 | + RealSrcSpan rsp _ -> tryParse inPrag rsp bInit lInit sp tok
|
|
| 110 | + GeneratedSrcSpan (OrigSpan rsp) -> tryParse inPrag rsp bInit lInit sp tok
|
|
| 111 | + _ -> pure ([], False) -- pretend the token never existed
|
|
| 157 | 112 | |
| 158 | - GeneratedSrcSpan rsp -> do
|
|
| 113 | + tryParse inPrag rsp bInit lInit sp tok = do
|
|
| 114 | + (bEnd, _) <- lift getInput
|
|
| 159 | 115 | let typ = if inPrag then TkPragma else classify tok
|
| 160 | 116 | RealSrcLoc lStart _ = srcSpanStart sp -- safe since @sp@ is real
|
| 161 | 117 | (spaceBStr, bStart) = spanPosition lInit lStart bInit
|
| ... | ... | @@ -53,7 +53,7 @@ module Haddock.Backends.Xhtml.Utils |
| 53 | 53 | , collapseControl
|
| 54 | 54 | ) where
|
| 55 | 55 | |
| 56 | -import GHC (Name, SrcSpan (..), srcSpanStartLine)
|
|
| 56 | +import GHC (Name, SrcSpan (..), GeneratedSrcSpanDetails (..), srcSpanStartLine)
|
|
| 57 | 57 | import GHC.Types.Name (getOccString, isValOcc, nameOccName)
|
| 58 | 58 | import GHC.Unit.Module (Module, ModuleName, moduleName, moduleNameString)
|
| 59 | 59 | import Text.XHtml hiding (name, p, quote, title)
|
| ... | ... | @@ -103,8 +103,10 @@ spliceURL' maybe_mod maybe_name maybe_loc = run |
| 103 | 103 | case span_ of
|
| 104 | 104 | RealSrcSpan span__ _ ->
|
| 105 | 105 | show $ srcSpanStartLine span__
|
| 106 | - GeneratedSrcSpan span__ ->
|
|
| 107 | - show $ srcSpanStartLine span__
|
|
| 106 | + GeneratedSrcSpan sp ->
|
|
| 107 | + case sp of
|
|
| 108 | + OrigSpan span__ -> show $ srcSpanStartLine span__
|
|
| 109 | + _ -> ""
|
|
| 108 | 110 | UnhelpfulSpan _ -> ""
|
| 109 | 111 | |
| 110 | 112 | run "" = ""
|