list all platforms (#15)

src/Directories.hs

@@ -1,18 +1,30 @@
+{-# LANGUAGE CPP #-}
+
 module Directories (
   getStackSubdir,
+  getStackProgramsDir,
   globDirs,
-  switchToSystemDirUnder,
+  traversePlatforms,
+  traversePlatforms',
   listCurrentDirectory
   )
 where
 
-import Control.Monad (unless)
+import Control.Monad (forM_, unless, when)
 import Data.List.Extra
-import SimpleCmd (error', warning)
+import SimpleCmd (
+#if MIN_VERSION_simple_cmd(0,2,0)
+                  warning
+#endif
+                 )
 import System.Directory
 import System.Environment
 import System.FilePath
 import System.FilePath.Glob
+#if !MIN_VERSION_simple_cmd(0,2,0)
+-- for warning
+import System.IO (hPutStrLn, stderr)
+#endif
 
 globDirs :: String -> IO [FilePath]
 globDirs pat = do
@@ -30,35 +42,50 @@ getStackRootDir = do
       home <- getHomeDirectory
       return $ home </> ".stack"
 
+getStackProgramsDir :: IO FilePath
+getStackProgramsDir =
+  getStackSubdir "programs"
+
 getStackSubdir :: FilePath -> IO FilePath
 getStackSubdir subdir = do
   stackRoot <- getStackRootDir
   return $ stackRoot </> subdir
 
-switchToSystemDirUnder :: Maybe String -> FilePath -> IO ()
-switchToSystemDirUnder msystem dir = do
-  exists <- doesDirectoryExist dir
-  if exists
-    then setCurrentDirectory dir
-    else error' $ dir ++ " not found"
-  systems <- listCurrentDirectory
-  -- FIXME be more precise/check "system" dirs
-  -- eg 64bit intel Linux: x86_64-linux-tinfo6
-  let system =
-        case msystem of
-          Just sys ->
-            if sys `elem` systems
-            then sys
-            else error' $ sys ++ " not found"
-          Nothing ->
-            case systems of
-              [] -> error' $ "No OS system in " ++ dir
-              [sys] -> sys
-              ss -> error' $ intercalate "\n" $
-                    ["Please specify platform with --os-system (-o).",
-                      dir ++ " has:"] ++ ss
-  setCurrentDirectory system
+traversePlatforms :: IO FilePath -> Maybe String -> IO () -> IO ()
+traversePlatforms getdir msystem act = do
+  dir <- getdir
+  withCurrentDirectory dir $ do
+    platforms <- listPlatforms msystem
+    forM_ platforms $ \p -> do
+      when (length platforms > 1) $
+        putStrLn (p ++ ":")
+      withCurrentDirectory p act
+
+traversePlatforms' :: IO FilePath -> Maybe String -> (FilePath -> IO ())
+                   -> IO ()
+traversePlatforms' getdir msystem act = do
+  dir <- getdir
+  withCurrentDirectory dir $ do
+    platforms <- listPlatforms msystem
+    mapM_ act platforms
+
+listPlatforms :: Maybe String -> IO [FilePath]
+listPlatforms msystem = do
+  platforms <- listDirectory "."
+  case msystem of
+    Nothing -> return platforms
+    Just s ->
+      if s `elem` platforms
+      then return [s]
+      else do
+        warning $ "no matching platform for: " ++ s
+        return []
 
 listCurrentDirectory :: IO [FilePath]
 listCurrentDirectory =
   filter (\d -> head d /= '.') <$> listDirectory "."
+
+#if !MIN_VERSION_simple_cmd(0,2,0)
+warning :: String -> IO ()
+warning = hPutStrLn stderr
+#endif

src/GHC.hs

@@ -13,7 +13,7 @@ import Data.Version.Extra
 import SimpleCmd
 import System.FilePath
 
-import Directories (getStackSubdir, globDirs, switchToSystemDirUnder)
+import Directories (getStackSubdir, globDirs, traversePlatforms)
 import qualified Remove
 import Types
 import Versions
@@ -27,13 +27,8 @@ sizeGhcPrograms nothuman = do
   programs <- getStackProgramsDir
   cmd_ "du" $ ["-h" | not nothuman] ++ ["-s", programs]
 
-setStackProgramsDir :: Maybe String -> IO ()
-setStackProgramsDir msystem =
-  getStackProgramsDir >>= switchToSystemDirUnder msystem
-
-getGhcInstallDirs :: Maybe Version -> Maybe String -> IO [FilePath]
-getGhcInstallDirs mghcver msystem = do
-  setStackProgramsDir msystem
+getGhcInstallDirs :: Maybe Version -> IO [FilePath]
+getGhcInstallDirs mghcver =
   sortOn ghcInstallVersion <$> globDirs ("ghc" ++ matchVersion)
   where
     matchVersion =
@@ -54,34 +49,40 @@ ghcInstallVersion =
 
 listGhcInstallation :: Maybe Version -> Maybe String -> IO ()
 listGhcInstallation mghcver msystem = do
-  dirs <- getGhcInstallDirs mghcver msystem
-  mapM_ putStrLn $ case mghcver of
-    Nothing -> dirs
-    Just ghcver -> filter ((== ghcver) . (if isMajorVersion ghcver then majorVersion else id) . ghcInstallVersion) dirs
+  traversePlatforms getStackProgramsDir msystem $ do
+    dirs <- getGhcInstallDirs mghcver
+    mapM_ putStrLn $
+      case mghcver of
+        Nothing -> dirs
+        Just ghcver -> filter ((== ghcver) . (if isMajorVersion ghcver then majorVersion else id) . ghcInstallVersion) dirs
 
 removeGhcVersionInstallation :: Deletion -> Version -> Maybe String -> IO ()
 removeGhcVersionInstallation deletion ghcver msystem = do
-  installs <- getGhcInstallDirs (Just ghcver) msystem
-  case installs of
-    [] -> 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
-      else error' "more than one match found!!"
+  traversePlatforms getStackProgramsDir msystem $ do
+    installs <- getGhcInstallDirs (Just ghcver)
+    case installs of
+      [] -> 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
+        else error' "more than one match found!!"
 
 removeGhcMinorInstallation :: Deletion -> Maybe Version -> Maybe String
                            -> IO ()
 removeGhcMinorInstallation deletion mghcver msystem = do
-  dirs <- getGhcInstallDirs (majorVersion <$> mghcver) msystem
-  case mghcver of
-    Nothing -> do
-      let majors = groupOn (majorVersion . ghcInstallVersion) dirs
-      forM_ majors $ \ minors ->
-        forM_ (init minors) $ doRemoveGhcVersion deletion
-    Just ghcver -> do
-      let minors = filter ((< ghcver) . ghcInstallVersion) dirs
-      forM_ minors $ doRemoveGhcVersion deletion
+  traversePlatforms getStackProgramsDir msystem $ do
+    dirs <- getGhcInstallDirs (majorVersion <$> mghcver)
+    case mghcver of
+      Nothing -> do
+        let majors = groupOn (majorVersion . ghcInstallVersion) dirs
+        forM_ majors $ \ minors ->
+          forM_ (init minors) $ doRemoveGhcVersion deletion
+      Just ghcver -> do
+        let minors = filter ((< ghcver) . ghcInstallVersion) dirs
+        forM_ minors $ doRemoveGhcVersion deletion
 
 doRemoveGhcVersion :: Deletion -> FilePath -> IO ()
 doRemoveGhcVersion deletion ghcinst = do

src/GHCTarball.hs

@@ -13,22 +13,17 @@ import SimpleCmd
 import System.FilePath (dropExtension)
 import System.FilePath.Glob
 
-import Directories (getStackSubdir, switchToSystemDirUnder)
+import Directories (getStackProgramsDir, traversePlatforms)
 import qualified Remove
 import Types
 import Versions
 
-getStackProgramsDir :: IO FilePath
-getStackProgramsDir =
-  getStackSubdir "programs"
+-- setStackProgramsDir :: Maybe String -> IO ()
+-- setStackProgramsDir msystem =
+--   getStackProgramsDir >>= switchToSystemDirUnder msystem
 
-setStackProgramsDir :: Maybe String -> IO ()
-setStackProgramsDir msystem =
-  getStackProgramsDir >>= switchToSystemDirUnder msystem
-
-getGhcTarballs :: Maybe Version -> Maybe String -> IO [FilePath]
-getGhcTarballs mghcver msystem = do
-  setStackProgramsDir msystem
+getGhcTarballs :: Maybe Version -> IO [FilePath]
+getGhcTarballs mghcver = do
   sortOn ghcTarballVersion . map (dropPrefix "./") <$> namesMatching ("ghc" ++ matchVersion ++ ".tar.*")
   where
     matchVersion =
@@ -49,35 +44,38 @@ ghcTarballVersion =
 
 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
+  traversePlatforms getStackProgramsDir msystem $ do
+    files <- getGhcTarballs mghcver
+    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!!"
+  traversePlatforms getStackProgramsDir msystem $ do
+    files <- getGhcTarballs (Just ghcver)
+    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
+  traversePlatforms getStackProgramsDir msystem $ do
+    files <- getGhcTarballs (majorVersion <$> mghcver)
+    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

src/Main.hs

@@ -18,6 +18,7 @@ import System.Environment (lookupEnv)
 import System.FilePath
 import System.IO (BufferMode(NoBuffering), hSetBuffering, stdout)
 
+import Directories (getStackSubdir, traversePlatforms)
 import GHC
 import GHCTarball
 import Paths_stack_clean_old (version)
@@ -41,6 +42,7 @@ main = do
       <$> modeOpt stackroot_str
       <*> recursionOpt
       <*> notHumanOpt
+      <*> optional systemOpt
     , Subcommand "list" "List sizes per ghc version" $
       listCmd
       <$> modeOpt stackroot_str
@@ -121,28 +123,28 @@ withRecursion' changedir needinstall mrecursion act = do
         else act dir
     Nothing -> act ""
 
-sizeCmd :: Mode -> Maybe Recursion -> Bool -> IO ()
-sizeCmd mode mrecursion notHuman =
+sizeCmd :: Mode -> Maybe Recursion -> Bool -> Maybe String -> IO ()
+sizeCmd mode mrecursion notHuman msystem =
   case mode of
     Project -> withRecursion' False False mrecursion $ sizeStackWork notHuman
-    Snapshots -> sizeSnapshots notHuman
+    Snapshots -> sizeSnapshots notHuman msystem
     Compilers -> sizeGhcPrograms notHuman
     Tarballs -> error' "use --compilers"
     GHC -> do
-      sizeCmd Snapshots Nothing notHuman
-      sizeCmd Compilers Nothing notHuman
+      sizeCmd Snapshots Nothing notHuman msystem
+      sizeCmd Compilers Nothing notHuman msystem
     Default -> do
       isProject <- doesDirectoryExist ".stack-work"
       if isProject || isJust mrecursion
-        then sizeCmd Project mrecursion notHuman
-        else sizeCmd GHC Nothing notHuman
+        then sizeCmd Project mrecursion notHuman msystem
+        else sizeCmd GHC Nothing notHuman msystem
 
 listCmd :: Mode -> Maybe Recursion -> Maybe Version -> Maybe String -> IO ()
 listCmd mode mrecursion mver msystem =
   withRecursion True mrecursion $
   case mode of
-    Project -> setStackWorkInstallDir msystem >> listGhcSnapshots mver
-    Snapshots -> setStackSnapshotsDir msystem >> listGhcSnapshots mver
+    Project -> listGhcSnapshots msystem mver stackWorkInstall
+    Snapshots -> getStackSubdir "snapshots" >>= listGhcSnapshots msystem mver
     Compilers -> listGhcInstallation mver msystem
     Tarballs -> listGhcTarballs mver msystem
     GHC -> do
@@ -167,12 +169,12 @@ removeRun deletion mode mrecursion ghcver msystem =
     case mode of
       Project -> do
         cwd <- getCurrentDirectory
-        setStackWorkInstallDir msystem
-        cleanGhcSnapshots deletion cwd ghcver
+        traversePlatforms (return stackWorkInstall) msystem $
+          cleanGhcSnapshots deletion cwd ghcver
       Snapshots -> do
         cwd <- getCurrentDirectory
-        setStackSnapshotsDir msystem
-        cleanGhcSnapshots deletion cwd ghcver
+        traversePlatforms (getStackSubdir "snapshots") msystem $
+          cleanGhcSnapshots deletion cwd ghcver
       Compilers -> do
         removeGhcVersionInstallation deletion ghcver msystem
       Tarballs -> do
@@ -199,12 +201,12 @@ removeMinorsRun deletion mode mrecursion mver msystem = do
     case mode of
       Project -> do
         cwd <- getCurrentDirectory
-        setStackWorkInstallDir msystem
-        cleanMinorSnapshots deletion cwd mver
+        traversePlatforms (return stackWorkInstall) msystem $
+          cleanMinorSnapshots deletion cwd mver
       Snapshots -> do
         cwd <- getCurrentDirectory
-        setStackSnapshotsDir msystem
-        cleanMinorSnapshots deletion cwd mver
+        traversePlatforms (getStackSubdir "snapshots") msystem $
+          cleanMinorSnapshots deletion cwd mver
       Compilers -> removeGhcMinorInstallation deletion mver msystem
       Tarballs -> removeGhcMinorTarball deletion mver msystem
       GHC -> do