diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/src/Directories.hs b/src/Directories.hs --- a/src/Directories.hs +++ b/src/Directories.hs @@ -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 diff --git a/src/GHC.hs b/src/GHC.hs --- a/src/GHC.hs +++ b/src/GHC.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 = diff --git a/src/Snapshots.hs b/src/Snapshots.hs --- a/src/Snapshots.hs +++ b/src/Snapshots.hs @@ -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 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.1 +version: 0.4.2 synopsis: Clean away old stack build artefacts description: A tool for removing old .stack-work/install builds and