-- TODO:
-- - validate modules
--- - expose/hide
-- - expanding of variables in new-style package conf
-- - version manipulation (checking whether old version exists,
-- hiding old version?)
import Version ( version, targetOS, targetARCH )
import Distribution.InstalledPackageInfo
import Distribution.Compat.ReadP
+import Distribution.ParseUtils ( showError, ParseResult(..) )
import Distribution.Package
-import Distribution.License
import Distribution.Version
-import Compat.Directory ( getAppUserDataDirectory )
+import Compat.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
+import Compat.RawSystem ( rawSystem )
import Control.Exception ( evaluate )
-import qualified Control.Exception as Exception
import Prelude
-import Package -- the old package config type
-
-#if __GLASGOW_HASKELL__ < 603
-#include "config.h"
-#endif
+#include "../../includes/ghcconfig.h"
#if __GLASGOW_HASKELL__ >= 504
import System.Console.GetOpt
import Data.Char ( isSpace )
import Monad
import Directory
-import System ( getEnv, getArgs, getProgName,
- system, exitWith,
- ExitCode(..)
+import System ( getArgs, getProgName,
+ exitWith, ExitCode(..)
)
-import IO
-import List ( isPrefixOf, isSuffixOf )
-
-import ParsePkgConfLite
-
-#include "../../includes/ghcconfig.h"
+import System.IO
+import Data.List ( isPrefixOf, isSuffixOf, intersperse )
#ifdef mingw32_HOST_OS
import Foreign
bye (usageInfo (usageHeader prog) flags)
(cli,_,[]) | FlagVersion `elem` cli ->
bye ourCopyright
- (cli@(_:_),nonopts,[]) ->
+ (cli,nonopts,[]) ->
runit cli nonopts
(_,_,errors) -> tryOldCmdLine errors args
| FlagConfig FilePath
| FlagGlobalConfig FilePath
| FlagForce
+ | FlagAutoGHCiLibs
deriving Eq
flags :: [OptDescr Flag]
"location of the global package config",
Option [] ["force"] (NoArg FlagForce)
"ignore missing dependencies, directories, and libraries",
+ Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
+ "automatically build libs for GHCi (with register)",
Option ['?'] ["help"] (NoArg FlagHelp)
"display this help and exit",
Option ['V'] ["version"] (NoArg FlagVersion)
usageHeader :: String -> String
usageHeader prog = substProg prog $
"Usage:\n" ++
- " $p {--help | -?}\n" ++
- " Produce this usage message.\n" ++
- "\n" ++
- " $p register {filename | -} [--user | --global]\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" ++
"\n" ++
+ " $p update {filename | -}\n" ++
+ " Register the package, overwriting any other package with the\n" ++
+ " same name.\n" ++
+ "\n" ++
" $p unregister {pkg-id}\n" ++
" Unregister the specified package.\n" ++
"\n" ++
" $p hide {pkg-id}\n" ++
" Hide the specified package.\n" ++
"\n" ++
- " $p list [--global | --user]\n" ++
- " List all registered packages, both global and user (unless either\n" ++
- " --global or --user is specified), and both hidden and exposed.\n" ++
+ " $p list\n" ++
+ " List registered packages in the global database, and also the" ++
+ " user database if --user is given.\n" ++
"\n" ++
" $p describe {pkg-id}\n" ++
" Give the registered description for the specified package. The\n" ++
"\n" ++
" $p field {pkg-id} {field}\n" ++
" Extract the specified field of the package description for the\n" ++
- " specified package.\n"
+ " specified package.\n" ++
+ "\n" ++
+ " The following optional flags are also accepted:\n"
substProg :: String -> String -> String
substProg _ [] = []
runit :: [Flag] -> [String] -> IO ()
runit cli nonopts = do
prog <- getProgramName
- dbs <- getPkgDatabases cli
- db_stack <- mapM readParseDatabase dbs
let
force = FlagForce `elem` cli
+ auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
--
-- first, parse the command
case nonopts of
["register", filename] ->
- registerPackage filename [] db_stack False False force
+ registerPackage filename [] cli auto_ghci_libs False force
["update", filename] ->
- registerPackage filename [] db_stack False True force
+ registerPackage filename [] cli auto_ghci_libs True force
["unregister", pkgid_str] -> do
- pkgid <- readPkgId pkgid_str
- unregisterPackage db_stack pkgid
+ pkgid <- readGlobPkgId pkgid_str
+ unregisterPackage pkgid cli
["expose", pkgid_str] -> do
- pkgid <- readPkgId pkgid_str
- exposePackage pkgid db_stack
+ pkgid <- readGlobPkgId pkgid_str
+ exposePackage pkgid cli
["hide", pkgid_str] -> do
- pkgid <- readPkgId pkgid_str
- hidePackage pkgid db_stack
+ pkgid <- readGlobPkgId pkgid_str
+ hidePackage pkgid cli
["list"] -> do
- listPackages db_stack
+ listPackages cli
["describe", pkgid_str] -> do
- pkgid <- readPkgId pkgid_str
- describePackage db_stack pkgid
+ pkgid <- readGlobPkgId pkgid_str
+ describePackage cli pkgid
["field", pkgid_str, field] -> do
- pkgid <- readPkgId pkgid_str
- describeField db_stack pkgid field
+ pkgid <- readGlobPkgId pkgid_str
+ describeField cli pkgid field
[] -> do
die ("missing command\n" ++
usageInfo (usageHeader prog) flags)
parseCheck :: ReadP a a -> String -> String -> IO a
parseCheck parser str what =
- case readP_to_S parser str of
- [(x,ys)] | all isSpace ys -> return x
+ 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
+ +++
+ (do n <- parsePackageName; string "-*"
+ return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
+
+-- globVersion means "all versions"
+globVersion = Version{ versionBranch=[], versionTags=["*"] }
+
-- -----------------------------------------------------------------------------
-- Package databases
-- A stack of package databases. Convention: head is the topmost
-- in the stack. Earlier entries override later one.
--- The output of this function is the list of databases to act upon, with
--- the "topmost" overlapped database last. The commands which operate on a
--- single database will use the last one. Commands which operate on multiple
--- databases will interpret the databases as overlapping.
-getPkgDatabases :: [Flag] -> IO [PackageDBName]
-getPkgDatabases flags = do
+getPkgDatabases :: Bool -> [Flag] -> IO PackageDBStack
+getPkgDatabases modify 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
subdir = targetARCH ++ '-':targetOS ++ '-':version
- user_conf = appdir `joinFileName` subdir `joinFileName` "package.conf"
+ archdir = appdir `joinFileName` subdir
+ user_conf = archdir `joinFileName` "package.conf"
b <- doesFileExist user_conf
when (not b) $ do
putStrLn ("Creating user package database in " ++ user_conf)
- createParents user_conf
+ createDirectoryIfMissing True archdir
writeFile user_conf emptyPackageConfig
let
- databases = foldl addDB [global_conf] flags
+ -- The semantics here are slightly strange. If we are
+ -- *modifying* the database, then the default is to modify
+ -- the global database by default, unless you say --user.
+ -- If we are not modifying (eg. list, describe etc.) then
+ -- the user database is included by default.
+ databases
+ | modify = foldl addDB [global_conf] flags
+ | not modify = foldl addDB [user_conf,global_conf] flags
-- implement the following rules:
- -- global database is the default
-- --user means overlap with the user database
-- --global means reset to just the global database
-- -f <file> means overlap with <file>
- addDB dbs FlagUser = user_conf : dbs
+ addDB dbs FlagUser = if user_conf `elem` dbs
+ then dbs
+ else user_conf : dbs
addDB dbs FlagGlobal = [global_conf]
addDB dbs (FlagConfig f) = f : dbs
addDB dbs _ = dbs
- return databases
+ db_stack <- mapM readParseDatabase databases
+ return db_stack
readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB)
readParseDatabase filename = do
let packages = read str
evaluate packages
`Exception.catch` \_ ->
- die (filename ++ ": parse error in package config file\n")
+ die (filename ++ ": parse error in package config file")
return (filename,packages)
emptyPackageConfig :: String
registerPackage :: FilePath
-> [(String,String)] -- defines, ToDo: maybe remove?
- -> PackageDBStack
+ -> [Flag]
-> Bool -- auto_ghci_libs
-> Bool -- update
-> Bool -- force
-> IO ()
-registerPackage input defines db_stack auto_ghci_libs update force = do
+registerPackage input defines flags auto_ghci_libs update force = do
+ db_stack <- getPkgDatabases True flags
let
- db_to_operate_on = head db_stack
+ db_to_operate_on = my_head "db" db_stack
db_filename = fst db_to_operate_on
--
checkConfigAccess db_filename
putStr "Reading package info from stdin... "
getContents
f -> do
- putStr ("Reading package info from " ++ show f)
+ putStr ("Reading package info from " ++ show f ++ " ")
readFile f
pkg <- parsePackageInfo s defines force
putStrLn "done."
validatePackageConfig pkg db_stack auto_ghci_libs update force
- new_details <- updatePackageDB (snd db_to_operate_on) pkg
+ new_details <- updatePackageDB db_stack (snd db_to_operate_on) pkg
savePackageConfig db_filename
maybeRestoreOldConfig db_filename $
writeNewConfig db_filename new_details
-> IO InstalledPackageInfo
parsePackageInfo str defines force =
case parseInstalledPackageInfo str of
- Right ok -> return ok
- Left err -> do
- old_pkg <- evaluate (parseOnePackageConfig str)
- `Exception.catch` \_ -> parse_failed
- putStr "Expanding embedded variables... "
- new_old_pkg <- expandEnvVars old_pkg defines force
- return (convertOldPackage old_pkg)
- where
- parse_failed = die "parse error in package info\n"
-
-convertOldPackage :: PackageConfig -> InstalledPackageInfo
-convertOldPackage
- Package {
- name = name,
- auto = auto,
- import_dirs = import_dirs,
- source_dirs = source_dirs,
- library_dirs = library_dirs,
- hs_libraries = hs_libraries,
- extra_libraries = extra_libraries,
- include_dirs = include_dirs,
- c_includes = c_includes,
- package_deps = package_deps,
- extra_ghc_opts = extra_ghc_opts,
- extra_cc_opts = extra_cc_opts,
- extra_ld_opts = extra_ld_opts,
- framework_dirs = framework_dirs,
- extra_frameworks= extra_frameworks
- }
- = InstalledPackageInfo {
- package = pkgNameToId name,
- license = AllRightsReserved,
- copyright = "",
- maintainer = "",
- author = "",
- stability = "",
- homepage = "",
- pkgUrl = "",
- description = "",
- category = "",
- exposed = auto,
- exposedModules = [],
- hiddenModules = [],
- importDirs = import_dirs,
- libraryDirs = library_dirs,
- hsLibraries = hs_libraries,
- extraLibraries = extra_libraries,
- includeDirs = include_dirs,
- includes = c_includes,
- depends = map pkgNameToId package_deps,
- extraHugsOpts = [],
- extraCcOpts = extra_cc_opts,
- extraLdOpts = extra_ld_opts,
- frameworkDirs = framework_dirs,
- extraFrameworks = extra_frameworks,
- haddockInterfaces = [],
- haddockHTMLs = []
- }
-
-
--- Used for converting old versionless package names to new PackageIdentifiers.
--- "Version [] []" is special: it means "no version" or "any version"
-pkgNameToId :: String -> PackageIdentifier
-pkgNameToId name = PackageIdentifier name (Version [] [])
+ ParseOk ok -> return ok
+ ParseFailed err -> die (showError err)
-- -----------------------------------------------------------------------------
--- Unregistering
+-- Exposing, Hiding, Unregistering are all similar
-unregisterPackage :: PackageDBStack -> PackageIdentifier -> IO ()
-unregisterPackage [] _ = error "unregisterPackage"
-unregisterPackage ((db_name, pkgs) : _) pkgid = do
- checkConfigAccess db_name
- when (pkgid `notElem` map package pkgs)
- (die (db_name ++ ": package '" ++ showPackageId pkgid
- ++ "' not found\n"))
- savePackageConfig db_name
- maybeRestoreOldConfig db_name $
- writeNewConfig db_name (filter ((/= pkgid) . package) pkgs)
+exposePackage :: PackageIdentifier -> [Flag] -> IO ()
+exposePackage = modifyPackage (\p -> [p{exposed=True}])
--- -----------------------------------------------------------------------------
--- Exposing
+hidePackage :: PackageIdentifier -> [Flag] -> IO ()
+hidePackage = modifyPackage (\p -> [p{exposed=False}])
-exposePackage :: PackageIdentifier -> PackageDBStack -> IO ()
-exposePackage = error "TODO"
+unregisterPackage :: PackageIdentifier -> [Flag] -> IO ()
+unregisterPackage = modifyPackage (\p -> [])
--- -----------------------------------------------------------------------------
--- Hiding
-
-hidePackage :: PackageIdentifier -> PackageDBStack -> IO ()
-hidePackage = error "TODO"
+modifyPackage
+ :: (InstalledPackageInfo -> [InstalledPackageInfo])
+ -> PackageIdentifier
+ -> [Flag]
+ -> IO ()
+modifyPackage fn pkgid flags = do
+ db_stack <- getPkgDatabases True{-modify-} flags
+ let ((db_name, pkgs) : _) = db_stack
+ checkConfigAccess db_name
+ ps <- findPackages [(db_name,pkgs)] pkgid
+ let pids = map package ps
+ savePackageConfig db_name
+ let new_config = concat (map modify pkgs)
+ modify pkg
+ | package pkg `elem` pids = fn pkg
+ | otherwise = [pkg]
+ maybeRestoreOldConfig db_name $
+ writeNewConfig db_name new_config
-- -----------------------------------------------------------------------------
-- Listing packages
-listPackages :: PackageDBStack -> IO ()
-listPackages db_confs = do
- mapM_ show_pkgconf (reverse db_confs)
+listPackages :: [Flag] -> IO ()
+listPackages flags = do
+ db_stack <- getPkgDatabases False flags
+ mapM_ show_pkgconf (reverse db_stack)
where show_pkgconf (db_name,pkg_confs) =
hPutStrLn stdout (render $
text (db_name ++ ":") $$ nest 4 packages
)
where packages = fsep (punctuate comma (map pp_pkg pkg_confs))
- pp_pkg = text . showPackageId . package
-
+ pp_pkg p
+ | exposed p = doc
+ | otherwise = parens doc
+ where doc = text (showPackageId (package p))
-- -----------------------------------------------------------------------------
-- Describe
-describePackage :: PackageDBStack -> PackageIdentifier -> IO ()
-describePackage db_stack pkgid = do
- p <- findPackage db_stack pkgid
- putStrLn (showInstalledPackageInfo p)
-
-findPackage :: PackageDBStack -> PackageIdentifier -> IO InstalledPackageInfo
-findPackage db_stack pkgid
- = case [ p | p <- all_pkgs, pkgid == package p ] of
- [] -> die ("cannot find package " ++ showPackageId pkgid)
- (p:ps) -> return p
+describePackage :: [Flag] -> PackageIdentifier -> IO ()
+describePackage flags pkgid = do
+ db_stack <- getPkgDatabases False flags
+ ps <- findPackages db_stack pkgid
+ mapM_ (putStrLn . showInstalledPackageInfo) ps
+
+-- PackageId is can have globVersion for the version
+findPackages :: PackageDBStack -> PackageIdentifier -> IO [InstalledPackageInfo]
+findPackages db_stack pkgid
+ = case [ p | p <- all_pkgs, pkgid `matches` p ] of
+ [] -> die ("cannot find package " ++ showPackageId pkgid)
+ [p] -> return [p]
+ -- if the version is globVersion, then we are allowed to match
+ -- multiple packages. So eg. "Cabal-*" matches all Cabal packages,
+ -- but "Cabal" matches just one Cabal package - if there are more,
+ -- you get an error.
+ ps | versionTags (pkgVersion pkgid) == versionTags globVersion
+ -> return ps
+ | otherwise
+ -> die ("package " ++ showPackageId pkgid ++
+ " matches multiple packages: " ++
+ concat (intersperse ", " (
+ map (showPackageId.package) ps)))
where
+ pid `matches` pkg
+ = (pkgName pid == pkgName p)
+ && (pkgVersion pid == pkgVersion p || not (realVersion pid))
+ where p = package pkg
+
all_pkgs = concat (map snd db_stack)
-- -----------------------------------------------------------------------------
-- Field
-describeField :: PackageDBStack -> PackageIdentifier -> String -> IO ()
-describeField db_stack pkgid field = do
+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
- p <- findPackage db_stack pkgid
- putStrLn (fn p)
+ ps <- findPackages db_stack pkgid
+ mapM_ (putStrLn.fn) ps
toField :: String -> Maybe (InstalledPackageInfo -> String)
-- backwards compatibility:
toField "include_dirs" = Just $ strList . includeDirs
toField "c_includes" = Just $ strList . includes
toField "package_deps" = Just $ strList . map showPackageId. depends
-toField "extra_cc_opts" = Just $ strList . extraCcOpts
-toField "extra_ld_opts" = Just $ strList . extraLdOpts
+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 . extraFrameworks
+toField "extra_frameworks"= Just $ strList . frameworks
toField s = showInstalledPackageInfoField s
strList :: [String] -> String
checkConfigAccess filename = do
access <- getPermissions filename
when (not (writable access))
- (die (filename ++ ": you don't have permission to modify this file\n"))
+ (die (filename ++ ": you don't have permission to modify this file"))
maybeRestoreOldConfig :: FilePath -> IO () -> IO ()
maybeRestoreOldConfig filename io
-> Bool -- force
-> IO ()
validatePackageConfig pkg db_stack auto_ghci_libs update force = do
+ checkPackageId pkg
checkDuplicates db_stack pkg update
mapM_ (checkDep db_stack force) (depends pkg)
mapM_ (checkDir force) (importDirs pkg)
-- 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
+-- 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 ipi =
+ let str = showPackageId (package ipi) in
+ case [ x | (x,ys) <- readP_to_S parsePackageId str, all isSpace ys ] of
+ [_] -> return ()
+ [] -> die ("invalid package identifier: " ++ str)
+ _ -> die ("ambiguous package identifier: " ++ str)
checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> IO ()
checkDuplicates db_stack pkg update = do
-- Check whether this package id already exists in this DB
--
when (not update && (package pkg `elem` map package pkgs)) $
- die ("package " ++ showPackageId pkgid ++ " is already installed\n")
+ die ("package " ++ showPackageId pkgid ++ " is already installed")
--
-- if we are exposing this new package, then check that
-- there are no other exposed packages with the same name.
when (not update && exposed pkg && not (null exposed_pkgs_with_same_name)) $
die ("trying to register " ++ showPackageId pkgid
++ " as exposed, but "
- ++ showPackageId (package (head exposed_pkgs_with_same_name))
+ ++ showPackageId (package (my_head "when" exposed_pkgs_with_same_name))
++ " is also exposed.")
checkDir :: Bool -> String -> IO ()
checkDir force d
- | "$libdir" `isPrefixOf` d = return ()
- -- can't check this, because we don't know what $libdir is
+ | "$topdir" `isPrefixOf` d = return ()
+ -- can't check this, because we don't know what $topdir is
| otherwise = do
there <- doesDirectoryExist d
when (not there)
- (dieOrForce force (d ++ " doesn't exist or isn't a directory\n"))
+ (dieOrForce force (d ++ " doesn't exist or isn't a directory"))
checkDep :: PackageDBStack -> Bool -> PackageIdentifier -> IO ()
checkDep db_stack force pkgid
| real_version && pkgid `elem` pkgids = return ()
| not real_version && pkgName pkgid `elem` pkg_names = return ()
| otherwise = dieOrForce force ("dependency " ++ showPackageId pkgid
- ++ " doesn't exist\n")
+ ++ " 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 = versionBranch (pkgVersion pkgid) /= []
+ real_version = realVersion pkgid
all_pkgs = concat (map snd db_stack)
pkgids = map package all_pkgs
pkg_names = map pkgName pkgids
+realVersion :: PackageIdentifier -> Bool
+realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
+
checkHSLib :: [String] -> Bool -> Bool -> String -> IO ()
checkHSLib dirs auto_ghci_libs force 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
- [] -> dieOrForce force ("cannot find `" ++ batch_lib_file ++
- "' on library path")
+ [] -> dieOrForce 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
- | "$libdir" `isPrefixOf` d = return True
+ | "$topdir" `isPrefixOf` d = return True
| otherwise = doesFileExist (d ++ '/':lib)
checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
| 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 ++ "'")
+ [] -> hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file)
(_:_) -> return ()
where
ghci_lib_file = lib ++ ".o"
autoBuildGHCiLib dir batch_file ghci_file = do
let ghci_lib_file = dir ++ '/':ghci_file
batch_lib_file = dir ++ '/':batch_file
- hPutStr stderr ("building GHCi library `" ++ ghci_lib_file ++ "'...")
-#ifdef darwin_TARGET_OS
- system("ld -r -x -o " ++ ghci_lib_file ++
- " -all_load " ++ batch_lib_file)
-#else
-#ifdef mingw32_HOST_OS
+ hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
+#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"
- system (maybe "" (++"/gcc-lib/") execDir++"ld -r -x -o " ++ ghci_lib_file ++
- " --whole-archive " ++ batch_lib_file)
+ r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
#else
- system("ld -r -x -o " ++ ghci_lib_file ++
- " --whole-archive " ++ batch_lib_file)
-#endif
+ r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
#endif
+ when (r /= ExitSuccess) $ exitWith r
hPutStrLn stderr (" done.")
-- -----------------------------------------------------------------------------
-- Updating the DB with the new package.
updatePackageDB
- :: [InstalledPackageInfo]
+ :: PackageDBStack
+ -> [InstalledPackageInfo]
-> InstalledPackageInfo
-> IO [InstalledPackageInfo]
-updatePackageDB pkgs new_pkg = do
+updatePackageDB db_stack pkgs new_pkg = do
let
+ -- 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
+
is_exposed = exposed new_pkg
pkgid = package new_pkg
name = pkgName pkgid
| is_exposed && pkgName (package p) == name = p{ exposed = False }
| otherwise = p
--
- return (pkgs'++[new_pkg])
+ return (pkgs'++[updateDeps new_pkg])
+
+-- -----------------------------------------------------------------------------
+-- Searching for modules
+
+#if not_yet
+
+findModules :: [FilePath] -> IO [String]
+findModules paths =
+ mms <- mapM searchDir paths
+ return (concat mms)
+
+searchDir path prefix = do
+ fs <- getDirectoryEntries path `catch` \_ -> return []
+ searchEntries path prefix fs
+
+searchEntries path prefix [] = return []
+searchEntries path prefix (f:fs)
+ | looks_like_a_module = do
+ ms <- searchEntries path prefix fs
+ return (prefix `joinModule` f : ms)
+ | looks_like_a_component = do
+ ms <- searchDir (path `joinFilename` f) (prefix `joinModule` f)
+ ms' <- searchEntries path prefix fs
+ return (ms ++ ms')
+ | otherwise
+ 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
+
+okInModuleName c
+
+#endif
-- -----------------------------------------------------------------------------
-- The old command-line syntax, supported for backwards compatibility
oldRunit :: [OldFlag] -> IO ()
oldRunit clis = do
- let config_flags = [ f | Just f <- map conv clis ]
+ 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
- db_names <- getPkgDatabases config_flags
- db_stack <- mapM readParseDatabase db_names
+
let fields = [ f | OF_Field f <- clis ]
let auto_ghci_libs = any isAuto clis
where isAuto OF_AutoGHCiLibs = True; isAuto _ = False
- input_file = head ([ f | (OF_Input f) <- clis] ++ ["-"])
+ input_file = my_head "inp" ([ f | (OF_Input f) <- clis] ++ ["-"])
force = OF_Force `elem` clis
defines = [ (nm,val) | OF_DefinedName nm val <- clis ]
case [ c | c <- clis, isAction c ] of
- [ OF_List ] -> listPackages db_stack
- [ OF_ListLocal ] -> listPackages db_stack
- [ OF_Add upd ] -> registerPackage input_file defines db_stack
- auto_ghci_libs upd force
- [ OF_Remove p ] -> unregisterPackage db_stack (pkgNameToId p)
- [ OF_Show p ]
- | null fields -> describePackage db_stack (pkgNameToId p)
- | otherwise -> mapM_ (describeField db_stack (pkgNameToId p)) fields
- _ -> do prog <- getProgramName
- die (usageInfo (usageHeader prog) flags)
+ [ OF_List ] -> listPackages new_flags
+ [ OF_ListLocal ] -> listPackages new_flags
+ [ 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 s [] = error s
+my_head s (x:xs) = x
-- ---------------------------------------------------------------------------
+#ifdef OLD_STUFF
+-- ToDo: reinstate
expandEnvVars :: PackageConfig -> [(String, String)]
-> Bool -> IO PackageConfig
expandEnvVars pkg defines force = do
wordsBy p s = case dropWhile p s of
"" -> []
s' -> w : wordsBy p s'' where (w,s'') = break p s'
+#endif
-----------------------------------------------------------------------------
die s = do
hFlush stdout
prog <- getProgramName
- hPutStr stderr (prog ++ ": " ++ s)
+ hPutStrLn stderr (prog ++ ": " ++ s)
exitWith (ExitFailure 1)
dieOrForce :: Bool -> String -> IO ()
dieOrForce force s
| force = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)")
- | otherwise = die (s ++ "\n")
+ | otherwise = die s
------------------------------------------------------------------------------
--- Create a hierarchy of directories
-
-createParents :: FilePath -> IO ()
-createParents dir = do
- let parent = directoryOf dir
- b <- doesDirectoryExist parent
- when (not b) $ do
- createParents parent
- createDirectory parent
-
-----------------------------------------
-- Cut and pasted from ghc/compiler/SysTools
#endif
-- -----------------------------------------------------------------------------
--- Utils from Krasimir's FilePath library, copied here for now
-
-directoryOf :: FilePath -> FilePath
-directoryOf = fst.splitFileName
-
-splitFileName :: FilePath -> (String, String)
-splitFileName p = (reverse (path2++drive), reverse fname)
- where
-#ifdef mingw32_TARGET_OS
- (path,drive) = break (== ':') (reverse p)
-#else
- (path,drive) = (reverse p,"")
-#endif
- (fname,path1) = break isPathSeparator path
- path2 = case path1 of
- [] -> "."
- [_] -> path1 -- don't remove the trailing slash if
- -- there is only one character
- (c:path) | isPathSeparator c -> path
- _ -> path1
+-- FilePath utils
+-- | 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 =
-#ifdef mingw32_TARGET_OS
- ch == '/' || ch == '\\'
-#else
- ch == '/'
-#endif
+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_TARGET_OS
+#ifdef mingw32_HOST_OS
pathSeparator = '\\'
#else
pathSeparator = '/'
projects / ghc-hetmet.git / blobdiff