From 57fb0a6e0bd8e878d9f0926f8791dbd6545a1697 Mon Sep 17 00:00:00 2001 From: Simon Jakobi Date: Tue, 10 Nov 2015 12:08:26 +0100 Subject: [PATCH] Add selective cleaning for multi-package projects #583 --- src/Stack/Build.hs | 11 -------- src/Stack/Clean.hs | 67 ++++++++++++++++++++++++++++++++++++++++++++ src/Stack/Options.hs | 12 ++++++++ src/main/Main.hs | 7 +++-- stack.cabal | 1 + 5 files changed, 84 insertions(+), 14 deletions(-) create mode 100644 src/Stack/Clean.hs diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 0a9d739545..1f1016097b 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -14,7 +14,6 @@ module Stack.Build (build - ,clean ,withLoadPackage ,mkBaseConfigOpts ,queryBuildInfo) @@ -43,7 +42,6 @@ import qualified Data.Vector as V import qualified Data.Yaml as Yaml import Network.HTTP.Client.Conduit (HasHttpManager) import Path -import Path.IO import Prelude hiding (FilePath, writeFile) import Stack.Build.ConstructPlan import Stack.Build.Execute @@ -51,7 +49,6 @@ import Stack.Build.Haddock import Stack.Build.Installed import Stack.Build.Source import Stack.Build.Target -import Stack.Constants import Stack.Fetch as Fetch import Stack.GhcPkg import Stack.Package @@ -184,14 +181,6 @@ withLoadPackage menv inner = do , packageConfigPlatform = configPlatform (getConfig econfig) } --- | Reset the build (remove Shake database and .gen files). -clean :: (M env m) => m () -clean = do - econfig <- asks getEnvConfig - forM_ - (Map.keys (envConfigPackages econfig)) - (distDirFromDir >=> removeTreeIfExists) - -- | Set the code page for this process as necessary. Only applies to Windows. -- See: https://github.com/commercialhaskell/stack/issues/738 fixCodePage :: (MonadIO m, MonadMask m, MonadLogger m) => m a -> m a diff --git a/src/Stack/Clean.hs b/src/Stack/Clean.hs new file mode 100644 index 0000000000..7c868cf4b9 --- /dev/null +++ b/src/Stack/Clean.hs @@ -0,0 +1,67 @@ +-- | Clean a project. +module Stack.Clean + (clean + ,CleanOpts(..) + ,StackCleanException(..) + ) where + +import Control.Exception (Exception) +import Control.Monad.Catch (MonadThrow,throwM) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Logger (MonadLogger) +import Control.Monad.Reader (MonadReader) +import Data.Foldable (forM_) +import Data.List (intercalate) +import qualified Data.Map.Strict as Map +import Data.Maybe (mapMaybe) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Typeable (Typeable) +import Path.IO (removeTreeIfExists) +import Stack.Build.Source (getLocalPackageViews) +import Stack.Build.Target (LocalPackageView(..)) +import Stack.Constants (distDirFromDir) +import Stack.Types (HasEnvConfig,PackageName) + + +-- | Reset the build, i.e. remove the @dist@ directory +-- (for example @.stack-work\/dist\/x84_64-linux\/Cabal-1.22.4.0@) +-- for all targets. +-- +-- Throws 'StackCleanException'. +clean + :: (MonadThrow m, MonadIO m, MonadReader env m, HasEnvConfig env, MonadLogger m) + => CleanOpts + -> m () +clean (CleanOpts targets) = do + localPkgViews <- getLocalPackageViews + let nonLocalPkgs = Set.fromList targets Set.\\ Map.keysSet localPkgViews + if Set.null nonLocalPkgs + then do + dirsToClean <- + mapM + (distDirFromDir . lpvRoot . fst) + (if null targets + then Map.elems localPkgViews + else mapMaybe (`Map.lookup` localPkgViews) targets) + forM_ dirsToClean removeTreeIfExists + else throwM (NonLocalPackages nonLocalPkgs) + +-- | Options for cleaning a project. +newtype CleanOpts = CleanOpts + { cleanOptsTargets :: [PackageName] + -- ^ Names of the packages to clean. + -- If the list is empty, every local package should be cleaned. + } + +-- | Exceptions during cleanup. +newtype StackCleanException + = NonLocalPackages (Set PackageName) + deriving (Typeable) + +instance Show StackCleanException where + show (NonLocalPackages pkgs) = + "The following packages are not part of this project: " ++ + intercalate ", " (map show $ Set.toList pkgs) + +instance Exception StackCleanException diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index 5046332301..6eb8e5c199 100644 --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -4,6 +4,7 @@ module Stack.Options (Command(..) ,benchOptsParser ,buildOptsParser + ,cleanOptsParser ,configCmdSetParser ,configOptsParser ,dockerOptsParser @@ -40,6 +41,7 @@ import Options.Applicative import Options.Applicative.Args import Options.Applicative.Builder.Extra import Options.Applicative.Types (fromM, oneM, readerAsk) +import Stack.Clean (CleanOpts(..)) import Stack.Config (packagesParser) import Stack.ConfigCmd import Stack.Constants (stackProgName) @@ -218,6 +220,16 @@ readFlag = do return $ Map.singleton pn' $ Map.singleton flagN b _ -> readerError "Must have a colon" +-- | Command-line parser for the clean command. +cleanOptsParser :: Parser CleanOpts +cleanOptsParser = CleanOpts <$> packages + where + packages = + many + (packageNameArgument + (metavar "PACKAGE" <> + help "If none specified, clean all local packages")) + -- | Command-line arguments parser for configuration. configOptsParser :: Bool -> Parser ConfigMonoid configOptsParser hide0 = diff --git a/src/main/Main.hs b/src/main/Main.hs index 3a251d86df..3796f8b760 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -51,6 +51,7 @@ import Path.IO import qualified Paths_stack as Meta import Prelude hiding (pi, mapM) import Stack.Build +import Stack.Clean (CleanOpts, clean) import Stack.Config import Stack.ConfigCmd as ConfigCmd import Stack.Constants @@ -283,7 +284,7 @@ main = withInterpreterArgs stackProgName $ \args isInterpreter -> do "Clean the local packages" cmdFooter cleanCmd - (pure ()) + cleanOptsParser addCommand' "list-dependencies" "List the dependencies" cmdFooter @@ -752,8 +753,8 @@ withBuildConfigExt go@GlobalOpts{..} mbefore inner mafter = do do lk' <- readIORef curLk munlockFile lk') -cleanCmd :: () -> GlobalOpts -> IO () -cleanCmd () go = withBuildConfigAndLock go (const clean) +cleanCmd :: CleanOpts -> GlobalOpts -> IO () +cleanCmd opts go = withBuildConfigAndLock go (const (clean opts)) -- | Helper for build and install commands buildCmd :: BuildOpts -> GlobalOpts -> IO () diff --git a/stack.cabal b/stack.cabal index c9be8dabd2..e08b229c85 100644 --- a/stack.cabal +++ b/stack.cabal @@ -51,6 +51,7 @@ library Options.Applicative.Args Options.Applicative.Complicated Stack.BuildPlan + Stack.Clean Stack.Config Stack.Config.Docker Stack.ConfigCmd