X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=0ac8041034ec6fec4ca31e8607058b8f0b5ee2ee;hb=dc5b9bd64d1c1f544e4813dc946b5a83ad304cee;hp=2ddf3152598e01ea875be247e8558e42365fba05;hpb=f314da8e1877e24c405630c6e8335b8f5bd49778;p=ghc-hetmet.git

diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 2ddf315..0ac8041 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -10,7 +10,7 @@
 module Main (main) where
 
 import Version ( version, targetOS, targetARCH )
-import Distribution.InstalledPackageInfo.Binary
+import Distribution.InstalledPackageInfo.Binary()
 import qualified Distribution.Simple.PackageIndex as PackageIndex
 import Distribution.ModuleName hiding (main)
 import Distribution.InstalledPackageInfo
@@ -73,7 +73,7 @@ import System.Process(runInteractiveCommand)
 import qualified System.Info(os)
 #endif
 
-#if !defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 611
+#if !defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 611 && !defined(BOOTSTRAPPING)
 import System.Console.Terminfo as Terminfo
 #endif
 
@@ -182,11 +182,11 @@ usageHeader prog = substProg prog $
   "  $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" ++
@@ -233,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" ++
@@ -593,7 +601,7 @@ myReadBinPackageDB filepath = do
 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->
@@ -602,7 +610,7 @@ 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"
@@ -642,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
 
@@ -723,7 +735,7 @@ updateDBCache verbosity db = do
   let filename = location db </> cachefilename
   when (verbosity > Normal) $
       putStrLn ("writing cache " ++ filename)
-  writeBinPackageDB filename (map convertPackageInfoOut (packages db))
+  writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db))
     `catch` \e ->
       if isPermissionError e
       then die (filename ++ ": you don't have permission to modify this file")
@@ -845,7 +857,7 @@ listPackages verbosity my_flags mPackageName mModuleName = do
 
   if simple_output then show_simple stack else do
 
-#if defined(mingw32_HOST_OS) || __GLASGOW_HASKELL__ < 611
+#if defined(mingw32_HOST_OS) || __GLASGOW_HASKELL__ < 611 || defined(BOOTSTRAPPING)
   mapM_ show_normal stack
 #else
   let
@@ -890,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 ++ "\""
@@ -898,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 "}"
@@ -934,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]
@@ -1531,12 +1548,20 @@ catchError io handler = io `Exception.catch` handler'
     where handler' (Exception.ErrorCall err) = handler err
 
 
+writeBinaryFileAtomic :: Bin.Binary a => FilePath -> a -> IO ()
+writeBinaryFileAtomic targetFile obj =
+  withFileAtomic targetFile $ \h -> B.hPutStr h (Bin.encode obj)
+
+writeFileAtomic :: FilePath -> String -> IO ()
+writeFileAtomic targetFile content =
+  withFileAtomic targetFile $ \h -> hPutStr h content
+
 -- copied from Cabal's Distribution.Simple.Utils, except that we want
 -- to use text files here, rather than binary files.
-writeFileAtomic :: FilePath -> String -> IO ()
-writeFileAtomic targetFile content = do
+withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO ()
+withFileAtomic targetFile write_content = do
   (newFile, newHandle) <- openNewFile targetDir template
-  do  hPutStr newHandle content
+  do  write_content newHandle
       hClose newHandle
 #if mingw32_HOST_OS || mingw32_TARGET_OS
       renameFile newFile targetFile
@@ -1643,3 +1668,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