diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Release history for stack-clean-old +## 0.5 (2023-09-13) +- simpler dry run output and use simple-prompt yesNo +- add --yes option for --delete +- keep-minor: fix ghc minor version checks with major version + ## 0.4.8 (2023-08-26) - support the `STACK_ROOT` environment variable which overrides the default Stack root (`~/.stack`) by @PRESFIL (#12) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -36,13 +36,12 @@ `delete-work`: removes `.stack-work` directories completely -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. +dry-run mode is used by default and one should use `--delete` (`-d`) +for actual deletion of files, after checking the dry-run output. If you should remove any needed snapshot builds, then they will get rebuilt again by stack next time you build any projects -using them, so removals should be done carefully +needing them, so removals should be done carefully but can recover a lot of diskspace. Further the commands can use `--subdirs` or `--recursive` to run over @@ -58,9 +57,9 @@ List a project's builds: ```ShellSession $ stack-clean-old list -154M 9.2.8 (5 dirs) -154M 9.4.5 (5 dirs) -163M 9.6.2 (5 dirs) +149M 9.2.8 (5 dirs) +163M 9.4.7 (5 dirs) +155M 9.6.2 (5 dirs) ``` Remove project's 9.0.2 builds: ```ShellSession @@ -69,21 +68,32 @@ ``` (--project is optional in a project dir). -Remove stack ghc-9.4 snapshot builds and minor compilers before 9.4.4: +Remove stack ghc-9.4 snapshot builds and minor compilers before 9.4.7: ```ShellSession $ stack-clean-old list --global 9.4 -421M 9.4.1 (7 dirs) -368M 9.4.2 (6 dirs) -489M 9.4.3 (8 dirs) -799M 9.4.4 (24 dirs) -$ stack-clean-old keep-minor -d -g 9.4.4 -ghc-tinfo6-9.4.3 removed -7 dirs removed for 9.4.1 -6 dirs removed for 9.4.2 -8 dirs removed for 9.4.3 +x86_64-linux-tinfo6: +1.8G 9.4.6 (61 dirs) +279M 9.4.7 (6 dirs) +x86_64-linux: +ghc-tinfo6-9.4.6 +ghc-tinfo6-9.4.7 +$ stack-clean-old keep-minor --global 9.4 +ghc-tinfo6-9.4.6 compiler would be removed +x86_64-linux-tinfo6: +61 dirs in ~/.stack/snapshots/x86_64-linux-tinfo6/*/9.4.6 would be removed + +(use --delete (-d) for removal) +$ stack-clean-old keep-minor --global 9.4 -d +ghc-tinfo6-9.4.6 compiler removed +x86_64-linux-tinfo6: +61 dirs in ~/.stack/snapshots/x86_64-linux-tinfo6/*/9.4.6 removed ``` (--global is optional outside a project dir). +If you have different latest minor versions for compilers and snapshots +you may prefer to specify the latest minor version to keep +to get more certain behaviour. + ### Purging older stack project builds ``` stack-clean-old purge-older @@ -106,7 +116,7 @@ To get help you can run `stack-clean-old --help` or just: ```ShellSession $ stack-clean-old --version -0.4.8 +0.5 $ stack-clean-old Stack clean up tool @@ -135,7 +145,7 @@ ```shellsession $ stack-clean-old remove --help -Usage: stack-clean-old remove [-d|--delete] +Usage: stack-clean-old remove [(-d|--delete) [-y|--yes]] [(-P|--project) | (-S|--snapshots) | (-C|--compilers) | (-T|--tarballs) | (-G|--global)] @@ -146,6 +156,7 @@ Available options: -d,--delete Do deletion [default is dryrun] + -y,--yes Assume yes for all prompts -P,--project Act on current project's .stack-work/ [default in project dir] -S,--snapshots Act on ~/.stack/snapshots/ @@ -161,7 +172,7 @@ -h,--help Show this help text ``` -(The `list` and `size` commands don't have `--delete`.) +(The `list` and `size` commands don't have `--delete` and `--yes`.) ## Installation diff --git a/src/Directories.hs b/src/Directories.hs --- a/src/Directories.hs +++ b/src/Directories.hs @@ -12,7 +12,7 @@ import Control.Monad (forM_, unless, when) import Data.List.Extra -import SimpleCmd ( +import SimpleCmd ((+-+), #if MIN_VERSION_simple_cmd(0,2,0) warning #endif @@ -36,7 +36,7 @@ case mroot of Just path -> do unless (isAbsolute path) $ - warning $ "STACK_ROOT is not absolute: " ++ path + warning $ "STACK_ROOT is not absolute:" +-+ path return path Nothing -> do home <- getHomeDirectory @@ -78,7 +78,7 @@ if s `elem` platforms then return [s] else do - warning $ "no matching platform for: " ++ s + warning $ "no matching platform for:" +-+ s return [] listCurrentDirectory :: IO [FilePath] diff --git a/src/GHC.hs b/src/GHC.hs --- a/src/GHC.hs +++ b/src/GHC.hs @@ -11,6 +11,7 @@ import Data.List.Extra import Data.Version.Extra import SimpleCmd +import SimplePrompt (yesNo) import System.FilePath import Directories (getStackSubdir, globDirs, traversePlatforms) @@ -61,13 +62,17 @@ traversePlatforms getStackProgramsDir msystem $ do installs <- getGhcInstallDirs (Just ghcver) case installs of - [] -> putStrLn $ "stack ghc compiler version " ++ showVersion ghcver ++ " not found" + [] -> putStrLn $ "stack ghc compiler version" +-+ showVersion ghcver +-+ "not found" [g] | not (isMajorVersion ghcver) -> doRemoveGhcVersion deletion g gs -> if isMajorVersion ghcver then do - Remove.prompt deletion ("all stack ghc " ++ showVersion ghcver ++ " installations: ") - mapM_ (doRemoveGhcVersion deletion) gs + yes <- + if deletePrompt deletion + then yesNo $ "Delete all stack ghc" +-+ showVersion ghcver +-+ "installations" + else return True + when yes $ + mapM_ (doRemoveGhcVersion deletion) gs else error' "more than one match found!!" removeGhcMinorInstallation :: Deletion -> Maybe Version -> Maybe String @@ -75,17 +80,21 @@ removeGhcMinorInstallation deletion mghcver msystem = do traversePlatforms getStackProgramsDir msystem $ do dirs <- getGhcInstallDirs (majorVersion <$> mghcver) - case mghcver of - Nothing -> do - let majors = groupOn (majorVersion . ghcInstallVersion) dirs - forM_ majors $ \ minors -> - forM_ (init minors) $ doRemoveGhcVersion deletion - Just ghcver -> do - let minors = filter ((< ghcver) . ghcInstallVersion) dirs - forM_ minors $ doRemoveGhcVersion deletion + unless (null dirs) $ + case mghcver of + Nothing -> do + let majors = groupOn (majorVersion . ghcInstallVersion) dirs + forM_ majors $ \ minors -> + forM_ (init minors) $ doRemoveGhcVersion deletion + Just ghcver -> do + let minors = + if isMajorVersion ghcver + then init dirs + else filter ((< ghcver) . ghcInstallVersion) dirs + forM_ minors $ doRemoveGhcVersion deletion 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" + putStrLn $ ghcinst +-+ "compiler" +-+ (if isDelete deletion then "" else "would be") +-+ "removed" diff --git a/src/GHCTarball.hs b/src/GHCTarball.hs --- a/src/GHCTarball.hs +++ b/src/GHCTarball.hs @@ -10,6 +10,7 @@ import Data.List.Extra import Data.Version.Extra import SimpleCmd +import SimplePrompt (yesNo) import System.FilePath (dropExtension) import System.FilePath.Glob @@ -56,11 +57,17 @@ traversePlatforms getStackProgramsDir msystem $ do files <- getGhcTarballs (Just ghcver) case files of - [] -> putStrLn $ "Tarball for " ++ showVersion ghcver ++ " not found" + [] -> putStrLn $ "Tarball for" +-+ showVersion ghcver +-+ "not found" [g] | not (isMajorVersion ghcver) -> doRemoveGhcTarballVersion deletion g - gs -> if isMajorVersion ghcver then do - Remove.prompt deletion ("all stack ghc " ++ showVersion ghcver ++ " tarballs: ") - mapM_ (doRemoveGhcTarballVersion deletion) gs + gs -> + if isMajorVersion ghcver + then do + yes <- + if deletePrompt deletion + then yesNo $ "Delete all stack ghc" +-+ showVersion ghcver +-+ "tarballs" + else return True + when yes $ + mapM_ (doRemoveGhcTarballVersion deletion) gs else error' "more than one match found!!" removeGhcMinorTarball :: Deletion -> Maybe Version -> Maybe String @@ -68,16 +75,20 @@ removeGhcMinorTarball deletion mghcver msystem = do traversePlatforms getStackProgramsDir msystem $ do files <- getGhcTarballs (majorVersion <$> mghcver) - case mghcver of - Nothing -> do - let majors = groupOn (majorVersion . ghcTarballVersion) files - forM_ majors $ \ minors -> - forM_ (init minors) $ doRemoveGhcTarballVersion deletion - Just ghcver -> do - let minors = filter ((< ghcver) . ghcTarballVersion) files - forM_ minors $ doRemoveGhcTarballVersion deletion + unless (null files) $ + case mghcver of + Nothing -> do + let majors = groupOn (majorVersion . ghcTarballVersion) files + forM_ majors $ \ minors -> + forM_ (init minors) $ doRemoveGhcTarballVersion deletion + Just ghcver -> do + let minors = + if isMajorVersion ghcver + then init files + else filter ((< ghcver) . ghcTarballVersion) files + forM_ minors $ doRemoveGhcTarballVersion deletion doRemoveGhcTarballVersion :: Deletion -> FilePath -> IO () doRemoveGhcTarballVersion deletion ghctarball = do Remove.removeFile deletion ghctarball - putStrLn $ ghctarball ++ " tarball " ++ (if isDelete deletion then "" else "would be ") ++ "removed" + putStrLn $ ghctarball +-+ "tarball" +-+ (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 @@ -25,7 +25,7 @@ import Snapshots import Types -data Mode = Default | Project | Snapshots | Compilers | GHC | Tarballs +data Mode = Default | Project | Snapshots | Compilers | Global | Tarballs data Recursion = Subdirs | Recursive deriving Eq @@ -77,12 +77,15 @@ where modeOpt stackroot = flagWith' Project 'P' "project" "Act on current project's .stack-work/ [default in project dir]" <|> - flagWith' Snapshots 'S' "snapshots" ("Act on " ++ stackroot "snapshots/") <|> - flagWith' Compilers 'C' "compilers" ("Act on " ++ stackroot "programs/ installations") <|> - flagWith' Tarballs 'T' "tarballs" ("Act on " ++ stackroot "programs/ tarballs") <|> - flagWith Default GHC 'G' "global" ("Act on both " ++ stackroot "{programs,snapshots}/ [default outside project dir]") + flagWith' Snapshots 'S' "snapshots" ("Act on" +-+ stackroot "snapshots/") <|> + flagWith' Compilers 'C' "compilers" ("Act on" +-+ stackroot "programs/ installations") <|> + flagWith' Tarballs 'T' "tarballs" ("Act on" +-+ stackroot "programs/ tarballs") <|> + flagWith Default Global 'G' "global" ("Act on both" +-+ stackroot "{programs,snapshots}/ [default outside project dir]") - deleteOpt = flagWith Dryrun Delete 'd' "delete" "Do deletion [default is dryrun]" + deleteOpt = + (flagWith' Delete 'd' "delete" "Do deletion [default is dryrun]" <*> + switchWith 'y' "yes" "Assume yes for all prompts") <|> + pure Dryrun recursionOpt = optional ( @@ -130,14 +133,14 @@ Snapshots -> sizeSnapshots notHuman msystem Compilers -> sizeGhcPrograms notHuman Tarballs -> error' "use --compilers" - GHC -> do + Global -> do sizeCmd Snapshots Nothing notHuman msystem sizeCmd Compilers Nothing notHuman msystem Default -> do isProject <- doesDirectoryExist ".stack-work" if isProject || isJust mrecursion then sizeCmd Project mrecursion notHuman msystem - else sizeCmd GHC Nothing notHuman msystem + else sizeCmd Global Nothing notHuman msystem listCmd :: Mode -> Maybe Recursion -> Maybe Version -> Maybe String -> IO () listCmd mode mrecursion mver msystem = @@ -147,14 +150,14 @@ Snapshots -> getStackSubdir "snapshots" >>= listGhcSnapshots msystem mver Compilers -> listGhcInstallation mver msystem Tarballs -> listGhcTarballs mver msystem - GHC -> do + Global -> do listCmd Snapshots Nothing mver msystem listCmd Compilers Nothing mver msystem Default -> do isProject <- doesDirectoryExist ".stack-work" if isProject then listCmd Project Nothing mver msystem - else listCmd GHC Nothing mver msystem + else listCmd Global Nothing mver msystem removeCmd :: Deletion -> Mode -> Maybe Recursion -> Version -> Maybe String -> IO () @@ -179,14 +182,14 @@ removeGhcVersionInstallation deletion ghcver msystem Tarballs -> do removeGhcVersionTarball deletion ghcver msystem - GHC -> do + Global -> do removeRun deletion Compilers Nothing ghcver msystem removeRun deletion Snapshots Nothing ghcver msystem Default -> do isProject <- doesDirectoryExist ".stack-work" if isProject then removeRun deletion Project Nothing ghcver msystem - else removeRun deletion GHC Nothing ghcver msystem + else removeRun deletion Global Nothing ghcver msystem removeMinorsCmd :: Deletion -> Mode -> Maybe Recursion -> Maybe Version -> Maybe String -> IO () @@ -209,14 +212,14 @@ cleanMinorSnapshots deletion cwd mver Compilers -> removeGhcMinorInstallation deletion mver msystem Tarballs -> removeGhcMinorTarball deletion mver msystem - GHC -> do + Global -> do removeMinorsRun deletion Compilers Nothing mver msystem removeMinorsRun deletion Snapshots Nothing mver msystem Default -> do isProject <- doesDirectoryExist ".stack-work" if isProject then removeMinorsRun deletion Project Nothing mver msystem - else removeMinorsRun deletion GHC Nothing mver msystem + else removeMinorsRun deletion Global Nothing mver msystem purgeOlderCmd :: Deletion -> Natural -> Maybe Recursion -> Maybe String -> IO () purgeOlderCmd deletion keep mrecursion msystem = do diff --git a/src/Remove.hs b/src/Remove.hs --- a/src/Remove.hs +++ b/src/Remove.hs @@ -1,6 +1,5 @@ module Remove ( doRemoveDirectory, - prompt, removeFile ) where @@ -20,12 +19,3 @@ when (isDelete deletion) $ whenM (D.doesFileExist file) $ D.removeFile file - -prompt :: Deletion -> String -> IO () -prompt deletion str = - if isDelete deletion - then do - putStr $ "Press Enter to delete " ++ str ++ ": " - void getLine - else - putStrLn $ str ++ " would be deleted" diff --git a/src/Snapshots.hs b/src/Snapshots.hs --- a/src/Snapshots.hs +++ b/src/Snapshots.hs @@ -20,6 +20,7 @@ #if MIN_VERSION_simple_cmd(0,2,1) hiding (whenM) #endif +import SimplePrompt (yesNo) import System.Directory hiding (removeDirectoryRecursive, removeFile) import System.FilePath import Text.Printf @@ -87,14 +88,14 @@ mapM_ printTotalGhcSize ghcs plural :: String -> Int -> String -plural thing n = show n ++ " " ++ thing ++ if n == 1 then "" else "s" +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 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) + putStrLn $ plural "dir" (length dirs) +-+ "in" +-+ renderDir home dir "*" showVersion (snapsVersion versnap) +-+ (if isDelete deletion then "" else "would be") +-+ "removed" mapM_ (Remove.doRemoveDirectory deletion) dirs where renderDir :: FilePath -> FilePath -> FilePath @@ -109,9 +110,12 @@ ghcs <- getSnapshotDirs (Just ghcver) unless (null ghcs) $ putStrLn (platform ++ ":") - when (isMajorVersion ghcver) $ do - Remove.prompt deletion ("all " ++ showVersion ghcver ++ " builds") - mapM_ (removeVersionSnaps deletion cwd) ghcs + yes <- + if isMajorVersion ghcver && deletePrompt deletion + then yesNo $ "Delete all" +-+ showVersion ghcver +-+ "builds" + else return True + when yes $ + mapM_ (removeVersionSnaps deletion cwd) ghcs cleanMinorSnapshots :: Deletion -> FilePath -> Maybe Version -> String -> IO () cleanMinorSnapshots deletion cwd mghcver platform = do @@ -148,7 +152,7 @@ oldfiles <- drop (fromEnum keep) . reverse <$> sortedByAge mapM_ (Remove.doRemoveDirectory deletion . takeDirectory) oldfiles unless (null oldfiles) $ - putStrLn $ plural "dir" (length oldfiles) ++ (if isDelete deletion then "" else " would be") ++ " 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 @@ -176,5 +180,9 @@ removeStackWork :: Deletion -> IO () removeStackWork deletion = do - Remove.prompt deletion ".stack-work" - Remove.doRemoveDirectory deletion ".stack-work" + yes <- + if deletePrompt deletion + then yesNo "Delete .stack-work" + else return True + when yes $ + Remove.doRemoveDirectory deletion ".stack-work" diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -1,11 +1,16 @@ module Types ( Deletion (..), - isDelete + isDelete, + deletePrompt ) where -data Deletion = Dryrun | Delete - deriving Eq +data Deletion = Dryrun | Delete Bool isDelete :: Deletion -> Bool -isDelete = (== Delete) +isDelete (Delete _) = True +isDelete Dryrun = False + +deletePrompt :: Deletion -> Bool +deletePrompt (Delete False) = True +deletePrompt _ = False diff --git a/src/Versions.hs b/src/Versions.hs --- a/src/Versions.hs +++ b/src/Versions.hs @@ -5,6 +5,7 @@ where import Data.Version +import SimpleCmd ((+-+)) majorVersion :: Version -> Version majorVersion ver = @@ -12,7 +13,7 @@ case length vernums of 2 -> ver 3 -> (makeVersion . init) vernums - _ -> error $ "Bad ghc version " ++ showVersion ver + _ -> error $ "Bad ghc version" +-+ showVersion ver isMajorVersion :: Version -> Bool isMajorVersion ver = 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.4.8 +version: 0.5 synopsis: Clean away old stack build artifacts description: A tool for removing old .stack-work/install builds and @@ -40,6 +40,7 @@ , filemanip , simple-cmd >= 0.1.4 , simple-cmd-args >= 0.1.2 + , simple-prompt >= 0.2 default-language: Haskell2010 ghc-options: -Wall if impl(ghc >= 8.0)