diff options
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 21 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 14 |
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 |