X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=d5e7bce25e881f9c31bcfe8140c3834d994f1e62;hb=7068f60cc7aefef514f02d5927d5abbdcd5c94d4;hp=114ce24f1e68fdf3dfa3cdad5af663de4a7ee3bc;hpb=e8553a5d90ed7ead50318dfc362f65414580701c;p=ghc-hetmet.git

diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 114ce24..d5e7bce 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -73,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
 
@@ -173,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" ++
@@ -306,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] ->
@@ -600,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
@@ -825,7 +845,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
@@ -870,7 +890,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 ++ "\""
@@ -878,7 +898,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 "}"