remove and keep-minor: only output platform if snapshots/builds to re…

…move
juhp · Aug 26, 2023 · c1814ce · c1814ce
1 parent fe56350
commit c1814ce
Show file tree

Hide file tree

Showing 2 changed files with 35 additions and 27 deletions.
diff --git a/src/Main.hs b/src/Main.hs
@@ -18,7 +18,7 @@ import System.Environment (lookupEnv)
 import System.FilePath
 import System.IO (BufferMode(NoBuffering), hSetBuffering, stdout)
 
-import Directories (getStackSubdir, traversePlatforms)
+import Directories (getStackSubdir, traversePlatforms')
 import GHC
 import GHCTarball
 import Paths_stack_clean_old (version)
@@ -169,11 +169,11 @@ removeRun deletion mode mrecursion ghcver msystem =
     case mode of
       Project -> do
         cwd <- getCurrentDirectory
-        traversePlatforms (return stackWorkInstall) msystem $
+        traversePlatforms' (return stackWorkInstall) msystem $
           cleanGhcSnapshots deletion cwd ghcver
       Snapshots -> do
         cwd <- getCurrentDirectory
-        traversePlatforms (getStackSubdir "snapshots") msystem $
+        traversePlatforms' (getStackSubdir "snapshots") msystem $
           cleanGhcSnapshots deletion cwd ghcver
       Compilers -> do
         removeGhcVersionInstallation deletion ghcver msystem
@@ -201,11 +201,11 @@ removeMinorsRun deletion mode mrecursion mver msystem = do
     case mode of
       Project -> do
         cwd <- getCurrentDirectory
-        traversePlatforms (return stackWorkInstall) msystem $
+        traversePlatforms' (return stackWorkInstall) msystem $
           cleanMinorSnapshots deletion cwd mver
       Snapshots -> do
         cwd <- getCurrentDirectory
-        traversePlatforms (getStackSubdir "snapshots") msystem $
+        traversePlatforms' (getStackSubdir "snapshots") msystem $
           cleanMinorSnapshots deletion cwd mver
       Compilers -> removeGhcMinorInstallation deletion mver msystem
       Tarballs -> removeGhcMinorTarball deletion mver msystem

diff --git a/src/Snapshots.hs b/src/Snapshots.hs
@@ -102,28 +102,36 @@ removeVersionSnaps deletion cwd versnap = do
         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
-
-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
+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 -> 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