diff options
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 64 |
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"] |