ifneq "$(ProjectPatchLevel)" "0"
compiler/stage1/inplace-pkg-config-munged: compiler/stage1/inplace-pkg-config
sed -e 's/^\(version: .*\)\.$(ProjectPatchLevel)$$/\1/' \
+ -e 's/^\(id: .*\)\.$(ProjectPatchLevel)$$/\1/' \
-e 's/^\(hs-libraries: HSghc-.*\)\.$(ProjectPatchLevel)$$/\1/' \
< $< > $@
"$(compiler_stage1_GHC_PKG)" update --force $(compiler_stage1_GHC_PKG_OPTS) $@
import SrcLoc
import qualified Maybes
import UniqSet
+import FiniteMap
import Constants
import FastString
import Config ( cProjectVersion )
linkPackages' :: DynFlags -> [PackageId] -> PersistentLinkerState
-> IO PersistentLinkerState
linkPackages' dflags new_pks pls = do
- let pkg_map = pkgIdMap (pkgState dflags)
-
- pkgs' <- link pkg_map (pkgs_loaded pls) new_pks
-
+ pkgs' <- link (pkgs_loaded pls) new_pks
return $! pls { pkgs_loaded = pkgs' }
where
- link :: PackageConfigMap -> [PackageId] -> [PackageId] -> IO [PackageId]
- link pkg_map pkgs new_pkgs =
- foldM (link_one pkg_map) pkgs new_pkgs
+ pkg_map = pkgIdMap (pkgState dflags)
+ ipid_map = installedPackageIdMap (pkgState dflags)
+
+ link :: [PackageId] -> [PackageId] -> IO [PackageId]
+ link pkgs new_pkgs =
+ foldM link_one pkgs new_pkgs
- link_one pkg_map pkgs new_pkg
+ link_one pkgs new_pkg
| new_pkg `elem` pkgs -- Already linked
= return pkgs
| Just pkg_cfg <- lookupPackage pkg_map new_pkg
= do { -- Link dependents first
- pkgs' <- link pkg_map pkgs (map mkPackageId (depends pkg_cfg))
+ pkgs' <- link pkgs [ Maybes.expectJust "link_one" $
+ lookupFM ipid_map ipid
+ | ipid <- depends pkg_cfg ]
-- Now link the package itself
; linkPackage dflags pkg_cfg
; return (new_pkg : pkgs') }
upd (\s -> s{ packageFlags = IgnorePackage p : packageFlags s })
setPackageName :: String -> DynFlags -> DynFlags
-setPackageName p
- | Nothing <- unpackPackageId pid
- = ghcError (CmdLineError ("cannot parse \'" ++ p ++ "\' as a package identifier"))
- | otherwise
- = \s -> s{ thisPackage = pid }
- where
- pid = stringToPackageId p
+setPackageName p s = s{ thisPackage = stringToPackageId p }
-- If we're linking a binary, then only targets that produce object
-- code are allowed (requests for other target types are ignored).
-- $package_naming
-- * PackageId
- mkPackageId, packageConfigId, unpackPackageId,
+ mkPackageId, packageConfigId,
-- * The PackageConfig type: information about a package
PackageConfig,
import Distribution.Package hiding (PackageId)
import Distribution.Text
import Distribution.Version
-import Distribution.Compat.ReadP
-- -----------------------------------------------------------------------------
-- Our PackageConfig type is just InstalledPackageInfo from Cabal. Later we
packageConfigId :: PackageConfig -> PackageId
packageConfigId = mkPackageId . package
--- | Try and interpret a GHC 'PackageId' as a cabal 'PackageIdentifer'. Returns @Nothing@ if
--- we could not parse it as such an object.
-unpackPackageId :: PackageId -> Maybe PackageIdentifier
-unpackPackageId p
- = case [ pid | (pid,"") <- readP_to_S parse str ] of
- [] -> Nothing
- (pid:_) -> Just pid
- where str = packageIdString p
-
-- | Turn a 'PackageConfig', which contains GHC 'Module.ModuleName's into a Cabal specific
-- 'InstalledPackageInfo' which contains Cabal 'Distribution.ModuleName.ModuleName's
packageConfigToInstalledPackageInfo :: PackageConfig -> InstalledPackageInfo
import Config ( cProjectVersion )
import Name ( Name, nameModule_maybe )
import UniqFM
+import FiniteMap
import Module
import Util
-import Maybes ( expectJust, MaybeErr(..) )
import Panic
import Outputable
+import Maybes
import System.Environment ( getEnv )
-import Distribution.InstalledPackageInfo hiding (depends)
-import Distribution.Package hiding (depends, PackageId)
+import Distribution.InstalledPackageInfo
+import Distribution.Package hiding (PackageId,depends)
import FastString
import ErrUtils ( debugTraceMsg, putMsg, Message )
import Exception
import System.FilePath
import Data.Maybe
import Control.Monad
-import Data.List
+import Data.List as List
-- ---------------------------------------------------------------------------
-- The Package state
-- should be in reverse dependency order; that is, a package
-- is always mentioned before the packages it depends on.
- moduleToPkgConfAll :: UniqFM [(PackageConfig,Bool)] -- ModuleEnv mapping
+ moduleToPkgConfAll :: UniqFM [(PackageConfig,Bool)], -- ModuleEnv mapping
-- Derived from pkgIdMap.
-- Maps Module to (pkgconf,exposed), where pkgconf is the
-- PackageConfig for the package containing the module, and
-- exposed is True if the package exposes that module.
+
+ installedPackageIdMap :: FiniteMap InstalledPackageId PackageId
}
-- | A PackageConfigMap maps a 'PackageId' to a 'PackageConfig'
findWiredInPackages
:: DynFlags
-> [PackageConfig] -- database
- -> [PackageIdentifier] -- preload packages
- -> PackageId -- this package
- -> IO ([PackageConfig],
- [PackageIdentifier],
- PackageId)
+ -> IO [PackageConfig]
-findWiredInPackages dflags pkgs preload this_package = do
+findWiredInPackages dflags pkgs = do
--
-- Now we must find our wired-in packages, and rename them to
-- their canonical names (eg. base-1.0 ==> base).
--
let
- wired_in_pkgids :: [(PackageId, [String])]
- wired_in_pkgids = [ (primPackageId, [""]),
- (integerPackageId, [""]),
- (basePackageId, [""]),
- (rtsPackageId, [""]),
- (haskell98PackageId, [""]),
- (thPackageId, [""]),
- (dphSeqPackageId, [""]),
- (dphParPackageId, [""])]
-
- matches :: PackageConfig -> (PackageId, [String]) -> Bool
- pc `matches` (pid, suffixes)
- = display (pkgName (package pc)) `elem`
- (map (packageIdString pid ++) suffixes)
+ wired_in_pkgids :: [String]
+ wired_in_pkgids = map packageIdString
+ [ primPackageId,
+ integerPackageId,
+ basePackageId,
+ rtsPackageId,
+ haskell98PackageId,
+ thPackageId,
+ dphSeqPackageId,
+ dphParPackageId ]
+
+ matches :: PackageConfig -> String -> Bool
+ pc `matches` pid = display (pkgName (package pc)) == pid
-- find which package corresponds to each wired-in package
-- delete any other packages with the same name
-- version. To override the default choice, -hide-package
-- could be used to hide newer versions.
--
- findWiredInPackage :: [PackageConfig] -> (PackageId, [String])
- -> IO (Maybe (PackageIdentifier, PackageId))
+ findWiredInPackage :: [PackageConfig] -> String
+ -> IO (Maybe InstalledPackageId)
findWiredInPackage pkgs wired_pkg =
let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] in
case all_ps of
[] -> notfound
many -> pick (head (sortByVersion many))
where
- suffixes = snd wired_pkg
notfound = do
debugTraceMsg dflags 2 $
ptext (sLit "wired-in package ")
- <> ppr (fst wired_pkg)
- <> (if null suffixes
- then empty
- else text (show suffixes))
+ <> text wired_pkg
<> ptext (sLit " not found.")
return Nothing
pick :: InstalledPackageInfo_ ModuleName
- -> IO (Maybe (PackageIdentifier, PackageId))
+ -> IO (Maybe InstalledPackageId)
pick pkg = do
debugTraceMsg dflags 2 $
ptext (sLit "wired-in package ")
- <> ppr (fst wired_pkg)
+ <> text wired_pkg
<> ptext (sLit " mapped to ")
<> text (display (package pkg))
- return (Just (package pkg, fst wired_pkg))
+ return (Just (installedPackageId pkg))
mb_wired_in_ids <- mapM (findWiredInPackage pkgs) wired_in_pkgids
-}
updateWiredInDependencies pkgs = map upd_pkg pkgs
- where upd_pkg p = p{ package = upd_pid (package p),
- depends = map upd_pid (depends p) }
-
- upd_pid pid = case filter ((== pid) . fst) wired_in_ids of
- [] -> pid
- ((x, y):_) -> x{ pkgName = PackageName (packageIdString y),
- pkgVersion = Version [] [] }
-
- -- pkgs1 = deleteOtherWiredInPackages pkgs
-
- pkgs2 = updateWiredInDependencies pkgs
-
- preload1 = map upd_pid preload
+ where upd_pkg p
+ | installedPackageId p `elem` wired_in_ids
+ = p { package = (package p){ pkgVersion = Version [] [] } }
+ | otherwise
+ = p
- -- we must return an updated thisPackage, just in case we
- -- are actually compiling one of the wired-in packages
- Just old_this_pkg = unpackPackageId this_package
- new_this_pkg = mkPackageId (upd_pid old_this_pkg)
-
- return (pkgs2, preload1, new_this_pkg)
+ return $ updateWiredInDependencies pkgs
-- ----------------------------------------------------------------------------
--
(new_avail, not_avail) -> go (new_avail ++ avail) (map fst not_avail)
depsAvailable :: [PackageConfig] -> PackageConfig
- -> Either PackageConfig (PackageConfig, [PackageIdentifier])
+ -> Either PackageConfig (PackageConfig, [InstalledPackageId])
depsAvailable pkgs_ok pkg
| null dangling = Left pkg
| otherwise = Right (pkg, dangling)
where dangling = filter (`notElem` pids) (depends pkg)
- pids = map package pkgs_ok
+ pids = map installedPackageId pkgs_ok
reportElim (p, deps) =
debugTraceMsg dflags 2 $
-- should contain at least rts & base, which is why we pretend that
-- the command line contains -package rts & -package base.
--
- let new_preload_packages =
- map package (pickPackages pkgs0 [ p | ExposePackage p <- flags ])
+ let preload1 = map installedPackageId $
+ pickPackages pkgs0 [ p | ExposePackage p <- flags ]
-- hide packages that are subsumed by later versions
pkgs2 <- hideOldPackages dflags pkgs1
-- sort out which packages are wired in
- (pkgs3, preload1, new_this_pkg)
- <- findWiredInPackages dflags pkgs2 new_preload_packages this_package
+ pkgs3 <- findWiredInPackages dflags pkgs2
let ignored = map packageConfigId $
pickPackages pkgs0 [ p | IgnorePackage p <- flags ]
let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs
+ ipid_map = listToFM [ (installedPackageId p, packageConfigId p)
+ | p <- pkgs ]
+
+ lookupIPID ipid@(InstalledPackageId str)
+ | Just pid <- lookupFM ipid_map ipid = return pid
+ | otherwise = missingPackageErr str
+
+ preload2 <- mapM lookupIPID preload1
+
+ let
-- add base & rts to the preload packages
basicLinkedPackages
| dopt Opt_AutoLinkPackages dflags
-- but in any case remove the current package from the set of
-- preloaded packages so that base/rts does not end up in the
-- set up preloaded package when we are just building it
- preload2 = nub (filter (/= new_this_pkg)
- (basicLinkedPackages ++ map mkPackageId preload1))
+ preload3 = nub $ filter (/= this_package)
+ $ (basicLinkedPackages ++ preload2)
-- Close the preload packages with their dependencies
- dep_preload <- closeDeps pkg_db (zip preload2 (repeat Nothing))
+ dep_preload <- closeDeps pkg_db ipid_map (zip preload3 (repeat Nothing))
let new_dep_preload = filter (`notElem` preload0) dep_preload
let pstate = PackageState{ preloadPackages = dep_preload,
pkgIdMap = pkg_db,
- moduleToPkgConfAll = mkModuleMap pkg_db
+ moduleToPkgConfAll = mkModuleMap pkg_db,
+ installedPackageIdMap = ipid_map
}
- return (pstate, new_dep_preload, new_this_pkg)
+ return (pstate, new_dep_preload, this_package)
-- -----------------------------------------------------------------------------
let
state = pkgState dflags
pkg_map = pkgIdMap state
+ ipid_map = installedPackageIdMap state
preload = preloadPackages state
pairs = zip pkgids (repeat Nothing)
in do
- all_pkgs <- throwErr (foldM (add_package pkg_map) preload pairs)
+ all_pkgs <- throwErr (foldM (add_package pkg_map ipid_map) preload pairs)
return (map (getPackageDetails state) all_pkgs)
-- Takes a list of packages, and returns the list with dependencies included,
-- in reverse dependency order (a package appears before those it depends on).
-closeDeps :: PackageConfigMap -> [(PackageId, Maybe PackageId)]
- -> IO [PackageId]
-closeDeps pkg_map ps = throwErr (closeDepsErr pkg_map ps)
+closeDeps :: PackageConfigMap
+ -> FiniteMap InstalledPackageId PackageId
+ -> [(PackageId, Maybe PackageId)]
+ -> IO [PackageId]
+closeDeps pkg_map ipid_map ps = throwErr (closeDepsErr pkg_map ipid_map ps)
throwErr :: MaybeErr Message a -> IO a
throwErr m = case m of
Failed e -> ghcError (CmdLineError (showSDoc e))
Succeeded r -> return r
-closeDepsErr :: PackageConfigMap -> [(PackageId,Maybe PackageId)]
- -> MaybeErr Message [PackageId]
-closeDepsErr pkg_map ps = foldM (add_package pkg_map) [] ps
+closeDepsErr :: PackageConfigMap
+ -> FiniteMap InstalledPackageId PackageId
+ -> [(PackageId,Maybe PackageId)]
+ -> MaybeErr Message [PackageId]
+closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps
-- internal helper
-add_package :: PackageConfigMap -> [PackageId] -> (PackageId,Maybe PackageId)
- -> MaybeErr Message [PackageId]
-add_package pkg_db ps (p, mb_parent)
+add_package :: PackageConfigMap
+ -> FiniteMap InstalledPackageId PackageId
+ -> [PackageId]
+ -> (PackageId,Maybe PackageId)
+ -> MaybeErr Message [PackageId]
+add_package pkg_db ipid_map ps (p, mb_parent)
| p `elem` ps = return ps -- Check if we've already added this package
| otherwise =
case lookupPackage pkg_db p of
missingDependencyMsg mb_parent)
Just pkg -> do
-- Add the package's dependents also
- let deps = map mkPackageId (depends pkg)
- ps' <- foldM (add_package pkg_db) ps (zip deps (repeat (Just p)))
+ ps' <- foldM add_package_ipid ps (depends pkg)
return (p : ps')
+ where
+ add_package_ipid ps ipid@(InstalledPackageId str)
+ | Just pid <- lookupFM ipid_map ipid
+ = add_package pkg_db ipid_map ps (pid, Just p)
+ | otherwise
+ = Failed (missingPackageMsg str <> missingDependencyMsg mb_parent)
-missingPackageErr :: String -> IO [PackageConfig]
+missingPackageErr :: String -> IO a
missingPackageErr p = ghcError (CmdLineError (showSDoc (missingPackageMsg p)))
missingPackageMsg :: String -> SDoc
_ -> happyError }
}
- | VARID '=' CONID STRING { id }
- -- another case of license
+ | VARID '=' CONID STRING
+ { \p -> case unpackFS $1 of
+ "installedPackageId" ->
+ p{installedPackageId = InstalledPackageId (unpackFS $4)}
+ _ -> p -- another case of license
+ }
| VARID '=' strlist
{\p -> case unpackFS $1 of
_ -> p
}
- | VARID '=' pkgidlist
+ | VARID '=' ipidlist
{% case unpackFS $1 of
"depends" -> return (\p -> p{depends = $3})
_ -> happyError
{ Version{ versionBranch=$5,
versionTags=map unpackFS $9 } }
-pkgidlist :: { [PackageIdentifier] }
- : '[' pkgids ']' { $2 }
+ipid :: { InstalledPackageId }
+ : CONID STRING
+ {% case unpackFS $1 of
+ "InstalledPackageId" -> return (InstalledPackageId (unpackFS $2))
+ _ -> happyError
+ }
+
+ipidlist :: { [InstalledPackageId] }
+ : '[' ipids ']' { $2 }
-- empty list case is covered by strlist, to avoid conflicts
-pkgids :: { [PackageIdentifier] }
- : pkgid { [ $1 ] }
- | pkgid ',' pkgids { $1 : $3 }
+ipids :: { [InstalledPackageId] }
+ : ipid { [ $1 ] }
+ | ipid ',' ipids { $1 : $3 }
intlist :: { [Int] }
: '[' ']' { [] }
name: ffi
version: 1.0
+id: builtin:ffi
license: BSD3
maintainer: glasgow-haskell-users@haskell.org
exposed: True
name: rts
version: 1.0
+id: builtin:rts
license: BSD3
maintainer: glasgow-haskell-users@haskell.org
exposed: True
#endif
includes: Stg.h
-depends: ffi-1.0
+depends: builtin:ffi
hugs-options:
cc-options:
import System.Environment
import System.Exit
import System.FilePath
+import Data.Char
main :: IO ()
main = do args <- getArgs
(Nothing, Nothing) -> return ()
(Just lib, Just clbi) -> do
cwd <- getCurrentDirectory
+ let ipid = InstalledPackageId (display (packageId pd) ++ "-inplace")
let installedPkgInfo = inplaceInstalledPackageInfo cwd distdir
pd lib lbi clbi
- content = Installed.showInstalledPackageInfo installedPkgInfo ++ "\n"
+ final_ipi = installedPkgInfo{ Installed.installedPackageId = ipid }
+ content = Installed.showInstalledPackageInfo final_ipi ++ "\n"
writeFileAtomic (distdir </> "inplace-pkg-config") content
_ -> error "Inconsistent lib components; can't happen?"
-- stricter than gnu ld). Thus we remove the ldOptions for
-- GHC's rts package:
hackRtsPackage index =
- case PackageIndex.lookupPackageName index (PackageName "rts") of
- [rts] -> PackageIndex.insert rts { Installed.ldOptions = [] } index
+ case PackageIndex.lookupInstalledPackageByName index (PackageName "rts") of
+ [rts] -> PackageIndex.addToInstalledPackageIndex rts { Installed.ldOptions = [] } index
_ -> error "No (or multiple) ghc rts package is registered!!"
+ dep_ids = map (packageId.getLocalPackageInfo lbi) $
+ externalPackageDeps lbi
+
let variablePrefix = directory ++ '_':distdir
let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
variablePrefix ++ "_MODULES = " ++ unwords (map display modules),
variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi),
- variablePrefix ++ "_DEPS = " ++ unwords (map display (externalPackageDeps lbi)),
- variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) (externalPackageDeps lbi)),
+ variablePrefix ++ "_DEPS = " ++ unwords (map display dep_ids),
+ variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) dep_ids),
variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords (includeDirs bi),
variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi),
variablePrefix ++ "_INSTALL_INCLUDES = " ++ unwords (installIncludes bi),
{-# 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
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.
-- -----------------------------------------------------------------------------
-- 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
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 package (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
| 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 (package 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
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 (package p),
+ depid <- depends p,
+ Just dep <- [PackageIndex.lookupInstalledPackage ipix depid],
+ let to = display (package dep)
+ ]
+ putStrLn "}"
+
-- -----------------------------------------------------------------------------
-- Prints the highest (hidden or exposed) version of a package
= (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))
-> 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)
-> 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
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"
projects / ghc-hetmet.git / commitdiff