-{-# OPTIONS -fglasgow-exts -cpp #-}
+{-# LANGUAGE PatternGuards, CPP, ForeignFunctionInterface #-}
-----------------------------------------------------------------------------
--
--- (c) The University of Glasgow 2004.
+-- (c) The University of Glasgow 2004-2009.
--
-- Package management tool
--
-----------------------------------------------------------------------------
--- TODO:
--- * validate modules
--- * expanding of variables in new-style package conf
--- * version manipulation (checking whether old version exists,
--- hiding old version?)
-
module Main (main) where
import Version ( version, targetOS, targetARCH )
-import Distribution.InstalledPackageInfo hiding (depends)
+import Distribution.InstalledPackageInfo.Binary()
+import qualified Distribution.Simple.PackageIndex as PackageIndex
+import Distribution.ModuleName hiding (main)
+import Distribution.InstalledPackageInfo
import Distribution.Compat.ReadP
import Distribution.ParseUtils
-import Distribution.Package
+import Distribution.Package hiding (depends)
import Distribution.Text
import Distribution.Version
-import System.FilePath
+import System.FilePath as FilePath
+import qualified System.FilePath.Posix as FilePath.Posix
import System.Cmd ( rawSystem )
-import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
+import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing,
+ getModificationTime )
+import Text.Printf
import Prelude
-#include "../../includes/ghcconfig.h"
-
import System.Console.GetOpt
-import Text.PrettyPrint
import qualified Control.Exception as Exception
import Data.Maybe
import Data.Char ( isSpace, toLower )
import Control.Monad
import System.Directory ( doesDirectoryExist, getDirectoryContents,
- doesFileExist, renameFile, removeFile )
+ doesFileExist, renameFile, removeFile,
+ getCurrentDirectory )
import System.Exit ( exitWith, ExitCode(..) )
import System.Environment ( getArgs, getProgName, getEnv )
import System.IO
-import System.IO.Error (try)
-import Data.List ( isPrefixOf, isSuffixOf, intersperse, sortBy, nub,
- unfoldr, break, partition )
-#if __GLASGOW_HASKELL__ > 604
-import Data.List ( isInfixOf )
-#else
-import Data.List ( tails )
-#endif
+import System.IO.Error
+import Data.List
import Control.Concurrent
-#ifdef mingw32_HOST_OS
+import qualified Data.ByteString.Lazy as B
+import qualified Data.Binary as Bin
+import qualified Data.Binary.Get as Bin
+
+#if defined(mingw32_HOST_OS)
+-- mingw32 needs these for getExecDir, GHC <6.12 needs them for openNewFile
import Foreign
-import Foreign.C.String
+import Foreign.C
+#endif
+
+#ifdef mingw32_HOST_OS
import GHC.ConsoleHandler
#else
-import System.Posix
+import System.Posix hiding (fdToHandle)
#endif
-import IO ( isPermissionError, isDoesNotExistError )
-
#if defined(GLOB)
import System.Process(runInteractiveCommand)
import qualified System.Info(os)
#endif
+#if !defined(mingw32_HOST_OS) && !defined(BOOTSTRAPPING)
+import System.Console.Terminfo as Terminfo
+#endif
+
-- -----------------------------------------------------------------------------
-- Entry point
(cli,_,[]) | FlagVersion `elem` cli ->
bye ourCopyright
(cli,nonopts,[]) ->
- runit cli nonopts
+ case getVerbosity Normal cli of
+ Right v -> runit v cli nonopts
+ Left err -> die err
(_,_,errors) -> do
prog <- getProgramName
die (concat errors ++ usageInfo (usageHeader prog) flags)
| FlagForce
| FlagForceFiles
| FlagAutoGHCiLibs
+ | FlagExpandEnvVars
+ | FlagExpandPkgroot
+ | FlagNoExpandPkgroot
| FlagSimpleOutput
| FlagNamesOnly
| FlagIgnoreCase
+ | FlagNoUserDb
+ | FlagVerbosity (Maybe String)
deriving Eq
flags :: [OptDescr Flag]
"use the specified package config file",
Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")
"location of the global package config",
+ Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)
+ "never read the user package database",
Option [] ["force"] (NoArg FlagForce)
"ignore missing dependencies, directories, and libraries",
Option [] ["force-files"] (NoArg FlagForceFiles)
"ignore missing directories and libraries only",
Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
"automatically build libs for GHCi (with register)",
+ Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars)
+ "expand environment variables (${name}-style) in input package descriptions",
+ Option [] ["expand-pkgroot"] (NoArg FlagExpandPkgroot)
+ "expand ${pkgroot}-relative paths to absolute in output package descriptions",
+ Option [] ["no-expand-pkgroot"] (NoArg FlagNoExpandPkgroot)
+ "preserve ${pkgroot}-relative paths in output package descriptions",
Option ['?'] ["help"] (NoArg FlagHelp)
"display this help and exit",
Option ['V'] ["version"] (NoArg FlagVersion)
Option [] ["names-only"] (NoArg FlagNamesOnly)
"only print package names, not versions; can only be used with list --simple-output",
Option [] ["ignore-case"] (NoArg FlagIgnoreCase)
- "ignore case for substring matching"
+ "ignore case for substring matching",
+ Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity")
+ "verbosity level (0-2, default 1)"
]
+data Verbosity = Silent | Normal | Verbose
+ deriving (Show, Eq, Ord)
+
+getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity
+getVerbosity v [] = Right v
+getVerbosity _ (FlagVerbosity Nothing : fs) = getVerbosity Verbose fs
+getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent fs
+getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal fs
+getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs
+getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v)
+getVerbosity v (_ : fs) = getVerbosity v fs
+
deprecFlags :: [OptDescr Flag]
deprecFlags = [
-- put deprecated flags here
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" ++
" all the registered versions will be listed in ascending order.\n" ++
" Accepts the --simple-output flag.\n" ++
"\n" ++
+ " $p dot\n" ++
+ " Generate a graph of the package dependencies in a form suitable\n" ++
+ " for input for the graphviz tools. For example, to generate a PDF" ++
+ " of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++
+ "\n" ++
" $p find-module {module}\n" ++
" List registered packages exposing module {module} in the global\n" ++
" database, and also the user database if --user is given.\n" ++
" $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" ++
" entirely. When multiple of these options are given, the rightmost\n"++
" one is used as the database to act upon.\n"++
"\n"++
- " Commands that query the package database (list, latest, describe,\n"++
+ " Commands that query the package database (list, tree, latest, describe,\n"++
" field) operate on the list of databases specified by the flags\n"++
" --user, --global, and --package-conf. If none of these flags are\n"++
" given, the default is --global --user.\n"++
-- -----------------------------------------------------------------------------
-- Do the business
-data Force = ForceAll | ForceFiles | NoForce
+data Force = NoForce | ForceFiles | ForceAll | CannotForce
+ deriving (Eq,Ord)
data PackageArg = Id PackageIdentifier | Substring String (String->Bool)
-runit :: [Flag] -> [String] -> IO ()
-runit cli nonopts = do
+runit :: Verbosity -> [Flag] -> [String] -> IO ()
+runit verbosity cli nonopts = do
installSignalHandlers -- catch ^C and clean up
prog <- getProgramName
let
| FlagForceFiles `elem` cli = ForceFiles
| otherwise = NoForce
auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
+ expand_env_vars= FlagExpandEnvVars `elem` cli
+ mexpand_pkgroot= foldl' accumExpandPkgroot Nothing cli
+ where accumExpandPkgroot _ FlagExpandPkgroot = Just True
+ accumExpandPkgroot _ FlagNoExpandPkgroot = Just False
+ accumExpandPkgroot x _ = x
+
splitFields fields = unfoldr splitComma (',':fields)
where splitComma "" = Nothing
splitComma fs = Just $ break (==',') (tail fs)
print filename
glob filename >>= print
#endif
+ ["init", filename] ->
+ initPackageDB filename verbosity cli
["register", filename] ->
- registerPackage filename cli auto_ghci_libs False force
+ registerPackage filename verbosity cli
+ auto_ghci_libs expand_env_vars False force
["update", filename] ->
- registerPackage filename cli auto_ghci_libs True force
+ registerPackage filename verbosity cli
+ auto_ghci_libs expand_env_vars True force
["unregister", pkgid_str] -> do
pkgid <- readGlobPkgId pkgid_str
- unregisterPackage pkgid cli force
+ unregisterPackage pkgid verbosity cli force
["expose", pkgid_str] -> do
pkgid <- readGlobPkgId pkgid_str
- exposePackage pkgid cli force
+ exposePackage pkgid verbosity cli force
["hide", pkgid_str] -> do
pkgid <- readGlobPkgId pkgid_str
- hidePackage pkgid cli force
+ hidePackage pkgid verbosity cli force
["list"] -> do
- listPackages cli Nothing Nothing
+ listPackages verbosity cli Nothing Nothing
["list", pkgid_str] ->
case substringCheck pkgid_str of
Nothing -> do pkgid <- readGlobPkgId pkgid_str
- listPackages cli (Just (Id pkgid)) Nothing
- Just m -> listPackages cli (Just (Substring pkgid_str m)) Nothing
+ listPackages verbosity cli (Just (Id pkgid)) Nothing
+ Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing
+ ["dot"] -> do
+ showPackageDot verbosity cli
["find-module", moduleName] -> do
let match = maybe (==moduleName) id (substringCheck moduleName)
- listPackages cli Nothing (Just match)
+ listPackages verbosity cli Nothing (Just match)
["latest", pkgid_str] -> do
pkgid <- readGlobPkgId pkgid_str
- latestPackage cli pkgid
- ["describe", pkgid_str] ->
- case substringCheck pkgid_str of
- Nothing -> do pkgid <- readGlobPkgId pkgid_str
- describePackage cli (Id pkgid)
- Just m -> describePackage cli (Substring pkgid_str m)
- ["field", pkgid_str, fields] ->
- case substringCheck pkgid_str of
- Nothing -> do pkgid <- readGlobPkgId pkgid_str
- describeField cli (Id pkgid) (splitFields fields)
- Just m -> describeField cli (Substring pkgid_str m)
- (splitFields fields)
+ latestPackage verbosity cli pkgid
+ ["describe", pkgid_str] -> do
+ pkgarg <- case substringCheck pkgid_str of
+ Nothing -> liftM Id (readGlobPkgId pkgid_str)
+ Just m -> return (Substring pkgid_str m)
+ describePackage verbosity cli pkgarg (fromMaybe False mexpand_pkgroot)
+
+ ["field", pkgid_str, fields] -> do
+ pkgarg <- case substringCheck pkgid_str of
+ Nothing -> liftM Id (readGlobPkgId pkgid_str)
+ Just m -> return (Substring pkgid_str m)
+ describeField verbosity cli pkgarg
+ (splitFields fields) (fromMaybe True mexpand_pkgroot)
+
["check"] -> do
- checkConsistency cli
+ checkConsistency verbosity cli
["dump"] -> do
- dumpPackages cli
+ dumpPackages verbosity cli (fromMaybe False mexpand_pkgroot)
+
+ ["recache"] -> do
+ recache verbosity cli
[] -> do
die ("missing command\n" ++
parse
+++
(do n <- parse
- string "-*"
+ _ <- string "-*"
return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
-- globVersion means "all versions"
-- Some commands operate on multiple databases, with overlapping semantics:
-- list, describe, field
-type PackageDBName = FilePath
-type PackageDB = [InstalledPackageInfo]
-
-type PackageDBStack = [(PackageDBName,PackageDB)]
+data PackageDB
+ = PackageDB {
+ location, locationAbsolute :: !FilePath,
+ -- We need both possibly-relative and definately-absolute package
+ -- db locations. This is because the relative location is used as
+ -- an identifier for the db, so it is important we do not modify it.
+ -- On the other hand we need the absolute path in a few places
+ -- particularly in relation to the ${pkgroot} stuff.
+
+ packages :: [InstalledPackageInfo]
+ }
+
+type PackageDBStack = [PackageDB]
-- A stack of package databases. Convention: head is the topmost
- -- in the stack. Earlier entries override later one.
+ -- in the stack.
allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
-allPackagesInStack = concatMap snd
+allPackagesInStack = concatMap packages
-getPkgDatabases :: Bool -> [Flag] -> IO PackageDBStack
-getPkgDatabases modify my_flags = do
+getPkgDatabases :: Verbosity
+ -> Bool -- we are modifying, not reading
+ -> Bool -- read caches, if available
+ -> Bool -- expand vars, like ${pkgroot} and $topdir
+ -> [Flag]
+ -> IO (PackageDBStack,
+ -- the real package DB stack: [global,user] ++
+ -- DBs specified on the command line with -f.
+ Maybe FilePath,
+ -- which one to modify, if any
+ PackageDBStack)
+ -- the package DBs specified on the command
+ -- line, or [global,user] otherwise. This
+ -- is used as the list of package DBs for
+ -- commands that just read the DB, such as 'list'.
+
+getPkgDatabases verbosity modify use_cache expand_vars my_flags = do
-- first we determine the location of the global package config. On Windows,
-- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
-- location is passed to the binary using the --global-config flag by the
let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
global_conf <-
case [ f | FlagGlobalConfig f <- my_flags ] of
- [] -> do mb_dir <- getExecDir "/bin/ghc-pkg.exe"
+ [] -> do mb_dir <- getLibDir
case mb_dir of
- Nothing -> die err_msg
- Just dir ->
- do let path1 = dir </> "package.conf"
- path2 = dir </> ".." </> ".." </> ".."
- </> "inplace-datadir"
- </> "package.conf"
- exists1 <- doesFileExist path1
- exists2 <- doesFileExist path2
- if exists1 then return path1
- else if exists2 then return path2
- else die "Can't find package.conf"
+ Nothing -> die err_msg
+ Just dir -> do
+ r <- lookForPackageDBIn dir
+ case r of
+ Nothing -> die ("Can't find package database in " ++ dir)
+ Just path -> return path
fs -> return (last fs)
- let global_conf_dir = global_conf ++ ".d"
- global_conf_dir_exists <- doesDirectoryExist global_conf_dir
- global_confs <-
- if global_conf_dir_exists
- then do files <- getDirectoryContents global_conf_dir
- return [ global_conf_dir ++ '/' : file
- | file <- files
- , isSuffixOf ".conf" file]
- else return []
+ -- The value of the $topdir variable used in some package descriptions
+ -- Note that the way we calculate this is slightly different to how it
+ -- is done in ghc itself. We rely on the convention that the global
+ -- package db lives in ghc's libdir.
+ top_dir <- absolutePath (takeDirectory global_conf)
+
+ let no_user_db = FlagNoUserDb `elem` my_flags
-- get the location of the user package database, and create it if necessary
-- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
- appdir <- try $ getAppUserDataDirectory "ghc"
+ e_appdir <- tryIO $ getAppUserDataDirectory "ghc"
mb_user_conf <-
- case appdir of
- Right dir -> do
- let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
- user_conf = dir </> subdir </> "package.conf"
- user_exists <- doesFileExist user_conf
- return (Just (user_conf,user_exists))
- Left ex ->
- return Nothing
+ if no_user_db then return Nothing else
+ case e_appdir of
+ Left _ -> return Nothing
+ Right appdir -> do
+ let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
+ dir = appdir </> subdir
+ r <- lookForPackageDBIn dir
+ case r of
+ Nothing -> return (Just (dir </> "package.conf.d", False))
+ Just f -> return (Just (f, True))
-- If the user database doesn't exist, and this command isn't a
-- "modify" command, then we won't attempt to create or use it.
let sys_databases
| Just (user_conf,user_exists) <- mb_user_conf,
- modify || user_exists = user_conf : global_confs ++ [global_conf]
- | otherwise = global_confs ++ [global_conf]
+ modify || user_exists = [user_conf, global_conf]
+ | otherwise = [global_conf]
- e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH")
+ e_pkg_path <- tryIO (System.Environment.getEnv "GHC_PACKAGE_PATH")
let env_stack =
case e_pkg_path of
Left _ -> sys_databases
Right path
| last cs == "" -> init cs ++ sys_databases
| otherwise -> cs
- where cs = splitSearchPath path
+ where cs = parseSearchPath path
-- The "global" database is always the one at the bottom of the stack.
-- This is the database we modify by default.
let db_flags = [ f | Just f <- map is_db_flag my_flags ]
where is_db_flag FlagUser
- | Just (user_conf,user_exists) <- mb_user_conf
+ | Just (user_conf, _user_exists) <- mb_user_conf
= Just user_conf
is_db_flag FlagGlobal = Just virt_global_conf
is_db_flag (FlagConfig f) = Just f
is_db_flag _ = Nothing
- final_stack <-
- if not modify
- then -- For a "read" command, we use all the databases
- -- specified on the command line. If there are no
- -- command-line flags specifying databases, the default
- -- is to use all the ones we know about.
- if null db_flags then return env_stack
- else return (reverse (nub db_flags))
- else let
- -- For a "modify" command, treat all the databases as
- -- a stack, where we are modifying the top one, but it
- -- can refer to packages in databases further down the
- -- stack.
-
- -- -f flags on the command line add to the database
- -- stack, unless any of them are present in the stack
- -- already.
- flag_stack = filter (`notElem` env_stack)
- [ f | FlagConfig f <- reverse my_flags ]
- ++ env_stack
-
- modifying f
- | f `elem` flag_stack = return (dropWhile (/= f) flag_stack)
- | otherwise = die ("requesting modification of database:\n\t" ++ f ++ "\n\twhich is not in the database stack.")
- in
- if null db_flags
- then modifying virt_global_conf
- else modifying (head db_flags)
-
- db_stack <- mapM readParseDatabase final_stack
- return db_stack
-
-readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB)
-readParseDatabase filename = do
- str <- readFile filename `catchIO` \_ -> return emptyPackageConfig
- let packages = map convertPackageInfoIn $ read str
- Exception.evaluate packages
+ let flag_db_names | null db_flags = env_stack
+ | otherwise = reverse (nub db_flags)
+
+ -- For a "modify" command, treat all the databases as
+ -- a stack, where we are modifying the top one, but it
+ -- can refer to packages in databases further down the
+ -- stack.
+
+ -- -f flags on the command line add to the database
+ -- stack, unless any of them are present in the stack
+ -- already.
+ let final_stack = filter (`notElem` env_stack)
+ [ f | FlagConfig f <- reverse my_flags ]
+ ++ env_stack
+
+ -- the database we actually modify is the one mentioned
+ -- rightmost on the command-line.
+ let to_modify
+ | not modify = Nothing
+ | null db_flags = Just virt_global_conf
+ | otherwise = Just (last db_flags)
+
+ db_stack <- sequence
+ [ do db <- readParseDatabase verbosity mb_user_conf use_cache db_path
+ if expand_vars then return (mungePackageDBPaths top_dir db)
+ else return db
+ | db_path <- final_stack ]
+
+ let flag_db_stack = [ db | db_name <- flag_db_names,
+ db <- db_stack, location db == db_name ]
+
+ return (db_stack, to_modify, flag_db_stack)
+
+
+lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)
+lookForPackageDBIn dir = do
+ let path_dir = dir </> "package.conf.d"
+ exists_dir <- doesDirectoryExist path_dir
+ if exists_dir then return (Just path_dir) else do
+ let path_file = dir </> "package.conf"
+ exists_file <- doesFileExist path_file
+ if exists_file then return (Just path_file) else return Nothing
+
+readParseDatabase :: Verbosity
+ -> Maybe (FilePath,Bool)
+ -> Bool -- use cache
+ -> FilePath
+ -> IO PackageDB
+
+readParseDatabase verbosity mb_user_conf use_cache path
+ -- the user database (only) is allowed to be non-existent
+ | Just (user_conf,False) <- mb_user_conf, path == user_conf
+ = mkPackageDB []
+ | otherwise
+ = do e <- tryIO $ getDirectoryContents path
+ case e of
+ Left _ -> do
+ pkgs <- parseMultiPackageConf verbosity path
+ mkPackageDB pkgs
+ Right fs
+ | not use_cache -> ignore_cache
+ | otherwise -> do
+ let cache = path </> cachefilename
+ tdir <- getModificationTime path
+ e_tcache <- tryIO $ getModificationTime cache
+ case e_tcache of
+ Left ex -> do
+ when (verbosity > Normal) $
+ warn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
+ ignore_cache
+ Right tcache
+ | tcache >= tdir -> do
+ when (verbosity > Normal) $
+ putStrLn ("using cache: " ++ cache)
+ pkgs <- myReadBinPackageDB cache
+ let pkgs' = map convertPackageInfoIn pkgs
+ mkPackageDB pkgs'
+ | otherwise -> do
+ when (verbosity >= Normal) $ do
+ warn ("WARNING: cache is out of date: " ++ cache)
+ warn " use 'ghc-pkg recache' to fix."
+ ignore_cache
+ where
+ ignore_cache = do
+ let confs = filter (".conf" `isSuffixOf`) fs
+ pkgs <- mapM (parseSingletonPackageConf verbosity) $
+ map (path </>) confs
+ mkPackageDB pkgs
+ where
+ mkPackageDB pkgs = do
+ path_abs <- absolutePath path
+ return PackageDB {
+ location = path,
+ locationAbsolute = path_abs,
+ 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 <- readUTF8File file
+ let pkgs = map convertPackageInfoIn $ read str
+ Exception.evaluate pkgs
`catchError` \e->
- die ("error while parsing " ++ filename ++ ": " ++ show e)
- return (filename,packages)
+ die ("error while parsing " ++ file ++ ": " ++ show e)
+
+parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
+parseSingletonPackageConf verbosity file = do
+ when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file)
+ readUTF8File file >>= fmap fst . parsePackageInfo
+
+cachefilename :: FilePath
+cachefilename = "package.cache"
+
+mungePackageDBPaths :: FilePath -> PackageDB -> PackageDB
+mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } =
+ db { packages = map (mungePackagePaths top_dir pkgroot) pkgs }
+ where
+ pkgroot = takeDirectory (locationAbsolute db)
+ -- It so happens that for both styles of package db ("package.conf"
+ -- files and "package.conf.d" dirs) the pkgroot is the parent directory
+ -- ${pkgroot}/package.conf or ${pkgroot}/package.conf.d/
+
+-- TODO: This code is duplicated in compiler/main/Packages.lhs
+mungePackagePaths :: FilePath -> FilePath
+ -> InstalledPackageInfo -> InstalledPackageInfo
+-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
+-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
+-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
+-- The "pkgroot" is the directory containing the package database.
+--
+-- Also perform a similar substitution for the older GHC-specific
+-- "$topdir" variable. The "topdir" is the location of the ghc
+-- installation (obtained from the -B option).
+mungePackagePaths top_dir pkgroot pkg =
+ pkg {
+ importDirs = munge_paths (importDirs pkg),
+ includeDirs = munge_paths (includeDirs pkg),
+ libraryDirs = munge_paths (libraryDirs pkg),
+ frameworkDirs = munge_paths (frameworkDirs pkg),
+ haddockInterfaces = munge_paths (haddockInterfaces pkg),
+ -- haddock-html is allowed to be either a URL or a file
+ haddockHTMLs = munge_paths (munge_urls (haddockHTMLs pkg))
+ }
+ where
+ munge_paths = map munge_path
+ munge_urls = map munge_url
+
+ munge_path p
+ | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
+ | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p'
+ | otherwise = p
+
+ munge_url p
+ | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
+ | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p'
+ | otherwise = p
+
+ toUrlPath r p = "file:///"
+ -- URLs always use posix style '/' separators:
+ ++ FilePath.Posix.joinPath
+ (r : -- We need to drop a leading "/" or "\\"
+ -- if there is one:
+ dropWhile (all isPathSeparator)
+ (FilePath.splitDirectories p))
+
+ -- We could drop the separator here, and then use </> above. However,
+ -- by leaving it in and using ++ we keep the same path separator
+ -- rather than letting FilePath change it to use \ as the separator
+ stripVarPrefix var path = case stripPrefix var path of
+ Just [] -> Just []
+ Just cs@(c : _) | isPathSeparator c -> Just cs
+ _ -> Nothing
+
-emptyPackageConfig :: String
-emptyPackageConfig = "[]"
+-- -----------------------------------------------------------------------------
+-- 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
+ filename_abs <- absolutePath filename
+ changeDB verbosity [] PackageDB {
+ location = filename, locationAbsolute = filename_abs,
+ packages = []
+ }
-- -----------------------------------------------------------------------------
-- Registering
registerPackage :: FilePath
+ -> Verbosity
-> [Flag]
-> Bool -- auto_ghci_libs
+ -> Bool -- expand_env_vars
-> Bool -- update
-> Force
-> IO ()
-registerPackage input my_flags auto_ghci_libs update force = do
- db_stack <- getPkgDatabases True my_flags
+registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update force = do
+ (db_stack, Just to_modify, _flag_dbs) <-
+ getPkgDatabases verbosity True True False{-expand vars-} my_flags
+
let
- db_to_operate_on = my_head "db" db_stack
- db_filename = fst db_to_operate_on
+ db_to_operate_on = my_head "register" $
+ filter ((== to_modify).location) db_stack
+ --
+ when (auto_ghci_libs && verbosity >= Silent) $
+ warn "Warning: --auto-ghci-libs is deprecated and will be removed in GHC 7.4"
--
-
s <-
case input of
"-" -> do
- putStr "Reading package info from stdin ... "
+ when (verbosity >= Normal) $
+ putStr "Reading package info from stdin ... "
+ -- fix the encoding to UTF-8, since this is an interchange format
+ hSetEncoding stdin utf8
getContents
f -> do
- putStr ("Reading package info from " ++ show f ++ " ... ")
- readFile f
-
- expanded <- expandEnvVars s force
-
- pkg <- parsePackageInfo expanded
- putStrLn "done."
-
- validatePackageConfig pkg db_stack auto_ghci_libs update force
- let new_details = filter not_this (snd db_to_operate_on) ++ [pkg]
- not_this p = package p /= package pkg
- writeNewConfig db_filename new_details
+ when (verbosity >= Normal) $
+ putStr ("Reading package info from " ++ show f ++ " ... ")
+ readUTF8File f
+
+ expanded <- if expand_env_vars then expandEnvVars s force
+ else return s
+
+ (pkg, ws) <- parsePackageInfo expanded
+ when (verbosity >= Normal) $
+ putStrLn "done."
+
+ -- report any warnings from the parse phase
+ _ <- reportValidateErrors [] ws
+ (display (sourcePackageId pkg) ++ ": Warning: ") Nothing
+
+ -- validate the expanded pkg, but register the unexpanded
+ pkgroot <- absolutePath (takeDirectory to_modify)
+ let top_dir = takeDirectory (location (last db_stack))
+ pkg_expanded = mungePackagePaths top_dir pkgroot pkg
+
+ let truncated_stack = dropWhile ((/= to_modify).location) db_stack
+ -- truncate the stack for validation, because we don't allow
+ -- packages lower in the stack to refer to those higher up.
+ validatePackageConfig pkg_expanded truncated_stack auto_ghci_libs update force
+ let
+ removes = [ RemovePackage p
+ | p <- packages db_to_operate_on,
+ sourcePackageId p == sourcePackageId pkg ]
+ --
+ changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
parsePackageInfo
:: String
- -> IO InstalledPackageInfo
+ -> IO (InstalledPackageInfo, [ValidateWarning])
parsePackageInfo str =
case parseInstalledPackageInfo str of
- ParseOk _warns ok -> return ok
+ ParseOk warnings ok -> return (ok, ws)
+ where
+ ws = [ msg | PWarning msg <- warnings
+ , not ("Unrecognized field pkgroot" `isPrefixOf` msg) ]
ParseFailed err -> case locatedErrorMsg err of
(Nothing, s) -> die s
(Just l, s) -> die (show l ++ ": " ++ s)
-- -----------------------------------------------------------------------------
+-- Making changes to a package database
+
+data DBOp = RemovePackage InstalledPackageInfo
+ | AddPackage InstalledPackageInfo
+ | ModifyPackage InstalledPackageInfo
+
+changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO ()
+changeDB verbosity cmds db = do
+ let db' = updateInternalDB db cmds
+ isfile <- doesFileExist (location db)
+ if isfile
+ then writeNewConfig verbosity (location db') (packages db')
+ else do
+ createDirectoryIfMissing True (location db)
+ changeDBDir verbosity cmds db'
+
+updateInternalDB :: PackageDB -> [DBOp] -> PackageDB
+updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }
+ where
+ do_cmd pkgs (RemovePackage p) =
+ filter ((/= installedPackageId p) . installedPackageId) pkgs
+ do_cmd pkgs (AddPackage p) = p : pkgs
+ do_cmd pkgs (ModifyPackage p) =
+ do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p)
+
+
+changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO ()
+changeDBDir verbosity cmds db = do
+ mapM_ do_cmd cmds
+ updateDBCache verbosity db
+ where
+ do_cmd (RemovePackage p) = do
+ let file = location db </> display (installedPackageId p) <.> "conf"
+ when (verbosity > Normal) $ putStrLn ("removing " ++ file)
+ removeFileSafe file
+ do_cmd (AddPackage p) = do
+ let file = location db </> display (installedPackageId p) <.> "conf"
+ when (verbosity > Normal) $ putStrLn ("writing " ++ file)
+ writeFileUtf8Atomic file (showInstalledPackageInfo p)
+ do_cmd (ModifyPackage p) =
+ do_cmd (AddPackage p)
+
+updateDBCache :: Verbosity -> PackageDB -> IO ()
+updateDBCache verbosity db = do
+ let filename = location db </> cachefilename
+ when (verbosity > Normal) $
+ putStrLn ("writing cache " ++ filename)
+ writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db))
+ `catchIO` \e ->
+ if isPermissionError e
+ then die (filename ++ ": you don't have permission to modify this file")
+ else ioError e
+
+-- -----------------------------------------------------------------------------
-- Exposing, Hiding, Unregistering are all similar
-exposePackage :: PackageIdentifier -> [Flag] -> Force -> IO ()
-exposePackage = modifyPackage (\p -> [p{exposed=True}])
+exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
+exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
-hidePackage :: PackageIdentifier -> [Flag] -> Force -> IO ()
-hidePackage = modifyPackage (\p -> [p{exposed=False}])
+hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
+hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
-unregisterPackage :: PackageIdentifier -> [Flag] -> Force -> IO ()
-unregisterPackage = modifyPackage (\_ -> [])
+unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
+unregisterPackage = modifyPackage RemovePackage
modifyPackage
- :: (InstalledPackageInfo -> [InstalledPackageInfo])
+ :: (InstalledPackageInfo -> DBOp)
-> PackageIdentifier
+ -> Verbosity
-> [Flag]
-> Force
-> IO ()
-modifyPackage fn pkgid my_flags force = do
- db_stack <- getPkgDatabases True{-modify-} my_flags
- let old_broken = brokenPackages (allPackagesInStack db_stack)
- let ((db_name, pkgs) : rest_of_stack) = db_stack
- ps <- findPackages [(db_name,pkgs)] (Id pkgid)
- let pids = map package ps
- let new_config = concat (map modify pkgs)
- modify pkg
- | package pkg `elem` pids = fn pkg
- | otherwise = [pkg]
- let new_stack = (db_name,new_config) : rest_of_stack
- new_broken = map package (brokenPackages (allPackagesInStack new_stack))
- newly_broken = filter (`notElem` map package old_broken) new_broken
+modifyPackage fn pkgid verbosity my_flags force = do
+ (db_stack, Just _to_modify, _flag_dbs) <-
+ getPkgDatabases verbosity True{-modify-} True{-use cache-} False{-expand vars-} my_flags
+ (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
+ let
+ db_name = location db
+ pkgs = packages db
+
+ pids = map sourcePackageId ps
+
+ cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ]
+ new_db = updateInternalDB db cmds
+
+ old_broken = brokenPackages (allPackagesInStack db_stack)
+ rest_of_stack = filter ((/= db_name) . location) db_stack
+ new_stack = new_db : rest_of_stack
+ new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack))
+ newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken
+ --
when (not (null newly_broken)) $
dieOrForceAll force ("unregistering " ++ display pkgid ++
" would break the following packages: "
++ unwords (map display newly_broken))
- writeNewConfig db_name new_config
+ changeDB verbosity cmds db
+
+recache :: Verbosity -> [Flag] -> IO ()
+recache verbosity my_flags = do
+ (db_stack, Just to_modify, _flag_dbs) <-
+ getPkgDatabases verbosity True{-modify-} False{-no cache-} False{-expand vars-} my_flags
+ let
+ db_to_operate_on = my_head "recache" $
+ filter ((== to_modify).location) db_stack
+ --
+ changeDB verbosity [] db_to_operate_on
-- -----------------------------------------------------------------------------
-- Listing packages
-listPackages :: [Flag] -> Maybe PackageArg -> Maybe (String->Bool) -> IO ()
-listPackages my_flags mPackageName mModuleName = do
+listPackages :: Verbosity -> [Flag] -> Maybe PackageArg
+ -> Maybe (String->Bool)
+ -> IO ()
+listPackages verbosity my_flags mPackageName mModuleName = do
let simple_output = FlagSimpleOutput `elem` my_flags
- db_stack <- getPkgDatabases False my_flags
+ (db_stack, _, flag_db_stack) <-
+ getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
+
let db_stack_filtered -- if a package is given, filter out all other packages
| Just this <- mPackageName =
- map (\(conf,pkgs) -> (conf, filter (this `matchesPkg`) pkgs))
- db_stack
+ [ db{ packages = filter (this `matchesPkg`) (packages db) }
+ | db <- flag_db_stack ]
| Just match <- mModuleName = -- packages which expose mModuleName
- map (\(conf,pkgs) -> (conf, filter (match `exposedInPkg`) pkgs))
- db_stack
- | otherwise = db_stack
+ [ db{ packages = filter (match `exposedInPkg`) (packages db) }
+ | db <- flag_db_stack ]
+ | otherwise = flag_db_stack
db_stack_sorted
- = [ (db, sort_pkgs pkgs) | (db,pkgs) <- db_stack_filtered ]
+ = [ db{ packages = sort_pkgs (packages db) }
+ | db <- db_stack_filtered ]
where sort_pkgs = sortBy cmpPkgIds
cmpPkgIds pkg1 pkg2 =
case pkgName p1 `compare` pkgName p2 of
LT -> LT
GT -> GT
EQ -> pkgVersion p1 `compare` pkgVersion p2
- where (p1,p2) = (package pkg1, package pkg2)
+ where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
+
+ stack = reverse db_stack_sorted
match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
pkg_map = allPackagesInStack db_stack
- show_func = if simple_output then show_simple else mapM_ (show_normal pkg_map)
+ broken = map sourcePackageId (brokenPackages pkg_map)
- show_func (reverse db_stack_sorted)
-
- where show_normal pkg_map (db_name,pkg_confs) =
- hPutStrLn stdout (render $
- text db_name <> colon $$ nest 4 packages
- )
- where packages = fsep (punctuate comma (map pp_pkg pkg_confs))
- broken = map package (brokenPackages pkg_map)
+ show_normal PackageDB{ location = db_name, packages = pkg_confs } =
+ hPutStrLn stdout $ unlines ((db_name ++ ":") : map (" " ++) pp_pkgs)
+ where
+ pp_pkgs = map pp_pkg pkg_confs
pp_pkg p
- | package p `elem` broken = braces doc
+ | sourcePackageId p `elem` broken = printf "{%s}" doc
| exposed p = doc
- | otherwise = parens doc
- where doc = text (display (package p))
+ | otherwise = printf "(%s)" doc
+ where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid
+ | otherwise = pkg
+ where
+ InstalledPackageId ipid = installedPackageId p
+ pkg = display (sourcePackageId p)
+
+ show_simple = simplePackageList my_flags . allPackagesInStack
- show_simple db_stack = do
- let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
- else display
- pkgs = map showPkg $ sortBy compPkgIdVer $
- map package (allPackagesInStack db_stack)
- when (not (null pkgs)) $
- hPutStrLn stdout $ concat $ intersperse " " pkgs
+ when (not (null broken) && not simple_output && verbosity /= Silent) $ do
+ prog <- getProgramName
+ warn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.")
+
+ if simple_output then show_simple stack else do
+
+#if defined(mingw32_HOST_OS) || defined(BOOTSTRAPPING)
+ mapM_ show_normal stack
+#else
+ let
+ show_colour withF db =
+ mconcat $ map (<#> termText "\n") $
+ (termText (location db) :
+ map (termText " " <#>) (map pp_pkg (packages db)))
+ where
+ pp_pkg p
+ | sourcePackageId p `elem` broken = withF Red doc
+ | exposed p = doc
+ | otherwise = withF Blue doc
+ where doc | verbosity >= Verbose
+ = termText (printf "%s (%s)" pkg ipid)
+ | otherwise
+ = termText pkg
+ where
+ InstalledPackageId ipid = installedPackageId p
+ pkg = display (sourcePackageId p)
+
+ is_tty <- hIsTerminalDevice stdout
+ if not is_tty
+ then mapM_ show_normal stack
+ else do tty <- Terminfo.setupTermFromEnv
+ case Terminfo.getCapability tty withForegroundColor of
+ Nothing -> mapM_ show_normal stack
+ Just w -> runTermOutput tty $ mconcat $
+ map (show_colour w) stack
+#endif
+
+simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
+simplePackageList my_flags pkgs = do
+ let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
+ else display
+ strs = map showPkg $ sortBy compPkgIdVer $ map sourcePackageId pkgs
+ when (not (null pkgs)) $
+ hPutStrLn stdout $ concat $ intersperse " " strs
+
+showPackageDot :: Verbosity -> [Flag] -> IO ()
+showPackageDot verbosity myflags = do
+ (_, _, flag_db_stack) <-
+ getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} myflags
+
+ let all_pkgs = allPackagesInStack flag_db_stack
+ ipix = PackageIndex.fromList all_pkgs
+
+ putStrLn "digraph {"
+ let quote s = '"':s ++ "\""
+ mapM_ putStrLn [ quote from ++ " -> " ++ quote to
+ | p <- all_pkgs,
+ let from = display (sourcePackageId p),
+ depid <- depends p,
+ Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid],
+ let to = display (sourcePackageId dep)
+ ]
+ putStrLn "}"
-- -----------------------------------------------------------------------------
-- Prints the highest (hidden or exposed) version of a package
-latestPackage :: [Flag] -> PackageIdentifier -> IO ()
-latestPackage my_flags pkgid = do
- db_stack <- getPkgDatabases False my_flags
- ps <- findPackages db_stack (Id pkgid)
- show_pkg (sortBy compPkgIdVer (map package ps))
+latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO ()
+latestPackage verbosity my_flags pkgid = do
+ (_, _, flag_db_stack) <-
+ getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
+
+ ps <- findPackages flag_db_stack (Id pkgid)
+ show_pkg (sortBy compPkgIdVer (map sourcePackageId ps))
where
show_pkg [] = die "no matches"
show_pkg pids = hPutStrLn stdout (display (last pids))
-- -----------------------------------------------------------------------------
-- Describe
-describePackage :: [Flag] -> PackageArg -> IO ()
-describePackage my_flags pkgarg = do
- db_stack <- getPkgDatabases False my_flags
- ps <- findPackages db_stack pkgarg
- doDump ps
-
-dumpPackages :: [Flag] -> IO ()
-dumpPackages my_flags = do
- db_stack <- getPkgDatabases False my_flags
- doDump (allPackagesInStack db_stack)
-
-doDump :: [InstalledPackageInfo] -> IO ()
-doDump = mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo
+describePackage :: Verbosity -> [Flag] -> PackageArg -> Bool -> IO ()
+describePackage verbosity my_flags pkgarg expand_pkgroot = do
+ (_, _, flag_db_stack) <-
+ getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
+ dbs <- findPackagesByDB flag_db_stack pkgarg
+ doDump expand_pkgroot [ (pkg, locationAbsolute db)
+ | (db, pkgs) <- dbs, pkg <- pkgs ]
+
+dumpPackages :: Verbosity -> [Flag] -> Bool -> IO ()
+dumpPackages verbosity my_flags expand_pkgroot = do
+ (_, _, flag_db_stack) <-
+ getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
+ doDump expand_pkgroot [ (pkg, locationAbsolute db)
+ | db <- flag_db_stack, pkg <- packages db ]
+
+doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO ()
+doDump expand_pkgroot pkgs = do
+ -- fix the encoding to UTF-8, since this is an interchange format
+ hSetEncoding stdout utf8
+ putStrLn $
+ intercalate "---\n"
+ [ if expand_pkgroot
+ then showInstalledPackageInfo pkg
+ else showInstalledPackageInfo pkg ++ pkgrootField
+ | (pkg, pkgloc) <- pkgs
+ , let pkgroot = takeDirectory pkgloc
+ pkgrootField = "pkgroot: " ++ pkgroot ++ "\n" ]
-- PackageId is can have globVersion for the version
findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
findPackages db_stack pkgarg
- = case [ p | p <- all_pkgs, pkgarg `matchesPkg` p ] of
- [] -> dieWith 2 ("cannot find package " ++ pkg_msg pkgarg)
+ = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
+
+findPackagesByDB :: PackageDBStack -> PackageArg
+ -> IO [(PackageDB, [InstalledPackageInfo])]
+findPackagesByDB db_stack pkgarg
+ = case [ (db, matched)
+ | db <- db_stack,
+ let matched = filter (pkgarg `matchesPkg`) (packages db),
+ not (null matched) ] of
+ [] -> die ("cannot find package " ++ pkg_msg pkgarg)
ps -> return ps
where
- all_pkgs = allPackagesInStack db_stack
pkg_msg (Id pkgid) = display pkgid
- pkg_msg (Substring pkgpat _) = "matching "++pkgpat
+ pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
matches :: PackageIdentifier -> PackageIdentifier -> Bool
pid `matches` pid'
= (pkgName pid == pkgName pid')
&& (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
+realVersion :: PackageIdentifier -> Bool
+realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
+ -- when versionBranch == [], this is a glob
+
matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
-(Id pid) `matchesPkg` pkg = pid `matches` package pkg
-(Substring _ m) `matchesPkg` pkg = m (display (package pkg))
+(Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg
+(Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
-- -----------------------------------------------------------------------------
-- Field
-describeField :: [Flag] -> PackageArg -> [String] -> IO ()
-describeField my_flags pkgarg fields = do
- db_stack <- getPkgDatabases False my_flags
+describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> Bool -> IO ()
+describeField verbosity my_flags pkgarg fields expand_pkgroot = do
+ (_, _, flag_db_stack) <-
+ getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
fns <- toFields fields
- ps <- findPackages db_stack pkgarg
- let top_dir = takeDirectory (fst (last db_stack))
- mapM_ (selectFields fns) (mungePackagePaths top_dir ps)
+ ps <- findPackages flag_db_stack pkgarg
+ mapM_ (selectFields fns) ps
where toFields [] = return []
toFields (f:fs) = case toField f of
Nothing -> die ("unknown field: " ++ f)
return (fn:fns)
selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
-mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
--- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
--- with the current topdir (obtained from the -B option).
-mungePackagePaths top_dir ps = map munge_pkg ps
- where
- munge_pkg p = p{ importDirs = munge_paths (importDirs p),
- includeDirs = munge_paths (includeDirs p),
- libraryDirs = munge_paths (libraryDirs p),
- frameworkDirs = munge_paths (frameworkDirs p),
- haddockInterfaces = munge_paths (haddockInterfaces p),
- haddockHTMLs = munge_paths (haddockHTMLs p)
- }
-
- munge_paths = map munge_path
-
- munge_path p
- | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
- | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
- | otherwise = p
-
- toHttpPath p = "file:///" ++ p
-
-maybePrefixMatch :: String -> String -> Maybe String
-maybePrefixMatch [] rest = Just rest
-maybePrefixMatch (_:_) [] = Nothing
-maybePrefixMatch (p:pat) (r:rest)
- | p == r = maybePrefixMatch pat rest
- | otherwise = Nothing
-
toField :: String -> Maybe (InstalledPackageInfo -> String)
-- backwards compatibility:
toField "import_dirs" = Just $ strList . importDirs
-- -----------------------------------------------------------------------------
-- Check: Check consistency of installed packages
-checkConsistency :: [Flag] -> IO ()
-checkConsistency my_flags = do
- db_stack <- getPkgDatabases True my_flags
+checkConsistency :: Verbosity -> [Flag] -> IO ()
+checkConsistency verbosity my_flags = do
+ (db_stack, _, _) <-
+ getPkgDatabases verbosity True True{-use cache-} True{-expand vars-} my_flags
-- check behaves like modify for the purposes of deciding which
-- databases to use, because ordering is important.
- let pkgs = allPackagesInStack db_stack
- broken_pkgs = brokenPackages pkgs
- broken_ids = map package broken_pkgs
- broken_why = [ (package p, filter (`elem` broken_ids) (depends p))
- | p <- broken_pkgs ]
- mapM_ (putStrLn . render . show_func) broken_why
- where
- show_func | FlagSimpleOutput `elem` my_flags = show_simple
- | otherwise = show_normal
- show_simple (pid,deps) =
- text (display pid) <> colon
- <+> fsep (punctuate comma (map (text . display) deps))
- show_normal (pid,deps) =
- text "package" <+> text (display pid) <+> text "has missing dependencies:"
- $$ nest 4 (fsep (punctuate comma (map (text . display) deps)))
+ let simple_output = FlagSimpleOutput `elem` my_flags
+
+ let pkgs = allPackagesInStack db_stack
-brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
-brokenPackages pkgs = go [] pkgs
+ checkPackage p = do
+ (_,es,ws) <- runValidate $ checkPackageConfig p db_stack False True
+ if null es
+ then do when (not simple_output) $ do
+ _ <- reportValidateErrors [] ws "" Nothing
+ return ()
+ return []
+ else do
+ when (not simple_output) $ do
+ reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
+ _ <- reportValidateErrors es ws " " Nothing
+ return ()
+ return [p]
+
+ broken_pkgs <- concat `fmap` mapM checkPackage pkgs
+
+ let filterOut pkgs1 pkgs2 = filter not_in pkgs2
+ where not_in p = sourcePackageId p `notElem` all_ps
+ all_ps = map sourcePackageId pkgs1
+
+ let not_broken_pkgs = filterOut broken_pkgs pkgs
+ (_, trans_broken_pkgs) = closure [] not_broken_pkgs
+ all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
+
+ when (not (null all_broken_pkgs)) $ do
+ if simple_output
+ then simplePackageList my_flags all_broken_pkgs
+ else do
+ reportError ("\nThe following packages are broken, either because they have a problem\n"++
+ "listed above, or because they depend on a broken package.")
+ mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
+
+ when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
+
+
+closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
+ -> ([InstalledPackageInfo], [InstalledPackageInfo])
+closure pkgs db_stack = go pkgs db_stack
where
go avail not_avail =
case partition (depsAvailable avail) not_avail of
- ([], not_avail) -> not_avail
- (new_avail, not_avail) -> go (new_avail ++ avail) not_avail
+ ([], not_avail') -> (avail, not_avail')
+ (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
-> Bool
depsAvailable pkgs_ok pkg = null dangling
where dangling = filter (`notElem` pids) (depends pkg)
- pids = map package pkgs_ok
+ pids = map installedPackageId pkgs_ok
-- we want mutually recursive groups of package to show up
-- as broken. (#1750)
+brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
+brokenPackages pkgs = snd (closure [] pkgs)
+
-- -----------------------------------------------------------------------------
-- Manipulating package.conf files
hiddenModules = map convert h }
where convert = fromJust . simpleParse
-writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO ()
-writeNewConfig filename packages = do
- hPutStr stdout "Writing new package config file... "
+writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()
+writeNewConfig verbosity filename ipis = do
+ when (verbosity >= Normal) $
+ hPutStr stdout "Writing new package config file... "
createDirectoryIfMissing True $ takeDirectory filename
let shown = concat $ intersperse ",\n "
- $ map (show . convertPackageInfoOut) packages
+ $ map (show . convertPackageInfoOut) ipis
fileContents = "[" ++ shown ++ "\n]"
- writeFileAtomic filename fileContents
- `catch` \e ->
+ writeFileUtf8Atomic filename fileContents
+ `catchIO` \e ->
if isPermissionError e
then die (filename ++ ": you don't have permission to modify this file")
else ioError e
- hPutStrLn stdout "done."
+ when (verbosity >= Normal) $
+ hPutStrLn stdout "done."
-----------------------------------------------------------------------------
-- Sanity-check a new package config, and automatically build GHCi libs
-- if requested.
+type ValidateError = (Force,String)
+type ValidateWarning = String
+
+newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) }
+
+instance Monad Validate where
+ return a = V $ return (a, [], [])
+ m >>= k = V $ do
+ (a, es, ws) <- runValidate m
+ (b, es', ws') <- runValidate (k a)
+ return (b,es++es',ws++ws')
+
+verror :: Force -> String -> Validate ()
+verror f s = V (return ((),[(f,s)],[]))
+
+vwarn :: String -> Validate ()
+vwarn s = V (return ((),[],["Warning: " ++ s]))
+
+liftIO :: IO a -> Validate a
+liftIO k = V (k >>= \a -> return (a,[],[]))
+
+-- returns False if we should die
+reportValidateErrors :: [ValidateError] -> [ValidateWarning]
+ -> String -> Maybe Force -> IO Bool
+reportValidateErrors es ws prefix mb_force = do
+ mapM_ (warn . (prefix++)) ws
+ oks <- mapM report es
+ return (and oks)
+ where
+ report (f,s)
+ | Just force <- mb_force
+ = if (force >= f)
+ then do reportError (prefix ++ s ++ " (ignoring)")
+ return True
+ else if f < CannotForce
+ then do reportError (prefix ++ s ++ " (use --force to override)")
+ return False
+ else do reportError err
+ return False
+ | otherwise = do reportError err
+ return False
+ where
+ err = prefix ++ s
+
validatePackageConfig :: InstalledPackageInfo
-> PackageDBStack
-> Bool -- auto-ghc-libs
- -> Bool -- update
+ -> Bool -- update, or check
-> Force
-> IO ()
validatePackageConfig pkg db_stack auto_ghci_libs update force = do
+ (_,es,ws) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update
+ ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force)
+ when (not ok) $ exitWith (ExitFailure 1)
+
+checkPackageConfig :: InstalledPackageInfo
+ -> PackageDBStack
+ -> Bool -- auto-ghc-libs
+ -> Bool -- update, or check
+ -> Validate ()
+checkPackageConfig pkg db_stack auto_ghci_libs update = do
+ checkInstalledPackageId pkg db_stack update
checkPackageId pkg
- checkDuplicates db_stack pkg update force
- mapM_ (checkDep db_stack force) (depends pkg)
- mapM_ (checkDir force) (importDirs pkg)
- mapM_ (checkDir force) (libraryDirs pkg)
- mapM_ (checkDir force) (includeDirs pkg)
- mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs force) (hsLibraries pkg)
+ checkDuplicates db_stack pkg update
+ mapM_ (checkDep db_stack) (depends pkg)
+ checkDuplicateDepends (depends pkg)
+ mapM_ (checkDir False "import-dirs") (importDirs pkg)
+ mapM_ (checkDir True "library-dirs") (libraryDirs pkg)
+ mapM_ (checkDir True "include-dirs") (includeDirs pkg)
+ mapM_ (checkDir True "framework-dirs") (frameworkDirs pkg)
+ mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg)
+ mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg)
+ checkModules pkg
+ mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
-- ToDo: check these somehow?
-- extra_libraries :: [String],
-- c_includes :: [String],
+checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool
+ -> Validate ()
+checkInstalledPackageId ipi db_stack update = do
+ let ipid@(InstalledPackageId str) = installedPackageId ipi
+ when (null str) $ verror CannotForce "missing id field"
+ let dups = [ p | p <- allPackagesInStack db_stack,
+ installedPackageId p == ipid ]
+ when (not update && not (null dups)) $
+ verror CannotForce $
+ "package(s) with this id already exist: " ++
+ unwords (map (display.packageId) dups)
+
-- When the package name and version are put together, sometimes we can
-- end up with a package id that cannot be parsed. This will lead to
-- difficulties when the user wants to refer to the package later, so
-- we check that the package id can be parsed properly here.
-checkPackageId :: InstalledPackageInfo -> IO ()
+checkPackageId :: InstalledPackageInfo -> Validate ()
checkPackageId ipi =
- let str = display (package ipi) in
+ let str = display (sourcePackageId ipi) in
case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
[_] -> return ()
- [] -> die ("invalid package identifier: " ++ str)
- _ -> die ("ambiguous package identifier: " ++ str)
+ [] -> verror CannotForce ("invalid package identifier: " ++ str)
+ _ -> verror CannotForce ("ambiguous package identifier: " ++ str)
-checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Force -> IO ()
-checkDuplicates db_stack pkg update force = do
+checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
+checkDuplicates db_stack pkg update = do
let
- pkgid = package pkg
- (_top_db_name, pkgs) : _ = db_stack
+ pkgid = sourcePackageId pkg
+ pkgs = packages (head db_stack)
--
-- Check whether this package id already exists in this DB
--
- when (not update && (pkgid `elem` map package pkgs)) $
- die ("package " ++ display pkgid ++ " is already installed")
+ when (not update && (pkgid `elem` map sourcePackageId pkgs)) $
+ verror CannotForce $
+ "package " ++ display pkgid ++ " is already installed"
let
uncasep = map toLower . display
- dups = filter ((== uncasep pkgid) . uncasep) (map package pkgs)
+ dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
- when (not update && not (null dups)) $ dieOrForceAll force $
+ when (not update && not (null dups)) $ verror ForceAll $
"Package names may be treated case-insensitively in the future.\n"++
"Package " ++ display pkgid ++
" overlaps with: " ++ unwords (map display dups)
-
-checkDir :: Force -> String -> IO ()
-checkDir force d
- | "$topdir" `isPrefixOf` d = return ()
- | "$httptopdir" `isPrefixOf` d = return ()
- -- can't check these, because we don't know what $(http)topdir is
+checkDir, checkFile, checkDirURL :: Bool -> String -> FilePath -> Validate ()
+checkDir = checkPath False True
+checkFile = checkPath False False
+checkDirURL = checkPath True True
+
+checkPath :: Bool -> Bool -> Bool -> String -> FilePath -> Validate ()
+checkPath url_ok is_dir warn_only thisfield d
+ | url_ok && ("http://" `isPrefixOf` d
+ || "https://" `isPrefixOf` d) = return ()
+
+ | url_ok
+ , Just d' <- stripPrefix "file://" d
+ = checkPath False is_dir warn_only thisfield d'
+
+ -- Note: we don't check for $topdir/${pkgroot} here. We rely on these
+ -- variables having been expanded already, see mungePackagePaths.
+
+ | isRelative d = verror ForceFiles $
+ thisfield ++ ": " ++ d ++ " is a relative path which "
+ ++ "makes no sense (as there is nothing for it to be "
+ ++ "relative to). You can make paths relative to the "
+ ++ "package database itself by using ${pkgroot}."
+ -- relative paths don't make any sense; #4134
| otherwise = do
- there <- doesDirectoryExist d
- when (not there)
- (dieOrForceFile force (d ++ " doesn't exist or isn't a directory"))
-
-checkDep :: PackageDBStack -> Force -> PackageIdentifier -> IO ()
-checkDep db_stack force pkgid
- | pkgid `elem` pkgids || (not real_version && name_exists) = return ()
- | otherwise = dieOrForceAll force ("dependency " ++ display pkgid
- ++ " doesn't exist")
+ there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d
+ when (not there) $
+ let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a "
+ ++ if is_dir then "directory" else "file"
+ in
+ if warn_only
+ then vwarn msg
+ else verror ForceFiles msg
+
+checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
+checkDep db_stack pkgid
+ | pkgid `elem` pkgids = return ()
+ | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
+ ++ "\" doesn't exist")
where
- -- for backwards compat, we treat 0.0 as a special version,
- -- and don't check that it actually exists.
- real_version = realVersion pkgid
-
- name_exists = any (\p -> pkgName (package p) == name) all_pkgs
- name = pkgName pkgid
-
all_pkgs = allPackagesInStack db_stack
- pkgids = map package all_pkgs
+ pkgids = map installedPackageId all_pkgs
-realVersion :: PackageIdentifier -> Bool
-realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
+checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
+checkDuplicateDepends deps
+ | null dups = return ()
+ | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
+ unwords (map display dups))
+ where
+ dups = [ p | (p:_:_) <- group (sort deps) ]
-checkHSLib :: [String] -> Bool -> Force -> String -> IO ()
-checkHSLib dirs auto_ghci_libs force lib = do
+checkHSLib :: [String] -> Bool -> String -> Validate ()
+checkHSLib dirs auto_ghci_libs lib = do
let batch_lib_file = "lib" ++ lib ++ ".a"
- bs <- mapM (doesLibExistIn batch_lib_file) dirs
- case [ dir | (exists,dir) <- zip bs dirs, exists ] of
- [] -> dieOrForceFile force ("cannot find " ++ batch_lib_file ++
- " on library path")
- (dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
-
-doesLibExistIn :: String -> String -> IO Bool
-doesLibExistIn lib d
- | "$topdir" `isPrefixOf` d = return True
- | "$httptopdir" `isPrefixOf` d = return True
- | otherwise = doesFileExist (d ++ '/':lib)
-
-checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
-checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build
- | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
- | otherwise = do
- bs <- mapM (doesLibExistIn ghci_lib_file) dirs
- case [dir | (exists,dir) <- zip bs dirs, exists] of
- [] -> hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file)
- (_:_) -> return ()
+ m <- liftIO $ doesFileExistOnPath batch_lib_file dirs
+ case m of
+ Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++
+ " on library path")
+ Just dir -> liftIO $ checkGHCiLib dir batch_lib_file lib auto_ghci_libs
+
+doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath)
+doesFileExistOnPath file path = go path
+ where go [] = return Nothing
+ go (p:ps) = do b <- doesFileExistIn file p
+ if b then return (Just p) else go ps
+
+doesFileExistIn :: String -> String -> IO Bool
+doesFileExistIn lib d = doesFileExist (d </> lib)
+
+checkModules :: InstalledPackageInfo -> Validate ()
+checkModules pkg = do
+ mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
where
- ghci_lib_file = lib ++ ".o"
+ findModule modl = do
+ -- there's no .hi file for GHC.Prim
+ if modl == fromString "GHC.Prim" then return () else do
+ let file = toFilePath modl <.> "hi"
+ m <- liftIO $ doesFileExistOnPath file (importDirs pkg)
+ when (isNothing m) $
+ verror ForceFiles ("file " ++ file ++ " is missing")
+
+checkGHCiLib :: String -> String -> String -> Bool -> IO ()
+checkGHCiLib batch_lib_dir batch_lib_file lib auto_build
+ | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
+ | otherwise = return ()
+ where
+ ghci_lib_file = lib <.> "o"
-- automatically build the GHCi version of a batch lib,
-- using ld --whole-archive.
#if defined(darwin_HOST_OS)
r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
#elif defined(mingw32_HOST_OS)
- execDir <- getExecDir "/bin/ghc-pkg.exe"
+ execDir <- getLibDir
r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
#else
r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
return (concat mms)
searchDir path prefix = do
- fs <- getDirectoryEntries path `catch` \_ -> return []
+ fs <- getDirectoryEntries path `catchIO` \_ -> return []
searchEntries path prefix fs
searchEntries path prefix [] = return []
= go str (c:acc)
lookupEnvVar :: String -> IO String
+ lookupEnvVar "pkgroot" = return "${pkgroot}" -- these two are special,
+ lookupEnvVar "pkgrooturl" = return "${pkgrooturl}" -- we don't expand them
lookupEnvVar nm =
- catch (System.Environment.getEnv nm)
+ catchIO (System.Environment.getEnv nm)
(\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
show nm)
return "")
dieOrForceAll ForceAll s = ignoreError s
dieOrForceAll _other s = dieForcible s
-dieOrForceFile :: Force -> String -> IO ()
-dieOrForceFile ForceAll s = ignoreError s
-dieOrForceFile ForceFiles s = ignoreError s
-dieOrForceFile _other s = dieForcible s
+warn :: String -> IO ()
+warn = reportError
ignoreError :: String -> IO ()
-ignoreError s = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)")
+ignoreError s = reportError (s ++ " (ignoring)")
+
+reportError :: String -> IO ()
+reportError s = do hFlush stdout; hPutStrLn stderr s
dieForcible :: String -> IO ()
dieForcible s = die (s ++ " (use --force to override)")
unDosifyPath :: FilePath -> FilePath
unDosifyPath xs = subst '\\' '/' xs
-getExecDir :: String -> IO (Maybe String)
+getLibDir :: IO (Maybe String)
+getLibDir = fmap (fmap (</> "lib")) $ getExecDir "/bin/ghc-pkg.exe"
+
-- (getExecDir cmd) returns the directory in which the current
-- executable, which should be called 'cmd', is running
-- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
-- you'll get "/a/b/c" back as the result
-getExecDir cmd
- = allocaArray len $ \buf -> do
- ret <- getModuleFileName nullPtr buf len
- if ret == 0 then return Nothing
- else do s <- peekCString buf
- return (Just (reverse (drop (length cmd)
- (reverse (unDosifyPath s)))))
- where
- len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32.
+getExecDir :: String -> IO (Maybe String)
+getExecDir cmd =
+ getExecPath >>= maybe (return Nothing) removeCmdSuffix
+ where initN n = reverse . drop n . reverse
+ removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
-foreign import stdcall unsafe "GetModuleFileNameA"
- getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
+getExecPath :: IO (Maybe String)
+getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
+ where
+ try_size size = allocaArray (fromIntegral size) $ \buf -> do
+ ret <- c_GetModuleFileName nullPtr buf size
+ case ret of
+ 0 -> return Nothing
+ _ | ret < size -> fmap Just $ peekCWString buf
+ | otherwise -> try_size (size * 2)
+
+foreign import stdcall unsafe "windows.h GetModuleFileNameW"
+ c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
#else
-getExecDir :: String -> IO (Maybe String)
-getExecDir _ = return Nothing
+getLibDir :: IO (Maybe String)
+getLibDir = return Nothing
#endif
-----------------------------------------
installSignalHandlers = do
threadid <- myThreadId
let
- interrupt = throwTo threadid (Exception.ErrorCall "interrupted")
+ interrupt = Exception.throwTo threadid
+ (Exception.ErrorCall "interrupted")
--
#if !defined(mingw32_HOST_OS)
- installHandler sigQUIT (Catch interrupt) Nothing
- installHandler sigINT (Catch interrupt) Nothing
+ _ <- installHandler sigQUIT (Catch interrupt) Nothing
+ _ <- installHandler sigINT (Catch interrupt) Nothing
return ()
-#elif __GLASGOW_HASKELL__ >= 603
+#else
-- GHC 6.3+ has support for console events on Windows
-- NOTE: running GHCi under a bash shell for some reason requires
-- you to press Ctrl-Break rather than Ctrl-C to provoke
sig_handler Break = interrupt
sig_handler _ = return ()
- installHandler (Catch sig_handler)
+ _ <- installHandler (Catch sig_handler)
return ()
-#else
- return () -- nothing
#endif
-#if __GLASGOW_HASKELL__ <= 604
-isInfixOf :: (Eq a) => [a] -> [a] -> Bool
-isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)
+#if mingw32_HOST_OS || mingw32_TARGET_OS
+throwIOIO :: Exception.IOException -> IO a
+throwIOIO = Exception.throwIO
#endif
catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
-#if __GLASGOW_HASKELL__ >= 609
catchIO = Exception.catch
-#else
-catchIO io handler = io `Exception.catch` handler'
- where handler' (Exception.IOException ioe) = handler ioe
- handler' e = Exception.throw e
-#endif
-
-throwIOIO :: Exception.IOException -> IO a
-#if __GLASGOW_HASKELL__ >= 609
-throwIOIO = Exception.throwIO
-#else
-throwIOIO ioe = Exception.throwIO (Exception.IOException ioe)
-#endif
catchError :: IO a -> (String -> IO a) -> IO a
-#if __GLASGOW_HASKELL__ >= 609
-catchError io handler = io `Exception.catch` handler'
- where handler' (Exception.ErrorCall err) = handler err
-#else
catchError io handler = io `Exception.catch` handler'
where handler' (Exception.ErrorCall err) = handler err
- handler' e = Exception.throw e
-#endif
-onException :: IO a -> IO () -> IO a
-#if __GLASGOW_HASKELL__ >= 609
-onException = Exception.onException
-#else
-onException io what = io `Exception.catch` \e -> do what
- Exception.throw e
-#endif
+tryIO :: IO a -> IO (Either Exception.IOException a)
+tryIO = Exception.try
+
+writeBinaryFileAtomic :: Bin.Binary a => FilePath -> a -> IO ()
+writeBinaryFileAtomic targetFile obj =
+ withFileAtomic targetFile $ \h -> do
+ hSetBinaryMode h True
+ B.hPutStr h (Bin.encode obj)
+writeFileUtf8Atomic :: FilePath -> String -> IO ()
+writeFileUtf8Atomic targetFile content =
+ withFileAtomic targetFile $ \h -> do
+ hSetEncoding h utf8
+ 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
- (tmpFile, tmpHandle) <- openTempFile targetDir template
- do hPutStr tmpHandle content
- hClose tmpHandle
+withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO ()
+withFileAtomic targetFile write_content = do
+ (newFile, newHandle) <- openNewFile targetDir template
+ do write_content newHandle
+ hClose newHandle
#if mingw32_HOST_OS || mingw32_TARGET_OS
- renameFile tmpFile targetFile
+ renameFile newFile targetFile
-- If the targetFile exists then renameFile will fail
`catchIO` \err -> do
exists <- doesFileExist targetFile
if exists
- then do removeFile targetFile
+ then do removeFileSafe targetFile
-- Big fat hairy race condition
- renameFile tmpFile targetFile
+ renameFile newFile targetFile
-- If the removeFile succeeds and the renameFile fails
-- then we've lost the atomic property.
else throwIOIO err
#else
- renameFile tmpFile targetFile
+ renameFile newFile targetFile
#endif
- `onException` do hClose tmpHandle
- removeFile tmpFile
+ `Exception.onException` do hClose newHandle
+ removeFileSafe newFile
where
template = targetName <.> "tmp"
targetDir | null targetDir_ = "."
--TODO: remove this when takeDirectory/splitFileName is fixed
-- to always return a valid dir
(targetDir_,targetName) = splitFileName targetFile
+
+openNewFile :: FilePath -> String -> IO (FilePath, Handle)
+openNewFile dir template = do
+ -- this was added to System.IO in 6.12.1
+ -- we must use this version because the version below opens the file
+ -- in binary mode.
+ openTempFileWithDefaultPermissions dir template
+
+-- | The function splits the given string to substrings
+-- using 'isSearchPathSeparator'.
+parseSearchPath :: String -> [FilePath]
+parseSearchPath path = split path
+ where
+ split :: String -> [String]
+ split s =
+ case rest' of
+ [] -> [chunk]
+ _:rest -> chunk : split rest
+ where
+ chunk =
+ case chunk' of
+#ifdef mingw32_HOST_OS
+ ('\"':xs@(_:_)) | last xs == '\"' -> init xs
+#endif
+ _ -> chunk'
+
+ (chunk', rest') = break isSearchPathSeparator s
+
+readUTF8File :: FilePath -> IO String
+readUTF8File file = do
+ h <- openFile file ReadMode
+ -- fix the encoding to UTF-8
+ hSetEncoding h utf8
+ hGetContents h
+
+-- removeFileSave doesn't throw an exceptions, if the file is already deleted
+removeFileSafe :: FilePath -> IO ()
+removeFileSafe fn =
+ removeFile fn `catchIO` \ e ->
+ when (not $ isDoesNotExistError e) $ ioError e
+
+absolutePath :: FilePath -> IO FilePath
+absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory
projects / ghc-hetmet.git / blobdiff