Skip to content
GitLab
Menu
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
d697af23
Commit
d697af23
authored
Nov 13, 2008
by
Saizan
Browse files
Implement 'cabal unpack' command as in #390
parent
4d49172e
Changes
3
Hide whitespace changes
Inline
Side-by-side
cabal-install/Distribution/Client/Setup.hs
View file @
d697af23
...
...
@@ -22,6 +22,7 @@ module Distribution.Client.Setup
,
checkCommand
,
uploadCommand
,
UploadFlags
(
..
)
,
reportCommand
,
unpackCommand
,
UnpackFlags
(
..
)
,
parsePackageArgs
--TODO: stop exporting these:
...
...
@@ -272,6 +273,46 @@ reportCommand = CommandUI {
commandOptions
=
\
_
->
[
optionVerbosity
id
const
]
}
-- ------------------------------------------------------------
-- * Unpack flags
-- ------------------------------------------------------------
data
UnpackFlags
=
UnpackFlags
{
unpackDestDir
::
Flag
FilePath
,
unpackVerbosity
::
Flag
Verbosity
}
defaultUnpackFlags
::
UnpackFlags
defaultUnpackFlags
=
UnpackFlags
{
unpackDestDir
=
mempty
,
unpackVerbosity
=
toFlag
normal
}
unpackCommand
::
CommandUI
UnpackFlags
unpackCommand
=
CommandUI
{
commandName
=
"unpack"
,
commandSynopsis
=
"Unpacks packages for user inspection."
,
commandDescription
=
Nothing
,
commandUsage
=
usagePackages
"unpack"
,
commandDefaultFlags
=
mempty
,
commandOptions
=
\
_
->
[
optionVerbosity
unpackVerbosity
(
\
v
flags
->
flags
{
unpackVerbosity
=
v
})
,
option
"d"
[
"destdir"
]
"where to unpack the packages, defaults to the current directory."
unpackDestDir
(
\
v
flags
->
flags
{
unpackDestDir
=
v
})
(
reqArgFlag
"PATH"
)
]
}
instance
Monoid
UnpackFlags
where
mempty
=
defaultUnpackFlags
mappend
a
b
=
UnpackFlags
{
unpackDestDir
=
combine
unpackDestDir
,
unpackVerbosity
=
combine
unpackVerbosity
}
where
combine
field
=
field
a
`
mappend
`
field
b
-- ------------------------------------------------------------
-- * List flags
-- ------------------------------------------------------------
...
...
cabal-install/Distribution/Client/Unpack.hs
0 → 100644
View file @
d697af23
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Unpack
-- Copyright : (c) Andrea Vezzosi 2008
-- License : BSD-like
--
-- Maintainer : cabal-devel@haskell.org
-- Stability : provisional
-- Portability : portable
--
--
-----------------------------------------------------------------------------
module
Distribution.Client.Unpack
(
-- * Commands
unpack
,
)
where
import
Distribution.Package
(
packageId
,
Dependency
(
..
)
)
import
Distribution.Simple.PackageIndex
as
PackageIndex
(
lookupDependency
)
import
Distribution.Simple.Setup
(
fromFlag
,
fromFlagOrDefault
)
import
Distribution.Simple.Utils
(
info
,
notice
)
import
Distribution.Text
(
display
)
import
Distribution.Version
(
VersionRange
(
..
))
import
Distribution.Client.Setup
(
UnpackFlags
(
unpackVerbosity
,
unpackDestDir
))
import
Distribution.Client.Types
(
UnresolvedDependency
(
..
),
Repo
,
AvailablePackageSource
(
RepoTarballPackage
),
AvailablePackage
(
AvailablePackage
),
AvailablePackageDb
(
AvailablePackageDb
))
import
Distribution.Client.Fetch
(
fetchPackage
)
import
Distribution.Client.Tar
(
extractTarGzFile
)
import
Distribution.Client.IndexUtils
as
IndexUtils
(
getAvailablePackages
,
disambiguateDependencies
)
import
System.Directory
(
createDirectoryIfMissing
)
import
Control.Monad
(
unless
)
import
Data.Ord
(
comparing
)
import
Data.List
(
null
,
maximumBy
)
import
System.FilePath
((
</>
))
import
qualified
Data.Map
as
Map
unpack
::
UnpackFlags
->
[
Repo
]
->
[
Dependency
]
->
IO
()
unpack
flags
repos
deps
|
null
deps
=
notice
verbosity
"No packages requested. Nothing to do."
|
otherwise
=
do
db
@
(
AvailablePackageDb
available
_
)
<-
getAvailablePackages
verbosity
repos
deps'
<-
fmap
(
map
dependency
)
.
IndexUtils
.
disambiguateDependencies
available
.
map
toUnresolved
$
deps
let
pkgs
=
resolvePackages
db
deps'
unless
(
null
prefix
)
$
createDirectoryIfMissing
True
prefix
sequence_
[
do
pkgPath
<-
fetchPackage
verbosity
repo
pkgid
let
pkgdir
=
display
pkgid
notice
verbosity
$
"Unpacking "
++
display
pkgid
++
"..."
info
verbosity
$
"Extracting "
++
pkgPath
++
" to "
++
prefix
</>
pkgdir
++
"..."
extractTarGzFile
prefix
pkgPath
|
(
AvailablePackage
pkgid
_
(
RepoTarballPackage
repo
))
<-
pkgs
]
where
verbosity
=
fromFlag
(
unpackVerbosity
flags
)
prefix
=
fromFlagOrDefault
""
(
unpackDestDir
flags
)
toUnresolved
d
=
UnresolvedDependency
d
[]
resolvePackages
::
AvailablePackageDb
->
[
Dependency
]
->
[
AvailablePackage
]
resolvePackages
(
AvailablePackageDb
available
prefs
)
deps
=
map
(
maximumBy
(
comparing
packageId
)
.
candidates
)
deps
where
candidates
dep
@
(
Dependency
name
ver
)
=
let
[
x
,
y
]
=
map
(
PackageIndex
.
lookupDependency
available
)
[
Dependency
name
(
maybe
AnyVersion
id
(
Map
.
lookup
name
prefs
)
`
IntersectVersionRanges
`
ver
)
,
dep
]
in
if
null
x
then
y
else
x
cabal-install/Main.hs
View file @
d697af23
...
...
@@ -22,6 +22,7 @@ import Distribution.Client.Setup
,
ListFlags
(
..
),
listCommand
,
UploadFlags
(
..
),
uploadCommand
,
reportCommand
,
unpackCommand
,
UnpackFlags
(
..
)
,
parsePackageArgs
,
configPackageDB'
)
import
Distribution.Simple.Setup
(
BuildFlags
(
..
),
buildCommand
...
...
@@ -48,6 +49,7 @@ import Distribution.Client.Check as Check (check)
--import Distribution.Client.Clean (clean)
import
Distribution.Client.Upload
as
Upload
(
upload
,
check
,
report
)
import
Distribution.Client.SrcDist
(
sdist
)
import
Distribution.Client.Unpack
(
unpack
)
import
qualified
Distribution.Client.Win32SelfUpgrade
as
Win32SelfUpgrade
import
Distribution.Simple.Program
(
defaultProgramConfiguration
)
...
...
@@ -114,6 +116,7 @@ mainWorker args =
,
checkCommand
`
commandAddAction
`
checkAction
,
sdistCommand
`
commandAddAction
`
sdistAction
,
reportCommand
`
commandAddAction
`
reportAction
,
unpackCommand
`
commandAddAction
`
unpackAction
,
wrapperAction
(
buildCommand
defaultProgramConfiguration
)
buildVerbosity
buildDistPref
,
wrapperAction
copyCommand
...
...
@@ -291,6 +294,13 @@ reportAction verbosityFlag extraArgs globalFlags = do
Upload
.
report
verbosity
(
globalRepos
(
savedGlobalFlags
config
))
unpackAction
::
UnpackFlags
->
[
String
]
->
GlobalFlags
->
IO
()
unpackAction
flags
extraArgs
globalFlags
=
do
pkgs
<-
either
die
return
(
parsePackageArgs
extraArgs
)
let
verbosity
=
fromFlag
(
unpackVerbosity
flags
)
config
<-
loadConfig
verbosity
(
globalConfigFile
globalFlags
)
mempty
unpack
flags
(
globalRepos
(
savedGlobalFlags
config
))
pkgs
win32SelfUpgradeAction
::
[
String
]
->
IO
()
win32SelfUpgradeAction
(
pid
:
path
:
rest
)
=
Win32SelfUpgrade
.
deleteOldExeFile
verbosity
(
read
pid
)
path
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a 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