diff --git a/html-test/run.lhs b/html-test/run.lhs
index a8664363e10f12e294f94f0a1ae014da9b1b5a7a..153ab32cf6a662176ba7e02d46f0c0f34ddd50b1 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 c1d48d975165dc4446735b93ce9b34cc4111e63f..423dc6fd1736c5bf207b1d2692ac21e4dc8f8fd2 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 024b109891640e68d1a964121b49c2e27022e043..3d049b18ed92b434d592b80c7e8c058bfcb970be 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 192c708a5d76dabada4c83477ffa8eaf557f7691..9628a33dbf6f9a3734ccd5425ad2027f51e106db 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 0429580c29cee8f24b3a638458475c1564b8e090..8884f69f40d8f59bf663890954d1d143c8806b21 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 253854c87b83a01ed04358cad6c908f14a3bdaff..e84a57b327cad8161fac0dfd0d96299632f41964 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 3d1db887cd51809a80ae30b39dfa5216128beb47..122861c3a65805aef1e24cafe0def309fc77d5d6 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 dfb0f14f775507c34b3d6a33fc5d9edb85c558ae..405bf2045d1fd87da33caa231af927c728f2398f 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 33d9213195948cb7cbe36ad72e86fa0b86182753..c06b34a653126866089ca25d12746f26e13d0358 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 ad6a1e98d421f5e61d8f72607b7f81e9a4929889..bc615cdeb0e70b0302d55a201ae0d8331d017f47 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 a804f4a1fcc65f626a84518e7748b204c2315b10..748e0210a60161aa8601455f2851f84a5cbd0bdb 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 c13125e9101ce3fc9cdd2b24c06c88727e9429eb..bb997b9a147d220c2a0c3e6244b9585885698dca 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 28c5c06d181b704d24f38d50e2e49065720290b5..2a7fbfcc791980e2a0c0934146898ef5a05556e7 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 1f44fde416dcc41bd6dfc05c593446bda98f1d09..85b3a592128b56ea611ba56a967f7e8eddbd1c74 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 9ccca362ab6a7981c41459c7a181dcd494636fef..ee7bfd0a511adcea2567118200d851ac4cae2ecc 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)