aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src
diff options
context:
space:
mode:
authorŁukasz Hanuszczak <lukasz.hanuszczak@gmail.com>2015-06-12 01:03:13 +0200
committerŁukasz Hanuszczak <lukasz.hanuszczak@gmail.com>2015-06-30 22:37:49 +0200
commit162b02ed6f50709ea203bf7706eee5804e455419 (patch)
tree81e703c37d31d2c254e51bae889cae7ca9fcc76d /haddock-api/src
parentb31513dbacb48102b4c5d2fd6de1982161d81fae (diff)
Add support for type declaration anchors.
Diffstat (limited to 'haddock-api/src')
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs21
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs14
2 files changed, 27 insertions, 8 deletions
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