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