{-# OPTIONS -fglasgow-exts -cpp #-}
-----------------------------------------------------------------------------
--
--- (c) The University of Glasgow 2004.
+-- (c) The University of Glasgow 2004-2009.
--
-- Package management tool
--
-----------------------------------------------------------------------------
--- TODO:
--- * validate modules
--- * expanding of variables in new-style package conf
--- * version manipulation (checking whether old version exists,
--- hiding old version?)
-
module Main (main) where
import Version ( version, targetOS, targetARCH )
+import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.ModuleName hiding (main)
-import Distribution.InstalledPackageInfo hiding (depends)
+import Distribution.InstalledPackageInfo
import Distribution.Compat.ReadP
import Distribution.ParseUtils
-import Distribution.Package
+import Distribution.Package hiding (depends)
import Distribution.Text
import Distribution.Version
import System.FilePath
" all the registered versions will be listed in ascending order.\n" ++
" Accepts the --simple-output flag.\n" ++
"\n" ++
+ " $p dot\n" ++
+ " Generate a graph of the package dependencies in a form suitable\n" ++
+ " for input for the graphviz tools. For example, to generate a PDF" ++
+ " of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++
+ "\n" ++
" $p find-module {module}\n" ++
" List registered packages exposing module {module} in the global\n" ++
" database, and also the user database if --user is given.\n" ++
" entirely. When multiple of these options are given, the rightmost\n"++
" one is used as the database to act upon.\n"++
"\n"++
- " Commands that query the package database (list, latest, describe,\n"++
+ " Commands that query the package database (list, tree, latest, describe,\n"++
" field) operate on the list of databases specified by the flags\n"++
" --user, --global, and --package-conf. If none of these flags are\n"++
" given, the default is --global --user.\n"++
pkgid <- readGlobPkgId pkgid_str
hidePackage pkgid verbosity cli force
["list"] -> do
- listPackages cli Nothing Nothing
+ listPackages verbosity cli Nothing Nothing
["list", pkgid_str] ->
case substringCheck pkgid_str of
Nothing -> do pkgid <- readGlobPkgId pkgid_str
- listPackages cli (Just (Id pkgid)) Nothing
- Just m -> listPackages cli (Just (Substring pkgid_str m)) Nothing
+ listPackages verbosity cli (Just (Id pkgid)) Nothing
+ Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing
+ ["dot"] -> do
+ showPackageDot verbosity cli
["find-module", moduleName] -> do
let match = maybe (==moduleName) id (substringCheck moduleName)
- listPackages cli Nothing (Just match)
+ listPackages verbosity cli Nothing (Just match)
["latest", pkgid_str] -> do
pkgid <- readGlobPkgId pkgid_str
latestPackage cli pkgid
parse
+++
(do n <- parse
- string "-*"
+ _ <- string "-*"
return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
-- globVersion means "all versions"
| otherwise
= do str <- readFile filename
let packages = map convertPackageInfoIn $ read str
- Exception.evaluate packages
+ _ <- Exception.evaluate packages
`catchError` \e->
die ("error while parsing " ++ filename ++ ": " ++ show e)
return (filename,packages)
when (verbosity >= Normal) $
putStrLn "done."
- let unversioned_deps = filter (not . realVersion) (depends pkg)
- unless (null unversioned_deps) $
- die ("Unversioned dependencies found: " ++
- unwords (map display unversioned_deps))
-
let truncated_stack = dropWhile ((/= to_modify).fst) db_stack
-- truncate the stack for validation, because we don't allow
-- packages lower in the stack to refer to those higher up.
validatePackageConfig pkg truncated_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
+ not_this p = sourcePackageId p /= sourcePackageId pkg
writeNewConfig verbosity to_modify new_details
parsePackageInfo
-- let ((db_name, pkgs) : rest_of_stack) = db_stack
-- ps <- findPackages [(db_name,pkgs)] (Id pkgid)
let
- pids = map package ps
+ pids = map sourcePackageId ps
modify pkg
- | package pkg `elem` pids = fn pkg
- | otherwise = [pkg]
+ | sourcePackageId pkg `elem` pids = fn pkg
+ | otherwise = [pkg]
new_config = concat (map modify pkgs)
let
rest_of_stack = [ (nm, mypkgs)
| (nm, mypkgs) <- db_stack, nm /= db_name ]
new_stack = (db_name,new_config) : rest_of_stack
- new_broken = map package (brokenPackages (allPackagesInStack new_stack))
- newly_broken = filter (`notElem` map package old_broken) new_broken
+ new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack))
+ newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken
--
when (not (null newly_broken)) $
dieOrForceAll force ("unregistering " ++ display pkgid ++
-- -----------------------------------------------------------------------------
-- Listing packages
-listPackages :: [Flag] -> Maybe PackageArg -> Maybe (String->Bool) -> IO ()
-listPackages my_flags mPackageName mModuleName = do
+listPackages :: Verbosity -> [Flag] -> Maybe PackageArg
+ -> Maybe (String->Bool)
+ -> IO ()
+listPackages verbosity my_flags mPackageName mModuleName = do
let simple_output = FlagSimpleOutput `elem` my_flags
(db_stack, _) <- getPkgDatabases False my_flags
let db_stack_filtered -- if a package is given, filter out all other packages
LT -> LT
GT -> GT
EQ -> pkgVersion p1 `compare` pkgVersion p2
- where (p1,p2) = (package pkg1, package pkg2)
+ where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
pkg_map = allPackagesInStack db_stack
- show_func = if simple_output then show_simple else mapM_ (show_normal pkg_map)
+ broken = map sourcePackageId (brokenPackages pkg_map)
- show_func (reverse db_stack_sorted)
+ show_func = if simple_output then show_simple else mapM_ show_normal
- where show_normal pkg_map (db_name,pkg_confs) =
+ show_normal (db_name,pkg_confs) =
hPutStrLn stdout (render $
text db_name <> colon $$ nest 4 packages
)
- where packages = fsep (punctuate comma (map pp_pkg pkg_confs))
- broken = map package (brokenPackages pkg_map)
+ where packages
+ | verbosity >= Verbose = vcat (map pp_pkg pkg_confs)
+ | otherwise = fsep (punctuate comma (map pp_pkg pkg_confs))
pp_pkg p
- | package p `elem` broken = braces doc
+ | sourcePackageId p `elem` broken = braces doc
| exposed p = doc
| otherwise = parens doc
- where doc = text (display (package p))
+ where doc | verbosity >= Verbose = pkg <+> parens ipid
+ | otherwise = pkg
+ where
+ InstalledPackageId ipid_str = installedPackageId p
+ ipid = text ipid_str
+ pkg = text (display (sourcePackageId p))
+
+ show_simple = simplePackageList my_flags . allPackagesInStack
- show_simple = simplePackageList my_flags . allPackagesInStack
+ when (not (null broken) && verbosity /= Silent) $ do
+ prog <- getProgramName
+ putStrLn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.")
+
+ show_func (reverse db_stack_sorted)
simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
simplePackageList my_flags pkgs = do
let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
else display
- strs = map showPkg $ sortBy compPkgIdVer $ map package pkgs
+ strs = map showPkg $ sortBy compPkgIdVer $ map sourcePackageId pkgs
when (not (null pkgs)) $
hPutStrLn stdout $ concat $ intersperse " " strs
+showPackageDot :: Verbosity -> [Flag] -> IO ()
+showPackageDot _verbosity myflags = do
+ (db_stack, _) <- getPkgDatabases False myflags
+ let all_pkgs = allPackagesInStack db_stack
+ ipix = PackageIndex.listToInstalledPackageIndex all_pkgs
+
+ putStrLn "digraph {"
+ let quote s = '"':s ++ "\""
+ mapM_ putStrLn [ quote from ++ " -> " ++ quote to
+ | p <- all_pkgs,
+ let from = display (sourcePackageId p),
+ depid <- depends p,
+ Just dep <- [PackageIndex.lookupInstalledPackage ipix depid],
+ let to = display (sourcePackageId dep)
+ ]
+ putStrLn "}"
+
-- -----------------------------------------------------------------------------
-- Prints the highest (hidden or exposed) version of a package
latestPackage my_flags pkgid = do
(db_stack, _) <- getPkgDatabases False my_flags
ps <- findPackages db_stack (Id pkgid)
- show_pkg (sortBy compPkgIdVer (map package ps))
+ show_pkg (sortBy compPkgIdVer (map sourcePackageId ps))
where
show_pkg [] = die "no matches"
show_pkg pids = hPutStrLn stdout (display (last pids))
= (pkgName pid == pkgName pid')
&& (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
+realVersion :: PackageIdentifier -> Bool
+realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
+ -- when versionBranch == [], this is a glob
+
matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
-(Id pid) `matchesPkg` pkg = pid `matches` package pkg
-(Substring _ m) `matchesPkg` pkg = m (display (package pkg))
+(Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg
+(Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
then return []
else do
when (not simple_output) $ do
- reportError ("There are problems in package " ++ display (package p) ++ ":")
- reportValidateErrors es " " Nothing
+ reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
+ _ <- reportValidateErrors es " " Nothing
return ()
return [p]
broken_pkgs <- concat `fmap` mapM checkPackage pkgs
let filterOut pkgs1 pkgs2 = filter not_in pkgs2
- where not_in p = package p `notElem` all_ps
- all_ps = map package pkgs1
+ where not_in p = sourcePackageId p `notElem` all_ps
+ all_ps = map sourcePackageId pkgs1
let not_broken_pkgs = filterOut broken_pkgs pkgs
(_, trans_broken_pkgs) = closure [] not_broken_pkgs
else do
reportError ("\nThe following packages are broken, either because they have a problem\n"++
"listed above, or because they depend on a broken package.")
- mapM_ (hPutStrLn stderr . display . package) all_broken_pkgs
+ mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
-> Bool
depsAvailable pkgs_ok pkg = null dangling
where dangling = filter (`notElem` pids) (depends pkg)
- pids = map package pkgs_ok
+ pids = map installedPackageId pkgs_ok
-- we want mutually recursive groups of package to show up
-- as broken. (#1750)
-> IO ()
validatePackageConfig pkg db_stack auto_ghci_libs update force = do
(_,es) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update
- ok <- reportValidateErrors es (display (package pkg) ++ ": ") (Just force)
+ ok <- reportValidateErrors es (display (sourcePackageId pkg) ++ ": ") (Just force)
when (not ok) $ exitWith (ExitFailure 1)
checkPackageConfig :: InstalledPackageInfo
-> Bool -- update, or check
-> Validate ()
checkPackageConfig pkg db_stack auto_ghci_libs update = do
+ checkInstalledPackageId pkg db_stack update
checkPackageId pkg
checkDuplicates db_stack pkg update
mapM_ (checkDep db_stack) (depends pkg)
-- extra_libraries :: [String],
-- c_includes :: [String],
+checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool
+ -> Validate ()
+checkInstalledPackageId ipi db_stack update = do
+ let ipid@(InstalledPackageId str) = installedPackageId ipi
+ when (null str) $ verror CannotForce "missing id field"
+ let dups = [ p | p <- allPackagesInStack db_stack,
+ installedPackageId p == ipid ]
+ when (not update && not (null dups)) $
+ verror CannotForce $
+ "package(s) with this id already exist: " ++
+ unwords (map (display.packageId) dups)
+
-- When the package name and version are put together, sometimes we can
-- end up with a package id that cannot be parsed. This will lead to
-- difficulties when the user wants to refer to the package later, so
-- we check that the package id can be parsed properly here.
checkPackageId :: InstalledPackageInfo -> Validate ()
checkPackageId ipi =
- let str = display (package ipi) in
+ let str = display (sourcePackageId ipi) in
case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
[_] -> return ()
[] -> verror CannotForce ("invalid package identifier: " ++ str)
checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
checkDuplicates db_stack pkg update = do
let
- pkgid = package pkg
+ pkgid = sourcePackageId pkg
(_top_db_name, pkgs) : _ = db_stack
--
-- Check whether this package id already exists in this DB
--
- when (not update && (pkgid `elem` map package pkgs)) $
+ when (not update && (pkgid `elem` map sourcePackageId pkgs)) $
verror CannotForce $
"package " ++ display pkgid ++ " is already installed"
let
uncasep = map toLower . display
- dups = filter ((== uncasep pkgid) . uncasep) (map package pkgs)
+ dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
when (not update && not (null dups)) $ verror ForceAll $
"Package names may be treated case-insensitively in the future.\n"++
when (not there) $
verror ForceFiles (thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory")
-checkDep :: PackageDBStack -> PackageIdentifier -> Validate ()
+checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
checkDep db_stack pkgid
- | pkgid `elem` pkgids || (not real_version && name_exists) = return ()
- | otherwise = verror ForceAll ("dependency " ++ display pkgid
- ++ " doesn't exist")
+ | pkgid `elem` pkgids = return ()
+ | otherwise = verror ForceAll ("dependency \"" ++ display 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 = allPackagesInStack db_stack
- pkgids = map package all_pkgs
+ pkgids = map installedPackageId all_pkgs
-checkDuplicateDepends :: [PackageIdentifier] -> Validate ()
+checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
checkDuplicateDepends deps
| null dups = return ()
| otherwise = verror ForceAll ("package has duplicate dependencies: " ++
where
dups = [ p | (p:_:_) <- group (sort deps) ]
-realVersion :: PackageIdentifier -> Bool
-realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
-
checkHSLib :: [String] -> Bool -> String -> Validate ()
checkHSLib dirs auto_ghci_libs lib = do
let batch_lib_file = "lib" ++ lib ++ ".a"
(Exception.ErrorCall "interrupted")
--
#if !defined(mingw32_HOST_OS)
- installHandler sigQUIT (Catch interrupt) Nothing
- installHandler sigINT (Catch interrupt) Nothing
+ _ <- installHandler sigQUIT (Catch interrupt) Nothing
+ _ <- installHandler sigINT (Catch interrupt) Nothing
return ()
#elif __GLASGOW_HASKELL__ >= 603
-- GHC 6.3+ has support for console events on Windows
sig_handler Break = interrupt
sig_handler _ = return ()
- installHandler (Catch sig_handler)
+ _ <- installHandler (Catch sig_handler)
return ()
#else
return () -- nothing