{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings   #-}

{-|
Module      : Stack.Clean
Description : Types and functions related to Stack's @clean@ and @purge@ commands.
License     : BSD-3-Clause

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 ( (</>), isProperPrefixOf )
import           Path.IO ( ignoringAbsence, listDirRecur, removeDirRecur )
import           Stack.Config ( withBuildConfig )
import           Stack.Constants.Config
                   ( distRelativeDir, rootDistDirFromDir, workDirFromDir )
import           Stack.Prelude
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 ( ProjectPackage, SMWanted (..), ppRoot )

-- | Type representing \'pretty\' exceptions thrown by functions exported by the

-- "Stack.Clean" module.

data CleanPrettyException
  = NonLocalPackages [PackageName]
  | DeletionFailures [(Path Abs Dir, SomeException)]
  deriving Int -> CleanPrettyException -> ShowS
[CleanPrettyException] -> ShowS
CleanPrettyException -> FilePath
(Int -> CleanPrettyException -> ShowS)
-> (CleanPrettyException -> FilePath)
-> ([CleanPrettyException] -> ShowS)
-> Show CleanPrettyException
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CleanPrettyException -> ShowS
showsPrec :: Int -> CleanPrettyException -> ShowS
$cshow :: CleanPrettyException -> FilePath
show :: CleanPrettyException -> FilePath
$cshowList :: [CleanPrettyException] -> ShowS
showList :: [CleanPrettyException] -> ShowS
Show

instance Pretty CleanPrettyException where
  pretty :: CleanPrettyException -> StyleDoc
pretty (NonLocalPackages [PackageName]
pkgs) =
    StyleDoc
"[S-9463]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         ( FilePath -> StyleDoc
flow FilePath
"The following are not project packages:"
         StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (Style -> Maybe Style
forall a. a -> Maybe a
Just Style
Current) Bool
False
             ((PackageName -> StyleDoc) -> [PackageName] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName [PackageName]
pkgs :: [StyleDoc])
         )
  pretty (DeletionFailures [(Path Abs Dir, SomeException)]
failures) =
    StyleDoc
"[S-6321]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
flow FilePath
"Exception while recursively deleting:"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
forall a. Monoid a => [a] -> a
mconcat (((Path Abs Dir, SomeException) -> StyleDoc)
-> [(Path Abs Dir, SomeException)] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Path Abs Dir, SomeException) -> StyleDoc
forall {a} {e}. (Pretty a, Exception e) => (a, e) -> StyleDoc
prettyFailure [(Path Abs Dir, SomeException)]
failures)
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
flow FilePath
"Perhaps you do not have permission to delete these files or they \
            \are in use?"
   where
    prettyFailure :: (a, e) -> StyleDoc
prettyFailure (a
dir, e
e) =
         a -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty a
dir
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
string (e -> FilePath
forall e. Exception e => e -> FilePath
displayException e
e)
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line

instance Exception CleanPrettyException

-- | Type representing command line options for the @stack clean@ command.

data CleanOpts = CleanOpts
  { CleanOpts -> CleanDepth
depth    :: !CleanDepth
  , CleanOpts -> Bool
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.

    -- If no project packages are given, all project packages should be cleaned.

  | CleanFull
    -- ^ Delete all work directories in the project.


-- | Type representing Stack's cleaning commands.

data CleanCommand
  = Clean
  | Purge

-- | Function underlying the @stack clean@ command.

cleanCmd :: CleanOpts -> RIO Runner ()
cleanCmd :: CleanOpts -> RIO Runner ()
cleanCmd = ShouldReexec -> RIO Config () -> RIO Runner ()
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
NoReexec (RIO Config () -> RIO Runner ())
-> (CleanOpts -> RIO Config ()) -> CleanOpts -> RIO Runner ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CleanOpts -> RIO Config ()
clean

-- | Deletes build artifacts in the current project.

clean :: CleanOpts -> RIO Config ()
clean :: CleanOpts -> RIO Config ()
clean CleanOpts
cleanOpts = do
  toDelete <- if CleanOpts
cleanOpts.omitThis
    then
      RIO EnvConfig [Path Abs Dir] -> RIO Config [Path Abs Dir]
forall a. RIO EnvConfig a -> RIO Config a
withDefaultEnvConfig (RIO EnvConfig [Path Abs Dir] -> RIO Config [Path Abs Dir])
-> RIO EnvConfig [Path Abs Dir] -> RIO Config [Path Abs Dir]
forall a b. (a -> b) -> a -> b
$ CleanDepth -> RIO EnvConfig [Path Abs Dir]
dirsToDeleteGivenConfig CleanOpts
cleanOpts.depth
    else
      RIO BuildConfig [Path Abs Dir] -> RIO Config [Path Abs Dir]
forall a. RIO BuildConfig a -> RIO Config a
withBuildConfig (RIO BuildConfig [Path Abs Dir] -> RIO Config [Path Abs Dir])
-> RIO BuildConfig [Path Abs Dir] -> RIO Config [Path Abs Dir]
forall a b. (a -> b) -> a -> b
$ CleanDepth -> RIO BuildConfig [Path Abs Dir]
dirsToDeleteSimple CleanOpts
cleanOpts.depth
  logDebug $ "Need to delete: " <> fromString (show (map toFilePath toDelete))
  failures <- catMaybes <$> mapM cleanDir toDelete
  case failures of
    [] -> () -> RIO Config ()
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [(Path Abs Dir, SomeException)]
_  -> CleanPrettyException -> RIO Config ()
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (CleanPrettyException -> RIO Config ())
-> CleanPrettyException -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ [(Path Abs Dir, SomeException)] -> CleanPrettyException
DeletionFailures [(Path Abs Dir, SomeException)]
failures

cleanDir :: Path Abs Dir -> RIO Config (Maybe (Path Abs Dir, SomeException))
cleanDir :: Path Abs Dir -> RIO Config (Maybe (Path Abs Dir, SomeException))
cleanDir Path Abs Dir
dir = do
  Utf8Builder -> RIO Config ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO Config ()) -> Utf8Builder -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Deleting directory: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
dir)
  IO (Maybe (Path Abs Dir, SomeException))
-> RIO Config (Maybe (Path Abs Dir, SomeException))
forall a. IO a -> RIO Config a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()
forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path Abs Dir
dir) IO ()
-> IO (Maybe (Path Abs Dir, SomeException))
-> IO (Maybe (Path Abs Dir, SomeException))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (Path Abs Dir, SomeException)
-> IO (Maybe (Path Abs Dir, SomeException))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs Dir, SomeException)
forall a. Maybe a
Nothing) RIO Config (Maybe (Path Abs Dir, SomeException))
-> (SomeException
    -> RIO Config (Maybe (Path Abs Dir, SomeException)))
-> RIO Config (Maybe (Path Abs Dir, SomeException))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
ex ->
    Maybe (Path Abs Dir, SomeException)
-> RIO Config (Maybe (Path Abs Dir, SomeException))
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Path Abs Dir, SomeException)
 -> RIO Config (Maybe (Path Abs Dir, SomeException)))
-> Maybe (Path Abs Dir, SomeException)
-> RIO Config (Maybe (Path Abs Dir, SomeException))
forall a b. (a -> b) -> a -> b
$ (Path Abs Dir, SomeException)
-> Maybe (Path Abs Dir, SomeException)
forall a. a -> Maybe a
Just (Path Abs Dir
dir, SomeException
ex)

dirsToDeleteSimple :: CleanDepth -> RIO BuildConfig [Path Abs Dir]
dirsToDeleteSimple :: CleanDepth -> RIO BuildConfig [Path Abs Dir]
dirsToDeleteSimple CleanDepth
depth = do
  packages <- Getting
  (Map PackageName ProjectPackage)
  BuildConfig
  (Map PackageName ProjectPackage)
-> RIO BuildConfig (Map PackageName ProjectPackage)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
   (Map PackageName ProjectPackage)
   BuildConfig
   (Map PackageName ProjectPackage)
 -> RIO BuildConfig (Map PackageName ProjectPackage))
-> Getting
     (Map PackageName ProjectPackage)
     BuildConfig
     (Map PackageName ProjectPackage)
-> RIO BuildConfig (Map PackageName ProjectPackage)
forall a b. (a -> b) -> a -> b
$ (BuildConfig -> Const (Map PackageName ProjectPackage) BuildConfig)
-> BuildConfig
-> Const (Map PackageName ProjectPackage) BuildConfig
forall env. HasBuildConfig env => Lens' env BuildConfig
Lens' BuildConfig BuildConfig
buildConfigL ((BuildConfig
  -> Const (Map PackageName ProjectPackage) BuildConfig)
 -> BuildConfig
 -> Const (Map PackageName ProjectPackage) BuildConfig)
-> Getting
     (Map PackageName ProjectPackage)
     BuildConfig
     (Map PackageName ProjectPackage)
-> Getting
     (Map PackageName ProjectPackage)
     BuildConfig
     (Map PackageName ProjectPackage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BuildConfig -> Map PackageName ProjectPackage)
-> SimpleGetter BuildConfig (Map PackageName ProjectPackage)
forall s a. (s -> a) -> SimpleGetter s a
to (.smWanted.project)
  case depth of
    CleanShallow [] -> do
      -- Filter out packages listed as extra-deps

      let pkgNames :: [ProjectPackage]
pkgNames = Map PackageName ProjectPackage -> [ProjectPackage]
forall k a. Map k a -> [a]
Map.elems Map PackageName ProjectPackage
packages
      (ProjectPackage -> RIO BuildConfig (Path Abs Dir))
-> [ProjectPackage] -> RIO BuildConfig [Path Abs Dir]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Path Abs Dir -> RIO BuildConfig (Path Abs Dir)
forall env (m :: * -> *).
(HasConfig env, MonadReader env m) =>
Path Abs Dir -> m (Path Abs Dir)
rootDistDirFromDir (Path Abs Dir -> RIO BuildConfig (Path Abs Dir))
-> (ProjectPackage -> Path Abs Dir)
-> ProjectPackage
-> RIO BuildConfig (Path Abs Dir)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> Path Abs Dir
ppRoot) [ProjectPackage]
pkgNames
    CleanShallow [PackageName]
targets -> do
      let localPkgNames :: [PackageName]
localPkgNames = Map PackageName ProjectPackage -> [PackageName]
forall k a. Map k a -> [k]
Map.keys Map PackageName ProjectPackage
packages
          getPkgDir :: PackageName -> Maybe (Path Abs Dir)
getPkgDir PackageName
pkgName' = (ProjectPackage -> Path Abs Dir)
-> Maybe ProjectPackage -> Maybe (Path Abs Dir)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ProjectPackage -> Path Abs Dir
ppRoot (PackageName
-> Map PackageName ProjectPackage -> Maybe ProjectPackage
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pkgName' Map PackageName ProjectPackage
packages)
          pkgNames :: [Path Abs Dir]
pkgNames = (PackageName -> Maybe (Path Abs Dir))
-> [PackageName] -> [Path Abs Dir]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PackageName -> Maybe (Path Abs Dir)
getPkgDir [PackageName]
targets
      case [PackageName]
targets [PackageName] -> [PackageName] -> [PackageName]
forall a. Eq a => [a] -> [a] -> [a]
\\ [PackageName]
localPkgNames of
        [] -> (Path Abs Dir -> RIO BuildConfig (Path Abs Dir))
-> [Path Abs Dir] -> RIO BuildConfig [Path Abs Dir]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Path Abs Dir -> RIO BuildConfig (Path Abs Dir)
forall env (m :: * -> *).
(HasConfig env, MonadReader env m) =>
Path Abs Dir -> m (Path Abs Dir)
rootDistDirFromDir [Path Abs Dir]
pkgNames
        [PackageName]
xs -> CleanPrettyException -> RIO BuildConfig [Path Abs Dir]
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM ([PackageName] -> CleanPrettyException
NonLocalPackages [PackageName]
xs)
    CleanDepth
CleanFull -> [ProjectPackage] -> RIO BuildConfig [Path Abs Dir]
forall env.
HasBuildConfig env =>
[ProjectPackage] -> RIO env [Path Abs Dir]
allWorkDirs ([ProjectPackage] -> RIO BuildConfig [Path Abs Dir])
-> [ProjectPackage] -> RIO BuildConfig [Path Abs Dir]
forall a b. (a -> b) -> a -> b
$ Map PackageName ProjectPackage -> [ProjectPackage]
forall k a. Map k a -> [a]
Map.elems Map PackageName ProjectPackage
packages

dirsToDeleteGivenConfig :: CleanDepth -> RIO EnvConfig [Path Abs Dir]
dirsToDeleteGivenConfig :: CleanDepth -> RIO EnvConfig [Path Abs Dir]
dirsToDeleteGivenConfig CleanDepth
depth = do
  packages <- Getting
  (Map PackageName ProjectPackage)
  EnvConfig
  (Map PackageName ProjectPackage)
-> RIO EnvConfig (Map PackageName ProjectPackage)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
   (Map PackageName ProjectPackage)
   EnvConfig
   (Map PackageName ProjectPackage)
 -> RIO EnvConfig (Map PackageName ProjectPackage))
-> Getting
     (Map PackageName ProjectPackage)
     EnvConfig
     (Map PackageName ProjectPackage)
-> RIO EnvConfig (Map PackageName ProjectPackage)
forall a b. (a -> b) -> a -> b
$ (BuildConfig -> Const (Map PackageName ProjectPackage) BuildConfig)
-> EnvConfig -> Const (Map PackageName ProjectPackage) EnvConfig
forall env. HasBuildConfig env => Lens' env BuildConfig
Lens' EnvConfig BuildConfig
buildConfigL ((BuildConfig
  -> Const (Map PackageName ProjectPackage) BuildConfig)
 -> EnvConfig -> Const (Map PackageName ProjectPackage) EnvConfig)
-> Getting
     (Map PackageName ProjectPackage)
     BuildConfig
     (Map PackageName ProjectPackage)
-> Getting
     (Map PackageName ProjectPackage)
     EnvConfig
     (Map PackageName ProjectPackage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BuildConfig -> Map PackageName ProjectPackage)
-> SimpleGetter BuildConfig (Map PackageName ProjectPackage)
forall s a. (s -> a) -> SimpleGetter s a
to (.smWanted.project)
  case depth of
    CleanShallow [] -> do
      -- Filter out packages listed as extra-deps

      let pkgNames :: [ProjectPackage]
pkgNames = Map PackageName ProjectPackage -> [ProjectPackage]
forall k a. Map k a -> [a]
Map.elems Map PackageName ProjectPackage
packages
      (ProjectPackage -> RIO EnvConfig [Path Abs Dir])
-> [ProjectPackage] -> RIO EnvConfig [Path Abs Dir]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (Path Abs Dir -> RIO EnvConfig [Path Abs Dir]
unusedRootDistDirsFromDir (Path Abs Dir -> RIO EnvConfig [Path Abs Dir])
-> (ProjectPackage -> Path Abs Dir)
-> ProjectPackage
-> RIO EnvConfig [Path Abs Dir]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> Path Abs Dir
ppRoot) [ProjectPackage]
pkgNames
    CleanShallow [PackageName]
targets -> do
      let localPkgNames :: [PackageName]
localPkgNames = Map PackageName ProjectPackage -> [PackageName]
forall k a. Map k a -> [k]
Map.keys Map PackageName ProjectPackage
packages
          getPkgDir :: PackageName -> Maybe (Path Abs Dir)
getPkgDir PackageName
pkgName' = (ProjectPackage -> Path Abs Dir)
-> Maybe ProjectPackage -> Maybe (Path Abs Dir)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ProjectPackage -> Path Abs Dir
ppRoot (PackageName
-> Map PackageName ProjectPackage -> Maybe ProjectPackage
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pkgName' Map PackageName ProjectPackage
packages)
          pkgNames :: [Path Abs Dir]
pkgNames = (PackageName -> Maybe (Path Abs Dir))
-> [PackageName] -> [Path Abs Dir]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PackageName -> Maybe (Path Abs Dir)
getPkgDir [PackageName]
targets
      case [PackageName]
targets [PackageName] -> [PackageName] -> [PackageName]
forall a. Eq a => [a] -> [a] -> [a]
\\ [PackageName]
localPkgNames of
        [] -> (Path Abs Dir -> RIO EnvConfig [Path Abs Dir])
-> [Path Abs Dir] -> RIO EnvConfig [Path Abs Dir]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM Path Abs Dir -> RIO EnvConfig [Path Abs Dir]
unusedRootDistDirsFromDir [Path Abs Dir]
pkgNames
        [PackageName]
xs -> CleanPrettyException -> RIO EnvConfig [Path Abs Dir]
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM ([PackageName] -> CleanPrettyException
NonLocalPackages [PackageName]
xs)
    CleanDepth
CleanFull -> [ProjectPackage] -> RIO EnvConfig [Path Abs Dir]
forall env.
HasBuildConfig env =>
[ProjectPackage] -> RIO env [Path Abs Dir]
allWorkDirs ([ProjectPackage] -> RIO EnvConfig [Path Abs Dir])
-> [ProjectPackage] -> RIO EnvConfig [Path Abs Dir]
forall a b. (a -> b) -> a -> b
$ Map PackageName ProjectPackage -> [ProjectPackage]
forall k a. Map k a -> [a]
Map.elems Map PackageName ProjectPackage
packages

allWorkDirs :: HasBuildConfig env => [ProjectPackage] -> RIO env [Path Abs Dir]
allWorkDirs :: forall env.
HasBuildConfig env =>
[ProjectPackage] -> RIO env [Path Abs Dir]
allWorkDirs [ProjectPackage]
pps = do
  pkgWorkDirs <- (ProjectPackage -> RIO env (Path Abs Dir))
-> [ProjectPackage] -> RIO env [Path Abs Dir]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Path Abs Dir -> RIO env (Path Abs Dir)
forall env (m :: * -> *).
(HasConfig env, MonadReader env m) =>
Path Abs Dir -> m (Path Abs Dir)
workDirFromDir (Path Abs Dir -> RIO env (Path Abs Dir))
-> (ProjectPackage -> Path Abs Dir)
-> ProjectPackage
-> RIO env (Path Abs Dir)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> Path Abs Dir
ppRoot) [ProjectPackage]
pps
  projectWorkDir <- getWorkDir
  pure (projectWorkDir : pkgWorkDirs)

unusedRootDistDirsFromDir :: Path Abs Dir -> RIO EnvConfig [Path Abs Dir]
unusedRootDistDirsFromDir :: Path Abs Dir -> RIO EnvConfig [Path Abs Dir]
unusedRootDistDirsFromDir Path Abs Dir
pkgDir = do
  rootDistDir <- Path Abs Dir -> RIO EnvConfig (Path Abs Dir)
forall env (m :: * -> *).
(HasConfig env, MonadReader env m) =>
Path Abs Dir -> m (Path Abs Dir)
rootDistDirFromDir Path Abs Dir
pkgDir
  omitDir <- fmap (pkgDir </>) distRelativeDir
  allDirsOmittingDirs rootDistDir omitDir

allDirsOmittingDirs ::
     MonadIO m
  => Path Abs Dir
  -> Path Abs Dir
  -> m [Path Abs Dir]
allDirsOmittingDirs :: forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> Path Abs Dir -> m [Path Abs Dir]
allDirsOmittingDirs Path Abs Dir
topDir Path Abs Dir
subDir = do
  allDirs <- (Path Abs Dir
topDir Path Abs Dir -> [Path Abs Dir] -> [Path Abs Dir]
forall a. a -> [a] -> [a]
:) ([Path Abs Dir] -> [Path Abs Dir])
-> (([Path Abs Dir], [Path Abs File]) -> [Path Abs Dir])
-> ([Path Abs Dir], [Path Abs File])
-> [Path Abs Dir]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Path Abs Dir], [Path Abs File]) -> [Path Abs Dir]
forall a b. (a, b) -> a
fst (([Path Abs Dir], [Path Abs File]) -> [Path Abs Dir])
-> m ([Path Abs Dir], [Path Abs File]) -> m [Path Abs Dir]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs Dir -> m ([Path Abs Dir], [Path Abs File])
forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDirRecur Path Abs Dir
topDir
  let isNotInSubDir Path Abs Dir
dir = Bool -> Bool
not
        ( Path Abs Dir -> Path Abs Dir -> Bool
forall b t. Path b Dir -> Path b t -> Bool
isProperPrefixOf Path Abs Dir
dir Path Abs Dir
subDir
        Bool -> Bool -> Bool
|| Path Abs Dir
subDir Path Abs Dir -> Path Abs Dir -> Bool
forall a. Eq a => a -> a -> Bool
== Path Abs Dir
dir
        Bool -> Bool -> Bool
|| Path Abs Dir -> Path Abs Dir -> Bool
forall b t. Path b Dir -> Path b t -> Bool
isProperPrefixOf Path Abs Dir
subDir Path Abs Dir
dir
        )
  pure $ filter isNotInSubDir allDirs