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