1{-# LANGUAGE NoImplicitPrelude #-}
2{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE OverloadedStrings #-}
6
7-- | Clean a project.
8module Stack.Clean
9    (clean
10    ,CleanOpts(..)
11    ,CleanCommand(..)
12    ,StackCleanException(..)
13    ) where
14
15import           Stack.Prelude
16import           Data.List ((\\),intercalate)
17import qualified Data.Map.Strict as Map
18import           Path.IO (ignoringAbsence, removeDirRecur)
19import           Stack.Constants.Config (rootDistDirFromDir, workDirFromDir)
20import           Stack.Types.Config
21import           Stack.Types.SourceMap
22
23-- | Deletes build artifacts in the current project.
24--
25-- Throws 'StackCleanException'.
26clean :: HasBuildConfig env => CleanOpts -> RIO env ()
27clean cleanOpts = do
28    toDelete <- dirsToDelete cleanOpts
29    logDebug $ "Need to delete: " <> fromString (show (map toFilePath toDelete))
30    failures <- mapM cleanDir toDelete
31    when (or failures) exitFailure
32  where
33    cleanDir dir = do
34      logDebug $ "Deleting directory: " <> fromString (toFilePath dir)
35      liftIO (ignoringAbsence (removeDirRecur dir) >> return False) `catchAny` \ex -> do
36        logError $ "Exception while recursively deleting " <> fromString (toFilePath dir) <> "\n" <> displayShow ex
37        logError "Perhaps you do not have permission to delete these files or they are in use?"
38        return True
39
40dirsToDelete :: HasBuildConfig env => CleanOpts -> RIO env [Path Abs Dir]
41dirsToDelete cleanOpts = do
42    packages <- view $ buildConfigL.to (smwProject . bcSMWanted)
43    case cleanOpts of
44        CleanShallow [] ->
45            -- Filter out packages listed as extra-deps
46            mapM (rootDistDirFromDir . ppRoot) $ Map.elems packages
47        CleanShallow targets -> do
48            let localPkgNames = Map.keys packages
49                getPkgDir pkgName' = fmap ppRoot (Map.lookup pkgName' packages)
50            case targets \\ localPkgNames of
51                [] -> mapM rootDistDirFromDir (mapMaybe getPkgDir targets)
52                xs -> throwM (NonLocalPackages xs)
53        CleanFull -> do
54            pkgWorkDirs <- mapM (workDirFromDir . ppRoot) $ Map.elems packages
55            projectWorkDir <- getProjectWorkDir
56            return (projectWorkDir : pkgWorkDirs)
57
58-- | Options for @stack clean@.
59data CleanOpts
60    = CleanShallow [PackageName]
61    -- ^ Delete the "dist directories" as defined in 'Stack.Constants.Config.distRelativeDir'
62    -- for the given local packages. If no packages are given, all project packages
63    -- should be cleaned.
64    | CleanFull
65    -- ^ Delete all work directories in the project.
66
67-- | Clean commands
68data CleanCommand
69    = Clean
70    | Purge
71
72-- | Exceptions during cleanup.
73newtype StackCleanException
74    = NonLocalPackages [PackageName]
75    deriving (Typeable)
76
77instance Show StackCleanException where
78    show (NonLocalPackages pkgs) =
79        "The following packages are not part of this project: " ++
80        intercalate ", " (map show pkgs)
81
82instance Exception StackCleanException
83