{-# LANGUAGE DataKinds #-}
{-# 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.Utils.Path hiding
  ( (<.>)
  , (</>)
  )
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 (SymbolicPath Pkg ('Dir Dist))
cleanDistDir :: Flag (SymbolicPath Pkg (Dir Dist))
  }
  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 (SymbolicPath Pkg ('Dir Dist))
cleanDistDir = Flag (SymbolicPath Pkg ('Dir Dist))
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 (SymbolicPath Pkg ('Dir Dist)))
-> (Flag (SymbolicPath Pkg ('Dir Dist))
    -> CleanFlags -> CleanFlags)
-> ShowOrParseArgs
-> OptionField CleanFlags
forall flags.
(flags -> Flag (SymbolicPath Pkg ('Dir Dist)))
-> (Flag (SymbolicPath Pkg ('Dir Dist)) -> flags -> flags)
-> ShowOrParseArgs
-> OptionField flags
optionDistPref
      CleanFlags -> Flag (SymbolicPath Pkg ('Dir Dist))
cleanDistDir
      (\Flag (SymbolicPath Pkg ('Dir Dist))
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
flagProjectDir :: ProjectFlags -> Flag String
flagProjectFile :: ProjectFlags -> Flag String
flagIgnoreProject :: ProjectFlags -> Flag Bool
..}, CleanFlags{Flag Bool
Flag Verbosity
Flag (SymbolicPath Pkg ('Dir Dist))
cleanSaveConfig :: CleanFlags -> Flag Bool
cleanVerbosity :: CleanFlags -> Flag Verbosity
cleanDistDir :: CleanFlags -> Flag (SymbolicPath Pkg ('Dir Dist))
cleanSaveConfig :: Flag Bool
cleanVerbosity :: Flag Verbosity
cleanDistDir :: Flag (SymbolicPath Pkg ('Dir Dist))
..}) 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 = (SymbolicPath Pkg ('Dir Dist) -> String)
-> Maybe (SymbolicPath Pkg ('Dir Dist)) -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SymbolicPath Pkg ('Dir Dist) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath (Maybe (SymbolicPath Pkg ('Dir Dist)) -> Maybe String)
-> Maybe (SymbolicPath Pkg ('Dir Dist)) -> Maybe String
forall a b. (a -> b) -> a -> b
$ Flag (SymbolicPath Pkg ('Dir Dist))
-> Maybe (SymbolicPath Pkg ('Dir Dist))
forall a. Flag a -> Maybe a
flagToMaybe Flag (SymbolicPath Pkg ('Dir Dist))
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

  -- TODO interpret extraArgs as targets and clean those targets only (issue #7506)
  --
  -- For now assume all files passed are the names of scripts
  LFlags
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
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LFlags -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null LFlags
notScripts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$
      LFlags -> CabalInstallException
CleanAction 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 a. a -> IO a
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
=<< Verbosity
-> Maybe String
-> Maybe String
-> IO (Either BadProjectRoot ProjectRoot)
findProjectRoot Verbosity
verbosity Maybe String
mprojectDir Maybe String
mprojectFile

  let distLayout :: DistDirLayout
distLayout = ProjectRoot -> Maybe String -> Maybe String -> DistDirLayout
defaultDistDirLayout ProjectRoot
projectRoot Maybe String
mdistDirectory Maybe String
forall a. Maybe a
Nothing

  -- Do not clean a project if just running a script in it's directory
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LFlags -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null LFlags
extraArgs Bool -> Bool -> Bool
|| Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
mdistDirectory) (IO () -> IO ()) -> IO () -> IO ()
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

        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 -> String -> IO ()
info Verbosity
verbosity (String
"Deleting build root (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
buildRoot String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
          () -> IO () -> IO ()
forall a. a -> IO a -> IO a
handleDoesNotExist () (IO () -> IO ()) -> IO () -> IO ()
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 (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
distRoot String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
        () -> IO () -> IO ()
forall a. a -> IO a -> IO a
handleDoesNotExist () (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeDirectoryRecursive String
distRoot

    String -> IO ()
removeEnvFiles (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ DistDirLayout -> String
distProjectRootDirectory DistDirLayout
distLayout

  -- Clean specified script build caches and orphaned caches.
  -- There is currently no good way to specify to only clean orphaned caches.
  -- It would be better as part of an explicit gc step (see issue #3333)
  Set String
toClean <- LFlags -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList (LFlags -> Set String) -> IO LFlags -> IO (Set String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO String) -> LFlags -> IO LFlags
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 LFlags -> IO LFlags
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  [(String, String)]
paths <- ([[(String, String)]] -> [(String, String)])
-> IO [[(String, String)]] -> IO [(String, String)]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[(String, String)]] -> [(String, String)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[(String, String)]] -> IO [(String, String)])
-> ((String -> IO [(String, String)]) -> IO [[(String, String)]])
-> (String -> IO [(String, String)])
-> IO [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LFlags
-> (String -> IO [(String, String)]) -> IO [[(String, String)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM LFlags
caches ((String -> IO [(String, String)]) -> IO [(String, String)])
-> (String -> IO [(String, String)]) -> IO [(String, String)]
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 (String, String) -> [(String, String)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String, String) -> [(String, String)])
-> (String -> (String, String)) -> String -> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) (String
cacheDir String -> String -> String
</> String
cache) (String -> [(String, String)])
-> IO String -> IO [(String, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
locFile else [(String, String)] -> IO [(String, String)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  [(String, String)] -> ((String, String) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, String)]
paths (((String, String) -> IO ()) -> IO ())
-> ((String, String) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(String
cache, String
script) -> do
    Bool
exists <- String -> IO Bool
doesFileExist String
script
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
exists Bool -> Bool -> Bool
|| String
script String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
toClean) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Verbosity -> String -> IO ()
info Verbosity
verbosity (String
"Deleting cache (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cache String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") for script (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
script String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
      String -> IO ()
removeDirectoryRecursive String
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