From a407eb8aaf435a8aea86adc76e9c48a6c7ff5a85 Mon Sep 17 00:00:00 2001 From: Jens Petersen Date: Wed, 13 Sep 2023 14:18:18 +0800 Subject: [PATCH] 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 | 6 +++--- src/GHC.hs | 13 +++++++++---- src/GHCTarball.hs | 17 ++++++++++++----- src/Main.hs | 8 ++++---- src/Remove.hs | 10 ---------- src/Snapshots.hs | 24 ++++++++++++++++-------- src/Versions.hs | 3 ++- stack-clean-old.cabal | 1 + stack-lts12.yaml | 5 +++-- stack.yaml | 2 ++ 10 files changed, 52 insertions(+), 37 deletions(-) diff --git a/src/Directories.hs b/src/Directories.hs index 24790f7..62c965a 100644 --- a/src/Directories.hs +++ b/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] diff --git a/src/GHC.hs b/src/GHC.hs index 1f1374d..32a9152 100644 --- a/src/GHC.hs +++ b/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" diff --git a/src/GHCTarball.hs b/src/GHCTarball.hs index e104aa4..7864fde 100644 --- a/src/GHCTarball.hs +++ b/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" diff --git a/src/Main.hs b/src/Main.hs index b3be951..818fc63 100644 --- a/src/Main.hs +++ b/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]" diff --git a/src/Remove.hs b/src/Remove.hs index f88a45d..230837d 100644 --- a/src/Remove.hs +++ b/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" diff --git a/src/Snapshots.hs b/src/Snapshots.hs index 2b2a3eb..7dc77db 100644 --- a/src/Snapshots.hs +++ b/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" diff --git a/src/Versions.hs b/src/Versions.hs index eef7f2d..bd5cb7a 100644 --- a/src/Versions.hs +++ b/src/Versions.hs @@ -5,6 +5,7 @@ module Versions ( where import Data.Version +import SimpleCmd ((+-+)) majorVersion :: Version -> Version majorVersion ver = @@ -12,7 +13,7 @@ majorVersion ver = 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 = diff --git a/stack-clean-old.cabal b/stack-clean-old.cabal index 11f169d..fc537f2 100644 --- a/stack-clean-old.cabal +++ b/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) diff --git a/stack-lts12.yaml b/stack-lts12.yaml index 3feca09..e813519 100644 --- a/stack-lts12.yaml +++ b/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 diff --git a/stack.yaml b/stack.yaml index fc9172f..7f142e5 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1 +1,3 @@ resolver: lts-20.26 +extra-deps: + - simple-prompt-0.2.1