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

-- | Clean a project.
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.Constants.Config (rootDistDirFromDir, workDirFromDir)
import           Stack.Types.Config
import           Stack.Types.SourceMap

-- | Deletes build artifacts in the current project.
--
-- Throws 'StackCleanException'.
clean :: HasBuildConfig env => CleanOpts -> RIO env ()
clean :: CleanOpts -> RIO env ()
clean CleanOpts
cleanOpts = do
    [Path Abs Dir]
toDelete <- CleanOpts -> RIO env [Path Abs Dir]
forall env.
HasBuildConfig env =>
CleanOpts -> RIO env [Path Abs Dir]
dirsToDelete CleanOpts
cleanOpts
    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Need to delete: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString ([String] -> String
forall a. Show a => a -> String
show ((Path Abs Dir -> String) -> [Path Abs Dir] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath [Path Abs Dir]
toDelete))
    [Bool]
failures <- (Path Abs Dir -> RIO env Bool) -> [Path Abs Dir] -> RIO env [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Path Abs Dir -> RIO env Bool
forall env (m :: * -> *) b.
(MonadReader env m, MonadUnliftIO m, HasLogFunc env) =>
Path b Dir -> m Bool
cleanDir [Path Abs Dir]
toDelete
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
failures) RIO env ()
forall (m :: * -> *) a. MonadIO m => m a
exitFailure
  where
    cleanDir :: Path b Dir -> m Bool
cleanDir Path b Dir
dir = do
      Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Deleting directory: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path b Dir -> String
forall b t. Path b t -> String
toFilePath Path b Dir
dir)
      IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()
forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (Path b Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path b Dir
dir) IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) m Bool -> (SomeException -> m Bool) -> m Bool
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
ex -> do
        Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Exception while recursively deleting " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path b Dir -> String
forall b t. Path b t -> String
toFilePath Path b Dir
dir) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> SomeException -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow SomeException
ex
        Utf8Builder -> m ()
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?"
        Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

dirsToDelete :: HasBuildConfig env => CleanOpts -> RIO env [Path Abs Dir]
dirsToDelete :: CleanOpts -> RIO env [Path Abs Dir]
dirsToDelete CleanOpts
cleanOpts = do
    Map PackageName ProjectPackage
packages <- Getting
  (Map PackageName ProjectPackage)
  env
  (Map PackageName ProjectPackage)
-> RIO env (Map PackageName ProjectPackage)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
   (Map PackageName ProjectPackage)
   env
   (Map PackageName ProjectPackage)
 -> RIO env (Map PackageName ProjectPackage))
-> Getting
     (Map PackageName ProjectPackage)
     env
     (Map PackageName ProjectPackage)
-> RIO env (Map PackageName ProjectPackage)
forall a b. (a -> b) -> a -> b
$ (BuildConfig -> Const (Map PackageName ProjectPackage) BuildConfig)
-> env -> Const (Map PackageName ProjectPackage) env
forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigL((BuildConfig
  -> Const (Map PackageName ProjectPackage) BuildConfig)
 -> env -> Const (Map PackageName ProjectPackage) env)
-> ((Map PackageName ProjectPackage
     -> Const
          (Map PackageName ProjectPackage) (Map PackageName ProjectPackage))
    -> BuildConfig
    -> Const (Map PackageName ProjectPackage) BuildConfig)
-> Getting
     (Map PackageName ProjectPackage)
     env
     (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 -> Map PackageName ProjectPackage
smwProject (SMWanted -> Map PackageName ProjectPackage)
-> (BuildConfig -> SMWanted)
-> BuildConfig
-> Map PackageName ProjectPackage
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
            (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)
mapM (Path Abs Dir -> RIO env (Path Abs Dir)
forall env (m :: * -> *).
(MonadReader env m, HasConfig env) =>
Path Abs Dir -> m (Path Abs Dir)
rootDistDirFromDir (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] -> RIO env [Path Abs Dir])
-> [ProjectPackage] -> RIO env [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
        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 (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)
            case [PackageName]
targets [PackageName] -> [PackageName] -> [PackageName]
forall a. Eq a => [a] -> [a] -> [a]
\\ [PackageName]
localPkgNames of
                [] -> (Path Abs Dir -> RIO env (Path Abs Dir))
-> [Path Abs Dir] -> RIO env [Path Abs Dir]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Path Abs Dir -> RIO env (Path Abs Dir)
forall env (m :: * -> *).
(MonadReader env m, HasConfig env) =>
Path Abs Dir -> m (Path Abs Dir)
rootDistDirFromDir ((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)
                [PackageName]
xs -> StackCleanException -> RIO env [Path Abs Dir]
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ([PackageName] -> StackCleanException
NonLocalPackages [PackageName]
xs)
        CleanOpts
CleanFull -> do
            [Path Abs Dir]
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)
mapM (Path Abs Dir -> RIO env (Path Abs Dir)
forall env (m :: * -> *).
(MonadReader env m, HasConfig env) =>
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] -> RIO env [Path Abs Dir])
-> [ProjectPackage] -> RIO env [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
            Path Abs Dir
projectWorkDir <- RIO env (Path Abs Dir)
forall env (m :: * -> *).
(HasBuildConfig env, MonadReader env m) =>
m (Path Abs Dir)
getProjectWorkDir
            [Path Abs Dir] -> RIO env [Path Abs Dir]
forall (m :: * -> *) a. Monad m => a -> m a
return (Path Abs Dir
projectWorkDir Path Abs Dir -> [Path Abs Dir] -> [Path Abs Dir]
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

-- | Exceptions during cleanup.
newtype StackCleanException
    = NonLocalPackages [PackageName]
    deriving (Typeable)

instance Show StackCleanException where
    show :: StackCleanException -> String
show (NonLocalPackages [PackageName]
pkgs) =
        String
"The following packages are not part of this project: " String -> ShowS
forall a. [a] -> [a] -> [a]
++
        String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((PackageName -> String) -> [PackageName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> String
forall a. Show a => a -> String
show [PackageName]
pkgs)

instance Exception StackCleanException