X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Futils%2Fghc-pkg%2FMain.hs;h=954d1f62e38871f03099e03cfdeaedaf238a3a1a;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=dadcd4443a31e4239bfe4be71798622d65ffb3f8;hpb=39ea6a04bf80f0df9385d0f872cc492dde0f28b6;p=ghc-hetmet.git diff --git a/ghc/utils/ghc-pkg/Main.hs b/ghc/utils/ghc-pkg/Main.hs index dadcd44..954d1f6 100644 --- a/ghc/utils/ghc-pkg/Main.hs +++ b/ghc/utils/ghc-pkg/Main.hs @@ -1,8 +1,6 @@ {-# OPTIONS -fglasgow-exts #-} ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.36 2003/09/08 17:55:40 sof Exp $ --- -- Package management tool ----------------------------------------------------------------------------- @@ -22,16 +20,16 @@ import qualified Exception import Monad import Directory -import System ( getEnv, getArgs, +import System ( getEnv, getArgs, getProgName, system, exitWith, ExitCode(..) ) import IO -import List ( isPrefixOf ) +import List ( isPrefixOf, isSuffixOf ) import ParsePkgConfLite -#include "../../includes/config.h" +#include "../../includes/ghcconfig.h" #ifdef mingw32_HOST_OS import Foreign @@ -43,13 +41,21 @@ import CString #endif #endif +main :: IO () main = do args <- getArgs case getOpt Permute flags args of - (clis@(_:_),[],[]) -> runit clis - (_,_,errors) -> die (concat errors ++ - usageInfo usageHeader flags) + (cli,_,[]) | DumpHelp `elem` cli -> do + prog <- getProgramName + bye (usageInfo (usageHeader prog) flags) + (cli,_,[]) | DumpVersion `elem` cli -> + bye copyright + (cli@(_:_),[],[]) -> + runit cli + (_,_,errors) -> do + prog <- getProgramName + die (concat errors ++ usageInfo (usageHeader prog) flags) data Flag = Config FilePath @@ -60,8 +66,11 @@ data Flag | Remove String | Show String | Field String | AutoGHCiLibs | Force | DefinedName String String + | DumpHelp + | DumpVersion deriving (Eq) +isAction :: Flag -> Bool isAction (Config _) = False isAction (Field _) = False isAction (Input _) = False @@ -70,33 +79,46 @@ isAction (Force) = False isAction DefinedName{} = False isAction _ = True -usageHeader = "ghc-pkg [OPTION...]" +copyright :: String +copyright = "GHC package manager version " ++ version ++ "\n" +-- hackery to convice cpp to splice GHC_PKG_VERSION into a string +version :: String +version = GHC_PKG_VERSION + +usageHeader :: String -> String +usageHeader prog = "Usage: " ++ prog ++ " [OPTION...]\n" + +flags :: [OptDescr Flag] flags = [ Option ['f'] ["config-file"] (ReqArg Config "FILE") - "Use the specified package config file", + "use the specified package config file", Option ['l'] ["list-packages"] (NoArg List) - "List packages in all config files", + "list packages in all config files", Option ['L'] ["list-local-packages"] (NoArg ListLocal) - "List packages in the specified config file", + "list packages in the specified config file", Option ['a'] ["add-package"] (NoArg (Add False)) - "Add a new package", + "add a new package", Option ['u'] ["update-package"] (NoArg (Add True)) - "Update package with new configuration", + "update package with new configuration", Option ['i'] ["input-file"] (ReqArg Input "FILE") - "Read new package info from specified file", + "read new package info from specified file", Option ['s'] ["show-package"] (ReqArg Show "NAME") - "Show the configuration for package NAME", + "show the configuration for package NAME", Option [] ["field"] (ReqArg Field "FIELD") "(with --show-package) Show field FIELD only", Option [] ["force"] (NoArg Force) "ignore missing directories/libraries", Option ['r'] ["remove-package"] (ReqArg Remove "NAME") - "Remove an installed package", + "remove an installed package", Option ['g'] ["auto-ghci-libs"] (NoArg AutoGHCiLibs) - "Automatically build libs for GHCi (with -a)", + "automatically build libs for GHCi (with -a)", Option ['D'] ["define-name"] (ReqArg toDefined "NAME=VALUE") - "Define NAME as VALUE" + "define NAME as VALUE", + Option ['?'] ["help"] (NoArg DumpHelp) + "display this help and exit", + Option ['V'] ["version"] (NoArg DumpVersion) + "output version information and exit" ] where toDefined str = @@ -104,8 +126,9 @@ flags = [ (nm,[]) -> DefinedName nm [] (nm,_:val) -> DefinedName nm val +runit :: [Flag] -> IO () runit clis = do - let err_msg = "missing -f option, location of package.conf unknown" + let err_msg = "missing -f option, location of package.conf unknown\n" conf_filenames <- case [ f | Config f <- clis ] of fs@(_:_) -> return (reverse fs) -- NOTE reverse @@ -127,7 +150,7 @@ runit clis = do toField "extra_ld_opts" = return extra_ld_opts toField "framework_dirs" = return framework_dirs toField "extra_frameworks"= return extra_frameworks - toField s = die ("unknown field: `" ++ s ++ "'") + toField s = die ("unknown field: `" ++ s ++ "'\n") fields <- mapM toField [ f | Field f <- clis ] @@ -135,7 +158,7 @@ runit clis = do str <- readFile filename let packages = parsePackageConfig str eval_catch packages - (\_ -> die (filename ++ ": parse error in package config file")) + (\_ -> die (filename ++ ": parse error in package config file\n")) pkg_confs <- mapM read_parse_conf conf_filenames @@ -159,7 +182,8 @@ runit clis = do auto_ghci_libs upd force [ Remove p ] -> removePackage pkg_confs conf_filename p [ Show p ] -> showPackage pkg_confs conf_filename p fields - _ -> die (usageInfo usageHeader flags) + _ -> do prog <- getProgramName + die (usageInfo (usageHeader prog) flags) listPackages :: [[PackageConfig]] -> [FilePath] -> IO () @@ -178,13 +202,13 @@ showPackage :: [[PackageConfig]] -> String -> [PackageConfig -> [String]] -> IO () -showPackage pkg_confs filename pkg_name fields = +showPackage pkg_confs _ pkg_name fields = case [ p | pkgs <- pkg_confs, p <- pkgs, name p == pkg_name ] of - [] -> die ("can't find package `" ++ pkg_name ++ "'") + [] -> die ("can't find package `" ++ pkg_name ++ "'\n") [pkg] | null fields -> hPutStrLn stdout (render (dumpPkgGuts pkg)) | otherwise -> hPutStrLn stdout (render (vcat (map (vcat . map text) (map ($ pkg) fields)))) - _ -> die "showPackage: internal error" + _ -> die "showPackage: internal error\n" addPackage :: [[PackageConfig]] -> [(String, String)] -> FilePath -> FilePath @@ -202,7 +226,7 @@ addPackage pkg_confs defines hPutStr stdout ("Reading package info from " ++ show f) readFile f let new_pkg = parseOnePackageConfig s - eval_catch new_pkg (\_ -> die "parse error in package info") + eval_catch new_pkg (\_ -> die "parse error in package info\n") hPutStrLn stdout "done." hPutStr stdout "Expanding embedded variables... " new_exp_pkg <- expandEnvVars new_pkg defines force @@ -217,7 +241,7 @@ removePackage :: [[PackageConfig]] -> FilePath -> String -> IO () removePackage (packages : _) filename pkgName = do checkConfigAccess filename when (pkgName `notElem` map name packages) - (die (filename ++ ": package `" ++ pkgName ++ "' not found")) + (die (filename ++ ": package `" ++ pkgName ++ "' not found\n")) savePackageConfig filename maybeRestoreOldConfig filename $ writeNewConfig filename (filter ((/= pkgName) . name) packages) @@ -226,14 +250,14 @@ checkConfigAccess :: FilePath -> IO () checkConfigAccess filename = do access <- getPermissions filename when (not (writable access)) - (die (filename ++ ": you don't have permission to modify this file")) + (die (filename ++ ": you don't have permission to modify this file\n")) maybeRestoreOldConfig :: FilePath -> IO () -> IO () maybeRestoreOldConfig filename io = my_catch io (\e -> do - hPutStr stdout "\nWARNING: an error was encountered while the new \n\ - \configuration was being written. Attempting to \n\ - \restore the old configuration... " + hPutStr stdout ("\nWARNING: an error was encountered while the new \n"++ + "configuration was being written. Attempting to \n"++ + "restore the old configuration... ") renameFile (filename ++ ".old") filename hPutStrLn stdout "done." my_throw e @@ -278,7 +302,7 @@ validatePackageConfig :: PackageConfig -> IO [PackageConfig] validatePackageConfig pkg pkg_confs@(pkgs:_) auto_ghci_libs updatePkg force = do when (not updatePkg && (name pkg `elem` map name pkgs)) - (die ("package `" ++ name pkg ++ "' is already installed")) + (die ("package `" ++ name pkg ++ "' is already installed\n")) mapM_ (checkDep pkg_confs force) (package_deps pkg) mapM_ (checkDir force) (import_dirs pkg) mapM_ (checkDir force) (source_dirs pkg) @@ -293,18 +317,19 @@ validatePackageConfig pkg pkg_confs@(pkgs:_) auto_ghci_libs updatePkg force = do | otherwise = pkgs return (existing_pkgs ++ [pkg]) +checkDir :: Bool -> String -> IO () checkDir force d | "$libdir" `isPrefixOf` d = return () -- can't check this, because we don't know what $libdir is | otherwise = do there <- doesDirectoryExist d when (not there) - (dieOrForce force ("`" ++ d ++ "' doesn't exist or isn't a directory")) + (dieOrForce force ("`" ++ d ++ "' doesn't exist or isn't a directory\n")) checkDep :: [[PackageConfig]] -> Bool -> String -> IO () checkDep pkgs force n | n `elem` pkg_names = return () - | otherwise = dieOrForce force ("dependency `" ++ n ++ "' doesn't exist") + | otherwise = dieOrForce force ("dependency `" ++ n ++ "' doesn't exist\n") where pkg_names = concat (map (map name) pkgs) @@ -317,26 +342,26 @@ checkHSLib dirs auto_ghci_libs force lib = do "' 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 | otherwise = doesFileExist (d ++ '/':lib) checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO () -checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build = do - let ghci_lib_file = lib ++ ".o" - ghci_lib_path = batch_lib_dir ++ '/':ghci_lib_file - bs <- mapM (\d -> doesFileExist (d ++ '/':ghci_lib_file)) dirs - case [ dir | (exists,dir) <- zip bs dirs, exists ] of - [] | auto_build -> - autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file - | otherwise -> - hPutStrLn stderr ("warning: can't find GHCi lib `" - ++ ghci_lib_file ++ "'") - (dir:_) -> return () +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" -- automatically build the GHCi version of a batch lib, -- using ld --whole-archive. +autoBuildGHCiLib :: String -> String -> String -> IO () autoBuildGHCiLib dir batch_file ghci_file = do let ghci_lib_file = dir ++ '/':ghci_file batch_lib_file = dir ++ '/':batch_file @@ -345,9 +370,15 @@ autoBuildGHCiLib dir batch_file ghci_file = do system("ld -r -x -o " ++ ghci_lib_file ++ " -all_load " ++ batch_lib_file) #else +#ifdef 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) +#else system("ld -r -x -o " ++ ghci_lib_file ++ " --whole-archive " ++ batch_lib_file) #endif +#endif hPutStrLn stderr (" done.") ----------------------------------------------------------------------------- @@ -385,21 +416,27 @@ expandEnvVars pkg defines force = do , extra_frameworks= e_frames }) where - expandStrings = mapM expandString - - -- Just for fun, keep this in the IO monad. + expandStrings :: [String] -> IO [String] + expandStrings = liftM concat . mapM expandSpecial + + -- Permit substitutions for list-valued variables (but only when + -- they occur alone), e.g., package_deps["${deps}"] where env var + -- (say) 'deps' is "base,haskell98,network" + expandSpecial :: String -> IO [String] + expandSpecial str = + let expand f = liftM f $ expandString str + in case splitString str of + [Var _] -> expand (wordsBy (== ',')) + _ -> expand (\x -> [x]) + expandString :: String -> IO String - expandString str = - case break (=='$') str of - (xs, _:'{':rs) -> - case span (/='}') rs of - (nm,_:remainder) -> do - nm' <- lookupEnvVar nm - str' <- expandString remainder - return (xs ++ nm' ++ str') - _ -> return str -- no closing '}' - _ -> return str + expandString = liftM concat . mapM expandElem . splitString + + expandElem :: Elem -> IO String + expandElem (String s) = return s + expandElem (Var v) = lookupEnvVar v + lookupEnvVar :: String -> IO String lookupEnvVar nm = case lookup nm defines of Just x | not (null x) -> return x @@ -409,15 +446,43 @@ expandEnvVars pkg defines force = do show nm) return "") +data Elem = String String | Var String + +splitString :: String -> [Elem] +splitString "" = [] +splitString str = + case break (== '$') str of + (pre, _:'{':xs) -> + case span (/= '}') xs of + (var, _:suf) -> + (if null pre then id else (String pre :)) (Var var : splitString suf) + _ -> [String str] -- no closing brace + _ -> [String str] -- no dollar/opening brace combo + +-- wordsBy isSpace == words +wordsBy :: (Char -> Bool) -> String -> [String] +wordsBy p s = case dropWhile p s of + "" -> [] + s' -> w : wordsBy p s'' where (w,s'') = break p s' + ----------------------------------------------------------------------------- +getProgramName :: IO String +getProgramName = liftM (`withoutSuffix` ".bin") getProgName + where str `withoutSuffix` suff + | suff `isSuffixOf` str = take (length str - length suff) str + | otherwise = str + +bye :: String -> IO a +bye s = putStr s >> exitWith ExitSuccess + die :: String -> IO a -die s = do { hFlush stdout ; hPutStrLn stderr s; exitWith (ExitFailure 1) } +die s = do { hFlush stdout ; hPutStr stderr s; exitWith (ExitFailure 1) } dieOrForce :: Bool -> String -> IO () dieOrForce force s | force = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)") - | otherwise = die s + | otherwise = die (s ++ "\n") ----------------------------------------------------------------------------- -- Exceptions @@ -467,5 +532,5 @@ foreign import stdcall "GetModuleFileNameA" unsafe getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 #else getExecDir :: String -> IO (Maybe String) -getExecDir s = do return Nothing +getExecDir _ = return Nothing #endif