diff options
| -rw-r--r-- | compiler/ghci/Linker.lhs | 10 | ||||
| -rw-r--r-- | compiler/main/Finder.lhs | 5 | ||||
| -rw-r--r-- | compiler/main/PackageConfig.hs | 2 | ||||
| -rw-r--r-- | compiler/main/Packages.lhs | 14 | ||||
| -rw-r--r-- | libraries/bin-package-db/GHC/PackageDb.hs | 25 | ||||
| -rw-r--r-- | utils/ghc-pkg/Main.hs | 83 |
6 files changed, 82 insertions, 57 deletions
diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index f581f9f59a..d4de513ba8 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -1117,7 +1117,8 @@ linkPackage dflags pkg objs = [ obj | Object obj <- classifieds ] archs = [ arch | Archive arch <- classifieds ] - maybePutStr dflags ("Loading package " ++ sourcePackageIdString pkg ++ " ... ") + maybePutStr dflags + ("Loading package " ++ sourcePackageIdString pkg ++ " ... ") -- See comments with partOfGHCi when (packageName pkg `notElem` partOfGHCi) $ do @@ -1132,8 +1133,11 @@ linkPackage dflags pkg maybePutStr dflags "linking ... " ok <- resolveObjs - if succeeded ok then maybePutStrLn dflags "done." - else throwGhcExceptionIO (InstallationError ("unable to load package `" ++ sourcePackageIdString pkg ++ "'")) + if succeeded ok + then maybePutStrLn dflags "done." + else let errmsg = "unable to load package `" + ++ sourcePackageIdString pkg ++ "'" + in throwGhcExceptionIO (InstallationError errmsg) -- we have already searched the filesystem; the strings passed to load_dyn -- can be passed directly to loadDLL. They are either fully-qualified diff --git a/compiler/main/Finder.lhs b/compiler/main/Finder.lhs index 8b9a5e9547..65151d9b2d 100644 --- a/compiler/main/Finder.lhs +++ b/compiler/main/Finder.lhs @@ -616,13 +616,14 @@ cantFindErr cannot_find _ dflags mod_name find_result hang (ptext (sLit "Locations searched:")) 2 $ vcat (map text files) pkg_hidden pkgid = - ptext (sLit "It is a member of the hidden package") <+> quotes (ppr pkgid) + ptext (sLit "It is a member of the hidden package") + <+> quotes (ppr pkgid) --FIXME: we don't really want to show the package key here we should -- show the source package id or installed package id if it's ambiguous <> dot $$ cabal_pkg_hidden_hint pkgid cabal_pkg_hidden_hint pkgid | gopt Opt_BuildingCabalPackage dflags - = let pkg = expectJust "cabal_pkg_hidden_hint" (lookupPackage dflags pkgid) + = let pkg = expectJust "pkg_hidden" (lookupPackage dflags pkgid) in ptext (sLit "Perhaps you need to add") <+> quotes (ppr (packageName pkg)) <+> ptext (sLit "to the build-depends in your .cabal file.") diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs index 09ff0659b3..7cd2779bc4 100644 --- a/compiler/main/PackageConfig.hs +++ b/compiler/main/PackageConfig.hs @@ -68,7 +68,7 @@ instance BinaryStringRep PackageKey where instance BinaryStringRep Module.ModuleName where fromStringRep = Module.mkModuleName . BS.unpack - toStringRep = BS.pack . Module.moduleNameString + toStringRep = BS.pack . Module.moduleNameString instance Outputable InstalledPackageId where ppr (InstalledPackageId str) = text str diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index cf9ab09f67..9640f72957 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -391,9 +391,10 @@ readPackageConfig dflags conf_file = do isfile <- doesFileExist conf_file if isfile then throwGhcExceptionIO $ InstallationError $ - "ghc no longer supports single-file style package databases (" ++ - conf_file ++ - ") use 'ghc-pkg init' to create the database with the correct format." + "ghc no longer supports single-file style package " ++ + "databases (" ++ conf_file ++ + ") use 'ghc-pkg init' to create the database with " ++ + "the correct format." else throwGhcExceptionIO $ InstallationError $ "can't find a package database at " ++ conf_file @@ -597,7 +598,8 @@ packageFlagErr dflags flag reasons -- ToDo: this admonition seems a bit dodgy text "(use -v for more information)") ppr_reasons = vcat (map ppr_reason reasons) - ppr_reason (p, reason) = pprReason (ppr (installedPackageId p) <+> text "is") reason + ppr_reason (p, reason) = + pprReason (ppr (installedPackageId p) <+> text "is") reason pprFlag :: PackageFlag -> SDoc pprFlag flag = case flag of @@ -692,7 +694,9 @@ findWiredInPackages dflags pkgs = do updateWiredInDependencies pkgs = map upd_pkg pkgs where upd_pkg pkg | installedPackageId pkg `elem` wired_in_ids - = pkg { packageKey = stringToPackageKey (packageNameString pkg) } + = pkg { + packageKey = stringToPackageKey (packageNameString pkg) + } | otherwise = pkg diff --git a/libraries/bin-package-db/GHC/PackageDb.hs b/libraries/bin-package-db/GHC/PackageDb.hs index b29d7075bd..eea525c70c 100644 --- a/libraries/bin-package-db/GHC/PackageDb.hs +++ b/libraries/bin-package-db/GHC/PackageDb.hs @@ -34,7 +34,7 @@ -- the second version -- the bit GHC uses -- and the part managed by ghc-pkg -- is kept in the file but here we treat it as an opaque blob of data. That way -- this library avoids depending on Cabal. --- +-- module GHC.PackageDb ( InstalledPackageInfo(..), ModuleExport(..), @@ -106,7 +106,8 @@ data ModuleExport instpkgid modulename } deriving (Eq, Show) -emptyInstalledPackageInfo :: (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c, BinaryStringRep d) +emptyInstalledPackageInfo :: (BinaryStringRep a, BinaryStringRep b, + BinaryStringRep c, BinaryStringRep d) => InstalledPackageInfo a b c d e emptyInstalledPackageInfo = InstalledPackageInfo { @@ -230,17 +231,17 @@ decodeFromFile file decoder = withBinaryFile file ReadMode $ \hnd -> feed hnd (runGetIncremental decoder) where - feed hnd (Partial k) = do chunk <- BS.hGet hnd BS.Lazy.defaultChunkSize - if BS.null chunk - then feed hnd (k Nothing) - else feed hnd (k (Just chunk)) - feed _ (Done _ _ result) = return result - feed _ (Fail _ _ msg) = ioError err + feed hnd (Partial k) = do chunk <- BS.hGet hnd BS.Lazy.defaultChunkSize + if BS.null chunk + then feed hnd (k Nothing) + else feed hnd (k (Just chunk)) + feed _ (Done _ _ res) = return res + feed _ (Fail _ _ msg) = ioError err where err = mkIOError InappropriateType loc Nothing (Just file) `ioeSetErrorString` msg loc = "GHC.PackageDb.readPackageDb" - + writeFileAtomic :: FilePath -> BS.Lazy.ByteString -> IO () writeFileAtomic targetPath content = do let (targetDir, targetName) = splitFileName targetPath @@ -272,7 +273,8 @@ instance (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c, BinaryStringRep d, BinaryStringRep e) => Binary (InstalledPackageInfo a b c d e) where put (InstalledPackageInfo - installedPackageId sourcePackageId packageName packageVersion packageKey + installedPackageId sourcePackageId + packageName packageVersion packageKey depends importDirs hsLibraries extraLibraries extraGHCiLibraries libraryDirs frameworks frameworkDirs @@ -357,7 +359,8 @@ instance Binary Version where b <- get return (Version a b) -instance (BinaryStringRep a, BinaryStringRep b) => Binary (ModuleExport a b) where +instance (BinaryStringRep a, BinaryStringRep b) => + Binary (ModuleExport a b) where put (ModuleExport a b c) = do put (toStringRep a) put (toStringRep b) diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 858797f567..cedc048f03 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -681,9 +681,9 @@ readParseDatabase verbosity mb_user_conf modify use_cache path case e of Left err | ioeGetErrorType err == InappropriateType -> - die ("ghc no longer supports single-file style package databases (" - ++ path ++ ") use 'ghc-pkg init' to create the database with " - ++ "the correct format.") + die ("ghc no longer supports single-file style package databases " + ++ "(" ++ path ++ ") use 'ghc-pkg init' to create the database " + ++ "with the correct format.") | otherwise -> ioError err Right fs | not use_cache -> ignore_cache (const $ return ()) @@ -693,13 +693,17 @@ readParseDatabase verbosity mb_user_conf modify use_cache path e_tcache <- tryIO $ getModificationTime cache case e_tcache of Left ex -> do - when (verbosity >= Normal && not modify || verbosity > Normal) $ do - if isDoesNotExistError ex - then do warn ("WARNING: cache does not exist: " ++ cache) - warn "ghc will fail to read this package db. Use 'ghc-pkg recache' to fix." - else do warn ("WARNING: cache cannot be read: " ++ show ex) - warn "ghc will fail to read this package db." - ignore_cache (const $ return ()) + when ( verbosity > Normal + || verbosity >= Normal && not modify) $ + if isDoesNotExistError ex + then do + warn ("WARNING: cache does not exist: " ++ cache) + warn ("ghc will fail to read this package db. " ++ + "Use 'ghc-pkg recache' to fix.") + else do + warn ("WARNING: cache cannot be read: " ++ show ex) + warn "ghc will fail to read this package db." + ignore_cache (const $ return ()) Right tcache -> do let compareTimestampToCache file = when (verbosity >= Verbose) $ do @@ -722,10 +726,11 @@ readParseDatabase verbosity mb_user_conf modify use_cache path pkgs <- GhcPkg.readPackageDbForGhcPkg cache mkPackageDB pkgs else do - when (verbosity >= Normal && not modify || verbosity > Normal) $ do - warn ("WARNING: cache is out of date: " - ++ cache) - warn "ghc will see an old view of this package db. Use 'ghc-pkg recache' to fix." + when ( verbosity > Normal + || verbosity >= Normal && not modify) $ do + warn ("WARNING: cache is out of date: " ++ cache) + warn ("ghc will see an old view of this " ++ + "package db. Use 'ghc-pkg recache' to fix.") ignore_cache compareTimestampToCache where ignore_cache :: (FilePath -> IO ()) -> IO PackageDB @@ -844,8 +849,8 @@ registerPackage :: FilePath registerPackage input verbosity my_flags auto_ghci_libs multi_instance expand_env_vars update force = do (db_stack, Just to_modify, _flag_dbs) <- - getPkgDatabases verbosity True{-modify-} True{-use user-} True{-use cache-} - False{-expand vars-} my_flags + getPkgDatabases verbosity True{-modify-} True{-use user-} + True{-use cache-} False{-expand vars-} my_flags let db_to_operate_on = my_head "register" $ @@ -1027,7 +1032,12 @@ updateDBCache verbosity db = do setFileTimes (location db) (accessTime status) (modificationTime status) #endif -type PackageCacheFormat = GhcPkg.InstalledPackageInfo String String String String ModuleName +type PackageCacheFormat = GhcPkg.InstalledPackageInfo + String -- installed package id + String -- src package id + String -- package name + String -- package key + ModuleName -- module name convertPackageInfoToCacheFormat :: InstalledPackageInfo -> PackageCacheFormat convertPackageInfoToCacheFormat pkg = @@ -1056,7 +1066,8 @@ convertPackageInfoToCacheFormat pkg = GhcPkg.reexportedModules = [ GhcPkg.ModuleExport m ipid' m' | ModuleExport { exportName = m, - exportCachedTrueOrig = Just (InstalledPackageId ipid', m') + exportCachedTrueOrig = + Just (InstalledPackageId ipid', m') } <- reexportedModules pkg ], GhcPkg.exposed = exposed pkg, @@ -1099,8 +1110,8 @@ modifyPackage -> IO () modifyPackage fn pkgarg verbosity my_flags force = do (db_stack, Just _to_modify, flag_dbs) <- - getPkgDatabases verbosity True{-modify-} True{-use user-} True{-use cache-} - False{-expand vars-} my_flags + getPkgDatabases verbosity True{-modify-} True{-use user-} + True{-use cache-} False{-expand vars-} my_flags -- Do the search for the package respecting flags... (db, ps) <- fmap head $ findPackagesByDB flag_dbs pkgarg @@ -1153,8 +1164,8 @@ listPackages :: Verbosity -> [Flag] -> Maybe PackageArg listPackages verbosity my_flags mPackageName mModuleName = do let simple_output = FlagSimpleOutput `elem` my_flags (db_stack, _, flag_db_stack) <- - getPkgDatabases verbosity False{-modify-} False{-use user-} True{-use cache-} - False{-expand vars-} my_flags + getPkgDatabases verbosity False{-modify-} False{-use user-} + True{-use cache-} False{-expand vars-} my_flags let db_stack_filtered -- if a package is given, filter out all other packages | Just this <- mPackageName = @@ -1255,8 +1266,8 @@ simplePackageList my_flags pkgs = do showPackageDot :: Verbosity -> [Flag] -> IO () showPackageDot verbosity myflags = do (_, _, flag_db_stack) <- - getPkgDatabases verbosity False{-modify-} False{-use user-} True{-use cache-} - False{-expand vars-} myflags + getPkgDatabases verbosity False{-modify-} False{-use user-} + True{-use cache-} False{-expand vars-} myflags let all_pkgs = allPackagesInStack flag_db_stack ipix = PackageIndex.fromList all_pkgs @@ -1280,8 +1291,8 @@ showPackageDot verbosity myflags = do latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO () latestPackage verbosity my_flags pkgid = do (_, _, flag_db_stack) <- - getPkgDatabases verbosity False{-modify-} False{-use user-} True{-use cache-} - False{-expand vars-} my_flags + getPkgDatabases verbosity False{-modify-} False{-use user-} + True{-use cache-} False{-expand vars-} my_flags ps <- findPackages flag_db_stack (Id pkgid) case ps of @@ -1296,8 +1307,8 @@ latestPackage verbosity my_flags pkgid = do describePackage :: Verbosity -> [Flag] -> PackageArg -> Bool -> IO () describePackage verbosity my_flags pkgarg expand_pkgroot = do (_, _, flag_db_stack) <- - getPkgDatabases verbosity False{-modify-} False{-use user-} True{-use cache-} - expand_pkgroot my_flags + getPkgDatabases verbosity False{-modify-} False{-use user-} + True{-use cache-} expand_pkgroot my_flags dbs <- findPackagesByDB flag_db_stack pkgarg doDump expand_pkgroot [ (pkg, locationAbsolute db) | (db, pkgs) <- dbs, pkg <- pkgs ] @@ -1305,8 +1316,8 @@ describePackage verbosity my_flags pkgarg expand_pkgroot = do dumpPackages :: Verbosity -> [Flag] -> Bool -> IO () dumpPackages verbosity my_flags expand_pkgroot = do (_, _, flag_db_stack) <- - getPkgDatabases verbosity False{-modify-} False{-use user-} True{-use cache-} - expand_pkgroot my_flags + getPkgDatabases verbosity False{-modify-} False{-use user-} + True{-use cache-} expand_pkgroot my_flags doDump expand_pkgroot [ (pkg, locationAbsolute db) | db <- flag_db_stack, pkg <- packages db ] @@ -1362,8 +1373,8 @@ matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> Bool -> IO () describeField verbosity my_flags pkgarg fields expand_pkgroot = do (_, _, flag_db_stack) <- - getPkgDatabases verbosity False{-modify-} False{-use user-} True{-use cache-} - expand_pkgroot my_flags + getPkgDatabases verbosity False{-modify-} False{-use user-} + True{-use cache-} expand_pkgroot my_flags fns <- mapM toField fields ps <- findPackages flag_db_stack pkgarg mapM_ (selectFields fns) ps @@ -1382,9 +1393,11 @@ describeField verbosity my_flags pkgarg fields expand_pkgroot = do checkConsistency :: Verbosity -> [Flag] -> IO () checkConsistency verbosity my_flags = do (db_stack, _, _) <- - getPkgDatabases verbosity False{-modify-} True{-use user-} True{-use cache-} True{-expand vars-} my_flags + getPkgDatabases verbosity False{-modify-} True{-use user-} + True{-use cache-} True{-expand vars-} + my_flags -- although check is not a modify command, we do need to use the user - -- db, because ordering is important. + -- db, because we may need it to verify package deps. let simple_output = FlagSimpleOutput `elem` my_flags @@ -2066,7 +2079,7 @@ getInstalledPackageInfo = do instance Binary PackageIdentifier where put pid = do put (pkgName pid); put (pkgVersion pid) - get = do + get = do pkgName <- get pkgVersion <- get return PackageIdentifier{..} |