aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api')
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs1
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs50
2 files changed, 46 insertions, 5 deletions
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"]