Finalize support for links to other packages

2 files changed, 28 insertions, 5 deletions

diff --git a/src/Haddock/Rename.hs b/src/Haddock/Rename.hs
index 6ba07215..5ac711cb 100644
--- a/src/Haddock/Rename.hs
+++ b/src/Haddock/Rename.hs
@@ -12,6 +12,7 @@ module Haddock.Rename (
 import Haddock.Types
 
 import GHC hiding ( NoLink )
+import Name
 import BasicTypes
 import SrcLoc 
 import Bag ( emptyBag )
@@ -20,6 +21,7 @@ import Data.Map ( Map )
 import qualified Data.Map as Map hiding ( Map )
 import Prelude hiding ( mapM )
 import Data.Traversable ( mapM )
+import Control.Arrow
 
 -- -----------------------------------------------------------------------------
 -- Monad for renaming
@@ -58,14 +60,22 @@ lookupRn and_then name = do
 	(False,maps_to) -> do outRn name; return (and_then maps_to)
 	(True, maps_to) -> return (and_then maps_to)
 
+newtype OrdName = MkOrdName Name
+
+instance Eq OrdName where
+  (MkOrdName a) == (MkOrdName b) = a == b
+
+instance Ord OrdName where
+  (MkOrdName a) `compare` (MkOrdName b) = nameOccName a `compare` nameOccName b
+
 runRnFM :: Map Name Name -> RnM a -> (a,[Name])
 runRnFM env rn = unRn rn lkp 
-  where lkp n = case Map.lookup n env of
-		  Nothing -> (False, NoLink n) 
-		  Just q  -> (True,  Link q)
+  where 
+    lkp n = case Map.lookup (MkOrdName n) ordEnv of
+      Nothing -> (False, NoLink n) 
+      Just (MkOrdName q)  -> (True, Link q)
 
-runRn :: (n -> (Bool,DocName)) -> GenRnM n a -> (a,[n])
-runRn lkp rn = unRn rn lkp
+    ordEnv = Map.fromList . map (MkOrdName *** MkOrdName) . Map.toList $ env
 
 -- -----------------------------------------------------------------------------
 -- Renaming 
diff --git a/src/Haddock/Utils/GHC.hs b/src/Haddock/Utils/GHC.hs
index b6fb54d4..4799734e 100644
--- a/src/Haddock/Utils/GHC.hs
+++ b/src/Haddock/Utils/GHC.hs
@@ -7,6 +7,9 @@ import HsSyn
 import SrcLoc
 import HscTypes
 import Outputable
+import Packages
+import UniqFM
+import Name
 
 getMainDeclBinder :: HsDecl name -> Maybe name
 getMainDeclBinder (TyClD d) = Just (tcdName d)
@@ -24,3 +27,13 @@ getMainDeclBinder _ = Nothing
 --modInfoMod  = mi_module . minf_iface 
 
 trace_ppr x y = trace (showSDoc (ppr x)) y
+
+-- names
+
+nameSetMod n newMod = 
+  mkExternalName (nameUnique n) newMod (nameOccName n) (nameSrcSpan n)
+
+nameSetPkg pkgId n = 
+  mkExternalName (nameUnique n) (mkModule pkgId (moduleName mod)) 
+	               (nameOccName n) (nameSrcSpan n)
+  where mod = nameModule n