Ignore the BufLoc/BufSpan added in GHC's !2516

3 files changed, 11 insertions, 9 deletions

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index b2e2dadd..af7662f1 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -69,11 +69,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)
@@ -96,9 +96,9 @@ 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
+              RealSrcLoc lStart _ = srcSpanStart sp -- safe since @sp@ is real
               (spaceBStr, bStart) = spanPosition lInit lStart bInit
               inPragDef = inPragma inPrag tok
 
@@ -153,11 +153,13 @@ parse dflags fpath bs = case unP (go False []) initState of
 
 -- | Get the input
 getInput :: P (StringBuffer, RealSrcLoc)
-getInput = P $ \p@PState { buffer = buf, loc = srcLoc } -> POk p (buf, srcLoc)
+getInput = P $ \p@PState { buffer = buf, loc = srcLoc } -> POk p (buf, psRealLoc srcLoc)
 
 -- | Set the input
 setInput :: (StringBuffer, RealSrcLoc) -> P ()
-setInput (buf, srcLoc) = P $ \p -> POk (p { buffer = buf, loc = srcLoc }) ()
+setInput (buf, srcLoc) =
+  P $ \p@PState{ loc = PsLoc _ buf_loc } ->
+    POk (p { buffer = buf, loc = PsLoc srcLoc buf_loc }) ()
 
 tryP :: P a -> MaybeT P a
 tryP (P f) = MaybeT $ P $ \s -> case f s of
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index 25d8b07a..a3c20aa7 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -166,7 +166,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
@@ -309,6 +309,6 @@ links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice mdl' docName@(D
         origPkg = moduleUnitId origMod
 
         fname = case loc of
-          RealSrcSpan l -> unpackFS (srcSpanFile l)
+          RealSrcSpan l _ -> unpackFS (srcSpanFile l)
           UnhelpfulSpan _ -> error "links: UnhelpfulSpan"
 links _ _ _ _ _ = noHtml
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
index c3acb6df..3e1312d5 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
@@ -75,7 +75,7 @@ spliceURL' maybe_file maybe_mod maybe_name maybe_loc = run
     Nothing -> ""
     Just span_ ->
       case span_ of
-      RealSrcSpan span__ ->
+      RealSrcSpan span__ _ ->
         show $ srcSpanStartLine span__
       UnhelpfulSpan _ -> ""