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
Packages
Cabal
Commits
16f1796d
Commit
16f1796d
authored
Dec 06, 2013
by
Mikhail Glushenkov
Browse files
Make 'list' and 'info' accept the '--package-db' option.
Fixes #1598.
parent
b62e3bc0
Changes
3
Hide whitespace changes
Inline
Side-by-side
Cabal/Distribution/Simple/Setup.hs
View file @
16f1796d
...
...
@@ -62,7 +62,7 @@ module Distribution.Simple.Setup (
GlobalFlags
(
..
),
emptyGlobalFlags
,
defaultGlobalFlags
,
globalCommand
,
ConfigFlags
(
..
),
emptyConfigFlags
,
defaultConfigFlags
,
configureCommand
,
configAbsolutePaths
,
configAbsolutePaths
,
readPackageDbList
,
showPackageDbList
,
CopyFlags
(
..
),
emptyCopyFlags
,
defaultCopyFlags
,
copyCommand
,
InstallFlags
(
..
),
emptyInstallFlags
,
defaultInstallFlags
,
installCommand
,
HaddockFlags
(
..
),
emptyHaddockFlags
,
defaultHaddockFlags
,
haddockCommand
,
...
...
@@ -549,20 +549,6 @@ configureOptions showOrParseArgs =
showFlagList
fs
=
[
if
not
set
then
'-'
:
fname
else
fname
|
(
FlagName
fname
,
set
)
<-
fs
]
readPackageDbList
::
String
->
[
Maybe
PackageDB
]
readPackageDbList
"clear"
=
[
Nothing
]
readPackageDbList
"global"
=
[
Just
GlobalPackageDB
]
readPackageDbList
"user"
=
[
Just
UserPackageDB
]
readPackageDbList
other
=
[
Just
(
SpecificPackageDB
other
)]
showPackageDbList
::
[
Maybe
PackageDB
]
->
[
String
]
showPackageDbList
=
map
showPackageDb
where
showPackageDb
Nothing
=
"clear"
showPackageDb
(
Just
GlobalPackageDB
)
=
"global"
showPackageDb
(
Just
UserPackageDB
)
=
"user"
showPackageDb
(
Just
(
SpecificPackageDB
db
))
=
db
liftInstallDirs
=
liftOption
configInstallDirs
(
\
v
flags
->
flags
{
configInstallDirs
=
v
})
...
...
@@ -570,6 +556,21 @@ configureOptions showOrParseArgs =
reqArgFlag
title
_sf
_lf
d
(
fmap
fromPathTemplate
.
get
)
(
set
.
fmap
toPathTemplate
)
readPackageDbList
::
String
->
[
Maybe
PackageDB
]
readPackageDbList
"clear"
=
[
Nothing
]
readPackageDbList
"global"
=
[
Just
GlobalPackageDB
]
readPackageDbList
"user"
=
[
Just
UserPackageDB
]
readPackageDbList
other
=
[
Just
(
SpecificPackageDB
other
)]
showPackageDbList
::
[
Maybe
PackageDB
]
->
[
String
]
showPackageDbList
=
map
showPackageDb
where
showPackageDb
Nothing
=
"clear"
showPackageDb
(
Just
GlobalPackageDB
)
=
"global"
showPackageDb
(
Just
UserPackageDB
)
=
"user"
showPackageDb
(
Just
(
SpecificPackageDB
db
))
=
db
parseDependency
::
Parse
.
ReadP
r
(
PackageName
,
InstalledPackageId
)
parseDependency
=
do
x
<-
parse
...
...
cabal-install/Distribution/Client/Setup.hs
View file @
16f1796d
...
...
@@ -50,6 +50,7 @@ import qualified Distribution.Client.Init.Types as IT
import
Distribution.Client.Targets
(
UserConstraint
,
readUserConstraint
)
import
Distribution.Simple.Compiler
(
PackageDB
)
import
Distribution.Simple.Program
(
defaultProgramConfiguration
)
import
Distribution.Simple.Command
hiding
(
boolOpt
)
...
...
@@ -57,6 +58,7 @@ import qualified Distribution.Simple.Setup as Cabal
import
Distribution.Simple.Setup
(
ConfigFlags
(
..
),
BuildFlags
(
..
),
TestFlags
(
..
),
BenchmarkFlags
(
..
)
,
SDistFlags
(
..
),
HaddockFlags
(
..
)
,
readPackageDbList
,
showPackageDbList
,
Flag
(
..
),
toFlag
,
fromFlag
,
flagToMaybe
,
flagToList
,
optionVerbosity
,
boolOpt
,
trueArg
,
falseArg
,
numJobsParser
)
import
Distribution.Simple.InstallDirs
...
...
@@ -700,16 +702,18 @@ instance Monoid GetFlags where
-- ------------------------------------------------------------
data
ListFlags
=
ListFlags
{
listInstalled
::
Flag
Bool
,
listInstalled
::
Flag
Bool
,
listSimpleOutput
::
Flag
Bool
,
listVerbosity
::
Flag
Verbosity
listVerbosity
::
Flag
Verbosity
,
listPackageDBs
::
[
Maybe
PackageDB
]
}
defaultListFlags
::
ListFlags
defaultListFlags
=
ListFlags
{
listInstalled
=
Flag
False
,
listInstalled
=
Flag
False
,
listSimpleOutput
=
Flag
False
,
listVerbosity
=
toFlag
normal
listVerbosity
=
toFlag
normal
,
listPackageDBs
=
[]
}
listCommand
::
CommandUI
ListFlags
...
...
@@ -732,15 +736,26 @@ listCommand = CommandUI {
listSimpleOutput
(
\
v
flags
->
flags
{
listSimpleOutput
=
v
})
trueArg
,
option
""
[
"package-db"
]
"Use a given package database. May be a specific file, 'global', 'user' or 'clear'."
listPackageDBs
(
\
v
flags
->
flags
{
listPackageDBs
=
v
})
(
reqArg'
"DB"
readPackageDbList
showPackageDbList
)
]
}
instance
Monoid
ListFlags
where
mempty
=
defaultListFlags
mempty
=
ListFlags
{
listInstalled
=
mempty
,
listSimpleOutput
=
mempty
,
listVerbosity
=
mempty
,
listPackageDBs
=
mempty
}
mappend
a
b
=
ListFlags
{
listInstalled
=
combine
listInstalled
,
listInstalled
=
combine
listInstalled
,
listSimpleOutput
=
combine
listSimpleOutput
,
listVerbosity
=
combine
listVerbosity
listVerbosity
=
combine
listVerbosity
,
listPackageDBs
=
combine
listPackageDBs
}
where
combine
field
=
field
a
`
mappend
`
field
b
...
...
@@ -749,12 +764,14 @@ instance Monoid ListFlags where
-- ------------------------------------------------------------
data
InfoFlags
=
InfoFlags
{
infoVerbosity
::
Flag
Verbosity
infoVerbosity
::
Flag
Verbosity
,
infoPackageDBs
::
[
Maybe
PackageDB
]
}
defaultInfoFlags
::
InfoFlags
defaultInfoFlags
=
InfoFlags
{
infoVerbosity
=
toFlag
normal
infoVerbosity
=
toFlag
normal
,
infoPackageDBs
=
[]
}
infoCommand
::
CommandUI
InfoFlags
...
...
@@ -766,13 +783,23 @@ infoCommand = CommandUI {
commandDefaultFlags
=
defaultInfoFlags
,
commandOptions
=
\
_
->
[
optionVerbosity
infoVerbosity
(
\
v
flags
->
flags
{
infoVerbosity
=
v
})
,
option
""
[
"package-db"
]
"Use a given package database. May be a specific file, 'global', 'user' or 'clear'."
infoPackageDBs
(
\
v
flags
->
flags
{
infoPackageDBs
=
v
})
(
reqArg'
"DB"
readPackageDbList
showPackageDbList
)
]
}
instance
Monoid
InfoFlags
where
mempty
=
defaultInfoFlags
mempty
=
InfoFlags
{
infoVerbosity
=
mempty
,
infoPackageDBs
=
mempty
}
mappend
a
b
=
InfoFlags
{
infoVerbosity
=
combine
infoVerbosity
infoVerbosity
=
combine
infoVerbosity
,
infoPackageDBs
=
combine
infoPackageDBs
}
where
combine
field
=
field
a
`
mappend
`
field
b
...
...
cabal-install/Main.hs
View file @
16f1796d
...
...
@@ -698,7 +698,11 @@ listAction :: ListFlags -> [String] -> GlobalFlags -> IO ()
listAction
listFlags
extraArgs
globalFlags
=
do
let
verbosity
=
fromFlag
(
listVerbosity
listFlags
)
(
_
,
config
)
<-
loadConfigOrSandboxConfig
verbosity
globalFlags
mempty
let
configFlags
=
savedConfigureFlags
config
let
configFlags'
=
savedConfigureFlags
config
configFlags
=
configFlags'
{
configPackageDBs
=
configPackageDBs
configFlags'
`
mappend
`
listPackageDBs
listFlags
}
globalFlags'
=
savedGlobalFlags
config
`
mappend
`
globalFlags
(
comp
,
_
,
conf
)
<-
configCompilerAux'
configFlags
List
.
list
verbosity
...
...
@@ -714,7 +718,11 @@ infoAction infoFlags extraArgs globalFlags = do
let
verbosity
=
fromFlag
(
infoVerbosity
infoFlags
)
targets
<-
readUserTargets
verbosity
extraArgs
(
_
,
config
)
<-
loadConfigOrSandboxConfig
verbosity
globalFlags
mempty
let
configFlags
=
savedConfigureFlags
config
let
configFlags'
=
savedConfigureFlags
config
configFlags
=
configFlags'
{
configPackageDBs
=
configPackageDBs
configFlags'
`
mappend
`
infoPackageDBs
infoFlags
}
globalFlags'
=
savedGlobalFlags
config
`
mappend
`
globalFlags
(
comp
,
_
,
conf
)
<-
configCompilerAuxEx
configFlags
List
.
info
verbosity
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment