import Distribution.ParseUtils
import Distribution.Package
import Distribution.Version
+import System.FilePath
#ifdef USING_COMPAT
import Compat.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
| FlagAutoGHCiLibs
| FlagDefinedName String String
| FlagSimpleOutput
+ | FlagNamesOnly
deriving Eq
flags :: [OptDescr Flag]
Option ['V'] ["version"] (NoArg FlagVersion)
"output version information and exit",
Option [] ["simple-output"] (NoArg FlagSimpleOutput)
- "print output in easy-to-parse format for some commands"
+ "print output in easy-to-parse format for some commands",
+ Option [] ["names-only"] (NoArg FlagNamesOnly)
+ "only print package names, not versions; can only be used with list --simple-output"
]
where
toDefined str =
[] -> do mb_dir <- getExecDir "/bin/ghc-pkg.exe"
case mb_dir of
Nothing -> die err_msg
- Just dir -> return (dir `joinFileName` "package.conf")
+ Just dir -> return (dir </> "package.conf")
fs -> return (last fs)
let global_conf_dir = global_conf ++ ".d"
let
subdir = targetARCH ++ '-':targetOS ++ '-':version
- archdir = appdir `joinFileName` subdir
- user_conf = archdir `joinFileName` "package.conf"
+ archdir = appdir </> subdir
+ user_conf = archdir </> "package.conf"
user_exists <- doesFileExist user_conf
-- If the user database doesn't exist, and this command isn't a
Right path
| last cs == "" -> init cs ++ sys_databases
| otherwise -> cs
- where cs = parseSearchPath path
+ where cs = splitSearchPath path
-- The "global" database is always the one at the bottom of the stack.
-- This is the database we modify by default.
where doc = text (showPackageId (package p))
show_simple db_stack = do
- let pkgs = map showPackageId $ sortBy compPkgIdVer $
+ let showPkg = if FlagNamesOnly `elem` flags then pkgName
+ else showPackageId
+ pkgs = map showPkg $ sortBy compPkgIdVer $
map package (concatMap snd db_stack)
when (null pkgs) $ die "no matches"
hPutStrLn stdout $ concat $ intersperse " " pkgs
Nothing -> die ("unknown field: " ++ field)
Just fn -> do
ps <- findPackages db_stack pkgid
- let top_dir = getFilenameDir (fst (last db_stack))
+ let top_dir = takeDirectory (fst (last db_stack))
mapM_ (putStrLn . fn) (mungePackagePaths top_dir ps)
mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
--- Replace the string "$topdir" at the beginning of a path
+-- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
-- with the current topdir (obtained from the -B option).
mungePackagePaths top_dir ps = map munge_pkg ps
where
munge_paths = map munge_path
munge_path p
- | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
- | otherwise = p
+ | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
+ | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
+ | otherwise = p
+
+ toHttpPath p = "file:///" ++ p
maybePrefixMatch :: String -> String -> Maybe String
maybePrefixMatch [] rest = Just rest
writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO ()
writeNewConfig filename packages = do
hPutStr stdout "Writing new package config file... "
- createDirectoryIfMissing True $ getFilenameDir filename
+ createDirectoryIfMissing True $ takeDirectory filename
h <- openFile filename WriteMode `catch` \e ->
if isPermissionError e
then die (filename ++ ": you don't have permission to modify this file")
checkDir :: Force -> String -> IO ()
checkDir force d
- | "$topdir" `isPrefixOf` d = return ()
- -- can't check this, because we don't know what $topdir is
+ | "$topdir" `isPrefixOf` d = return ()
+ | "$httptopdir" `isPrefixOf` d = return ()
+ -- can't check these, because we don't know what $(http)topdir is
| otherwise = do
there <- doesDirectoryExist d
when (not there)
doesLibExistIn :: String -> String -> IO Bool
doesLibExistIn lib d
- | "$topdir" `isPrefixOf` d = return True
+ | "$topdir" `isPrefixOf` d = return True
+ | "$httptopdir" `isPrefixOf` d = return True
| otherwise = doesFileExist (d ++ '/':lib)
checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
ms <- searchEntries path prefix fs
return (prefix `joinModule` f : ms)
| looks_like_a_component = do
- ms <- searchDir (path `joinFilename` f) (prefix `joinModule` f)
+ ms <- searchDir (path </> f) (prefix `joinModule` f)
ms' <- searchEntries path prefix fs
return (ms ++ ms')
| otherwise
-- Cut and pasted from ghc/compiler/SysTools
#if defined(mingw32_HOST_OS)
+subst :: Char -> Char -> String -> String
subst a b ls = map (\ x -> if x == a then b else x) ls
+
+unDosifyPath :: FilePath -> FilePath
unDosifyPath xs = subst '\\' '/' xs
getExecDir :: String -> IO (Maybe String)
getExecDir :: String -> IO (Maybe String)
getExecDir _ = return Nothing
#endif
-
--- -----------------------------------------------------------------------------
--- FilePath utils
-
--- | The 'joinFileName' function is the opposite of 'splitFileName'.
--- It joins directory and file names to form a complete file path.
---
--- The general rule is:
---
--- > dir `joinFileName` basename == path
--- > where
--- > (dir,basename) = splitFileName path
---
--- There might be an exceptions to the rule but in any case the
--- reconstructed path will refer to the same object (file or directory).
--- An example exception is that on Windows some slashes might be converted
--- to backslashes.
-joinFileName :: String -> String -> FilePath
-joinFileName "" fname = fname
-joinFileName "." fname = fname
-joinFileName dir "" = dir
-joinFileName dir fname
- | isPathSeparator (last dir) = dir++fname
- | otherwise = dir++pathSeparator:fname
-
--- | Checks whether the character is a valid path separator for the host
--- platform. The valid character is a 'pathSeparator' but since the Windows
--- operating system also accepts a slash (\"\/\") since DOS 2, the function
--- checks for it on this platform, too.
-isPathSeparator :: Char -> Bool
-isPathSeparator ch = ch == pathSeparator || ch == '/'
-
--- | Provides a platform-specific character used to separate directory levels in
--- a path string that reflects a hierarchical file system organization. The
--- separator is a slash (@\"\/\"@) on Unix and Macintosh, and a backslash
--- (@\"\\\"@) on the Windows operating system.
-pathSeparator :: Char
-#ifdef mingw32_HOST_OS
-pathSeparator = '\\'
-#else
-pathSeparator = '/'
-#endif
-
-getFilenameDir :: FilePath -> FilePath
-getFilenameDir fn = case break isPathSeparator (reverse fn) of
- (xs, "") -> "."
- (_, sep:ys) -> reverse ys
-
--- | 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