Repository : ssh://darcs.haskell.org//srv/darcs/packages/Cabal On branch : master
http://hackage.haskell.org/trac/ghc/changeset/248382f6aad15d35f1571a3124e8ab77ce430c1f >--------------------------------------------------------------- commit 248382f6aad15d35f1571a3124e8ab77ce430c1f Author: Andrea Vezzosi <[email protected]> Date: Thu Nov 13 18:59:23 2008 +0000 Implement 'cabal unpack' command as in #390 >--------------------------------------------------------------- cabal-install/Distribution/Client/Setup.hs | 41 +++++++++++++ cabal-install/Distribution/Client/Unpack.hs | 86 +++++++++++++++++++++++++++ cabal-install/Main.hs | 10 +++ 3 files changed, 137 insertions(+), 0 deletions(-) diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs index 8ac73e6..e44117d 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/cabal-install/Distribution/Client/Setup.hs @@ -22,6 +22,7 @@ module Distribution.Client.Setup , checkCommand , uploadCommand, UploadFlags(..) , reportCommand + , unpackCommand, UnpackFlags(..) , parsePackageArgs --TODO: stop exporting these: @@ -273,6 +274,46 @@ reportCommand = CommandUI { } -- ------------------------------------------------------------ +-- * 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 -- ------------------------------------------------------------ diff --git a/cabal-install/Distribution/Client/Unpack.hs b/cabal-install/Distribution/Client/Unpack.hs new file mode 100644 index 0000000..4da24b0 --- /dev/null +++ b/cabal-install/Distribution/Client/Unpack.hs @@ -0,0 +1,86 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Unpack +-- Copyright : (c) Andrea Vezzosi 2008 +-- License : BSD-like +-- +-- Maintainer : [email protected] +-- 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 diff --git a/cabal-install/Main.hs b/cabal-install/Main.hs index 1c7f8f2..66fffdb 100644 --- a/cabal-install/Main.hs +++ b/cabal-install/Main.hs @@ -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 _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
