X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Futils%2Fghc-pkg%2FMain.hs;h=cf3adc95fcaa581e3f2f5b42d29b0a2fbc858c57;hb=c63aaee42e3e95276861121286eefce511cd1343;hp=7e76758f58f43bd14beed6476e37676f726f4b61;hpb=922de7530ddb443c50e3e5d0e01c92d12a84b64f;p=ghc-hetmet.git diff --git a/ghc/utils/ghc-pkg/Main.hs b/ghc/utils/ghc-pkg/Main.hs index 7e76758..cf3adc9 100644 --- a/ghc/utils/ghc-pkg/Main.hs +++ b/ghc/utils/ghc-pkg/Main.hs @@ -1,5 +1,7 @@ +{-# OPTIONS -fglasgow-exts #-} + ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.11 2001/07/11 11:01:59 rrt Exp $ +-- $Id: Main.hs,v 1.29 2002/10/27 10:38:32 mthomas Exp $ -- -- Package management tool ----------------------------------------------------------------------------- @@ -8,32 +10,56 @@ 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 +import System ( getEnv, getArgs, + system, exitWith, + ExitCode(..) + ) import IO +import List ( isPrefixOf ) + +import ParsePkgConfLite + +#include "../../includes/config.h" -#ifdef mingw32_TARGET_OS -import Win32DLL +#ifdef mingw32_HOST_OS +import Foreign.C.String +import Foreign #endif main = do args <- getArgs case getOpt Permute flags args of - (clis,[],[]) -> runit clis + (clis@(_:_),[],[]) -> runit clis (_,_,errors) -> die (concat errors ++ usageInfo usageHeader flags) -data Flag = Config String | List | Add | Remove String | Show String | Field String -isConfigOrField (Config _) = True -isConfigOrField (Field _) = True -isConfigOrField _ = False +data Flag + = Config FilePath + | Input FilePath + | List | Add Bool {- True => replace existing info -} + | Remove String | Show String + | Field String | AutoGHCiLibs | Force + deriving (Eq) + +isAction (Config _) = False +isAction (Field _) = False +isAction (Input _) = False +isAction (AutoGHCiLibs) = False +isAction (Force) = False +isAction _ = True usageHeader = "ghc-pkg [OPTION...]" @@ -42,32 +68,42 @@ flags = [ "Use the specified package config file", Option ['l'] ["list-packages"] (NoArg List) "List the currently installed packages", - Option ['a'] ["add-package"] (NoArg Add) + Option ['a'] ["add-package"] (NoArg (Add False)) "Add a new package", + Option ['u'] ["update-package"] (NoArg (Add True)) + "Update package with new configuration", + Option ['i'] ["input-file"] (ReqArg Input "FILE") + "Read new package info from specified file", Option ['s'] ["show-package"] (ReqArg Show "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)" ] -#ifdef mingw32_TARGET_OS +#ifdef mingw32_HOST_OS +subst a b ls = map (\ x -> if x == a then b else x) ls + unDosifyPath xs = subst '\\' '/' xs #endif runit clis = do -#ifndef mingw32_TARGET_OS + let err_msg = "missing -f option, location of package.conf unknown" conf_file <- case [ f | Config f <- clis ] of - [] -> die "missing -f option, location of package.conf unknown" - [f] -> return f - _ -> die (usageInfo usageHeader flags) + fs@(_:_) -> return (last fs) +#ifndef mingw32_HOST_OS + [] -> die err_msg #else - h <- getModuleHandle Nothing - n <- getModuleFileName h - let conf_file = reverse (tail (dropWhile (not . isSlash) (reverse (unDosifyPath n)))) - ++ "/package.conf" + [] -> do mb_dir <- getExecDir "/bin/ghc-pkg.exe" + case mb_dir of + Nothing -> die err_msg + Just dir -> return (dir ++ "/package.conf") #endif let toField "import_dirs" = return import_dirs @@ -81,61 +117,79 @@ 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 "framework_dirs" = return framework_dirs + toField "extra_frameworks"= return extra_frameworks toField s = die ("unknown field: `" ++ s ++ "'") fields <- mapM toField [ f | Field f <- clis ] s <- readFile conf_file - let details = read s :: [PackageConfig] - eval_catch details (\_ -> die "parse error in package config file") - - case [ c | c <- clis, not (isConfigOrField c) ] of - [ List ] -> listPackages details - [ Add ] -> addPackage details conf_file - [ Remove p ] -> removePackage details conf_file p - [ Show p ] -> showPackage details conf_file p fields + let packages = parsePackageConfig s + eval_catch packages (\_ -> die "parse error in package config file") + + let auto_ghci_libs = any isAuto clis + where isAuto AutoGHCiLibs = True; isAuto _ = False + input_file = head ([ f | (Input f) <- clis] ++ ["-"]) + + force = Force `elem` 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 details = do - hPutStr stdout (listPkgs details) - hPutChar stdout '\n' - -showPackage :: [PackageConfig] -> FilePath -> String - -> [PackageConfig->[String]] -> IO () -showPackage details pkgconf pkg_name fields = - case [ p | p <- details, name p == pkg_name ] of +listPackages packages = hPutStrLn stdout (listPkgs packages) + +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 ++ "'") [pkg] | null fields -> hPutStrLn stdout (render (dumpPkgGuts pkg)) | otherwise -> hPutStrLn stdout (render (vcat - (map (vcat . map text) (map ($pkg) fields)))) + (map (vcat . map text) (map ($ pkg) fields)))) _ -> die "showPackage: internal error" -addPackage :: [PackageConfig] -> FilePath -> IO () -addPackage details pkgconf = do +addPackage :: [PackageConfig] -> FilePath -> FilePath + -> Bool -> Bool -> Bool -> IO () +addPackage packages pkgconf inputFile auto_ghci_libs updatePkg force = do checkConfigAccess pkgconf - hPutStr stdout "Reading package info from stdin... " - s <- getContents - let new_pkg = read s :: PackageConfig + s <- + case inputFile of + "-" -> do + hPutStr stdout "Reading package info from stdin... " + getContents + f -> do + 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") hPutStrLn stdout "done." - if (name new_pkg `elem` map name details) - then die ("package `" ++ name new_pkg ++ "' already installed") - else do + hPutStr stdout "Expanding embedded variables..." + new_exp_pkg <- expandEnvVars new_pkg force + hPutStrLn stdout "done." + new_details <- validatePackageConfig new_exp_pkg packages + auto_ghci_libs updatePkg force savePackageConfig pkgconf maybeRestoreOldConfig pkgconf $ - writeNewConfig pkgconf (details ++ [new_pkg]) + writeNewConfig pkgconf new_details removePackage :: [PackageConfig] -> FilePath -> String -> IO () -removePackage details pkgconf pkg = do +removePackage packages pkgconf pkgName = do checkConfigAccess pkgconf - if (pkg `notElem` map name details) - then die ("package `" ++ pkg ++ "' not installed") - else do + when (pkgName `notElem` map name packages) + (die ("package `" ++ pkgName ++ "' not installed")) savePackageConfig pkgconf maybeRestoreOldConfig pkgconf $ - writeNewConfig pkgconf (filter ((/= pkg) . name) details) + writeNewConfig pkgconf (filter ((/= pkgName) . name) packages) checkConfigAccess :: FilePath -> IO () checkConfigAccess pkgconf = do @@ -155,10 +209,10 @@ maybeRestoreOldConfig conf_file io ) writeNewConfig :: String -> [PackageConfig] -> IO () -writeNewConfig conf_file details = do +writeNewConfig conf_file packages = do hPutStr stdout "Writing new package config file... " h <- openFile conf_file WriteMode - hPutStrLn h (dumpPackages details) + hPutStrLn h (dumpPackages packages) hClose h hPutStrLn stdout "done." @@ -168,13 +222,166 @@ savePackageConfig conf_file = do -- 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... - renameFile conf_file (conf_file ++ ".old") + let oldFile = conf_file ++ ".old" + doesExist <- doesFileExist oldFile `catch` (\ _ -> return False) + when doesExist (removeFile oldFile `catch` (const $ return ())) + catch (renameFile conf_file oldFile) + (\ err -> do + hPutStrLn stderr (unwords [ "Unable to rename " + , show conf_file + , " to " + , show oldFile + ]) + ioError err) hPutStrLn stdout "done." ----------------------------------------------------------------------------- +-- Sanity-check a new package config, and automatically build GHCi libs +-- if requested. + +validatePackageConfig :: PackageConfig + -> [PackageConfig] + -> Bool + -> Bool + -> Bool + -> IO [PackageConfig] +validatePackageConfig pkg 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) + mapM_ (checkDir force) (import_dirs pkg) + mapM_ (checkDir force) (source_dirs pkg) + mapM_ (checkDir force) (library_dirs pkg) + mapM_ (checkDir force) (include_dirs pkg) + mapM_ (checkHSLib (library_dirs pkg) auto_ghci_libs force) (hs_libraries pkg) + -- ToDo: check these somehow? + -- extra_libraries :: [String], + -- c_includes :: [String], + let existing_pkgs + | updatePkg = filter ((/=(name pkg)).name) pkgs + | otherwise = pkgs + return (existing_pkgs ++ [pkg]) + +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")) + +checkDep :: [PackageConfig] -> Bool -> String -> IO () +checkDep pkgs force n + | n `elem` map name pkgs = return () + | otherwise = dieOrForce force ("dependency `" ++ n ++ "' doesn't exist") + +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") + (dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs + +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 () + +-- automatically build the GHCi version of a batch lib, +-- using ld --whole-archive. + +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 + -- permit _all_ strings to contain ${..} environment variable references, + -- arguably too flexible. + nm <- expandString (name pkg) + imp_dirs <- expandStrings (import_dirs pkg) + src_dirs <- expandStrings (source_dirs pkg) + lib_dirs <- expandStrings (library_dirs pkg) + hs_libs <- expandStrings (hs_libraries pkg) + ex_libs <- expandStrings (extra_libraries pkg) + inc_dirs <- expandStrings (include_dirs pkg) + c_incs <- expandStrings (c_includes pkg) + p_deps <- expandStrings (package_deps pkg) + 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 + , library_dirs = lib_dirs + , hs_libraries = hs_libs + , extra_libraries = ex_libs + , include_dirs = inc_dirs + , c_includes = c_incs + , package_deps = p_deps + , 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. + 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 + + lookupEnvVar nm = + catch (System.getEnv nm) + (\ _ -> do dieOrForce force ("Unable to expand variable " ++ + show nm) + return "") + +----------------------------------------------------------------------------- die :: String -> IO a -die s = do { hPutStrLn stderr s; exitWith (ExitFailure 1) } +die s = do { hFlush stdout ; hPutStrLn stderr s; exitWith (ExitFailure 1) } + +dieOrForce :: Bool -> String -> IO () +dieOrForce force s + | force = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)") + | otherwise = die s ----------------------------------------------------------------------------- -- Exceptions @@ -197,3 +404,29 @@ my_catch = Exception.catchAllIO #endif #endif + +----------------------------------------- +-- Cut and pasted from ghc/compiler/SysTools + +#if defined(mingw32_HOST_OS) +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 s = do return Nothing +#endif