From bbd036ad309c95ce70affa5aa0a77a61aa5569c8 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 6 Jul 2015 17:06:19 +0200
Subject: Add support for hyperlinking modules in import lists.

---
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs    | 21 +++++++++------------
 .../src/Haddock/Backends/Hyperlinker/Types.hs       | 10 +++++++---
 2 files changed, 16 insertions(+), 15 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

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)
-- 
cgit v1.2.3