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
| FlagGlobalConfig FilePath
| FlagForce
| FlagAutoGHCiLibs
+ | FlagDefinedName String String
+ | FlagSimpleOutput
deriving Eq
flags :: [OptDescr Flag]
"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"
" $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" ++
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
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
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"
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 <file> means overlap with <file>
- 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)
-- Registering
registerPackage :: FilePath
- -> [(String,String)] -- defines, ToDo: maybe remove?
+ -> [(String,String)] -- defines
-> [Flag]
-> Bool -- auto_ghci_libs
-> Bool -- update
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
-> IO InstalledPackageInfo
parsePackageInfo str defines force =
case parseInstalledPackageInfo str of
- ParseOk ok -> return ok
+ ParseOk _warns ok -> return ok
ParseFailed err -> die (showError err)
-- -----------------------------------------------------------------------------
-- -----------------------------------------------------------------------------
-- 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
)
| 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
-- 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
-> 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],
[] -> 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 ()
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
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) /= []
-- 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
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
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 =
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
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
#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
+
projects / ghc-hetmet.git / blobdiff