Introduce EnvConfig and HasEnvConfig (#289)

@snoyberg

Author: chrisdone

src/Stack/Build.hs

@@ -47,7 +47,7 @@ import           System.Posix.Files (createSymbolicLink,removeLink)
 #endif
 --}
 
-type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env)
+type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env,HasEnvConfig env)
 
 -- | Build
 build :: M env m => BuildOpts -> m ()

src/Stack/Build/Cache.hs

@@ -18,13 +18,11 @@ module Stack.Build.Cache
     ) where
 
 import           Control.Exception.Enclosed (handleIO, tryIO)
-
 import           Control.Monad.Catch        (MonadCatch, MonadThrow, catch,
                                              throwM)
 import           Control.Monad.IO.Class
 import           Control.Monad.Logger (MonadLogger)
 import           Control.Monad.Reader
-
 import           Data.Binary (Binary)
 import qualified Data.Binary as Binary
 import           Data.ByteString (ByteString)
@@ -37,7 +35,6 @@ import           Data.Set (Set)
 import qualified Data.Set as Set
 import           Data.Text (Text)
 import           Data.Text.Encoding (encodeUtf8)
-
 import           GHC.Generics (Generic)
 import           Path
 import           Path.IO
@@ -87,17 +84,17 @@ data BuildCache = BuildCache
 instance Binary BuildCache
 
 -- | Try to read the dirtiness cache for the given package directory.
-tryGetBuildCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasBuildConfig env)
+tryGetBuildCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
                  => Path Abs Dir -> m (Maybe BuildCache)
 tryGetBuildCache = tryGetCache buildCacheFile
 
 -- | Try to read the dirtiness cache for the given package directory.
-tryGetConfigCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasBuildConfig env)
+tryGetConfigCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
                   => Path Abs Dir -> m (Maybe ConfigCache)
 tryGetConfigCache = tryGetCache configCacheFile
 
 -- | Try to load a cache.
-tryGetCache :: (MonadIO m, Binary a, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasBuildConfig env)
+tryGetCache :: (MonadIO m, Binary a, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
             => (Path Abs Dir -> m (Path Abs File))
             -> Path Abs Dir
             -> m (Maybe a)
@@ -114,7 +111,7 @@ tryGetCache get' dir = do
           where thd (_,_,x) = x
 
 -- | Write the dirtiness cache for this package's files.
-writeBuildCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasBuildConfig env)
+writeBuildCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
                 => Path Abs Dir -> Map FilePath ModTime -> m ()
 writeBuildCache dir times =
     writeCache
@@ -125,7 +122,7 @@ writeBuildCache dir times =
          })
 
 -- | Write the dirtiness cache for this package's configuration.
-writeConfigCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasBuildConfig env)
+writeConfigCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
                 => Path Abs Dir
                 -> [Text]
                 -> Set GhcPkgId -- ^ dependencies
@@ -148,7 +145,7 @@ writeConfigCache dir opts deps cabalfp ttype =
            cache
 
 -- | Delete the caches for the project.
-deleteCaches :: (MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, MonadThrow m, HasBuildConfig env)
+deleteCaches :: (MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, MonadThrow m, HasEnvConfig env)
              => Path Abs Dir -> m ()
 deleteCaches dir = do
     bfp <- buildCacheFile dir
@@ -157,7 +154,7 @@ deleteCaches dir = do
     removeFileIfExists cfp
 
 -- | Write to a cache.
-writeCache :: (Binary a, MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasBuildConfig env)
+writeCache :: (Binary a, MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
            => Path Abs Dir
            -> (Path Abs Dir -> m (Path Abs File))
            -> a

src/Stack/Build/Execute.hs

@@ -67,7 +67,7 @@ import           System.IO.Temp                 (withSystemTempDirectory)
 import           System.Process.Internals       (createProcess_)
 import           System.Process.Read
 
-type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env)
+type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env,HasEnvConfig env)
 
 printPlan :: M env m => Plan -> m ()
 printPlan plan = do
@@ -155,7 +155,7 @@ executePlan menv bopts baseConfigOpts locals plan = do
         idMap <- liftIO $ newTVarIO M.empty
         let setupHs = tmpdir' </> $(mkRelFile "Setup.hs")
         liftIO $ writeFile (toFilePath setupHs) "import Distribution.Simple\nmain = defaultMain"
-        cabalPkgVer <- asks (bcCabalVersion . getBuildConfig)
+        cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig)
         executePlan' plan ExecuteEnv
             { eeEnvOverride = menv
             , eeBuildOpts = bopts

src/Stack/Build/Source.hs

@@ -52,7 +52,7 @@ instance PackageInstallInfo PackageSource where
     piiLocation (PSLocal _) = Local
     piiLocation (PSUpstream _ loc _) = loc
 
-loadSourceMap :: (MonadIO m, MonadCatch m, MonadReader env m, HasBuildConfig env, MonadBaseControl IO m, HasHttpManager env, MonadLogger m)
+loadSourceMap :: (MonadIO m, MonadCatch m, MonadReader env m, HasBuildConfig env, MonadBaseControl IO m, HasHttpManager env, MonadLogger m, HasEnvConfig env)
               => BuildOpts
               -> m ( MiniBuildPlan
                    , [LocalPackage]
@@ -127,7 +127,7 @@ loadSourceMap bopts = do
     return (mbp, locals, nonLocalTargets, sourceMap)
 
 -- | Returns locals and extra target packages
-loadLocals :: (MonadReader env m, HasBuildConfig env, MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m)
+loadLocals :: (MonadReader env m, HasBuildConfig env, MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m,HasEnvConfig env)
            => BuildOpts
            -> Map PackageName Version
            -> m ([LocalPackage], Set PackageName, Set PackageIdentifier)

src/Stack/Config.hs

@@ -66,7 +66,6 @@ import           Stack.Types.Config
 import           Stack.Constants
 import qualified Stack.Docker as Docker
 import           Stack.Package
-import           Stack.GhcPkg (getCabalPkgVer)
 import           Stack.Types
 import           System.Directory
 import           System.Environment
@@ -359,8 +358,6 @@ loadBuildConfig menv mproject config noConfigStrat = do
     packages' <- mapM (resolvePackageEntry menv root) (projectPackages project)
     let packages = Map.fromList $ concat packages'
 
-    cabalVer <- getCabalPkgVer menv
-
     return BuildConfig
         { bcConfig = config
         , bcResolver = projectResolver project
@@ -370,7 +367,6 @@ loadBuildConfig menv mproject config noConfigStrat = do
         , bcRoot = root
         , bcStackYaml = stackYamlFP
         , bcFlags = projectFlags project
-        , bcCabalVersion = cabalVer
         }
 
 -- | Resolve a PackageEntry into a list of paths, downloading and cloning as

src/Stack/Constants.hs

@@ -44,30 +44,30 @@ haskellFileExts :: [Text]
 haskellFileExts = ["hs","hsc","lhs"]
 
 -- | The filename used for completed build indicators.
-builtFileFromDir :: (MonadThrow m, MonadReader env m, HasPlatform env,HasBuildConfig env)
+builtFileFromDir :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)
                  => Path Abs Dir
                  -> m (Path Abs File)
 builtFileFromDir fp = do
   dist <- distDirFromDir fp
   return (dist </> $(mkRelFile "stack.gen"))
 
 -- | The filename used for completed configure indicators.
-configuredFileFromDir :: (MonadThrow m, MonadReader env m, HasPlatform env,HasBuildConfig env)
+configuredFileFromDir :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)
                       => Path Abs Dir
                       -> m (Path Abs File)
 configuredFileFromDir fp = do
   dist <- distDirFromDir fp
   return (dist </> $(mkRelFile "setup-config"))
 
 -- | The filename used for completed build indicators.
-builtConfigFileFromDir :: (MonadThrow m, MonadReader env m, HasPlatform env,HasBuildConfig env)
+builtConfigFileFromDir :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)
                        => Path Abs Dir
                        -> m (Path Abs File)
 builtConfigFileFromDir fp =
     liftM (fp </>) builtConfigRelativeFile
 
 -- | Relative location of completed build indicators.
-builtConfigRelativeFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasBuildConfig env)
+builtConfigRelativeFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)
                         => m (Path Rel File)
 builtConfigRelativeFile = do
   dist <- distRelativeDir
@@ -96,7 +96,7 @@ userDocsDir :: Config -> Path Abs Dir
 userDocsDir config = configStackRoot config </> $(mkRelDir "doc/")
 
 -- | The filename used for dirtiness check of source files.
-buildCacheFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasBuildConfig env)
+buildCacheFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)
                => Path Abs Dir      -- ^ Package directory.
                -> m (Path Abs File)
 buildCacheFile dir = do
@@ -105,7 +105,7 @@ buildCacheFile dir = do
         (distDirFromDir dir)
 
 -- | The filename used for dirtiness check of config.
-configCacheFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasBuildConfig env)
+configCacheFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)
                 => Path Abs Dir      -- ^ Package directory.
                 -> m (Path Abs File)
 configCacheFile dir = do
@@ -114,17 +114,17 @@ configCacheFile dir = do
         (distDirFromDir dir)
 
 -- | Package's build artifacts directory.
-distDirFromDir :: (MonadThrow m, MonadReader env m, HasPlatform env, HasBuildConfig env)
+distDirFromDir :: (MonadThrow m, MonadReader env m, HasPlatform env, HasEnvConfig env)
                => Path Abs Dir
                -> m (Path Abs Dir)
 distDirFromDir fp =
     liftM (fp </>) distRelativeDir
 
 -- | Relative location of build artifacts.
-distRelativeDir :: (MonadThrow m, MonadReader env m, HasPlatform env, HasBuildConfig env)
+distRelativeDir :: (MonadThrow m, MonadReader env m, HasPlatform env, HasEnvConfig env)
                 => m (Path Rel Dir)
 distRelativeDir = do
-    cabalPkgVer <- asks (bcCabalVersion . getBuildConfig)
+    cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig)
     platform <- platformRelDir
     cabal <-
         parseRelDir $

src/Stack/Types/Config.hs

@@ -181,10 +181,22 @@ data BuildConfig = BuildConfig
       -- different from bcRoot </> "stack.yaml"
     , bcFlags      :: !(Map PackageName (Map FlagName Bool))
       -- ^ Per-package flag overrides
-    , bcCabalVersion :: !Version
-      -- ^ Cabal version used.
     }
 
+-- | Configuration after the environment has been setup.
+data EnvConfig = EnvConfig
+    {envConfigBuildConfig :: !BuildConfig
+    ,envConfigCabalVersion :: !Version}
+instance HasBuildConfig EnvConfig where
+    getBuildConfig = envConfigBuildConfig
+instance HasConfig EnvConfig
+instance HasPlatform EnvConfig
+instance HasStackRoot EnvConfig
+class HasEnvConfig r where
+    getEnvConfig :: r -> EnvConfig
+instance HasEnvConfig EnvConfig where
+    getEnvConfig = id
+
 -- | Value returned by 'Stack.Config.loadConfig'.
 data LoadConfig m = LoadConfig
     { lcConfig          :: !Config

src/Stack/Types/Internal.hs

@@ -23,6 +23,8 @@ instance HasConfig config => HasConfig (Env config) where
     getConfig = getConfig . envConfig
 instance HasBuildConfig config => HasBuildConfig (Env config) where
     getBuildConfig = getBuildConfig . envConfig
+instance HasEnvConfig config => HasEnvConfig (Env config) where
+    getEnvConfig = getEnvConfig . envConfig
 
 instance HasHttpManager (Env config) where
   getHttpManager = envManager

src/main/Main.hs

@@ -37,7 +37,7 @@ import           Stack.Config
 import           Stack.Constants
 import qualified Stack.Docker as Docker
 import           Stack.Fetch
-import           Stack.GhcPkg (envHelper)
+import           Stack.GhcPkg (envHelper,getCabalPkgVer)
 import qualified Stack.PackageIndex
 import           Stack.Path
 import           Stack.Setup
@@ -258,16 +258,26 @@ setupCmd SetupCmdOpts{..} go@GlobalOpts{..} = do
 
 withBuildConfig :: GlobalOpts
                 -> NoBuildConfigStrategy
-                -> StackT BuildConfig IO ()
+                -> StackT EnvConfig IO ()
                 -> IO ()
 withBuildConfig go@GlobalOpts{..} strat inner = do
     (manager, lc) <- loadConfigWithOpts go
     runStackLoggingT manager globalLogLevel $
         Docker.rerunWithOptionalContainer (lcConfig lc) (lcProjectRoot lc) $ do
             bconfig1 <- runStackLoggingT manager globalLogLevel $
                 lcLoadBuildConfig lc strat
-            bconfig2 <- runStackT manager globalLogLevel bconfig1 setupEnv
-            runStackT manager globalLogLevel bconfig2 inner
+            (bconfig2,cabalVer) <-
+                runStackT
+                    manager globalLogLevel bconfig1
+                    (do cfg <- setupEnv
+                        menv <- getMinimalEnvOverride
+                        cabalVer <- getCabalPkgVer menv
+                        return (cfg,cabalVer))
+            runStackT
+                manager
+                globalLogLevel
+                (EnvConfig bconfig2 cabalVer)
+                inner
 
 cleanCmd :: () -> GlobalOpts -> IO ()
 cleanCmd () go = withBuildConfig go ThrowException clean