stack-clean-old 0.4.8 → 0.5
raw patch · 11 files changed
+130/−86 lines, 11 filesdep +simple-prompt
Dependencies added: simple-prompt
Files
- ChangeLog.md +5/−0
- README.md +31/−20
- src/Directories.hs +3/−3
- src/GHC.hs +21/−12
- src/GHCTarball.hs +24/−13
- src/Main.hs +17/−14
- src/Remove.hs +0/−10
- src/Snapshots.hs +16/−8
- src/Types.hs +9/−4
- src/Versions.hs +2/−1
- stack-clean-old.cabal +2/−1
ChangeLog.md view
@@ -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)
README.md view
@@ -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
src/Directories.hs view
@@ -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]
src/GHC.hs view
@@ -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"
src/GHCTarball.hs view
@@ -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"
src/Main.hs view
@@ -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
src/Remove.hs view
@@ -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"
src/Snapshots.hs view
@@ -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"
src/Types.hs view
@@ -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
src/Versions.hs view
@@ -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 =
stack-clean-old.cabal view
@@ -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)