cabal-install/src/Distribution/Client/CmdClean.hs

   1 {-# LANGUAGE RecordWildCards #-}
   2
   3 module Distribution.Client.CmdClean (cleanCommand, cleanAction) where
   4
   5 import Distribution.Client.Compat.Prelude
   6 import Prelude ()
   7
   8 import Distribution.Client.Config
   9   ( defaultScriptBuildsDir
  10   )
  11 import Distribution.Client.DistDirLayout
  12   ( DistDirLayout (..)
  13   , defaultDistDirLayout
  14   )
  15 import Distribution.Client.Errors
  16 import Distribution.Client.ProjectConfig
  17   ( findProjectRoot
  18   )
  19 import Distribution.Client.ProjectFlags
  20   ( ProjectFlags (..)
  21   , defaultProjectFlags
  22   , projectFlagsOptions
  23   , removeIgnoreProjectOption
  24   )
  25 import Distribution.Client.Setup
  26   ( GlobalFlags
  27   )
  28 import Distribution.Compat.Lens
  29   ( _1
  30   , _2
  31   )
  32 import Distribution.Simple.Command
  33   ( CommandUI (..)
  34   , OptionField
  35   , ShowOrParseArgs
  36   , liftOptionL
  37   , option
  38   )
  39 import Distribution.Simple.Setup
  40   ( Flag (..)
  41   , falseArg
  42   , flagToMaybe
  43   , fromFlagOrDefault
  44   , optionDistPref
  45   , optionVerbosity
  46   , toFlag
  47   )
  48 import Distribution.Simple.Utils
  49   ( dieWithException
  50   , handleDoesNotExist
  51   , info
  52   , wrapText
  53   )
  54 import Distribution.Verbosity
  55   ( normal
  56   )
  57
  58 import Control.Monad
  59   ( forM
  60   , forM_
  61   , mapM
  62   )
  63 import qualified Data.Set as Set
  64 import System.Directory
  65   ( canonicalizePath
  66   , doesDirectoryExist
  67   , doesFileExist
  68   , getDirectoryContents
  69   , listDirectory
  70   , removeDirectoryRecursive
  71   , removeFile
  72   )
  73 import System.FilePath
  74   ( (</>)
  75   )
  76
  77 data CleanFlags = CleanFlags
  78   { cleanSaveConfig :: Flag Bool
  79   , cleanVerbosity :: Flag Verbosity
  80   , cleanDistDir :: Flag FilePath
  81   }
  82   deriving (Eq)
  83
  84 defaultCleanFlags :: CleanFlags
  85 defaultCleanFlags =
  86   CleanFlags
  87     { cleanSaveConfig = toFlag False
  88     , cleanVerbosity = toFlag normal
  89     , cleanDistDir = NoFlag
  90     }
  91
  92 cleanCommand :: CommandUI (ProjectFlags, CleanFlags)
  93 cleanCommand =
  94   CommandUI
  95     { commandName = "v2-clean"
  96     , commandSynopsis = "Clean the package store and remove temporary files."
  97     , commandUsage = \pname ->
  98         "Usage: " ++ pname ++ " new-clean [FLAGS]\n"
  99     , commandDescription = Just $ \_ ->
 100         wrapText $
 101           "Removes all temporary files created during the building process "
 102             ++ "(.hi, .o, preprocessed sources, etc.) and also empties out the "
 103             ++ "local caches (by default).\n\n"
 104     , commandNotes = Nothing
 105     , commandDefaultFlags = (defaultProjectFlags, defaultCleanFlags)
 106     , commandOptions = \showOrParseArgs ->
 107         map
 108           (liftOptionL _1)
 109           (removeIgnoreProjectOption (projectFlagsOptions showOrParseArgs))
 110           ++ map (liftOptionL _2) (cleanOptions showOrParseArgs)
 111     }
 112
 113 cleanOptions :: ShowOrParseArgs -> [OptionField CleanFlags]
 114 cleanOptions showOrParseArgs =
 115   [ optionVerbosity
 116       cleanVerbosity
 117       (\v flags -> flags{cleanVerbosity = v})
 118   , optionDistPref
 119       cleanDistDir
 120       (\dd flags -> flags{cleanDistDir = dd})
 121       showOrParseArgs
 122   , option
 123       ['s']
 124       ["save-config"]
 125       "Save configuration, only remove build artifacts"
 126       cleanSaveConfig
 127       (\sc flags -> flags{cleanSaveConfig = sc})
 128       falseArg
 129   ]
 130
 131 cleanAction :: (ProjectFlags, CleanFlags) -> [String] -> GlobalFlags -> IO ()
 132 cleanAction (ProjectFlags{..}, CleanFlags{..}) extraArgs _ = do
 133   let verbosity = fromFlagOrDefault normal cleanVerbosity
 134       saveConfig = fromFlagOrDefault False cleanSaveConfig
 135       mdistDirectory = flagToMaybe cleanDistDir
 136       mprojectDir = flagToMaybe flagProjectDir
 137       mprojectFile = flagToMaybe flagProjectFile
 138
 139   -- TODO interpret extraArgs as targets and clean those targets only (issue #7506)
 140   --
 141   -- For now assume all files passed are the names of scripts
 142   notScripts <- filterM (fmap not . doesFileExist) extraArgs
 143   unless (null notScripts) $
 144     dieWithException verbosity $
 145       CleanAction notScripts
 146
 147   projectRoot <- either throwIO return =<< findProjectRoot verbosity mprojectDir mprojectFile
 148
 149   let distLayout = defaultDistDirLayout projectRoot mdistDirectory Nothing
 150
 151   -- Do not clean a project if just running a script in it's directory
 152   when (null extraArgs || isJust mdistDirectory) $ do
 153     if saveConfig
 154       then do
 155         let buildRoot = distBuildRootDirectory distLayout
 156
 157         buildRootExists <- doesDirectoryExist buildRoot
 158
 159         when buildRootExists $ do
 160           info verbosity ("Deleting build root (" ++ buildRoot ++ ")")
 161           handleDoesNotExist () $ removeDirectoryRecursive buildRoot
 162       else do
 163         let distRoot = distDirectory distLayout
 164
 165         info verbosity ("Deleting dist-newstyle (" ++ distRoot ++ ")")
 166         handleDoesNotExist () $ removeDirectoryRecursive distRoot
 167
 168     removeEnvFiles (distProjectRootDirectory distLayout)
 169
 170   -- Clean specified script build caches and orphaned caches.
 171   -- There is currently no good way to specify to only clean orphaned caches.
 172   -- It would be better as part of an explicit gc step (see issue #3333)
 173   toClean <- Set.fromList <$> mapM canonicalizePath extraArgs
 174   cacheDir <- defaultScriptBuildsDir
 175   existsCD <- doesDirectoryExist cacheDir
 176   caches <- if existsCD then listDirectory cacheDir else return []
 177   paths <- fmap concat . forM caches $ \cache -> do
 178     let locFile = cacheDir </> cache </> "scriptlocation"
 179     exists <- doesFileExist locFile
 180     if exists then pure . (,) (cacheDir </> cache) <$> readFile locFile else return []
 181   forM_ paths $ \(cache, script) -> do
 182     exists <- doesFileExist script
 183     when (not exists || script `Set.member` toClean) $ do
 184       info verbosity ("Deleting cache (" ++ cache ++ ") for script (" ++ script ++ ")")
 185       removeDirectoryRecursive cache
 186
 187 removeEnvFiles :: FilePath -> IO ()
 188 removeEnvFiles dir =
 189   (traverse_ (removeFile . (dir </>)) . filter ((".ghc.environment" ==) . take 16))
 190     =<< getDirectoryContents dir