{-# LANGUAGE RecordWildCards #-}
module Haddock.Backends.Hyperlinker.Renderer (render) where
import Haddock.Backends.Hyperlinker.Types
import Haddock.Backends.Hyperlinker.Utils
import qualified GHC
import qualified Name as GHC
import qualified Unique as GHC
import System.FilePath.Posix ((</>))
import Data.List
import Data.Maybe
import Data.Monoid
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 -> 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
where
hypsrc = mconcat . map (tokenGroup srcs) . groupTokens $ tokens
header :: Maybe FilePath -> Maybe FilePath -> Html
header mcss mjs
| isNothing mcss && isNothing mjs = Html.noHtml
header mcss mjs =
Html.header $ css mcss <> js mjs
where
css Nothing = Html.noHtml
css (Just cssFile) = Html.thelink Html.noHtml !
[ Html.rel "stylesheet"
, Html.thetype "text/css"
, Html.href cssFile
]
js Nothing = Html.noHtml
js (Just scriptFile) = Html.script Html.noHtml !
[ Html.thetype "text/javascript"
, Html.src scriptFile
]
tokenGroup :: SrcMap -> TokenGroup -> Html
tokenGroup _ (GrpNormal tok@(Token { .. }))
| tkType == TkSpace = renderSpace (posRow . spStart $ tkSpan) tkValue
| otherwise = tokenSpan tok ! attrs
where
attrs = [ multiclass . tokenStyle $ tkType ]
tokenGroup srcs (GrpRich det tokens) =
externalAnchor det . internalAnchor det . hyperlink srcs det $ 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
richTokenStyle :: TokenDetails -> [StyleClass]
richTokenStyle (RtkVar _) = ["hs-var"]
richTokenStyle (RtkType _) = ["hs-type"]
richTokenStyle _ = []
tokenStyle :: TokenType -> [StyleClass]
tokenStyle TkIdentifier = ["hs-identifier"]
tokenStyle TkKeyword = ["hs-keyword"]
tokenStyle TkString = ["hs-string"]
tokenStyle TkChar = ["hs-char"]
tokenStyle TkNumber = ["hs-number"]
tokenStyle TkOperator = ["hs-operator"]
tokenStyle TkGlyph = ["hs-glyph"]
tokenStyle TkSpecial = ["hs-special"]
tokenStyle TkSpace = []
tokenStyle TkComment = ["hs-comment"]
tokenStyle TkCpp = ["hs-cpp"]
tokenStyle TkPragma = ["hs-pragma"]
tokenStyle TkUnknown = []
multiclass :: [StyleClass] -> HtmlAttr
multiclass = Html.theclass . intercalate " "
externalAnchor :: TokenDetails -> Html -> Html
externalAnchor (RtkDecl name) content =
Html.anchor content ! [ Html.name $ externalAnchorIdent name ]
externalAnchor _ content = content
internalAnchor :: TokenDetails -> Html -> Html
internalAnchor (RtkBind name) content =
Html.anchor content ! [ Html.name $ internalAnchorIdent name ]
internalAnchor _ content = content
externalAnchorIdent :: GHC.Name -> String
externalAnchorIdent = hypSrcNameUrl
internalAnchorIdent :: GHC.Name -> String
internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique
hyperlink :: SrcMap -> TokenDetails -> Html -> Html
hyperlink srcs details = case rtkName details of
Left name ->
if GHC.isInternalName name
then internalHyperlink name
else externalNameHyperlink srcs name
Right name -> externalModHyperlink srcs name
internalHyperlink :: GHC.Name -> Html -> Html
internalHyperlink name content =
Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
externalNameHyperlink :: SrcMap -> GHC.Name -> Html -> Html
externalNameHyperlink (srcs, _) name content = case Map.lookup mdl srcs of
Just SrcLocal -> Html.anchor content !
[ Html.href $ hypSrcModuleNameUrl mdl name ]
Just (SrcExternal path) -> Html.anchor content !
[ Html.href $ path </> hypSrcModuleNameUrl mdl name ]
Nothing -> content
where
mdl = GHC.nameModule name
externalModHyperlink :: SrcMap -> GHC.ModuleName -> Html -> Html
externalModHyperlink (_, srcs) name content = case Map.lookup name srcs of
Just SrcLocal -> Html.anchor content !
[ Html.href $ hypSrcModuleUrl' name ]
Just (SrcExternal path) -> Html.anchor content !
[ Html.href $ path </> hypSrcModuleUrl' name ]
Nothing -> content
renderSpace :: Int -> String -> Html
renderSpace _ [] = Html.noHtml
renderSpace line ('\n':rest) = mconcat
[ Html.thespan . Html.toHtml $ "\n"
, lineAnchor (line + 1)
, renderSpace (line + 1) rest
]
renderSpace line space =
let (hspace, rest) = span (/= '\n') space
in (Html.thespan . Html.toHtml) hspace <> renderSpace line rest
lineAnchor :: Int -> Html
lineAnchor line = Html.anchor Html.noHtml ! [ Html.name $ hypSrcLineUrl line ]