aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src')
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs19
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs28
2 files changed, 29 insertions, 18 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 3c07ff3c..10389958 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -24,12 +24,14 @@ data TokenDetails
| RtkType GHC.Name
| RtkBind GHC.Name
| RtkDecl GHC.Name
+ | RtkModule GHC.ModuleName
-rtkName :: TokenDetails -> GHC.Name
-rtkName (RtkVar name) = name
-rtkName (RtkType name) = name
-rtkName (RtkBind name) = name
-rtkName (RtkDecl name) = name
+rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName
+rtkName (RtkVar name) = Left name
+rtkName (RtkType name) = Left name
+rtkName (RtkBind name) = Left name
+rtkName (RtkDecl name) = Left name
+rtkName (RtkModule name) = Right name
enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
enrich src =
@@ -109,8 +111,8 @@ decls (group, _, _, _) = concatMap ($ group)
_ -> empty
imports :: GHC.RenamedSource -> DetailsMap
-imports =
- everything (<|>) ie
+imports src@(_, imps, _, _) =
+ everything (<|>) ie src ++ map (imp . GHC.unLoc) imps
where
ie term = case cast term of
(Just (GHC.IEVar v)) -> pure $ var v
@@ -120,6 +122,9 @@ imports =
_ -> empty
typ (GHC.L sspan name) = (sspan, RtkType name)
var (GHC.L sspan name) = (sspan, RtkVar name)
+ imp idecl =
+ let (GHC.L sspan name) = GHC.ideclName idecl
+ in (sspan, RtkModule name)
matches :: Span -> GHC.SrcSpan -> Bool
matches tspan (GHC.RealSrcSpan aspan)
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index e08d8974..70524759 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -8,6 +8,7 @@ import qualified Name as GHC
import qualified Unique as GHC
import Data.List
+import Data.Maybe
import Data.Monoid
import Text.XHtml (Html, HtmlAttr, (!))
@@ -86,20 +87,25 @@ internalAnchorIdent :: GHC.Name -> String
internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique
hyperlink :: TokenDetails -> Html -> Html
-hyperlink details =
- if GHC.isInternalName $ name
- then internalHyperlink name
- else externalHyperlink name
- where
- name = rtkName details
+hyperlink details = case rtkName details of
+ Left name ->
+ if GHC.isInternalName name
+ then internalHyperlink name
+ else externalHyperlink mname (Just name)
+ where
+ mname = GHC.moduleName <$> GHC.nameModule_maybe name
+ Right name -> externalHyperlink (Just name) Nothing
internalHyperlink :: GHC.Name -> Html -> Html
internalHyperlink name content =
Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
-externalHyperlink :: GHC.Name -> Html -> Html
-externalHyperlink name content =
- Html.anchor content ! [ Html.href $ maybe "" id mmod ++ ".html#" ++ ident ]
+externalHyperlink :: Maybe GHC.ModuleName -> Maybe GHC.Name -> Html -> Html
+externalHyperlink mmname miname content =
+ Html.anchor content ! [ Html.href $ path ++ anchor ]
where
- mmod = GHC.moduleNameString . GHC.moduleName <$> GHC.nameModule_maybe name
- ident = externalAnchorIdent name
+ path = fromMaybe "" $ modulePath <$> mmname
+ anchor = fromMaybe "" $ ("#" ++) . externalAnchorIdent <$> miname
+
+modulePath :: GHC.ModuleName -> String
+modulePath name = GHC.moduleNameString name ++ ".html"