[commit: haddock] master: Add dummy support for hyperlinking named tokens. (cb3ece1)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/haddock

On branch  : master
Link       : http://git.haskell.org/haddock.git/commitdiff/cb3ece1a493eb444ccb61b6ad3c74e922184b63e

>---------------------------------------------------------------

commit cb3ece1a493eb444ccb61b6ad3c74e922184b63e
Author: Łukasz Hanuszczak <lukasz.hanuszczak at gmail.com>
Date:   Sat Jun 6 21:43:15 2015 +0200

    Add dummy support for hyperlinking named tokens.


>---------------------------------------------------------------

cb3ece1a493eb444ccb61b6ad3c74e922184b63e
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 23 +++++++++++++++++++---
 1 file 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 39d7d18..32d2c86 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