stack-clean-old 0.4.7 → 0.4.8
raw patch · 9 files changed
+232/−208 lines, 9 files
Files
- ChangeLog.md +5/−0
- LICENSE +1/−1
- README.md +16/−40
- src/Directories.hs +68/−27
- src/GHC.hs +33/−32
- src/GHCTarball.hs +31/−33
- src/Main.hs +31/−27
- src/Snapshots.hs +46/−47
- stack-clean-old.cabal +1/−1
ChangeLog.md view
@@ -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)
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2020, Jens Petersen+Copyright (c) 2020-2023, Jens Petersen All rights reserved.
README.md view
@@ -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
src/Directories.hs view
@@ -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
src/GHC.hs view
@@ -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
src/GHCTarball.hs view
@@ -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
src/Main.hs view
@@ -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
src/Snapshots.hs view
@@ -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
stack-clean-old.cabal view
@@ -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