{-# LANGUAGE RecordWildCards #-}
module Distribution.Client.CmdClean (cleanCommand, cleanAction) where
import Distribution.Client.Compat.Prelude
import Prelude ()
import Distribution.Client.Config
( defaultScriptBuildsDir
)
import Distribution.Client.DistDirLayout
( DistDirLayout (..)
, defaultDistDirLayout
)
import Distribution.Client.Errors
import Distribution.Client.ProjectConfig
( findProjectRoot
)
import Distribution.Client.ProjectFlags
( ProjectFlags (..)
, defaultProjectFlags
, projectFlagsOptions
, removeIgnoreProjectOption
)
import Distribution.Client.Setup
( GlobalFlags
)
import Distribution.Compat.Lens
( _1
, _2
)
import Distribution.Simple.Command
( CommandUI (..)
, OptionField
, ShowOrParseArgs
, liftOptionL
, option
)
import Distribution.Simple.Setup
( Flag (..)
, falseArg
, flagToMaybe
, fromFlagOrDefault
, optionDistPref
, optionVerbosity
, toFlag
)
import Distribution.Simple.Utils
( dieWithException
, handleDoesNotExist
, info
, wrapText
)
import Distribution.Verbosity
( normal
)
import Control.Monad
( forM
, forM_
, mapM
)
import qualified Data.Set as Set
import System.Directory
( canonicalizePath
, doesDirectoryExist
, doesFileExist
, getDirectoryContents
, listDirectory
, removeDirectoryRecursive
, removeFile
)
import System.FilePath
( (</>)
)
data CleanFlags = CleanFlags
{ CleanFlags -> Flag Bool
cleanSaveConfig :: Flag Bool
, CleanFlags -> Flag Verbosity
cleanVerbosity :: Flag Verbosity
, CleanFlags -> Flag String
cleanDistDir :: Flag FilePath
}
deriving (CleanFlags -> CleanFlags -> Bool
(CleanFlags -> CleanFlags -> Bool)
-> (CleanFlags -> CleanFlags -> Bool) -> Eq CleanFlags
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CleanFlags -> CleanFlags -> Bool
== :: CleanFlags -> CleanFlags -> Bool
$c/= :: CleanFlags -> CleanFlags -> Bool
/= :: CleanFlags -> CleanFlags -> Bool
Eq)
defaultCleanFlags :: CleanFlags
defaultCleanFlags :: CleanFlags
defaultCleanFlags =
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 String
cleanDistDir = Flag String
forall a. Flag a
NoFlag
}
cleanCommand :: CommandUI (ProjectFlags, CleanFlags)
cleanCommand :: CommandUI (ProjectFlags, 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: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" new-clean [FLAGS]\n"
, commandDescription :: Maybe (String -> String)
commandDescription = (String -> String) -> Maybe (String -> String)
forall a. a -> Maybe a
Just ((String -> String) -> Maybe (String -> String))
-> (String -> String) -> Maybe (String -> String)
forall a b. (a -> b) -> a -> b
$ \String
_ ->
String -> String
wrapText (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
String
"Removes all temporary files created during the building process "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(.hi, .o, preprocessed sources, etc.) and also empties out the "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"local caches (by default).\n\n"
, commandNotes :: Maybe (String -> String)
commandNotes = Maybe (String -> String)
forall a. Maybe a
Nothing
, commandDefaultFlags :: (ProjectFlags, CleanFlags)
commandDefaultFlags = (ProjectFlags
defaultProjectFlags, CleanFlags
defaultCleanFlags)
, commandOptions :: ShowOrParseArgs -> [OptionField (ProjectFlags, CleanFlags)]
commandOptions = \ShowOrParseArgs
showOrParseArgs ->
(OptionField ProjectFlags
-> OptionField (ProjectFlags, CleanFlags))
-> [OptionField ProjectFlags]
-> [OptionField (ProjectFlags, CleanFlags)]
forall a b. (a -> b) -> [a] -> [b]
map
(ALens' (ProjectFlags, CleanFlags) ProjectFlags
-> OptionField ProjectFlags
-> OptionField (ProjectFlags, CleanFlags)
forall b a. ALens' b a -> OptionField a -> OptionField b
liftOptionL ALens' (ProjectFlags, CleanFlags) ProjectFlags
forall a c b (f :: * -> *).
Functor f =>
LensLike f (a, c) (b, c) a b
_1)
([OptionField ProjectFlags] -> [OptionField ProjectFlags]
forall a. [OptionField a] -> [OptionField a]
removeIgnoreProjectOption (ShowOrParseArgs -> [OptionField ProjectFlags]
projectFlagsOptions ShowOrParseArgs
showOrParseArgs))
[OptionField (ProjectFlags, CleanFlags)]
-> [OptionField (ProjectFlags, CleanFlags)]
-> [OptionField (ProjectFlags, CleanFlags)]
forall a. [a] -> [a] -> [a]
++ (OptionField CleanFlags -> OptionField (ProjectFlags, CleanFlags))
-> [OptionField CleanFlags]
-> [OptionField (ProjectFlags, CleanFlags)]
forall a b. (a -> b) -> [a] -> [b]
map (ALens' (ProjectFlags, CleanFlags) CleanFlags
-> OptionField CleanFlags -> OptionField (ProjectFlags, CleanFlags)
forall b a. ALens' b a -> OptionField a -> OptionField b
liftOptionL ALens' (ProjectFlags, CleanFlags) CleanFlags
forall c a b (f :: * -> *).
Functor f =>
LensLike f (c, a) (c, b) a b
_2) (ShowOrParseArgs -> [OptionField CleanFlags]
cleanOptions ShowOrParseArgs
showOrParseArgs)
}
cleanOptions :: ShowOrParseArgs -> [OptionField CleanFlags]
cleanOptions :: ShowOrParseArgs -> [OptionField CleanFlags]
cleanOptions 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 = v})
, (CleanFlags -> Flag String)
-> (Flag String -> CleanFlags -> CleanFlags)
-> ShowOrParseArgs
-> OptionField CleanFlags
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 = dd})
ShowOrParseArgs
showOrParseArgs
, String
-> LFlags
-> String
-> (CleanFlags -> Flag Bool)
-> (Flag Bool -> CleanFlags -> CleanFlags)
-> MkOptDescr
(CleanFlags -> Flag Bool)
(Flag Bool -> CleanFlags -> CleanFlags)
CleanFlags
-> OptionField CleanFlags
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 = sc})
MkOptDescr
(CleanFlags -> Flag Bool)
(Flag Bool -> CleanFlags -> CleanFlags)
CleanFlags
forall a. MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
falseArg
]
cleanAction :: (ProjectFlags, CleanFlags) -> [String] -> GlobalFlags -> IO ()
cleanAction :: (ProjectFlags, CleanFlags) -> LFlags -> GlobalFlags -> IO ()
cleanAction (ProjectFlags{Flag Bool
Flag String
flagProjectDir :: Flag String
flagProjectFile :: Flag String
flagIgnoreProject :: Flag Bool
flagIgnoreProject :: ProjectFlags -> Flag Bool
flagProjectFile :: ProjectFlags -> Flag String
flagProjectDir :: ProjectFlags -> Flag String
..}, CleanFlags{Flag Bool
Flag String
Flag Verbosity
cleanSaveConfig :: CleanFlags -> Flag Bool
cleanVerbosity :: CleanFlags -> Flag Verbosity
cleanDistDir :: CleanFlags -> Flag String
cleanSaveConfig :: Flag Bool
cleanVerbosity :: Flag Verbosity
cleanDistDir :: Flag String
..}) 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 String
mdistDirectory = Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe Flag String
cleanDistDir
mprojectDir :: Maybe String
mprojectDir = Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe Flag String
flagProjectDir
mprojectFile :: Maybe String
mprojectFile = Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe Flag String
flagProjectFile
notScripts <- (String -> IO Bool) -> LFlags -> IO LFlags
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Bool -> Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (IO Bool -> IO Bool) -> (String -> IO Bool) -> String -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Bool
doesFileExist) LFlags
extraArgs
unless (null notScripts) $
dieWithException verbosity $
CleanAction notScripts
projectRoot <- either throwIO return =<< findProjectRoot verbosity mprojectDir mprojectFile
let distLayout = ProjectRoot -> Maybe String -> Maybe String -> DistDirLayout
defaultDistDirLayout ProjectRoot
projectRoot Maybe String
mdistDirectory Maybe String
forall a. Maybe a
Nothing
when (null extraArgs || isJust mdistDirectory) $ do
if saveConfig
then do
let buildRoot = DistDirLayout -> String
distBuildRootDirectory DistDirLayout
distLayout
buildRootExists <- doesDirectoryExist buildRoot
when buildRootExists $ do
info verbosity ("Deleting build root (" ++ buildRoot ++ ")")
handleDoesNotExist () $ removeDirectoryRecursive buildRoot
else do
let distRoot = DistDirLayout -> String
distDirectory DistDirLayout
distLayout
info verbosity ("Deleting dist-newstyle (" ++ distRoot ++ ")")
handleDoesNotExist () $ removeDirectoryRecursive distRoot
removeEnvFiles (distProjectRootDirectory distLayout)
toClean <- Set.fromList <$> mapM canonicalizePath extraArgs
cacheDir <- defaultScriptBuildsDir
existsCD <- doesDirectoryExist cacheDir
caches <- if existsCD then listDirectory cacheDir else return []
paths <- fmap concat . forM caches $ \String
cache -> do
let locFile :: String
locFile = String
cacheDir String -> String -> String
</> String
cache String -> String -> String
</> String
"scriptlocation"
exists <- String -> IO Bool
doesFileExist String
locFile
if exists then pure . (,) (cacheDir </> cache) <$> readFile locFile else return []
forM_ paths $ \(String
cache, String
script) -> do
exists <- String -> IO Bool
doesFileExist String
script
when (not exists || script `Set.member` toClean) $ do
info verbosity ("Deleting cache (" ++ cache ++ ") for script (" ++ script ++ ")")
removeDirectoryRecursive cache
removeEnvFiles :: FilePath -> IO ()
removeEnvFiles :: String -> IO ()
removeEnvFiles String
dir =
((String -> IO ()) -> LFlags -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (String -> IO ()
removeFile (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
dir String -> String -> String
</>)) (LFlags -> IO ()) -> (LFlags -> LFlags) -> LFlags -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> LFlags -> LFlags
forall a. (a -> Bool) -> [a] -> [a]
filter ((String
".ghc.environment" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> Bool) -> (String -> String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
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
=<< String -> IO LFlags
getDirectoryContents String
dir