{-# LANGUAGE RecordWildCards #-}
module Distribution.Client.CmdClean (cleanCommand, cleanAction) where
import Prelude ()
import Distribution.Client.Compat.Prelude
import Distribution.Client.Config
( defaultScriptBuildsDir )
import Distribution.Client.DistDirLayout
( DistDirLayout(..), defaultDistDirLayout )
import Distribution.Client.ProjectConfig
( findProjectRoot )
import Distribution.Client.Setup
( GlobalFlags )
import Distribution.ReadE ( succeedReadE )
import Distribution.Simple.Setup
( Flag(..), toFlag, fromFlagOrDefault, flagToList, flagToMaybe
, optionDistPref, optionVerbosity, falseArg
)
import Distribution.Simple.Command
( CommandUI(..), option, reqArg )
import Distribution.Simple.Utils
( info, die', wrapText, handleDoesNotExist )
import Distribution.Verbosity
( normal )
import Control.Monad
( forM, forM_, mapM )
import qualified Data.Set as Set
import System.Directory
( removeDirectoryRecursive, removeFile
, doesDirectoryExist, doesFileExist
, getDirectoryContents, listDirectory
, canonicalizePath )
import System.FilePath
( (</>) )
data CleanFlags = CleanFlags
{ CleanFlags -> Flag Bool
cleanSaveConfig :: Flag Bool
, CleanFlags -> Flag Verbosity
cleanVerbosity :: Flag Verbosity
, CleanFlags -> Flag String
cleanDistDir :: Flag FilePath
, CleanFlags -> Flag String
cleanProjectFile :: Flag FilePath
} deriving (CleanFlags -> CleanFlags -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CleanFlags -> CleanFlags -> Bool
$c/= :: CleanFlags -> CleanFlags -> Bool
== :: CleanFlags -> CleanFlags -> Bool
$c== :: CleanFlags -> CleanFlags -> Bool
Eq)
defaultCleanFlags :: CleanFlags
defaultCleanFlags :: CleanFlags
defaultCleanFlags = CleanFlags
{ cleanSaveConfig :: Flag Bool
cleanSaveConfig = forall a. a -> Flag a
toFlag Bool
False
, cleanVerbosity :: Flag Verbosity
cleanVerbosity = forall a. a -> Flag a
toFlag Verbosity
normal
, cleanDistDir :: Flag String
cleanDistDir = forall a. Flag a
NoFlag
, cleanProjectFile :: Flag String
cleanProjectFile = forall a. Monoid a => a
mempty
}
cleanCommand :: CommandUI CleanFlags
cleanCommand :: CommandUI CleanFlags
cleanCommand = CommandUI
{ commandName :: String
commandName = String
"v2-clean"
, commandSynopsis :: String
commandSynopsis = String
"Clean the package store and remove temporary files."
, commandUsage :: String -> String
commandUsage = \String
pname ->
String
"Usage: " forall a. [a] -> [a] -> [a]
++ String
pname forall a. [a] -> [a] -> [a]
++ String
" new-clean [FLAGS]\n"
, commandDescription :: Maybe (String -> String)
commandDescription = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ \String
_ -> String -> String
wrapText forall a b. (a -> b) -> a -> b
$
String
"Removes all temporary files created during the building process "
forall a. [a] -> [a] -> [a]
++ String
"(.hi, .o, preprocessed sources, etc.) and also empties out the "
forall a. [a] -> [a] -> [a]
++ String
"local caches (by default).\n\n"
, commandNotes :: Maybe (String -> String)
commandNotes = forall a. Maybe a
Nothing
, commandDefaultFlags :: CleanFlags
commandDefaultFlags = CleanFlags
defaultCleanFlags
, commandOptions :: ShowOrParseArgs -> [OptionField CleanFlags]
commandOptions = \ShowOrParseArgs
showOrParseArgs ->
[ forall flags.
(flags -> Flag Verbosity)
-> (Flag Verbosity -> flags -> flags) -> OptionField flags
optionVerbosity
CleanFlags -> Flag Verbosity
cleanVerbosity (\Flag Verbosity
v CleanFlags
flags -> CleanFlags
flags { cleanVerbosity :: Flag Verbosity
cleanVerbosity = Flag Verbosity
v })
, forall flags.
(flags -> Flag String)
-> (Flag String -> flags -> flags)
-> ShowOrParseArgs
-> OptionField flags
optionDistPref
CleanFlags -> Flag String
cleanDistDir (\Flag String
dd CleanFlags
flags -> CleanFlags
flags { cleanDistDir :: Flag String
cleanDistDir = Flag String
dd })
ShowOrParseArgs
showOrParseArgs
, forall get set a.
String
-> LFlags
-> String
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option [] [String
"project-file"]
(String
"Set the name of the cabal.project file"
forall a. [a] -> [a] -> [a]
++ String
" to search for in parent directories")
CleanFlags -> Flag String
cleanProjectFile (\Flag String
pf CleanFlags
flags -> CleanFlags
flags {cleanProjectFile :: Flag String
cleanProjectFile = Flag String
pf})
(forall b a.
Monoid b =>
String
-> ReadE b -> (b -> LFlags) -> MkOptDescr (a -> b) (b -> a -> a) a
reqArg String
"FILE" (forall a. (String -> a) -> ReadE a
succeedReadE forall a. a -> Flag a
Flag) forall a. Flag a -> [a]
flagToList)
, forall get set a.
String
-> LFlags
-> String
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option [Char
's'] [String
"save-config"]
String
"Save configuration, only remove build artifacts"
CleanFlags -> Flag Bool
cleanSaveConfig (\Flag Bool
sc CleanFlags
flags -> CleanFlags
flags { cleanSaveConfig :: Flag Bool
cleanSaveConfig = Flag Bool
sc })
forall a. MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
falseArg
]
}
cleanAction :: CleanFlags -> [String] -> GlobalFlags -> IO ()
cleanAction :: CleanFlags -> LFlags -> GlobalFlags -> IO ()
cleanAction CleanFlags{Flag Bool
Flag String
Flag Verbosity
cleanProjectFile :: Flag String
cleanDistDir :: Flag String
cleanVerbosity :: Flag Verbosity
cleanSaveConfig :: Flag Bool
cleanProjectFile :: CleanFlags -> Flag String
cleanDistDir :: CleanFlags -> Flag String
cleanVerbosity :: CleanFlags -> Flag Verbosity
cleanSaveConfig :: CleanFlags -> Flag Bool
..} LFlags
extraArgs GlobalFlags
_ = do
let verbosity :: Verbosity
verbosity = forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal Flag Verbosity
cleanVerbosity
saveConfig :: Bool
saveConfig = forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False Flag Bool
cleanSaveConfig
mdistDirectory :: Maybe String
mdistDirectory = forall a. Flag a -> Maybe a
flagToMaybe Flag String
cleanDistDir
mprojectFile :: Maybe String
mprojectFile = forall a. Flag a -> Maybe a
flagToMaybe Flag String
cleanProjectFile
LFlags
notScripts <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Bool
doesFileExist) LFlags
extraArgs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null LFlags
notScripts) forall a b. (a -> b) -> a -> b
$
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"'clean' extra arguments should be script files: "
forall a. [a] -> [a] -> [a]
++ LFlags -> String
unwords LFlags
notScripts
ProjectRoot
projectRoot <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> IO a
throwIO forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe String
-> Maybe String -> IO (Either BadProjectRoot ProjectRoot)
findProjectRoot forall a. Maybe a
Nothing Maybe String
mprojectFile
let distLayout :: DistDirLayout
distLayout = ProjectRoot -> Maybe String -> DistDirLayout
defaultDistDirLayout ProjectRoot
projectRoot Maybe String
mdistDirectory
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null LFlags
extraArgs Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
isJust Maybe String
mdistDirectory) forall a b. (a -> b) -> a -> b
$ do
if Bool
saveConfig then do
let buildRoot :: String
buildRoot = DistDirLayout -> String
distBuildRootDirectory DistDirLayout
distLayout
Bool
buildRootExists <- String -> IO Bool
doesDirectoryExist String
buildRoot
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
buildRootExists forall a b. (a -> b) -> a -> b
$ do
Verbosity -> String -> IO ()
info Verbosity
verbosity (String
"Deleting build root (" forall a. [a] -> [a] -> [a]
++ String
buildRoot forall a. [a] -> [a] -> [a]
++ String
")")
forall a. a -> IO a -> IO a
handleDoesNotExist () forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeDirectoryRecursive String
buildRoot
else do
let distRoot :: String
distRoot = DistDirLayout -> String
distDirectory DistDirLayout
distLayout
Verbosity -> String -> IO ()
info Verbosity
verbosity (String
"Deleting dist-newstyle (" forall a. [a] -> [a] -> [a]
++ String
distRoot forall a. [a] -> [a] -> [a]
++ String
")")
forall a. a -> IO a -> IO a
handleDoesNotExist () forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeDirectoryRecursive String
distRoot
String -> IO ()
removeEnvFiles (DistDirLayout -> String
distProjectRootDirectory DistDirLayout
distLayout)
Set String
toClean <- forall a. Ord a => [a] -> Set a
Set.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO String
canonicalizePath LFlags
extraArgs
String
cacheDir <- IO String
defaultScriptBuildsDir
Bool
existsCD <- String -> IO Bool
doesDirectoryExist String
cacheDir
LFlags
caches <- if Bool
existsCD then String -> IO LFlags
listDirectory String
cacheDir else forall (m :: * -> *) a. Monad m => a -> m a
return []
[(String, String)]
paths <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM LFlags
caches forall a b. (a -> b) -> a -> b
$ \String
cache -> do
let locFile :: String
locFile = String
cacheDir String -> String -> String
</> String
cache String -> String -> String
</> String
"scriptlocation"
Bool
exists <- String -> IO Bool
doesFileExist String
locFile
if Bool
exists then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) (String
cacheDir String -> String -> String
</> String
cache) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
locFile else forall (m :: * -> *) a. Monad m => a -> m a
return []
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, String)]
paths forall a b. (a -> b) -> a -> b
$ \(String
cache, String
script) -> do
Bool
exists <- String -> IO Bool
doesFileExist String
script
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
exists Bool -> Bool -> Bool
|| String
script forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
toClean) forall a b. (a -> b) -> a -> b
$ do
Verbosity -> String -> IO ()
info Verbosity
verbosity (String
"Deleting cache (" forall a. [a] -> [a] -> [a]
++ String
cache forall a. [a] -> [a] -> [a]
++ String
") for script (" forall a. [a] -> [a] -> [a]
++ String
script forall a. [a] -> [a] -> [a]
++ String
")")
String -> IO ()
removeDirectoryRecursive String
cache
removeEnvFiles :: FilePath -> IO ()
removeEnvFiles :: String -> IO ()
removeEnvFiles String
dir =
(forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (String -> IO ()
removeFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
dir String -> String -> String
</>)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((String
".ghc.environment" forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take Int
16))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO LFlags
getDirectoryContents String
dir