aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends
diff options
context:
space:
mode:
authorAlec Theriault <alec.theriault@gmail.com>2018-05-08 02:15:45 -0700
committerSimon Jakobi <simon.jakobi@gmail.com>2018-06-13 23:39:30 +0200
commit276c352b5dd3dd52b333e0d04ea71f7686ecd7b9 (patch)
treee12c9454772e217e095d1adc5c8a8c61c8305bee /haddock-api/src/Haddock/Backends
parent00c401b965e1468aee71caa4cffd049cadd515d8 (diff)
Remove 'TokenGroup' from Hyperlinker (#818)
Since the hyperlinker backend now relies on the GHC tokenizer, something like 'Bar.Baz.foo' already gets bunched together into one token (as opposed to being spread across 'Bar', '.', 'Baz', '.', and 'foo').
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs64
1 files changed, 14 insertions, 50 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 5291220a..d7ea70a6 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -1,6 +1,5 @@
{-# LANGUAGE RecordWildCards #-}
-
module Haddock.Backends.Hyperlinker.Renderer (render) where
@@ -28,36 +27,10 @@ render :: Maybe FilePath -> Maybe FilePath -> SrcMap -> [RichToken]
-> Html
render mcss mjs srcs tokens = header mcss mjs <> body 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 :: SrcMap -> [RichToken] -> Html
-body srcs tokens =
- Html.body . Html.pre $ hypsrc
+body srcs tokens = Html.body . Html.pre $ hypsrc
where
- hypsrc = mconcat . map (tokenGroup srcs) . groupTokens $ tokens
+ hypsrc = mconcat . map (richToken srcs) $ tokens
header :: Maybe FilePath -> Maybe FilePath -> Html
@@ -78,29 +51,20 @@ header mcss mjs =
, Html.src scriptFile
]
-
-tokenGroup :: SrcMap -> TokenGroup -> Html
-tokenGroup _ (GrpNormal tok@(Token { .. }))
+-- | Given information about the source position of definitions, render a token
+richToken :: SrcMap -> RichToken -> Html
+richToken srcs (RichToken Token{..} details)
| tkType == TkSpace = renderSpace (GHC.srcSpanStartLine tkSpan) tkValue
- | otherwise = tokenSpan tok ! attrs
- where
- attrs = [ multiclass . tokenStyle $ tkType ]
-tokenGroup srcs (GrpRich det tokens) =
- externalAnchor det . internalAnchor det . hyperlink srcs det $ content
+ | otherwise = linked content
where
- 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
-
+ content = tokenSpan ! [ multiclass style ]
+ tokenSpan = Html.thespan (Html.toHtml tkValue)
+ style = tokenStyle tkType ++ maybe [] richTokenStyle details
+
+ -- If we have name information, we can make links
+ linked = case details of
+ Just d -> externalAnchor d . internalAnchor d . hyperlink srcs d
+ Nothing -> id
richTokenStyle :: TokenDetails -> [StyleClass]
richTokenStyle (RtkVar _) = ["hs-var"]