X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=ea18000818432033c9c14724bbf3765e8a605548;hb=59b01a2fb6cd6a9af37f5fd6775f574bc53af02a;hp=411dc56afdf60b02d7ceec15caba91772dcdbf3c;hpb=930421d4ed09e5389e0ef4c5eef36075a6809cc0;p=ghc-hetmet.git diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 411dc56..ea18000 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -48,6 +48,10 @@ import System.IO.Error (try) import Data.List import Control.Concurrent +import qualified Data.ByteString.Lazy as B +import qualified Data.Binary as Bin +import qualified Data.Binary.Get as Bin + import Foreign import Foreign.C #ifdef mingw32_HOST_OS @@ -69,7 +73,7 @@ import System.Process(runInteractiveCommand) import qualified System.Info(os) #endif -#if __GLASGOW_HASKELL__ >= 611 +#if !defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 611 && !defined(BOOTSTRAPPING) import System.Console.Terminfo as Terminfo #endif @@ -169,14 +173,20 @@ ourCopyright = "GHC package manager version " ++ Version.version ++ "\n" usageHeader :: String -> String usageHeader prog = substProg prog $ "Usage:\n" ++ + " $p init {path}\n" ++ + " Create and initialise a package database at the location {path}.\n" ++ + " Packages can be registered in the new database using the register\n" ++ + " command with --package-conf={path}. To use the new database with GHC,\n" ++ + " use GHC's -package-conf flag.\n" ++ + "\n" ++ " $p register {filename | -}\n" ++ " Register the package using the specified installed package\n" ++ " description. The syntax for the latter is given in the $p\n" ++ - " documentation.\n" ++ + " documentation. The input file should be encoded in UTF-8.\n" ++ "\n" ++ " $p update {filename | -}\n" ++ " Register the package, overwriting any other package with the\n" ++ - " same name.\n" ++ + " same name. The input file should be encoded in UTF-8.\n" ++ "\n" ++ " $p unregister {pkg-id}\n" ++ " Unregister the specified package.\n" ++ @@ -223,7 +233,15 @@ usageHeader prog = substProg prog $ " $p dump\n" ++ " Dump the registered description for every package. This is like\n" ++ " \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++ - " by tools that parse the results, rather than humans.\n" ++ + " by tools that parse the results, rather than humans. The output is\n" ++ + " always encoded in UTF-8, regardless of the current locale.\n" ++ + "\n" ++ + " $p recache\n" ++ + " Regenerate the package database cache. This command should only be\n" ++ + " necessary if you added a package to the database by dropping a file\n" ++ + " into the database directory manually. By default, the global DB\n" ++ + " is recached; to recache a different DB use --user or --package-conf\n" ++ + " as appropriate.\n" ++ "\n" ++ " Substring matching is supported for {module} in find-module and\n" ++ " for {pkg} in list, describe, and field, where a '*' indicates\n" ++ @@ -302,6 +320,8 @@ runit verbosity cli nonopts = do print filename glob filename >>= print #endif + ["init", filename] -> + initPackageDB filename verbosity cli ["register", filename] -> registerPackage filename verbosity cli auto_ghci_libs False force ["update", filename] -> @@ -551,7 +571,7 @@ readParseDatabase verbosity mb_user_conf use_cache path | tcache >= tdir -> do when (verbosity > Normal) $ putStrLn ("using cache: " ++ cache) - pkgs <- readBinPackageDB cache + pkgs <- myReadBinPackageDB cache let pkgs' = map convertPackageInfoIn pkgs return PackageDB { location = path, packages = pkgs' } | otherwise -> do @@ -566,11 +586,22 @@ readParseDatabase verbosity mb_user_conf use_cache path map (path ) confs return PackageDB { location = path, packages = pkgs } +-- read the package.cache file strictly, to work around a problem with +-- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed +-- after it has been completely read, leading to a sharing violation +-- later. +myReadBinPackageDB :: FilePath -> IO [InstalledPackageInfoString] +myReadBinPackageDB filepath = do + h <- openBinaryFile filepath ReadMode + sz <- hFileSize h + b <- B.hGet h (fromIntegral sz) + hClose h + return $ Bin.runGet Bin.get b parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo] parseMultiPackageConf verbosity file = do when (verbosity > Normal) $ putStrLn ("reading package database: " ++ file) - str <- readFile file + str <- readUTF8File file let pkgs = map convertPackageInfoIn $ read str Exception.evaluate pkgs `catchError` \e-> @@ -579,12 +610,24 @@ parseMultiPackageConf verbosity file = do parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo parseSingletonPackageConf verbosity file = do when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file) - readFile file >>= parsePackageInfo + readUTF8File file >>= parsePackageInfo cachefilename :: FilePath cachefilename = "package.cache" -- ----------------------------------------------------------------------------- +-- Creating a new package DB + +initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO () +initPackageDB filename verbosity _flags = do + let eexist = die ("cannot create: " ++ filename ++ " already exists") + b1 <- doesFileExist filename + when b1 eexist + b2 <- doesDirectoryExist filename + when b2 eexist + changeDB verbosity [] PackageDB{ location = filename, packages = [] } + +-- ----------------------------------------------------------------------------- -- Registering registerPackage :: FilePath @@ -607,11 +650,15 @@ registerPackage input verbosity my_flags auto_ghci_libs update force = do "-" -> do when (verbosity >= Normal) $ putStr "Reading package info from stdin ... " +#if __GLASGOW_HASKELL__ >= 612 + -- fix the encoding to UTF-8, since this is an interchange format + hSetEncoding stdin utf8 +#endif getContents f -> do when (verbosity >= Normal) $ putStr ("Reading package info from " ++ show f ++ " ... ") - readFile f + readUTF8File f expanded <- expandEnvVars s force @@ -810,7 +857,7 @@ listPackages verbosity my_flags mPackageName mModuleName = do if simple_output then show_simple stack else do -#if __GLASGOW_HASKELL__ < 611 +#if defined(mingw32_HOST_OS) || __GLASGOW_HASKELL__ < 611 || defined(BOOTSTRAPPING) mapM_ show_normal stack #else let @@ -855,7 +902,7 @@ showPackageDot verbosity myflags = do getPkgDatabases verbosity False True{-use cache-} myflags let all_pkgs = allPackagesInStack flag_db_stack - ipix = PackageIndex.listToInstalledPackageIndex all_pkgs + ipix = PackageIndex.fromList all_pkgs putStrLn "digraph {" let quote s = '"':s ++ "\"" @@ -863,7 +910,7 @@ showPackageDot verbosity myflags = do | p <- all_pkgs, let from = display (sourcePackageId p), depid <- depends p, - Just dep <- [PackageIndex.lookupInstalledPackage ipix depid], + Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid], let to = display (sourcePackageId dep) ] putStrLn "}" @@ -899,7 +946,12 @@ dumpPackages verbosity my_flags = do doDump (allPackagesInStack flag_db_stack) doDump :: [InstalledPackageInfo] -> IO () -doDump = mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo +doDump pkgs = do +#if __GLASGOW_HASKELL__ >= 612 + -- fix the encoding to UTF-8, since this is an interchange format + hSetEncoding stdout utf8 +#endif + mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo $ pkgs -- PackageId is can have globVersion for the version findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo] @@ -1608,3 +1660,12 @@ parseSearchPath path = split path _ -> chunk' (chunk', rest') = break isSearchPathSeparator s + +readUTF8File :: FilePath -> IO String +readUTF8File file = do + h <- openFile file ReadMode +#if __GLASGOW_HASKELL__ >= 612 + -- fix the encoding to UTF-8 + hSetEncoding h utf8 +#endif + hGetContents h