import Version ( version, targetOS, targetARCH )
import Distribution.InstalledPackageInfo
import Distribution.Compat.ReadP
-import Distribution.ParseUtils ( showError )
+import Distribution.ParseUtils
import Distribution.Package
import Distribution.Version
-import Compat.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
-import Compat.RawSystem ( rawSystem )
+
+#ifdef USING_COMPAT
+import Compat.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
+import Compat.RawSystem ( rawSystem )
+#else
+import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
+import System.Cmd ( rawSystem )
+#endif
import Prelude
#include "../../includes/ghcconfig.h"
-#if __GLASGOW_HASKELL__ >= 504
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
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, sortBy )
#ifdef mingw32_HOST_OS
import Foreign
-
-#if __GLASGOW_HASKELL__ >= 504
import Foreign.C.String
-#else
-import CString
-#endif
#endif
+import IO ( isPermissionError, isDoesNotExistError )
+
-- -----------------------------------------------------------------------------
-- Entry point
| FlagConfig FilePath
| FlagGlobalConfig FilePath
| FlagForce
+ | FlagForceFiles
| FlagAutoGHCiLibs
| FlagDefinedName String String
| FlagSimpleOutput
"location of the global package config",
Option [] ["force"] (NoArg FlagForce)
"ignore missing dependencies, directories, and libraries",
+ Option [] ["force-files"] (NoArg FlagForceFiles)
+ "ignore missing directories and libraries only",
Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
"automatically build libs for GHCi (with register)",
Option ['?'] ["help"] (NoArg FlagHelp)
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'"
+ "print output in easy-to-parse format for some commands"
]
where
toDefined str =
" 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" ++
+ " Accepts the --simple-output flag.\n" ++
"\n" ++
" $p latest pkg\n" ++
" Prints the highest registered version of a package.\n" ++
"\n" ++
+ " $p check\n" ++
+ " Check the consistency of package depenencies and list broken packages.\n" ++
+ " Accepts the --simple-output flag.\n" ++
+ "\n" ++
" $p describe {pkg-id}\n" ++
" Give the registered description for the specified package. The\n" ++
" description is returned in precisely the syntax required by $p\n" ++
-- -----------------------------------------------------------------------------
-- Do the business
+data Force = ForceAll | ForceFiles | NoForce
+
runit :: [Flag] -> [String] -> IO ()
runit cli nonopts = do
prog <- getProgramName
let
- force = FlagForce `elem` cli
+ force
+ | FlagForce `elem` cli = ForceAll
+ | FlagForceFiles `elem` cli = ForceFiles
+ | otherwise = NoForce
auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
defines = [ (nm,val) | FlagDefinedName nm val <- cli ]
--
["field", pkgid_str, field] -> do
pkgid <- readGlobPkgId pkgid_str
describeField cli pkgid field
+ ["check"] -> do
+ checkConsistency cli
[] -> do
die ("missing command\n" ++
usageInfo (usageHeader prog) flags)
-> [Flag]
-> Bool -- auto_ghci_libs
-> Bool -- update
- -> Bool -- force
+ -> Force
-> IO ()
registerPackage input defines flags auto_ghci_libs update force = do
db_stack <- getPkgDatabases True flags
db_to_operate_on = my_head "db" db_stack
db_filename = fst db_to_operate_on
--
- checkConfigAccess db_filename
s <-
case input of
expanded <- expandEnvVars s defines force
- pkg0 <- parsePackageInfo expanded defines force
+ pkg0 <- parsePackageInfo expanded defines
putStrLn "done."
let pkg = resolveDeps db_stack pkg0
validatePackageConfig pkg db_stack auto_ghci_libs update force
let new_details = filter not_this (snd db_to_operate_on) ++ [pkg]
not_this p = package p /= package pkg
- savePackageConfig db_filename
- maybeRestoreOldConfig db_filename $
+ savingOldConfig db_filename $
writeNewConfig db_filename new_details
parsePackageInfo
:: String
-> [(String,String)]
- -> Bool
-> IO InstalledPackageInfo
-parsePackageInfo str defines force =
+parsePackageInfo str defines =
case parseInstalledPackageInfo str of
ParseOk _warns ok -> return ok
- ParseFailed err -> die (showError err)
+ ParseFailed err -> case locatedErrorMsg err of
+ (Nothing, s) -> die s
+ (Just l, s) -> die (show l ++ ": " ++ s)
-- -----------------------------------------------------------------------------
-- Exposing, Hiding, Unregistering are all similar
modifyPackage fn pkgid flags = do
db_stack <- getPkgDatabases True{-modify-} flags
let ((db_name, pkgs) : _) = db_stack
- checkConfigAccess db_name
ps <- findPackages [(db_name,pkgs)] pkgid
let pids = map package ps
- savePackageConfig db_name
let new_config = concat (map modify pkgs)
modify pkg
| package pkg `elem` pids = fn pkg
| otherwise = [pkg]
- maybeRestoreOldConfig db_name $
+ savingOldConfig db_name $
writeNewConfig db_name new_config
-- -----------------------------------------------------------------------------
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
+ pkg_map = map (\p -> (package p, p)) $ concatMap snd db_stack
+ show_func = if simple_output then show_simple else mapM_ (show_normal pkg_map)
show_func (reverse db_stack_sorted)
- where show_regular (db_name,pkg_confs) =
+ where show_normal pkg_map (db_name,pkg_confs) =
hPutStrLn stdout (render $
- text (db_name ++ ":") $$ nest 4 packages
+ text db_name <> colon $$ nest 4 packages
)
where packages = fsep (punctuate comma (map pp_pkg pkg_confs))
pp_pkg p
+ | isBrokenPackage p pkg_map = braces doc
| exposed p = doc
| otherwise = parens doc
where doc = text (showPackageId (package p))
- show_easy db_stack = do
+ show_simple db_stack = do
let pkgs = map showPackageId $ sortBy compPkgIdVer $
map package (concatMap snd db_stack)
when (null pkgs) $ die "no matches"
Nothing -> die ("unknown field: " ++ field)
Just fn -> do
ps <- findPackages db_stack pkgid
- mapM_ (putStrLn.fn) ps
+ let top_dir = getFilenameDir (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
+-- with the current topdir (obtained from the -B option).
+mungePackagePaths top_dir ps = map munge_pkg ps
+ where
+ munge_pkg p = p{ importDirs = munge_paths (importDirs p),
+ includeDirs = munge_paths (includeDirs p),
+ libraryDirs = munge_paths (libraryDirs p),
+ frameworkDirs = munge_paths (frameworkDirs p),
+ haddockInterfaces = munge_paths (haddockInterfaces p),
+ haddockHTMLs = munge_paths (haddockHTMLs p)
+ }
+
+ munge_paths = map munge_path
+
+ munge_path p
+ | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
+ | otherwise = p
+
+maybePrefixMatch :: String -> String -> Maybe String
+maybePrefixMatch [] rest = Just rest
+maybePrefixMatch (_:_) [] = Nothing
+maybePrefixMatch (p:pat) (r:rest)
+ | p == r = maybePrefixMatch pat rest
+ | otherwise = Nothing
toField :: String -> Maybe (InstalledPackageInfo -> String)
-- backwards compatibility:
strList :: [String] -> String
strList = show
+
-- -----------------------------------------------------------------------------
--- Manipulating package.conf files
+-- Check: Check consistency of installed packages
+
+checkConsistency :: [Flag] -> IO ()
+checkConsistency flags = do
+ db_stack <- getPkgDatabases False flags
+ let pkgs = map (\p -> (package p, p)) $ concatMap snd db_stack
+ broken_pkgs = do
+ (pid, p) <- pkgs
+ let broken_deps = missingPackageDeps p pkgs
+ guard (not . null $ broken_deps)
+ return (pid, broken_deps)
+ mapM_ (putStrLn . render . show_func) broken_pkgs
+ where
+ show_func | FlagSimpleOutput `elem` flags = show_simple
+ | otherwise = show_normal
+ show_simple (pid,deps) =
+ text (showPackageId pid) <> colon
+ <+> fsep (punctuate comma (map (text . showPackageId) deps))
+ show_normal (pid,deps) =
+ text "package" <+> text (showPackageId pid) <+> text "has missing dependencies:"
+ $$ nest 4 (fsep (punctuate comma (map (text . showPackageId) deps)))
+
+missingPackageDeps :: InstalledPackageInfo
+ -> [(PackageIdentifier, InstalledPackageInfo)]
+ -> [PackageIdentifier]
+missingPackageDeps pkg pkg_map =
+ [ d | d <- depends pkg, isNothing (lookup d pkg_map)] ++
+ [ d | d <- depends pkg, Just p <- return (lookup d pkg_map), isBrokenPackage p pkg_map]
+
+isBrokenPackage :: InstalledPackageInfo -> [(PackageIdentifier, InstalledPackageInfo)] -> Bool
+isBrokenPackage pkg pkg_map = not . null $ missingPackageDeps pkg pkg_map
+
-checkConfigAccess :: FilePath -> IO ()
-checkConfigAccess filename = do
- access <- getPermissions filename
- when (not (writable access))
- (die (filename ++ ": you don't have permission to modify this file"))
-
-maybeRestoreOldConfig :: FilePath -> IO () -> IO ()
-maybeRestoreOldConfig filename io
- = io `catch` \e -> do
- hPutStrLn stderr (show e)
- 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."
- ioError e
+-- -----------------------------------------------------------------------------
+-- Manipulating package.conf files
writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO ()
writeNewConfig filename packages = do
hPutStr stdout "Writing new package config file... "
- h <- openFile filename WriteMode
- hPutStrLn h (show packages)
+ createDirectoryIfMissing True $ getFilenameDir filename
+ h <- openFile filename WriteMode `catch` \e ->
+ if isPermissionError e
+ then die (filename ++ ": you don't have permission to modify this file")
+ else ioError e
+ let shown = concat $ intersperse ",\n " $ map show packages
+ fileContents = "[" ++ shown ++ "\n]"
+ hPutStrLn h fileContents
hClose h
hPutStrLn stdout "done."
-savePackageConfig :: FilePath -> IO ()
-savePackageConfig filename = do
+savingOldConfig :: FilePath -> IO () -> IO ()
+savingOldConfig filename io = Exception.block $ do
hPutStr stdout "Saving old package config file... "
-- mv rather than cp because we've already done an hGetContents
-- on this file so we won't be able to open it for writing
-- unless we move the old one out of the way...
let oldFile = filename ++ ".old"
- doesExist <- doesFileExist oldFile `catch` (\ _ -> return False)
- when doesExist (removeFile oldFile `catch` (const $ return ()))
- catch (renameFile filename oldFile)
- (\ err -> do
- hPutStrLn stderr (unwords [ "Unable to rename "
- , show filename
- , " to "
- , show oldFile
- ])
- ioError err)
+ restore_on_error <- catch (renameFile filename oldFile >> return True) $
+ \err -> do
+ unless (isDoesNotExistError err) $ do
+ hPutStrLn stderr (unwords ["Unable to rename", show filename,
+ "to", show oldFile])
+ ioError err
+ return False
hPutStrLn stdout "done."
+ io `catch` \e -> do
+ hPutStrLn stderr (show e)
+ hPutStr stdout ("\nWARNING: an error was encountered while writing"
+ ++ "the new configuration.\n")
+ when restore_on_error $ do
+ hPutStr stdout "Attempting to restore the old configuration..."
+ do renameFile oldFile filename
+ hPutStrLn stdout "done."
+ `catch` \err -> hPutStrLn stdout ("Failed: " ++ show err)
+ ioError e
-----------------------------------------------------------------------------
-- Sanity-check a new package config, and automatically build GHCi libs
-> PackageDBStack
-> Bool -- auto-ghc-libs
-> Bool -- update
- -> Bool -- force
+ -> Force
-> IO ()
validatePackageConfig pkg db_stack auto_ghci_libs update force = do
checkPackageId pkg
- checkDuplicates db_stack pkg update force
+ checkDuplicates db_stack pkg update
mapM_ (checkDep db_stack force) (depends pkg)
mapM_ (checkDir force) (importDirs pkg)
mapM_ (checkDir force) (libraryDirs pkg)
[] -> dep_pkgid -- No installed package; use
-- the version-less one
-checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Bool
- -> IO ()
-checkDuplicates db_stack pkg update force = do
+checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> IO ()
+checkDuplicates db_stack pkg update = do
let
pkgid = package pkg
(_top_db_name, pkgs) : _ = db_stack
-checkDir :: Bool -> String -> IO ()
+checkDir :: Force -> String -> IO ()
checkDir force d
| "$topdir" `isPrefixOf` d = return ()
-- can't check this, because we don't know what $topdir is
| otherwise = do
there <- doesDirectoryExist d
when (not there)
- (dieOrForce force (d ++ " doesn't exist or isn't a directory"))
+ (dieOrForceFile force (d ++ " doesn't exist or isn't a directory"))
-checkDep :: PackageDBStack -> Bool -> PackageIdentifier -> IO ()
+checkDep :: PackageDBStack -> Force -> PackageIdentifier -> IO ()
checkDep db_stack force pkgid
- | not real_version || pkgid `elem` pkgids = return ()
- | otherwise = dieOrForce force ("dependency " ++ showPackageId pkgid
+ | pkgid `elem` pkgids || (not real_version && name_exists) = return ()
+ | otherwise = dieOrForceAll force ("dependency " ++ showPackageId pkgid
++ " doesn't exist")
where
-- for backwards compat, we treat 0.0 as a special version,
-- and don't check that it actually exists.
real_version = realVersion pkgid
+ name_exists = any (\p -> pkgName (package p) == name) all_pkgs
+ name = pkgName pkgid
+
all_pkgs = concat (map snd db_stack)
pkgids = map package all_pkgs
realVersion :: PackageIdentifier -> Bool
realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
-checkHSLib :: [String] -> Bool -> Bool -> String -> IO ()
+checkHSLib :: [String] -> Bool -> Force -> String -> IO ()
checkHSLib dirs auto_ghci_libs force lib = do
let batch_lib_file = "lib" ++ lib ++ ".a"
bs <- mapM (doesLibExistIn batch_lib_file) dirs
case [ dir | (exists,dir) <- zip bs dirs, exists ] of
- [] -> dieOrForce force ("cannot find " ++ batch_lib_file ++
+ [] -> dieOrForceFile force ("cannot find " ++ batch_lib_file ++
" on library path")
(dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
where isAuto OF_AutoGHCiLibs = True; isAuto _ = False
input_file = my_head "inp" ([ f | (OF_Input f) <- clis] ++ ["-"])
- force = OF_Force `elem` clis
+ force = if OF_Force `elem` clis then ForceAll else NoForce
defines = [ (nm,val) | OF_DefinedName nm val <- clis ]
-- ---------------------------------------------------------------------------
-- expanding environment variables in the package configuration
-expandEnvVars :: String -> [(String, String)] -> Bool -> IO String
+expandEnvVars :: String -> [(String, String)] -> Force -> IO String
expandEnvVars str defines force = go str ""
where
go "" acc = return $! reverse acc
Just x | not (null x) -> return x
_ ->
catch (System.getEnv nm)
- (\ _ -> do dieOrForce force ("Unable to expand variable " ++
+ (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
show nm)
return "")
hPutStrLn stderr (prog ++ ": " ++ s)
exitWith (ExitFailure 1)
-dieOrForce :: Bool -> String -> IO ()
-dieOrForce force s
- | force = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)")
- | otherwise = die (s ++ " (use --force to override)")
+dieOrForceAll :: Force -> String -> IO ()
+dieOrForceAll ForceAll s = ignoreError s
+dieOrForceAll _other s = dieForcible s
+
+dieOrForceFile :: Force -> String -> IO ()
+dieOrForceFile ForceAll s = ignoreError s
+dieOrForceFile ForceFiles s = ignoreError s
+dieOrForceFile _other s = dieForcible s
+
+ignoreError :: String -> IO ()
+ignoreError s = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)")
+
+dieForcible :: String -> IO ()
+dieForcible s = die (s ++ " (use --force to override)")
-----------------------------------------
-- Cut and pasted from ghc/compiler/SysTools
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]
projects / ghc-hetmet.git / blobdiff