add support for programs/ ghc tarballs too (#9)

src/GHCTarball.hs

@@ -0,0 +1,85 @@
+module GHCTarball (
+  listGhcTarballs,
+  removeGhcMinorTarball,
+  removeGhcVersionTarball
+  )
+where
+
+import Control.Monad.Extra
+import Data.Char (isDigit)
+import Data.List.Extra
+import Data.Version.Extra
+import SimpleCmd
+import System.FilePath (dropExtension)
+import System.FilePath.Glob
+
+import Directories (getStackSubdir, switchToSystemDirUnder)
+import qualified Remove
+import Types
+import Versions
+
+getStackProgramsDir :: IO FilePath
+getStackProgramsDir =
+  getStackSubdir "programs"
+
+setStackProgramsDir :: Maybe String -> IO ()
+setStackProgramsDir msystem =
+  getStackProgramsDir >>= switchToSystemDirUnder msystem
+
+getGhcTarballs :: Maybe Version -> Maybe String -> IO [FilePath]
+getGhcTarballs mghcver msystem = do
+  setStackProgramsDir msystem
+  sortOn ghcTarballVersion . map (dropPrefix "./") <$> namesMatching ("ghc" ++ matchVersion ++ ".tar.*")
+  where
+    matchVersion =
+      case mghcver of
+        Nothing -> "*"
+        Just ver ->
+          "*-" ++ showVersion ver ++ if isMajorVersion ver then "*" else ""
+
+ghcTarballVersion :: FilePath -> Version
+ghcTarballVersion =
+  readVersion . checkChars . takeWhileEnd (/= '-') .  dropSuffix ".tar" . dropExtension
+  where
+    checkChars vs =
+      let isVerChar c = isDigit c || c == '.'
+      in if all isVerChar vs
+         then vs
+         else error $ "unknown version:" +-+ vs
+
+listGhcTarballs :: Maybe Version -> Maybe String -> IO ()
+listGhcTarballs mghcver msystem = do
+  files <- getGhcTarballs mghcver msystem
+  mapM_ putStrLn $
+    case mghcver of
+      Nothing -> files
+      Just ghcver -> filter ((== ghcver) . (if isMajorVersion ghcver then majorVersion else id) . ghcTarballVersion) files
+
+removeGhcVersionTarball :: Deletion -> Version -> Maybe String -> IO ()
+removeGhcVersionTarball deletion ghcver msystem = do
+  files <- getGhcTarballs (Just ghcver) msystem
+  case files of
+    [] -> 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
+      else error' "more than one match found!!"
+
+removeGhcMinorTarball :: Deletion -> Maybe Version -> Maybe String
+                           -> IO ()
+removeGhcMinorTarball deletion mghcver msystem = do
+  files <- getGhcTarballs (majorVersion <$> mghcver) msystem
+  case mghcver of
+    Nothing -> do
+      let majors = groupOn (majorVersion . ghcTarballVersion) files
+      forM_ majors $ \ minors ->
+        forM_ (init minors) $ doRemoveGhcTarballVersion deletion
+    Just ghcver -> do
+      let minors = filter ((< ghcver) . ghcTarballVersion) files
+      forM_ minors $ doRemoveGhcTarballVersion deletion
+
+doRemoveGhcTarballVersion :: Deletion -> FilePath -> IO ()
+doRemoveGhcTarballVersion deletion ghctarball = do
+  Remove.removeFile deletion ghctarball
+  putStrLn $ ghctarball ++ " tarball " ++ (if isDelete deletion then "" else "would be ") ++ "removed"

src/Main.hs

@@ -18,11 +18,12 @@ import System.FilePath
 import System.IO (BufferMode(NoBuffering), hSetBuffering, stdout)
 
 import GHC
+import GHCTarball
 import Paths_stack_clean_old (version)
 import Snapshots
 import Types
 
-data Mode = Default | Project | Snapshots | Compilers | GHC
+data Mode = Default | Project | Snapshots | Compilers | GHC | Tarballs
 
 data Recursion = Subdirs | Recursive
   deriving Eq
@@ -74,7 +75,8 @@ main = do
       flagWith' Project 'P' "project" "Act on current project's .stack-work/ [default in project dir]" <|>
       flagWith' Snapshots 'S' "snapshots" "Act on ~/.stack/snapshots/" <|>
       flagWith' GHC 'G' "global" "Act on both ~/.stack/{programs,snapshots}/ [default outside project dir]" <|>
-      flagWith Default Compilers 'C' "compilers" "Act on ~/.stack/programs/"
+      flagWith' Compilers 'C' "compilers" "Act on ~/.stack/programs/ installations" <|>
+      flagWith Default Tarballs 'T' "tarballs" "Act on ~/.stack/programs/ tarballs"
 
     deleteOpt = flagWith Dryrun Delete 'd' "delete" "Do deletion [default is dryrun]"
 
@@ -123,6 +125,7 @@ sizeCmd mode mrecursion notHuman =
     Project -> withRecursion' False False mrecursion $ sizeStackWork notHuman
     Snapshots -> sizeSnapshots notHuman
     Compilers -> sizeGhcInstalls notHuman
+    Tarballs -> error' "use --compilers"
     GHC -> do
       sizeCmd Snapshots Nothing notHuman
       sizeCmd Compilers Nothing notHuman
@@ -139,6 +142,7 @@ listCmd mode mrecursion mver msystem =
     Project -> setStackWorkInstallDir msystem >> listGhcSnapshots mver
     Snapshots -> setStackSnapshotsDir msystem >> listGhcSnapshots mver
     Compilers -> listGhcInstallation mver msystem
+    Tarballs -> listGhcTarballs mver msystem
     GHC -> do
       listCmd Snapshots Nothing mver msystem
       listCmd Compilers Nothing mver msystem
@@ -169,6 +173,8 @@ removeRun deletion mode mrecursion ghcver msystem =
         cleanGhcSnapshots deletion cwd ghcver
       Compilers -> do
         removeGhcVersionInstallation deletion ghcver msystem
+      Tarballs -> do
+        removeGhcVersionTarball deletion ghcver msystem
       GHC -> do
         removeRun deletion Compilers Nothing ghcver msystem
         removeRun deletion Snapshots Nothing ghcver msystem
@@ -198,6 +204,7 @@ removeMinorsRun deletion mode mrecursion mver msystem = do
         setStackSnapshotsDir msystem
         cleanMinorSnapshots deletion cwd mver
       Compilers -> removeGhcMinorInstallation deletion mver msystem
+      Tarballs -> removeGhcMinorTarball deletion mver msystem
       GHC -> do
         removeMinorsRun deletion Compilers Nothing mver msystem
         removeMinorsRun deletion Snapshots Nothing mver msystem

stack-clean-old.cabal

@@ -27,6 +27,7 @@ executable stack-clean-old
   other-modules:       Paths_stack_clean_old
                        Directories
                        GHC
+                       GHCTarball
                        Remove
                        Snapshots
                        Types