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
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
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" ++
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] ->
| 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
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
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
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
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 ++ "\""
| 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 "}"