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/Ast.hs | 21 ++++++++++++++++-----
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs    | 14 +++++++++++---
 2 files changed, 27 insertions(+), 8 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 2749096e..39bbacf5 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -28,6 +28,7 @@ data RichTokenType
     = RtkVar
     | RtkType
     | RtkBind
+    | RtkDecl
 
 enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
 enrich src =
@@ -36,11 +37,12 @@ enrich src =
         , rtkDetails = enrichToken token detailsMap
         }
   where
-    detailsMap = concat
-        [ variables src
-        , types src
-        , binds src
-        , imports src
+    detailsMap = concatMap ($ src)
+        [ variables
+        , types
+        , binds
+        , imports
+        , decls
         ]
 
 type DetailsMap = [(GHC.SrcSpan, TokenDetails)]
@@ -91,6 +93,15 @@ binds =
             pure (sspan, TokenDetails RtkBind name)
         _ -> empty
 
+decls :: GHC.RenamedSource -> DetailsMap
+decls (group, _, _, _) = concatMap ($ group)
+    [ map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds
+    ]
+  where
+    typ (GHC.L _ t) =
+        let (GHC.L sspan name) = GHC.tcdLName t
+        in (sspan, TokenDetails RtkDecl name)
+
 imports :: GHC.RenamedSource -> DetailsMap
 imports =
     everything (<|>) ie
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