simplify dry run output, use simple-prompt yesNo and simple-cmd +-+

based on experience from Stackage server

Previously was giving output like:

$ env STACK_ROOT=$PWD/work/stack/ stack-clean-old remove 9.4
all stack ghc 9.4 installations:  would be deleted
ghc-tinfo6-9.4.4 compiler would be removed
ghc-tinfo6-9.4.5 compiler would be removed
ghc-tinfo6-9.4.6 compiler would be removed
all 9.4 builds would be deleted
all 9.4 builds would be deleted
x86_64-linux-tinfo6:
all 9.4 builds would be deleted
1 dir in work/stack/snapshots/x86_64-linux-tinfo6 would be removed for 9.4.6

(use --delete (-d) for removal)

src/Directories.hs

@@ -12,7 +12,7 @@ where
 
 import Control.Monad (forM_, unless, when)
 import Data.List.Extra
-import SimpleCmd (
+import SimpleCmd ((+-+),
 #if MIN_VERSION_simple_cmd(0,2,0)
                   warning
 #endif
@@ -36,7 +36,7 @@ getStackRootDir = do
   case mroot of
     Just path -> do
       unless (isAbsolute path) $
-        warning $ "STACK_ROOT is not absolute: " ++ path
+        warning $ "STACK_ROOT is not absolute:" +-+ path
       return path
     Nothing -> do
       home <- getHomeDirectory
@@ -78,7 +78,7 @@ listPlatforms msystem = do
       if s `elem` platforms
       then return [s]
       else do
-        warning $ "no matching platform for: " ++ s
+        warning $ "no matching platform for:" +-+ s
         return []
 
 listCurrentDirectory :: IO [FilePath]

src/GHC.hs

@@ -11,6 +11,7 @@ import Data.Char (isDigit)
 import Data.List.Extra
 import Data.Version.Extra
 import SimpleCmd
+import SimplePrompt (yesNo)
 import System.FilePath
 
 import Directories (getStackSubdir, globDirs, traversePlatforms)
@@ -61,13 +62,17 @@ removeGhcVersionInstallation deletion ghcver msystem = do
   traversePlatforms getStackProgramsDir msystem $ do
     installs <- getGhcInstallDirs (Just ghcver)
     case installs of
-      [] -> putStrLn $ "stack ghc compiler version " ++ showVersion ghcver ++ " not found"
+      [] -> 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
+          yes <-
+            if isDelete deletion then
+              yesNo $ "Delete all stack ghc" +-+ showVersion ghcver +-+ "installations"
+              else return True
+          when yes $
+            mapM_ (doRemoveGhcVersion deletion) gs
         else error' "more than one match found!!"
 
 removeGhcMinorInstallation :: Deletion -> Maybe Version -> Maybe String
@@ -92,4 +97,4 @@ doRemoveGhcVersion :: Deletion -> FilePath -> IO ()
 doRemoveGhcVersion deletion ghcinst = do
   Remove.doRemoveDirectory deletion ghcinst
   Remove.removeFile deletion (ghcinst <.> "installed")
-  putStrLn $ ghcinst ++ " compiler " ++ (if isDelete deletion then "" else "would be ") ++ "removed"
+  putStrLn $ ghcinst +-+ "compiler" +-+ (if isDelete deletion then "" else "would be") +-+ "removed"

src/GHCTarball.hs

@@ -10,6 +10,7 @@ import Data.Char (isDigit)
 import Data.List.Extra
 import Data.Version.Extra
 import SimpleCmd
+import SimplePrompt (yesNo)
 import System.FilePath (dropExtension)
 import System.FilePath.Glob
 
@@ -56,11 +57,17 @@ removeGhcVersionTarball deletion ghcver msystem = do
   traversePlatforms getStackProgramsDir msystem $ do
     files <- getGhcTarballs (Just ghcver)
     case files of
-      [] -> putStrLn $ "Tarball for " ++ showVersion ghcver ++ " not found"
+      [] -> 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
+      gs ->
+        if isMajorVersion ghcver
+        then do
+          yes <-
+            if isDelete deletion then
+              yesNo $ "Delete all stack ghc" +-+ showVersion ghcver +-+ "tarballs"
+              else return True
+          when yes $
+            mapM_ (doRemoveGhcTarballVersion deletion) gs
         else error' "more than one match found!!"
 
 removeGhcMinorTarball :: Deletion -> Maybe Version -> Maybe String
@@ -84,4 +91,4 @@ removeGhcMinorTarball deletion mghcver msystem = do
 doRemoveGhcTarballVersion :: Deletion -> FilePath -> IO ()
 doRemoveGhcTarballVersion deletion ghctarball = do
   Remove.removeFile deletion ghctarball
-  putStrLn $ ghctarball ++ " tarball " ++ (if isDelete deletion then "" else "would be ") ++ "removed"
+  putStrLn $ ghctarball +-+ "tarball" +-+ (if isDelete deletion then "" else "would be") +-+ "removed"

src/Main.hs

@@ -77,10 +77,10 @@ main = do
   where
     modeOpt stackroot =
       flagWith' Project 'P' "project" "Act on current project's .stack-work/ [default in project dir]" <|>
-      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 Global 'G' "global" ("Act on both " ++ stackroot </> "{programs,snapshots}/ [default outside project dir]")
+      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 Global 'G' "global" ("Act on both" +-+ stackroot </> "{programs,snapshots}/ [default outside project dir]")
 
     deleteOpt = flagWith Dryrun Delete 'd' "delete" "Do deletion [default is dryrun]"
 

src/Remove.hs

@@ -1,6 +1,5 @@
 module Remove (
   doRemoveDirectory,
-  prompt,
   removeFile
   )
 where
@@ -20,12 +19,3 @@ removeFile deletion file =
   when (isDelete deletion) $
   whenM (D.doesFileExist file) $
   D.removeFile file
-
-prompt :: Deletion -> String -> IO ()
-prompt deletion str =
-  if isDelete deletion
-  then do
-    putStr $ "Press Enter to delete " ++ str ++ ": "
-    void getLine
-  else
-    putStrLn $ str ++ " would be deleted"

src/Snapshots.hs

@@ -20,6 +20,7 @@ import SimpleCmd
 #if MIN_VERSION_simple_cmd(0,2,1)
   hiding (whenM)
 #endif
+import SimplePrompt (yesNo)
 import System.Directory hiding (removeDirectoryRecursive, removeFile)
 import System.FilePath
 import Text.Printf
@@ -87,14 +88,14 @@ listGhcSnapshots msystem mghcver dir = do
     mapM_ printTotalGhcSize ghcs
 
 plural :: String -> Int -> String
-plural thing n = show n ++ " " ++ thing ++ if n == 1 then "" else "s"
+plural thing n = show n +-+ thing ++ if n == 1 then "" else "s"
 
 removeVersionSnaps :: Deletion -> FilePath -> VersionSnapshots -> IO ()
 removeVersionSnaps deletion cwd versnap = do
   let dirs = snapsHashes versnap
   dir <- getCurrentDirectory
   home <- getHomeDirectory
-  putStrLn $ plural "dir" (length dirs) ++ " in " ++ renderDir home dir ++ " " ++ (if isDelete deletion then "" else "would be ") ++ "removed for " ++ showVersion (snapsVersion versnap)
+  putStrLn $ plural "dir" (length dirs) +-+ "in" +-+ renderDir home dir </> "*" </> showVersion (snapsVersion versnap) +-+ (if isDelete deletion then "" else "would be") +-+ "removed"
   mapM_ (Remove.doRemoveDirectory deletion) dirs
   where
     renderDir :: FilePath -> FilePath -> FilePath
@@ -109,9 +110,12 @@ cleanGhcSnapshots deletion cwd ghcver 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
+    yes <-
+      if isMajorVersion ghcver && isDelete deletion
+      then yesNo $ "Delete all" +-+ showVersion ghcver +-+ "builds"
+      else return True
+    when yes $
+      mapM_ (removeVersionSnaps deletion cwd) ghcs
 
 cleanMinorSnapshots :: Deletion -> FilePath -> Maybe Version -> String -> IO ()
 cleanMinorSnapshots deletion cwd mghcver platform = do
@@ -148,7 +152,7 @@ cleanOldStackWork deletion keep msystem = do
       oldfiles <- drop (fromEnum keep) . reverse <$> sortedByAge
       mapM_ (Remove.doRemoveDirectory deletion . takeDirectory) oldfiles
       unless (null oldfiles) $
-        putStrLn $ plural "dir" (length oldfiles) ++ (if isDelete deletion then "" else " would be") ++ " removed for " ++ ghcver
+        putStrLn $ plural "dir" (length oldfiles) +-+ (if isDelete deletion then "" else "would be") +-+ "removed for" +-+ ghcver
       where
         sortedByAge = do
           fileTimes <- mapM newestTimeStamp dirs
@@ -176,5 +180,9 @@ printTotalGhcSize versnaps = do
 
 removeStackWork :: Deletion -> IO ()
 removeStackWork deletion = do
-  Remove.prompt deletion ".stack-work"
-  Remove.doRemoveDirectory deletion ".stack-work"
+  yes <-
+    if isDelete deletion
+    then yesNo "Delete .stack-work"
+    else return True
+  when yes $
+    Remove.doRemoveDirectory deletion ".stack-work"

src/Versions.hs

@@ -5,14 +5,15 @@ module Versions (
 where
 
 import Data.Version
+import SimpleCmd ((+-+))
 
 majorVersion :: Version -> Version
 majorVersion ver =
   let vernums = versionBranch ver in
     case length vernums of
       2 -> ver
       3 -> (makeVersion . init) vernums
-      _ -> error $ "Bad ghc version " ++ showVersion ver
+      _ -> error $ "Bad ghc version" +-+ showVersion ver
 
 isMajorVersion :: Version -> Bool
 isMajorVersion ver =

stack-clean-old.cabal

@@ -40,6 +40,7 @@ executable stack-clean-old
                      , filemanip
                      , simple-cmd >= 0.1.4
                      , simple-cmd-args >= 0.1.2
+                     , simple-prompt >= 0.2
   default-language:    Haskell2010
   ghc-options:         -Wall
   if impl(ghc >= 8.0)

stack-lts12.yaml

@@ -1,5 +1,6 @@
 resolver: lts-12.26
 
 extra-deps:
-- simple-cmd-args-0.1.2
-- simple-cmd-0.1.4
+  - simple-cmd-args-0.1.2
+  - simple-cmd-0.1.4
+  - simple-prompt-0.2.1

stack.yaml

@@ -1 +1,3 @@
 resolver: lts-20.26
+extra-deps:
+  - simple-prompt-0.2.1