forked from haskell/cabal
/
CmdClean.hs
107 lines (92 loc) · 3.95 KB
/
CmdClean.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
{-# 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.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, wrapText )
import Distribution.Verbosity
( Verbosity, normal )
import Control.Exception
( throwIO )
import System.Directory
( removeDirectoryRecursive, doesDirectoryExist )
data CleanFlags = CleanFlags
{ cleanSaveConfig :: Flag Bool
, cleanVerbosity :: Flag Verbosity
, cleanDistDir :: Flag FilePath
, cleanProjectFile :: Flag FilePath
} deriving (Eq)
defaultCleanFlags :: CleanFlags
defaultCleanFlags = CleanFlags
{ cleanSaveConfig = toFlag False
, cleanVerbosity = toFlag normal
, cleanDistDir = NoFlag
, cleanProjectFile = mempty
}
cleanCommand :: CommandUI CleanFlags
cleanCommand = CommandUI
{ commandName = "new-clean"
, commandSynopsis = "Clean the package store and remove temporary files."
, commandUsage = \pname ->
"Usage: " ++ pname ++ " new-clean [FLAGS]\n"
, commandDescription = Just $ \_ -> wrapText $
"Removes all temporary files created during the building process "
++ "(.hi, .o, preprocessed sources, etc.) and also empties out the "
++ "local caches (by default).\n\n"
, commandNotes = Nothing
, commandDefaultFlags = defaultCleanFlags
, commandOptions = \showOrParseArgs ->
[ optionVerbosity
cleanVerbosity (\v flags -> flags { cleanVerbosity = v })
, optionDistPref
cleanDistDir (\dd flags -> flags { cleanDistDir = dd })
showOrParseArgs
, option [] ["project-file"]
"Set the name of the cabal.project file to search for in parent directories"
cleanProjectFile (\pf flags -> flags {cleanProjectFile = pf})
(reqArg "FILE" (succeedReadE Flag) flagToList)
, option ['s'] ["save-config"]
"Save configuration, only remove build artifacts"
cleanSaveConfig (\sc flags -> flags { cleanSaveConfig = sc })
falseArg
]
}
cleanAction :: CleanFlags -> [String] -> GlobalFlags -> IO ()
cleanAction CleanFlags{..} extraArgs _ = do
let verbosity = fromFlagOrDefault normal cleanVerbosity
saveConfig = fromFlagOrDefault False cleanSaveConfig
mdistDirectory = flagToMaybe cleanDistDir
mprojectFile = flagToMaybe cleanProjectFile
unless (null extraArgs) $
die' verbosity $ "'clean' doesn't take any extra arguments: " ++ unwords extraArgs
projectRoot <- either throwIO return =<< findProjectRoot Nothing mprojectFile
let distLayout = defaultDistDirLayout projectRoot mdistDirectory
if saveConfig
then do
let buildRoot = distBuildRootDirectory distLayout
unpackedSrcRoot = distUnpackedSrcRootDirectory distLayout
buildRootExists <- doesDirectoryExist buildRoot
unpackedSrcRootExists <- doesDirectoryExist unpackedSrcRoot
when buildRootExists $ do
info verbosity ("Deleting build root (" ++ buildRoot ++ ")")
removeDirectoryRecursive buildRoot
when unpackedSrcRootExists $ do
info verbosity ("Deleting unpacked source root (" ++ unpackedSrcRoot ++ ")")
removeDirectoryRecursive unpackedSrcRoot
else do
let distRoot = distDirectory distLayout
info verbosity ("Deleting dist-newstyle (" ++ distRoot ++ ")")
removeDirectoryRecursive distRoot