-{-# OPTIONS -fglasgow-exts #-}
+{-# OPTIONS -fglasgow-exts -cpp #-}
-----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 2004.
-----------------------------------------------------------------------------
-- TODO:
--- - validate modules
--- - expanding of variables in new-style package conf
--- - version manipulation (checking whether old version exists,
--- hiding old version?)
+-- * 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
+import Version ( version, targetOS, targetARCH )
+import Distribution.ModuleName hiding (main)
+import Distribution.InstalledPackageInfo hiding (depends)
import Distribution.Compat.ReadP
-import Distribution.ParseUtils ( showError )
+import Distribution.ParseUtils
import Distribution.Package
+import Distribution.Text
import Distribution.Version
-import Compat.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
-import Compat.RawSystem ( rawSystem )
+import System.FilePath
+import System.Cmd ( rawSystem )
+import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
import Prelude
#include "../../includes/ghcconfig.h"
-#if __GLASGOW_HASKELL__ >= 504
import System.Console.GetOpt
import Text.PrettyPrint
+#if __GLASGOW_HASKELL__ >= 609
import qualified Control.Exception as Exception
-import Data.Maybe
#else
-import GetOpt
-import Pretty
-import qualified Exception
-import Maybe
+import qualified Control.Exception.Extensible as Exception
#endif
+import Data.Maybe
-import Data.Char ( isSpace )
-import Monad
-import Directory
-import System ( getArgs, getProgName, getEnv,
- exitWith, ExitCode(..)
- )
+import Data.Char ( isSpace, toLower )
+import Control.Monad
+import System.Directory ( doesDirectoryExist, getDirectoryContents,
+ doesFileExist, renameFile, removeFile )
+import System.Exit ( exitWith, ExitCode(..) )
+import System.Environment ( getArgs, getProgName, getEnv )
import System.IO
-#if __GLASGOW_HASKELL__ >= 600
import System.IO.Error (try)
-#else
-import System.IO (try)
-#endif
-import Data.List ( isPrefixOf, isSuffixOf, intersperse, sortBy )
+import Data.List
+import Control.Concurrent
-#ifdef mingw32_HOST_OS
import Foreign
-
-#if __GLASGOW_HASKELL__ >= 504
-import Foreign.C.String
+import Foreign.C
+#ifdef mingw32_HOST_OS
+import GHC.ConsoleHandler
#else
-import CString
-#endif
+import System.Posix hiding (fdToHandle)
#endif
-import IO ( isPermissionError, isDoesNotExistError )
+import IO ( isPermissionError )
+import System.Posix.Internals
+import GHC.Handle (fdToHandle)
+
+#if defined(GLOB)
+import System.Process(runInteractiveCommand)
+import qualified System.Info(os)
+#endif
-- -----------------------------------------------------------------------------
-- Entry point
main = do
args <- getArgs
- case getOpt Permute flags args of
- (cli,_,[]) | FlagHelp `elem` cli -> do
- prog <- getProgramName
- bye (usageInfo (usageHeader prog) flags)
- (cli,_,[]) | FlagVersion `elem` cli ->
- bye ourCopyright
- (cli,nonopts,[]) ->
- runit cli nonopts
- (_,_,errors) -> tryOldCmdLine errors args
-
--- If the new command-line syntax fails, then we try the old. If that
--- fails too, then we output the original errors and the new syntax
--- (so the old syntax is still available, but hidden).
-tryOldCmdLine :: [String] -> [String] -> IO ()
-tryOldCmdLine errors args = do
- case getOpt Permute oldFlags args of
- (cli@(_:_),[],[]) ->
- oldRunit cli
- _failed -> do
- prog <- getProgramName
- die (concat errors ++ usageInfo (usageHeader prog) flags)
+ case getOpt Permute (flags ++ deprecFlags) args of
+ (cli,_,[]) | FlagHelp `elem` cli -> do
+ prog <- getProgramName
+ bye (usageInfo (usageHeader prog) flags)
+ (cli,_,[]) | FlagVersion `elem` cli ->
+ bye ourCopyright
+ (cli,nonopts,[]) ->
+ runit cli nonopts
+ (_,_,errors) -> do
+ prog <- getProgramName
+ die (concat errors ++ usageInfo (usageHeader prog) flags)
-- -----------------------------------------------------------------------------
-- Command-line syntax
| FlagGlobal
| FlagHelp
| FlagVersion
- | FlagConfig FilePath
+ | FlagConfig FilePath
| FlagGlobalConfig FilePath
| FlagForce
| FlagForceFiles
| FlagAutoGHCiLibs
- | FlagDefinedName String String
| FlagSimpleOutput
+ | FlagNamesOnly
+ | FlagIgnoreCase
+ | FlagNoUserDb
deriving Eq
flags :: [OptDescr Flag]
flags = [
Option [] ["user"] (NoArg FlagUser)
- "use the current user's package database",
+ "use the current user's package database",
Option [] ["global"] (NoArg FlagGlobal)
- "(default) use the global package database",
+ "use the global package database",
Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE")
- "act upon specified package config file (only)",
+ "use the specified package config file",
Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")
- "location of the global package config",
+ "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",
+ "ignore missing dependencies, directories, and libraries",
Option [] ["force-files"] (NoArg FlagForceFiles)
- "ignore missing directories and libraries only",
+ "ignore missing directories and libraries only",
Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
- "automatically build libs for GHCi (with register)",
+ "automatically build libs for GHCi (with register)",
Option ['?'] ["help"] (NoArg FlagHelp)
- "display this help and exit",
- Option ['D'] ["define-name"] (ReqArg toDefined "NAME=VALUE")
- "define NAME as VALUE",
+ "display this help and exit",
Option ['V'] ["version"] (NoArg FlagVersion)
- "output version information and exit",
+ "output version information and exit",
Option [] ["simple-output"] (NoArg FlagSimpleOutput)
- "print output in easy-to-parse format for some commands"
+ "print output in easy-to-parse format for some commands",
+ 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"
+ ]
+
+deprecFlags :: [OptDescr Flag]
+deprecFlags = [
+ -- put deprecated flags here
]
- where
- toDefined str =
- case break (=='=') str of
- (nm,[]) -> FlagDefinedName nm []
- (nm,_:val) -> FlagDefinedName nm val
ourCopyright :: String
-ourCopyright = "GHC package manager version " ++ version ++ "\n"
+ourCopyright = "GHC package manager version " ++ Version.version ++ "\n"
usageHeader :: String -> String
usageHeader prog = substProg prog $
" all the registered versions will be listed in ascending order.\n" ++
" Accepts the --simple-output flag.\n" ++
"\n" ++
- " $p latest pkg\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" ++
+ " All the registered versions will be listed in ascending order.\n" ++
+ " Accepts the --simple-output flag.\n" ++
+ "\n" ++
+ " $p latest {pkg-id}\n" ++
" Prints the highest registered version of a package.\n" ++
"\n" ++
" $p check\n" ++
" Check the consistency of package depenencies and list broken packages.\n" ++
" Accepts the --simple-output flag.\n" ++
"\n" ++
- " $p describe {pkg-id}\n" ++
+ " $p describe {pkg}\n" ++
" Give the registered description for the specified package. The\n" ++
" description is returned in precisely the syntax required by $p\n" ++
" register.\n" ++
"\n" ++
- " $p field {pkg-id} {field}\n" ++
+ " $p field {pkg} {field}\n" ++
" Extract the specified field of the package description for the\n" ++
- " specified package.\n" ++
+ " specified package. Accepts comma-separated multiple fields.\n" ++
+ "\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" ++
+ "\n" ++
+ " Substring matching is supported for {module} in find-module and\n" ++
+ " for {pkg} in list, describe, and field, where a '*' indicates\n" ++
+ " open substring ends (prefix*, *suffix, *infix*).\n" ++
+ "\n" ++
+ " When asked to modify a database (register, unregister, update,\n"++
+ " hide, expose, and also check), ghc-pkg modifies the global database by\n"++
+ " default. Specifying --user causes it to act on the user database,\n"++
+ " or --package-conf can be used to act on another database\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"++
+ " 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"++
"\n" ++
" The following optional flags are also accepted:\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
+ installSignalHandlers -- catch ^C and clean up
prog <- getProgramName
let
- force
- | FlagForce `elem` cli = ForceAll
+ force
+ | FlagForce `elem` cli = ForceAll
| FlagForceFiles `elem` cli = ForceFiles
| otherwise = NoForce
- auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
- defines = [ (nm,val) | FlagDefinedName nm val <- cli ]
+ auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
+ splitFields fields = unfoldr splitComma (',':fields)
+ where splitComma "" = Nothing
+ splitComma fs = Just $ break (==',') (tail fs)
+
+ substringCheck :: String -> Maybe (String -> Bool)
+ substringCheck "" = Nothing
+ substringCheck "*" = Just (const True)
+ substringCheck [_] = Nothing
+ substringCheck (h:t) =
+ case (h, init t, last t) of
+ ('*',s,'*') -> Just (isInfixOf (f s) . f)
+ ('*',_, _ ) -> Just (isSuffixOf (f t) . f)
+ ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f)
+ _ -> Nothing
+ where f | FlagIgnoreCase `elem` cli = map toLower
+ | otherwise = id
+#if defined(GLOB)
+ glob x | System.Info.os=="mingw32" = do
+ -- glob echoes its argument, after win32 filename globbing
+ (_,o,_,_) <- runInteractiveCommand ("glob "++x)
+ txt <- hGetContents o
+ return (read txt)
+ glob x | otherwise = return [x]
+#endif
--
-- first, parse the command
case nonopts of
- ["register", filename] ->
- registerPackage filename defines cli auto_ghci_libs False force
- ["update", filename] ->
- registerPackage filename defines cli auto_ghci_libs True force
+#if defined(GLOB)
+ -- dummy command to demonstrate usage and permit testing
+ -- without messing things up; use glob to selectively enable
+ -- windows filename globbing for file parameters
+ -- register, update, FlagGlobalConfig, FlagConfig; others?
+ ["glob", filename] -> do
+ print filename
+ glob filename >>= print
+#endif
+ ["register", filename] ->
+ registerPackage filename cli auto_ghci_libs False force
+ ["update", filename] ->
+ registerPackage filename cli auto_ghci_libs True force
["unregister", pkgid_str] -> do
- pkgid <- readGlobPkgId pkgid_str
- unregisterPackage pkgid cli
+ pkgid <- readGlobPkgId pkgid_str
+ unregisterPackage pkgid cli force
["expose", pkgid_str] -> do
- pkgid <- readGlobPkgId pkgid_str
- exposePackage pkgid cli
+ pkgid <- readGlobPkgId pkgid_str
+ exposePackage pkgid cli force
["hide", pkgid_str] -> do
- pkgid <- readGlobPkgId pkgid_str
- hidePackage pkgid cli
+ pkgid <- readGlobPkgId pkgid_str
+ hidePackage pkgid cli force
["list"] -> do
- listPackages cli Nothing
- ["list", pkgid_str] -> do
- pkgid <- readGlobPkgId pkgid_str
- listPackages cli (Just pkgid)
+ listPackages 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
+ ["find-module", moduleName] -> do
+ let match = maybe (==moduleName) id (substringCheck moduleName)
+ listPackages cli Nothing (Just match)
["latest", pkgid_str] -> do
- pkgid <- readGlobPkgId pkgid_str
- latestPackage cli pkgid
- ["describe", pkgid_str] -> do
- pkgid <- readGlobPkgId pkgid_str
- describePackage cli pkgid
- ["field", pkgid_str, field] -> do
- pkgid <- readGlobPkgId pkgid_str
- describeField cli pkgid field
+ 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)
["check"] -> do
- checkConsistency cli
+ checkConsistency cli
+
+ ["dump"] -> do
+ dumpPackages cli
+
[] -> do
- die ("missing command\n" ++
- usageInfo (usageHeader prog) flags)
+ die ("missing command\n" ++
+ usageInfo (usageHeader prog) flags)
(_cmd:_) -> do
- die ("command-line syntax error\n" ++
- usageInfo (usageHeader prog) flags)
+ die ("command-line syntax error\n" ++
+ usageInfo (usageHeader prog) flags)
parseCheck :: ReadP a a -> String -> String -> IO a
-parseCheck parser str what =
+parseCheck parser str what =
case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
[x] -> return x
_ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
-readPkgId :: String -> IO PackageIdentifier
-readPkgId str = parseCheck parsePackageId str "package identifier"
-
readGlobPkgId :: String -> IO PackageIdentifier
readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
parseGlobPackageId :: ReadP r PackageIdentifier
-parseGlobPackageId =
- parsePackageId
+parseGlobPackageId =
+ parse
+++
- (do n <- parsePackageName; string "-*"
+ (do n <- parse
+ string "-*"
return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
-- globVersion means "all versions"
-- Package databases
-- Some commands operate on a single database:
--- register, unregister, expose, hide
+-- register, unregister, expose, hide
-- however these commands also check the union of the available databases
-- in order to check consistency. For example, register will check that
-- dependencies exist before registering a package.
--
-- Some commands operate on multiple databases, with overlapping semantics:
--- list, describe, field
+-- list, describe, field
type PackageDBName = FilePath
type PackageDB = [InstalledPackageInfo]
-type PackageDBStack = [(PackageDBName,PackageDB)]
- -- A stack of package databases. Convention: head is the topmost
- -- in the stack. Earlier entries override later one.
+type NamedPackageDB = (PackageDBName, PackageDB)
+type PackageDBStack = [NamedPackageDB]
+ -- A stack of package databases. Convention: head is the topmost
+ -- in the stack. Earlier entries override later one.
-getPkgDatabases :: Bool -> [Flag] -> IO PackageDBStack
-getPkgDatabases modify flags = do
+allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
+allPackagesInStack = concatMap snd
+
+getPkgDatabases :: Bool -> [Flag] -> IO (PackageDBStack, Maybe PackageDBName)
+getPkgDatabases modify 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
-- wrapper script.
let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
- global_conf <-
- case [ f | FlagGlobalConfig f <- flags ] of
- [] -> do mb_dir <- getExecDir "/bin/ghc-pkg.exe"
- case mb_dir of
- Nothing -> die err_msg
- Just dir -> return (dir `joinFileName` "package.conf")
+ global_conf <-
+ case [ f | FlagGlobalConfig f <- my_flags ] of
+ [] -> do mb_dir <- getLibDir
+ case mb_dir of
+ Nothing -> die err_msg
+ Just dir ->
+ do let path = dir </> "package.conf"
+ exists <- doesFileExist path
+ unless exists $ die "Can't find package.conf"
+ return path
fs -> return (last fs)
let global_conf_dir = global_conf ++ ".d"
, isSuffixOf ".conf" file]
else return []
- -- get the location of the user package database, and create it if necessary
- appdir <- getAppUserDataDirectory "ghc"
+ let no_user_db = FlagNoUserDb `elem` my_flags
- let
- subdir = targetARCH ++ '-':targetOS ++ '-':version
- archdir = appdir `joinFileName` subdir
- user_conf = archdir `joinFileName` "package.conf"
- user_exists <- doesFileExist user_conf
+ -- 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"
+
+ mb_user_conf <-
+ if no_user_db then return Nothing else
+ 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 _ ->
+ return Nothing
-- 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
- | modify || user_exists = user_conf : global_confs ++ [global_conf]
- | otherwise = global_confs ++ [global_conf]
+ | Just (user_conf,user_exists) <- mb_user_conf,
+ modify || user_exists = user_conf : global_confs ++ [global_conf]
+ | otherwise = global_confs ++ [global_conf]
- e_pkg_path <- try (getEnv "GHC_PACKAGE_PATH")
+ e_pkg_path <- try (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 = parseSearchPath path
-
- -- The "global" database is always the one at the bottom of the stack.
- -- This is the database we modify by default.
+ case e_pkg_path of
+ Left _ -> sys_databases
+ Right path
+ | last cs == "" -> init cs ++ sys_databases
+ | otherwise -> cs
+ 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.
virt_global_conf = last env_stack
- -- -f flags on the command line add to the database stack, unless any
- -- of them are present in the stack already.
- let flag_stack = filter (`notElem` env_stack)
- [ f | FlagConfig f <- reverse flags ] ++ env_stack
-
- -- Now we have the full stack of databases. Next, if the current
- -- command is a "modify" type command, then we truncate the stack
- -- so that the topmost element is the database being modified.
- final_stack <-
- if not modify
- then return flag_stack
- else let
- go (FlagUser : fs) = modifying user_conf
- go (FlagGlobal : fs) = modifying virt_global_conf
- go (FlagConfig f : fs) = modifying f
- go (_ : fs) = go fs
- go [] = modifying virt_global_conf
-
- 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
- go flags
-
- db_stack <- mapM readParseDatabase final_stack
- return db_stack
-
-readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB)
-readParseDatabase filename = do
- str <- readFile filename `Exception.catch` \_ -> return emptyPackageConfig
- let packages = read str
- Exception.evaluate packages
- `Exception.catch` \_ ->
- die (filename ++ ": parse error in package config file")
- return (filename,packages)
-
-emptyPackageConfig :: String
-emptyPackageConfig = "[]"
+ 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
+ is_db_flag FlagGlobal = Just virt_global_conf
+ is_db_flag (FlagConfig f) = Just f
+ is_db_flag _ = Nothing
+
+ (final_stack, to_modify) <-
+ 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, Nothing)
+ else return (reverse (nub db_flags), Nothing)
+ 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
+
+ -- the database we actually modify is the one mentioned
+ -- rightmost on the command-line.
+ to_modify = if null db_flags
+ then Just virt_global_conf
+ else Just (last db_flags)
+ in
+ return (flag_stack, to_modify)
+
+ db_stack <- mapM (readParseDatabase mb_user_conf) final_stack
+ return (db_stack, to_modify)
+
+readParseDatabase :: Maybe (PackageDBName,Bool)
+ -> PackageDBName
+ -> IO (PackageDBName,PackageDB)
+readParseDatabase mb_user_conf filename
+ -- the user database (only) is allowed to be non-existent
+ | Just (user_conf,False) <- mb_user_conf, filename == user_conf
+ = return (filename, [])
+ | otherwise
+ = do str <- readFile filename
+ let packages = map convertPackageInfoIn $ read str
+ Exception.evaluate packages
+ `catchError` \e->
+ die ("error while parsing " ++ filename ++ ": " ++ show e)
+ return (filename,packages)
-- -----------------------------------------------------------------------------
-- Registering
registerPackage :: FilePath
- -> [(String,String)] -- defines
- -> [Flag]
- -> Bool -- auto_ghci_libs
- -> Bool -- update
- -> Force
- -> IO ()
-registerPackage input defines flags auto_ghci_libs update force = do
- db_stack <- getPkgDatabases True flags
+ -> [Flag]
+ -> Bool -- auto_ghci_libs
+ -> Bool -- update
+ -> Force
+ -> IO ()
+registerPackage input my_flags auto_ghci_libs update force = do
+ (db_stack, Just to_modify) <- getPkgDatabases True 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).fst) db_stack
--
-
s <-
case input of
"-" -> do
- putStr "Reading package info from stdin ... "
+ putStr "Reading package info from stdin ... "
getContents
f -> do
putStr ("Reading package info from " ++ show f ++ " ... ")
- readFile f
+ readFile f
- expanded <- expandEnvVars s defines force
+ expanded <- expandEnvVars s force
- pkg0 <- parsePackageInfo expanded defines
+ pkg <- parsePackageInfo expanded
putStrLn "done."
- let pkg = resolveDeps db_stack pkg0
- validatePackageConfig pkg db_stack auto_ghci_libs update force
+ let unversioned_deps = filter (not . realVersion) (depends pkg)
+ unless (null unversioned_deps) $
+ die ("Unversioned dependencies found: " ++
+ unwords (map display unversioned_deps))
+
+ let truncated_stack = dropWhile ((/= to_modify).fst) 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 truncated_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
- savingOldConfig db_filename $
- writeNewConfig db_filename new_details
+ writeNewConfig to_modify new_details
parsePackageInfo
- :: String
- -> [(String,String)]
- -> IO InstalledPackageInfo
-parsePackageInfo str defines =
+ :: String
+ -> IO InstalledPackageInfo
+parsePackageInfo str =
case parseInstalledPackageInfo str of
ParseOk _warns ok -> return ok
- ParseFailed err -> die (showError err)
+ ParseFailed err -> case locatedErrorMsg err of
+ (Nothing, s) -> die s
+ (Just l, s) -> die (show l ++ ": " ++ s)
-- -----------------------------------------------------------------------------
-- Exposing, Hiding, Unregistering are all similar
-exposePackage :: PackageIdentifier -> [Flag] -> IO ()
+exposePackage :: PackageIdentifier -> [Flag] -> Force -> IO ()
exposePackage = modifyPackage (\p -> [p{exposed=True}])
-hidePackage :: PackageIdentifier -> [Flag] -> IO ()
+hidePackage :: PackageIdentifier -> [Flag] -> Force -> IO ()
hidePackage = modifyPackage (\p -> [p{exposed=False}])
-unregisterPackage :: PackageIdentifier -> [Flag] -> IO ()
-unregisterPackage = modifyPackage (\p -> [])
+unregisterPackage :: PackageIdentifier -> [Flag] -> Force -> IO ()
+unregisterPackage = modifyPackage (\_ -> [])
modifyPackage
:: (InstalledPackageInfo -> [InstalledPackageInfo])
-> PackageIdentifier
-> [Flag]
+ -> Force
-> IO ()
-modifyPackage fn pkgid flags = do
- db_stack <- getPkgDatabases True{-modify-} flags
- let ((db_name, pkgs) : _) = db_stack
- ps <- findPackages [(db_name,pkgs)] pkgid
- let pids = map package ps
- let new_config = concat (map modify pkgs)
+modifyPackage fn pkgid my_flags force = do
+ (db_stack, Just _to_modify) <- getPkgDatabases True{-modify-} my_flags
+ ((db_name, pkgs), ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
+-- let ((db_name, pkgs) : rest_of_stack) = db_stack
+-- ps <- findPackages [(db_name,pkgs)] (Id pkgid)
+ let
+ pids = map package ps
modify pkg
- | package pkg `elem` pids = fn pkg
- | otherwise = [pkg]
- savingOldConfig db_name $
- writeNewConfig db_name new_config
+ | package pkg `elem` pids = fn pkg
+ | otherwise = [pkg]
+ new_config = concat (map modify pkgs)
+
+ let
+ old_broken = brokenPackages (allPackagesInStack db_stack)
+ rest_of_stack = [ (nm, mypkgs)
+ | (nm, mypkgs) <- db_stack, nm /= db_name ]
+ 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
+ --
+ 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
-- -----------------------------------------------------------------------------
-- Listing packages
-listPackages :: [Flag] -> Maybe PackageIdentifier -> IO ()
-listPackages flags mPackageName = do
- let simple_output = FlagSimpleOutput `elem` flags
- db_stack <- getPkgDatabases False flags
+listPackages :: [Flag] -> Maybe PackageArg -> Maybe (String->Bool) -> IO ()
+listPackages my_flags mPackageName mModuleName = do
+ let simple_output = FlagSimpleOutput `elem` my_flags
+ (db_stack, _) <- getPkgDatabases False 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
+ map (\(conf,pkgs) -> (conf, filter (this `matchesPkg`) pkgs))
+ db_stack
+ | Just match <- mModuleName = -- packages which expose mModuleName
+ map (\(conf,pkgs) -> (conf, filter (match `exposedInPkg`) pkgs))
+ db_stack
| otherwise = db_stack
- db_stack_sorted
+ db_stack_sorted
= [ (db, sort_pkgs pkgs) | (db,pkgs) <- 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)
-
- pkg_map = map (\p -> (package p, p)) $ concatMap snd db_stack
+ 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)
+
+ 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)
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))
- pp_pkg p
- | isBrokenPackage p pkg_map = braces doc
- | exposed p = doc
- | otherwise = parens doc
- where doc = text (showPackageId (package p))
-
- show_simple db_stack = do
- let pkgs = map showPackageId $ sortBy compPkgIdVer $
- map package (concatMap snd db_stack)
- when (null pkgs) $ die "no matches"
- hPutStrLn stdout $ concat $ intersperse " " pkgs
+ 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)
+ pp_pkg p
+ | package p `elem` broken = braces doc
+ | exposed p = doc
+ | otherwise = parens doc
+ where doc = text (display (package p))
+
+ show_simple = simplePackageList my_flags . allPackagesInStack
+
+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 package pkgs
+ when (not (null pkgs)) $
+ hPutStrLn stdout $ concat $ intersperse " " strs
-- -----------------------------------------------------------------------------
-- Prints the highest (hidden or exposed) version of a package
latestPackage :: [Flag] -> PackageIdentifier -> IO ()
-latestPackage flags pkgid = do
- db_stack <- getPkgDatabases False flags
- ps <- findPackages db_stack pkgid
+latestPackage my_flags pkgid = do
+ (db_stack, _) <- getPkgDatabases False my_flags
+ ps <- findPackages db_stack (Id pkgid)
show_pkg (sortBy compPkgIdVer (map package ps))
where
show_pkg [] = die "no matches"
- show_pkg pids = hPutStrLn stdout (showPackageId (last pids))
+ show_pkg pids = hPutStrLn stdout (display (last pids))
-- -----------------------------------------------------------------------------
-- Describe
-describePackage :: [Flag] -> PackageIdentifier -> IO ()
-describePackage flags pkgid = do
- db_stack <- getPkgDatabases False flags
- ps <- findPackages db_stack pkgid
- mapM_ (putStrLn . showInstalledPackageInfo) ps
+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
-- PackageId is can have globVersion for the version
-findPackages :: PackageDBStack -> PackageIdentifier -> IO [InstalledPackageInfo]
-findPackages db_stack pkgid
- = case [ p | p <- all_pkgs, pkgid `matchesPkg` p ] of
- [] -> die ("cannot find package " ++ showPackageId pkgid)
- ps -> return ps
+findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
+findPackages db_stack pkgarg
+ = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
+
+findPackagesByDB :: PackageDBStack -> PackageArg
+ -> IO [(NamedPackageDB, [InstalledPackageInfo])]
+findPackagesByDB db_stack pkgarg
+ = case [ (db, matched)
+ | db@(_, pkgs) <- db_stack,
+ let matched = filter (pkgarg `matchesPkg`) pkgs,
+ not (null matched) ] of
+ [] -> die ("cannot find package " ++ pkg_msg pkgarg)
+ ps -> return ps
where
- all_pkgs = concat (map snd db_stack)
+ pkg_msg (Id pkgid) = display pkgid
+ pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
matches :: PackageIdentifier -> PackageIdentifier -> Bool
pid `matches` pid'
= (pkgName pid == pkgName pid')
&& (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
-matchesPkg :: PackageIdentifier -> InstalledPackageInfo -> Bool
-pid `matchesPkg` pkg = pid `matches` package pkg
+matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
+(Id pid) `matchesPkg` pkg = pid `matches` package pkg
+(Substring _ m) `matchesPkg` pkg = m (display (package pkg))
compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
-- -----------------------------------------------------------------------------
-- Field
-describeField :: [Flag] -> PackageIdentifier -> String -> IO ()
-describeField flags pkgid field = do
- db_stack <- getPkgDatabases False flags
- case toField field of
- Nothing -> die ("unknown field: " ++ field)
- Just fn -> do
- ps <- findPackages db_stack pkgid
- let top_dir = getFilenameDir (fst (last db_stack))
- mapM_ (putStrLn . fn) (mungePackagePaths top_dir ps)
+describeField :: [Flag] -> PackageArg -> [String] -> IO ()
+describeField my_flags pkgarg fields = do
+ (db_stack, _) <- getPkgDatabases False 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)
+ where toFields [] = return []
+ toFields (f:fs) = case toField f of
+ Nothing -> die ("unknown field: " ++ f)
+ Just fn -> do fns <- toFields fs
+ return (fn:fns)
+ selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
--- Replace the string "$topdir" at the beginning of a path
+-- 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)
+ 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'
- | otherwise = p
+ 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
toField "extra_libraries" = Just $ strList . extraLibraries
toField "include_dirs" = Just $ strList . includeDirs
toField "c_includes" = Just $ strList . includes
-toField "package_deps" = Just $ strList . map showPackageId. depends
+toField "package_deps" = Just $ strList . map display. depends
toField "extra_cc_opts" = Just $ strList . ccOptions
toField "extra_ld_opts" = Just $ strList . ldOptions
-toField "framework_dirs" = Just $ strList . frameworkDirs
-toField "extra_frameworks"= Just $ strList . frameworks
-toField s = showInstalledPackageInfoField s
+toField "framework_dirs" = Just $ strList . frameworkDirs
+toField "extra_frameworks"= Just $ strList . frameworks
+toField s = showInstalledPackageInfoField s
strList :: [String] -> String
strList = show
-- Check: Check consistency of installed packages
checkConsistency :: [Flag] -> IO ()
-checkConsistency flags = do
- db_stack <- getPkgDatabases False flags
- let pkgs = map (\p -> (package p, p)) $ concatMap snd db_stack
- broken_pkgs = do
- (pid, p) <- pkgs
- let broken_deps = missingPackageDeps p pkgs
- guard (not . null $ broken_deps)
- return (pid, broken_deps)
- mapM_ (putStrLn . render . show_func) broken_pkgs
- where
- show_func | FlagSimpleOutput `elem` flags = show_simple
- | otherwise = show_normal
- show_simple (pid,deps) =
- text (showPackageId pid) <> colon
- <+> fsep (punctuate comma (map (text . showPackageId) deps))
- show_normal (pid,deps) =
- text "package" <+> text (showPackageId pid) <+> text "has missing dependencies:"
- $$ nest 4 (fsep (punctuate comma (map (text . showPackageId) deps)))
-
-missingPackageDeps :: InstalledPackageInfo
- -> [(PackageIdentifier, InstalledPackageInfo)]
- -> [PackageIdentifier]
-missingPackageDeps pkg pkg_map =
- [ d | d <- depends pkg, isNothing (lookup d pkg_map)] ++
- [ d | d <- depends pkg, Just p <- return (lookup d pkg_map), isBrokenPackage p pkg_map]
-
-isBrokenPackage :: InstalledPackageInfo -> [(PackageIdentifier, InstalledPackageInfo)] -> Bool
-isBrokenPackage pkg pkg_map = not . null $ missingPackageDeps pkg pkg_map
+checkConsistency my_flags = do
+ (db_stack, _) <- getPkgDatabases True my_flags
+ -- check behaves like modify for the purposes of deciding which
+ -- databases to use, because ordering is important.
+
+ let simple_output = FlagSimpleOutput `elem` my_flags
+
+ let pkgs = allPackagesInStack db_stack
+
+ checkPackage p = do
+ (_,es) <- runValidate $ checkPackageConfig p db_stack False True
+ if null es
+ then return []
+ else do
+ when (not simple_output) $ do
+ reportError ("There are problems in package " ++ display (package p) ++ ":")
+ reportValidateErrors es " " Nothing
+ return ()
+ return [p]
+
+ broken_pkgs <- concat `fmap` mapM checkPackage pkgs
+
+ let filterOut pkgs1 pkgs2 = filter not_in pkgs2
+ where not_in p = package p `notElem` all_ps
+ all_ps = map package 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 . package) 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') -> (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
+ -- 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
+type InstalledPackageInfoString = InstalledPackageInfo_ String
+
+convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString
+convertPackageInfoOut
+ (pkgconf@(InstalledPackageInfo { exposedModules = e,
+ hiddenModules = h })) =
+ pkgconf{ exposedModules = map display e,
+ hiddenModules = map display h }
+
+convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
+convertPackageInfoIn
+ (pkgconf@(InstalledPackageInfo { exposedModules = e,
+ hiddenModules = h })) =
+ pkgconf{ exposedModules = map convert e,
+ hiddenModules = map convert h }
+ where convert = fromJust . simpleParse
+
writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO ()
writeNewConfig filename packages = do
hPutStr stdout "Writing new package config file... "
- createDirectoryIfMissing True $ getFilenameDir filename
- h <- openFile filename WriteMode `catch` \e ->
+ createDirectoryIfMissing True $ takeDirectory filename
+ let shown = concat $ intersperse ",\n "
+ $ map (show . convertPackageInfoOut) packages
+ fileContents = "[" ++ shown ++ "\n]"
+ writeFileAtomic filename fileContents
+ `catch` \e ->
if isPermissionError e
then die (filename ++ ": you don't have permission to modify this file")
else ioError e
- hPutStrLn h (show packages)
- hClose h
hPutStrLn stdout "done."
-savingOldConfig :: FilePath -> IO () -> IO ()
-savingOldConfig filename io = Exception.block $ do
- hPutStr stdout "Saving old package config file... "
- -- mv rather than cp because we've already done an hGetContents
- -- on this file so we won't be able to open it for writing
- -- unless we move the old one out of the way...
- let oldFile = filename ++ ".old"
- restore_on_error <- catch (renameFile filename oldFile >> return True) $
- \err -> do
- unless (isDoesNotExistError err) $ do
- hPutStrLn stderr (unwords ["Unable to rename", show filename,
- "to", show oldFile])
- ioError err
- return False
- hPutStrLn stdout "done."
- io `catch` \e -> do
- hPutStrLn stderr (show e)
- hPutStr stdout ("\nWARNING: an error was encountered while writing"
- ++ "the new configuration.\n")
- when restore_on_error $ do
- hPutStr stdout "Attempting to restore the old configuration..."
- do renameFile oldFile filename
- hPutStrLn stdout "done."
- `catch` \err -> hPutStrLn stdout ("Failed: " ++ show err)
- ioError e
-
-----------------------------------------------------------------------------
-- Sanity-check a new package config, and automatically build GHCi libs
-- if requested.
+type ValidateError = (Force,String)
+
+newtype Validate a = V { runValidate :: IO (a, [ValidateError]) }
+
+instance Monad Validate where
+ return a = V $ return (a, [])
+ m >>= k = V $ do
+ (a, es) <- runValidate m
+ (b, es') <- runValidate (k a)
+ return (b,es++es')
+
+verror :: Force -> String -> Validate ()
+verror f s = V (return ((),[(f,s)]))
+
+liftIO :: IO a -> Validate a
+liftIO k = V (k >>= \a -> return (a,[]))
+
+-- returns False if we should die
+reportValidateErrors :: [ValidateError] -> String -> Maybe Force -> IO Bool
+reportValidateErrors es prefix mb_force = do
+ 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
- -> Force
- -> IO ()
+ -> PackageDBStack
+ -> Bool -- auto-ghc-libs
+ -> Bool -- update, or check
+ -> Force
+ -> IO ()
validatePackageConfig pkg db_stack auto_ghci_libs update force = do
+ (_,es) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update
+ ok <- reportValidateErrors es (display (package 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
checkPackageId pkg
checkDuplicates db_stack pkg update
- 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)
+ mapM_ (checkDep db_stack) (depends pkg)
+ checkDuplicateDepends (depends pkg)
+ mapM_ (checkDir "import-dirs") (importDirs pkg)
+ mapM_ (checkDir "library-dirs") (libraryDirs pkg)
+ mapM_ (checkDir "include-dirs") (includeDirs pkg)
+ checkModules pkg
+ mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
-- ToDo: check these somehow?
- -- extra_libraries :: [String],
- -- c_includes :: [String],
+ -- extra_libraries :: [String],
+ -- c_includes :: [String],
-- 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
+-- 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 = showPackageId (package ipi) in
- case [ x | (x,ys) <- readP_to_S parsePackageId str, all isSpace ys ] of
+ let str = display (package 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)
-resolveDeps :: PackageDBStack -> InstalledPackageInfo -> InstalledPackageInfo
-resolveDeps db_stack p = updateDeps p
- where
- -- The input package spec is allowed to give a package dependency
- -- without a version number; e.g.
- -- depends: base
- -- Here, we update these dependencies without version numbers to
- -- match the actual versions of the relevant packages installed.
- updateDeps p = p{depends = map resolveDep (depends p)}
-
- resolveDep dep_pkgid
- | realVersion dep_pkgid = dep_pkgid
- | otherwise = lookupDep dep_pkgid
-
- lookupDep dep_pkgid
- = let
- name = pkgName dep_pkgid
- in
- case [ pid | p <- concat (map snd db_stack),
- let pid = package p,
- pkgName pid == name ] of
- (pid:_) -> pid -- Found installed package,
- -- replete with its version
- [] -> dep_pkgid -- No installed package; use
- -- the version-less one
-
-checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> IO ()
+checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
checkDuplicates db_stack pkg update = do
let
- pkgid = package pkg
- (_top_db_name, pkgs) : _ = db_stack
+ pkgid = package pkg
+ (_top_db_name, pkgs) : _ = db_stack
--
-- Check whether this package id already exists in this DB
--
when (not update && (pkgid `elem` map package pkgs)) $
- die ("package " ++ showPackageId pkgid ++ " is already installed")
+ verror CannotForce $
+ "package " ++ display pkgid ++ " is already installed"
+
+ let
+ uncasep = map toLower . display
+ dups = filter ((== uncasep pkgid) . uncasep) (map package pkgs)
+ 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 ()
- -- can't check this, because we don't know what $topdir is
+checkDir :: String -> String -> Validate ()
+checkDir thisfield d
+ | "$topdir" `isPrefixOf` d = return ()
+ | "$httptopdir" `isPrefixOf` d = return ()
+ -- can't check these, because we don't know what $(http)topdir is
| otherwise = do
- there <- doesDirectoryExist d
- when (not there)
- (dieOrForceFile force (d ++ " doesn't exist or isn't a directory"))
+ there <- liftIO $ doesDirectoryExist d
+ when (not there) $
+ verror ForceFiles (thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory")
-checkDep :: PackageDBStack -> Force -> PackageIdentifier -> IO ()
-checkDep db_stack force pkgid
+checkDep :: PackageDBStack -> PackageIdentifier -> Validate ()
+checkDep db_stack pkgid
| pkgid `elem` pkgids || (not real_version && name_exists) = return ()
- | otherwise = dieOrForceAll force ("dependency " ++ showPackageId pkgid
- ++ " doesn't exist")
+ | 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
-
+ -- 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 = concat (map snd db_stack)
- pkgids = map package all_pkgs
+ all_pkgs = allPackagesInStack db_stack
+ pkgids = map package all_pkgs
+
+checkDuplicateDepends :: [PackageIdentifier] -> Validate ()
+checkDuplicateDepends deps
+ | null dups = return ()
+ | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
+ unwords (map display dups))
+ where
+ dups = [ p | (p:_:_) <- group (sort deps) ]
realVersion :: PackageIdentifier -> Bool
realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
-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
- | otherwise = doesFileExist (d ++ '/':lib)
+ 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 dirs 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
+ | "$topdir" `isPrefixOf` d = return True
+ | "$httptopdir" `isPrefixOf` d = return True
+ | otherwise = doesFileExist (d </> lib)
+
+checkModules :: InstalledPackageInfo -> Validate ()
+checkModules pkg = do
+ mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
+ where
+ 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 -> 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 ()
- where
- ghci_lib_file = lib ++ ".o"
+ m <- doesFileExistOnPath ghci_lib_file dirs
+ when (isNothing m && ghci_lib_file /= "HSrts.o") $
+ hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file)
+ where
+ ghci_lib_file = lib <.> "o"
--- automatically build the GHCi version of a batch lib,
+-- automatically build the GHCi version of a batch lib,
-- using ld --whole-archive.
autoBuildGHCiLib :: String -> String -> String -> IO ()
#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]
#if not_yet
findModules :: [FilePath] -> IO [String]
-findModules paths =
+findModules paths =
mms <- mapM searchDir paths
return (concat mms)
searchEntries path prefix [] = return []
searchEntries path prefix (f:fs)
| looks_like_a_module = do
- ms <- searchEntries path prefix fs
- return (prefix `joinModule` f : ms)
+ ms <- searchEntries path prefix fs
+ return (prefix `joinModule` f : ms)
| looks_like_a_component = do
- ms <- searchDir (path `joinFilename` f) (prefix `joinModule` f)
+ ms <- searchDir (path </> f) (prefix `joinModule` f)
ms' <- searchEntries path prefix fs
- return (ms ++ ms')
+ return (ms ++ ms')
| otherwise
- searchEntries path prefix fs
+ searchEntries path prefix fs
where
- (base,suffix) = splitFileExt f
- looks_like_a_module =
- suffix `elem` haskell_suffixes &&
- all okInModuleName base
- looks_like_a_component =
- null suffix && all okInModuleName base
+ (base,suffix) = splitFileExt f
+ looks_like_a_module =
+ suffix `elem` haskell_suffixes &&
+ all okInModuleName base
+ looks_like_a_component =
+ null suffix && all okInModuleName base
okInModuleName c
#endif
--- -----------------------------------------------------------------------------
--- The old command-line syntax, supported for backwards compatibility
-
-data OldFlag
- = OF_Config FilePath
- | OF_Input FilePath
- | OF_List
- | OF_ListLocal
- | OF_Add Bool {- True => replace existing info -}
- | OF_Remove String | OF_Show String
- | OF_Field String | OF_AutoGHCiLibs | OF_Force
- | OF_DefinedName String String
- | OF_GlobalConfig FilePath
- deriving (Eq)
-
-isAction :: OldFlag -> Bool
-isAction OF_Config{} = False
-isAction OF_Field{} = False
-isAction OF_Input{} = False
-isAction OF_AutoGHCiLibs{} = False
-isAction OF_Force{} = False
-isAction OF_DefinedName{} = False
-isAction OF_GlobalConfig{} = False
-isAction _ = True
-
-oldFlags :: [OptDescr OldFlag]
-oldFlags = [
- Option ['f'] ["config-file"] (ReqArg OF_Config "FILE")
- "use the specified package config file",
- Option ['l'] ["list-packages"] (NoArg OF_List)
- "list packages in all config files",
- Option ['L'] ["list-local-packages"] (NoArg OF_ListLocal)
- "list packages in the specified config file",
- Option ['a'] ["add-package"] (NoArg (OF_Add False))
- "add a new package",
- Option ['u'] ["update-package"] (NoArg (OF_Add True))
- "update package with new configuration",
- Option ['i'] ["input-file"] (ReqArg OF_Input "FILE")
- "read new package info from specified file",
- Option ['s'] ["show-package"] (ReqArg OF_Show "NAME")
- "show the configuration for package NAME",
- Option [] ["field"] (ReqArg OF_Field "FIELD")
- "(with --show-package) Show field FIELD only",
- Option [] ["force"] (NoArg OF_Force)
- "ignore missing directories/libraries",
- Option ['r'] ["remove-package"] (ReqArg OF_Remove "NAME")
- "remove an installed package",
- Option ['g'] ["auto-ghci-libs"] (NoArg OF_AutoGHCiLibs)
- "automatically build libs for GHCi (with -a)",
- Option ['D'] ["define-name"] (ReqArg toDefined "NAME=VALUE")
- "define NAME as VALUE",
- Option [] ["global-conf"] (ReqArg OF_GlobalConfig "FILE")
- "location of the global package config"
- ]
- where
- toDefined str =
- case break (=='=') str of
- (nm,[]) -> OF_DefinedName nm []
- (nm,_:val) -> OF_DefinedName nm val
-
-oldRunit :: [OldFlag] -> IO ()
-oldRunit clis = do
- let new_flags = [ f | Just f <- map conv clis ]
-
- conv (OF_GlobalConfig f) = Just (FlagGlobalConfig f)
- conv (OF_Config f) = Just (FlagConfig f)
- conv _ = Nothing
-
-
-
- let fields = [ f | OF_Field f <- clis ]
-
- let auto_ghci_libs = any isAuto clis
- where isAuto OF_AutoGHCiLibs = True; isAuto _ = False
- input_file = my_head "inp" ([ f | (OF_Input f) <- clis] ++ ["-"])
-
- force = if OF_Force `elem` clis then ForceAll else NoForce
-
- defines = [ (nm,val) | OF_DefinedName nm val <- clis ]
-
- case [ c | c <- clis, isAction c ] of
- [ OF_List ] -> listPackages new_flags Nothing
- [ OF_ListLocal ] -> listPackages new_flags Nothing
- [ OF_Add upd ] ->
- registerPackage input_file defines new_flags auto_ghci_libs upd force
- [ OF_Remove pkgid_str ] -> do
- pkgid <- readPkgId pkgid_str
- unregisterPackage pkgid new_flags
- [ OF_Show pkgid_str ]
- | null fields -> do
- pkgid <- readPkgId pkgid_str
- describePackage new_flags pkgid
- | otherwise -> do
- pkgid <- readPkgId pkgid_str
- mapM_ (describeField new_flags pkgid) fields
- _ -> do
- prog <- getProgramName
- die (usageInfo (usageHeader prog) flags)
-
-my_head :: String -> [a] -> a
-my_head s [] = error s
-my_head s (x:xs) = x
-
-- ---------------------------------------------------------------------------
-- expanding environment variables in the package configuration
-expandEnvVars :: String -> [(String, String)] -> Force -> IO String
-expandEnvVars str defines force = go str ""
+expandEnvVars :: String -> Force -> IO String
+expandEnvVars str0 force = go str0 ""
where
go "" acc = return $! reverse acc
go ('$':'{':str) acc | (var, '}':rest) <- break close str
= do value <- lookupEnvVar var
- go rest (reverse value ++ acc)
- where close c = c == '}' || c == '\n' -- don't span newlines
+ go rest (reverse value ++ acc)
+ where close c = c == '}' || c == '\n' -- don't span newlines
go (c:str) acc
- = go str (c:acc)
+ = go str (c:acc)
lookupEnvVar :: String -> IO String
- lookupEnvVar nm =
- case lookup nm defines of
- Just x | not (null x) -> return x
- _ ->
- catch (System.getEnv nm)
- (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
- show nm)
- return "")
+ lookupEnvVar nm =
+ catch (System.Environment.getEnv nm)
+ (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
+ show nm)
+ return "")
-----------------------------------------------------------------------------
bye s = putStr s >> exitWith ExitSuccess
die :: String -> IO a
-die s = do
+die = dieWith 1
+
+dieWith :: Int -> String -> IO a
+dieWith ec s = do
hFlush stdout
prog <- getProgramName
hPutStrLn stderr (prog ++ ": " ++ s)
- exitWith (ExitFailure 1)
+ exitWith (ExitFailure ec)
dieOrForceAll :: Force -> String -> IO ()
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
-
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)")
+my_head :: String -> [a] -> a
+my_head s [] = error s
+my_head _ (x : _) = x
+
-----------------------------------------
--- Cut and pasted from ghc/compiler/SysTools
+-- Cut and pasted from ghc/compiler/main/SysTools
#if defined(mingw32_HOST_OS)
+subst :: Char -> Char -> String -> String
subst a b ls = map (\ x -> if x == a then b else x) ls
+
+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
+-- 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 unDosifyPath = subst '\\' '/'
+ initN n = reverse . drop n . reverse
+ removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
+
+getExecPath :: IO (Maybe String)
+getExecPath =
+ allocaArray len $ \buf -> do
+ ret <- getModuleFileName nullPtr buf len
+ if ret == 0 then return Nothing
+ else liftM Just $ peekCString buf
+ where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
+
+foreign import stdcall unsafe "GetModuleFileNameA"
+ getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
-foreign import stdcall unsafe "GetModuleFileNameA"
- getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
#else
-getExecDir :: String -> IO (Maybe String)
-getExecDir _ = return Nothing
+getLibDir :: IO (Maybe String)
+getLibDir = return Nothing
#endif
--- -----------------------------------------------------------------------------
--- FilePath utils
+-----------------------------------------
+-- Adapted from ghc/compiler/utils/Panic
--- | The 'joinFileName' function is the opposite of 'splitFileName'.
--- It joins directory and file names to form a complete file path.
---
--- The general rule is:
---
--- > dir `joinFileName` basename == path
--- > where
--- > (dir,basename) = splitFileName path
---
--- There might be an exceptions to the rule but in any case the
--- reconstructed path will refer to the same object (file or directory).
--- An example exception is that on Windows some slashes might be converted
--- to backslashes.
-joinFileName :: String -> String -> FilePath
-joinFileName "" fname = fname
-joinFileName "." fname = fname
-joinFileName dir "" = dir
-joinFileName dir fname
- | isPathSeparator (last dir) = dir++fname
- | otherwise = dir++pathSeparator:fname
-
--- | Checks whether the character is a valid path separator for the host
--- platform. The valid character is a 'pathSeparator' but since the Windows
--- operating system also accepts a slash (\"\/\") since DOS 2, the function
--- checks for it on this platform, too.
-isPathSeparator :: Char -> Bool
-isPathSeparator ch = ch == pathSeparator || ch == '/'
-
--- | Provides a platform-specific character used to separate directory levels in
--- a path string that reflects a hierarchical file system organization. The
--- separator is a slash (@\"\/\"@) on Unix and Macintosh, and a backslash
--- (@\"\\\"@) on the Windows operating system.
-pathSeparator :: Char
-#ifdef mingw32_HOST_OS
-pathSeparator = '\\'
+installSignalHandlers :: IO ()
+installSignalHandlers = do
+ threadid <- myThreadId
+ let
+ interrupt = Exception.throwTo threadid
+ (Exception.ErrorCall "interrupted")
+ --
+#if !defined(mingw32_HOST_OS)
+ installHandler sigQUIT (Catch interrupt) Nothing
+ installHandler sigINT (Catch interrupt) Nothing
+ return ()
+#elif __GLASGOW_HASKELL__ >= 603
+ -- 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
+ -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
+ -- why --SDM 17/12/2004
+ let sig_handler ControlC = interrupt
+ sig_handler Break = interrupt
+ sig_handler _ = return ()
+
+ 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)
+#endif
+
+#if mingw32_HOST_OS || mingw32_TARGET_OS
+throwIOIO :: Exception.IOException -> IO a
+throwIOIO = Exception.throwIO
+
+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
+catchIO = Exception.catch
+#endif
+
+catchError :: IO a -> (String -> IO a) -> IO a
+catchError io handler = io `Exception.catch` handler'
+ where handler' (Exception.ErrorCall err) = handler err
+
+
+-- 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
+ (newFile, newHandle) <- openNewFile targetDir template
+ do hPutStr newHandle content
+ hClose newHandle
+#if mingw32_HOST_OS || mingw32_TARGET_OS
+ renameFile newFile targetFile
+ -- If the targetFile exists then renameFile will fail
+ `catchIO` \err -> do
+ exists <- doesFileExist targetFile
+ if exists
+ then do removeFile targetFile
+ -- Big fat hairy race condition
+ renameFile newFile targetFile
+ -- If the removeFile succeeds and the renameFile fails
+ -- then we've lost the atomic property.
+ else throwIOIO err
+#else
+ renameFile newFile targetFile
+#endif
+ `Exception.onException` do hClose newHandle
+ removeFile newFile
+ where
+ template = targetName <.> "tmp"
+ targetDir | null targetDir_ = "."
+ | otherwise = targetDir_
+ --TODO: remove this when takeDirectory/splitFileName is fixed
+ -- to always return a valid dir
+ (targetDir_,targetName) = splitFileName targetFile
+
+-- Ugh, this is a copy/paste of code from the base library, but
+-- if uses 666 rather than 600 for the permissions.
+openNewFile :: FilePath -> String -> IO (FilePath, Handle)
+openNewFile dir template = do
+ pid <- c_getpid
+ findTempName pid
+ where
+ -- We split off the last extension, so we can use .foo.ext files
+ -- for temporary files (hidden on Unix OSes). Unfortunately we're
+ -- below filepath in the hierarchy here.
+ (prefix,suffix) =
+ case break (== '.') $ reverse template of
+ -- First case: template contains no '.'s. Just re-reverse it.
+ (rev_suffix, "") -> (reverse rev_suffix, "")
+ -- Second case: template contains at least one '.'. Strip the
+ -- dot from the prefix and prepend it to the suffix (if we don't
+ -- do this, the unique number will get added after the '.' and
+ -- thus be part of the extension, which is wrong.)
+ (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
+ -- Otherwise, something is wrong, because (break (== '.')) should
+ -- always return a pair with either the empty string or a string
+ -- beginning with '.' as the second component.
+ _ -> error "bug in System.IO.openTempFile"
+
+ oflags = rw_flags .|. o_EXCL
+
+ findTempName x = do
+ fd <- withCString filepath $ \ f ->
+ c_open f oflags 0o666
+ if fd < 0
+ then do
+ errno <- getErrno
+ if errno == eEXIST
+ then findTempName (x+1)
+ else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))
+ else do
+ -- XXX We want to tell fdToHandle what the filepath is,
+ -- as any exceptions etc will only be able to report the
+ -- fd currently
+ h <-
+#if __GLASGOW_HASKELL__ >= 609
+ fdToHandle fd
#else
-pathSeparator = '/'
+ fdToHandle (fromIntegral fd)
#endif
+ `Exception.onException` c_close fd
+ return (filepath, h)
+ where
+ filename = prefix ++ show x ++ suffix
+ filepath = dir `combine` filename
-getFilenameDir :: FilePath -> FilePath
-getFilenameDir fn = case break isPathSeparator (reverse fn) of
- (xs, "") -> "."
- (_, sep:ys) -> reverse ys
+-- XXX Copied from GHC.Handle
+std_flags, output_flags, rw_flags :: CInt
+std_flags = o_NONBLOCK .|. o_NOCTTY
+output_flags = std_flags .|. o_CREAT
+rw_flags = output_flags .|. o_RDWR
-- | The function splits the given string to substrings
--- using the 'searchPathSeparator'.
+-- using 'isSearchPathSeparator'.
parseSearchPath :: String -> [FilePath]
parseSearchPath path = split path
where
split :: String -> [String]
split s =
case rest' of
- [] -> [chunk]
+ [] -> [chunk]
_:rest -> chunk : split rest
where
- chunk =
+ chunk =
case chunk' of
#ifdef mingw32_HOST_OS
('\"':xs@(_:_)) | last xs == '\"' -> init xs
#endif
_ -> chunk'
- (chunk', rest') = break (==searchPathSeparator) s
-
--- | A platform-specific character used to separate search path strings in
--- environment variables. The separator is a colon (\":\") on Unix and Macintosh,
--- and a semicolon (\";\") on the Windows operating system.
-searchPathSeparator :: Char
-#if mingw32_HOST_OS || mingw32_TARGET_OS
-searchPathSeparator = ';'
-#else
-searchPathSeparator = ':'
-#endif
-
+ (chunk', rest') = break isSearchPathSeparator s
projects / ghc-hetmet.git / blobdiff