diff options
| -rw-r--r-- | haddock-api/src/Haddock.hs | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 21 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs | 10 |
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) |