stack clean does not need ghc-pkg (fixes #4480)

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:
 

src/Stack/Clean.hs

@@ -15,37 +15,40 @@ 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)
 
 -- | 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

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

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)

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

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
 

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 })
 

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