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 )
exitWith, ExitCode(..)
)
import System.IO
+#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
| FlagForce
| FlagAutoGHCiLibs
| FlagDefinedName String String
+ | FlagSimpleOutput
deriving Eq
flags :: [OptDescr Flag]
Option ['D'] ["define-name"] (ReqArg toDefined "NAME=VALUE")
"define NAME as VALUE",
Option ['V'] ["version"] (NoArg FlagVersion)
- "output version information and exit"
+ "output version information and exit",
+ Option [] ["simple-output"] (NoArg FlagSimpleOutput)
+ "print output in easy-to-parse format when running command 'list'"
]
where
toDefined str =
" $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" ++
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
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
- | user_conf `elem` dbs = dbs
- | modify || user_exists = user_conf : dbs
- addDB dbs FlagGlobal = [global_conf]
- addDB dbs (FlagConfig f) = f : dbs
- addDB dbs _ = dbs
+ -- 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_conf]
+ | otherwise = [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` databases) $ do
+ 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)
-- -----------------------------------------------------------------------------
-- 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
+ show_func = if simple_output then show_easy else mapM_ show_regular
+ show_func (reverse db_stack_filtered)
+ where show_regular (db_name,pkg_confs) =
hPutStrLn stdout (render $
text (db_name ++ ":") $$ nest 4 packages
)
| exposed p = doc
| 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
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
#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