1 files changed, 189 insertions, 0 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
new file mode 100644
index 00000000..15793f0c
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -0,0 +1,189 @@
+{-# 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 ]