Change the representation of DocNames

Ross Paterson reported a bug where links would point to the defining module
instead of the "best" module for an identifier (e.g Int pointing to GHC.Base
instead of Data.Int). This patch fixes this problem by refactoring the way
renamed names are represented. Instead of representing them by:

> data DocName = Link Name | NoLink Name

they are now represented as such:

> data DocName = Documented Name Module | Undocumented Name

and the the link-env looks like this:

> type LinkEnv = Map Name Module

There are several reasons for this. First of all, the bug was caused by
changing the module part of Names during the renaming process, without changing
the Unique field. This caused names to be overwritten during the loading of
.haddock files (which caches names using the NameCache of the GHC session).
So we might create new Uniques during renaming to fix this (but I'm not
sure that would be problem-free). Instead, we just keep the Name and add the
Module where the name is best documented, since it can be useful to keep
the original Name around (for e.g. source-code location info and for users of
the Haddock API).

Also, the names Link/NoLink don't really make sense, since wether to use
links or not is entirely up to the users of DocName.

In the process of following this change into H.Backends.Html I removed the
assumption that binder names are Undocumented (which was just an unnecessary
assumption, the OccName is the only thing needed to render these). This will
probably make it possible to get rid of the renamer and replace it with a
traversal from SYB or Uniplate.

Since DocName has changed, InterfaceFile has changed so this patch also
increments the file-format version. No backwards-compatibility is implemented.

12 files changed, 141 insertions, 116 deletions

diff --git a/src/Haddock/Backends/DevHelp.hs b/src/Haddock/Backends/DevHelp.hs
index 85eb6399..3ba7baf3 100644
--- a/src/Haddock/Backends/DevHelp.hs
+++ b/src/Haddock/Backends/DevHelp.hs
@@ -12,7 +12,7 @@ import Haddock.Utils
 
 import Module        ( moduleName, moduleNameString, Module, mkModule, mkModuleName )
 import PackageConfig ( stringToPackageId )
-import Name          ( Name, nameModule, getOccString )
+import Name          ( Name, nameModule, getOccString, nameOccName )
 
 import Data.Maybe    ( fromMaybe )
 import qualified Data.Map as Map
@@ -77,5 +77,5 @@ ppDevHelpFile odir doctitle maybe_package modules = do
     ppReference :: Name -> [Module] -> Doc
     ppReference name [] = empty
     ppReference name (mod:refs) =  
-      text "<function name=\""<>text (escapeStr (getOccString name))<>text"\" link=\""<>text (nameHtmlRef mod name)<>text"\"/>" $$
+      text "<function name=\""<>text (escapeStr (getOccString name))<>text"\" link=\""<>text (nameHtmlRef mod (nameOccName name))<>text"\"/>" $$
       ppReference name refs
diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs
index cd35e9f6..45bffdcd 100644
--- a/src/Haddock/Backends/Html.hs
+++ b/src/Haddock/Backends/Html.hs
@@ -14,6 +14,7 @@ module Haddock.Backends.Html (
 
 import Prelude hiding (div)
 
+import Haddock.DocName
 import Haddock.Backends.DevHelp
 import Haddock.Backends.HH
 import Haddock.Backends.HH2
@@ -660,7 +661,7 @@ doDecl summary links x (L loc d) mbDoc instances docMap = doDecl d
   where
     doDecl (TyClD d) = doTyClD d 
     doDecl (SigD (TypeSig (L _ n) (L _ t))) = 
-      ppFunSig summary links loc mbDoc (getName n) t
+      ppFunSig summary links loc mbDoc (docNameOrig n) t
     doDecl (ForD d) = ppFor summary links loc mbDoc d
 
     doTyClD d0@(TyData {}) = ppDataDecl summary links instances x loc mbDoc d0
@@ -672,7 +673,8 @@ ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) ->
             Name -> HsType DocName -> HtmlTable
 ppFunSig summary links loc mbDoc name typ =
   ppTypeOrFunSig summary links loc name typ mbDoc 
-                 (ppTypeSig summary name typ, ppBinder False name, dcolon)
+    (ppTypeSig summary (nameOccName name) typ, 
+     ppBinder False (nameOccName name), dcolon)
 
 
 ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> Name -> HsType DocName ->
@@ -721,10 +723,10 @@ ppTypeOrFunSig summary links loc name typ doc (pref1, pref2, sep)
 ppTyVars tvs = ppTyNames (tyvarNames tvs)
 
 tyvarNames = map f 
-  where f x = let NoLink n = hsTyVarName (unLoc x) in n
+  where f x = docNameOrig . hsTyVarName . unLoc $ x
   
 ppFor summary links loc mbDoc (ForeignImport (L _ name) (L _ typ) _)
-  = ppFunSig summary links loc mbDoc (getName name) typ
+  = ppFunSig summary links loc mbDoc (docNameOrig name) typ
 ppFor _ _ _ _ _ = error "ppFor"
 
 -- we skip type patterns for now
@@ -732,12 +734,13 @@ ppTySyn summary links loc mbDoc (TySynonym (L _ name) ltyvars _ ltype)
   = ppTypeOrFunSig summary links loc n (unLoc ltype) mbDoc 
                    (full, hdr, spaceHtml +++ equals)
   where
-    hdr  = hsep ([keyword "type", ppBinder summary n] ++ ppTyVars ltyvars)
+    hdr  = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars)
     full = hdr <+> equals <+> ppLType ltype
-    NoLink n = name
+    n    = docNameOrig name
+    occ  = docNameOcc name
 
 
-ppTypeSig :: Bool -> Name -> HsType DocName -> Html
+ppTypeSig :: Bool -> OccName -> HsType DocName -> Html
 ppTypeSig summary nm ty = ppBinder summary nm <+> dcolon <+> ppType ty
 
 
@@ -762,7 +765,7 @@ ppAppNameTypes n ts = ppTypeApp n ts ppDocName ppParendType
 -- | Print an application of a DocName and a list of Names 
 ppDataClassHead :: Bool -> DocName -> [Name] -> Html
 ppDataClassHead summ n ns = 
-  ppTypeApp n ns (ppBinder summ . getName) ppTyName
+  ppTypeApp n ns (ppBinder summ . docNameOcc) ppTyName
 
 
 -- | General printing of type applications
@@ -771,7 +774,7 @@ ppTypeApp n ts@(t1:t2:rest) ppDN ppT
   | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest)
   | operator                    = opApp
   where
-    operator = isNameSym . getName $ n
+    operator = isNameSym . docNameOrig $ n
     opApp = ppT t1 <+> ppDN n <+> ppT t2
 
 ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts)
@@ -835,12 +838,12 @@ ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc
 	     vanillaTable << 
          aboves ([ ppAT summary at | L _ at <- ats ] ++
 	        [ ppFunSig summary links loc mbDoc n typ
-		          | L _ (TypeSig (L _ (NoLink n)) (L _ typ)) <- sigs
-              , let mbDoc = Map.lookup n docMap ])
+		          | L _ (TypeSig (L _ fname) (L _ typ)) <- sigs
+              , let n = docNameOrig fname, let mbDoc = Map.lookup n docMap ])
           )
   where
     hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds
-    NoLink nm = unLoc lname
+    nm  = docNameOrig . unLoc $ lname
     
     ppAT summary at = case at of
       TyData {} -> topDeclBox links loc nm (ppDataHeader summary at)
@@ -863,7 +866,7 @@ ppClassDecl summary links instances orig_c loc mbDoc docMap
       | null lsigs = topDeclBox links loc nm hdr
       | otherwise  = topDeclBox links loc nm (hdr <+> keyword "where")
 
-    NoLink nm = unLoc lname
+    nm   = docNameOrig . unLoc $ lname
     ctxt = unLoc lctxt
 
     hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds
@@ -877,9 +880,9 @@ ppClassDecl summary links instances orig_c loc mbDoc docMap
       | otherwise  = 
         s8 </> methHdr </>
         tda [theclass "body"] << vanillaTable << (
-          abovesSep s8 [ ppFunSig summary links loc mbDoc (orig n) typ
-                           | L _ (TypeSig n (L _ typ)) <- lsigs
-                           , let mbDoc = Map.lookup (orig n) docMap ]
+          abovesSep s8 [ ppFunSig summary links loc mbDoc (docNameOrig n) typ
+                           | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs
+                           , let mbDoc = Map.lookup (docNameOrig n) docMap ]
         )
 
     instId = collapseId nm
@@ -901,9 +904,6 @@ ppInstHead (ctxt, n, ts) = ppContextNoLocs ctxt <+> ppAppNameTypes n ts
 -- -----------------------------------------------------------------------------
 -- Data & newtype declarations
 
-orig (L _ (NoLink name)) = name
-orig _ = error "orig"
-
 
 -- TODO: print contexts
 ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> 
@@ -937,7 +937,7 @@ ppShortDataDecl summary links loc mbDoc dataDecl
     doConstr c con = declBox (toHtml [c] <+> ppShortConstr summary (unLoc con))
     doGADTConstr con = declBox (ppShortConstr summary (unLoc con))
 
-    name      = orig (tcdLName dataDecl)
+    name      = docNameOrig . unLoc . tcdLName $ dataDecl
     context   = unLoc (tcdCtxt dataDecl)
     newOrData = tcdND dataDecl
     tyVars    = tyvarNames (tcdTyVars dataDecl)
@@ -962,7 +962,7 @@ ppDataDecl summary links instances x loc mbDoc dataDecl
 
 
   where
-    name      = orig (tcdLName dataDecl)
+    name      = docNameOrig . unLoc . tcdLName $ dataDecl
     context   = unLoc (tcdCtxt dataDecl)
     newOrData = tcdND dataDecl
     tyVars    = tyvarNames (tcdTyVars dataDecl)
@@ -1019,11 +1019,11 @@ ppShortConstr :: Bool -> ConDecl DocName -> Html
 ppShortConstr summary con = case con_res con of 
 
   ResTyH98 -> case con_details con of 
-    PrefixCon args -> header +++ hsep (ppBinder summary name : map ppLType args)
-    RecCon fields -> header +++ ppBinder summary name <+>
+    PrefixCon args -> header +++ hsep (ppBinder summary occ : map ppLType args)
+    RecCon fields -> header +++ ppBinder summary occ <+>
       braces (vanillaTable << aboves (map (ppShortField summary) fields))
     InfixCon arg1 arg2 -> header +++ 
-      hsep [ppLType arg1, ppBinder summary name, ppLType arg2]    
+      hsep [ppLType arg1, ppBinder summary occ, ppLType arg2]    
 
   ResTyGADT resTy -> case con_details con of 
     PrefixCon args -> doGADTCon args resTy
@@ -1031,12 +1031,12 @@ ppShortConstr summary con = case con_res con of
     InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy 
     
   where
-    doGADTCon args resTy = ppBinder summary name <+> dcolon <+> hsep [
+    doGADTCon args resTy = ppBinder summary occ <+> dcolon <+> hsep [
                              ppForAll forall ltvs lcontext,
                              ppLType (foldr mkFunTy resTy args) ]
 
     header   = ppConstrHdr forall tyVars context
-    name     = orig (con_name con)
+    occ      = docNameOcc . unLoc . con_name $ con
     ltvs     = con_qvars con
     tyVars   = tyvarNames ltvs 
     lcontext = con_cxt con
@@ -1060,17 +1060,17 @@ ppSideBySideConstr (L _ con) = case con_res con of
   ResTyH98 -> case con_details con of 
 
     PrefixCon args -> 
-      argBox (hsep ((header +++ ppBinder False name) : map ppLType args)) 
+      argBox (hsep ((header +++ ppBinder False occ) : map ppLType args)) 
       <-> maybeRDocBox mbLDoc  
 
     RecCon fields -> 
-      argBox (header +++ ppBinder False name) <->
+      argBox (header +++ ppBinder False occ) <->
       maybeRDocBox mbLDoc </>
       (tda [theclass "body"] << spacedTable1 <<
       aboves (map ppSideBySideField fields))
 
     InfixCon arg1 arg2 -> 
-      argBox (hsep [header+++ppLType arg1, ppBinder False name, ppLType arg2])
+      argBox (hsep [header+++ppLType arg1, ppBinder False occ, ppLType arg2])
       <-> maybeRDocBox mbLDoc
  
   ResTyGADT resTy -> case con_details con of
@@ -1079,14 +1079,14 @@ ppSideBySideConstr (L _ con) = case con_res con of
     InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy 
 
  where 
-    doGADTCon args resTy = argBox (ppBinder False name <+> dcolon <+> hsep [
+    doGADTCon args resTy = argBox (ppBinder False occ <+> dcolon <+> hsep [
                                ppForAll forall ltvs (con_cxt con),
                                ppLType (foldr mkFunTy resTy args) ]
                             ) <-> maybeRDocBox mbLDoc
 
 
     header  = ppConstrHdr forall tyVars context
-    name    = orig (con_name con)
+    occ     = docNameOcc . unLoc . con_name $ con
     ltvs    = con_qvars con
     tyVars  = tyvarNames (con_qvars con)
     context = unLoc (con_cxt con)
@@ -1095,8 +1095,8 @@ ppSideBySideConstr (L _ con) = case con_res con of
     mkFunTy a b = noLoc (HsFunTy a b)
 
 ppSideBySideField :: ConDeclField DocName -> HtmlTable
-ppSideBySideField (ConDeclField lname ltype mbLDoc) =
-  argBox (ppBinder False (orig lname)
+ppSideBySideField (ConDeclField (L _ name) ltype mbLDoc) =
+  argBox (ppBinder False (docNameOcc name)
     <+> dcolon <+> ppLType ltype) <->
   maybeRDocBox mbLDoc
 
@@ -1128,9 +1128,9 @@ ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) =
 -}
 
 ppShortField :: Bool -> ConDeclField DocName -> HtmlTable
-ppShortField summary (ConDeclField lname ltype _) 
+ppShortField summary (ConDeclField (L _ name) ltype _) 
   = tda [theclass "recfield"] << (
-      ppBinder summary (orig lname)
+      ppBinder summary (docNameOcc name)
       <+> dcolon <+> ppLType ltype
     )
 
@@ -1272,8 +1272,8 @@ ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2)
   = maybeParen ctxt_prec pREC_OP $
     ppr_mono_lty pREC_OP ty1 <+> ppr_op <+> ppr_mono_lty pREC_OP ty2
   where
-    ppr_op = if not (isNameSym name) then quote (ppLDocName op) else ppLDocName op
-    name = getName . unLoc $ op
+    ppr_op = if not (isSymOcc occName) then quote (ppLDocName op) else ppLDocName op
+    occName = docNameOcc . unLoc $ op
 
 ppr_mono_ty ctxt_prec (HsParTy ty)
   = parens (ppr_mono_lty pREC_TOP ty)
@@ -1300,28 +1300,34 @@ ppRdrName = ppOccName . rdrNameOcc
 ppLDocName (L _ d) = ppDocName d
 
 ppDocName :: DocName -> Html
-ppDocName (Link name) = linkId (nameModule name) (Just name) << ppName name
-ppDocName (NoLink name) = toHtml (getOccString name)
+ppDocName (Documented name mod) = 
+  linkIdOcc mod (Just occName) << ppOccName occName
+    where occName = nameOccName name
+ppDocName (Undocumented name) = toHtml (getOccString name)
 
-linkTarget :: Name -> Html
-linkTarget name = namedAnchor (anchorNameStr name) << toHtml "" 
+linkTarget :: OccName -> Html
+linkTarget n = namedAnchor (anchorNameStr n) << toHtml "" 
 
 ppName :: Name -> Html
 ppName name = toHtml (getOccString name)
 
-ppBinder :: Bool -> Name -> Html
+ppBinder :: Bool -> OccName -> Html
 -- The Bool indicates whether we are generating the summary, in which case
 -- the binder will be a link to the full definition.
-ppBinder True nm = linkedAnchor (anchorNameStr nm) << ppBinder' nm
-ppBinder False nm = linkTarget nm +++ bold << ppBinder' nm
+ppBinder True n = linkedAnchor (anchorNameStr n) << ppBinder' n
+ppBinder False n = linkTarget n +++ bold << ppBinder' n
+
+ppBinder' :: OccName -> Html
+ppBinder' n
+  | isSymOcc n = parens $ toHtml (occNameString n)
+  | otherwise  = toHtml (occNameString n)             
+
+
+linkId mod mbName = linkIdOcc mod (fmap nameOccName mbName)
 
-ppBinder' :: Name -> Html
-ppBinder' name
-  | isNameVarSym name = parens $ toHtml (getOccString name)
-  | otherwise = toHtml (getOccString name)             
 
-linkId :: Module -> Maybe Name -> Html -> Html
-linkId mod mbName = anchor ! [href hr]
+linkIdOcc :: Module -> Maybe OccName -> Html -> Html
+linkIdOcc mod mbName = anchor ! [href hr]
   where 
     hr = case mbName of
       Nothing   -> moduleHtmlFile mod
diff --git a/src/Haddock/DocName.hs b/src/Haddock/DocName.hs
new file mode 100644
index 00000000..bb3cf711
--- /dev/null
+++ b/src/Haddock/DocName.hs
@@ -0,0 +1,50 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+
+module Haddock.DocName where
+
+
+import Haddock.GHC.Utils
+
+import GHC
+import OccName
+import Name
+import Binary
+import Outputable
+
+
+data DocName = Documented Name Module | Undocumented Name
+
+
+docNameOcc :: DocName -> OccName
+docNameOcc = nameOccName . docNameOrig
+
+
+docNameOrig :: DocName -> Name
+docNameOrig (Documented name _) = name
+docNameOrig (Undocumented name) = name
+
+
+instance Binary DocName where
+  put_ bh (Documented name mod) = do
+    putByte bh 0
+    put_ bh name
+    put_ bh mod
+  put_ bh (Undocumented name) = do
+    putByte bh 1
+    put_ bh name
+
+  get bh = do
+    h <- getByte bh
+    case h of
+      0 -> do
+        name <- get bh
+        mod  <- get bh
+        return (Documented name mod)
+      1 -> do
+        name <- get bh
+        return (Undocumented name)
diff --git a/src/Haddock/GHC/Utils.hs b/src/Haddock/GHC/Utils.hs
index cfe0a83b..21c34fc5 100644
--- a/src/Haddock/GHC/Utils.hs
+++ b/src/Haddock/GHC/Utils.hs
@@ -61,9 +61,7 @@ instance (Outputable a, Outputable b) => Outputable (Map.Map a b) where
 -- misc
 
 
-isNameSym n  = isNameVarSym n || isNameConSym n
-isNameVarSym = isLexVarSym . occNameFS . nameOccName 
-isNameConSym = isLexConSym . occNameFS . nameOccName 
+isNameSym = isSymOcc . nameOccName
 
 
 getMainDeclBinder :: HsDecl name -> Maybe name
diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs
index 5f40422e..51d8de2c 100644
--- a/src/Haddock/Interface.hs
+++ b/src/Haddock/Interface.hs
@@ -14,6 +14,7 @@ module Haddock.Interface (
 ) where
 
 
+import Haddock.DocName
 import Haddock.Interface.Create
 import Haddock.Interface.AttachInstances
 import Haddock.Interface.Rename
@@ -74,17 +75,15 @@ createInterfaces' modules flags = do
 -- The interfaces are passed in in topologically sorted order, but we start
 -- by reversing the list so we can do a foldl.
 buildHomeLinks :: [Interface] -> LinkEnv
-buildHomeLinks modules = foldl upd Map.empty (reverse modules)
+buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces)
   where
-    upd old_env mod
-      | OptHide    `elem` ifaceOptions mod = old_env
-      | OptNotHome `elem` ifaceOptions mod =
+    upd old_env iface
+      | OptHide    `elem` ifaceOptions iface = old_env
+      | OptNotHome `elem` ifaceOptions iface =
         foldl' keep_old old_env exported_names
       | otherwise = foldl' keep_new old_env exported_names
       where
-        exported_names = ifaceVisibleExports mod
-        modName = ifaceMod mod
-
-        keep_old env n = Map.insertWith (\new old -> old) n
-                         (nameSetMod n modName) env
-        keep_new env n = Map.insert n (nameSetMod n modName) env
+        exported_names = ifaceVisibleExports iface
+        mod            = ifaceMod iface
+        keep_old env n = Map.insertWith (\new old -> old) n mod env
+        keep_new env n = Map.insert n mod env
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index d43213c8..e3acc6cf 100644
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -133,7 +133,7 @@ toHsType t = case t of
 
   TyConApp tc ts -> case ts of 
     t1:t2:rest
-      | isNameConSym . tyConName $ tc ->
+      | isSymOcc . nameOccName . tyConName $ tc ->
           app (HsOpTy (toLHsType t1) (noLoc . tyConName $ tc) (toLHsType t2)) rest
     _ -> app (tycon tc) ts
 
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 947c3b29..11a0a14c 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -8,6 +8,7 @@
 module Haddock.Interface.Rename (renameInterface) where
 
 
+import Haddock.DocName
 import Haddock.Types
 import Haddock.GHC.Utils
 
@@ -35,7 +36,7 @@ renameInterface renamingEnv mod =
   -- is mapped to itself, and everything else comes from the global renaming
   -- env
   let localEnv = foldl fn renamingEnv (ifaceVisibleExports mod)
-        where fn env name = Map.insert name (nameSetMod name (ifaceMod mod)) env
+        where fn env name = Map.insert name (ifaceMod mod) env
       
       docs = Map.toList (ifaceDocMap mod)
       renameMapElem (k,d) = do d' <- renameDoc d; return (k, d') 
@@ -119,8 +120,8 @@ runRnFM :: LinkEnv -> 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)
+      Nothing  -> (False, Undocumented n) 
+      Just mod -> (True,  Documented n mod)
 
 
 --------------------------------------------------------------------------------
@@ -128,8 +129,8 @@ runRnFM env rn = unRn rn lkp
 --------------------------------------------------------------------------------
 
 
-keep n = NoLink n
-keepL (L loc n) = L loc (NoLink n)
+keep n = Undocumented n
+keepL (L loc n) = L loc (Undocumented n)
 
 
 rename = lookupRn id 
@@ -162,7 +163,7 @@ renameDoc doc = case doc of
     lkp <- getLookupRn
     case [ n | (True, n) <- map lkp ids ] of
       ids'@(_:_) -> return (DocIdentifier ids')
-      [] -> return (DocIdentifier (map NoLink ids))
+      [] -> return (DocIdentifier (map Undocumented ids))
   DocModule str -> return (DocModule str)
   DocEmphasis doc -> do
     doc' <- renameDoc doc
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index fe383336..680e71b7 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -12,6 +12,7 @@ module Haddock.InterfaceFile (
 ) where
 
 
+import Haddock.DocName
 import Haddock.Types
 import Haddock.Exception
 
@@ -45,7 +46,7 @@ data InterfaceFile = InterfaceFile {
 
 
 binaryInterfaceMagic = 0xD0Cface :: Word32
-binaryInterfaceVersion = 0 :: Word16
+binaryInterfaceVersion = 1 :: Word16
 
 
 initBinMemSize = (1024*1024) :: Int
@@ -244,26 +245,6 @@ instance Binary InstalledInterface where
     return (InstalledInterface mod info (Map.fromList docMap) exps visExps)
 
 
-{-* Generated by DrIFT : Look, but Don't Touch. *-}
-instance Binary DocName where
-    put_ bh (Link aa) = do
-            putByte bh 0
-            put_ bh aa
-    put_ bh (NoLink ab) = do
-            putByte bh 1
-            put_ bh ab
-    get bh = do
-            h <- getByte bh
-            case h of
-              0 -> do
-                    aa <- get bh
-                    return (Link aa)
-              1 -> do
-                    ab <- get bh
-                    return (NoLink ab)
-              _ -> fail "invalid binary data found"
-
-
 instance Binary DocOption where
     put_ bh OptHide = do
             putByte bh 0
diff --git a/src/Haddock/ModuleTree.hs b/src/Haddock/ModuleTree.hs
index f73cf2ee..2413f951 100644
--- a/src/Haddock/ModuleTree.hs
+++ b/src/Haddock/ModuleTree.hs
@@ -6,7 +6,7 @@
 
 module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where
 
-import Haddock.Types ( DocName )
+import Haddock.DocName
 import GHC           ( HsDoc, Name )
 import Module        ( Module, moduleNameString, moduleName, modulePackageId )
 import PackageConfig ( packageIdString )
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 580dc8cc..086469cf 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -8,12 +8,17 @@
 module Haddock.Types where
 
 
+import Haddock.GHC.Utils
+import Haddock.DocName
+
 import Data.Map (Map)
 import qualified Data.Map as Map
 
 import GHC hiding (NoLink)
 import Outputable
 import OccName
+import Name
+
 
 {-! for DocOption derive: Binary !-}
 data DocOption
@@ -78,21 +83,7 @@ data ExportItem name
 type InstHead name = ([HsPred name], name, [HsType name])
 type ModuleMap     = Map Module Interface
 type DocMap        = Map Name (HsDoc DocName)
-type LinkEnv       = Map Name Name
-
-
-{-! for DocName   derive: Binary !-}
-data DocName = Link Name | NoLink Name
-
-
-instance Outputable DocName where
-  ppr (Link   n) = ppr n
-  ppr (NoLink n) = ppr n
-
-
-instance NamedThing DocName where
-  getName (Link n)   = n
-  getName (NoLink n) = n
+type LinkEnv       = Map Name Module
 
 
 -- | This structure holds the module information we get from GHC's 
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
index b7b215d9..ca21c020 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -167,8 +167,8 @@ moduleHtmlFile mdl =
    mdl' = map (\c -> if c == '.' then '-' else c) 
               (moduleNameString (moduleName mdl))
 
-nameHtmlRef :: Module -> Name -> String	
-nameHtmlRef mdl str = moduleHtmlFile mdl ++ '#':escapeStr (anchorNameStr str)
+nameHtmlRef :: Module -> OccName -> String	
+nameHtmlRef mdl n = moduleHtmlFile mdl ++ '#':escapeStr (anchorNameStr n)
 
 contentsHtmlFile, indexHtmlFile :: String
 contentsHtmlFile = "index.html"
@@ -179,10 +179,9 @@ subIndexHtmlFile a = "doc-index-" ++ b ++ ".html"
    where b | isAlpha a = [a]
            | otherwise = show (ord a)
 
-anchorNameStr :: Name -> String
-anchorNameStr name | isValOcc occName = "v:" ++ getOccString name 
-                   | otherwise        = "t:" ++ getOccString name
-  where occName = nameOccName name
+anchorNameStr :: OccName -> String
+anchorNameStr name | isValOcc name = "v:" ++ occNameString name 
+                   | otherwise     = "t:" ++ occNameString name
 
 pathJoin :: [FilePath] -> FilePath
 pathJoin = foldr join []
diff --git a/src/Main.hs b/src/Main.hs
index bd2b4830..597048fb 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -13,7 +13,7 @@ module Main (main) where
 import Haddock.Backends.Html
 import Haddock.Backends.Hoogle
 import Haddock.Interface
-import Haddock.Types hiding (NoLink)
+import Haddock.Types
 import Haddock.Version
 import Haddock.InterfaceFile
 import Haddock.Exception