Merge pull request #6796 from commercialhaskell/fix6711

Re #6771 Add `--[no-]omit-this` to `stack clean`

Author: mpilgrem

ChangeLog.md

@@ -27,6 +27,9 @@ Other enhancements:
 * From GHC 9.12.1, `base` is not a GHC wired-in package. In configuration files,
   the `notify-if-base-not-boot` key is introduced, to allow the exisitng
   notification to be muted if unwanted when using such GHC versions.
+* Add flag `--[no-]omit-this` (default: disabled) to Stack's `clean` command to
+  omit directories currently in use from cleaning (when `--full` is not
+  specified).
 
 Bug fixes:
 

doc/commands/clean_command.md

@@ -5,7 +5,7 @@
 Either
 
 ~~~text
-stack clean [PACKAGE]
+stack clean [PACKAGE] [--[no-]omit-this]
 ~~~
 
 or
@@ -14,8 +14,17 @@ or
 stack clean --full
 ~~~
 
-`stack clean` deletes build artefacts for one or more project packages specified
-as arguments. If no project packages are specified, all project packages are
-cleaned.
+`stack clean` deletes build artefacts for one or more project packages.
 
-`stack clean --full` deletes the project's Stack working directory.
+By default:
+
+* all project packages are cleaned. Pass one or more project package names to
+  specify individual project packages; and
+
+* the `dist` directory and all of its subdirectories in the Stack work directory
+  for each relevant project package are deleted. Pass the flag `--omit-this` to
+  omit, from cleaning, the `dist` work directory (see `stack path --dist-dir`)
+  and its subdirectories currently in use.
+
+`stack clean --full` deletes the Stack work directories of the project and its
+project packages.

src/Stack/CLI.hs

@@ -230,7 +230,7 @@ commandLineHandler currentDir progName mExecutablePath isInterpreter =
 
   clean = addCommand'
     "clean"
-    "Delete build artefacts for the project packages."
+    "Delete build artefacts for project packages."
     cleanCmd
     (cleanOptsParser Clean)
 

src/Stack/Clean.hs

@@ -12,23 +12,29 @@ Types and functions related to Stack's @clean@ and @purge@ commands.
 
 module Stack.Clean
   ( CleanOpts (..)
+  , CleanDepth (..)
   , CleanCommand (..)
   , cleanCmd
   , clean
   ) where
 
+import           Control.Monad.Extra ( concatMapM )
 import           Data.List ( (\\) )
 import qualified Data.Map.Strict as Map
-import           Path.IO ( ignoringAbsence, removeDirRecur )
+import           Path ( (</>), isProperPrefixOf )
+import           Path.IO ( ignoringAbsence, listDirRecur, removeDirRecur )
 import           Stack.Config ( withBuildConfig )
-import           Stack.Constants.Config ( rootDistDirFromDir, workDirFromDir )
+import           Stack.Constants.Config
+                   ( distRelativeDir, rootDistDirFromDir, workDirFromDir )
 import           Stack.Prelude
-import           Stack.Runners ( ShouldReexec (..), withConfig )
+import           Stack.Runners
+                   ( ShouldReexec (..), withConfig, withDefaultEnvConfig )
 import           Stack.Types.BuildConfig
                    ( BuildConfig (..), HasBuildConfig (..), getWorkDir )
 import           Stack.Types.Config ( Config )
+import           Stack.Types.EnvConfig ( EnvConfig )
 import           Stack.Types.Runner ( Runner )
-import           Stack.Types.SourceMap ( SMWanted (..), ppRoot )
+import           Stack.Types.SourceMap ( ProjectPackage, SMWanted (..), ppRoot )
 
 -- | Type representing \'pretty\' exceptions thrown by functions exported by the
 -- "Stack.Clean" module.
@@ -64,7 +70,13 @@ instance Pretty CleanPrettyException where
 instance Exception CleanPrettyException
 
 -- | Type representing command line options for the @stack clean@ command.
-data CleanOpts
+data CleanOpts = CleanOpts
+  { depth    :: !CleanDepth
+  , omitThis :: !Bool
+  }
+
+-- | Type representing depths of cleaning for the @stack clean@ command.
+data CleanDepth
   = CleanShallow [PackageName]
     -- ^ Delete the "dist directories" as defined in
     -- 'Stack.Constants.Config.distRelativeDir' for the given project packages.
@@ -84,7 +96,11 @@ cleanCmd = withConfig NoReexec . clean
 -- | Deletes build artifacts in the current project.
 clean :: CleanOpts -> RIO Config ()
 clean cleanOpts = do
-  toDelete <- withBuildConfig $ dirsToDelete cleanOpts
+  toDelete <- if cleanOpts.omitThis
+    then
+      withDefaultEnvConfig $ dirsToDeleteGivenConfig cleanOpts.depth
+    else
+      withBuildConfig $ dirsToDeleteSimple cleanOpts.depth
   logDebug $ "Need to delete: " <> fromString (show (map toFilePath toDelete))
   failures <- catMaybes <$> mapM cleanDir toDelete
   case failures of
@@ -97,20 +113,62 @@ cleanDir dir = do
   liftIO (ignoringAbsence (removeDirRecur dir) >> pure Nothing) `catchAny` \ex ->
     pure $ Just (dir, ex)
 
-dirsToDelete :: CleanOpts -> RIO BuildConfig [Path Abs Dir]
-dirsToDelete cleanOpts = do
+dirsToDeleteSimple :: CleanDepth -> RIO BuildConfig [Path Abs Dir]
+dirsToDeleteSimple depth = do
+  packages <- view $ buildConfigL . to (.smWanted.project)
+  case depth of
+    CleanShallow [] -> do
+      -- Filter out packages listed as extra-deps
+      let pkgNames = Map.elems packages
+      mapM (rootDistDirFromDir . ppRoot) pkgNames
+    CleanShallow targets -> do
+      let localPkgNames = Map.keys packages
+          getPkgDir pkgName' = fmap ppRoot (Map.lookup pkgName' packages)
+          pkgNames = mapMaybe getPkgDir targets
+      case targets \\ localPkgNames of
+        [] -> mapM rootDistDirFromDir pkgNames
+        xs -> prettyThrowM (NonLocalPackages xs)
+    CleanFull -> allWorkDirs $ Map.elems packages
+
+dirsToDeleteGivenConfig :: CleanDepth -> RIO EnvConfig [Path Abs Dir]
+dirsToDeleteGivenConfig depth = do
   packages <- view $ buildConfigL . to (.smWanted.project)
-  case cleanOpts of
-    CleanShallow [] ->
+  case depth of
+    CleanShallow [] -> do
       -- Filter out packages listed as extra-deps
-      mapM (rootDistDirFromDir . ppRoot) $ Map.elems packages
+      let pkgNames = Map.elems packages
+      concatMapM (unusedRootDistDirsFromDir . ppRoot) pkgNames
     CleanShallow targets -> do
       let localPkgNames = Map.keys packages
           getPkgDir pkgName' = fmap ppRoot (Map.lookup pkgName' packages)
+          pkgNames = mapMaybe getPkgDir targets
       case targets \\ localPkgNames of
-        [] -> mapM rootDistDirFromDir (mapMaybe getPkgDir targets)
+        [] -> concatMapM unusedRootDistDirsFromDir pkgNames
         xs -> prettyThrowM (NonLocalPackages xs)
-    CleanFull -> do
-      pkgWorkDirs <- mapM (workDirFromDir . ppRoot) $ Map.elems packages
-      projectWorkDir <- getWorkDir
-      pure (projectWorkDir : pkgWorkDirs)
+    CleanFull -> allWorkDirs $ Map.elems packages
+
+allWorkDirs :: HasBuildConfig env => [ProjectPackage] -> RIO env [Path Abs Dir]
+allWorkDirs pps = do
+  pkgWorkDirs <- mapM (workDirFromDir . ppRoot) pps
+  projectWorkDir <- getWorkDir
+  pure (projectWorkDir : pkgWorkDirs)
+
+unusedRootDistDirsFromDir :: Path Abs Dir -> RIO EnvConfig [Path Abs Dir]
+unusedRootDistDirsFromDir pkgDir = do
+  rootDistDir <- rootDistDirFromDir pkgDir
+  omitDir <- fmap (pkgDir </>) distRelativeDir
+  allDirsOmittingDirs rootDistDir omitDir
+
+allDirsOmittingDirs ::
+     MonadIO m
+  => Path Abs Dir
+  -> Path Abs Dir
+  -> m [Path Abs Dir]
+allDirsOmittingDirs topDir subDir = do
+  allDirs <- (topDir :) . fst <$> listDirRecur topDir
+  let isNotInSubDir dir = not
+        ( isProperPrefixOf dir subDir
+        || subDir == dir
+        || isProperPrefixOf subDir dir
+        )
+  pure $ filter isNotInSubDir allDirs

src/Stack/Options/CleanParser.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE ApplicativeDo     #-}
 
 {-|
 Module      : Stack.Options.CleanParser
@@ -9,25 +10,50 @@ module Stack.Options.CleanParser
   ( cleanOptsParser
   ) where
 
-import           Options.Applicative ( Parser, flag', help, long, metavar )
-import           Stack.Clean ( CleanCommand (..), CleanOpts (..) )
+import           Options.Applicative ( Parser, flag', help, idm, long, metavar )
+import           Options.Applicative.Builder.Extra ( boolFlags )
+import           Stack.Clean
+                   ( CleanCommand (..), CleanDepth (..), CleanOpts (..) )
 import           Stack.Prelude
 import           Stack.Types.PackageName ( packageNameArgument )
 
 -- | Command-line parser for the clean command.
 cleanOptsParser :: CleanCommand -> Parser CleanOpts
-cleanOptsParser Clean = CleanShallow
-  <$> packages
-  <|> doFullClean
+cleanOptsParser Clean = shallowParser <|> fullParser
+
+cleanOptsParser Purge = pure $ CleanOpts
+  { depth = CleanFull
+  , omitThis = False
+  }
+
+shallowParser :: Parser CleanOpts
+shallowParser = do
+  packages <- parsePackages
+  omitThis <- parseOmitThis
+  pure $ CleanOpts
+    { depth = CleanShallow packages
+    , omitThis
+    }
  where
-  packages = many (packageNameArgument
+  parsePackages = many (packageNameArgument
     (  metavar "PACKAGE"
     <> help "If none specified, clean all project packages."
     ))
+  parseOmitThis = boolFlags False
+    "omit-this"
+    "the omission of directories currently in use"
+    idm
+
+fullParser :: Parser CleanOpts
+fullParser = do
+  depth <- doFullClean
+  pure $ CleanOpts
+    { depth
+    , omitThis = False
+    }
+ where
   doFullClean = flag' CleanFull
     (  long "full"
-    <> help "Delete the project's Stack working directories (.stack-work by \
+    <> help "Delete the project's Stack work directories (.stack-work by \
             \default)."
     )
-
-cleanOptsParser Purge = pure CleanFull