diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Release history for stack-clean-old-work +## 0.4.4 (2022-01-04) +- handle .stack-work/ consistently for --subdir and --recursive +- remind user to use '--delete' for removal +- purge-older: output is now sorted by ghc versions + ## 0.4.3 (2021-11-23) - 'delete-work' now prints ".stack-work" would be deleted - prompts now print what would be deleted diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,18 +4,15 @@ snapshot builds and ghc versions to recover diskspace. ## Usage -`stack-clean-old [size|list|remove|keep-minor|purge-older|delete-work] [-d|--delete] [(-p|--project) | (-g|--ghc)] [GHCVER] -` - -Options: +`stack-clean-old [size|list|remove|keep-minor|purge-older|delete-work] [(-P|--project)|(-G|--global)] [(-s|--subdirs)|(-r|--recursive)] [-d|--delete] [GHCVER]` -- `--project` (default in a stack project dir): act on `.stack-work/install/` -- `--global` (default outside a project dir): act on `~/.stack/snapshots/` and `~/.stack/programs/` +In a project directory it acts on `.stack-work/install/` by default, +otherwise on `~/.stack/{snapshots,programs}/`. -and the subcommands: +Subcommands: `size`: - prints the total size of the above directories + prints the total size of `.stack-work/` or `~/.stack/` (`size` does not take a GHCVER argument). `list`: @@ -27,19 +24,25 @@ `keep-minor`: 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. + If GHCVER is given then only minor versions older than it + (or than the latest installed minor version) are removed. + If no GHCVER is given it applies to each installed ghc major version. -`purge-older` and `delete-work`: - see sections below +`purge-older`: + removes snapshot builds with older timestamps -If you remove any needed snapshot builds for a version of ghc, -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. +`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. +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 +but can recover a lot of diskspace. + ### Example usage List a project's builds: ```ShellSession @@ -55,7 +58,7 @@ ``` (--project is optional in a project dir). -Remove stack ghc-8.4 snapshot builds and compilers before 8.4.4: +Remove stack ghc-8.4 snapshot builds and minor compilers before 8.4.4: ```ShellSession $ stack-clean-old list --global 8.4 421M 8.4.1 (7 dirs) @@ -83,18 +86,16 @@ ### Deleting all `.stack-work/` subdirectories `stack-clean-old delete-work --recursive` can be used to remove recursively -_all_ `.stack-work/` dirs from a project to save space -(seems same as `stack clean --full`). - -`stack-clean-old delete-work --all` works from outside stack projects: -please use with care with `--delete`. +_all_ `.stack-work/` dirs within (or outside) a project directory to save +space (seems same as `stack clean --full` inside a project). ### 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: ```ShellSession -$ Stack clean up tool +$ stack-clean-old +Stack clean up tool Usage: stack-clean-old [--version] COMMAND Cleans away old stack-work builds (and pending: stack snapshots) to recover @@ -120,7 +121,8 @@ Run `stack install` or `cabal install` ## Related -This tool complements [stack-all](https://hackage.haskell.org/package/stack-all) +This tool complements +[stack-all](https://hackage.haskell.org/package/stack-all) which builds projects across LTS major versions and hence generates a lot of stack builds. @@ -130,7 +132,7 @@ ## Contributing BSD license -Project: https://github.com/juhp/stack-clean-old +Project: ## Disclaimer Use at your own risk: the author takes no responsibility for any loss or diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -94,51 +94,47 @@ systemOpt = strOptionWith 'o' "os-system" "SYSTEM" "Specify which of the OS platforms to work on (eg 'x86_64-linux-tinfo6' or 'aarch64-linux-nix', etc)" -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 +withRecursion :: Bool -> Maybe Recursion -> IO () -> IO () +withRecursion needinstall mrecursion = + withRecursion' True needinstall mrecursion . const -withRecursion' :: Maybe Recursion -> (FilePath -> IO ()) -> IO () -withRecursion' mrecursion act = do +withRecursion' :: Bool -> Bool -> Maybe Recursion -> (FilePath -> IO ()) -> IO () +withRecursion' changedir needinstall mrecursion act = do case mrecursion of Just recursion -> do - dirs <- if recursion == Recursive - then map (dropPrefix "./" . takeDirectory) <$> findStackWorks - else listStackSubdirs - mapM_ act dirs + dirs <- (if recursion == Recursive + then map (dropPrefix "./" . takeDirectory) <$> findStackWorks + else listStackSubdirs) + >>= if needinstall + then filterM (doesDirectoryExist . ( "install")) + else return + forM_ dirs $ \dir -> + if changedir + then + withCurrentDirectory dir $ do + putStrLn $ "\n" ++ takeFileName dir ++ "/" + act dir + else act dir Nothing -> act "" sizeCmd :: Mode -> Maybe Recursion -> Bool -> IO () sizeCmd mode mrecursion notHuman = - withRecursion' mrecursion $ \dir -> case mode of - Project -> sizeStackWork notHuman dir + Project -> withRecursion' False False mrecursion $ sizeStackWork notHuman Snapshots -> sizeSnapshots notHuman Compilers -> sizeGhcInstalls notHuman GHC -> do sizeCmd Snapshots Nothing notHuman sizeCmd Compilers Nothing notHuman - Default -> - if isJust mrecursion - then sizeStackWork notHuman dir - else do + Default -> do isProject <- doesDirectoryExist ".stack-work" - if isProject - then sizeCmd Project Nothing notHuman + if isProject || isJust mrecursion + then sizeCmd Project mrecursion notHuman else sizeCmd GHC Nothing notHuman listCmd :: Mode -> Maybe Recursion -> Maybe Version -> Maybe String -> IO () listCmd mode mrecursion mver msystem = - withRecursion mrecursion $ + withRecursion True mrecursion $ case mode of Project -> setStackWorkInstallDir msystem >> listGhcSnapshots mver Snapshots -> setStackSnapshotsDir msystem >> listGhcSnapshots mver @@ -154,66 +150,73 @@ removeCmd :: Deletion -> Mode -> Maybe Recursion -> Version -> Maybe String -> IO () -removeCmd deletion mode mrecursion ghcver msystem = - withRecursion mrecursion $ - case mode of - Project -> do - cwd <- getCurrentDirectory - setStackWorkInstallDir msystem - cleanGhcSnapshots deletion cwd ghcver - Snapshots -> do - cwd <- getCurrentDirectory - setStackSnapshotsDir msystem - cleanGhcSnapshots deletion cwd ghcver - Compilers -> removeGhcVersionInstallation deletion ghcver msystem - GHC -> do - removeCmd deletion Compilers Nothing ghcver msystem - removeCmd deletion Snapshots Nothing ghcver msystem - Default -> do - isProject <- doesDirectoryExist ".stack-work" - if isProject - then removeCmd deletion Project Nothing ghcver msystem - else removeCmd deletion GHC Nothing ghcver msystem +removeCmd deletion mode mrecursion ghcver msystem = do + withRecursion True mrecursion $ + case mode of + Project -> do + cwd <- getCurrentDirectory + setStackWorkInstallDir msystem + cleanGhcSnapshots deletion cwd ghcver + Snapshots -> do + cwd <- getCurrentDirectory + setStackSnapshotsDir msystem + cleanGhcSnapshots deletion cwd ghcver + Compilers -> removeGhcVersionInstallation deletion ghcver msystem + GHC -> do + removeCmd deletion Compilers Nothing ghcver msystem + removeCmd deletion Snapshots Nothing ghcver msystem + Default -> do + isProject <- doesDirectoryExist ".stack-work" + if isProject + then removeCmd deletion Project Nothing ghcver msystem + else removeCmd deletion GHC Nothing ghcver msystem + remindDelete deletion removeMinorsCmd :: Deletion -> Mode -> Maybe Recursion -> Maybe Version -> Maybe String -> IO () -removeMinorsCmd deletion mode mrecursion mver msystem = - withRecursion mrecursion $ - case mode of - Project -> do - cwd <- getCurrentDirectory - setStackWorkInstallDir msystem - cleanMinorSnapshots deletion cwd mver - Snapshots -> do - cwd <- getCurrentDirectory - setStackSnapshotsDir msystem - cleanMinorSnapshots deletion cwd mver - Compilers -> removeGhcMinorInstallation deletion mver msystem - GHC -> do - removeMinorsCmd deletion Compilers Nothing mver msystem - removeMinorsCmd deletion Snapshots Nothing mver msystem - Default -> do - isProject <- doesDirectoryExist ".stack-work" - if isProject - then removeMinorsCmd deletion Project Nothing mver msystem - else removeMinorsCmd deletion GHC Nothing mver msystem +removeMinorsCmd deletion mode mrecursion mver msystem = do + withRecursion True mrecursion $ + case mode of + Project -> do + cwd <- getCurrentDirectory + setStackWorkInstallDir msystem + cleanMinorSnapshots deletion cwd mver + Snapshots -> do + cwd <- getCurrentDirectory + setStackSnapshotsDir msystem + cleanMinorSnapshots deletion cwd mver + Compilers -> removeGhcMinorInstallation deletion mver msystem + GHC -> do + removeMinorsCmd deletion Compilers Nothing mver msystem + removeMinorsCmd deletion Snapshots Nothing mver msystem + Default -> do + isProject <- doesDirectoryExist ".stack-work" + if isProject + then removeMinorsCmd deletion Project Nothing mver msystem + else removeMinorsCmd deletion GHC Nothing mver msystem + remindDelete deletion purgeOlderCmd :: Deletion -> Natural -> Maybe Recursion -> Maybe String -> IO () -purgeOlderCmd deletion keep mrecursion msystem = - withRecursion mrecursion $ - cleanOldStackWork deletion keep msystem +purgeOlderCmd deletion keep mrecursion msystem = do + withRecursion True mrecursion $ + cleanOldStackWork deletion keep msystem + remindDelete deletion deleteWorkCmd :: Deletion -> Maybe Recursion -> IO () -deleteWorkCmd deletion mrecursion = - withRecursion mrecursion $ - removeStackWork deletion +deleteWorkCmd deletion mrecursion = do + withRecursion False mrecursion $ + removeStackWork deletion + remindDelete 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 + L.sort . lines <$> cmdIgnoreErr "find" [".", "-type", "d", "-name", ".stack-work", "-prune"] [] listStackSubdirs :: IO [FilePath] listStackSubdirs = listDirectory "." >>= filterM (\f -> doesDirectoryExist (f ".stack-work")) . L.sort + +remindDelete :: Deletion -> IO () +remindDelete deletion = + unless (isDelete deletion) $ putStrLn "\n(use --delete for removal)" diff --git a/src/Snapshots.hs b/src/Snapshots.hs --- a/src/Snapshots.hs +++ b/src/Snapshots.hs @@ -130,7 +130,8 @@ cleanOldStackWork deletion keep msystem = do setStackWorkInstallDir msystem dirs <- sortOn takeFileName . lines <$> shell ( unwords $ "ls" : ["-d", "*/*"]) - let ghcs = groupOn takeFileName dirs + let ghcs = sortOn (readVersion . takeFileName . head) $ + groupOn takeFileName dirs mapM_ removeOlder ghcs where removeOlder :: [FilePath] -> IO () 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.3 +version: 0.4.4 synopsis: Clean away old stack build artefacts 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-2021 Jens Petersen +copyright: 2020-2022 Jens Petersen homepage: https://github.com/juhp/stack-clean-old bug-reports: https://github.com/juhp/stack-clean-old/issues build-type: Simple