From a85224a68b51b70035446ad8e5565d571c4a10d4 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 17 Jun 2015 22:22:49 +0200
Subject: Implement hyperlinking of imported module names.

---
 .../src/Haddock/Backends/Hyperlinker/Ast.hs        | 19 +++++++++------
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 28 +++++++++++++---------
 2 files changed, 29 insertions(+), 18 deletions(-)

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

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