From 162b02ed6f50709ea203bf7706eee5804e455419 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 12 Jun 2015 01:03:13 +0200
Subject: Add support for type declaration anchors.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 14 +++++++++++---
 1 file changed, 11 insertions(+), 3 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 995e24e6..b7cc5aeb 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -38,7 +38,7 @@ richToken (RichToken tok Nothing) =
   where
     attrs = [ multiclass . tokenStyle . tkType $ tok ]
 richToken (RichToken tok (Just det)) =
-    internalAnchor det . hyperlink det $ content
+    externalAnchor det . internalAnchor det . hyperlink det $ content
   where
     content = tokenSpan tok ! [ multiclass style]
     style = (tokenStyle . tkType) tok ++ (richTokenStyle . rtkType) det
@@ -49,7 +49,7 @@ tokenSpan = Html.thespan . Html.toHtml . tkValue
 richTokenStyle :: RichTokenType -> [StyleClass]
 richTokenStyle RtkVar = ["hs-var"]
 richTokenStyle RtkType = ["hs-type"]
-richTokenStyle RtkBind = []
+richTokenStyle _ = []
 
 tokenStyle :: TokenType -> [StyleClass]
 tokenStyle TkIdentifier = ["hs-identifier"]
@@ -69,11 +69,19 @@ tokenStyle TkUnknown = []
 multiclass :: [StyleClass] -> HtmlAttr
 multiclass = Html.theclass . intercalate " "
 
+externalAnchor :: TokenDetails -> Html -> Html
+externalAnchor (TokenDetails RtkDecl name) content =
+    Html.anchor content ! [ Html.name $ externalAnchorIdent name ]
+externalAnchor _ content = content
+
 internalAnchor :: TokenDetails -> Html -> Html
 internalAnchor (TokenDetails RtkBind name) content =
     Html.anchor content ! [ Html.name $ internalAnchorIdent name ]
 internalAnchor _ content = content
 
+externalAnchorIdent :: GHC.Name -> String
+externalAnchorIdent = GHC.occNameString . GHC.nameOccName
+
 internalAnchorIdent :: GHC.Name -> String
 internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique
 
@@ -91,4 +99,4 @@ externalHyperlink name content =
     Html.anchor content ! [ Html.href $ maybe "" id mmod ++ "#" ++ ident ]
   where
     mmod = GHC.moduleNameString . GHC.moduleName <$> GHC.nameModule_maybe name
-    ident = GHC.occNameString . GHC.nameOccName $ name
+    ident = externalAnchorIdent name
-- 
cgit v1.2.3