import Distribution.ParseUtils ( showError )
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 System.FilePath ( joinFileName )
import Prelude
import Monad
import Directory
import System ( getArgs, getProgName,
- system, exitWith,
- ExitCode(..)
+ exitWith, ExitCode(..)
)
-import IO
-import List ( isPrefixOf, isSuffixOf )
+import System.IO
+import Data.List ( isPrefixOf, isSuffixOf, intersperse )
-#include "../../includes/ghcconfig.h"
-
-#ifdef mingw32_HOST_OS
+#ifdef mingw32_TARGET_OS
import Foreign
#if __GLASGOW_HASKELL__ >= 504
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)
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 [] db_stack auto_ghci_libs False force
["update", filename] ->
- registerPackage filename [] db_stack False True force
+ 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
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
parsePackageInfo str defines force =
case parseInstalledPackageInfo str of
Right ok -> return ok
- Left err -> die (showError err ++ "\n")
+ Left 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
-
-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)
-
--- -----------------------------------------------------------------------------
--- Exposing
+-- Exposing, Hiding, Unregistering are all similar
exposePackage :: PackageIdentifier -> PackageDBStack -> IO ()
-exposePackage = error "TODO"
-
--- -----------------------------------------------------------------------------
--- Hiding
+exposePackage = modifyPackage (\p -> [p{exposed=True}])
hidePackage :: PackageIdentifier -> PackageDBStack -> IO ()
-hidePackage = error "TODO"
+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 new_config
-- -----------------------------------------------------------------------------
-- Listing packages
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
+ = case [ p | p <- all_pkgs, pkgid `matches` p ] of
+ [] -> die ("cannot find package " ++ showPackageId pkgid)
+ [p] -> return p
+ ps -> die ("package " ++ showPackageId pkgid ++
+ " matches multiple packages: " ++
+ concat (intersperse ", " (
+ map (showPackageId.package) ps)))
where
all_pkgs = concat (map snd db_stack)
+matches :: PackageIdentifier -> InstalledPackageInfo -> Bool
+pid `matches` p =
+ pid == package p ||
+ not (realVersion pid) && pkgName pid == pkgName (package p)
+
-- -----------------------------------------------------------------------------
-- Field
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
-- 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.
| 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.
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
| 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 ++ "'...")
+ 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)
+ 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.")
[ 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
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
-#if defined(mingw32_HOST_OS)
+#if defined(mingw32_TARGET_OS)
subst a b ls = map (\ x -> if x == a then b else x) ls
unDosifyPath xs = subst '\\' '/' xs
getExecDir :: String -> IO (Maybe String)
getExecDir _ = return Nothing
#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
-
-joinFileName :: String -> String -> FilePath
-joinFileName "" fname = fname
-joinFileName "." fname = fname
-joinFileName dir fname
- | isPathSeparator (last dir) = dir++fname
- | otherwise = dir++pathSeparator:fname
-
-isPathSeparator :: Char -> Bool
-isPathSeparator ch =
-#ifdef mingw32_TARGET_OS
- ch == '/' || ch == '\\'
-#else
- ch == '/'
-#endif
-
-pathSeparator :: Char
-#ifdef mingw32_TARGET_OS
-pathSeparator = '\\'
-#else
-pathSeparator = '/'
-#endif
projects / ghc-hetmet.git / blobdiff