From 83cad945b00e3a200a58e068dff241fae5a2c8d8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 16 Jun 2015 16:02:33 +0300 Subject: [PATCH] --resolver (closes #224) --- ChangeLog.md | 1 + src/Stack/Config.hs | 17 +++++++++++++---- src/Stack/Types/Config.hs | 2 +- src/main/Main.hs | 22 +++++++++++++++++++--- 4 files changed, 34 insertions(+), 8 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 15695d3cba..78c01b291f 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -3,6 +3,7 @@ * `--prefetch` [#297](https://github.com/commercialhaskell/stack/issues/297) * `upload` command ported from stackage-upload [#225](https://github.com/commercialhaskell/stack/issues/225) * `--only-snapshot` [#310](https://github.com/commercialhaskell/stack/issues/310) +* `--resolver` [#224](https://github.com/commercialhaskell/stack/issues/224) ## 0.0.2 diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 3b81dd4fec..2066a52104 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -335,12 +335,13 @@ loadBuildConfig :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader env m, H -> Maybe (Project, Path Abs File, ConfigMonoid) -> Config -> Path Abs Dir + -> Maybe Resolver -- override resolver -> NoBuildConfigStrategy -> m BuildConfig -loadBuildConfig menv mproject config stackRoot noConfigStrat = do +loadBuildConfig menv mproject config stackRoot mresolver noConfigStrat = do env <- ask let miniConfig = MiniConfig (getHttpManager env) config - (project, stackYamlFP) <- case mproject of + (project', stackYamlFP) <- case mproject of Just (project, fp, _) -> return (project, fp) Nothing -> case noConfigStrat of ThrowException -> do @@ -359,8 +360,13 @@ loadBuildConfig menv mproject config stackRoot noConfigStrat = do inTerminal <- liftIO (hIsTerminalDevice stdout) ProjectAndConfigMonoid project _ <- loadYaml dest when inTerminal $ do - $logInfo ("Using resolver: " <> renderResolver (projectResolver project) <> - " from global config file: " <> T.pack dest') + case mresolver of + Nothing -> + $logInfo ("Using resolver: " <> renderResolver (projectResolver project) <> + " from global config file: " <> T.pack dest') + Just resolver -> + $logInfo ("Using resolver: " <> renderResolver resolver <> + " specified on command line") return (project, dest) else do r <- runReaderT getLatestResolver miniConfig @@ -391,6 +397,9 @@ loadBuildConfig menv mproject config stackRoot noConfigStrat = do } liftIO $ Yaml.encodeFile dest' p return (p, dest) + let project = project' + { projectResolver = fromMaybe (projectResolver project') mresolver + } ghcVersion <- case projectResolver project of diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 5f369ab6f5..8516a4a805 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -201,7 +201,7 @@ instance HasEnvConfig EnvConfig where data LoadConfig m = LoadConfig { lcConfig :: !Config -- ^ Top-level Stack configuration. - , lcLoadBuildConfig :: !(NoBuildConfigStrategy -> m BuildConfig) + , lcLoadBuildConfig :: !(Maybe Resolver -> NoBuildConfigStrategy -> m BuildConfig) -- ^ Action to load the remaining 'BuildConfig'. , lcProjectRoot :: !(Maybe (Path Abs Dir)) -- ^ The project root directory, if in a project. diff --git a/src/main/Main.hs b/src/main/Main.hs index cd21fd762f..d88abb57b5 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -191,7 +191,8 @@ main = pathCmd :: PathArg -> GlobalOpts -> IO () pathCmd pathArg go@GlobalOpts{..} = do (manager,lc) <- loadConfigWithOpts go - buildConfig <- runStackLoggingT manager globalLogLevel (lcLoadBuildConfig lc ExecStrategy) + buildConfig <- runStackLoggingT manager globalLogLevel + (lcLoadBuildConfig lc globalResolver ExecStrategy) runStackT manager globalLogLevel buildConfig (pathString pathArg) >>= putStrLn @@ -250,7 +251,7 @@ setupCmd SetupCmdOpts{..} go@GlobalOpts{..} = do case scoGhcVersion of Just v -> return (v, Nothing) Nothing -> do - bc <- lcLoadBuildConfig lc ThrowException + bc <- lcLoadBuildConfig lc globalResolver ThrowException return (bcGhcVersion bc, Just $ bcStackYaml bc) mpaths <- runStackT manager globalLogLevel (lcConfig lc) $ ensureGHC SetupOpts { soptsInstallIfMissing = True @@ -277,7 +278,7 @@ withBuildConfig go@GlobalOpts{..} strat inner = do runStackLoggingT manager globalLogLevel $ Docker.rerunWithOptionalContainer (lcConfig lc) (lcProjectRoot lc) $ do bconfig1 <- runStackLoggingT manager globalLogLevel $ - lcLoadBuildConfig lc strat + lcLoadBuildConfig lc globalResolver strat (bconfig2,cabalVer) <- runStackT manager globalLogLevel bconfig1 @@ -515,6 +516,7 @@ globalOpts = GlobalOpts <$> logLevelOpt <*> configOptsParser False + <*> optional resolverParser -- | Parse for a logging level. logLevelOpt :: Parser LogLevel @@ -543,6 +545,19 @@ logLevelOpt = "error" -> LevelError _ -> LevelOther (T.pack s) +resolverParser :: Parser Resolver +resolverParser = + option readResolver + (long "resolver" <> + metavar "RESOLVER" <> + help "Override resolver in project file") + where + readResolver = do + s <- readerAsk + case parseResolver $ T.pack s of + Left e -> readerError $ show e + Right x -> return x + -- | Default logging level should be something useful but not crazy. defaultLogLevel :: LogLevel defaultLogLevel = LevelInfo @@ -551,6 +566,7 @@ defaultLogLevel = LevelInfo data GlobalOpts = GlobalOpts { globalLogLevel :: LogLevel -- ^ Log level , globalConfigMonoid :: ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig' + , globalResolver :: Maybe Resolver -- ^ Resolver override } deriving (Show) -- | Load the configuration with a manager. Convenience function used