stack-clean-old 0.5.1 → 0.5.2
raw patch · 10 files changed
+127/−86 lines, 10 filesdep +safe
Dependencies added: safe
Files
- ChangeLog.md +5/−0
- README.md +29/−25
- src/Directories.hs +15/−1
- src/GHC.hs +1/−1
- src/GHCTarball.hs +1/−1
- src/Main.hs +26/−20
- src/Remove.hs +10/−3
- src/Snapshots.hs +33/−28
- src/Versions.hs +4/−5
- stack-clean-old.cabal +3/−2
ChangeLog.md view
@@ -1,5 +1,10 @@ # Release history for stack-clean-old +## 0.5.2 (2025-12-28)+- 'delete-work' now provides output+- some safe refactorings (helps with #21 reported by @andreasabel)+- support `$STACK_WORK` (#20 suggested by @JonnyRa)+ ## 0.5.1 (2023-12-17) - listStackSubdirs: sort after filtering - Directory: ignore non-directories, like .DS_Store files (#19,
README.md view
@@ -4,11 +4,11 @@ snapshot builds and ghc versions to recover diskspace. ## Usage-```-stack-clean-old [size|list|remove|keep-minor|purge-older|delete-work] [(-P|--project)|(-G|--global)|(-C|--compilers)|(-T|--tarballs)] [(-s|--subdirs)|(-r|--recursive)] [-d|--delete] [GHCVER]`-```-In a project directory it acts on `.stack-work/install/` by default,-otherwise on `${STACK_ROOT}/{snapshots,programs}/`+stack-clean-old [size|list|remove|keep-minor|purge-older|delete-work] [(-P|--project)|(-G|--global)|(-C|--compilers)|(-T|--tarballs)] [(-s|--subdirs)|(-r|--recursive)] [-d|--delete] [GHCVER]++In a project directory it acts on `.stack-work/install/` by default+(or `$STACK_WORK/install` if defined).+Otherwise on `${STACK_ROOT}/{snapshots,programs}/` (the default *Stack root* is `~/.stack/`): see the [Stack root documentation](https://docs.haskellstack.org/en/stable/stack_root/). @@ -58,36 +58,36 @@ List a project's builds: ```ShellSession $ stack-clean-old list-149M 9.2.8 (5 dirs)-163M 9.4.7 (5 dirs)-155M 9.6.2 (5 dirs)+149M 9.6.7 (5 dirs)+163M 9.8.4 (5 dirs)+155M 9.10.3 (5 dirs) ```-Remove project's 9.0.2 builds:+Remove project's 9.4.8 builds: ```ShellSession-$ stack-clean-old remove --delete --project 9.0.2+$ stack-clean-old remove --delete --project 9.4.8 : ``` (--project is optional in a project dir). -Remove stack ghc-9.4 snapshot builds and minor compilers before 9.4.7:+Remove stack ghc-9.6 snapshot builds and minor compilers before 9.6.7: ```ShellSession-$ stack-clean-old list --global 9.4+$ stack-clean-old list --global 9.6 x86_64-linux-tinfo6:-1.8G 9.4.6 (61 dirs)-279M 9.4.7 (6 dirs)+1.8G 9.6.6 (61 dirs)+279M 9.6.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+ghc-tinfo6-9.6.6+ghc-tinfo6-9.6.7+$ stack-clean-old keep-minor --global 9.6+ghc-tinfo6-9.6.6 compiler would be removed x86_64-linux-tinfo6:-61 dirs in ~/.stack/snapshots/x86_64-linux-tinfo6/*/9.4.6 would be removed+61 dirs in ~/.stack/snapshots/x86_64-linux-tinfo6/*/9.6.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+$ stack-clean-old keep-minor --global 9.6 --delete+ghc-tinfo6-9.6.6 compiler removed x86_64-linux-tinfo6:-61 dirs in ~/.stack/snapshots/x86_64-linux-tinfo6/*/9.4.6 removed+61 dirs in ~/.stack/snapshots/x86_64-linux-tinfo6/*/9.6.6 removed ``` (--global is optional outside a project dir). @@ -114,12 +114,15 @@ ## Help output (Note you can also run this tool via `stack clean-old`.) -To get help you can run `stack-clean-old --help` or just: `$ stack-clean-old --version`+ ```-0.5+0.5.2 ```+To get help you can run `stack-clean-old` or:+ `$ stack-clean-old --help`+ ``` Stack clean up tool @@ -147,6 +150,7 @@ Most of the commands have similar options, e.g.: `$ stack-clean-old remove --help`+ ``` Usage: stack-clean-old remove [(-d|--delete) [-y|--yes]] [(-P|--project) | (-S|--snapshots) | @@ -160,7 +164,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+ -P,--project Act on current project's .stack-work [default in project dir] -S,--snapshots Act on ~/.stack/snapshots/ -C,--compilers Act on ~/.stack/programs/ installations
src/Directories.hs view
@@ -3,6 +3,8 @@ module Directories ( getStackSubdir, getStackProgramsDir,+ getStackWorkDir,+ getStackWorkInstall, globDirs, traversePlatforms, traversePlatforms',@@ -12,6 +14,8 @@ import Control.Monad (filterM, forM_, unless, when) import Data.List.Extra+import Data.Maybe (fromMaybe)+import Safe (headMay) import SimpleCmd ((+-+), #if MIN_VERSION_simple_cmd(0,2,0) warning@@ -51,6 +55,16 @@ stackRoot <- getStackRootDir return $ stackRoot </> subdir +getStackWorkDir :: IO FilePath+getStackWorkDir = do+ mwork <- lookupEnv "STACK_WORK"+ return $ fromMaybe ".stack-work" mwork++getStackWorkInstall :: IO FilePath+getStackWorkInstall = do+ stackwork <- getStackWorkDir+ return $ stackwork </> "install"+ traversePlatforms :: IO FilePath -> Maybe String -> IO () -> IO () traversePlatforms getdir msystem act = do dir <- getdir@@ -83,7 +97,7 @@ listCurrentDirectory :: IO [FilePath] listCurrentDirectory =- listDirectory "." >>= filterM doesDirectoryExist . filter (\d -> head d /= '.')+ listDirectory "." >>= filterM doesDirectoryExist . filter (\d -> headMay d /= Just '.') #if !MIN_VERSION_simple_cmd(0,2,0) warning :: String -> IO ()
src/GHC.hs view
@@ -97,4 +97,4 @@ 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" +-+ Remove.wouldBeRemoved deletion
src/GHCTarball.hs view
@@ -91,4 +91,4 @@ 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" +-+ Remove.wouldBeRemoved deletion
src/Main.hs view
@@ -18,7 +18,8 @@ import System.FilePath import System.IO (BufferMode(NoBuffering), hSetBuffering, stdout) -import Directories (getStackSubdir, traversePlatforms')+import Directories (getStackSubdir, getStackWorkDir, getStackWorkInstall,+ traversePlatforms') import GHC import GHCTarball import Paths_stack_clean_old (version)@@ -33,33 +34,34 @@ main :: IO () main = do stackroot_str <- maybe "~/.stack" (const "$STACK_ROOT") <$> lookupEnv "STACK_ROOT"+ stackwork_str <- maybe ".stack-work" (const "$STACK_WORK") <$> lookupEnv "STACK_WORK" hSetBuffering stdout NoBuffering simpleCmdArgs (Just version) "Stack clean up tool" "Cleans away old stack-work builds (and pending: stack snapshots) to recover diskspace. Use the --delete option to perform actual removals. https://github.com/juhp/stack-clean-old#readme" $ subcommands [ Subcommand "size" "Total size" $ sizeCmd- <$> modeOpt stackroot_str+ <$> modeOpt stackroot_str stackwork_str <*> recursionOpt <*> notHumanOpt <*> optional systemOpt , Subcommand "list" "List sizes per ghc version" $ listCmd- <$> modeOpt stackroot_str+ <$> modeOpt stackroot_str stackwork_str <*> recursionOpt <*> optional ghcVerArg <*> optional systemOpt , Subcommand "remove" "Remove for a ghc version" $ removeCmd <$> deleteOpt- <*> modeOpt stackroot_str+ <*> modeOpt stackroot_str stackwork_str <*> recursionOpt <*> ghcVerArg <*> optional systemOpt , Subcommand "keep-minor" "Remove for previous ghc minor versions" $ removeMinorsCmd <$> deleteOpt- <*> modeOpt stackroot_str+ <*> modeOpt stackroot_str stackwork_str <*> recursionOpt <*> optional ghcVerArg <*> optional systemOpt@@ -75,8 +77,8 @@ <*> recursionOpt ] where- modeOpt stackroot =- flagWith' Project 'P' "project" "Act on current project's .stack-work/ [default in project dir]" <|>+ modeOpt stackroot stackwork =+ flagWith' Project 'P' "project" ("Act on current project's" +-+ stackwork +-+ "[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") <|>@@ -107,15 +109,17 @@ withRecursion needinstall mrecursion = withRecursion' True needinstall mrecursion . const -withRecursion' :: Bool -> Bool -> Maybe Recursion -> (FilePath -> IO ()) -> IO ()+withRecursion' :: Bool -> Bool -> Maybe Recursion -> (FilePath -> IO ())+ -> IO () withRecursion' changedir needinstall mrecursion act = do case mrecursion of Just recursion -> do+ stackworkinstall <- getStackWorkInstall dirs <- (if recursion == Recursive then map (dropPrefix "./" . takeDirectory) <$> findStackWorks else listStackSubdirs) >>= if needinstall- then filterM (doesDirectoryExist . (</> ".stack-work/install"))+ then filterM (doesDirectoryExist . (</> stackworkinstall)) else return forM_ dirs $ \dir -> if changedir@@ -137,7 +141,7 @@ sizeCmd Snapshots Nothing notHuman msystem sizeCmd Compilers Nothing notHuman msystem Default -> do- isProject <- doesDirectoryExist ".stack-work"+ isProject <- getStackWorkDir >>= doesDirectoryExist if isProject || isJust mrecursion then sizeCmd Project mrecursion notHuman msystem else sizeCmd Global Nothing notHuman msystem@@ -146,7 +150,7 @@ listCmd mode mrecursion mver msystem = withRecursion True mrecursion $ case mode of- Project -> listGhcSnapshots msystem mver stackWorkInstall+ Project -> getStackWorkInstall >>= listGhcSnapshots msystem mver Snapshots -> getStackSubdir "snapshots" >>= listGhcSnapshots msystem mver Compilers -> listGhcInstallation mver msystem Tarballs -> listGhcTarballs mver msystem@@ -154,7 +158,7 @@ listCmd Snapshots Nothing mver msystem listCmd Compilers Nothing mver msystem Default -> do- isProject <- doesDirectoryExist ".stack-work"+ isProject <- getStackWorkDir >>= doesDirectoryExist if isProject then listCmd Project Nothing mver msystem else listCmd Global Nothing mver msystem@@ -172,7 +176,7 @@ case mode of Project -> do cwd <- getCurrentDirectory- traversePlatforms' (return stackWorkInstall) msystem $+ traversePlatforms' getStackWorkInstall msystem $ cleanGhcSnapshots deletion cwd ghcver Snapshots -> do cwd <- getCurrentDirectory@@ -186,7 +190,7 @@ removeRun deletion Compilers Nothing ghcver msystem removeRun deletion Snapshots Nothing ghcver msystem Default -> do- isProject <- doesDirectoryExist ".stack-work"+ isProject <- getStackWorkDir >>= doesDirectoryExist if isProject then removeRun deletion Project Nothing ghcver msystem else removeRun deletion Global Nothing ghcver msystem@@ -204,7 +208,7 @@ case mode of Project -> do cwd <- getCurrentDirectory- traversePlatforms' (return stackWorkInstall) msystem $+ traversePlatforms' getStackWorkInstall msystem $ cleanMinorSnapshots deletion cwd mver Snapshots -> do cwd <- getCurrentDirectory@@ -216,7 +220,7 @@ removeMinorsRun deletion Compilers Nothing mver msystem removeMinorsRun deletion Snapshots Nothing mver msystem Default -> do- isProject <- doesDirectoryExist ".stack-work"+ isProject <- getStackWorkDir >>= doesDirectoryExist if isProject then removeMinorsRun deletion Project Nothing mver msystem else removeMinorsRun deletion Global Nothing mver msystem@@ -234,13 +238,15 @@ remindDelete deletion findStackWorks :: IO [FilePath]-findStackWorks =+findStackWorks = do+ stackwork <- getStackWorkDir -- ignore find errors (e.g. access rights)- L.sort . lines <$> cmdIgnoreErr "find" [".", "-type", "d", "-name", ".stack-work", "-prune"] []+ L.sort . lines <$> cmdIgnoreErr "find" [".", "-type", "d", "-name", stackwork, "-prune"] [] listStackSubdirs :: IO [FilePath]-listStackSubdirs =- listDirectory "." >>= fmap L.sort . filterM (doesDirectoryExist . (</> ".stack-work"))+listStackSubdirs = do+ stackwork <- getStackWorkDir+ listDirectory "." >>= fmap L.sort . filterM (doesDirectoryExist . (</> stackwork)) remindDelete :: Deletion -> IO () remindDelete deletion =
src/Remove.hs view
@@ -1,21 +1,28 @@ module Remove ( doRemoveDirectory,- removeFile+ removeFile,+ wouldBeRemoved ) where import Control.Monad.Extra+import SimpleCmd ((+-+)) import qualified System.Directory as D import Types doRemoveDirectory :: Deletion -> FilePath -> IO ()-doRemoveDirectory deletion dir =+doRemoveDirectory deletion dir = do when (isDelete deletion) $- D.removeDirectoryRecursive dir+ D.removeDirectoryRecursive dir+ putStrLn $ dir +-+ wouldBeRemoved deletion removeFile :: Deletion -> FilePath -> IO () removeFile deletion file = when (isDelete deletion) $ whenM (D.doesFileExist file) $ D.removeFile file++wouldBeRemoved :: Deletion -> String+wouldBeRemoved deletion =+ (if isDelete deletion then "" else "would be") +-+ "removed"
src/Snapshots.hs view
@@ -5,7 +5,6 @@ cleanMinorSnapshots, cleanOldStackWork, listGhcSnapshots,- stackWorkInstall, sizeSnapshots, sizeStackWork, removeStackWork@@ -13,6 +12,7 @@ where import Control.Monad.Extra+import Data.Bifunctor (second) import Data.List.Extra import Data.Version.Extra import Numeric.Natural@@ -25,7 +25,8 @@ import System.FilePath import Text.Printf -import Directories (globDirs, getStackSubdir, listCurrentDirectory,+import Directories (globDirs, getStackSubdir, getStackWorkDir,+ getStackWorkInstall, listCurrentDirectory, traversePlatforms, traversePlatforms') import qualified Remove import Types@@ -52,14 +53,10 @@ readVersionedSnaps :: [FilePath] -> [VersionSnapshots] readVersionedSnaps snaps =- let ghcs = (groupOn snapGHC . sort) (map readSnapshot snaps)- in map installVerSnaps ghcs+ map (uncurry VersionSnaps . second (map snapHash)) .+ groupOnKey snapGHC . sort $+ map readSnapshot snaps where- installVerSnaps :: [SnapshotInstall] -> VersionSnapshots- installVerSnaps versnaps =- let ver = snapGHC (head versnaps) in- VersionSnaps ver (map snapHash versnaps)- readSnapshot :: FilePath -> SnapshotInstall readSnapshot pth = let (hash,ver) = splitFileName pth@@ -95,7 +92,7 @@ let dirs = snapsHashes versnap dir <- getCurrentDirectory home <- getHomeDirectory- putStrLn $ plural "dir" (length dirs) +-+ "in" +-+ renderDir home dir </> "*" </> showVersion (snapsVersion versnap) +-+ (if isDelete deletion then "" else "would be") +-+ "removed"+ putStrLn $ plural "dir" (length dirs) +-+ "in" +-+ renderDir home dir </> "*" </> showVersion (snapsVersion versnap) +-+ Remove.wouldBeRemoved deletion mapM_ (Remove.doRemoveDirectory deletion) dirs where renderDir :: FilePath -> FilePath -> FilePath@@ -140,19 +137,18 @@ cleanOldStackWork :: Deletion -> Natural -> Maybe String -> IO () cleanOldStackWork deletion keep msystem = do- traversePlatforms (return stackWorkInstall) msystem $ do+ traversePlatforms getStackWorkInstall msystem $ do dirs <- sortOn takeFileName . lines <$> shell ( unwords $ "ls" : ["-d", "*/*"])- let ghcs = sortOn (readVersion . takeFileName . head) $- groupOn takeFileName dirs+ let ghcs = sortOn (readVersion . fst) $+ groupOnKey takeFileName dirs mapM_ removeOlder ghcs where- removeOlder :: [FilePath] -> IO ()- removeOlder dirs = do- let ghcver = (takeFileName . head) dirs+ removeOlder :: (String,[FilePath]) -> IO ()+ removeOlder (ghcver,dirs) = do 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) +-+ Remove.wouldBeRemoved deletion +-+ "for" +-+ ghcver where sortedByAge = do fileTimes <- mapM newestTimeStamp dirs@@ -164,25 +160,34 @@ timestamp <- maximum <$> mapM getModificationTime files return (dir, timestamp) -stackWorkInstall :: FilePath-stackWorkInstall = ".stack-work/install"- sizeStackWork :: Bool -> FilePath -> IO () sizeStackWork nothuman dir = do- let path = dir </> ".stack-work"+ stackwork <- getStackWorkDir+ let path = dir </> stackwork whenM (doesDirectoryExist path) $ cmd_ "du" $ ["-h" | not nothuman] ++ ["-s", path] printTotalGhcSize :: VersionSnapshots -> IO () printTotalGhcSize versnaps = do- total <- head . words . last <$> cmdLines "du" ("-shc":snapsHashes versnaps)+ total <- fst . word1 . last <$> cmdLines "du" ("-shc":snapsHashes versnaps) printf "%4s %-6s (%d dirs)\n" total ((showVersion . snapsVersion) versnaps) (length (snapsHashes versnaps)) removeStackWork :: Deletion -> IO () removeStackWork deletion = do- yes <-- if deletePrompt deletion- then yesNo "Delete .stack-work"- else return True- when yes $- Remove.doRemoveDirectory deletion ".stack-work"+ exists <- doesDirectoryExist ".stack-work"+ when exists $ do+ yes <-+ if deletePrompt deletion+ then yesNo "Delete .stack-work"+ else return True+ when yes $+ Remove.doRemoveDirectory deletion ".stack-work"++#if !MIN_VERSION_extra(1,7,11)+groupOnKey :: Eq k => (a -> k) -> [a] -> [(k, [a])]+groupOnKey _ [] = []+groupOnKey f (x:xs) = (fx, x:yes) : groupOnKey f no+ where+ fx = f x+ (yes, no) = span (\y -> fx == f y) xs+#endif
src/Versions.hs view
@@ -9,11 +9,10 @@ majorVersion :: Version -> Version majorVersion ver =- let vernums = versionBranch ver in- case length vernums of- 2 -> ver- 3 -> (makeVersion . init) vernums- _ -> error $ "Bad ghc version" +-+ showVersion ver+ case versionBranch ver of+ [_,_] -> ver+ (v1:v2:_) -> makeVersion [v1,v2]+ _ -> 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.5.1+version: 0.5.2 synopsis: Clean away old stack build artifacts description: A tool for removing old .stack-work/install builds and@@ -9,7 +9,7 @@ license-file: LICENSE author: Jens Petersen <juhpetersen@gmail.com> maintainer: Jens Petersen <juhpetersen@gmail.com>-copyright: 2020-2023 Jens Petersen <juhpetersen@gmail.com>+copyright: 2020-2023,2025 Jens Petersen <juhpetersen@gmail.com> homepage: https://github.com/juhp/stack-clean-old bug-reports: https://github.com/juhp/stack-clean-old/issues build-type: Simple@@ -38,6 +38,7 @@ , extra >= 1.4.3 , filepath , filemanip+ , safe , simple-cmd >= 0.1.4 , simple-cmd-args >= 0.1.2 , simple-prompt >= 0.2