Add selective cleaning for multi-package projects #583

src/Stack/Build.hs

@@ -14,7 +14,6 @@
 
 module Stack.Build
   (build
-  ,clean
   ,withLoadPackage
   ,mkBaseConfigOpts
   ,queryBuildInfo)
@@ -43,15 +42,13 @@ import qualified Data.Vector as V
 import qualified Data.Yaml as Yaml
 import           Network.HTTP.Client.Conduit (HasHttpManager)
 import           Path
-import           Path.IO
 import           Prelude hiding (FilePath, writeFile)
 import           Stack.Build.ConstructPlan
 import           Stack.Build.Execute
 import           Stack.Build.Haddock
 import           Stack.Build.Installed
 import           Stack.Build.Source
 import           Stack.Build.Target
-import           Stack.Constants
 import           Stack.Fetch as Fetch
 import           Stack.GhcPkg
 import           Stack.Package
@@ -184,14 +181,6 @@ withLoadPackage menv inner = do
         , packageConfigPlatform = configPlatform (getConfig econfig)
         }
 
--- | Reset the build (remove Shake database and .gen files).
-clean :: (M env m) => m ()
-clean = do
-    econfig <- asks getEnvConfig
-    forM_
-        (Map.keys (envConfigPackages econfig))
-        (distDirFromDir >=> removeTreeIfExists)
-
 -- | Set the code page for this process as necessary. Only applies to Windows.
 -- See: https://github.com/commercialhaskell/stack/issues/738
 fixCodePage :: (MonadIO m, MonadMask m, MonadLogger m) => m a -> m a

src/Stack/Clean.hs

@@ -0,0 +1,66 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
+-- | Clean a project.
+module Stack.Clean
+    (clean
+    ,CleanOpts(..)
+    ,StackCleanException(..)
+    ) where
+
+import           Control.Exception (Exception)
+import           Control.Monad.Catch (MonadThrow,throwM)
+import           Control.Monad.IO.Class (MonadIO)
+import           Control.Monad.Logger (MonadLogger)
+import           Control.Monad.Reader (MonadReader)
+import           Data.Foldable (forM_)
+import           Data.List ((\\),intercalate)
+import qualified Data.Map.Strict as Map
+import           Data.Maybe (mapMaybe)
+import           Data.Typeable (Typeable)
+import           Path.IO (removeTreeIfExists)
+import           Stack.Build.Source (getLocalPackageViews)
+import           Stack.Build.Target (LocalPackageView(..))
+import           Stack.Constants (distDirFromDir)
+import           Stack.Types (HasEnvConfig,PackageName)
+
+
+-- | Reset the build, i.e. remove the @dist@ directory
+-- (for example @.stack-work\/dist\/x84_64-linux\/Cabal-1.22.4.0@)
+-- for all targets.
+--
+-- Throws 'StackCleanException'.
+clean
+    :: (MonadThrow m, MonadIO m, MonadReader env m, HasEnvConfig env, MonadLogger m)
+    => CleanOpts
+    -> m ()
+clean (CleanOpts targets) = do
+    locals <- getLocalPackageViews
+    case targets \\ Map.keys locals of
+        [] -> do
+            let lpvs =
+                    if null targets
+                        then Map.elems locals -- default to cleaning all local packages
+                        else mapMaybe (`Map.lookup` locals) targets
+            forM_ lpvs $ \(LocalPackageView{lpvRoot = pkgDir},_) -> do
+                distDir <- distDirFromDir pkgDir
+                removeTreeIfExists distDir
+        pkgs -> throwM (NonLocalPackages pkgs)
+
+-- | Options for cleaning a project.
+newtype CleanOpts = CleanOpts
+    { cleanOptsTargets :: [PackageName]
+    -- ^ Names of the packages to clean.
+    -- If the list is empty, every local package should be cleaned.
+    }
+
+-- | Exceptions during cleanup.
+newtype StackCleanException
+    = NonLocalPackages [PackageName]
+    deriving (Typeable)
+
+instance Show StackCleanException where
+    show (NonLocalPackages pkgs) =
+        "The following packages are not part of this project: " ++
+        intercalate ", " (map show pkgs)
+
+instance Exception StackCleanException

src/Stack/Options.hs

@@ -4,6 +4,7 @@ module Stack.Options
     (Command(..)
     ,benchOptsParser
     ,buildOptsParser
+    ,cleanOptsParser
     ,configCmdSetParser
     ,configOptsParser
     ,dockerOptsParser
@@ -40,6 +41,7 @@ import           Options.Applicative
 import           Options.Applicative.Args
 import           Options.Applicative.Builder.Extra
 import           Options.Applicative.Types (fromM, oneM, readerAsk)
+import           Stack.Clean (CleanOpts(..))
 import           Stack.Config (packagesParser)
 import           Stack.ConfigCmd
 import           Stack.Constants (stackProgName)
@@ -218,6 +220,16 @@ readFlag = do
             return $ Map.singleton pn' $ Map.singleton flagN b
         _ -> readerError "Must have a colon"
 
+-- | Command-line parser for the clean command.
+cleanOptsParser :: Parser CleanOpts
+cleanOptsParser = CleanOpts <$> packages
+  where
+    packages =
+        many
+            (packageNameArgument
+                 (metavar "PACKAGE" <>
+                  help "If none specified, clean all local packages"))
+
 -- | Command-line arguments parser for configuration.
 configOptsParser :: Bool -> Parser ConfigMonoid
 configOptsParser hide0 =

src/main/Main.hs

@@ -51,6 +51,7 @@ import           Path.IO
 import qualified Paths_stack as Meta
 import           Prelude hiding (pi, mapM)
 import           Stack.Build
+import           Stack.Clean (CleanOpts, clean)
 import           Stack.Config
 import           Stack.ConfigCmd as ConfigCmd
 import           Stack.Constants
@@ -283,7 +284,7 @@ main = withInterpreterArgs stackProgName $ \args isInterpreter -> do
                         "Clean the local packages"
                         cmdFooter
                         cleanCmd
-                        (pure ())
+                        cleanOptsParser
              addCommand' "list-dependencies"
                         "List the dependencies"
                         cmdFooter
@@ -752,8 +753,8 @@ withBuildConfigExt go@GlobalOpts{..} mbefore inner mafter = do
                                              do lk' <- readIORef curLk
                                                 munlockFile lk')
 
-cleanCmd :: () -> GlobalOpts -> IO ()
-cleanCmd () go = withBuildConfigAndLock go (const clean)
+cleanCmd :: CleanOpts -> GlobalOpts -> IO ()
+cleanCmd opts go = withBuildConfigAndLock go (const (clean opts))
 
 -- | Helper for build and install commands
 buildCmd :: BuildOpts -> GlobalOpts -> IO ()

stack.cabal

@@ -51,6 +51,7 @@ library
                      Options.Applicative.Args
                      Options.Applicative.Complicated
                      Stack.BuildPlan
+                     Stack.Clean
                      Stack.Config
                      Stack.Config.Docker
                      Stack.ConfigCmd