stack-clean-old 0.4.1 → 0.4.2
raw patch · 7 files changed
+126/−81 lines, 7 files
Files
- ChangeLog.md +4/−0
- README.md +14/−10
- src/Directories.hs +14/−6
- src/GHC.hs +16/−15
- src/Main.hs +68/−40
- src/Snapshots.hs +9/−9
- stack-clean-old.cabal +1/−1
ChangeLog.md view
@@ -1,5 +1,9 @@ # Release history for stack-clean-old-work +## 0.4.2 (2021-11-22)+- add optional --os-system to fix #7+- list/size snapshots before compilers for --global+ ## 0.4.1 (2021-10-05) - --help now mentions --delete and a link to README
README.md view
@@ -41,19 +41,23 @@ after checking the dry-run output first. ### Example usage-To remove project builds for ghc-8.2.2:+List a project's builds: ```ShellSession $ stack-clean-old list 154M 8.2.2 (5 dirs) 154M 8.4.4 (5 dirs) 163M 8.6.5 (5 dirs)-$ stack-clean-old remove --delete -p 8.2.2+```+Remove project's 8.2.2 builds:+```ShellSession+$ stack-clean-old remove --delete --project 8.2.2 : ```+(--project is optional in a project dir). Remove stack ghc-8.4 snapshot builds and compilers before 8.4.4: ```ShellSession-$ stack-clean-old list -g 8.4+$ stack-clean-old list --global 8.4 421M 8.4.1 (7 dirs) 368M 8.4.2 (6 dirs) 489M 8.4.3 (8 dirs)@@ -64,8 +68,7 @@ 6 dirs removed for 8.4.2 8 dirs removed for 8.4.3 ```--Incidently I build my projects across as many major Stackage LTS versions as possible (using my stack-all tool), and collectively this piles up to a lot of diskspace: so I wrote this tool to help manage that.+(--global is optional outside a project dir). ### Purging older stack project builds ```@@ -79,7 +82,7 @@ NB: If you regularly build your project for several branches/tags against the same LTS or ghc version then it is safer to avoid using `purge-older`. ### Deleting all `.stack-work/` subdirectories-`stack-clean-old delete-work` can be used to recursively remove+`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`). @@ -91,8 +94,7 @@ To get help you can run `stack-clean-old --help` or just: ```ShellSession-$ stack-clean-old-Stack clean up tool+$ Stack clean up tool Usage: stack-clean-old [--version] COMMAND Cleans away old stack-work builds (and pending: stack snapshots) to recover@@ -109,7 +111,8 @@ remove Remove for a ghc version keep-minor Remove for previous ghc minor versions purge-older Purge older builds in .stack-work/install- delete-work Remove project's .stack-work subdirs recursively+ delete-work Remove project's .stack-work/ (optionally+ recursively) ``` ## Installation@@ -118,7 +121,8 @@ ## Related This tool complements [stack-all](https://hackage.haskell.org/package/stack-all)-which builds projects over LTS major versions and hence generates lot of stack builds.+which builds projects across LTS major versions and+hence generates a lot of stack builds. [cabal-clean](https://hackage.haskell.org/package/cabal-clean) is a similar tool for cleaning old cached cabal build files.
src/Directories.hs view
@@ -20,8 +20,8 @@ home <- getHomeDirectory return $ home </> ".stack" </> subdir -switchToSystemDirUnder :: FilePath -> IO ()-switchToSystemDirUnder dir = do+switchToSystemDirUnder :: Maybe String -> FilePath -> IO ()+switchToSystemDirUnder msystem dir = do exists <- doesDirectoryExist dir if exists then setCurrentDirectory dir@@ -30,8 +30,16 @@ -- FIXME be more precise/check "system" dirs -- eg 64bit intel Linux: x86_64-linux-tinfo6 let system =- case systems of- [] -> error' $ "No OS system in " ++ dir- [sys] -> sys- _ -> error' "More than one OS systems found " ++ dir ++ " (unsupported)"+ 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
src/GHC.hs view
@@ -26,13 +26,13 @@ programs <- getStackProgramsDir cmd_ "du" $ ["-h" | not nothuman] ++ ["-s", programs] -setStackProgramsDir :: IO ()-setStackProgramsDir =- getStackProgramsDir >>= switchToSystemDirUnder+setStackProgramsDir :: Maybe String -> IO ()+setStackProgramsDir msystem =+ getStackProgramsDir >>= switchToSystemDirUnder msystem -getGhcInstallDirs :: Maybe Version -> IO [FilePath]-getGhcInstallDirs mghcver = do- setStackProgramsDir+getGhcInstallDirs :: Maybe Version -> Maybe String -> IO [FilePath]+getGhcInstallDirs mghcver msystem = do+ setStackProgramsDir msystem sortOn ghcInstallVersion <$> globDirs matchVersion where matchVersion =@@ -45,16 +45,16 @@ ghcInstallVersion = readVersion . takeWhileEnd (/= '-') . dropSuffix ".temp" -listGhcInstallation :: Maybe Version -> IO ()-listGhcInstallation mghcver = do- dirs <- getGhcInstallDirs mghcver+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 -removeGhcVersionInstallation :: Deletion -> Version -> IO ()-removeGhcVersionInstallation deletion ghcver = do- installs <- getGhcInstallDirs (Just ghcver)+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@@ -63,9 +63,10 @@ mapM_ (doRemoveGhcVersion deletion) gs else error' "more than one match found!!" -removeGhcMinorInstallation :: Deletion -> Maybe Version -> IO ()-removeGhcMinorInstallation deletion mghcver = do- dirs <- getGhcInstallDirs (majorVersion <$> mghcver)+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
src/Main.hs view
@@ -34,17 +34,40 @@ "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 <*> recursionOpt <*> notHumanOpt+ sizeCmd+ <$> modeOpt+ <*> recursionOpt+ <*> notHumanOpt , Subcommand "list" "List sizes per ghc version" $- listCmd <$> modeOpt <*> recursionOpt <*> optional ghcVerArg+ listCmd+ <$> modeOpt+ <*> recursionOpt+ <*> optional ghcVerArg+ <*> optional systemOpt , Subcommand "remove" "Remove for a ghc version" $- removeCmd <$> deleteOpt <*> modeOpt <*> recursionOpt <*> ghcVerArg+ removeCmd+ <$> deleteOpt+ <*> modeOpt+ <*> recursionOpt+ <*> ghcVerArg+ <*> optional systemOpt , Subcommand "keep-minor" "Remove for previous ghc minor versions" $- removeMinorsCmd <$> deleteOpt <*> modeOpt <*> recursionOpt <*> optional ghcVerArg+ removeMinorsCmd+ <$> deleteOpt+ <*> modeOpt+ <*> recursionOpt+ <*> optional ghcVerArg+ <*> optional systemOpt , Subcommand "purge-older" "Purge older builds in .stack-work/install" $- purgeOlderCmd <$> deleteOpt <*> keepOption <*> recursionOpt- , Subcommand "delete-work" "Remove project's .stack-work subdirs recursively" $- deleteWorkCmd <$> deleteOpt <*> recursionOpt+ purgeOlderCmd+ <$> deleteOpt+ <*> keepOption+ <*> recursionOpt+ <*> optional systemOpt+ , Subcommand "delete-work" "Remove project's .stack-work/ (optionally recursively)" $+ deleteWorkCmd+ <$> deleteOpt+ <*> recursionOpt ] where modeOpt =@@ -60,12 +83,16 @@ flagWith' Subdirs 's' "subdirs" "List subdirectories" <|> flagWith' Recursive 'r' "recursive" "List subdirectories") - notHumanOpt = switchWith 'H' "not-human-size" "Do not use du --human-readable"+ notHumanOpt = switchWith 'H' "not-human-size"+ "Do not use du --human-readable" ghcVerArg = readVersion <$> strArg "GHCVER" - keepOption = optionalWith auto 'k' "keep" "INT" "number of project builds per ghc version [default 5]" 5+ keepOption = optionalWith auto 'k' "keep" "INT"+ "number of project builds per ghc version [default 5]" 5 + 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@@ -98,8 +125,8 @@ Snapshots -> sizeSnapshots notHuman Compilers -> sizeGhcInstalls notHuman GHC -> do- sizeCmd Compilers Nothing notHuman sizeCmd Snapshots Nothing notHuman+ sizeCmd Compilers Nothing notHuman Default -> if isJust mrecursion then sizeStackWork notHuman dir@@ -109,71 +136,72 @@ then sizeCmd Project Nothing notHuman else sizeCmd GHC Nothing notHuman -listCmd :: Mode -> Maybe Recursion -> Maybe Version -> IO ()-listCmd mode mrecursion mver =+listCmd :: Mode -> Maybe Recursion -> Maybe Version -> Maybe String -> IO ()+listCmd mode mrecursion mver msystem = withRecursion mrecursion $ case mode of- Project -> setStackWorkInstallDir >> listGhcSnapshots mver- Snapshots -> setStackSnapshotsDir >> listGhcSnapshots mver- Compilers -> listGhcInstallation mver+ Project -> setStackWorkInstallDir msystem >> listGhcSnapshots mver+ Snapshots -> setStackSnapshotsDir msystem >> listGhcSnapshots mver+ Compilers -> listGhcInstallation mver msystem GHC -> do- listCmd Compilers Nothing mver- listCmd Snapshots Nothing mver+ listCmd Snapshots Nothing mver msystem+ listCmd Compilers Nothing mver msystem Default -> do isProject <- doesDirectoryExist ".stack-work" if isProject- then listCmd Project Nothing mver- else listCmd GHC Nothing mver+ then listCmd Project Nothing mver msystem+ else listCmd GHC Nothing mver msystem -removeCmd :: Deletion -> Mode -> Maybe Recursion -> Version -> IO ()-removeCmd deletion mode mrecursion ghcver =+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+ setStackWorkInstallDir msystem cleanGhcSnapshots deletion cwd ghcver Snapshots -> do cwd <- getCurrentDirectory- setStackSnapshotsDir+ setStackSnapshotsDir msystem cleanGhcSnapshots deletion cwd ghcver- Compilers -> removeGhcVersionInstallation deletion ghcver+ Compilers -> removeGhcVersionInstallation deletion ghcver msystem GHC -> do- removeCmd deletion Compilers Nothing ghcver- removeCmd deletion Snapshots Nothing ghcver+ 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- else removeCmd deletion GHC Nothing ghcver+ then removeCmd deletion Project Nothing ghcver msystem+ else removeCmd deletion GHC Nothing ghcver msystem removeMinorsCmd :: Deletion -> Mode -> Maybe Recursion -> Maybe Version- -> IO ()-removeMinorsCmd deletion mode mrecursion mver =+ -> Maybe String -> IO ()+removeMinorsCmd deletion mode mrecursion mver msystem = withRecursion mrecursion $ case mode of Project -> do cwd <- getCurrentDirectory- setStackWorkInstallDir+ setStackWorkInstallDir msystem cleanMinorSnapshots deletion cwd mver Snapshots -> do cwd <- getCurrentDirectory- setStackSnapshotsDir+ setStackSnapshotsDir msystem cleanMinorSnapshots deletion cwd mver- Compilers -> removeGhcMinorInstallation deletion mver+ Compilers -> removeGhcMinorInstallation deletion mver msystem GHC -> do- removeMinorsCmd deletion Compilers Nothing mver- removeMinorsCmd deletion Snapshots Nothing mver+ 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- else removeMinorsCmd deletion GHC Nothing mver+ then removeMinorsCmd deletion Project Nothing mver msystem+ else removeMinorsCmd deletion GHC Nothing mver msystem -purgeOlderCmd :: Deletion -> Natural -> Maybe Recursion -> IO ()-purgeOlderCmd deletion keep mrecursion =+purgeOlderCmd :: Deletion -> Natural -> Maybe Recursion -> Maybe String -> IO ()+purgeOlderCmd deletion keep mrecursion msystem = withRecursion mrecursion $- cleanOldStackWork deletion keep+ cleanOldStackWork deletion keep msystem deleteWorkCmd :: Deletion -> Maybe Recursion -> IO () deleteWorkCmd deletion mrecursion =
src/Snapshots.hs view
@@ -126,9 +126,9 @@ gminors = filter ((< newestMinor) . snapsVersion) ghcs mapM_ (removeVersionSnaps deletion cwd) gminors -cleanOldStackWork :: Deletion -> Natural -> IO ()-cleanOldStackWork deletion keep = do- setStackWorkInstallDir+cleanOldStackWork :: Deletion -> Natural -> Maybe String -> IO ()+cleanOldStackWork deletion keep msystem = do+ setStackWorkInstallDir msystem dirs <- sortOn takeFileName . lines <$> shell ( unwords $ "ls" : ["-d", "*/*"]) let ghcs = groupOn takeFileName dirs mapM_ removeOlder ghcs@@ -165,13 +165,13 @@ total <- head . words . last <$> cmdLines "du" ("-shc":snapsHashes versnaps) printf "%4s %-6s (%d dirs)\n" total ((showVersion . snapsVersion) versnaps) (length (snapsHashes versnaps)) -setStackWorkInstallDir :: IO ()-setStackWorkInstallDir = do- switchToSystemDirUnder stackWorkInstall+setStackWorkInstallDir :: Maybe String -> IO ()+setStackWorkInstallDir msystem = do+ switchToSystemDirUnder msystem stackWorkInstall -setStackSnapshotsDir :: IO ()-setStackSnapshotsDir = do- getStackSubdir "snapshots" >>= switchToSystemDirUnder+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.1+version: 0.4.2 synopsis: Clean away old stack build artefacts description: A tool for removing old .stack-work/install builds and