Add "ghc-pkg init" command for creating a new package DB

[ghc-hetmet.git] / utils / ghc-pkg / Main.hs

diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 411dc56..aa81178 100644 (file)
--- 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
@@ -169,6 +173,12 @@ 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" ++
@@ -302,6 +312,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 +563,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,6 +578,17 @@ 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
@@ -585,6 +608,18 @@ 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