X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Futils%2Fghc-pkg%2FMain.hs;h=954d1f62e38871f03099e03cfdeaedaf238a3a1a;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=324e7d9fe5c121690b35727c88777d14785a7475;hpb=a61ed6aedac50b8bf4972261473236dc6097a8fc;p=ghc-hetmet.git diff --git a/ghc/utils/ghc-pkg/Main.hs b/ghc/utils/ghc-pkg/Main.hs index 324e7d9..954d1f6 100644 --- a/ghc/utils/ghc-pkg/Main.hs +++ b/ghc/utils/ghc-pkg/Main.hs @@ -29,7 +29,7 @@ import List ( isPrefixOf, isSuffixOf ) import ParsePkgConfLite -#include "../../includes/config.h" +#include "../../includes/ghcconfig.h" #ifdef mingw32_HOST_OS import Foreign @@ -41,6 +41,7 @@ import CString #endif #endif +main :: IO () main = do args <- getArgs @@ -69,6 +70,7 @@ data Flag | DumpVersion deriving (Eq) +isAction :: Flag -> Bool isAction (Config _) = False isAction (Field _) = False isAction (Input _) = False @@ -82,12 +84,12 @@ 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" +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", @@ -124,6 +126,7 @@ 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\n" conf_filenames <- @@ -199,7 +202,7 @@ 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 ++ "'\n") [pkg] | null fields -> hPutStrLn stdout (render (dumpPkgGuts pkg)) @@ -252,9 +255,9 @@ checkConfigAccess filename = do 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 @@ -314,6 +317,7 @@ 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 @@ -338,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 @@ -366,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.") ----------------------------------------------------------------------------- @@ -406,27 +416,27 @@ expandEnvVars pkg defines force = do , extra_frameworks= e_frames }) where - expandStrings vs = do - xs <- mapM expandString vs - -- Flatten the elements of the expanded list; this is - -- to permit substitutions for list-valued variables. e.g., - -- package_deps["${deps}"] where env var (say) 'deps' - -- is "base,haskell98,network" - return (concat (map (wordsBy (==',')) xs)) - - -- 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 @@ -436,6 +446,20 @@ 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 "" -> [] @@ -508,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