{-# LANGUAGE NoImplicitPrelude  #-}
{-# LANGUAGE ConstraintKinds    #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE OverloadedStrings  #-}

-- | Clean a project.

module Stack.Clean
  ( clean
  , CleanOpts (..)
  , CleanCommand (..)
  ) where

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.Prelude
import           Stack.Types.Config
import           Stack.Types.SourceMap

-- | Type representing exceptions thrown by functions exported by the

-- "Stack.Clean" module.

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

instance Exception CleanException where
    displayException :: CleanException -> FilePath
displayException (NonLocalPackages [PackageName]
pkgs) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ FilePath
"Error: [S-9463]\n"
        , FilePath
"The following packages are not part of this project: "
        , forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> FilePath
show [PackageName]
pkgs)
        ]
    displayException (DeletionFailures [(Path Abs Dir, SomeException)]
failures) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ FilePath
"Error: [S-6321]\n"
        , FilePath
"Exception while recursively deleting:\n"
        , forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Path Abs Dir
dir, SomeException
e) ->
            forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
dir forall a. Semigroup a => a -> a -> a
<> FilePath
"\n" forall a. Semigroup a => a -> a -> a
<> forall e. Exception e => e -> FilePath
displayException SomeException
e forall a. Semigroup a => a -> a -> a
<> FilePath
"\n") [(Path Abs Dir, SomeException)]
failures
        , FilePath
"Perhaps you do not have permission to delete these files or they \
          \are in use?"
        ]

-- | Deletes build artifacts in the current project.

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))
    [(Path Abs Dir, SomeException)]
failures <- forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Path Abs Dir -> RIO Config (Maybe (Path Abs Dir, SomeException))
cleanDir [Path Abs Dir]
toDelete
    case [(Path Abs Dir, SomeException)]
failures of
        [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        [(Path Abs Dir, SomeException)]
_  -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ [(Path Abs Dir, SomeException)] -> CleanException
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
    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 Abs 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 Abs Dir
dir) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
ex ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Path Abs Dir
dir, SomeException
ex)

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 [] ->
            -- Filter out packages listed as extra-deps

            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] -> CleanException
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 (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir
projectWorkDir forall a. a -> [a] -> [a]
: [Path Abs Dir]
pkgWorkDirs)

-- | Options for @stack clean@.

data CleanOpts
    = CleanShallow [PackageName]
    -- ^ Delete the "dist directories" as defined in 'Stack.Constants.Config.distRelativeDir'

    -- for the given local packages. If no packages are given, all project packages

    -- should be cleaned.

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


-- | Clean commands

data CleanCommand
    = Clean
    | Purge