move setdir to Main and use HOME/CWD to prettyprint directories

TODO

@@ -5,6 +5,5 @@
 - handle ghc super version
 - count (dirs/installs)
 - types for dirs (Install, Snapshots, Programs)
-- use ~ for $HOME
 - --keep-only X.Y W.Z:
   https://www.reddit.com/r/haskell/comments/knn5yt/stackcleanold_cli_tool_to_recover_diskspace/ghtl9wy/

src/Main.hs

@@ -73,8 +73,8 @@ sizeCmd mode notHuman =
 listCmd :: Mode -> Maybe Version -> IO ()
 listCmd mode mver =
   case mode of
-    Project -> listGhcSnapshots setStackWorkDir mver
-    Snapshots -> listGhcSnapshots setStackSnapshotsDir mver
+    Project -> setStackWorkDir >> listGhcSnapshots mver
+    Snapshots -> setStackSnapshotsDir >> listGhcSnapshots mver
     Compilers -> listGhcInstallation mver
     GHC -> do
       listCmd Compilers mver
@@ -88,8 +88,14 @@ listCmd mode mver =
 removeCmd :: Bool -> Mode -> Version -> IO ()
 removeCmd dryrun mode ghcver =
   case mode of
-    Project -> cleanGhcSnapshots setStackWorkDir dryrun ghcver
-    Snapshots -> cleanGhcSnapshots setStackSnapshotsDir dryrun ghcver
+    Project -> do
+      cwd <- getCurrentDirectory
+      setStackWorkDir
+      cleanGhcSnapshots dryrun cwd ghcver
+    Snapshots -> do
+      cwd <- getCurrentDirectory
+      setStackSnapshotsDir
+      cleanGhcSnapshots dryrun cwd ghcver
     Compilers -> removeGhcVersionInstallation dryrun ghcver
     GHC -> do
       removeCmd dryrun Compilers ghcver
@@ -103,8 +109,14 @@ removeCmd dryrun mode ghcver =
 removeMinorsCmd :: Bool -> Mode -> Maybe Version -> IO ()
 removeMinorsCmd dryrun mode mver =
   case mode of
-    Project -> cleanMinorSnapshots setStackWorkDir dryrun mver
-    Snapshots -> cleanMinorSnapshots setStackSnapshotsDir dryrun mver
+    Project -> do
+      cwd <- getCurrentDirectory
+      setStackWorkDir
+      cleanMinorSnapshots dryrun cwd mver
+    Snapshots -> do
+      cwd <- getCurrentDirectory
+      setStackSnapshotsDir
+      cleanMinorSnapshots dryrun cwd mver
     Compilers -> removeGhcMinorInstallation dryrun mver
     GHC -> do
       removeMinorsCmd dryrun Compilers mver

src/Snapshots.hs

@@ -79,42 +79,50 @@ sizeSnapshots nothuman = do
   snapshots <- getStackSubdir "snapshots"
   cmd_ "du" $ ["-h" | not nothuman] ++ ["-s", snapshots]
 
-listGhcSnapshots :: IO () -> Maybe Version -> IO ()
-listGhcSnapshots setdir mghcver = do
-  setdir
+listGhcSnapshots :: Maybe Version -> IO ()
+listGhcSnapshots mghcver = do
   ghcs <- getSnapshotDirs mghcver
   mapM_ printTotalGhcSize ghcs
 
-removeVersionSnaps :: Bool -> VersionSnapshots -> IO ()
-removeVersionSnaps dryrun versnap = do
+removeVersionSnaps :: Bool -> FilePath -> VersionSnapshots -> IO ()
+removeVersionSnaps dryrun cwd versnap = do
   let dirs = snapsHashes versnap
+  dir <- getCurrentDirectory
+  home <- getHomeDirectory
+  putStrLn $ plural (length dirs) "dir" ++ " in " ++ renderDir home dir ++ " " ++ (if dryrun then "would be " else "") ++ "removed for " ++ showVersion (snapsVersion versnap)
   mapM_ (Remove.doRemoveDirectory dryrun) dirs
-  putStrLn $ show (length dirs) ++ " dirs in ~/.stack/snapshots/ " ++ (if dryrun then "would be " else "") ++ "removed for " ++ showVersion (snapsVersion versnap)
+  where
+    plural :: Int -> String -> String
+    plural n thing = show n ++ " " ++ thing ++ if n == 1 then "" else "s"
+
+    renderDir :: FilePath -> FilePath -> FilePath
+    renderDir home fp =
+      case stripPrefix (cwd ++ "/") fp of
+        Just reldir -> reldir
+        Nothing -> "~" </> dropPrefix (home ++ "/") fp
 
-cleanGhcSnapshots :: IO () -> Bool -> Version -> IO ()
-cleanGhcSnapshots setDir dryrun ghcver = do
-  setDir
+cleanGhcSnapshots :: Bool -> FilePath -> Version -> IO ()
+cleanGhcSnapshots dryrun cwd ghcver = do
   ghcs <- getSnapshotDirs (Just ghcver)
   when (isMajorVersion ghcver) $ do
     Remove.prompt dryrun ("all " ++ showVersion ghcver ++ " builds")
-  mapM_ (removeVersionSnaps dryrun) ghcs
+  mapM_ (removeVersionSnaps dryrun cwd) ghcs
 
-cleanMinorSnapshots :: IO () -> Bool -> Maybe Version -> IO ()
-cleanMinorSnapshots setDir dryrun mghcver = do
-  setDir
+cleanMinorSnapshots :: Bool -> FilePath -> Maybe Version -> IO ()
+cleanMinorSnapshots dryrun 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 dryrun) (init gmajor)
+        mapM_ (removeVersionSnaps dryrun cwd) (init gmajor)
     Just ghcver -> do
       let newestMinor = if isMajorVersion ghcver
                         then (snapsVersion . last) ghcs
                         else ghcver
           gminors = filter ((< newestMinor) . snapsVersion) ghcs
-      mapM_ (removeVersionSnaps dryrun) gminors
+      mapM_ (removeVersionSnaps dryrun cwd) gminors
 
 cleanOldStackWork :: Bool -> Int -> IO ()
 cleanOldStackWork dryrun keep = do