Merge branch 'reverts'

This reverts any changes that were made to have Haddock compile with
7.9. When 7.10 release comes, we can simply re-apply all the patches and
any patches that occur on ghc-head branch from now on.

This allows us to build master with 7.8.3

15 files changed, 59 insertions, 67 deletions

diff --git a/html-test/run.lhs b/html-test/run.lhs
index a8664363..153ab32c 100755
--- a/html-test/run.lhs
+++ b/html-test/run.lhs
@@ -41,7 +41,7 @@ main = do
 test :: IO ()
 test = do
   x <- doesFileExist haddockPath
-  unless x $ System.Exit.die "you need to run 'cabal build' successfully first"
+  unless x $ die "you need to run 'cabal build' successfully first"
 
   contents <- getDirectoryContents testDir
   args <- getArgs
diff --git a/latex-test/run.lhs b/latex-test/run.lhs
index c1d48d97..423dc6fd 100755
--- a/latex-test/run.lhs
+++ b/latex-test/run.lhs
@@ -41,7 +41,7 @@ main = do
 test :: IO ()
 test = do
   x <- doesFileExist haddockPath
-  unless x $ System.Exit.die "you need to run 'cabal build' successfully first"
+  unless x $ die "you need to run 'cabal build' successfully first"
 
   contents <- getDirectoryContents testDir
 
diff --git a/src/Haddock.hs b/src/Haddock.hs
index 024b1098..3d049b18 100644
--- a/src/Haddock.hs
+++ b/src/Haddock.hs
@@ -215,7 +215,7 @@ renderStep dflags flags qual pkgs interfaces = do
   let
     ifaceFiles = map snd pkgs
     installedIfaces = concatMap ifInstalledIfaces ifaceFiles
-    srcMap = Map.fromList [ (ifPackageKey if_, x) | ((_, Just x), if_) <- pkgs ]
+    srcMap = Map.fromList [ (ifPackageId if_, x) | ((_, Just x), if_) <- pkgs ]
   render dflags flags qual interfaces installedIfaces srcMap
 
 
@@ -240,14 +240,14 @@ render dflags flags qual ifaces installedIfaces srcMap = do
     allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ]
 
     pkgMod           = ifaceMod (head ifaces)
-    pkgKey            = modulePackageKey pkgMod
-    pkgStr           = Just (packageKeyString pkgKey)
+    pkgId            = modulePackageId pkgMod
+    pkgStr           = Just (packageIdString pkgId)
     (pkgName,pkgVer) = modulePackageInfo pkgMod
 
     (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags
-    srcMap' = maybe srcMap (\path -> Map.insert pkgKey path srcMap) srcEntity
+    srcMap' = maybe srcMap (\path -> Map.insert pkgId path srcMap) srcEntity
     -- TODO: Get these from the interface files as with srcMap
-    srcLMap' = maybe Map.empty (\path -> Map.singleton pkgKey path) srcLEntity
+    srcLMap' = maybe Map.empty (\path -> Map.singleton pkgId path) srcLEntity
     sourceUrls' = (srcBase, srcModule, srcMap', srcLMap')
 
   libDir   <- getHaddockLibDir flags
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 192c708a..9628a33d 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -306,7 +306,7 @@ mkNode qual ss p (Node s leaf pkg short ts) =
 
     htmlModule = thespan ! modAttrs << (cBtn +++
       if leaf
-        then ppModule (mkModule (stringToPackageKey (fromMaybe "" pkg))
+        then ppModule (mkModule (stringToPackageId (fromMaybe "" pkg))
                                        (mkModuleName mdl))
         else toHtml s
       )
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 0429580c..8884f69f 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -280,8 +280,8 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
       = ppInstances instances docname unicode qual
 
     -- Individual equation of a closed type family
-    ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs
-                        , tfe_pats = HsWB { hswb_cts = ts }}
+    ppTyFamEqn TyFamInstEqn { tfie_tycon = n, tfie_rhs = rhs
+                            , tfie_pats = HsWB { hswb_cts = ts }}
       = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual
           <+> equals <+> ppType unicode qual (unLoc rhs)
         , Nothing, [] )
diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs
index 253854c8..e84a57b3 100644
--- a/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/src/Haddock/Backends/Xhtml/Layout.hs
@@ -224,7 +224,7 @@ topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names htm
         -- TODO: do something about type instances. They will point to
         -- the module defining the type family, which is wrong.
         origMod = nameModule n
-        origPkg = modulePackageKey origMod
+        origPkg = modulePackageId origMod
 
         -- Name must be documented, otherwise we wouldn't get here
         Documented n mdl = head names
diff --git a/src/Haddock/Backends/Xhtml/Types.hs b/src/Haddock/Backends/Xhtml/Types.hs
index 3d1db887..122861c3 100644
--- a/src/Haddock/Backends/Xhtml/Types.hs
+++ b/src/Haddock/Backends/Xhtml/Types.hs
@@ -23,7 +23,7 @@ import GHC
 
 
 -- the base, module and entity URLs for the source code and wiki links.
-type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageKey FilePath, Map PackageKey FilePath)
+type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageId FilePath, Map PackageId FilePath)
 type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath)
 
 
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
index dfb0f14f..405bf204 100644
--- a/src/Haddock/Convert.hs
+++ b/src/Haddock/Convert.hs
@@ -64,7 +64,7 @@ tyThingToLHsDecl t = noLoc $ case t of
            extractFamilyDecl _           =
              error "tyThingToLHsDecl: impossible associated tycon"
 
-           atTyClDecls = [synifyTyCon Nothing at_tc | ATI at_tc _ <- classATItems cl]
+           atTyClDecls = [synifyTyCon Nothing at_tc | (at_tc, _) <- classATItems cl]
            atFamDecls  = map extractFamilyDecl atTyClDecls in
        TyClD $ ClassDecl
          { tcdCtxt = synifyCtx (classSCTheta cl)
@@ -107,11 +107,11 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
         typats     = map (synifyType WithinType) args
         hs_rhs     = synifyType WithinType rhs
         (kvs, tvs) = partition isKindVar tkvs
-    in TyFamEqn { tfe_tycon = name
-                , tfe_pats  = HsWB { hswb_cts = typats
-                                    , hswb_kvs = map tyVarName kvs
-                                    , hswb_tvs = map tyVarName tvs }
-                , tfe_rhs   = hs_rhs }
+    in TyFamInstEqn { tfie_tycon = name
+                    , tfie_pats  = HsWB { hswb_cts = typats
+                                        , hswb_kvs = map tyVarName kvs
+                                        , hswb_tvs = map tyVarName tvs }
+                    , tfie_rhs   = hs_rhs }
 
 synifyAxiom :: CoAxiom br -> HsDecl Name
 synifyAxiom ax@(CoAxiom { co_ax_tc = tc })
diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs
index 33d92131..c06b34a6 100644
--- a/src/Haddock/GhcUtils.hs
+++ b/src/Haddock/GhcUtils.hs
@@ -44,23 +44,23 @@ moduleString = moduleNameString . moduleName
 
 -- return the (name,version) of the package
 modulePackageInfo :: Module -> (String, [Char])
-modulePackageInfo modu = case unpackPackageKey pkg of
-                          Nothing -> (packageKeyString pkg, "")
+modulePackageInfo modu = case unpackPackageId pkg of
+                          Nothing -> (packageIdString pkg, "")
                           Just x -> (display $ pkgName x, showVersion (pkgVersion x))
-  where pkg = modulePackageKey modu
+  where pkg = modulePackageId modu
 
 
 -- This was removed from GHC 6.11
 -- XXX we shouldn't be using it, probably
 
--- | Try and interpret a GHC 'PackageKey' as a cabal 'PackageIdentifer'. Returns @Nothing@ if
+-- | Try and interpret a GHC 'PackageId' as a cabal 'PackageIdentifer'. Returns @Nothing@ if
 -- we could not parse it as such an object.
-unpackPackageKey :: PackageKey -> Maybe PackageIdentifier
-unpackPackageKey p
+unpackPackageId :: PackageId -> Maybe PackageIdentifier
+unpackPackageId p
   = case [ pid | (pid,"") <- readP_to_S parse str ] of
         []      -> Nothing
         (pid:_) -> Just pid
-  where str = packageKeyString p
+  where str = packageIdString p
 
 
 lookupLoadedHomeModuleGRE  :: GhcMonad m => ModuleName -> m (Maybe GlobalRdrEnv)
@@ -102,7 +102,7 @@ getInstLoc (TyFamInstD (TyFamInstDecl
   -- Since CoAxioms' Names refer to the whole line for type family instances
   -- in particular, we need to dig a bit deeper to pull out the entire
   -- equation. This does not happen for data family instances, for some reason.
-  { tfid_eqn = L _ (TyFamEqn { tfe_rhs = L l _ })})) = l
+  { tfid_eqn = L _ (TyFamInstEqn { tfie_rhs = L l _ })})) = l
 
 -- Useful when there is a signature with multiple names, e.g.
 --   foo, bar :: Types..
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index ad6a1e98..bc615cde 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -157,7 +157,7 @@ mkAliasMap dflags mRenamedSource =
         alias <- ideclAs impDecl
         return $
           (lookupModuleDyn dflags
-             (fmap Module.fsToPackageKey $
+             (fmap Module.fsToPackageId $
               ideclPkgQual impDecl)
              (case ideclName impDecl of SrcLoc.L _ name -> name),
            alias))
@@ -165,13 +165,15 @@ mkAliasMap dflags mRenamedSource =
 
 -- similar to GHC.lookupModule
 lookupModuleDyn ::
-  DynFlags -> Maybe PackageKey -> ModuleName -> Module
+  DynFlags -> Maybe PackageId -> ModuleName -> Module
 lookupModuleDyn _ (Just pkgId) mdlName =
   Module.mkModule pkgId mdlName
 lookupModuleDyn dflags Nothing mdlName =
-  case Packages.lookupModuleInAllPackages dflags mdlName of
-    (m,_):_ -> m
-    [] -> Module.mkModule Module.mainPackageKey mdlName
+  flip Module.mkModule mdlName $
+  case filter snd $
+       Packages.lookupModuleInAllPackages dflags mdlName of
+    (pkgId,_):_ -> Packages.packageConfigId pkgId
+    [] -> Module.mainPackageId
 
 
 -------------------------------------------------------------------------------
@@ -676,8 +678,8 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa
                     "documentation for exported module: " ++ pretty dflags expMod]
             return []
   where
-    m = mkModule packageKey expMod
-    packageKey = modulePackageKey thisMod
+    m = mkModule packageId expMod
+    packageId = modulePackageId thisMod
 
 
 -- Note [1]:
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index a804f4a1..748e0210 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -323,7 +323,7 @@ renameTyClD d = case d of
     lfundeps' <- mapM renameLFunDep lfundeps
     lsigs'    <- mapM renameLSig lsigs
     ats'      <- mapM (renameLThing renameFamilyDecl) ats
-    at_defs'  <- mapM renameLTyFamDefltEqn at_defs
+    at_defs'  <- mapM (mapM renameTyFamInstD) at_defs
     -- we don't need the default methods or the already collected doc entities
     return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars'
                       , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag
@@ -351,7 +351,7 @@ renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName)
 renameFamilyInfo DataFamily     = return DataFamily
 renameFamilyInfo OpenTypeFamily = return OpenTypeFamily
 renameFamilyInfo (ClosedTypeFamily eqns)
-  = do { eqns' <- mapM renameLTyFamInstEqn eqns
+  = do { eqns' <- mapM (renameLThing renameTyFamInstEqn) eqns
        ; return $ ClosedTypeFamily eqns' }
 
 renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName)
@@ -442,41 +442,27 @@ renameInstD (DataFamInstD { dfid_inst = d }) = do
   return (DataFamInstD { dfid_inst = d' })
 
 renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName)
-renameClsInstD (ClsInstDecl { cid_overlap_mode = omode
-                            , cid_poly_ty =ltype, cid_tyfam_insts = lATs
-                            , cid_datafam_insts = lADTs }) = do
+renameClsInstD (ClsInstDecl { cid_poly_ty =ltype, cid_tyfam_insts = lATs, cid_datafam_insts = lADTs }) = do
   ltype' <- renameLType ltype
   lATs'  <- mapM (mapM renameTyFamInstD) lATs
   lADTs' <- mapM (mapM renameDataFamInstD) lADTs
-  return (ClsInstDecl { cid_overlap_mode = omode
-                      , cid_poly_ty = ltype', cid_binds = emptyBag
-                      , cid_sigs = []
+  return (ClsInstDecl { cid_poly_ty = ltype', cid_binds = emptyBag, cid_sigs = []
                       , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' })
 
 
 renameTyFamInstD :: TyFamInstDecl Name -> RnM (TyFamInstDecl DocName)
 renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
-  = do { eqn' <- renameLTyFamInstEqn eqn
+  = do { eqn' <- renameLThing renameTyFamInstEqn eqn
        ; return (TyFamInstDecl { tfid_eqn = eqn'
                                , tfid_fvs = placeHolderNames }) }
 
-renameLTyFamInstEqn :: LTyFamInstEqn Name -> RnM (LTyFamInstEqn DocName)
-renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats_w_bndrs, tfe_rhs = rhs }))
+renameTyFamInstEqn :: TyFamInstEqn Name -> RnM (TyFamInstEqn DocName)
+renameTyFamInstEqn (TyFamInstEqn { tfie_tycon = tc, tfie_pats = pats_w_bndrs, tfie_rhs = rhs })
   = do { tc' <- renameL tc
        ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs)
        ; rhs' <- renameLType rhs
-       ; return (L loc (TyFamEqn { tfe_tycon = tc'
-                                 , tfe_pats = pats_w_bndrs { hswb_cts = pats' }
-                                 , tfe_rhs = rhs' })) }
-
-renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName)
-renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_rhs = rhs }))
-  = do { tc' <- renameL tc
-       ; tvs'  <- renameLTyVarBndrs tvs
-       ; rhs' <- renameLType rhs
-       ; return (L loc (TyFamEqn { tfe_tycon = tc'
-                                 , tfe_pats = tvs'
-                                 , tfe_rhs = rhs' })) }
+       ; return (TyFamInstEqn { tfie_tycon = tc', tfie_pats = pats_w_bndrs { hswb_cts = pats' }
+                              , tfie_rhs = rhs' }) }
 
 renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName)
 renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs, dfid_defn = defn })
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index c13125e9..bb997b9a 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -14,7 +14,7 @@
 -- Reading and writing the .haddock interface file
 -----------------------------------------------------------------------------
 module Haddock.InterfaceFile (
-  InterfaceFile(..), ifPackageKey,
+  InterfaceFile(..), ifPackageId,
   readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor,
   writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility
 ) where
@@ -52,11 +52,11 @@ data InterfaceFile = InterfaceFile {
 }
 
 
-ifPackageKey :: InterfaceFile -> PackageKey
-ifPackageKey if_ =
+ifPackageId :: InterfaceFile -> PackageId
+ifPackageId if_ =
   case ifInstalledIfaces if_ of
     [] -> error "empty InterfaceFile"
-    iface:_ -> modulePackageKey $ instMod iface
+    iface:_ -> modulePackageId $ instMod iface
 
 
 binaryInterfaceMagic :: Word32
@@ -310,7 +310,7 @@ getSymbolTable bh namecache = do
   return (namecache', arr)
 
 
-type OnDiskName = (PackageKey, ModuleName, OccName)
+type OnDiskName = (PackageId, ModuleName, OccName)
 
 
 fromOnDiskName
@@ -340,7 +340,7 @@ fromOnDiskName _ nc (pid, mod_name, occ) =
 serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
 serialiseName bh name _ = do
   let modu = nameModule name
-  put_ bh (modulePackageKey modu, moduleName modu, nameOccName name)
+  put_ bh (modulePackageId modu, moduleName modu, nameOccName name)
 
 
 -------------------------------------------------------------------------------
diff --git a/src/Haddock/ModuleTree.hs b/src/Haddock/ModuleTree.hs
index 28c5c06d..2a7fbfcc 100644
--- a/src/Haddock/ModuleTree.hs
+++ b/src/Haddock/ModuleTree.hs
@@ -15,8 +15,8 @@ module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where
 import Haddock.Types ( Doc )
 
 import GHC           ( Name )
-import Module        ( Module, moduleNameString, moduleName, modulePackageKey,
-                       packageKeyString )
+import Module        ( Module, moduleNameString, moduleName, modulePackageId,
+                       packageIdString )
 
 
 data ModuleTree = Node String Bool (Maybe String) (Maybe (Doc Name)) [ModuleTree]
@@ -26,7 +26,7 @@ mkModuleTree :: Bool -> [(Module, Maybe (Doc Name))] -> [ModuleTree]
 mkModuleTree showPkgs mods =
   foldr fn [] [ (splitModule mdl, modPkg mdl, short) | (mdl, short) <- mods ]
   where
-    modPkg mod_ | showPkgs = Just (packageKeyString (modulePackageKey mod_))
+    modPkg mod_ | showPkgs = Just (packageIdString (modulePackageId mod_))
                 | otherwise = Nothing
     fn (mod_,pkg,short) = addToTrees mod_ pkg short
 
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 1f44fde4..85b3a592 100644
--- a/src/Haddock/Types.hs
+++ b/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 PackageId FilePath
 type DocPaths      = (FilePath, Maybe FilePath) -- paths to HTML and sources
 
 
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
index 9ccca362..ee7bfd0a 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -300,7 +300,11 @@ bye :: String -> IO a
 bye s = putStr s >> exitSuccess
 
 
-dieMsg :: String -> IO ()
+die :: String -> IO a
+die s = hPutStr stderr s >> exitWith (ExitFailure 1)
+
+
+dieMsg :: String -> IO a
 dieMsg s = getProgramName >>= \prog -> die (prog ++ ": " ++ s)