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