Use the GHC lexer for the Hyperlinker backend

CHANGES.md

@@ -19,6 +19,9 @@
  * Fix: Generate constraint signatures for constructors exported as pattern
    synonyms (#663)
 
+ * The hyperlinker backend now uses the GHC lexer instead of a custom one.
+   This notably fixes rendering of quasiquotes.
+
 ## Changes in version 2.18.1
 
  * Synopsis is working again (#599)

haddock-api/haddock-api.cabal

@@ -124,24 +124,68 @@ test-suite spec
       test
     , src
 
-  -- NB: We only use a small subset of lib:haddock-api here, which
-  --     explains why this component has a smaller build-depends set
   other-modules:
+    Haddock
+    Haddock.Backends.Hoogle
+    Haddock.Backends.Hyperlinker
+    Haddock.Backends.Hyperlinker.Ast
+    Haddock.Backends.Hyperlinker.Renderer
+    Haddock.Backends.Hyperlinker.Utils
+    Haddock.Backends.LaTeX
+    Haddock.Backends.Xhtml
+    Haddock.Backends.Xhtml.Decl
+    Haddock.Backends.Xhtml.DocMarkup
+    Haddock.Backends.Xhtml.Layout
+    Haddock.Backends.Xhtml.Meta
+    Haddock.Backends.Xhtml.Names
+    Haddock.Backends.Xhtml.Themes
+    Haddock.Backends.Xhtml.Types
+    Haddock.Backends.Xhtml.Utils
+    Haddock.Convert
+    Haddock.Doc
+    Haddock.GhcUtils
+    Haddock.Interface
+    Haddock.Interface.AttachInstances
+    Haddock.Interface.Create
+    Haddock.Interface.Json
+    Haddock.Interface.LexParseRn
+    Haddock.Interface.ParseModuleHeader
+    Haddock.Interface.Rename
+    Haddock.Interface.Specialize
+    Haddock.InterfaceFile
+    Haddock.ModuleTree
+    Haddock.Options
+    Haddock.Parser
+    Haddock.Syb
+    Haddock.Types
+    Haddock.Utils
+    Haddock.Utils.Json
+    Haddock.Version
+    Paths_haddock_api
     Haddock.Backends.Hyperlinker.ParserSpec
     Haddock.Backends.Hyperlinker.Parser
     Haddock.Backends.Hyperlinker.Types
 
-  build-depends:
-      ghc         ^>= 8.2
-    , hspec       ^>= 2.4.4
-    , QuickCheck  ^>= 2.10
+  build-depends: Cabal           ^>= 2.0.0
+               , ghc             ^>= 8.2
+               , ghc-paths       ^>= 0.1.0.9
+               , haddock-library ^>= 1.4.6
+               , xhtml           ^>= 3000.2.2
+               , hspec           ^>= 2.4.4
+               , QuickCheck      ^>= 2.10
 
   -- Versions for the dependencies below are transitively pinned by
   -- the non-reinstallable `ghc` package and hence need no version
   -- bounds
-  build-depends:
-      base
-    , containers
+  build-depends: base
+               , array
+               , bytestring
+               , containers
+               , deepseq
+               , directory
+               , filepath
+               , ghc-boot
+               , transformers
 
   build-tool-depends:
     hspec-discover:hspec-discover ^>= 2.4.4

haddock-api/src/Haddock.hs

@@ -278,7 +278,7 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
       | Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat
       | otherwise = srcModule
 
-    srcMap = mkSrcMap $ Map.union
+    srcMap = Map.union
       (Map.map SrcExternal extSrcMap)
       (Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ])
 

haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs

@@ -12,6 +12,7 @@ import qualified Haddock.Syb as Syb
 import Haddock.Backends.Hyperlinker.Types
 
 import qualified GHC
+import qualified SrcLoc
 
 import Control.Applicative
 import Control.Monad (guard)
@@ -51,28 +52,22 @@ type DetailsMap = Map.Map Position (Span, TokenDetails)
 
 mkDetailsMap :: [(GHC.SrcSpan, TokenDetails)] -> DetailsMap
 mkDetailsMap xs =
-  Map.fromListWith select_details [ (start, (token_span, token_details))
+  Map.fromListWith select_details [ (start, (span, token_details))
                                   | (ghc_span, token_details) <- xs
-                                  , Just !token_span <- [ghcSrcSpanToSpan ghc_span]
-                                  , let start = spStart token_span
+                                  , GHC.RealSrcSpan span <- [ghc_span]
+                                  , let start = SrcLoc.realSrcSpanStart span
                                   ]
   where
     -- favour token details which appear earlier in the list
     select_details _new old = old
 
 lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails
 lookupBySpan span details = do
-  (_, (tok_span, tok_details)) <- Map.lookupLE (spStart span) details
-  guard (tok_span `containsSpan` span )
+  let pos = SrcLoc.realSrcSpanStart span
+  (_, (tok_span, tok_details)) <- Map.lookupLE pos details
+  guard (tok_span `SrcLoc.containsSpan` span)
   return tok_details
 
-ghcSrcSpanToSpan :: GHC.SrcSpan -> Maybe Span
-ghcSrcSpanToSpan (GHC.RealSrcSpan span) =
-  Just (Span { spStart = Position (GHC.srcSpanStartLine span) (GHC.srcSpanStartCol span)
-             , spEnd   = Position (GHC.srcSpanEndLine span) (GHC.srcSpanEndCol span)
-             })
-ghcSrcSpanToSpan _ = Nothing
-
 enrichToken :: Token -> DetailsMap -> Maybe TokenDetails
 enrichToken (Token typ _ spn) dm
     | typ `elem` [TkIdentifier, TkOperator] = lookupBySpan spn dm