Add dummy support for hyperlinking named tokens.

1 files changed, 20 insertions, 3 deletions

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 39d7d183..32d2c863 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -1,16 +1,20 @@
 module Haddock.Backends.Hyperlinker.Renderer where
 
 import Haddock.Backends.Hyperlinker.Parser
+import Haddock.Backends.Hyperlinker.Ast
+
+import qualified GHC
+import qualified Name as GHC
 
 import Data.Monoid
 import Text.XHtml (Html, HtmlAttr, (!))
 import qualified Text.XHtml as Html
 
-render :: Maybe FilePath -> [Token] -> Html
+render :: Maybe FilePath -> [RichToken] -> Html
 render css tokens = header css <> body tokens
 
-body :: [Token] -> Html
-body = Html.body . Html.pre . mconcat . map token
+body :: [RichToken] -> Html
+body = Html.body . Html.pre . mconcat . map richToken
 
 header :: Maybe FilePath -> Html
 header Nothing = Html.noHtml
@@ -23,6 +27,10 @@ header (Just css) =
         , Html.thetype "text/css"
         ]
 
+richToken :: RichToken -> Html
+richToken (RichToken t Nothing) = token t
+richToken (RichToken t (Just name)) = Html.anchor (token t) ! nameAttrs name
+
 token :: Token -> Html
 token (Token t v _) = Html.thespan (Html.toHtml v) ! tokenAttrs t
 
@@ -40,3 +48,12 @@ tokenAttrs TkComment = [Html.theclass "hs-comment"]
 tokenAttrs TkCpp = [Html.theclass "hs-cpp"]
 tokenAttrs TkPragma = [Html.theclass "hs-pragma"]
 tokenAttrs TkUnknown = []
+
+nameAttrs :: GHC.Name -> [HtmlAttr]
+nameAttrs name =
+    [ Html.href (maybe "" id mmod ++ "#" ++ ident)
+    , Html.theclass "varid-reference"
+    ]
+  where
+    mmod = GHC.moduleNameString . GHC.moduleName <$> GHC.nameModule_maybe name
+    ident = GHC.occNameString . GHC.nameOccName $ name