diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Release history for stack-clean-old-work +## 0.4 (2021-09-26) +- dryrun is now default: use --delete for actual removal + (suggested by @andreasabel #6) +- new --subdirs and --recursive options +- various output improvements +- purge-older now also says "would be removed" when dryrun + ## 0.3.1 (2021-08-01) - 'delete-work': use find -prune and ignore inaccessible files (@petrem, #4) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,7 +5,7 @@ ## Usage ``` -stack-clean-old [size|list|remove|keep-minor|purge-older|delete-work] [(-p|--project) | (-g|--ghc)] [GHCVER] +stack-clean-old [size|list|remove|keep-minor|purge-older|delete-work] [(-p|--project) | (-g|--ghc)] [--delete] [GHCVER] ``` Options: @@ -26,7 +26,7 @@ removes for the specified ghc version (the GHCVER argument is required). `keep-minor`: - removes the builds/installs for previous minor ghc versions. + removes the builds/installs for older minor releases of ghc major versions. If GHCVER is given then only minor versions older than it are removed. `purge-older` and `delete-work`: @@ -36,8 +36,9 @@ then you would have to rebuild them again for any projects still using them, so removal should be used cautiously, but it can recover a lot of diskspace. -NBB: All the command support `--dry-run` (`-n`), so please use it to -check the effect of running them safely beforehand. +Since version 0.4 dry-run mode is now the default and one needs to use +`--delete` (`-d`) for actual deletion of files, +after checking the dry-run output first. ### Example usage To remove project builds for ghc-8.2.2: @@ -46,7 +47,7 @@ 154M 8.2.2 (5 dirs) 154M 8.4.4 (5 dirs) 163M 8.6.5 (5 dirs) -$ stack-clean-old remove -p 8.2.2 +$ stack-clean-old remove --delete -p 8.2.2 ``` Remove stack ghc-8.4 snapshot builds and compilers before 8.4.4: @@ -56,7 +57,7 @@ 368M 8.4.2 (6 dirs) 489M 8.4.3 (8 dirs) 799M 8.4.4 (24 dirs) -$ stack-clean-old keep-minor -g 8.4.4 +$ stack-clean-old keep-minor -d -g 8.4.4 ghc-tinfo6-8.4.3 removed 7 dirs removed for 8.4.1 6 dirs removed for 8.4.2 @@ -82,7 +83,7 @@ (seems same as `stack clean --full`). `stack-clean-old delete-work --all` works from outside stack projects: -please test with `--dry-run` first. +please use with care. ## Installation @@ -92,12 +93,16 @@ This tool complements [stack-all](https://hackage.haskell.org/package/stack-all) which builds projects over LTS major versions and hence generates lot of stack builds. +[cabal-clean](https://hackage.haskell.org/package/cabal-clean) is +a similar tool for cleaning old cached cabal build files. + ## Contributing BSD license Project: https://github.com/juhp/stack-clean-old ## Warning disclaimer -Use at your own risk: the author takes no responsibility for any loss or damaged caused by using this tool, as also mentioned in LICENSE. +Use at your own risk: the author takes no responsibility for any loss or +damaged caused by using this tool. Bug reports, suggestions, and improvements are welcome. diff --git a/src/Directories.hs b/src/Directories.hs --- a/src/Directories.hs +++ b/src/Directories.hs @@ -5,7 +5,6 @@ ) where -import Control.Monad.Extra import Data.List.Extra import SimpleCmd (error') import System.Directory @@ -23,14 +22,16 @@ switchToSystemDirUnder :: FilePath -> IO () switchToSystemDirUnder dir = do - ifM (doesDirectoryExist dir) - (setCurrentDirectory dir) - (error' $ dir ++ " not found") + exists <- doesDirectoryExist dir + if exists + then setCurrentDirectory dir + else error' $ dir ++ " not found" systems <- listDirectory "." -- FIXME be more precise/check "system" dirs -- eg 64bit intel Linux: x86_64-linux-tinfo6 - let system = case systems of - [] -> error' $ "No OS system in " ++ dir - [sys] -> sys - _ -> error' "More than one OS systems found " ++ dir ++ " (unsupported)" + let system = + case systems of + [] -> error' $ "No OS system in " ++ dir + [sys] -> sys + _ -> error' "More than one OS systems found " ++ dir ++ " (unsupported)" setCurrentDirectory system diff --git a/src/GHC.hs b/src/GHC.hs --- a/src/GHC.hs +++ b/src/GHC.hs @@ -14,6 +14,7 @@ import Directories (getStackSubdir, globDirs, switchToSystemDirUnder) import qualified Remove +import Types import Versions getStackProgramsDir :: IO FilePath @@ -51,31 +52,31 @@ Nothing -> dirs Just ghcver -> filter ((== ghcver) . (if isMajorVersion ghcver then majorVersion else id) . ghcInstallVersion) dirs -removeGhcVersionInstallation :: Bool -> Version -> IO () -removeGhcVersionInstallation dryrun ghcver = do +removeGhcVersionInstallation :: Deletion -> Version -> IO () +removeGhcVersionInstallation deletion ghcver = do installs <- getGhcInstallDirs (Just ghcver) case installs of [] -> putStrLn $ "stack ghc compiler version " ++ showVersion ghcver ++ " not found" - [g] | not (isMajorVersion ghcver) -> doRemoveGhcVersion dryrun g + [g] | not (isMajorVersion ghcver) -> doRemoveGhcVersion deletion g gs -> if isMajorVersion ghcver then do - Remove.prompt dryrun ("all stack ghc " ++ showVersion ghcver ++ " installations: ") - mapM_ (doRemoveGhcVersion dryrun) gs + Remove.prompt deletion ("all stack ghc " ++ showVersion ghcver ++ " installations: ") + mapM_ (doRemoveGhcVersion deletion) gs else error' "more than one match found!!" -removeGhcMinorInstallation :: Bool -> Maybe Version -> IO () -removeGhcMinorInstallation dryrun mghcver = do +removeGhcMinorInstallation :: Deletion -> Maybe Version -> IO () +removeGhcMinorInstallation deletion mghcver = do dirs <- getGhcInstallDirs (majorVersion <$> mghcver) case mghcver of Nothing -> do let majors = groupOn (majorVersion . ghcInstallVersion) dirs forM_ majors $ \ minors -> - forM_ (init minors) $ doRemoveGhcVersion dryrun + forM_ (init minors) $ doRemoveGhcVersion deletion Just ghcver -> do let minors = filter ((< ghcver) . ghcInstallVersion) dirs - forM_ minors $ doRemoveGhcVersion dryrun + forM_ minors $ doRemoveGhcVersion deletion -doRemoveGhcVersion :: Bool -> FilePath -> IO () -doRemoveGhcVersion dryrun ghcinst = do - Remove.doRemoveDirectory dryrun ghcinst - Remove.removeFile dryrun (ghcinst <.> "installed") - putStrLn $ ghcinst ++ " compiler " ++ (if dryrun then "would be " else "") ++ "removed" +doRemoveGhcVersion :: Deletion -> FilePath -> IO () +doRemoveGhcVersion deletion ghcinst = do + Remove.doRemoveDirectory deletion ghcinst + Remove.removeFile deletion (ghcinst <.> "installed") + putStrLn $ ghcinst ++ " compiler " ++ (if isDelete deletion then "" else "would be ") ++ "removed" diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -5,18 +5,28 @@ #if !MIN_VERSION_simple_cmd_args(0,1,3) import Control.Applicative ((<|>)) #endif +import Control.Monad +import qualified Data.List as L +import Data.List.Extra +import Data.Maybe import Data.Version.Extra +import Numeric.Natural import SimpleCmd import SimpleCmdArgs import System.Directory +import System.FilePath import System.IO (BufferMode(NoBuffering), hSetBuffering, stdout) import GHC import Paths_stack_clean_old (version) import Snapshots +import Types data Mode = Default | Project | Snapshots | Compilers | GHC +data Recursion = Subdirs | Recursive + deriving Eq + main :: IO () main = do hSetBuffering stdout NoBuffering @@ -24,93 +34,158 @@ "Cleans away old stack-work builds (and pending: stack snapshots) to recover diskspace." $ subcommands [ Subcommand "size" "Total size" $ - sizeCmd <$> modeOpt <*> notHumanOpt + sizeCmd <$> modeOpt <*> recursionOpt <*> notHumanOpt , Subcommand "list" "List sizes per ghc version" $ - listCmd <$> modeOpt <*> optional ghcVerArg + listCmd <$> modeOpt <*> recursionOpt <*> optional ghcVerArg , Subcommand "remove" "Remove for a ghc version" $ - removeCmd <$> dryrun <*> modeOpt <*> ghcVerArg + removeCmd <$> deleteOpt <*> modeOpt <*> recursionOpt <*> ghcVerArg , Subcommand "keep-minor" "Remove for previous ghc minor versions" $ - removeMinorsCmd <$> dryrun <*> modeOpt <*> optional ghcVerArg + removeMinorsCmd <$> deleteOpt <*> modeOpt <*> recursionOpt <*> optional ghcVerArg , Subcommand "purge-older" "Purge older builds in .stack-work/install" $ - cleanOldStackWork <$> dryrun <*> keepOption + purgeOlderCmd <$> deleteOpt <*> keepOption <*> recursionOpt , Subcommand "delete-work" "Remove project's .stack-work subdirs recursively" $ - removeStackWorks <$> dryrun <*> switchWith 'a' "all" "Find all .stack-work/ subdirs, even if current directory not a stack project" + deleteWorkCmd <$> deleteOpt <*> recursionOpt ] where modeOpt = - flagWith' Project 'p' "project" "Act on current project's .stack-work/ [default in project dir]" <|> - flagWith' GHC 'g' "global" "Act on both ~/.stack/{programs,snapshots}/ [default outside project dir]" <|> - flagWith' Snapshots 's' "snapshots" "Act on ~/.stack/snapshots/" <|> - flagWith Default Compilers 'c' "compilers" "Act on ~/.stack/programs/" + flagWith' Project 'P' "project" "Act on current project's .stack-work/ [default in project dir]" <|> + flagWith' GHC 'G' "global" "Act on both ~/.stack/{programs,snapshots}/ [default outside project dir]" <|> + flagWith' Snapshots 'S' "snapshots" "Act on ~/.stack/snapshots/" <|> + flagWith Default Compilers 'C' "compilers" "Act on ~/.stack/programs/" - dryrun = switchWith 'n' "dry-run" "Show what would be done, without removing" + deleteOpt = flagWith Dryrun Delete 'd' "delete" "Do deletion [default is dryrun]" + recursionOpt = + optional ( + flagWith' Subdirs 's' "subdirs" "List subdirectories" + <|> flagWith' Recursive 'r' "recursive" "List subdirectories") + notHumanOpt = switchWith 'H' "not-human-size" "Do not use du --human-readable" ghcVerArg = readVersion <$> strArg "GHCVER" - keepOption = positive <$> optionalWith auto 'k' "keep" "INT" "number of project builds per ghc version [default 5]" 5 + keepOption = optionalWith auto 'k' "keep" "INT" "number of project builds per ghc version [default 5]" 5 - positive :: Int -> Int - positive n = if n > 0 then n else error' "Must be positive integer" +withRecursion :: Maybe Recursion -> IO () -> IO () +withRecursion mrecursion act = do + case mrecursion of + Just recursion -> do + dirs <- if recursion == Recursive + then map takeDirectory <$> findStackWorks + else listStackSubdirs + forM_ dirs $ \dir -> + withCurrentDirectory dir $ do + putStrLn $ "\n" ++ takeFileName dir + act + Nothing -> act -sizeCmd :: Mode -> Bool -> IO () -sizeCmd mode notHuman = +withRecursion' :: Maybe Recursion -> (FilePath -> IO ()) -> IO () +withRecursion' mrecursion act = do + case mrecursion of + Just recursion -> do + dirs <- if recursion == Recursive + then map (dropPrefix "./" . takeDirectory) <$> findStackWorks + else listStackSubdirs + mapM_ act dirs + Nothing -> act "" + +sizeCmd :: Mode -> Maybe Recursion -> Bool -> IO () +sizeCmd mode mrecursion notHuman = + withRecursion' mrecursion $ \dir -> case mode of - Project -> sizeStackWork notHuman + Project -> sizeStackWork notHuman dir Snapshots -> sizeSnapshots notHuman Compilers -> sizeGhcInstalls notHuman GHC -> do - sizeCmd Compilers notHuman - sizeCmd Snapshots notHuman - Default -> do + sizeCmd Compilers Nothing notHuman + sizeCmd Snapshots Nothing notHuman + Default -> + if isJust mrecursion + then sizeStackWork notHuman dir + else do isProject <- doesDirectoryExist ".stack-work" if isProject - then sizeCmd Project notHuman - else sizeCmd GHC notHuman + then sizeCmd Project Nothing notHuman + else sizeCmd GHC Nothing notHuman -listCmd :: Mode -> Maybe Version -> IO () -listCmd mode mver = +listCmd :: Mode -> Maybe Recursion -> Maybe Version -> IO () +listCmd mode mrecursion mver = + withRecursion mrecursion $ case mode of - Project -> listGhcSnapshots setStackWorkDir mver - Snapshots -> listGhcSnapshots setStackSnapshotsDir mver + Project -> setStackWorkInstallDir >> listGhcSnapshots mver + Snapshots -> setStackSnapshotsDir >> listGhcSnapshots mver Compilers -> listGhcInstallation mver GHC -> do - listCmd Compilers mver - listCmd Snapshots mver + listCmd Compilers Nothing mver + listCmd Snapshots Nothing mver Default -> do isProject <- doesDirectoryExist ".stack-work" if isProject - then listCmd Project mver - else listCmd GHC mver + then listCmd Project Nothing mver + else listCmd GHC Nothing mver -removeCmd :: Bool -> Mode -> Version -> IO () -removeCmd dryrun mode ghcver = +removeCmd :: Deletion -> Mode -> Maybe Recursion -> Version -> IO () +removeCmd deletion mode mrecursion ghcver = + withRecursion mrecursion $ case mode of - Project -> cleanGhcSnapshots setStackWorkDir dryrun ghcver - Snapshots -> cleanGhcSnapshots setStackSnapshotsDir dryrun ghcver - Compilers -> removeGhcVersionInstallation dryrun ghcver + Project -> do + cwd <- getCurrentDirectory + setStackWorkInstallDir + cleanGhcSnapshots deletion cwd ghcver + Snapshots -> do + cwd <- getCurrentDirectory + setStackSnapshotsDir + cleanGhcSnapshots deletion cwd ghcver + Compilers -> removeGhcVersionInstallation deletion ghcver GHC -> do - removeCmd dryrun Compilers ghcver - removeCmd dryrun Snapshots ghcver + removeCmd deletion Compilers Nothing ghcver + removeCmd deletion Snapshots Nothing ghcver Default -> do isProject <- doesDirectoryExist ".stack-work" if isProject - then removeCmd dryrun Project ghcver - else removeCmd dryrun GHC ghcver + then removeCmd deletion Project Nothing ghcver + else removeCmd deletion GHC Nothing ghcver -removeMinorsCmd :: Bool -> Mode -> Maybe Version -> IO () -removeMinorsCmd dryrun mode mver = +removeMinorsCmd :: Deletion -> Mode -> Maybe Recursion -> Maybe Version + -> IO () +removeMinorsCmd deletion mode mrecursion mver = + withRecursion mrecursion $ case mode of - Project -> cleanMinorSnapshots setStackWorkDir dryrun mver - Snapshots -> cleanMinorSnapshots setStackSnapshotsDir dryrun mver - Compilers -> removeGhcMinorInstallation dryrun mver + Project -> do + cwd <- getCurrentDirectory + setStackWorkInstallDir + cleanMinorSnapshots deletion cwd mver + Snapshots -> do + cwd <- getCurrentDirectory + setStackSnapshotsDir + cleanMinorSnapshots deletion cwd mver + Compilers -> removeGhcMinorInstallation deletion mver GHC -> do - removeMinorsCmd dryrun Compilers mver - removeMinorsCmd dryrun Snapshots mver + removeMinorsCmd deletion Compilers Nothing mver + removeMinorsCmd deletion Snapshots Nothing mver Default -> do isProject <- doesDirectoryExist ".stack-work" if isProject - then removeMinorsCmd dryrun Project mver - else removeMinorsCmd dryrun GHC mver + then removeMinorsCmd deletion Project Nothing mver + else removeMinorsCmd deletion GHC Nothing mver + +purgeOlderCmd :: Deletion -> Natural -> Maybe Recursion -> IO () +purgeOlderCmd deletion keep mrecursion = + withRecursion mrecursion $ + cleanOldStackWork deletion keep + +deleteWorkCmd :: Deletion -> Maybe Recursion -> IO () +deleteWorkCmd deletion mrecursion = + withRecursion mrecursion $ + removeStackWork deletion + +findStackWorks :: IO [FilePath] +findStackWorks = + -- ignore find errors (e.g. access rights) + cmdIgnoreErr "find" [".", "-type", "d", "-name", ".stack-work", "-prune"] [] + >>= fmap L.sort . filterM (doesDirectoryExist . ( "install")) . lines + +listStackSubdirs :: IO [FilePath] +listStackSubdirs = + listDirectory "." >>= filterM (\f -> doesDirectoryExist (f ".stack-work")) . L.sort diff --git a/src/Remove.hs b/src/Remove.hs --- a/src/Remove.hs +++ b/src/Remove.hs @@ -8,19 +8,21 @@ import Control.Monad.Extra import qualified System.Directory as D -doRemoveDirectory :: Bool -> FilePath -> IO () -doRemoveDirectory dryrun dir = - unless dryrun $ +import Types + +doRemoveDirectory :: Deletion -> FilePath -> IO () +doRemoveDirectory deletion dir = + when (isDelete deletion) $ D.removeDirectoryRecursive dir -removeFile :: Bool -> FilePath -> IO () -removeFile dryrun file = - unless dryrun $ +removeFile :: Deletion -> FilePath -> IO () +removeFile deletion file = + when (isDelete deletion) $ whenM (D.doesFileExist file) $ D.removeFile file -prompt :: Bool -> String -> IO () -prompt dryrun str = - unless dryrun $ do +prompt :: Deletion -> String -> IO () +prompt deletion str = + when (isDelete deletion) $ do putStr $ "Press Enter to delete " ++ str ++ ": " void getLine diff --git a/src/Snapshots.hs b/src/Snapshots.hs --- a/src/Snapshots.hs +++ b/src/Snapshots.hs @@ -8,16 +8,17 @@ cleanOldStackWork, listGhcSnapshots, setStackSnapshotsDir, - setStackWorkDir, + setStackWorkInstallDir, sizeSnapshots, sizeStackWork, - removeStackWorks + removeStackWork ) where import Control.Monad.Extra import Data.List.Extra import Data.Version.Extra +import Numeric.Natural import SimpleCmd #if MIN_VERSION_simple_cmd(0,2,1) hiding (whenM) @@ -28,6 +29,7 @@ import Directories (globDirs, getStackSubdir, switchToSystemDirUnder) import qualified Remove +import Types import Versions data SnapshotInstall = @@ -79,46 +81,54 @@ snapshots <- getStackSubdir "snapshots" cmd_ "du" $ ["-h" | not nothuman] ++ ["-s", snapshots] -listGhcSnapshots :: IO () -> Maybe Version -> IO () -listGhcSnapshots setdir mghcver = do - setdir +listGhcSnapshots :: Maybe Version -> IO () +listGhcSnapshots mghcver = do ghcs <- getSnapshotDirs mghcver mapM_ printTotalGhcSize ghcs -removeVersionSnaps :: Bool -> VersionSnapshots -> IO () -removeVersionSnaps dryrun versnap = do +plural :: String -> Int -> String +plural thing n = show n ++ " " ++ thing ++ if n == 1 then "" else "s" + +removeVersionSnaps :: Deletion -> FilePath -> VersionSnapshots -> IO () +removeVersionSnaps deletion cwd versnap = do let dirs = snapsHashes versnap - mapM_ (Remove.doRemoveDirectory dryrun) dirs - putStrLn $ show (length dirs) ++ " dirs in ~/.stack/snapshots/ " ++ (if dryrun then "would be " else "") ++ "removed for " ++ showVersion (snapsVersion versnap) + dir <- getCurrentDirectory + home <- getHomeDirectory + putStrLn $ plural "dir" (length dirs) ++ " in " ++ renderDir home dir ++ " " ++ (if isDelete deletion then "" else "would be ") ++ "removed for " ++ showVersion (snapsVersion versnap) + mapM_ (Remove.doRemoveDirectory deletion) dirs + where + renderDir :: FilePath -> FilePath -> FilePath + renderDir home fp = + case stripPrefix (cwd ++ "/") fp of + Just reldir -> reldir + Nothing -> "~" dropPrefix (home ++ "/") fp -cleanGhcSnapshots :: IO () -> Bool -> Version -> IO () -cleanGhcSnapshots setDir dryrun ghcver = do - setDir +cleanGhcSnapshots :: Deletion -> FilePath -> Version -> IO () +cleanGhcSnapshots deletion cwd ghcver = do ghcs <- getSnapshotDirs (Just ghcver) when (isMajorVersion ghcver) $ do - Remove.prompt dryrun ("all " ++ showVersion ghcver ++ " builds") - mapM_ (removeVersionSnaps dryrun) ghcs + Remove.prompt deletion ("all " ++ showVersion ghcver ++ " builds") + mapM_ (removeVersionSnaps deletion cwd) ghcs -cleanMinorSnapshots :: IO () -> Bool -> Maybe Version -> IO () -cleanMinorSnapshots setDir dryrun mghcver = do - setDir +cleanMinorSnapshots :: Deletion -> FilePath -> Maybe Version -> IO () +cleanMinorSnapshots deletion cwd mghcver = do ghcs <- getSnapshotDirs (majorVersion <$> mghcver) case mghcver of Nothing -> do let majors = groupOn (majorVersion . snapsVersion) ghcs forM_ majors $ \ gmajor -> when (length gmajor > 1) $ - mapM_ (removeVersionSnaps dryrun) (init gmajor) + mapM_ (removeVersionSnaps deletion cwd) (init gmajor) Just ghcver -> do let newestMinor = if isMajorVersion ghcver then (snapsVersion . last) ghcs else ghcver gminors = filter ((< newestMinor) . snapsVersion) ghcs - mapM_ (removeVersionSnaps dryrun) gminors + mapM_ (removeVersionSnaps deletion cwd) gminors -cleanOldStackWork :: Bool -> Int -> IO () -cleanOldStackWork dryrun keep = do - setStackWorkDir +cleanOldStackWork :: Deletion -> Natural -> IO () +cleanOldStackWork deletion keep = do + setStackWorkInstallDir dirs <- sortOn takeFileName . lines <$> shell ( unwords $ "ls" : ["-d", "*/*"]) let ghcs = groupOn takeFileName dirs mapM_ removeOlder ghcs @@ -126,10 +136,10 @@ removeOlder :: [FilePath] -> IO () removeOlder dirs = do let ghcver = (takeFileName . head) dirs - oldfiles <- drop keep . reverse <$> sortedByAge - mapM_ (Remove.doRemoveDirectory dryrun . takeDirectory) oldfiles + oldfiles <- drop (fromEnum keep) . reverse <$> sortedByAge + mapM_ (Remove.doRemoveDirectory deletion . takeDirectory) oldfiles unless (null oldfiles) $ - putStrLn $ show (length oldfiles) ++ " dirs removed for " ++ ghcver + putStrLn $ plural "dir" (length oldfiles) ++ (if isDelete deletion then "" else " would be") ++ " removed for " ++ ghcver where sortedByAge = do fileTimes <- mapM newestTimeStamp dirs @@ -144,9 +154,9 @@ stackWorkInstall :: FilePath stackWorkInstall = ".stack-work/install" -sizeStackWork :: Bool -> IO () -sizeStackWork nothuman = do - let path = stackWorkInstall +sizeStackWork :: Bool -> FilePath -> IO () +sizeStackWork nothuman dir = do + let path = dir ".stack-work" whenM (doesDirectoryExist path) $ cmd_ "du" $ ["-h" | not nothuman] ++ ["-s", path] @@ -155,24 +165,15 @@ total <- head . words . last <$> cmdLines "du" ("-shc":snapsHashes versnaps) printf "%4s %-6s (%d dirs)\n" total ((showVersion . snapsVersion) versnaps) (length (snapsHashes versnaps)) -setStackWorkDir :: IO () -setStackWorkDir = do +setStackWorkInstallDir :: IO () +setStackWorkInstallDir = do switchToSystemDirUnder stackWorkInstall setStackSnapshotsDir :: IO () setStackSnapshotsDir = do getStackSubdir "snapshots" >>= switchToSystemDirUnder -removeStackWorks :: Bool -> Bool -> IO () -removeStackWorks dryrun allrecurse = do - recurse <- - if allrecurse then return True - else doesDirectoryExist ".stack-work" - if recurse then do - -- ignore find errors (e.g. access rights) - workdirs <- sort . lines <$> cmdIgnoreErr "find" [".", "-type", "d", "-name", ".stack-work", "-prune"] [] - unless (null workdirs) $ do - mapM_ putStrLn workdirs - Remove.prompt dryrun "these dirs" - mapM_ (Remove.doRemoveDirectory dryrun) workdirs - else error' "run in a project dir (containing .stack-work/)\n or use --all to find and remove all .stack-work/ subdirectories" +removeStackWork :: Deletion -> IO () +removeStackWork deletion = do + Remove.prompt deletion "this dir" + Remove.doRemoveDirectory deletion ".stack-work" diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 --- /dev/null +++ b/src/Types.hs @@ -0,0 +1,11 @@ +module Types ( + Deletion (..), + isDelete + ) +where + +data Deletion = Dryrun | Delete + deriving Eq + +isDelete :: Deletion -> Bool +isDelete = (== Delete) diff --git a/stack-clean-old.cabal b/stack-clean-old.cabal --- a/stack-clean-old.cabal +++ b/stack-clean-old.cabal @@ -1,5 +1,5 @@ name: stack-clean-old -version: 0.3.1 +version: 0.4 synopsis: Clean away old stack build artefacts description: A tool for removing old .stack-work/install builds and @@ -29,6 +29,7 @@ GHC Remove Snapshots + Types Versions hs-source-dirs: src build-depends: base >= 4.8 && < 5