diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 84ccaf60e2..282756ac65 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -27,6 +27,7 @@ import GHC.Types.SrcLoc ( realSrcLocSpan, mkRealSrcLoc, srcSpanFile ) import Data.Map as M import GHC.Data.FastString ( mkFastString ) import GHC.Unit.Module ( Module, moduleName ) +import qualified GHC.Data.Strict as Strict -- | Generate hyperlinked source for given interfaces. @@ -95,7 +96,7 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do path = srcdir hypSrcModuleFile (ifaceMod iface) emptyHieAst fileFs = Node - { nodeSpan = realSrcLocSpan (mkRealSrcLoc fileFs 1 0) + { nodeSpan = realSrcLocSpan (mkRealSrcLoc fileFs 1 0) Strict.Nothing , nodeChildren = [] , sourcedNodeInfo = SourcedNodeInfo mempty } diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 1d70e532bd..83097fbed7 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -27,6 +27,7 @@ import GHC.Utils.Panic ( panic ) import GHC.Driver.Ppr ( showSDoc ) import GHC.Types.SrcLoc import GHC.Data.StringBuffer ( StringBuffer, atEnd ) +import qualified GHC.Data.Strict as Strict import Haddock.Backends.Hyperlinker.Types as T import Haddock.GhcUtils @@ -78,11 +79,11 @@ parse dflags fpath bs = case unP (go False []) initState of -- | Like 'Lexer.lexer', but slower, with a better API, and filtering out empty tokens wrappedLexer :: P (RealLocated Lexer.Token) wrappedLexer = Lexer.lexer False andThen - where andThen (L (RealSrcSpan s _) t) + where andThen (L (RealSrcSpan s) t) | srcSpanStartLine s /= srcSpanEndLine s || srcSpanStartCol s /= srcSpanEndCol s = pure (L s t) - andThen (L (RealSrcSpan s _) ITeof) = pure (L s ITeof) + andThen (L (RealSrcSpan s) ITeof) = pure (L s ITeof) andThen _ = wrappedLexer -- | Try to parse a CPP line (can fail) @@ -93,7 +94,7 @@ parse dflags fpath bs = case unP (go False []) initState of Just (cppBStr, l', b') -> let cppTok = T.Token { tkType = TkCpp , tkValue = cppBStr - , tkSpan = mkRealSrcSpan l l' } + , tkSpan = mkRealSrcSpan l l' Strict.Nothing } in setInput (b', l') *> pure (Just ([cppTok], False)) _ -> return Nothing @@ -105,7 +106,7 @@ parse dflags fpath bs = case unP (go False []) initState of (bEnd, _) <- lift getInput case sp of UnhelpfulSpan _ -> pure ([], False) -- pretend the token never existed - RealSrcSpan rsp _ -> do + 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 @@ -144,7 +145,7 @@ parse dflags fpath bs = case unP (go False []) initState of , tkSpan = rsp } spaceTok = T.Token { tkType = TkSpace , tkValue = spaceBStr - , tkSpan = mkRealSrcSpan lInit lStart } + , tkSpan = mkRealSrcSpan lInit lStart Strict.Nothing} pure (plainTok : [ spaceTok | not (BS.null spaceBStr) ], inPrag') @@ -155,7 +156,7 @@ parse dflags fpath bs = case unP (go False []) initState of let (unkBStr, l', b') = spanLine l b unkTok = T.Token { tkType = TkUnknown , tkValue = unkBStr - , tkSpan = mkRealSrcSpan l l' } + , tkSpan = mkRealSrcSpan l l' Strict.Nothing } setInput (b', l') pure ([unkTok], False) @@ -411,4 +412,3 @@ inPragma False tok = ITctype {} -> True _ -> False - diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index 41afe5a0d4..c61282a0a8 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -168,7 +168,7 @@ subTableSrc pkg qual lnks splice decls = Just $ table << aboves (concatMap subRo : map (cell . (td <<)) subs linkHtml :: SrcSpan -> Maybe Module -> DocName -> Html - linkHtml loc@(RealSrcSpan _ _) mdl dn = links lnks loc splice mdl dn + linkHtml loc@(RealSrcSpan _) mdl dn = links lnks loc splice mdl dn linkHtml _ _ _ = noHtml subBlock :: [Html] -> Maybe Html diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs index 7f8be25a6a..94865eda16 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -73,7 +73,7 @@ spliceURL' maybe_mod maybe_name maybe_loc = run Nothing -> "" Just span_ -> case span_ of - RealSrcSpan span__ _ -> + RealSrcSpan span__ -> show $ srcSpanStartLine span__ UnhelpfulSpan _ -> "" diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index cd94add63c..b1360cb5b2 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -290,7 +290,7 @@ processModule verbosity modSummary flags ifaceMap instIfaceMap = do where formatName :: SrcSpan -> HsDecl GhcRn -> String formatName loc n = p (getMainDeclBinder emptyOccEnv n) ++ case loc of - RealSrcSpan rss _ -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ + RealSrcSpan rss -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ show (srcSpanStartLine rss) ++ ")" _ -> ""