Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
72547264
Commit
72547264
authored
Aug 20, 2009
by
Simon Marlow
Browse files
Add unique package identifiers (InstalledPackageId) in the package DB
See commentary at
http://hackage.haskell.org/trac/ghc/wiki/Commentary/Packages
parent
21c5c9c0
Changes
10
Hide whitespace changes
Inline
Side-by-side
compiler/ghc.mk
View file @
72547264
...
...
@@ -464,6 +464,7 @@ $(eval $(call compiler-hs-dependency,PrimOp,$(PRIMOP_BITS)))
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)
$@
...
...
compiler/ghci/Linker.lhs
View file @
72547264
...
...
@@ -51,6 +51,7 @@ import ErrUtils
import SrcLoc
import qualified Maybes
import UniqSet
import FiniteMap
import Constants
import FastString
import Config ( cProjectVersion )
...
...
@@ -973,23 +974,25 @@ linkPackages dflags new_pkgs = do
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') }
...
...
compiler/main/DynFlags.hs
View file @
72547264
...
...
@@ -2058,13 +2058,7 @@ ignorePackage p =
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).
...
...
compiler/main/PackageConfig.hs
View file @
72547264
...
...
@@ -7,7 +7,7 @@ module PackageConfig (
-- $package_naming
-- * PackageId
mkPackageId
,
packageConfigId
,
unpackPackageId
,
mkPackageId
,
packageConfigId
,
-- * The PackageConfig type: information about a package
PackageConfig
,
...
...
@@ -28,7 +28,6 @@ import Distribution.ModuleName
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
...
...
@@ -62,15 +61,6 @@ mkPackageId = stringToPackageId . display
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
...
...
compiler/main/Packages.lhs
View file @
72547264
...
...
@@ -42,15 +42,16 @@ import StaticFlags
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
...
...
@@ -59,7 +60,7 @@ import System.Directory
import System.FilePath
import Data.Maybe
import Control.Monad
import Data.List
import Data.List
as List
-- ---------------------------------------------------------------------------
-- The Package state
...
...
@@ -113,11 +114,13 @@ data PackageState = PackageState {
-- 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'
...
...
@@ -370,32 +373,27 @@ hideOldPackages dflags pkgs = mapM maybe_hide pkgs
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
...
...
@@ -407,33 +405,29 @@ findWiredInPackages dflags pkgs preload this_package = do
-- 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
Installed
PackageId)
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
Installed
PackageId)
pick pkg = do
debugTraceMsg dflags 2 $
ptext (sLit "wired-in package ")
<>
ppr (fs
t wired_pkg
)
<>
tex
t 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
...
...
@@ -454,26 +448,13 @@ findWiredInPackages dflags pkgs preload this_package = do
-}
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
-- ----------------------------------------------------------------------------
--
...
...
@@ -499,12 +480,12 @@ elimDanglingDeps dflags pkgs ignored = go [] pkgs'
(new_avail, not_avail) -> go (new_avail ++ avail) (map fst not_avail)
depsAvailable :: [PackageConfig] -> PackageConfig
-> Either PackageConfig (PackageConfig, [PackageId
entifier
])
-> Either PackageConfig (PackageConfig, [
Installed
PackageId])
depsAvailable pkgs_ok pkg
| null dangling = Left pkg
| otherwise = Right (pkg, dangling)
where dangling = filter (`notElem` pids) (depends pkg)
pids = map
p
ackage pkgs_ok
pids = map
installedP
ackage
Id
pkgs_ok
reportElim (p, deps) =
debugTraceMsg dflags 2 $
...
...
@@ -542,15 +523,14 @@ mkPackageState dflags orig_pkg_db preload0 this_package = do
-- should contain at least rts & base, which is why we pretend that
-- the command line contains -package rts & -package base.
--
let
new_
preload
_p
ackage
s =
map package (
pickPackages pkgs0 [ p | ExposePackage p <- flags ]
)
let preload
1 = map installedP
ackage
Id $
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 ]
...
...
@@ -558,6 +538,16 @@ mkPackageState dflags orig_pkg_db preload0 this_package = do
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
...
...
@@ -566,19 +556,20 @@ mkPackageState dflags orig_pkg_db preload0 this_package = do
-- 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
preload
2
= nub
(
filter (/=
new_
this_p
kg
)
(basicLinkedPackages ++
map mkPackageId
preload
1)
)
preload
3
= nub
$
filter (/= this_p
ackage
)
$
(basicLinkedPackages ++ preload
2
)
-- Close the preload packages with their dependencies
dep_preload <- closeDeps pkg_db (zip preload
2
(repeat Nothing))
dep_preload <- closeDeps pkg_db
ipid_map
(zip preload
3
(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_p
kg
)
return (pstate, new_dep_preload, this_p
ackage
)
-- -----------------------------------------------------------------------------
...
...
@@ -697,31 +688,39 @@ getPreloadPackagesAnd dflags pkgids =
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
...
...
@@ -729,11 +728,16 @@ add_package pkg_db ps (p, mb_parent)
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
...
...
compiler/main/ParsePkgConf.y
View file @
72547264
...
...
@@ -81,8 +81,12 @@ field :: { PackageConfig -> PackageConfig }
_ -> 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
...
...
@@ -107,7 +111,7 @@ field :: { PackageConfig -> PackageConfig }
_ -> p
}
| VARID '=' p
kg
idlist
| VARID '='
i
pidlist
{% case unpackFS $1 of
"depends" -> return (\p -> p{depends = $3})
_ -> happyError
...
...
@@ -129,13 +133,20 @@ version :: { Version }
{ 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
p
kg
ids :: { [PackageId
entifier
] }
: p
kg
id { [ $1 ] }
| p
kg
id ','
pkgids
{ $1 : $3 }
i
pids :: { [
Installed
PackageId] }
:
i
pid { [ $1 ] }
|
i
pid ','
ipids
{ $1 : $3 }
intlist :: { [Int] }
: '[' ']' { [] }
...
...
libffi/package.conf.in
View file @
72547264
name: ffi
version: 1.0
id: builtin:ffi
license: BSD3
maintainer: glasgow-haskell-users@haskell.org
exposed: True
...
...
rts/package.conf.in
View file @
72547264
...
...
@@ -5,6 +5,7 @@
name: rts
version: 1.0
id: builtin:rts
license: BSD3
maintainer: glasgow-haskell-users@haskell.org
exposed: True
...
...
@@ -55,7 +56,7 @@ include-dirs: TOP"/includes"
#endif
includes: Stg.h
depends:
ffi-1.0
depends:
builtin:ffi
hugs-options:
cc-options:
...
...
utils/ghc-cabal/ghc-cabal.hs
View file @
72547264
...
...
@@ -25,6 +25,7 @@ import System.Directory
import
System.Environment
import
System.Exit
import
System.FilePath
import
Data.Char
main
::
IO
()
main
=
do
args
<-
getArgs
...
...
@@ -208,9 +209,11 @@ generate config_args distdir directory
(
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?"
...
...
@@ -242,16 +245,19 @@ generate config_args distdir directory
-- 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
.
lookup
Installed
Package
By
Name
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
),
...
...
utils/ghc-pkg/Main.hs
View file @
72547264
{-# 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
...
...
@@ -192,6 +187,11 @@ usageHeader prog = substProg prog $
" 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
"
++
...
...
@@ -230,7 +230,7 @@ usageHeader prog = substProg prog $
" 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
"
++
...
...
@@ -310,15 +310,17 @@ runit verbosity cli nonopts = do
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
...
...
@@ -544,11 +546,6 @@ registerPackage input verbosity my_flags auto_ghci_libs update force = do
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.
...
...
@@ -616,8 +613,10 @@ modifyPackage fn pkgid verbosity my_flags force = do
-- -----------------------------------------------------------------------------
-- 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
...
...
@@ -642,23 +641,35 @@ listPackages my_flags mPackageName mModuleName = do
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
)