diff --git a/ChangeLog.md b/ChangeLog.md index c2ceb5744e..9069219be9 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -113,6 +113,9 @@ Other enhancements: downside to this, however: if you have a multifile script, and change one of the dependency modules, Stack will not automatically detect and recompile. +* `stack clean` will delete the entire `.stack-work/dist` directory, + not just the relevant subdirectory for the current GHC version. See + [#4480](https://github.com/commercialhaskell/stack/issues/4480). Bug fixes: diff --git a/src/Stack/Clean.hs b/src/Stack/Clean.hs index c14f583b6c..6a8087649f 100644 --- a/src/Stack/Clean.hs +++ b/src/Stack/Clean.hs @@ -15,7 +15,7 @@ import Stack.Prelude import Data.List ((\\),intercalate) import qualified Data.Map.Strict as Map import Path.IO (ignoringAbsence, removeDirRecur) -import Stack.Constants.Config (distDirFromDir, workDirFromDir) +import Stack.Constants.Config (rootDistDirFromDir, workDirFromDir) import Stack.Types.Config import Stack.Types.SourceMap import System.Exit (exitFailure) @@ -23,29 +23,32 @@ import System.Exit (exitFailure) -- | Deletes build artifacts in the current project. -- -- Throws 'StackCleanException'. -clean :: HasEnvConfig env => CleanOpts -> RIO env () +clean :: HasBuildConfig env => CleanOpts -> RIO env () clean cleanOpts = do - failures <- mapM cleanDir =<< dirsToDelete cleanOpts + toDelete <- dirsToDelete cleanOpts + logDebug $ "Need to delete: " <> fromString (show (map toFilePath toDelete)) + failures <- mapM cleanDir toDelete when (or failures) $ liftIO exitFailure where - cleanDir dir = + cleanDir dir = do + logDebug $ "Deleting directory: " <> fromString (toFilePath dir) liftIO (ignoringAbsence (removeDirRecur dir) >> return False) `catchAny` \ex -> do logError $ "Exception while recursively deleting " <> fromString (toFilePath dir) <> "\n" <> displayShow ex logError "Perhaps you do not have permission to delete these files or they are in use?" return True -dirsToDelete :: HasEnvConfig env => CleanOpts -> RIO env [Path Abs Dir] +dirsToDelete :: HasBuildConfig env => CleanOpts -> RIO env [Path Abs Dir] dirsToDelete cleanOpts = do packages <- view $ buildConfigL.to (smwProject . bcSMWanted) case cleanOpts of CleanShallow [] -> -- Filter out packages listed as extra-deps - mapM (distDirFromDir . ppRoot) $ Map.elems packages + mapM (rootDistDirFromDir . ppRoot) $ Map.elems packages CleanShallow targets -> do let localPkgNames = Map.keys packages getPkgDir pkgName' = fmap ppRoot (Map.lookup pkgName' packages) case targets \\ localPkgNames of - [] -> mapM distDirFromDir (mapMaybe getPkgDir targets) + [] -> mapM rootDistDirFromDir (mapMaybe getPkgDir targets) xs -> throwM (NonLocalPackages xs) CleanFull -> do pkgWorkDirs <- mapM (workDirFromDir . ppRoot) $ Map.elems packages diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 3c30adff7a..24293e2fd6 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -660,7 +660,6 @@ loadBuildConfig mproject maresolver mcompiler = do LCSProject _ -> False LCSNoConfig _extraDeps -> False , bcCurator = projectCurator project - , bcDownloadCompiler = WithDownloadCompiler } where getEmptyProject :: Maybe RawSnapshotLocation -> [PackageIdentifierRevision] -> RIO Config Project diff --git a/src/Stack/Constants/Config.hs b/src/Stack/Constants/Config.hs index c1ca27fcab..65dd865fcc 100644 --- a/src/Stack/Constants/Config.hs +++ b/src/Stack/Constants/Config.hs @@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} module Stack.Constants.Config ( distDirFromDir + , rootDistDirFromDir , workDirFromDir , distRelativeDir , imageStagingDir @@ -105,8 +106,26 @@ distDirFromDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) distDirFromDir fp = liftM (fp ) distRelativeDir +-- | The directory containing all dist directories, including all +-- different GHC/Cabal combos. +rootDistDirFromDir + :: (MonadReader env m, HasConfig env) + => Path Abs Dir + -> m (Path Abs Dir) +rootDistDirFromDir fp = + liftM (fp ) rootDistRelativeDir + +-- | Relative directory to the top dist directory, containing +-- individual GHC/Cabal combo as subdirs. +rootDistRelativeDir + :: (MonadReader env m, HasConfig env) + => m (Path Rel Dir) +rootDistRelativeDir = do + workDir <- view workDirL + return $ workDir $(mkRelDir "dist") + -- | Package's working directory. -workDirFromDir :: (MonadReader env m, HasEnvConfig env) +workDirFromDir :: (MonadReader env m, HasConfig env) => Path Abs Dir -> m (Path Abs Dir) workDirFromDir fp = view $ workDirL.to (fp ) @@ -129,11 +148,8 @@ distRelativeDir = do packageIdentifierString $ PackageIdentifier cabalPackageName cabalPkgVer platformAndCabal <- useShaPathOnWindows (platform envDir) - workDir <- view workDirL - return $ - workDir - $(mkRelDir "dist") - platformAndCabal + allDist <- rootDistRelativeDir + return $ allDist platformAndCabal -- | Docker sandbox from project root. projectDockerSandboxDir :: (MonadReader env m, HasConfig env) diff --git a/src/Stack/Runners.hs b/src/Stack/Runners.hs index 20a2d25e1c..37866a5b16 100644 --- a/src/Stack/Runners.hs +++ b/src/Stack/Runners.hs @@ -11,9 +11,7 @@ module Stack.Runners , withMiniConfigAndLock , withBuildConfigAndLock , withDefaultBuildConfigAndLock - , withDefaultBuildConfigAndLockNoDocker - , withBuildConfigAndLockInClean - , withBuildConfigAndLockNoDockerInClean + , withCleanConfig , withBuildConfig , withDefaultBuildConfig , withBuildConfigExt @@ -143,7 +141,7 @@ withDefaultBuildConfigAndLock -> (Maybe FileLock -> RIO EnvConfig ()) -> IO () withDefaultBuildConfigAndLock go inner = - withBuildConfigExt WithDocker WithDownloadCompiler go AllowNoTargets defaultBuildOptsCLI Nothing inner Nothing + withBuildConfigExt WithDocker go AllowNoTargets defaultBuildOptsCLI Nothing inner Nothing withBuildConfigAndLock :: GlobalOpts @@ -152,36 +150,28 @@ withBuildConfigAndLock -> (Maybe FileLock -> RIO EnvConfig ()) -> IO () withBuildConfigAndLock go needTargets boptsCLI inner = - withBuildConfigExt WithDocker WithDownloadCompiler go needTargets boptsCLI Nothing inner Nothing + withBuildConfigExt WithDocker go needTargets boptsCLI Nothing inner Nothing --- | See issue #2010 for why this exists. Currently just used for the --- specific case of "stack clean --full". -withDefaultBuildConfigAndLockNoDocker - :: GlobalOpts - -> (Maybe FileLock -> RIO EnvConfig ()) - -> IO () -withDefaultBuildConfigAndLockNoDocker go inner = - withBuildConfigExt SkipDocker WithDownloadCompiler go AllowNoTargets defaultBuildOptsCLI Nothing inner Nothing - -withBuildConfigAndLockInClean - :: GlobalOpts - -> (Maybe FileLock -> RIO EnvConfig ()) - -> IO () -withBuildConfigAndLockInClean go inner = - withBuildConfigExt WithDocker SkipDownloadCompiler go AllowNoTargets defaultBuildOptsCLI Nothing inner Nothing - --- | See issue #2010 for why this exists. Currently just used for the --- specific case of "stack clean --full". -withBuildConfigAndLockNoDockerInClean - :: GlobalOpts - -> (Maybe FileLock -> RIO EnvConfig ()) - -> IO () -withBuildConfigAndLockNoDockerInClean go inner = - withBuildConfigExt SkipDocker SkipDownloadCompiler go AllowNoTargets defaultBuildOptsCLI Nothing inner Nothing +-- | A runner specially built for the "stack clean" use case. For some +-- reason (hysterical raisins?), all of the functions in this module +-- which say BuildConfig actually work on an EnvConfig, while the +-- clean command legitimately only needs a BuildConfig. At some point +-- in the future, we could consider renaming everything for more +-- consistency. +-- +-- /NOTE/ This command always runs outside of the Docker environment, +-- since it does not need to run any commands to get information on +-- the project. This is a change as of #4480. For previous behavior, +-- see issue #2010. +withCleanConfig :: GlobalOpts -> RIO BuildConfig () -> IO () +withCleanConfig go inner = + loadConfigWithOpts go $ \lc -> + withUserFileLock go (view stackRootL lc) $ \_lk0 -> do + bconfig <- lcLoadBuildConfig lc $ globalCompiler go + runRIO bconfig inner withBuildConfigExt :: WithDocker - -> WithDownloadCompiler -- ^ bypassed download compiler if SkipDownloadCompiler. -> GlobalOpts -> NeedTargets -> BuildOptsCLI @@ -199,7 +189,7 @@ withBuildConfigExt -- available in this action, since that would require build tools to be -- installed on the host OS. -> IO () -withBuildConfigExt skipDocker downloadCompiler go@GlobalOpts{..} needTargets boptsCLI mbefore inner mafter = loadConfigWithOpts go $ \lc -> do +withBuildConfigExt skipDocker go@GlobalOpts{..} needTargets boptsCLI mbefore inner mafter = loadConfigWithOpts go $ \lc -> do withUserFileLock go (view stackRootL lc) $ \lk0 -> do -- A local bit of state for communication between callbacks: curLk <- newIORef lk0 @@ -217,8 +207,7 @@ withBuildConfigExt skipDocker downloadCompiler go@GlobalOpts{..} needTargets bop let inner'' lk = do bconfig <- lcLoadBuildConfig lc globalCompiler - let bconfig' = bconfig { bcDownloadCompiler = downloadCompiler } - envConfig <- runRIO bconfig' (setupEnv needTargets boptsCLI Nothing) + envConfig <- runRIO bconfig (setupEnv needTargets boptsCLI Nothing) runRIO envConfig (inner' lk) let getCompilerVersion = loadCompilerVersion go lc diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index c25d4cc0ec..49f53a9c57 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -63,7 +63,7 @@ import qualified Data.Yaml as Yaml import Distribution.System (OS, Arch (..), Platform (..)) import qualified Distribution.System as Cabal import Distribution.Text (simpleParse) -import Distribution.Types.PackageName (mkPackageName, unPackageName) +import Distribution.Types.PackageName (mkPackageName) import Distribution.Version (mkVersion) import Lens.Micro (set) import Network.HTTP.StackClient (CheckHexDigest (..), DownloadRequest (..), HashCheck (..), @@ -87,7 +87,6 @@ import Stack.Config (loadConfig) import Stack.Constants import Stack.Constants.Config (distRelativeDir) import Stack.GhcPkg (createDatabase, getCabalPkgVer, getGlobalDB, mkGhcPackagePath, ghcPkgPathEnvVar) -import Stack.PackageDump (DumpPackage (..)) import Stack.Prelude hiding (Display (..)) import Stack.SourceMap import Stack.Setup.Installed @@ -96,7 +95,6 @@ import Stack.Types.Compiler import Stack.Types.CompilerBuild import Stack.Types.Config import Stack.Types.Docker -import Stack.Types.GhcPkgId (parseGhcPkgId) import Stack.Types.Runner import Stack.Types.SourceMap import Stack.Types.Version @@ -246,10 +244,7 @@ setupEnv needTargets boptsCLI mResolveMissingGHC = do , soptsGHCJSBootOpts = ["--clean"] } - (mghcBin, mCompilerBuild, _) <- - case bcDownloadCompiler bc of - SkipDownloadCompiler -> return (Nothing, Nothing, False) - WithDownloadCompiler -> ensureCompiler sopts + (mghcBin, mCompilerBuild, _) <- ensureCompiler sopts -- Modify the initial environment to include the GHC path, if a local GHC -- is being used @@ -275,45 +270,11 @@ setupEnv needTargets boptsCLI mResolveMissingGHC = do bcPath = set envOverrideSettingsL (\_ -> return menv) $ set processContextL menv bc sourceMap <- runRIO bcPath $ do - (smActual, prunedActual) <- case bcDownloadCompiler bc of - SkipDownloadCompiler -> do - -- FIXME temprorary version, should be resolved the same way as getCompilerVersion above - sma <- actualFromHints (bcSMWanted bc) compilerVer - let noDepsDump :: PackageName -> a -> DumpedGlobalPackage - noDepsDump pname _ = DumpPackage - { dpGhcPkgId = fromMaybe (error "bad package name") $ - parseGhcPkgId (T.pack $ unPackageName pname) - , dpPackageIdent = PackageIdentifier pname (mkVersion []) - , dpParentLibIdent = Nothing - , dpLicense = Nothing - , dpLibDirs = [] - , dpLibraries = [] - , dpHasExposedModules = True - , dpExposedModules = mempty - , dpDepends = [] - , dpHaddockInterfaces = [] - , dpHaddockHtml = Nothing - , dpIsExposed = True - } - fakeDump = sma { - smaGlobal = Map.mapWithKey noDepsDump (smaGlobal sma) - } - fakePruned = sma { - smaGlobal = Map.map (\(GlobalPackageVersion v) -> GlobalPackage v) - (smaGlobal sma) - } - return (fakeDump, fakePruned) - WithDownloadCompiler -> do - sma <- actualFromGhc (bcSMWanted bc) compilerVer - let actualPkgs = Map.keysSet (smaDeps sma) <> - Map.keysSet (smaProject sma) - return ( sma - , sma { - smaGlobal = pruneGlobals (smaGlobal sma) actualPkgs - } - ) - - let haddockDeps = shouldHaddockDeps (configBuild config) + smActual <- actualFromGhc (bcSMWanted bc) compilerVer + let actualPkgs = Map.keysSet (smaDeps smActual) <> + Map.keysSet (smaProject smActual) + prunedActual = smActual { smaGlobal = pruneGlobals (smaGlobal smActual) actualPkgs } + haddockDeps = shouldHaddockDeps (configBuild config) targets <- parseTargets needTargets haddockDeps boptsCLI prunedActual loadSourceMap targets boptsCLI smActual diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 769c12cd8e..9f2ac0c7df 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -83,8 +83,6 @@ module Stack.Types.Config ,LoadConfig(..) -- ** WithDocker ,WithDocker(..) - -- ** WithDownloadCompiler - ,WithDownloadCompiler(..) -- ** Project & ProjectAndConfigMonoid ,Project(..) @@ -495,17 +493,12 @@ data BuildConfig = BuildConfig -- ^ Are we loading from the implicit global stack.yaml? This is useful -- for providing better error messages. , bcCurator :: !(Maybe Curator) - , bcDownloadCompiler :: !WithDownloadCompiler } data WithDocker = SkipDocker | WithDocker -data WithDownloadCompiler - = SkipDownloadCompiler - | WithDownloadCompiler - stackYamlL :: HasBuildConfig env => Lens' env (Path Abs File) stackYamlL = buildConfigL.lens bcStackYaml (\x y -> x { bcStackYaml = y }) diff --git a/src/main/Main.hs b/src/main/Main.hs index 9670bd32d2..53834746e6 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -658,12 +658,7 @@ setupCmd sco@SetupCmdOpts{..} go@GlobalOpts{..} = loadConfigWithOpts go $ \lc -> (Just $ munlockFile lk) cleanCmd :: CleanOpts -> GlobalOpts -> IO () -cleanCmd opts go = - -- See issues #2010 and #3468 for why "stack clean --full" is not used - -- within docker. - case opts of - CleanFull{} -> withBuildConfigAndLockNoDockerInClean go (const (clean opts)) - CleanShallow{} -> withBuildConfigAndLockInClean go (const (clean opts)) +cleanCmd opts go = withCleanConfig go (clean opts) -- | Helper for build and install commands buildCmd :: BuildOptsCLI -> GlobalOpts -> IO () @@ -998,7 +993,6 @@ imgDockerCmd (rebuild,images) go@GlobalOpts{..} = loadConfigWithOpts go $ \lc -> let mProjectRoot = lcProjectRoot lc withBuildConfigExt WithDocker - WithDownloadCompiler go NeedTargets defaultBuildOptsCLI