From c3d370ad042eeeb9f8afc3bf3e99cbbcb9407d60 Mon Sep 17 00:00:00 2001
From: Henning Thielemann <git@henning-thielemann.de>
Date: Mon, 2 Apr 2012 00:19:36 +0200
Subject: abbreviated qualification: use Packages.lookupModuleInAllPackages for
 finding the package that a module belongs to

---
 src/Haddock/Backends/Xhtml/Names.hs |  2 +-
 src/Haddock/Interface/Create.hs     | 41 ++++++++++++++++++++++++++++---------
 src/Haddock/Types.hs                |  2 +-
 3 files changed, 33 insertions(+), 12 deletions(-)

diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs
index 88ba14dc..863e5f90 100644
--- a/src/Haddock/Backends/Xhtml/Names.hs
+++ b/src/Haddock/Backends/Xhtml/Names.hs
@@ -81,7 +81,7 @@ ppQualifyName qual name mdl =
         Nothing      -> ppFullQualName mdl name
     AbbreviateQual abbrevs localmdl ->
       case (moduleString mdl == moduleString localmdl,
-            M.lookup (moduleName mdl) abbrevs) of
+            M.lookup mdl abbrevs) of
         (False, Just abbrev) -> ppQualName abbrev name
         _ -> ppName name
 
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 9f183432..b9ca6d8c 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -30,6 +30,8 @@ import Control.Applicative
 import Control.Monad
 import qualified Data.Traversable as T
 
+import qualified Packages
+import qualified Module
 import qualified SrcLoc
 import GHC hiding (flags)
 import HscTypes
@@ -108,16 +110,7 @@ createInterface tm flags modMap instIfaceMap = do
         | otherwise = exportItems
 
   let abbrevs =
-        case tm_renamed_source tm of
-          Nothing -> M.empty
-          Just (_,impDecls,_,_) ->
-            M.fromList $
-            mapMaybe (\(SrcLoc.L _ impDecl) -> do
-              abbrev <- ideclAs impDecl
-              return
-                (case ideclName impDecl of SrcLoc.L _ name -> name,
-                 abbrev))
-              impDecls
+        mkAbbrevMap dflags $ tm_renamed_source tm
 
   return Interface {
     ifaceMod             = mdl,
@@ -141,6 +134,34 @@ createInterface tm flags modMap instIfaceMap = do
     ifaceHaddockCoverage = coverage
   }
 
+mkAbbrevMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName
+mkAbbrevMap dflags mRenamedSource =
+  case mRenamedSource of
+    Nothing -> M.empty
+    Just (_,impDecls,_,_) ->
+      M.fromList $
+      mapMaybe (\(SrcLoc.L _ impDecl) -> do
+        abbrev <- ideclAs impDecl
+        return $
+          (lookupModuleDyn dflags
+             (fmap Module.fsToPackageId $
+              ideclPkgQual impDecl)
+             (case ideclName impDecl of SrcLoc.L _ name -> name),
+           abbrev))
+        impDecls
+
+-- similar to GHC.lookupModule
+lookupModuleDyn ::
+  DynFlags -> Maybe PackageId -> ModuleName -> Module
+lookupModuleDyn _ (Just pkgId) mdlName =
+  Module.mkModule pkgId mdlName
+lookupModuleDyn dflags Nothing mdlName =
+  flip Module.mkModule mdlName $
+  case filter snd $
+       Packages.lookupModuleInAllPackages dflags mdlName of
+    (pkgId,_):_ -> Packages.packageConfigId pkgId
+    [] -> Module.mainPackageId
+
 
 -------------------------------------------------------------------------------
 -- Warnings
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 2195faf5..7a6d7bb9 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -390,7 +390,7 @@ data QualOption
                       --   Image a re-export of a whole module,
                       --   how could the re-exported identifiers be qualified?
 
-type AbbreviationMap = Map ModuleName ModuleName
+type AbbreviationMap = Map Module ModuleName
 
 data Qualification
   = NoQual
-- 
cgit v1.2.3