Tie up with GHC wip/az/bufspan-in-anchor branch

haskell · Jul 19, 2023 · d27663c · d27663c
1 parent b96241b
commit d27663c
Show file tree

Hide file tree

Showing 5 changed files with 12 additions and 11 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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) ++ ")"
             _ -> ""