Refactor source path mapping to use modules as indices.

4 files changed, 38 insertions, 33 deletions

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index 1fadef49..f007f970 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -8,7 +8,6 @@ import Haddock.Backends.Hyperlinker.Renderer
 import Haddock.Backends.Hyperlinker.Utils
 
 import Text.XHtml hiding ((</>))
-import GHC
 
 import Data.Maybe
 import System.Directory
@@ -24,30 +23,28 @@ ppHyperlinkedSource :: FilePath -- ^ Output directory
                     -> FilePath -- ^ Resource directory
                     -> Maybe FilePath -- ^ Custom CSS file path
                     -> Bool -- ^ Flag indicating whether to pretty-print HTML
-                    -> PackageKey -- ^ Package for which we create source
-                    -> SrcMap -- ^ Paths to external sources
+                    -> SrcMap -- ^ Paths to sources
                     -> [Interface] -- ^ Interfaces for which we create source
                     -> IO ()
-ppHyperlinkedSource outdir libdir mstyle pretty pkg srcs ifaces = do
+ppHyperlinkedSource outdir libdir mstyle pretty srcs ifaces = do
     createDirectoryIfMissing True srcdir
     let cssFile = fromMaybe (defaultCssFile libdir) mstyle
     copyFile cssFile $ srcdir </> srcCssFile
     copyFile (libdir </> "html" </> highlightScript) $
         srcdir </> highlightScript
-    mapM_ (ppHyperlinkedModuleSource srcdir pretty pkg srcs) ifaces
+    mapM_ (ppHyperlinkedModuleSource srcdir pretty srcs) ifaces
   where
     srcdir = outdir </> hypSrcDir
 
 -- | Generate hyperlinked source for particular interface.
-ppHyperlinkedModuleSource :: FilePath -> Bool
-                          -> PackageKey -> SrcMap -> Interface
+ppHyperlinkedModuleSource :: FilePath -> Bool -> SrcMap -> Interface
                           -> IO ()
-ppHyperlinkedModuleSource srcdir pretty pkg srcs iface =
+ppHyperlinkedModuleSource srcdir pretty srcs iface =
     case ifaceTokenizedSrc iface of
         Just tokens -> writeFile path . html . render' $ tokens
         Nothing -> return ()
   where
-    render' = render (Just srcCssFile) (Just highlightScript) pkg srcs
+    render' = render (Just srcCssFile) (Just highlightScript) srcs
     html = if pretty then renderHtml else showHtml
     path = srcdir </> hypSrcModuleFile (ifaceMod iface)
 
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index ddb2e5b9..a4d7bc2d 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -23,10 +23,9 @@ import qualified Text.XHtml as Html
 type StyleClass = String
 
 
-render :: Maybe FilePath -> Maybe FilePath
-       -> GHC.PackageKey -> SrcMap -> [RichToken]
+render :: Maybe FilePath -> Maybe FilePath -> SrcMap -> [RichToken]
        -> Html
-render mcss mjs pkg srcs tokens = header mcss mjs <> body pkg srcs tokens
+render mcss mjs srcs tokens = header mcss mjs <> body srcs tokens
 
 
 data TokenGroup
@@ -53,11 +52,11 @@ groupTokens ((RichToken tok (Just det)):rest) =
     same _ = False
 
 
-body :: GHC.PackageKey -> SrcMap -> [RichToken] -> Html
-body pkg srcs tokens =
+body :: SrcMap -> [RichToken] -> Html
+body srcs tokens =
     Html.body . Html.pre $ hypsrc
   where
-    hypsrc = mconcat . map (tokenGroup pkg srcs) . groupTokens $ tokens
+    hypsrc = mconcat . map (tokenGroup srcs) . groupTokens $ tokens
 
 
 header :: Maybe FilePath -> Maybe FilePath -> Html
@@ -79,13 +78,13 @@ header mcss mjs =
         ]
 
 
-tokenGroup :: GHC.PackageKey -> SrcMap -> TokenGroup -> Html
-tokenGroup _ _ (GrpNormal tok) =
+tokenGroup :: SrcMap -> TokenGroup -> Html
+tokenGroup _ (GrpNormal tok) =
     tokenSpan tok ! attrs
   where
     attrs = [ multiclass . tokenStyle . tkType $ tok ]
-tokenGroup pkg srcs (GrpRich det tokens) =
-    externalAnchor det . internalAnchor det . hyperlink pkg srcs det $ content
+tokenGroup srcs (GrpRich det tokens) =
+    externalAnchor det . internalAnchor det . hyperlink srcs det $ content
   where
     content = mconcat . map (richToken det) $ tokens
 
@@ -140,28 +139,27 @@ externalAnchorIdent = hypSrcNameUrl
 internalAnchorIdent :: GHC.Name -> String
 internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique
 
-hyperlink :: GHC.PackageKey -> SrcMap -> TokenDetails -> Html -> Html
-hyperlink pkg srcs details = case rtkName details of
+hyperlink :: SrcMap -> TokenDetails -> Html -> Html
+hyperlink srcs details = case rtkName details of
     Left name ->
         if GHC.isInternalName name
         then internalHyperlink name
-        else externalNameHyperlink pkg srcs name
+        else externalNameHyperlink srcs name
     Right name -> externalModHyperlink name
 
 internalHyperlink :: GHC.Name -> Html -> Html
 internalHyperlink name content =
     Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
 
-externalNameHyperlink :: GHC.PackageKey -> SrcMap -> GHC.Name -> Html -> Html
-externalNameHyperlink pkg srcs name content
-    | namePkg == pkg = Html.anchor content !
+externalNameHyperlink :: SrcMap -> GHC.Name -> Html -> Html
+externalNameHyperlink srcs name content = case Map.lookup mdl srcs of
+    Just SrcLocal -> Html.anchor content !
         [ Html.href $ hypSrcModuleNameUrl mdl name ]
-    | Just path <- Map.lookup namePkg srcs = Html.anchor content !
+    Just (SrcExternal path) -> Html.anchor content !
         [ Html.href $ path </> hypSrcModuleNameUrl mdl name ]
-    | otherwise = content
+    Nothing -> content
   where
     mdl = GHC.nameModule name
-    namePkg = GHC.modulePackageKey mdl
 
 -- TODO: Implement module hyperlinks.
 --
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 4b39d315..d5762ce8 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -14,7 +14,7 @@
 -- Reading and writing the .haddock interface file
 -----------------------------------------------------------------------------
 module Haddock.InterfaceFile (
-  InterfaceFile(..), ifPackageKey,
+  InterfaceFile(..), ifModule, ifPackageKey,
   readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor,
   writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility
 ) where
@@ -51,11 +51,14 @@ data InterfaceFile = InterfaceFile {
 }
 
 
-ifPackageKey :: InterfaceFile -> PackageKey
-ifPackageKey if_ =
+ifModule :: InterfaceFile -> Module
+ifModule if_ =
   case ifInstalledIfaces if_ of
     [] -> error "empty InterfaceFile"
-    iface:_ -> modulePackageKey $ instMod iface
+    iface:_ -> instMod iface
+
+ifPackageKey :: InterfaceFile -> PackageKey
+ifPackageKey = modulePackageKey . ifModule
 
 
 binaryInterfaceMagic :: Word32
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index fbb5f44c..da4b3eec 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -50,7 +50,7 @@ type SubMap        = Map Name [Name]
 type DeclMap       = Map Name [LHsDecl Name]
 type InstMap       = Map SrcSpan Name
 type FixMap        = Map Name Fixity
-type SrcMap        = Map PackageKey FilePath
+type SrcMap        = Map Module SrcPath
 type DocPaths      = (FilePath, Maybe FilePath) -- paths to HTML and sources
 
 
@@ -271,6 +271,13 @@ unrenameDocForDecl (doc, fnArgsDoc) =
 -- | Type of environment used to cross-reference identifiers in the syntax.
 type LinkEnv = Map Name Module
 
+-- | Path for making cross-package hyperlinks in generated sources.
+--
+-- Used in 'SrcMap' to determine whether module originates in current package
+-- or in an external package.
+data SrcPath
+  = SrcExternal FilePath
+  | SrcLocal
 
 -- | Extends 'Name' with cross-reference information.
 data DocName