{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Stack.Clean
(clean
,CleanOpts(..)
,CleanCommand(..)
,StackCleanException(..)
) where
import Stack.Prelude
import Data.List ((\\),intercalate)
import qualified Data.Map.Strict as Map
import Path.IO (ignoringAbsence, removeDirRecur)
import Stack.Config (withBuildConfig)
import Stack.Constants.Config (rootDistDirFromDir, workDirFromDir)
import Stack.Types.Config
import Stack.Types.SourceMap
clean :: CleanOpts -> RIO Config ()
clean :: CleanOpts -> RIO Config ()
clean CleanOpts
cleanOpts = do
[Path Abs Dir]
toDelete <- forall a. RIO BuildConfig a -> RIO Config a
withBuildConfig forall a b. (a -> b) -> a -> b
$ CleanOpts -> RIO BuildConfig [Path Abs Dir]
dirsToDelete CleanOpts
cleanOpts
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Need to delete: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => FilePath -> a
fromString (forall a. Show a => a -> FilePath
show (forall a b. (a -> b) -> [a] -> [b]
map forall b t. Path b t -> FilePath
toFilePath [Path Abs Dir]
toDelete))
[Bool]
failures <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {env} {m :: * -> *} {b}.
(MonadReader env m, MonadUnliftIO m, HasLogFunc env) =>
Path b Dir -> m Bool
cleanDir [Path Abs Dir]
toDelete
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
failures) forall (m :: * -> *) a. MonadIO m => m a
exitFailure
where
cleanDir :: Path b Dir -> m Bool
cleanDir Path b Dir
dir = do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Deleting directory: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => FilePath -> a
fromString (forall b t. Path b t -> FilePath
toFilePath Path b Dir
dir)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path b Dir
dir) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
ex -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Exception while recursively deleting " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => FilePath -> a
fromString (forall b t. Path b t -> FilePath
toFilePath Path b Dir
dir) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow SomeException
ex
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"Perhaps you do not have permission to delete these files or they are in use?"
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
dirsToDelete :: CleanOpts -> RIO BuildConfig [Path Abs Dir]
dirsToDelete :: CleanOpts -> RIO BuildConfig [Path Abs Dir]
dirsToDelete CleanOpts
cleanOpts = do
Map PackageName ProjectPackage
packages <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to (SMWanted -> Map PackageName ProjectPackage
smwProject forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildConfig -> SMWanted
bcSMWanted)
case CleanOpts
cleanOpts of
CleanShallow [] ->
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall env (m :: * -> *).
(MonadReader env m, HasConfig env) =>
Path Abs Dir -> m (Path Abs Dir)
rootDistDirFromDir forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> Path Abs Dir
ppRoot) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map PackageName ProjectPackage
packages
CleanShallow [PackageName]
targets -> do
let localPkgNames :: [PackageName]
localPkgNames = forall k a. Map k a -> [k]
Map.keys Map PackageName ProjectPackage
packages
getPkgDir :: PackageName -> Maybe (Path Abs Dir)
getPkgDir PackageName
pkgName' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ProjectPackage -> Path Abs Dir
ppRoot (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pkgName' Map PackageName ProjectPackage
packages)
case [PackageName]
targets forall a. Eq a => [a] -> [a] -> [a]
\\ [PackageName]
localPkgNames of
[] -> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall env (m :: * -> *).
(MonadReader env m, HasConfig env) =>
Path Abs Dir -> m (Path Abs Dir)
rootDistDirFromDir (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PackageName -> Maybe (Path Abs Dir)
getPkgDir [PackageName]
targets)
[PackageName]
xs -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ([PackageName] -> StackCleanException
NonLocalPackages [PackageName]
xs)
CleanOpts
CleanFull -> do
[Path Abs Dir]
pkgWorkDirs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall env (m :: * -> *).
(MonadReader env m, HasConfig env) =>
Path Abs Dir -> m (Path Abs Dir)
workDirFromDir forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> Path Abs Dir
ppRoot) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map PackageName ProjectPackage
packages
Path Abs Dir
projectWorkDir <- forall env (m :: * -> *).
(HasBuildConfig env, MonadReader env m) =>
m (Path Abs Dir)
getProjectWorkDir
forall (m :: * -> *) a. Monad m => a -> m a
return (Path Abs Dir
projectWorkDir forall a. a -> [a] -> [a]
: [Path Abs Dir]
pkgWorkDirs)
data CleanOpts
= CleanShallow [PackageName]
| CleanFull
data CleanCommand
= Clean
| Purge
newtype StackCleanException
= NonLocalPackages [PackageName]
deriving (Typeable)
instance Show StackCleanException where
show :: StackCleanException -> FilePath
show (NonLocalPackages [PackageName]
pkgs) =
FilePath
"The following packages are not part of this project: " forall a. [a] -> [a] -> [a]
++
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> FilePath
show [PackageName]
pkgs)
instance Exception StackCleanException