From 868248d5e847e29ffede5b6c7d20f08a3ec7eb47 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 1 Jul 2015 22:25:21 +0200
Subject: Make hyperlinker render qualified names as one entity.

---
 .../src/Haddock/Backends/Hyperlinker/Ast.hs        |  1 +
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 50 +++++++++++++++++++---
 2 files changed, 46 insertions(+), 5 deletions(-)

(limited to 'haddock-api/src/Haddock')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 79e31db7..decb1206 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -25,6 +25,7 @@ data TokenDetails
     | RtkBind GHC.Name
     | RtkDecl GHC.Name
     | RtkModule GHC.ModuleName
+    deriving (Eq)
 
 rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName
 rtkName (RtkVar name) = Left name
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 89d9b60d..ddb2e5b9 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -19,15 +19,46 @@ import qualified Data.Map as Map
 import Text.XHtml (Html, HtmlAttr, (!))
 import qualified Text.XHtml as Html
 
+
 type StyleClass = String
 
+
 render :: Maybe FilePath -> Maybe FilePath
        -> GHC.PackageKey -> SrcMap -> [RichToken]
        -> Html
 render mcss mjs pkg srcs tokens = header mcss mjs <> body pkg srcs tokens
 
+
+data TokenGroup
+    = GrpNormal Token
+    | GrpRich TokenDetails [Token]
+
+
+-- | Group consecutive tokens pointing to the same element.
+--
+-- We want to render qualified identifiers as one entity. For example,
+-- @Bar.Baz.foo@ consists of 5 tokens (@Bar@, @.@, @Baz@, @.@, @foo@) but for
+-- better user experience when highlighting and clicking links, these tokens
+-- should be regarded as one identifier. Therefore, before rendering we must
+-- group consecutive elements pointing to the same 'GHC.Name' (note that even
+-- dot token has it if it is part of qualified name).
+groupTokens :: [RichToken] -> [TokenGroup]
+groupTokens [] = []
+groupTokens ((RichToken tok Nothing):rest) = (GrpNormal tok):(groupTokens rest)
+groupTokens ((RichToken tok (Just det)):rest) =
+    let (grp, rest') = span same rest
+    in (GrpRich det (tok:(map rtkToken grp))):(groupTokens rest')
+  where
+    same (RichToken _ (Just det')) = det == det'
+    same _ = False
+
+
 body :: GHC.PackageKey -> SrcMap -> [RichToken] -> Html
-body pkg srcs = Html.body . Html.pre . mconcat . map (richToken pkg srcs)
+body pkg srcs tokens =
+    Html.body . Html.pre $ hypsrc
+  where
+    hypsrc = mconcat . map (tokenGroup pkg srcs) . groupTokens $ tokens
+
 
 header :: Maybe FilePath -> Maybe FilePath -> Html
 header mcss mjs
@@ -47,20 +78,29 @@ header mcss mjs =
         , Html.src scriptFile
         ]
 
-richToken :: GHC.PackageKey -> SrcMap -> RichToken -> Html
-richToken _ _ (RichToken tok Nothing) =
+
+tokenGroup :: GHC.PackageKey -> SrcMap -> TokenGroup -> Html
+tokenGroup _ _ (GrpNormal tok) =
     tokenSpan tok ! attrs
   where
     attrs = [ multiclass . tokenStyle . tkType $ tok ]
-richToken pkg srcs (RichToken tok (Just det)) =
+tokenGroup pkg srcs (GrpRich det tokens) =
     externalAnchor det . internalAnchor det . hyperlink pkg srcs det $ content
   where
-    content = tokenSpan tok ! [ multiclass style]
+    content = mconcat . map (richToken det) $ tokens
+
+
+richToken :: TokenDetails -> Token -> Html
+richToken det tok =
+    tokenSpan tok ! [ multiclass style ]
+  where
     style = (tokenStyle . tkType) tok ++ richTokenStyle det
 
+
 tokenSpan :: Token -> Html
 tokenSpan = Html.thespan . Html.toHtml . tkValue
 
+
 richTokenStyle :: TokenDetails -> [StyleClass]
 richTokenStyle (RtkVar _) = ["hs-var"]
 richTokenStyle (RtkType _) = ["hs-type"]
-- 
cgit v1.2.3