aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--haddock-api/src/Haddock.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs21
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs10
3 files changed, 17 insertions, 16 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index d4d8e3e6..350a73ea 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -268,7 +268,7 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
| Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat
| otherwise = srcModule
- srcMap = Map.union
+ srcMap = mkSrcMap $ Map.union
(Map.map SrcExternal extSrcMap)
(Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ])
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 1065897d..5037421a 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -144,14 +144,14 @@ hyperlink srcs details = case rtkName details of
if GHC.isInternalName name
then internalHyperlink name
else externalNameHyperlink srcs name
- Right name -> externalModHyperlink name
+ Right name -> externalModHyperlink srcs name
internalHyperlink :: GHC.Name -> Html -> Html
internalHyperlink name content =
Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
externalNameHyperlink :: SrcMap -> GHC.Name -> Html -> Html
-externalNameHyperlink srcs name content = case Map.lookup mdl srcs of
+externalNameHyperlink (srcs, _) name content = case Map.lookup mdl srcs of
Just SrcLocal -> Html.anchor content !
[ Html.href $ hypSrcModuleNameUrl mdl name ]
Just (SrcExternal path) -> Html.anchor content !
@@ -160,13 +160,10 @@ externalNameHyperlink srcs name content = case Map.lookup mdl srcs of
where
mdl = GHC.nameModule name
--- TODO: Implement module hyperlinks.
---
--- Unfortunately, 'ModuleName' is not enough to provide viable cross-package
--- hyperlink. And the problem is that GHC AST does not have other information
--- on imported modules, so for the time being, we do not provide such reference
--- either.
-externalModHyperlink :: GHC.ModuleName -> Html -> Html
-externalModHyperlink _ content =
- content
- --Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ]
+externalModHyperlink :: SrcMap -> GHC.ModuleName -> Html -> Html
+externalModHyperlink (_, srcs) name content = case Map.lookup name srcs of
+ Just SrcLocal -> Html.anchor content !
+ [ Html.href $ hypSrcModuleUrl' name ]
+ Just (SrcExternal path) -> Html.anchor content !
+ [ Html.href $ path </> hypSrcModuleUrl' name ]
+ Nothing -> content
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
index ecb51a07..c3954dc9 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
@@ -4,6 +4,7 @@ module Haddock.Backends.Hyperlinker.Types where
import qualified GHC
import Data.Map (Map)
+import qualified Data.Map as Map
data Token = Token
@@ -66,7 +67,10 @@ rtkName (RtkModule name) = Right name
-- Used in 'SrcMap' to determine whether module originates in current package
-- or in an external package.
data SrcPath
- = SrcExternal FilePath
- | SrcLocal
+ = SrcExternal FilePath
+ | SrcLocal
-type SrcMap = Map GHC.Module SrcPath
+type SrcMap = (Map GHC.Module SrcPath, Map GHC.ModuleName SrcPath)
+
+mkSrcMap :: Map GHC.Module SrcPath -> SrcMap
+mkSrcMap srcs = (srcs, Map.mapKeys GHC.moduleName srcs)