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.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, diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/src/Directories.hs b/src/Directories.hs --- a/src/Directories.hs +++ b/src/Directories.hs @@ -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 () diff --git a/src/GHC.hs b/src/GHC.hs --- a/src/GHC.hs +++ b/src/GHC.hs @@ -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 diff --git a/src/GHCTarball.hs b/src/GHCTarball.hs --- a/src/GHCTarball.hs +++ b/src/GHCTarball.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 = diff --git a/src/Remove.hs b/src/Remove.hs --- a/src/Remove.hs +++ b/src/Remove.hs @@ -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" diff --git a/src/Snapshots.hs b/src/Snapshots.hs --- a/src/Snapshots.hs +++ b/src/Snapshots.hs @@ -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 diff --git a/src/Versions.hs b/src/Versions.hs --- a/src/Versions.hs +++ b/src/Versions.hs @@ -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 = 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.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 maintainer: Jens Petersen -copyright: 2020-2023 Jens Petersen +copyright: 2020-2023,2025 Jens Petersen 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