From e1156b56e4711546956f5588b7b4258cb42caaac Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Fri, 12 Dec 2014 06:22:31 +0000 Subject: Revert "Merge branch 'reverts'" This reverts commit 5c93cc347773c7634321edd5f808d5b55b46301f, reversing changes made to 5b81a9e53894d2ae591ca0c6c96199632d39eb06. Conflicts: haddock-api/src/Haddock/Convert.hs --- haddock-api/src/Haddock/Backends/Xhtml.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 4 +-- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Types.hs | 2 +- haddock-api/src/Haddock/Convert.hs | 12 ++++----- haddock-api/src/Haddock/GhcUtils.hs | 16 ++++++------ haddock-api/src/Haddock/Interface/Create.hs | 16 ++++++------ haddock-api/src/Haddock/Interface/Rename.hs | 32 +++++++++++++++++------- haddock-api/src/Haddock/InterfaceFile.hs | 12 ++++----- haddock-api/src/Haddock/ModuleTree.hs | 6 ++--- haddock-api/src/Haddock/Types.hs | 2 +- haddock-api/src/Haddock/Utils.hs | 6 +---- 12 files changed, 60 insertions(+), 52 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 8e133e65..d1176525 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/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 (stringToPackageId (fromMaybe "" pkg)) + then ppModule (mkModule (stringToPackageKey (fromMaybe "" pkg)) (mkModuleName mdl)) else toHtml s ) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 5e326019..517ad64a 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -281,8 +281,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 TyFamInstEqn { tfie_tycon = n, tfie_rhs = rhs - , tfie_pats = HsWB { hswb_cts = ts }} + ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs + , tfe_pats = HsWB { hswb_cts = ts }} = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual <+> equals <+> ppType unicode qual (unLoc rhs) , Nothing, [] ) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index e6a91391..b2c60534 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -225,7 +225,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 = modulePackageId origMod + origPkg = modulePackageKey origMod -- Name must be documented, otherwise we wouldn't get here Documented n mdl = head names diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs index 122861c3..3d1db887 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs +++ b/haddock-api/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 PackageId FilePath, Map PackageId FilePath) +type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageKey FilePath, Map PackageKey FilePath) type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index d0d44f1a..749421cc 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -66,7 +66,7 @@ tyThingToLHsDecl t = case t of extractFamilyDecl _ = Left "tyThingToLHsDecl: impossible associated tycon" - atTyClDecls = [synifyTyCon Nothing at_tc | (at_tc, _) <- classATItems cl] + atTyClDecls = [synifyTyCon Nothing at_tc | ATI at_tc _ <- classATItems cl] atFamDecls = map extractFamilyDecl (rights atTyClDecls) tyClErrors = lefts atTyClDecls famDeclErrors = lefts atFamDecls @@ -123,11 +123,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 TyFamInstEqn { tfie_tycon = name - , tfie_pats = HsWB { hswb_cts = typats - , hswb_kvs = map tyVarName kvs - , hswb_tvs = map tyVarName tvs } - , tfie_rhs = hs_rhs } + 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 } synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name) synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index c06b34a6..33d92131 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/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 unpackPackageId pkg of - Nothing -> (packageIdString pkg, "") +modulePackageInfo modu = case unpackPackageKey pkg of + Nothing -> (packageKeyString pkg, "") Just x -> (display $ pkgName x, showVersion (pkgVersion x)) - where pkg = modulePackageId modu + where pkg = modulePackageKey modu -- This was removed from GHC 6.11 -- XXX we shouldn't be using it, probably --- | Try and interpret a GHC 'PackageId' as a cabal 'PackageIdentifer'. Returns @Nothing@ if +-- | Try and interpret a GHC 'PackageKey' as a cabal 'PackageIdentifer'. Returns @Nothing@ if -- we could not parse it as such an object. -unpackPackageId :: PackageId -> Maybe PackageIdentifier -unpackPackageId p +unpackPackageKey :: PackageKey -> Maybe PackageIdentifier +unpackPackageKey p = case [ pid | (pid,"") <- readP_to_S parse str ] of [] -> Nothing (pid:_) -> Just pid - where str = packageIdString p + where str = packageKeyString 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 _ (TyFamInstEqn { tfie_rhs = L l _ })})) = l + { tfid_eqn = L _ (TyFamEqn { tfe_rhs = L l _ })})) = l -- Useful when there is a signature with multiple names, e.g. -- foo, bar :: Types.. diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 2ed25542..11b8494d 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -157,7 +157,7 @@ mkAliasMap dflags mRenamedSource = alias <- ideclAs impDecl return $ (lookupModuleDyn dflags - (fmap Module.fsToPackageId $ + (fmap Module.fsToPackageKey $ ideclPkgQual impDecl) (case ideclName impDecl of SrcLoc.L _ name -> name), alias)) @@ -165,15 +165,13 @@ mkAliasMap dflags mRenamedSource = -- similar to GHC.lookupModule lookupModuleDyn :: - DynFlags -> Maybe PackageId -> ModuleName -> Module + DynFlags -> Maybe PackageKey -> 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 + case Packages.lookupModuleInAllPackages dflags mdlName of + (m,_):_ -> m + [] -> Module.mkModule Module.mainPackageKey mdlName ------------------------------------------------------------------------------- @@ -697,8 +695,8 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa "documentation for exported module: " ++ pretty dflags expMod] return [] where - m = mkModule packageId expMod - packageId = modulePackageId thisMod + m = mkModule packageKey expMod + packageKey = modulePackageKey thisMod -- Note [1]: diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 277d6ca9..1cc8c8d7 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -322,7 +322,7 @@ renameTyClD d = case d of lfundeps' <- mapM renameLFunDep lfundeps lsigs' <- mapM renameLSig lsigs ats' <- mapM (renameLThing renameFamilyDecl) ats - at_defs' <- mapM (mapM renameTyFamInstD) at_defs + at_defs' <- mapM renameLTyFamDefltEqn 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 @@ -350,7 +350,7 @@ renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName) renameFamilyInfo DataFamily = return DataFamily renameFamilyInfo OpenTypeFamily = return OpenTypeFamily renameFamilyInfo (ClosedTypeFamily eqns) - = do { eqns' <- mapM (renameLThing renameTyFamInstEqn) eqns + = do { eqns' <- mapM renameLTyFamInstEqn eqns ; return $ ClosedTypeFamily eqns' } renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName) @@ -441,27 +441,41 @@ renameInstD (DataFamInstD { dfid_inst = d }) = do return (DataFamInstD { dfid_inst = d' }) renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName) -renameClsInstD (ClsInstDecl { cid_poly_ty =ltype, cid_tyfam_insts = lATs, cid_datafam_insts = lADTs }) = do +renameClsInstD (ClsInstDecl { cid_overlap_mode = omode + , 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_poly_ty = ltype', cid_binds = emptyBag, cid_sigs = [] + return (ClsInstDecl { cid_overlap_mode = omode + , 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' <- renameLThing renameTyFamInstEqn eqn + = do { eqn' <- renameLTyFamInstEqn eqn ; return (TyFamInstDecl { tfid_eqn = eqn' , tfid_fvs = placeHolderNames }) } -renameTyFamInstEqn :: TyFamInstEqn Name -> RnM (TyFamInstEqn DocName) -renameTyFamInstEqn (TyFamInstEqn { tfie_tycon = tc, tfie_pats = pats_w_bndrs, tfie_rhs = rhs }) +renameLTyFamInstEqn :: LTyFamInstEqn Name -> RnM (LTyFamInstEqn DocName) +renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats_w_bndrs, tfe_rhs = rhs })) = do { tc' <- renameL tc ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) ; rhs' <- renameLType rhs - ; return (TyFamInstEqn { tfie_tycon = tc', tfie_pats = pats_w_bndrs { hswb_cts = pats' } - , tfie_rhs = 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' })) } renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName) renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs, dfid_defn = defn }) diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index e4671f5e..a4d2d864 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -14,7 +14,7 @@ -- Reading and writing the .haddock interface file ----------------------------------------------------------------------------- module Haddock.InterfaceFile ( - InterfaceFile(..), ifPackageId, + InterfaceFile(..), ifPackageKey, readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor, writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility ) where @@ -52,11 +52,11 @@ data InterfaceFile = InterfaceFile { } -ifPackageId :: InterfaceFile -> PackageId -ifPackageId if_ = +ifPackageKey :: InterfaceFile -> PackageKey +ifPackageKey if_ = case ifInstalledIfaces if_ of [] -> error "empty InterfaceFile" - iface:_ -> modulePackageId $ instMod iface + iface:_ -> modulePackageKey $ instMod iface binaryInterfaceMagic :: Word32 @@ -310,7 +310,7 @@ getSymbolTable bh namecache = do return (namecache', arr) -type OnDiskName = (PackageId, ModuleName, OccName) +type OnDiskName = (PackageKey, 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 (modulePackageId modu, moduleName modu, nameOccName name) + put_ bh (modulePackageKey modu, moduleName modu, nameOccName name) ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/ModuleTree.hs b/haddock-api/src/Haddock/ModuleTree.hs index 22cfcdfa..662d7025 100644 --- a/haddock-api/src/Haddock/ModuleTree.hs +++ b/haddock-api/src/Haddock/ModuleTree.hs @@ -15,8 +15,8 @@ module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where import Haddock.Types ( MDoc ) import GHC ( Name ) -import Module ( Module, moduleNameString, moduleName, modulePackageId, - packageIdString ) +import Module ( Module, moduleNameString, moduleName, modulePackageKey, + packageKeyString ) data ModuleTree = Node String Bool (Maybe String) (Maybe (MDoc Name)) [ModuleTree] @@ -26,7 +26,7 @@ mkModuleTree :: Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree] mkModuleTree showPkgs mods = foldr fn [] [ (splitModule mdl, modPkg mdl, short) | (mdl, short) <- mods ] where - modPkg mod_ | showPkgs = Just (packageIdString (modulePackageId mod_)) + modPkg mod_ | showPkgs = Just (packageKeyString (modulePackageKey mod_)) | otherwise = Nothing fn (mod_,pkg,short) = addToTrees mod_ pkg short diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index d131f019..71139971 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/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 PackageId FilePath +type SrcMap = Map PackageKey FilePath type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index bbb9c02b..c4f8eb97 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -304,11 +304,7 @@ bye :: String -> IO a bye s = putStr s >> exitSuccess -die :: String -> IO a -die s = hPutStr stderr s >> exitWith (ExitFailure 1) - - -dieMsg :: String -> IO a +dieMsg :: String -> IO () dieMsg s = getProgramName >>= \prog -> die (prog ++ ": " ++ s) -- cgit v1.2.3