X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Futils%2Fghc-pkg%2FMain.hs;h=d0f8d3a8f7e96469a19fa8f6c0c9eb7adbaaaffc;hb=e43235be10087016fb2bd7659044fbf68550bf8a;hp=b875ce3babc71c7cdcb1649ed95bc220fc7781b4;hpb=712f906d070021b0fc6cef2727ccf9913d3cc374;p=ghc-hetmet.git diff --git a/ghc/utils/ghc-pkg/Main.hs b/ghc/utils/ghc-pkg/Main.hs index b875ce3..d0f8d3a 100644 --- a/ghc/utils/ghc-pkg/Main.hs +++ b/ghc/utils/ghc-pkg/Main.hs @@ -1,6 +1,6 @@ +{-# OPTIONS -fglasgow-exts #-} + ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.23 2002/05/29 22:11:58 sof Exp $ --- -- Package management tool ----------------------------------------------------------------------------- @@ -8,90 +8,135 @@ module Main where import Package -#ifdef __GLASGOW_HASKELL__ -import qualified Exception -#endif +#if __GLASGOW_HASKELL__ >= 504 +import System.Console.GetOpt +import Text.PrettyPrint +import qualified Control.Exception as Exception +#else import GetOpt import Pretty +import qualified Exception +#endif + 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" #ifdef mingw32_HOST_OS -import Win32DLL +import Foreign + +#if __GLASGOW_HASKELL__ >= 504 +import Foreign.C.String +#else +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 | Input FilePath - | List | Add Bool {- True => replace existing info -} + | List + | ListLocal + | Add Bool {- True => replace existing info -} | 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 isAction (AutoGHCiLibs) = False +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 = tail "\ + \ 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 the currently installed packages", + "list packages in all config files", + Option ['L'] ["list-local-packages"] (NoArg ListLocal) + "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", + Option ['?'] ["help"] (NoArg DumpHelp) + "display this help and exit", + Option ['V'] ["version"] (NoArg DumpVersion) + "output version information and exit" ] + where + toDefined str = + case break (=='=') str of + (nm,[]) -> DefinedName nm [] + (nm,_:val) -> DefinedName nm val -#ifdef mingw32_HOST_OS -subst a b ls = map (\ x -> if x == a then b else x) ls - -unDosifyPath xs = subst '\\' '/' xs -#endif - +runit :: [Flag] -> IO () runit clis = do - conf_file <- + let err_msg = "missing -f option, location of package.conf unknown\n" + conf_filenames <- case [ f | Config f <- clis ] of - fs@(_:_) -> return (last fs) -#ifndef mingw32_HOST_OS - [] -> die "missing -f option, location of package.conf unknown" -#else - [] -> do h <- getModuleHandle Nothing - n <- getModuleFileName h - return (reverse (drop (length "/bin/ghc-pkg.exe") (reverse (unDosifyPath n))) ++ "/package.conf") -#endif + fs@(_:_) -> return (reverse fs) -- NOTE reverse + [] -> do mb_dir <- getExecDir "/bin/ghc-pkg.exe" + case mb_dir of + Nothing -> die err_msg + Just dir -> return [dir ++ "/package.conf"] let toField "import_dirs" = return import_dirs toField "source_dirs" = return source_dirs @@ -104,49 +149,75 @@ runit clis = do toField "extra_ghc_opts" = return extra_ghc_opts toField "extra_cc_opts" = return extra_cc_opts toField "extra_ld_opts" = return extra_ld_opts - toField s = die ("unknown field: `" ++ s ++ "'") + toField "framework_dirs" = return framework_dirs + toField "extra_frameworks"= return extra_frameworks + toField s = die ("unknown field: `" ++ s ++ "'\n") fields <- mapM toField [ f | Field f <- clis ] - s <- readFile conf_file - let packages = read s :: [PackageConfig] - eval_catch packages (\_ -> die "parse error in package config file") + let read_parse_conf filename = do + str <- readFile filename + let packages = parsePackageConfig str + eval_catch packages + (\_ -> die (filename ++ ": parse error in package config file\n")) + + pkg_confs <- mapM read_parse_conf conf_filenames + + let conf_filename = head conf_filenames + -- this is the file we're going to update: the last one specified + -- on the command-line. let auto_ghci_libs = any isAuto clis where isAuto AutoGHCiLibs = True; isAuto _ = False input_file = head ([ f | (Input f) <- clis] ++ ["-"]) force = Force `elem` clis + + defines = [ (nm,val) | DefinedName nm val <- clis ] case [ c | c <- clis, isAction c ] of - [ List ] -> listPackages packages - [ Add upd ] -> addPackage packages conf_file input_file - auto_ghci_libs upd force - [ Remove p ] -> removePackage packages conf_file p - [ Show p ] -> showPackage packages conf_file p fields - _ -> die (usageInfo usageHeader flags) - - -listPackages :: [PackageConfig] -> IO () -listPackages packages = hPutStrLn stdout (listPkgs packages) + [ List ] -> listPackages pkg_confs conf_filenames + [ ListLocal ] -> listPackages [head pkg_confs] [""] + [ Add upd ] -> addPackage pkg_confs defines + conf_filename input_file + auto_ghci_libs upd force + [ Remove p ] -> removePackage pkg_confs conf_filename p + [ Show p ] -> showPackage pkg_confs conf_filename p fields + _ -> do prog <- getProgramName + die (usageInfo (usageHeader prog) flags) + + +listPackages :: [[PackageConfig]] -> [FilePath] -> IO () +listPackages pkg_confs conf_filenames = do + zipWithM_ show_pkgconf pkg_confs conf_filenames + where show_pkgconf pkg_conf filename = + hPutStrLn stdout (render $ + if null filename + then packages + else text (filename ++ ":") $$ nest 4 packages + ) + where packages = fsep (punctuate comma (map (text . name) pkg_conf)) -showPackage :: [PackageConfig] +showPackage :: [[PackageConfig]] -> FilePath -> String -> [PackageConfig -> [String]] -> IO () -showPackage packages pkgconf pkg_name fields = - case [ p | p <- packages, name p == pkg_name ] of - [] -> die ("can't find package `" ++ pkg_name ++ "'") +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 ++ "'\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" - -addPackage :: [PackageConfig] -> FilePath -> FilePath - -> Bool -> Bool -> Bool -> IO () -addPackage packages pkgconf inputFile auto_ghci_libs updatePkg force = do - checkConfigAccess pkgconf + (map (vcat . map text) (map ($ pkg) fields)))) + _ -> die "showPackage: internal error\n" + +addPackage :: [[PackageConfig]] -> [(String, String)] + -> FilePath -> FilePath + -> Bool -> Bool -> Bool -> IO () +addPackage pkg_confs defines + filename inputFile + auto_ghci_libs updatePkg force = do + checkConfigAccess filename s <- case inputFile of "-" -> do @@ -155,65 +226,65 @@ addPackage packages pkgconf inputFile auto_ghci_libs updatePkg force = do f -> do hPutStr stdout ("Reading package info from " ++ show f) readFile f - let new_pkg = read s :: PackageConfig - eval_catch new_pkg (\_ -> die "parse error in package info") + let new_pkg = parseOnePackageConfig s + 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 force + hPutStr stdout "Expanding embedded variables... " + new_exp_pkg <- expandEnvVars new_pkg defines force hPutStrLn stdout "done." - new_details <- validatePackageConfig new_exp_pkg packages + new_details <- validatePackageConfig new_exp_pkg pkg_confs auto_ghci_libs updatePkg force - savePackageConfig pkgconf - maybeRestoreOldConfig pkgconf $ - writeNewConfig pkgconf new_details + savePackageConfig filename + maybeRestoreOldConfig filename $ + writeNewConfig filename new_details -removePackage :: [PackageConfig] -> FilePath -> String -> IO () -removePackage packages pkgconf pkgName = do - checkConfigAccess pkgconf +removePackage :: [[PackageConfig]] -> FilePath -> String -> IO () +removePackage (packages : _) filename pkgName = do + checkConfigAccess filename when (pkgName `notElem` map name packages) - (die ("package `" ++ pkgName ++ "' not installed")) - savePackageConfig pkgconf - maybeRestoreOldConfig pkgconf $ - writeNewConfig pkgconf (filter ((/= pkgName) . name) packages) + (die (filename ++ ": package `" ++ pkgName ++ "' not found\n")) + savePackageConfig filename + maybeRestoreOldConfig filename $ + writeNewConfig filename (filter ((/= pkgName) . name) packages) checkConfigAccess :: FilePath -> IO () -checkConfigAccess pkgconf = do - access <- getPermissions pkgconf +checkConfigAccess filename = do + access <- getPermissions filename when (not (writable access)) - (die "you don't have permission to modify the package configuration file") + (die (filename ++ ": you don't have permission to modify this file\n")) -maybeRestoreOldConfig :: String -> IO () -> IO () -maybeRestoreOldConfig conf_file io +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... " - renameFile (conf_file ++ ".old") conf_file + renameFile (filename ++ ".old") filename hPutStrLn stdout "done." my_throw e ) -writeNewConfig :: String -> [PackageConfig] -> IO () -writeNewConfig conf_file packages = do +writeNewConfig :: FilePath -> [PackageConfig] -> IO () +writeNewConfig filename packages = do hPutStr stdout "Writing new package config file... " - h <- openFile conf_file WriteMode + h <- openFile filename WriteMode hPutStrLn h (dumpPackages packages) hClose h hPutStrLn stdout "done." -savePackageConfig :: String -> IO () -savePackageConfig conf_file = do +savePackageConfig :: FilePath -> IO () +savePackageConfig filename = 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 = conf_file ++ ".old" + let oldFile = filename ++ ".old" doesExist <- doesFileExist oldFile `catch` (\ _ -> return False) when doesExist (removeFile oldFile `catch` (const $ return ())) - catch (renameFile conf_file oldFile) + catch (renameFile filename oldFile) (\ err -> do hPutStrLn stderr (unwords [ "Unable to rename " - , show conf_file + , show filename , " to " , show oldFile ]) @@ -225,15 +296,15 @@ savePackageConfig conf_file = do -- if requested. validatePackageConfig :: PackageConfig - -> [PackageConfig] + -> [[PackageConfig]] -> Bool -> Bool -> Bool -> IO [PackageConfig] -validatePackageConfig pkg pkgs auto_ghci_libs updatePkg force = do +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")) - mapM_ (checkDep pkgs force) (package_deps pkg) + (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) mapM_ (checkDir force) (library_dirs pkg) @@ -247,18 +318,21 @@ validatePackageConfig pkg 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 :: [[PackageConfig]] -> Bool -> String -> IO () checkDep pkgs force n - | n `elem` map name pkgs = return () - | otherwise = dieOrForce force ("dependency `" ++ n ++ "' doesn't exist") + | n `elem` pkg_names = return () + | otherwise = dieOrForce force ("dependency `" ++ n ++ "' doesn't exist\n") + where + pkg_names = concat (map (map name) pkgs) checkHSLib :: [String] -> Bool -> Bool -> String -> IO () checkHSLib dirs auto_ghci_libs force lib = do @@ -269,6 +343,7 @@ 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) @@ -276,7 +351,6 @@ doesLibExistIn lib d 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 -> @@ -284,22 +358,28 @@ checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build = do | otherwise -> hPutStrLn stderr ("warning: can't find GHCi lib `" ++ ghci_lib_file ++ "'") - (dir:_) -> return () + (_:_) -> return () -- 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 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 system("ld -r -x -o " ++ ghci_lib_file ++ " --whole-archive " ++ batch_lib_file) +#endif hPutStrLn stderr (" done.") ----------------------------------------------------------------------------- -expandEnvVars :: PackageConfig -> Bool -> IO PackageConfig -expandEnvVars pkg force = do +expandEnvVars :: PackageConfig -> [(String, String)] -> Bool -> IO PackageConfig +expandEnvVars pkg defines force = do -- permit _all_ strings to contain ${..} environment variable references, -- arguably too flexible. nm <- expandString (name pkg) @@ -314,6 +394,8 @@ expandEnvVars pkg force = do e_g_opts <- expandStrings (extra_ghc_opts pkg) e_c_opts <- expandStrings (extra_cc_opts pkg) e_l_opts <- expandStrings (extra_ld_opts pkg) + f_dirs <- expandStrings (framework_dirs pkg) + e_frames <- expandStrings (extra_frameworks pkg) return (pkg { name = nm , import_dirs = imp_dirs , source_dirs = src_dirs @@ -326,38 +408,77 @@ expandEnvVars pkg force = do , extra_ghc_opts = e_g_opts , extra_cc_opts = e_c_opts , extra_ld_opts = e_l_opts + , framework_dirs = f_dirs + , 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 (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 + _ -> catch (System.getEnv nm) (\ _ -> do dieOrForce force ("Unable to expand variable " ++ 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 @@ -380,3 +501,32 @@ my_catch = Exception.catchAllIO #endif #endif + +----------------------------------------- +-- Cut and pasted from ghc/compiler/SysTools + +#if defined(mingw32_HOST_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 cmd) returns the directory in which the current +-- 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. + +foreign import stdcall "GetModuleFileNameA" unsafe + getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 +#else +getExecDir :: String -> IO (Maybe String) +getExecDir _ = return Nothing +#endif