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.4.8 (2023-08-26) +- support the `STACK_ROOT` environment variable which overrides + the default Stack root (`~/.stack`) by @PRESFIL (#12) +- list all the platform variants by default (#15) + ## 0.4.7 (2023-08-22) - add --tarballs for programs/ ghc tarballs too (#9) - bug fix to match both ghc-*.* and ghc-variant-*.* (#14) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2020, Jens Petersen +Copyright (c) 2020-2023, Jens Petersen All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -7,13 +7,15 @@ `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/{snapshots,programs}/`. +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/). Subcommands: `size`: - prints the total size of `.stack-work/` or `~/.stack/` - (`size` does not take a GHCVER argument). + prints the total size of `.stack-work/` of project(s) or the *Stack root*. + directories (`size` does not take a GHCVER argument). `list`: shows the total size and number of snapshots per ghc version @@ -48,10 +50,9 @@ all matching `.stack-work` dirs from the current directory and below respectively. -Note is you have different ghc variants/archs installed -you may need to use the `--platform` option to choose which one to query/clean: -examples include `x86_64-linux-tinfo6`, `x86_64-linux`, `aarch64-linux-nix`, -`x86_64-osx`, `aarch64-osx`, etc. +If you have different ghc variants/archs installed +you can use `--platform` to restrict to one of then, +otherwise they are each listed by default. ### Example usage List a project's builds: @@ -105,7 +106,7 @@ To get help you can run `stack-clean-old --help` or just: ```ShellSession $ stack-clean-old --version -0.4.7 +0.4.8 $ stack-clean-old Stack clean up tool @@ -130,41 +131,14 @@ ``` ### Command options -All the commands have similar options. e.g.: - -Size and list command: -``` -$ stack-clean-old list --help -Usage: stack-clean-old list [(-P|--project) | (-S|--snapshots) | (-G|--global) | - (-C|--compilers) | (-T|--tarballs)] - [(-s|--subdirs) | (-r|--recursive)] [GHCVER] - [-o|--platform SYSTEM] - - List sizes per ghc version - -Available options: - -P,--project Act on current project's .stack-work/ [default in - project dir] - -S,--snapshots Act on ~/.stack/snapshots/ - -G,--global Act on both ~/.stack/{programs,snapshots}/ [default - outside project dir] - -C,--compilers Act on ~/.stack/programs/ installations - -T,--tarballs Act on ~/.stack/programs/ tarballs - -s,--subdirs List subdirectories - -r,--recursive List subdirectories - -o,--platform SYSTEM Specify which OS platform to work on (eg - 'x86_64-linux-tinfo6', 'aarch64-linux-nix', - 'x86_64-osx', 'aarch64-osx', etc) - -h,--help Show this help text -``` +Most of the commands have similar options, e.g.: -Removal commands additionally have `--delete`: ```shellsession $ stack-clean-old remove --help Usage: stack-clean-old remove [-d|--delete] [(-P|--project) | (-S|--snapshots) | - (-G|--global) | (-C|--compilers) | - (-T|--tarballs)] + (-C|--compilers) | (-T|--tarballs) | + (-G|--global)] [(-s|--subdirs) | (-r|--recursive)] GHCVER [-o|--platform SYSTEM] @@ -175,10 +149,10 @@ -P,--project Act on current project's .stack-work/ [default in project dir] -S,--snapshots Act on ~/.stack/snapshots/ - -G,--global Act on both ~/.stack/{programs,snapshots}/ [default - outside project dir] -C,--compilers Act on ~/.stack/programs/ installations -T,--tarballs Act on ~/.stack/programs/ tarballs + -G,--global Act on both ~/.stack/{programs,snapshots}/ [default + outside project dir] -s,--subdirs List subdirectories -r,--recursive List subdirectories -o,--platform SYSTEM Specify which OS platform to work on (eg @@ -186,6 +160,8 @@ 'x86_64-osx', 'aarch64-osx', etc) -h,--help Show this help text ``` + +(The `list` and `size` commands don't have `--delete`.) ## Installation diff --git a/src/Directories.hs b/src/Directories.hs --- a/src/Directories.hs +++ b/src/Directories.hs @@ -1,50 +1,91 @@ +{-# LANGUAGE CPP #-} + module Directories ( getStackSubdir, + getStackProgramsDir, globDirs, - switchToSystemDirUnder, + traversePlatforms, + traversePlatforms', listCurrentDirectory ) where +import Control.Monad (forM_, unless, when) import Data.List.Extra -import SimpleCmd (error') +import SimpleCmd ( +#if MIN_VERSION_simple_cmd(0,2,0) + warning +#endif + ) import System.Directory +import System.Environment import System.FilePath import System.FilePath.Glob +#if !MIN_VERSION_simple_cmd(0,2,0) +-- for warning +import System.IO (hPutStrLn, stderr) +#endif globDirs :: String -> IO [FilePath] globDirs pat = do map (dropPrefix "./") <$> namesMatching (pat ++ "/") +getStackRootDir :: IO FilePath +getStackRootDir = do + mroot <- lookupEnv "STACK_ROOT" + case mroot of + Just path -> do + unless (isAbsolute path) $ + warning $ "STACK_ROOT is not absolute: " ++ path + return path + Nothing -> do + home <- getHomeDirectory + return $ home ".stack" + +getStackProgramsDir :: IO FilePath +getStackProgramsDir = + getStackSubdir "programs" + getStackSubdir :: FilePath -> IO FilePath getStackSubdir subdir = do - home <- getHomeDirectory - return $ home ".stack" subdir + stackRoot <- getStackRootDir + return $ stackRoot subdir -switchToSystemDirUnder :: Maybe String -> FilePath -> IO () -switchToSystemDirUnder msystem dir = do - exists <- doesDirectoryExist dir - if exists - then setCurrentDirectory dir - else error' $ dir ++ " not found" - systems <- listCurrentDirectory - -- FIXME be more precise/check "system" dirs - -- eg 64bit intel Linux: x86_64-linux-tinfo6 - let system = - case msystem of - Just sys -> - if sys `elem` systems - then sys - else error' $ sys ++ " not found" - Nothing -> - case systems of - [] -> error' $ "No OS system in " ++ dir - [sys] -> sys - ss -> error' $ intercalate "\n" $ - ["Please specify platform with --os-system (-o).", - dir ++ " has:"] ++ ss - setCurrentDirectory system +traversePlatforms :: IO FilePath -> Maybe String -> IO () -> IO () +traversePlatforms getdir msystem act = do + dir <- getdir + withCurrentDirectory dir $ do + platforms <- listPlatforms msystem + forM_ platforms $ \p -> do + when (length platforms > 1) $ + putStrLn (p ++ ":") + withCurrentDirectory p act +traversePlatforms' :: IO FilePath -> Maybe String -> (FilePath -> IO ()) + -> IO () +traversePlatforms' getdir msystem act = do + dir <- getdir + withCurrentDirectory dir $ do + platforms <- listPlatforms msystem + mapM_ act platforms + +listPlatforms :: Maybe String -> IO [FilePath] +listPlatforms msystem = do + platforms <- listDirectory "." + case msystem of + Nothing -> return platforms + Just s -> + if s `elem` platforms + then return [s] + else do + warning $ "no matching platform for: " ++ s + return [] + listCurrentDirectory :: IO [FilePath] listCurrentDirectory = filter (\d -> head d /= '.') <$> listDirectory "." + +#if !MIN_VERSION_simple_cmd(0,2,0) +warning :: String -> IO () +warning = hPutStrLn stderr +#endif diff --git a/src/GHC.hs b/src/GHC.hs --- a/src/GHC.hs +++ b/src/GHC.hs @@ -2,7 +2,7 @@ listGhcInstallation, removeGhcMinorInstallation, removeGhcVersionInstallation, - sizeGhcInstalls + sizeGhcPrograms ) where @@ -13,7 +13,7 @@ import SimpleCmd import System.FilePath -import Directories (getStackSubdir, globDirs, switchToSystemDirUnder) +import Directories (getStackSubdir, globDirs, traversePlatforms) import qualified Remove import Types import Versions @@ -22,18 +22,13 @@ getStackProgramsDir = getStackSubdir "programs" -sizeGhcInstalls :: Bool -> IO () -sizeGhcInstalls nothuman = do +sizeGhcPrograms :: Bool -> IO () +sizeGhcPrograms nothuman = do programs <- getStackProgramsDir cmd_ "du" $ ["-h" | not nothuman] ++ ["-s", programs] -setStackProgramsDir :: Maybe String -> IO () -setStackProgramsDir msystem = - getStackProgramsDir >>= switchToSystemDirUnder msystem - -getGhcInstallDirs :: Maybe Version -> Maybe String -> IO [FilePath] -getGhcInstallDirs mghcver msystem = do - setStackProgramsDir msystem +getGhcInstallDirs :: Maybe Version -> IO [FilePath] +getGhcInstallDirs mghcver = sortOn ghcInstallVersion <$> globDirs ("ghc" ++ matchVersion) where matchVersion = @@ -54,34 +49,40 @@ listGhcInstallation :: Maybe Version -> Maybe String -> IO () listGhcInstallation mghcver msystem = do - dirs <- getGhcInstallDirs mghcver msystem - mapM_ putStrLn $ case mghcver of - Nothing -> dirs - Just ghcver -> filter ((== ghcver) . (if isMajorVersion ghcver then majorVersion else id) . ghcInstallVersion) dirs + traversePlatforms getStackProgramsDir msystem $ do + dirs <- getGhcInstallDirs mghcver + mapM_ putStrLn $ + case mghcver of + Nothing -> dirs + Just ghcver -> filter ((== ghcver) . (if isMajorVersion ghcver then majorVersion else id) . ghcInstallVersion) dirs removeGhcVersionInstallation :: Deletion -> Version -> Maybe String -> IO () removeGhcVersionInstallation deletion ghcver msystem = do - installs <- getGhcInstallDirs (Just ghcver) msystem - case installs of - [] -> 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 - else error' "more than one match found!!" + traversePlatforms getStackProgramsDir msystem $ do + installs <- getGhcInstallDirs (Just ghcver) + case installs of + [] -> 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 + else error' "more than one match found!!" removeGhcMinorInstallation :: Deletion -> Maybe Version -> Maybe String -> IO () removeGhcMinorInstallation deletion mghcver msystem = do - dirs <- getGhcInstallDirs (majorVersion <$> mghcver) msystem - 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 + 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 doRemoveGhcVersion :: Deletion -> FilePath -> IO () doRemoveGhcVersion deletion ghcinst = do diff --git a/src/GHCTarball.hs b/src/GHCTarball.hs --- a/src/GHCTarball.hs +++ b/src/GHCTarball.hs @@ -13,22 +13,17 @@ import System.FilePath (dropExtension) import System.FilePath.Glob -import Directories (getStackSubdir, switchToSystemDirUnder) +import Directories (getStackProgramsDir, traversePlatforms) import qualified Remove import Types import Versions -getStackProgramsDir :: IO FilePath -getStackProgramsDir = - getStackSubdir "programs" - -setStackProgramsDir :: Maybe String -> IO () -setStackProgramsDir msystem = - getStackProgramsDir >>= switchToSystemDirUnder msystem +-- setStackProgramsDir :: Maybe String -> IO () +-- setStackProgramsDir msystem = +-- getStackProgramsDir >>= switchToSystemDirUnder msystem -getGhcTarballs :: Maybe Version -> Maybe String -> IO [FilePath] -getGhcTarballs mghcver msystem = do - setStackProgramsDir msystem +getGhcTarballs :: Maybe Version -> IO [FilePath] +getGhcTarballs mghcver = do sortOn ghcTarballVersion . map (dropPrefix "./") <$> namesMatching ("ghc" ++ matchVersion ++ ".tar.*") where matchVersion = @@ -49,35 +44,38 @@ listGhcTarballs :: Maybe Version -> Maybe String -> IO () listGhcTarballs mghcver msystem = do - files <- getGhcTarballs mghcver msystem - mapM_ putStrLn $ - case mghcver of - Nothing -> files - Just ghcver -> filter ((== ghcver) . (if isMajorVersion ghcver then majorVersion else id) . ghcTarballVersion) files + traversePlatforms getStackProgramsDir msystem $ do + files <- getGhcTarballs mghcver + mapM_ putStrLn $ + case mghcver of + Nothing -> files + Just ghcver -> filter ((== ghcver) . (if isMajorVersion ghcver then majorVersion else id) . ghcTarballVersion) files removeGhcVersionTarball :: Deletion -> Version -> Maybe String -> IO () removeGhcVersionTarball deletion ghcver msystem = do - files <- getGhcTarballs (Just ghcver) msystem - case files of - [] -> 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 - else error' "more than one match found!!" + traversePlatforms getStackProgramsDir msystem $ do + files <- getGhcTarballs (Just ghcver) + case files of + [] -> 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 + else error' "more than one match found!!" removeGhcMinorTarball :: Deletion -> Maybe Version -> Maybe String -> IO () removeGhcMinorTarball deletion mghcver msystem = do - files <- getGhcTarballs (majorVersion <$> mghcver) msystem - 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 + 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 doRemoveGhcTarballVersion :: Deletion -> FilePath -> IO () doRemoveGhcTarballVersion deletion ghctarball = do diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -14,9 +14,11 @@ import SimpleCmd import SimpleCmdArgs import System.Directory +import System.Environment (lookupEnv) import System.FilePath import System.IO (BufferMode(NoBuffering), hSetBuffering, stdout) +import Directories (getStackSubdir, traversePlatforms') import GHC import GHCTarball import Paths_stack_clean_old (version) @@ -30,32 +32,34 @@ main :: IO () main = do + stackroot_str <- maybe "~/.stack" (const "$STACK_ROOT") <$> lookupEnv "STACK_ROOT" 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 + <$> modeOpt stackroot_str <*> recursionOpt <*> notHumanOpt + <*> optional systemOpt , Subcommand "list" "List sizes per ghc version" $ listCmd - <$> modeOpt + <$> modeOpt stackroot_str <*> recursionOpt <*> optional ghcVerArg <*> optional systemOpt , Subcommand "remove" "Remove for a ghc version" $ removeCmd <$> deleteOpt - <*> modeOpt + <*> modeOpt stackroot_str <*> recursionOpt <*> ghcVerArg <*> optional systemOpt , Subcommand "keep-minor" "Remove for previous ghc minor versions" $ removeMinorsCmd <$> deleteOpt - <*> modeOpt + <*> modeOpt stackroot_str <*> recursionOpt <*> optional ghcVerArg <*> optional systemOpt @@ -71,12 +75,12 @@ <*> recursionOpt ] where - modeOpt = + modeOpt stackroot = flagWith' Project 'P' "project" "Act on current project's .stack-work/ [default in project dir]" <|> - flagWith' Snapshots 'S' "snapshots" "Act on ~/.stack/snapshots/" <|> - flagWith' GHC 'G' "global" "Act on both ~/.stack/{programs,snapshots}/ [default outside project dir]" <|> - flagWith' Compilers 'C' "compilers" "Act on ~/.stack/programs/ installations" <|> - flagWith Default Tarballs 'T' "tarballs" "Act on ~/.stack/programs/ tarballs" + 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]") deleteOpt = flagWith Dryrun Delete 'd' "delete" "Do deletion [default is dryrun]" @@ -119,28 +123,28 @@ else act dir Nothing -> act "" -sizeCmd :: Mode -> Maybe Recursion -> Bool -> IO () -sizeCmd mode mrecursion notHuman = +sizeCmd :: Mode -> Maybe Recursion -> Bool -> Maybe String -> IO () +sizeCmd mode mrecursion notHuman msystem = case mode of Project -> withRecursion' False False mrecursion $ sizeStackWork notHuman - Snapshots -> sizeSnapshots notHuman - Compilers -> sizeGhcInstalls notHuman + Snapshots -> sizeSnapshots notHuman msystem + Compilers -> sizeGhcPrograms notHuman Tarballs -> error' "use --compilers" GHC -> do - sizeCmd Snapshots Nothing notHuman - sizeCmd Compilers Nothing notHuman + 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 - else sizeCmd GHC Nothing notHuman + then sizeCmd Project mrecursion notHuman msystem + else sizeCmd GHC Nothing notHuman msystem listCmd :: Mode -> Maybe Recursion -> Maybe Version -> Maybe String -> IO () listCmd mode mrecursion mver msystem = withRecursion True mrecursion $ case mode of - Project -> setStackWorkInstallDir msystem >> listGhcSnapshots mver - Snapshots -> setStackSnapshotsDir msystem >> listGhcSnapshots mver + Project -> listGhcSnapshots msystem mver stackWorkInstall + Snapshots -> getStackSubdir "snapshots" >>= listGhcSnapshots msystem mver Compilers -> listGhcInstallation mver msystem Tarballs -> listGhcTarballs mver msystem GHC -> do @@ -165,12 +169,12 @@ case mode of Project -> do cwd <- getCurrentDirectory - setStackWorkInstallDir msystem - cleanGhcSnapshots deletion cwd ghcver + traversePlatforms' (return stackWorkInstall) msystem $ + cleanGhcSnapshots deletion cwd ghcver Snapshots -> do cwd <- getCurrentDirectory - setStackSnapshotsDir msystem - cleanGhcSnapshots deletion cwd ghcver + traversePlatforms' (getStackSubdir "snapshots") msystem $ + cleanGhcSnapshots deletion cwd ghcver Compilers -> do removeGhcVersionInstallation deletion ghcver msystem Tarballs -> do @@ -197,12 +201,12 @@ case mode of Project -> do cwd <- getCurrentDirectory - setStackWorkInstallDir msystem - cleanMinorSnapshots deletion cwd mver + traversePlatforms' (return stackWorkInstall) msystem $ + cleanMinorSnapshots deletion cwd mver Snapshots -> do cwd <- getCurrentDirectory - setStackSnapshotsDir msystem - cleanMinorSnapshots deletion cwd mver + traversePlatforms' (getStackSubdir "snapshots") msystem $ + cleanMinorSnapshots deletion cwd mver Compilers -> removeGhcMinorInstallation deletion mver msystem Tarballs -> removeGhcMinorTarball deletion mver msystem GHC -> do diff --git a/src/Snapshots.hs b/src/Snapshots.hs --- a/src/Snapshots.hs +++ b/src/Snapshots.hs @@ -1,14 +1,11 @@ {-# LANGUAGE CPP #-} module Snapshots ( - --getSnapshotDirs - --, VersionSnapshots(..) cleanGhcSnapshots, cleanMinorSnapshots, cleanOldStackWork, listGhcSnapshots, - setStackSnapshotsDir, - setStackWorkInstallDir, + stackWorkInstall, sizeSnapshots, sizeStackWork, removeStackWork @@ -28,7 +25,7 @@ import Text.Printf import Directories (globDirs, getStackSubdir, listCurrentDirectory, - switchToSystemDirUnder) + traversePlatforms, traversePlatforms') import qualified Remove import Types import Versions @@ -77,15 +74,17 @@ versionMatch ghcver = showVersion ghcver ++ if isMajorVersion ghcver then ".*" else "" -sizeSnapshots :: Bool -> IO () -sizeSnapshots nothuman = do - snapshots <- getStackSubdir "snapshots" - cmd_ "du" $ ["-h" | not nothuman] ++ ["-s", snapshots] +sizeSnapshots :: Bool -> Maybe String -> IO () +sizeSnapshots nothuman msystem = + traversePlatforms' (getStackSubdir "snapshots") msystem $ \plat -> do + cwd <- getCurrentDirectory + cmd_ "du" $ ["-h" | not nothuman] ++ ["-s", cwd plat] -listGhcSnapshots :: Maybe Version -> IO () -listGhcSnapshots mghcver = do - ghcs <- getSnapshotDirs mghcver - mapM_ printTotalGhcSize ghcs +listGhcSnapshots :: Maybe String -> Maybe Version -> FilePath -> IO () +listGhcSnapshots msystem mghcver dir = do + traversePlatforms (return dir) msystem $ do + ghcs <- getSnapshotDirs mghcver + mapM_ printTotalGhcSize ghcs plural :: String -> Int -> String plural thing n = show n ++ " " ++ thing ++ if n == 1 then "" else "s" @@ -104,36 +103,44 @@ Just reldir -> reldir Nothing -> "~" dropPrefix (home ++ "/") fp -cleanGhcSnapshots :: Deletion -> FilePath -> Version -> IO () -cleanGhcSnapshots deletion cwd ghcver = do - ghcs <- getSnapshotDirs (Just ghcver) - when (isMajorVersion ghcver) $ do - Remove.prompt deletion ("all " ++ showVersion ghcver ++ " builds") - mapM_ (removeVersionSnaps deletion cwd) ghcs +cleanGhcSnapshots :: Deletion -> FilePath -> Version -> String -> IO () +cleanGhcSnapshots deletion cwd ghcver platform = do + withCurrentDirectory platform $ do + 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 -cleanMinorSnapshots :: Deletion -> FilePath -> Maybe Version -> IO () -cleanMinorSnapshots deletion cwd mghcver = do - ghcs <- getSnapshotDirs (majorVersion <$> mghcver) - case mghcver of - Nothing -> do - let majors = groupOn (majorVersion . snapsVersion) ghcs - forM_ majors $ \ gmajor -> - when (length gmajor > 1) $ - mapM_ (removeVersionSnaps deletion cwd) (init gmajor) - Just ghcver -> do - let newestMinor = if isMajorVersion ghcver - then (snapsVersion . last) ghcs - else ghcver - gminors = filter ((< newestMinor) . snapsVersion) ghcs - mapM_ (removeVersionSnaps deletion cwd) gminors +cleanMinorSnapshots :: Deletion -> FilePath -> Maybe Version -> String -> IO () +cleanMinorSnapshots deletion cwd mghcver platform = do + withCurrentDirectory platform $ do + ghcs <- getSnapshotDirs (majorVersion <$> mghcver) + case mghcver of + Nothing -> do + let majors = groupOn (majorVersion . snapsVersion) ghcs + unless (null majors) $ + putStrLn (platform ++ ":") + forM_ majors $ \ gmajor -> + when (length gmajor > 1) $ + mapM_ (removeVersionSnaps deletion cwd) (init gmajor) + Just ghcver -> do + let newestMinor = if isMajorVersion ghcver + then (snapsVersion . last) ghcs + else ghcver + gminors = filter ((< newestMinor) . snapsVersion) ghcs + unless (null gminors) $ + putStrLn (platform ++ ":") + mapM_ (removeVersionSnaps deletion cwd) gminors cleanOldStackWork :: Deletion -> Natural -> Maybe String -> IO () cleanOldStackWork deletion keep msystem = do - setStackWorkInstallDir msystem - dirs <- sortOn takeFileName . lines <$> shell ( unwords $ "ls" : ["-d", "*/*"]) - let ghcs = sortOn (readVersion . takeFileName . head) $ - groupOn takeFileName dirs - mapM_ removeOlder ghcs + traversePlatforms (return stackWorkInstall) msystem $ do + dirs <- sortOn takeFileName . lines <$> shell ( unwords $ "ls" : ["-d", "*/*"]) + let ghcs = sortOn (readVersion . takeFileName . head) $ + groupOn takeFileName dirs + mapM_ removeOlder ghcs where removeOlder :: [FilePath] -> IO () removeOlder dirs = do @@ -166,14 +173,6 @@ printTotalGhcSize versnaps = do total <- head . words . last <$> cmdLines "du" ("-shc":snapsHashes versnaps) printf "%4s %-6s (%d dirs)\n" total ((showVersion . snapsVersion) versnaps) (length (snapsHashes versnaps)) - -setStackWorkInstallDir :: Maybe String -> IO () -setStackWorkInstallDir msystem = do - switchToSystemDirUnder msystem stackWorkInstall - -setStackSnapshotsDir :: Maybe String -> IO () -setStackSnapshotsDir msystem = do - getStackSubdir "snapshots" >>= switchToSystemDirUnder msystem removeStackWork :: Deletion -> IO () removeStackWork deletion = do 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.7 +version: 0.4.8 synopsis: Clean away old stack build artifacts description: A tool for removing old .stack-work/install builds and