Permalink
Browse files

Added a cabal remove command that finds duplicates.

  • Loading branch information...
1 parent 630c79b commit 48dc3aa02919188033dabc07731bbb6c20c12699 @phischu committed Aug 30, 2012
@@ -0,0 +1,117 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Client.Remove
+-- Copyright : (c) Philipp Schuster 2012
+-- License : BSD-like
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- Implementation of the 'cabal remove' command, which removes a user
+-- specified package or optionally suggests packages for removal.
+--
+-----------------------------------------------------------------------------
+
+module Distribution.Client.Remove (
+ remove
+ ) where
+
+import Distribution.Simple.Compiler
+ ( Compiler, PackageDBStack )
+import Distribution.Simple.Program
+ ( ProgramConfiguration )
+import Distribution.Simple.Setup
+ ( Flag(NoFlag,Flag), fromFlagOrDefault )
+import Distribution.Client.Setup
+ ( RemoveFlags(..) )
+import Distribution.Simple.PackageIndex
+ ( PackageIndex, deleteInstalledPackageId, allPackagesBySourcePackageId,
+ reverseDependencyClosure )
+import Distribution.Simple.Configure
+ ( getInstalledPackages )
+import Distribution.InstalledPackageInfo
+ ( installedPackageId, timeStamp )
+import Distribution.Package
+ ( InstalledPackageId(..) )
+import Distribution.Verbosity
+ ( normal )
+import Distribution.Simple.Utils
+ ( die )
+
+import Data.List
+ ( sortBy, delete )
+import Data.Ord
+ ( comparing )
+
+-- | The two things cabal remove can do:
+-- remove a single package or remove duplicates
+--
+data RemovalAction = SinglePackage InstalledPackageId
+ | Duplicates
+ deriving Show
+
+-- | Interpret the flags passed to 'cabal remove' to either
+-- an error message or a 'RemovalAction'
+--
+interpretRemoveFlags :: RemoveFlags -> Either String RemovalAction
+interpretRemoveFlags removeFlags = case singlePackage removeFlags of
+ NoFlag -> case duplicates removeFlags of
+ NoFlag -> Left "Please specify at least either --package-id or --duplicates"
+ Flag True -> Right Duplicates
+ Flag False -> Left "duplicates flag set to false"
+ Flag ipid -> case duplicates removeFlags of
+ NoFlag -> Right (SinglePackage ipid)
+ Flag True -> Left "Please do not specify both --package-id and --duplicates"
+ Flag False -> Left "duplicates flag set to false"
+
+-- | Given the mode of operation and a 'PackageIndex' find the
+-- packages to be removed
+--
+removals :: RemovalAction -> PackageIndex -> [InstalledPackageId]
+removals (SinglePackage ipid) _ = [ipid]
+removals Duplicates packageindex = findDuplicates packageindex []
+
+-- | Collect unnecessary packages and delete them from the
+-- 'PackageIndex' until there are no more
+--
+findDuplicates :: PackageIndex -> [InstalledPackageId] -> [InstalledPackageId]
+findDuplicates packageIndex deletedPackages = case unnecessary packageIndex of
+ [] -> deletedPackages
+ ps -> findDuplicates packageIndex' (deletedPackages ++ ps) where
+ packageIndex' = foldl (flip deleteInstalledPackageId) packageIndex ps
+
+-- | All packages that are probably unnecessary in the 'PackageIndex'.
+-- A package is unnecessary if no package depends on it and it is not
+-- the latest instance of its version.
+--
+unnecessary :: PackageIndex -> [InstalledPackageId]
+unnecessary packageIndex = concatMap
+ (filter noReverseDependencies
+ . map installedPackageId
+ . tail
+ . reverse
+ . sortBy (comparing timeStamp)
+ . snd)
+
+ (allPackagesBySourcePackageId packageIndex)
+ where
+ noReverseDependencies ipid = null (delete ipid (map installedPackageId (reverseDependencyClosure packageIndex [ipid])))
+
+-- | Actually remove a package. Currently only prints what it would
+-- remove.
+--
+runRemoval :: Bool -> InstalledPackageId -> IO ()
+runRemoval _ (InstalledPackageId ipid) = do
+ print ("Would remove " ++ ipid)
+
+-- | Stitch everything together.
+--
+remove :: PackageDBStack -> Compiler -> ProgramConfiguration -> RemoveFlags -> IO ()
+remove packageDB compiler programConfiguration removeFlags = do
+ let forreal = fromFlagOrDefault False (really removeFlags)
+ verbosity = fromFlagOrDefault normal (removeVerbosity removeFlags)
+ packageIndex <- getInstalledPackages verbosity compiler packageDB programConfiguration
+ removalAction <- either die return (interpretRemoveFlags removeFlags)
+ mapM_ (runRemoval forreal) (removals removalAction packageIndex)
+
@@ -27,6 +27,7 @@ module Distribution.Client.Setup
, reportCommand, ReportFlags(..)
, unpackCommand, UnpackFlags(..)
, initCommand, IT.InitFlags(..)
+ , removeCommand, RemoveFlags(..)
, sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..)
, parsePackageArgs
@@ -62,7 +63,8 @@ import Distribution.Simple.InstallDirs
import Distribution.Version
( Version(Version), anyVersion, thisVersion )
import Distribution.Package
- ( PackageIdentifier, packageName, packageVersion, Dependency(..) )
+ ( PackageIdentifier, packageName, packageVersion, Dependency(..),
+ InstalledPackageId )
import Distribution.Text
( Text(..), display )
import Distribution.ReadE
@@ -1097,6 +1099,74 @@ initCommand = CommandUI {
_ -> Nothing
-- ------------------------------------------------------------
+-- * Remove flags
+-- ------------------------------------------------------------
+
+data RemoveFlags = RemoveFlags {
+ removeVerbosity :: Flag Verbosity,
+ singlePackage :: Flag InstalledPackageId,
+ duplicates :: Flag Bool,
+ really :: Flag Bool
+ }
+ deriving (Show)
+
+instance Monoid RemoveFlags where
+ mempty = RemoveFlags {
+ removeVerbosity = mempty,
+ singlePackage = mempty,
+ duplicates = mempty,
+ really = mempty
+ }
+ mappend a b = RemoveFlags {
+ removeVerbosity = combine removeVerbosity,
+ singlePackage = combine singlePackage,
+ duplicates = combine duplicates,
+ really = combine really
+ }
+ where combine field = field a `mappend` field b
+
+removeCommand :: CommandUI RemoveFlags
+removeCommand = CommandUI {
+ commandName = "remove",
+ commandSynopsis = "Removes one or more packages.",
+ commandUsage = \pname -> pname ++ "remove [FLAGS]" ,
+ commandDescription = Nothing,
+ commandDefaultFlags = mempty,
+ commandOptions = \_ -> [
+
+ optionVerbosity removeVerbosity (\v flags -> flags { removeVerbosity = v })
+
+ ,option
+ "p"
+ ["package-id"]
+ "Remove the single package with the given InstalledPackageId."
+ singlePackage
+ (\v flags -> flags { singlePackage = v })
+ (reqArg
+ "INSTALLEDPACKAGEID"
+ (readP_to_E ("Cannot parse InstalledPackageId: "++) (fmap toFlag parse))
+ (flagToList . fmap display))
+
+ ,option
+ "d"
+ ["duplicates"]
+ "Remove duplicate instances of a package version except the latest one."
+ duplicates
+ (\v flags -> flags { duplicates = v })
+ trueArg
+
+ ,option
+ []
+ ["really"]
+ "Actually remove the package(s) from the PackageDB and filesystem"
+ really
+ (\v flags -> flags { really = v })
+ trueArg
+
+ ]
+ }
+
+-- ------------------------------------------------------------
-- * SDist flags
-- ------------------------------------------------------------
View
@@ -27,6 +27,7 @@ import Distribution.Client.Setup
, UploadFlags(..), uploadCommand
, ReportFlags(..), reportCommand
, InitFlags(initVerbosity), initCommand
+ , RemoveFlags(removeVerbosity) , removeCommand
, SDistFlags(..), SDistExFlags(..), sdistCommand
, reportCommand
, unpackCommand, UnpackFlags(..) )
@@ -59,6 +60,7 @@ import Distribution.Client.Upload as Upload (upload, check, report)
import Distribution.Client.SrcDist (sdist)
import Distribution.Client.Unpack (unpack)
import Distribution.Client.Init (initCabal)
+import Distribution.Client.Remove (remove)
import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade
import Distribution.Simple.Compiler
@@ -138,6 +140,7 @@ mainWorker args = topHandler $
,reportCommand `commandAddAction` reportAction
,initCommand `commandAddAction` initAction
,configureExCommand `commandAddAction` configureAction
+ ,removeCommand `commandAddAction` removeAction
,wrapperAction (buildCommand defaultProgramConfiguration)
buildVerbosity buildDistPref
,wrapperAction copyCommand
@@ -371,6 +374,17 @@ initAction initFlags _extraArgs globalFlags = do
conf
initFlags
+removeAction :: RemoveFlags -> [String] -> GlobalFlags -> IO ()
+removeAction removeFlags _extraArgs globalFlags = do
+ let verbosity = fromFlagOrDefault normal (removeVerbosity removeFlags)
+ config <- loadConfig verbosity (globalConfigFile globalFlags) mempty
+ let configFlags = savedConfigureFlags config
+ (comp, conf) <- configCompilerAux' configFlags
+ remove (configPackageDB' configFlags)
+ comp
+ conf
+ removeFlags
+
-- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details.
--
win32SelfUpgradeAction :: [String] -> IO ()
@@ -89,6 +89,7 @@ Executable cabal
Distribution.Client.List
Distribution.Client.PackageIndex
Distribution.Client.PackageUtils
+ Distribution.Client.Remove
Distribution.Client.Setup
Distribution.Client.SetupWrapper
Distribution.Client.SrcDist

0 comments on commit 48dc3aa

Please sign in to comment.