Allow overriding OS and architecture #261

commercialhaskell · Jun 11, 2015 · 81a5f45 · 81a5f45
1 parent 13e4e36
commit 81a5f45
Show file tree

Hide file tree

Showing 3 changed files with 32 additions and 5 deletions.
diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs
@@ -44,6 +44,7 @@ import qualified Data.IntMap as IntMap
 import qualified Data.Map as Map
 import qualified Distribution.Package as C
 import qualified Distribution.PackageDescription as C
+import qualified Distribution.Text
 import qualified Distribution.Version as C
 import           Data.Maybe
 import           Data.Monoid
@@ -54,7 +55,7 @@ import qualified Data.Yaml as Yaml
 import           Distribution.System (OS (Windows), Platform (..), buildPlatform)
 import           Network.HTTP.Client.Conduit (HasHttpManager, getHttpManager, Manager, parseUrl)
 import           Network.HTTP.Download (download)
-import           Options.Applicative (Parser, idm)
+import           Options.Applicative (Parser, idm, strOption, long, metavar, help)
 import           Options.Applicative.Builder.Extra (maybeBoolFlags)
 import           Path
 import           Path.IO
@@ -174,7 +175,12 @@ configFromConfigMonoid configStackRoot mproject ConfigMonoid{..} = do
 
          -- Only place in the codebase where platform is hard-coded. In theory
          -- in the future, allow it to be configured.
-         configPlatform = buildPlatform
+         (Platform defArch defOS) = buildPlatform
+         arch = fromMaybe defArch
+              $ configMonoidArch >>= Distribution.Text.simpleParse
+         os = fromMaybe defOS
+            $ configMonoidOS >>= Distribution.Text.simpleParse
+         configPlatform = Platform arch os
 
          configRequireStackVersion = fromMaybe C.anyVersion configMonoidRequireStackVersion
 
@@ -199,10 +205,12 @@ configFromConfigMonoid configStackRoot mproject ConfigMonoid{..} = do
 -- | Command-line arguments parser for configuration.
 configOptsParser :: Bool -> Parser ConfigMonoid
 configOptsParser docker =
-    (\opts systemGHC installGHC -> mempty
+    (\opts systemGHC installGHC arch os -> mempty
         { configMonoidDockerOpts = opts
         , configMonoidSystemGHC = systemGHC
         , configMonoidInstallGHC = installGHC
+        , configMonoidArch = arch
+        , configMonoidOS = os
         })
     <$> Docker.dockerOptsParser docker
     <*> maybeBoolFlags
@@ -213,6 +221,16 @@ configOptsParser docker =
             "install-ghc"
             "downloading and installing GHC if necessary (can be done manually with stack setup)"
             idm
+    <*> optional (strOption
+            ( long "arch"
+           <> metavar "ARCH"
+           <> help "System architecture, e.g. i386, x86_64"
+            ))
+    <*> optional (strOption
+            ( long "os"
+           <> metavar "OS"
+           <> help "Operating system, e.g. linux, windows"
+            ))
 
 -- | Get the directory on Windows where we should install extra programs. For
 -- more information, see discussion at:

diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs
@@ -457,8 +457,7 @@ getOSKey = do
         Platform I386 FreeBSD -> return "freebsd32"
         Platform X86_64 FreeBSD -> return "freebsd64"
         Platform I386 Windows -> return "windows32"
-        -- Note: we always use 32-bit Windows as the 64-bit version has problems
-        Platform X86_64 Windows -> return "windows32"
+        Platform X86_64 Windows -> return "windows64"
         Platform arch os -> throwM $ UnsupportedSetupCombo os arch
 
 downloadPair :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)

diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs
@@ -366,6 +366,10 @@ data ConfigMonoid =
     -- ^ See: 'configInstallGHC'
     ,configMonoidRequireStackVersion :: !(Maybe VersionRange)
     -- ^ See: 'configRequireStackVersion'
+    ,configMonoidOS                  :: !(Maybe String)
+    -- ^ Used for overriding the platform
+    ,configMonoidArch                :: !(Maybe String)
+    -- ^ Used for overriding the platform
     }
   deriving Show
 
@@ -379,6 +383,8 @@ instance Monoid ConfigMonoid where
     , configMonoidSystemGHC = Nothing
     , configMonoidInstallGHC = Nothing
     , configMonoidRequireStackVersion = Nothing
+    , configMonoidOS = Nothing
+    , configMonoidArch = Nothing
     }
   mappend l r = ConfigMonoid
     { configMonoidDockerOpts = configMonoidDockerOpts l <> configMonoidDockerOpts r
@@ -389,6 +395,8 @@ instance Monoid ConfigMonoid where
     , configMonoidSystemGHC = configMonoidSystemGHC l <|> configMonoidSystemGHC r
     , configMonoidInstallGHC = configMonoidInstallGHC l <|> configMonoidInstallGHC r
     , configMonoidRequireStackVersion = configMonoidRequireStackVersion l <|> configMonoidRequireStackVersion r
+    , configMonoidOS = configMonoidOS l <|> configMonoidOS r
+    , configMonoidArch = configMonoidArch l <|> configMonoidArch r
     }
 
 instance FromJSON ConfigMonoid where
@@ -404,6 +412,8 @@ instance FromJSON ConfigMonoid where
          configMonoidInstallGHC <- obj .:? "install-ghc"
          configMonoidRequireStackVersion <- fmap unVersionRangeJSON <$>
                                             obj .:? "require-stack-version"
+         configMonoidOS <- obj .:? "os"
+         configMonoidArch <- obj .:? "arch"
          return ConfigMonoid {..}
 
 -- | Newtype for non-orphan FromJSON instance.