-- 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 )
+import Distribution.ParseUtils ( showError, ParseResult(..) )
import Distribution.Package
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
-#if __GLASGOW_HASKELL__ < 603
-#include "config.h"
-#endif
+#include "../../includes/ghcconfig.h"
#if __GLASGOW_HASKELL__ >= 504
import System.Console.GetOpt
import Monad
import Directory
import System ( getArgs, getProgName,
- system, exitWith,
- ExitCode(..)
+ exitWith, ExitCode(..)
)
import System.IO
import Data.List ( isPrefixOf, isSuffixOf, intersperse )
-#include "../../includes/ghcconfig.h"
-
#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
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" ++
+ " $p list\n" ++
" List all registered packages, both global and user (unless either\n" ++
" --global or --user is specified), and both hidden and exposed.\n" ++
"\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 _ [] = []
registerPackage filename [] db_stack auto_ghci_libs True force
["unregister", pkgid_str] -> do
pkgid <- readPkgId pkgid_str
- unregisterPackage db_stack pkgid
+ unregisterPackage pkgid db_stack
["expose", pkgid_str] -> do
pkgid <- readPkgId pkgid_str
exposePackage pkgid db_stack
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
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
-> IO ()
registerPackage input defines db_stack auto_ghci_libs update force = do
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
-> IO InstalledPackageInfo
parsePackageInfo str defines force =
case parseInstalledPackageInfo str of
- Right ok -> return ok
- Left err -> die (showError err)
+ ParseOk ok -> return ok
+ ParseFailed err -> die (showError err)
-- Used for converting versionless package names to new
-- PackageIdentifiers. "Version [] []" is special: it means "no
pkgNameToId name = PackageIdentifier name (Version [] [])
-- -----------------------------------------------------------------------------
--- Unregistering
+-- Exposing, Hiding, Unregistering are all similar
-unregisterPackage :: PackageDBStack -> PackageIdentifier -> IO ()
-unregisterPackage [] _ = error "unregisterPackage"
-unregisterPackage ((db_name, pkgs) : _) pkgid = do
+exposePackage :: PackageIdentifier -> PackageDBStack -> IO ()
+exposePackage = modifyPackage (\p -> [p{exposed=True}])
+
+hidePackage :: PackageIdentifier -> PackageDBStack -> IO ()
+hidePackage = modifyPackage (\p -> [p{exposed=False}])
+
+unregisterPackage :: PackageIdentifier -> PackageDBStack -> IO ()
+unregisterPackage = modifyPackage (\p -> [])
+
+modifyPackage
+ :: (InstalledPackageInfo -> [InstalledPackageInfo])
+ -> PackageIdentifier
+ -> PackageDBStack
+ -> IO ()
+modifyPackage _ _ [] = error "modifyPackage"
+modifyPackage fn pkgid ((db_name, pkgs) : _) = do
checkConfigAccess db_name
p <- findPackage [(db_name,pkgs)] pkgid
let pid = package p
savePackageConfig db_name
+ let new_config = concat (map modify pkgs)
+ modify pkg
+ | package pkg == pid = fn pkg
+ | otherwise = [pkg]
maybeRestoreOldConfig db_name $
- writeNewConfig db_name (filter ((/= pid) . package) pkgs)
-
--- -----------------------------------------------------------------------------
--- Exposing
-
-exposePackage :: PackageIdentifier -> PackageDBStack -> IO ()
-exposePackage = error "TODO"
-
--- -----------------------------------------------------------------------------
--- Hiding
-
-hidePackage :: PackageIdentifier -> PackageDBStack -> IO ()
-hidePackage = error "TODO"
+ writeNewConfig db_name new_config
-- -----------------------------------------------------------------------------
-- Listing packages
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
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)
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 ++ "'...")
-#if defined(darwin_TARGET_OS)
- r <- system("ld -r -x -o " ++ ghci_lib_file ++
- " -all_load " ++ batch_lib_file)
+ 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"
- r <- 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
- r <- system("ld -r -x -o " ++ ghci_lib_file ++
- " --whole-archive " ++ batch_lib_file)
+ r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
#endif
when (r /= ExitSuccess) $ exitWith r
hPutStrLn stderr (" done.")
-> IO [InstalledPackageInfo]
updatePackageDB db_stack pkgs new_pkg = do
let
- -- we update dependencies without version numbers to
- -- match the actual versions of the relevant packages instaled.
+ -- 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 pkgid
- | realVersion pkgid = pkgid
- | otherwise = lookupDep (pkgName pkgid)
-
- lookupDep name
- = head [ pid | p <- concat (map snd db_stack),
+ 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 ]
+ 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
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
[ 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_Remove p ] -> unregisterPackage (pkgNameToId p) db_stack
[ 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)
+my_head s [] = error s
+my_head s (x:xs) = x
+
-- ---------------------------------------------------------------------------
#ifdef OLD_STUFF
| 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 = '/'