X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Futils%2Fghc-pkg%2FMain.hs;h=fb3ef07c3ffadfda6a767fe50e2a409089a0f8b9;hb=50bc39808cd5b483a048a4d387f937963bd0e00f;hp=42753db6c64c556305b8f63baa6b7a797df1c30d;hpb=576543c90ce56ba2bf648ebe8d356d79de79883c;p=ghc-hetmet.git diff --git a/ghc/utils/ghc-pkg/Main.hs b/ghc/utils/ghc-pkg/Main.hs index 42753db..fb3ef07 100644 --- a/ghc/utils/ghc-pkg/Main.hs +++ b/ghc/utils/ghc-pkg/Main.hs @@ -32,20 +32,27 @@ import Prelude import System.Console.GetOpt import Text.PrettyPrint import qualified Control.Exception as Exception +import Data.Maybe #else import GetOpt import Pretty import qualified Exception +import Maybe #endif import Data.Char ( isSpace ) import Monad import Directory -import System ( getArgs, getProgName, +import System ( getArgs, getProgName, getEnv, exitWith, ExitCode(..) ) import System.IO -import Data.List ( isPrefixOf, isSuffixOf, intersperse ) +#if __GLASGOW_HASKELL__ >= 600 +import System.IO.Error (try) +#else +import System.IO (try) +#endif +import Data.List ( isPrefixOf, isSuffixOf, intersperse, groupBy, sortBy ) #ifdef mingw32_HOST_OS import Foreign @@ -98,6 +105,8 @@ data Flag | FlagGlobalConfig FilePath | FlagForce | FlagAutoGHCiLibs + | FlagDefinedName String String + | FlagSimpleOutput deriving Eq flags :: [OptDescr Flag] @@ -116,9 +125,18 @@ flags = [ "automatically build libs for GHCi (with register)", Option ['?'] ["help"] (NoArg FlagHelp) "display this help and exit", - Option ['V'] ["version"] (NoArg FlagVersion) - "output version information and exit" + Option ['D'] ["define-name"] (ReqArg toDefined "NAME=VALUE") + "define NAME as VALUE", + Option ['V'] ["version"] (NoArg FlagVersion) + "output version information and exit", + Option [] ["simple-output"] (NoArg FlagSimpleOutput) + "print output in easy-to-parse format when running command 'list'" ] + where + toDefined str = + case break (=='=') str of + (nm,[]) -> FlagDefinedName nm [] + (nm,_:val) -> FlagDefinedName nm val ourCopyright :: String ourCopyright = "GHC package manager version " ++ version ++ "\n" @@ -144,9 +162,13 @@ usageHeader prog = substProg prog $ " $p hide {pkg-id}\n" ++ " Hide the specified package.\n" ++ "\n" ++ - " $p list\n" ++ - " List registered packages in the global database, and also the" ++ - " user database if --user is given.\n" ++ + " $p list [pkg]\n" ++ + " List registered packages in the global database, and also the\n" ++ + " user database if --user is given. If a package name is given\n" ++ + " all the registered versions will be listed in ascending order.\n" ++ + "\n" ++ + " $p latest pkg\n" ++ + " Prints the highest registered version of a package.\n" ++ "\n" ++ " $p describe {pkg-id}\n" ++ " Give the registered description for the specified package. The\n" ++ @@ -173,13 +195,14 @@ runit cli nonopts = do let force = FlagForce `elem` cli auto_ghci_libs = FlagAutoGHCiLibs `elem` cli + defines = [ (nm,val) | FlagDefinedName nm val <- cli ] -- -- first, parse the command case nonopts of ["register", filename] -> - registerPackage filename [] cli auto_ghci_libs False force + registerPackage filename defines cli auto_ghci_libs False force ["update", filename] -> - registerPackage filename [] cli auto_ghci_libs True force + registerPackage filename defines cli auto_ghci_libs True force ["unregister", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str unregisterPackage pkgid cli @@ -190,7 +213,13 @@ runit cli nonopts = do pkgid <- readGlobPkgId pkgid_str hidePackage pkgid cli ["list"] -> do - listPackages cli + listPackages cli Nothing + ["list", pkgid_str] -> do + pkgid <- readGlobPkgId pkgid_str + listPackages cli (Just pkgid) + ["latest", pkgid_str] -> do + pkgid <- readGlobPkgId pkgid_str + latestPackage cli pkgid ["describe", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str describePackage cli pkgid @@ -261,6 +290,16 @@ getPkgDatabases modify flags = do Just dir -> return (dir `joinFileName` "package.conf") fs -> return (last fs) + let global_conf_dir = global_conf ++ ".d" + global_conf_dir_exists <- doesDirectoryExist global_conf_dir + global_confs <- + if global_conf_dir_exists + then do files <- getDirectoryContents global_conf_dir + return [ global_conf_dir ++ '/' : file + | file <- files + , isSuffixOf ".conf" file] + else return [] + -- get the location of the user package database, and create it if necessary appdir <- getAppUserDataDirectory "ghc" @@ -270,34 +309,57 @@ getPkgDatabases modify flags = do user_conf = archdir `joinFileName` "package.conf" user_exists <- doesFileExist user_conf - let - -- The semantics here are slightly strange. If we are - -- *modifying* the database, then the default is to modify - -- the global database by default, unless you say --user. - -- If we are not modifying (eg. list, describe etc.) then - -- the user database is included by default. - databases - | modify = foldl addDB [global_conf] flags - | not user_exists = foldl addDB [global_conf] flags - | otherwise = foldl addDB [user_conf,global_conf] flags - - -- implement the following rules: - -- --user means overlap with the user database - -- --global means reset to just the global database - -- -f means overlap with - addDB dbs FlagUser = if user_conf `elem` dbs - then dbs - else user_conf : dbs - addDB dbs FlagGlobal = [global_conf] - addDB dbs (FlagConfig f) = f : dbs - addDB dbs _ = dbs - - when (not user_exists && user_conf `elem` databases) $ do + -- If the user database doesn't exist, and this command isn't a + -- "modify" command, then we won't attempt to create or use it. + let sys_databases + | modify || user_exists = user_conf : global_confs ++ [global_conf] + | otherwise = global_confs ++ [global_conf] + + e_pkg_path <- try (getEnv "GHC_PACKAGE_PATH") + let env_stack = + case e_pkg_path of + Left _ -> sys_databases + Right path + | last cs == "" -> init cs ++ sys_databases + | otherwise -> cs + where cs = parseSearchPath path + + -- The "global" database is always the one at the bottom of the stack. + -- This is the database we modify by default. + virt_global_conf = last env_stack + + -- -f flags on the command line add to the database stack, unless any + -- of them are present in the stack already. + let flag_stack = filter (`notElem` env_stack) + [ f | FlagConfig f <- reverse flags ] ++ env_stack + + -- Now we have the full stack of databases. Next, if the current + -- command is a "modify" type command, then we truncate the stack + -- so that the topmost element is the database being modified. + final_stack <- + if not modify + then return flag_stack + else let + go (FlagUser : fs) = modifying user_conf + go (FlagGlobal : fs) = modifying virt_global_conf + go (FlagConfig f : fs) = modifying f + go (_ : fs) = go fs + go [] = modifying virt_global_conf + + modifying f + | f `elem` flag_stack = return (dropWhile (/= f) flag_stack) + | otherwise = die ("requesting modification of database:\n\t" ++ f ++ "\n\twhich is not in the database stack.") + in + go flags + + -- we create the user database iff (a) we're modifying, and (b) the + -- user asked to use it by giving the --user flag. + when (not user_exists && user_conf `elem` final_stack) $ do putStrLn ("Creating user package database in " ++ user_conf) createDirectoryIfMissing True archdir writeFile user_conf emptyPackageConfig - db_stack <- mapM readParseDatabase databases + db_stack <- mapM readParseDatabase final_stack return db_stack readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB) @@ -316,7 +378,7 @@ emptyPackageConfig = "[]" -- Registering registerPackage :: FilePath - -> [(String,String)] -- defines, ToDo: maybe remove? + -> [(String,String)] -- defines -> [Flag] -> Bool -- auto_ghci_libs -> Bool -- update @@ -333,17 +395,20 @@ registerPackage input defines flags auto_ghci_libs update force = do s <- case input of "-" -> do - putStr "Reading package info from stdin... " + putStr "Reading package info from stdin ... " getContents f -> do - putStr ("Reading package info from " ++ show f ++ " ") + putStr ("Reading package info from " ++ show f ++ " ... ") readFile f - pkg <- parsePackageInfo s defines force + expanded <- expandEnvVars s defines force + + pkg0 <- parsePackageInfo expanded defines force putStrLn "done." - validatePackageConfig pkg db_stack auto_ghci_libs update force - new_details <- updatePackageDB db_stack (snd db_to_operate_on) pkg + let pkg = resolveDeps db_stack pkg0 + overlaps <- validatePackageConfig pkg db_stack auto_ghci_libs update force + new_details <- updatePackageDB db_stack overlaps (snd db_to_operate_on) pkg savePackageConfig db_filename maybeRestoreOldConfig db_filename $ writeNewConfig db_filename new_details @@ -355,7 +420,7 @@ parsePackageInfo -> IO InstalledPackageInfo parsePackageInfo str defines force = case parseInstalledPackageInfo str of - ParseOk ok -> return ok + ParseOk _warns ok -> return ok ParseFailed err -> die (showError err) -- ----------------------------------------------------------------------------- @@ -392,11 +457,31 @@ modifyPackage fn pkgid flags = do -- ----------------------------------------------------------------------------- -- Listing packages -listPackages :: [Flag] -> IO () -listPackages flags = do +listPackages :: [Flag] -> Maybe PackageIdentifier -> IO () +listPackages flags mPackageName = do + let simple_output = FlagSimpleOutput `elem` flags db_stack <- getPkgDatabases False flags - mapM_ show_pkgconf (reverse db_stack) - where show_pkgconf (db_name,pkg_confs) = + let db_stack_filtered -- if a package is given, filter out all other packages + | Just this <- mPackageName = + map (\(conf,pkgs) -> (conf, filter (this `matchesPkg`) pkgs)) + db_stack + | otherwise = db_stack + + db_stack_sorted + = [ (db, sort_pkgs pkgs) | (db,pkgs) <- db_stack_filtered ] + where sort_pkgs = sortBy cmpPkgIds + cmpPkgIds pkg1 pkg2 = + case pkgName p1 `compare` pkgName p2 of + LT -> LT + GT -> GT + EQ -> pkgVersion p1 `compare` pkgVersion p2 + where (p1,p2) = (package pkg1, package pkg2) + + show_func = if simple_output then show_easy else mapM_ show_regular + + show_func (reverse db_stack_sorted) + + where show_regular (db_name,pkg_confs) = hPutStrLn stdout (render $ text (db_name ++ ":") $$ nest 4 packages ) @@ -406,6 +491,24 @@ listPackages flags = do | otherwise = parens doc where doc = text (showPackageId (package p)) + show_easy db_stack = do + let pkgs = map showPackageId $ sortBy compPkgIdVer $ + map package (concatMap snd db_stack) + when (null pkgs) $ die "no matches" + hPutStrLn stdout $ concat $ intersperse " " pkgs + +-- ----------------------------------------------------------------------------- +-- Prints the highest (hidden or exposed) version of a package + +latestPackage :: [Flag] -> PackageIdentifier -> IO () +latestPackage flags pkgid = do + db_stack <- getPkgDatabases False flags + ps <- findPackages db_stack pkgid + show_pkg (sortBy compPkgIdVer (map package ps)) + where + show_pkg [] = die "no matches" + show_pkg pids = hPutStrLn stdout (showPackageId (last pids)) + -- ----------------------------------------------------------------------------- -- Describe @@ -418,28 +521,23 @@ describePackage flags pkgid = do -- PackageId is can have globVersion for the version findPackages :: PackageDBStack -> PackageIdentifier -> IO [InstalledPackageInfo] findPackages db_stack pkgid - = case [ p | p <- all_pkgs, pkgid `matches` p ] of + = case [ p | p <- all_pkgs, pkgid `matchesPkg` p ] of [] -> die ("cannot find package " ++ showPackageId pkgid) - [p] -> return [p] - -- if the version is globVersion, then we are allowed to match - -- multiple packages. So eg. "Cabal-*" matches all Cabal packages, - -- but "Cabal" matches just one Cabal package - if there are more, - -- you get an error. - ps | versionTags (pkgVersion pkgid) == versionTags globVersion - -> return ps - | otherwise - -> die ("package " ++ showPackageId pkgid ++ - " matches multiple packages: " ++ - concat (intersperse ", " ( - map (showPackageId.package) ps))) + ps -> return ps where - pid `matches` pkg - = (pkgName pid == pkgName p) - && (pkgVersion pid == pkgVersion p || not (realVersion pid)) - where p = package pkg - all_pkgs = concat (map snd db_stack) +matches :: PackageIdentifier -> PackageIdentifier -> Bool +pid `matches` pid' + = (pkgName pid == pkgName pid') + && (pkgVersion pid == pkgVersion pid' || not (realVersion pid)) + +matchesPkg :: PackageIdentifier -> InstalledPackageInfo -> Bool +pid `matchesPkg` pkg = pid `matches` package pkg + +compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering +compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2 + -- ----------------------------------------------------------------------------- -- Field @@ -527,15 +625,16 @@ validatePackageConfig :: InstalledPackageInfo -> Bool -- auto-ghc-libs -> Bool -- update -> Bool -- force - -> IO () + -> IO [PackageIdentifier] validatePackageConfig pkg db_stack auto_ghci_libs update force = do checkPackageId pkg - checkDuplicates db_stack pkg update + overlaps <- checkDuplicates db_stack pkg update force mapM_ (checkDep db_stack force) (depends pkg) mapM_ (checkDir force) (importDirs pkg) mapM_ (checkDir force) (libraryDirs pkg) mapM_ (checkDir force) (includeDirs pkg) mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs force) (hsLibraries pkg) + return overlaps -- ToDo: check these somehow? -- extra_libraries :: [String], -- c_includes :: [String], @@ -552,31 +651,141 @@ checkPackageId ipi = [] -> die ("invalid package identifier: " ++ str) _ -> die ("ambiguous package identifier: " ++ str) -checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> IO () -checkDuplicates db_stack pkg update = do +resolveDeps :: PackageDBStack -> InstalledPackageInfo -> InstalledPackageInfo +resolveDeps db_stack p = updateDeps p + where + -- The input package spec is allowed to give a package dependency + -- without a version number; e.g. + -- depends: base + -- Here, we update these dependencies without version numbers to + -- match the actual versions of the relevant packages installed. + updateDeps p = p{depends = map resolveDep (depends p)} + + resolveDep dep_pkgid + | realVersion dep_pkgid = dep_pkgid + | otherwise = lookupDep dep_pkgid + + lookupDep dep_pkgid + = let + name = pkgName dep_pkgid + in + case [ pid | p <- concat (map snd db_stack), + let pid = package p, + pkgName pid == name ] of + (pid:_) -> pid -- Found installed package, + -- replete with its version + [] -> dep_pkgid -- No installed package; use + -- the version-less one + +checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Bool + -> IO [PackageIdentifier] +checkDuplicates db_stack pkg update force = do let pkgid = package pkg - (_top_db_name, pkgs) : _ = db_stack - - pkgs_with_same_name = - [ p | p <- pkgs, pkgName (package p) == pkgName pkgid] - exposed_pkgs_with_same_name = - filter exposed pkgs_with_same_name -- -- Check whether this package id already exists in this DB -- - when (not update && (package pkg `elem` map package pkgs)) $ + when (not update && (pkgid `elem` map package pkgs)) $ die ("package " ++ showPackageId pkgid ++ " is already installed") + + -- + -- Check whether any of the dependencies of the current package + -- conflict with each other. + -- + let + all_pkgs = concat (map snd db_stack) + + allModules p = exposedModules p ++ hiddenModules p + + our_dependencies = closePackageDeps all_pkgs [pkg] + all_dep_modules = concat (map (\p -> zip (allModules p) (repeat p)) + our_dependencies) + + overlaps = [ (m, map snd group) + | group@((m,_):_) <- groupBy eqfst (sortBy cmpfst all_dep_modules), + length group > 1 ] + where eqfst (a,_) (b,_) = a == b + cmpfst (a,_) (b,_) = a `compare` b + + when (not (null overlaps)) $ + diePrettyOrForce force $ vcat [ + text "package" <+> text (showPackageId (package pkg)) <+> + text "has conflicting dependencies:", + let complain_about (mod,ps) = + text mod <+> text "is in the following packages:" <+> + sep (map (text.showPackageId.package) ps) + in + nest 3 (vcat (map complain_about overlaps)) + ] + -- - -- if we are exposing this new package, then check that - -- there are no other exposed packages with the same name. + -- Now check whether exposing this package will result in conflicts, and + -- Figure out which packages we need to hide to resolve the conflicts. -- - when (not update && exposed pkg && not (null exposed_pkgs_with_same_name)) $ - die ("trying to register " ++ showPackageId pkgid - ++ " as exposed, but " - ++ showPackageId (package (my_head "when" exposed_pkgs_with_same_name)) - ++ " is also exposed.") + let + closure_exposed_pkgs = closePackageDeps pkgs (filter exposed pkgs) + + new_dep_modules = concat $ map allModules $ + filter (\p -> package p `notElem` + map package closure_exposed_pkgs) $ + our_dependencies + + pkgs_with_overlapping_modules = + [ (p, overlapping_mods) + | p <- closure_exposed_pkgs, + let overlapping_mods = + filter (`elem` new_dep_modules) (allModules p), + (_:_) <- [overlapping_mods] --trick to get the non-empty ones + ] + + to_hide = map package + $ filter exposed + $ closePackageDepsUpward pkgs + $ map fst pkgs_with_overlapping_modules + + when (not update && exposed pkg && not (null pkgs_with_overlapping_modules)) $ do + diePretty $ vcat [ + text "package" <+> text (showPackageId (package pkg)) <+> + text "conflicts with the following packages, which are", + text "either exposed or a dependency (direct or indirect) of an exposed package:", + let complain_about (p, mods) + = text (showPackageId (package p)) <+> text "contains modules" <+> + sep (punctuate comma (map text mods)) in + nest 3 (vcat (map complain_about pkgs_with_overlapping_modules)), + text "Using 'update' instead of 'register' will cause the following packages", + text "to be hidden, which will eliminate the conflict:", + nest 3 (sep (map (text.showPackageId) to_hide)) + ] + + when (not (null to_hide)) $ do + hPutStrLn stderr $ render $ + sep [text "Warning: hiding the following packages to avoid conflict: ", + nest 2 (sep (map (text.showPackageId) to_hide))] + + return to_hide + + +closure :: (a->[a]->Bool) -> (a -> [a]) -> [a] -> [a] -> [a] +closure pred more [] res = res +closure pred more (p:ps) res + | p `pred` res = closure pred more ps res + | otherwise = closure pred more (more p ++ ps) (p:res) + +closePackageDeps :: [InstalledPackageInfo] -> [InstalledPackageInfo] + -> [InstalledPackageInfo] +closePackageDeps db start + = closure (\p ps -> package p `elem` map package ps) getDepends start [] + where + getDepends p = [ pkg | dep <- depends p, pkg <- lookupPkg dep ] + lookupPkg p = [ q | q <- db, p == package q ] + +closePackageDepsUpward :: [InstalledPackageInfo] -> [InstalledPackageInfo] + -> [InstalledPackageInfo] +closePackageDepsUpward db start + = closure (\p ps -> package p `elem` map package ps) getUpwardDepends start [] + where + getUpwardDepends p = [ pkg | pkg <- db, package p `elem` depends pkg ] checkDir :: Bool -> String -> IO () @@ -590,8 +799,7 @@ checkDir force d 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 () + | not real_version || pkgid `elem` pkgids = return () | otherwise = dieOrForce force ("dependency " ++ showPackageId pkgid ++ " doesn't exist") where @@ -601,7 +809,6 @@ checkDep db_stack force pkgid all_pkgs = concat (map snd db_stack) pkgids = map package all_pkgs - pkg_names = map pkgName pkgids realVersion :: PackageIdentifier -> Bool realVersion pkgid = versionBranch (pkgVersion pkgid) /= [] @@ -654,50 +861,25 @@ autoBuildGHCiLib dir batch_file ghci_file = do -- Updating the DB with the new package. updatePackageDB - :: PackageDBStack - -> [InstalledPackageInfo] - -> InstalledPackageInfo + :: PackageDBStack -- the full stack + -> [PackageIdentifier] -- packages to hide + -> [InstalledPackageInfo] -- packages in *this* DB + -> InstalledPackageInfo -- the new package -> IO [InstalledPackageInfo] -updatePackageDB db_stack pkgs new_pkg = do +updatePackageDB db_stack to_hide pkgs new_pkg = do let - -- The input package spec is allowed to give a package dependency - -- without a version number; e.g. - -- depends: base - -- Here, we update these dependencies without version numbers to - -- match the actual versions of the relevant packages installed. - updateDeps p = p{depends = map resolveDep (depends p)} - - resolveDep dep_pkgid - | realVersion dep_pkgid = dep_pkgid - | otherwise = lookupDep dep_pkgid - - lookupDep dep_pkgid - = let - name = pkgName dep_pkgid - in - case [ pid | p <- concat (map snd db_stack), - let pid = package p, - pkgName pid == name ] of - (pid:_) -> pid -- Found installed package, - -- replete with its version - [] -> dep_pkgid -- No installed package; use - -- the version-less one - - is_exposed = exposed new_pkg - pkgid = package new_pkg - name = pkgName pkgid + pkgid = package new_pkg pkgs' = [ maybe_hide p | p <- pkgs, package p /= pkgid ] -- When update is on, and we're exposing the new package, - -- we hide any packages with the same name (different versions) - -- in the current DB. Earlier checks will have failed if - -- update isn't on. + -- we hide any packages which conflict (see checkDuplicates) + -- in the current DB. maybe_hide p - | is_exposed && pkgName (package p) == name = p{ exposed = False } + | exposed new_pkg && package p `elem` to_hide = p{ exposed = False } | otherwise = p -- - return (pkgs'++[updateDeps new_pkg]) + return (pkgs'++ [new_pkg]) -- ----------------------------------------------------------------------------- -- Searching for modules @@ -818,8 +1000,8 @@ oldRunit clis = do defines = [ (nm,val) | OF_DefinedName nm val <- clis ] case [ c | c <- clis, isAction c ] of - [ OF_List ] -> listPackages new_flags - [ OF_ListLocal ] -> listPackages new_flags + [ OF_List ] -> listPackages new_flags Nothing + [ OF_ListLocal ] -> listPackages new_flags Nothing [ OF_Add upd ] -> registerPackage input_file defines new_flags auto_ghci_libs upd force [ OF_Remove pkgid_str ] -> do @@ -841,63 +1023,18 @@ my_head s [] = error s my_head s (x:xs) = x -- --------------------------------------------------------------------------- +-- expanding environment variables in the package configuration -#ifdef OLD_STUFF --- ToDo: reinstate -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) - 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 :: [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 = liftM concat . mapM expandElem . splitString - - expandElem :: Elem -> IO String - expandElem (String s) = return s - expandElem (Var v) = lookupEnvVar v +expandEnvVars :: String -> [(String, String)] -> Bool -> IO String +expandEnvVars str defines force = go str "" + where + go "" acc = return $! reverse acc + go ('$':'{':str) acc | (var, '}':rest) <- break close str + = do value <- lookupEnvVar var + go rest (reverse value ++ acc) + where close c = c == '}' || c == '\n' -- don't span newlines + go (c:str) acc + = go str (c:acc) lookupEnvVar :: String -> IO String lookupEnvVar nm = @@ -909,26 +1046,6 @@ 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' -#endif - ----------------------------------------------------------------------------- getProgramName :: IO String @@ -950,8 +1067,19 @@ die s = do dieOrForce :: Bool -> String -> IO () dieOrForce force s | force = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)") - | otherwise = die s + | otherwise = die (s ++ " (use --force to override)") +diePretty :: Doc -> IO () +diePretty doc = do + hFlush stdout + prog <- getProgramName + hPutStrLn stderr $ render $ (text prog <> colon $$ nest 2 doc) + exitWith (ExitFailure 1) + +diePrettyOrForce :: Bool -> Doc -> IO () +diePrettyOrForce force doc + | force = do hFlush stdout; hPutStrLn stderr (render (doc $$ text "(ignoring)")) + | otherwise = diePretty (doc $$ text "(use --force to override)") ----------------------------------------- -- Cut and pasted from ghc/compiler/SysTools @@ -1023,3 +1151,34 @@ pathSeparator = '\\' #else pathSeparator = '/' #endif + +-- | The function splits the given string to substrings +-- using the 'searchPathSeparator'. +parseSearchPath :: String -> [FilePath] +parseSearchPath path = split path + where + split :: String -> [String] + split s = + case rest' of + [] -> [chunk] + _:rest -> chunk : split rest + where + chunk = + case chunk' of +#ifdef mingw32_HOST_OS + ('\"':xs@(_:_)) | last xs == '\"' -> init xs +#endif + _ -> chunk' + + (chunk', rest') = break (==searchPathSeparator) s + +-- | A platform-specific character used to separate search path strings in +-- environment variables. The separator is a colon (\":\") on Unix and Macintosh, +-- and a semicolon (\";\") on the Windows operating system. +searchPathSeparator :: Char +#if mingw32_HOST_OS || mingw32_TARGET_OS +searchPathSeparator = ';' +#else +searchPathSeparator = ':' +#endif +