--resolver (closes #224)

commercialhaskell · Jun 16, 2015 · 83cad94 · 83cad94
1 parent a855035
commit 83cad94
Show file tree

Hide file tree

Showing 4 changed files with 34 additions and 8 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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