Merge pull request #816 from commercialhaskell/wip/530-specialized-gh…

…c-bindists Support specialized GHC bindists (#530)
commercialhaskell · Sep 18, 2015 · de6cff6 · de6cff6
2 parents 4e58783 + 1bab31b
commit de6cff6
Show file tree

Hide file tree

Showing 16 changed files with 531 additions and 258 deletions.
diff --git a/ChangeLog.md b/ChangeLog.md
@@ -3,6 +3,14 @@
 Major changes:
 
 * On Windows, we now use a full MSYS2 installation in place of the previous PortableGit. This gives you access to the pacman package manager for more easily installing libraries.
+* Support for custom GHC binary distributions [#530](https://github.com/commercialhaskell/stack/issues/530)
+    * `ghc-variant` option in stack.yaml to specify the variant (also
+      `--ghc-variant` command-line option)
+    * `setup-info` in stack.yaml, to specify where to download custom binary
+      distributions (also `--ghc-bindist` command-line option)
+    * Note: On systems with libgmp4 (aka `libgmp.so.3`), such as CentOS 6, you
+      may need to re-run `stack setup` due to the centos6 GHC bindist being
+      treated like a variant
 
 Other enhancements:
 

diff --git a/src/Data/Aeson/Extended.hs b/src/Data/Aeson/Extended.hs
@@ -10,13 +10,15 @@ module Data.Aeson.Extended (
   , WarningParser
   , JSONWarning (..)
   , withObjectWarnings
-  , (..:)
-  , (..:?)
-  , (..!=)
   , jsonSubWarnings
   , jsonSubWarningsT
-  , jsonSubWarningsMT
+  , jsonSubWarningsTT
   , logJSONWarnings
+  , tellJSONField
+  , unWarningParser
+  , (..:)
+  , (..:?)
+  , (..!=)
   ) where
 
 import Control.Monad.Logger (MonadLogger, logWarn)
@@ -49,13 +51,13 @@ import Prelude -- Fix redundant import warnings
 (..:)
     :: FromJSON a
     => Object -> Text -> WarningParser a
-o ..: k = tellField k >> lift (o .: k)
+o ..: k = tellJSONField k >> lift (o .: k)
 
 -- | 'WarningParser' version of @.:?@.
 (..:?)
     :: FromJSON a
     => Object -> Text -> WarningParser (Maybe a)
-o ..:? k = tellField k >> lift (o .:? k)
+o ..:? k = tellJSONField k >> lift (o .:? k)
 
 -- | 'WarningParser' version of @.!=@.
 (..!=) :: WarningParser (Maybe a) -> a -> WarningParser a
@@ -65,11 +67,11 @@ wp ..!= d =
          do a <- fmap snd p
             fmap (, a) (fmap fst p .!= d)
 
--- | Tell warning parser about about an expected field.
-tellField :: Text -> WarningParser ()
-tellField key = tell (mempty { wpmExpectedFields = Set.singleton key})
+-- | Tell warning parser about about an expected field, so it doesn't warn about it.
+tellJSONField :: Text -> WarningParser ()
+tellJSONField key = tell (mempty { wpmExpectedFields = Set.singleton key})
 
--- | 'MonadParser' version of 'withObject'.
+-- | 'WarningParser' version of 'withObject'.
 withObjectWarnings :: String
                    -> (Object -> WarningParser a)
                    -> Value
@@ -90,6 +92,12 @@ withObjectWarnings expected f =
                       [] -> []
                       _ -> [JSONUnrecognizedFields expected unrecognizedFields])
 
+-- | Convert a 'WarningParser' to a 'Parser'.
+unWarningParser :: WarningParser a -> Parser a
+unWarningParser wp = do
+    (a,_) <- runWriterT wp
+    return a
+
 -- | Log JSON warnings.
 logJSONWarnings
     :: MonadLogger m
@@ -115,20 +123,17 @@ jsonSubWarningsT f =
     Traversable.mapM (jsonSubWarnings . return) =<< f
 
 -- | Handle warnings in a @Maybe Traversable@ of sub-objects.
-jsonSubWarningsMT
-    :: (Traversable t)
-    => WarningParser (Maybe (t (a, [JSONWarning])))
-    -> WarningParser (Maybe (t a))
-jsonSubWarningsMT f = do
-    ml <- f
-    case ml of
-        Nothing -> return Nothing
-        Just l -> fmap Just (jsonSubWarningsT (return l))
+jsonSubWarningsTT
+    :: (Traversable t, Traversable u)
+    => WarningParser (u (t (a, [JSONWarning])))
+    -> WarningParser (u (t a))
+jsonSubWarningsTT f =
+    Traversable.mapM (jsonSubWarningsT . return) =<< f
 
 -- | JSON parser that warns about unexpected fields in objects.
 type WarningParser a = WriterT WarningParserMonoid Parser a
 
--- | Monoid used by 'MonadParser' to track expected fields and warnings.
+-- | Monoid used by 'WarningParser' to track expected fields and warnings.
 data WarningParserMonoid = WarningParserMonoid
     { wpmExpectedFields :: !(Set Text)
     , wpmWarnings :: [JSONWarning]

diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs
@@ -108,6 +108,7 @@ data Ctx = Ctx
 
 instance HasStackRoot Ctx
 instance HasPlatform Ctx
+instance HasGHCVariant Ctx
 instance HasConfig Ctx
 instance HasBuildConfig Ctx where
     getBuildConfig = getBuildConfig . getEnvConfig

diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs
@@ -429,7 +429,7 @@ instance FromJSON Snapshots where
 
 -- | Load up a 'MiniBuildPlan', preferably from cache
 loadMiniBuildPlan
-    :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m, MonadCatch m)
+    :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, HasGHCVariant env, MonadBaseControl IO m, MonadCatch m)
     => SnapName
     -> m MiniBuildPlan
 loadMiniBuildPlan name = do
@@ -587,7 +587,7 @@ instance Monoid DepError where
 
 -- | Find a snapshot and set of flags that is compatible with the given
 -- 'GenericPackageDescription'. Returns 'Nothing' if no such snapshot is found.
-findBuildPlan :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m)
+findBuildPlan :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, HasGHCVariant env, MonadBaseControl IO m)
               => [GenericPackageDescription]
               -> [SnapName]
               -> m (Maybe (SnapName, Map PackageName (Map FlagName Bool)))

diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs
@@ -21,7 +21,9 @@
 -- probably default to behaving like cabal, possibly with spitting out
 -- a warning that "you should run `stk init` to make things better".
 module Stack.Config
-  (loadConfig
+  (MiniConfig
+  ,loadConfig
+  ,loadMiniConfig
   ,packagesParser
   ,resolvePackageEntry
   ) where
@@ -35,7 +37,7 @@ import           Control.Monad
 import           Control.Monad.Catch (Handler(..), MonadCatch, MonadThrow, catches, throwM)
 import           Control.Monad.IO.Class
 import           Control.Monad.Logger hiding (Loc)
-import           Control.Monad.Reader (MonadReader, ask, asks, runReaderT)
+import           Control.Monad.Reader (MonadReader, ask, runReaderT)
 import           Control.Monad.Trans.Control (MonadBaseControl)
 import qualified Crypto.Hash.SHA256 as SHA256
 import           Data.Aeson.Extended
@@ -46,7 +48,8 @@ import qualified Data.Map as Map
 import           Data.Maybe
 import           Data.Monoid
 import qualified Data.Text as T
-import           Data.Text.Encoding (encodeUtf8, decodeUtf8)
+import           Data.Text.Encoding (encodeUtf8, decodeUtf8, decodeUtf8With)
+import           Data.Text.Encoding.Error (lenientDecode)
 import qualified Data.Yaml as Yaml
 import           Distribution.System (OS (..), Platform (..), buildPlatform)
 import qualified Distribution.Text
@@ -58,6 +61,7 @@ import           Options.Applicative (Parser, strOption, long, help)
 import           Path
 import           Path.IO
 import qualified Paths_stack as Meta
+import           Safe (headMay)
 import           Stack.BuildPlan
 import           Stack.Constants
 import qualified Stack.Docker as Docker
@@ -115,7 +119,9 @@ configFromConfigMonoid configStackRoot mproject configMonoid@ConfigMonoid{..} =
                 }]
             configMonoidPackageIndices
 
-         configSystemGHC = fromMaybe True configMonoidSystemGHC
+         configGHCVariant0 = configMonoidGHCVariant
+
+         configSystemGHC = fromMaybe (isNothing configGHCVariant0) configMonoidSystemGHC
          configInstallGHC = fromMaybe False configMonoidInstallGHC
          configSkipGHCCheck = fromMaybe False configMonoidSkipGHCCheck
          configSkipMsys = fromMaybe False configMonoidSkipMsys
@@ -147,14 +153,16 @@ configFromConfigMonoid configStackRoot mproject configMonoid@ConfigMonoid{..} =
               $ map (T.pack *** T.pack) rawEnv
      let configEnvOverride _ = return origEnv
 
-     platform <- runReaderT platformRelDir configPlatform
-
+     platformOnlyDir <- runReaderT platformOnlyRelDir configPlatform
      configLocalPrograms <-
-        case configPlatform of
-            Platform _ Windows -> do
-                progsDir <- getWindowsProgsDir configStackRoot origEnv
-                return $ progsDir </> $(mkRelDir stackProgName) </> platform
-            _ -> return $ configStackRoot </> $(mkRelDir "programs") </> platform
+         case configPlatform of
+             Platform _ Windows -> do
+                 progsDir <- getWindowsProgsDir configStackRoot origEnv
+                 return $ progsDir </> $(mkRelDir stackProgName) </> platformOnlyDir
+             _ ->
+                 return $
+                 configStackRoot </> $(mkRelDir "programs") </>
+                 platformOnlyDir
 
      configLocalBin <-
          case configMonoidLocalBinPath of
@@ -176,9 +184,30 @@ configFromConfigMonoid configStackRoot mproject configMonoid@ConfigMonoid{..} =
      let configTemplateParams = configMonoidTemplateParameters
          configScmInit = configMonoidScmInit
          configGhcOptions = configMonoidGhcOptions
+         configSetupInfoLocations = configMonoidSetupInfoLocations
 
      return Config {..}
 
+-- | Get the default 'GHCVariant'.  On older Linux systems with libgmp4, returns 'GHCGMP4'.
+getDefaultGHCVariant
+    :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadLogger m)
+    => EnvOverride -> Platform -> m GHCVariant
+getDefaultGHCVariant menv (Platform _ Linux) = do
+    executablePath <- liftIO getExecutablePath
+    elddOut <- tryProcessStdout Nothing menv "ldd" [executablePath]
+    return $
+        case elddOut of
+            Left _ -> GHCStandard
+            Right lddOut ->
+                if hasLineWithFirstWord "libgmp.so.3" lddOut
+                    then GHCGMP4
+                    else GHCStandard
+  where
+    hasLineWithFirstWord w =
+        elem (Just w) .
+        map (headMay . T.words) . T.lines . decodeUtf8With lenientDecode
+getDefaultGHCVariant _ _ = return GHCStandard
+
 -- | Get the directory on Windows where we should install extra programs. For
 -- more information, see discussion at:
 -- https://github.com/fpco/minghc/issues/43#issuecomment-99737383
@@ -193,13 +222,29 @@ getWindowsProgsDir stackRoot m =
             return $ lad </> $(mkRelDir "Programs")
         Nothing -> return $ stackRoot </> $(mkRelDir "Programs")
 
-data MiniConfig = MiniConfig Manager Config
+-- | An environment with a subset of BuildConfig used for setup.
+data MiniConfig = MiniConfig Manager GHCVariant Config
 instance HasConfig MiniConfig where
-    getConfig (MiniConfig _ c) = c
+    getConfig (MiniConfig _ _ c) = c
 instance HasStackRoot MiniConfig
 instance HasHttpManager MiniConfig where
-    getHttpManager (MiniConfig man _) = man
+    getHttpManager (MiniConfig man _ _) = man
 instance HasPlatform MiniConfig
+instance HasGHCVariant MiniConfig where
+    getGHCVariant (MiniConfig _ v _) = v
+
+-- | Load the 'MiniConfig'.
+loadMiniConfig
+    :: (MonadIO m, HasHttpManager a, MonadReader a m, MonadBaseControl IO m, MonadCatch m, MonadLogger m)
+    => Config -> m MiniConfig
+loadMiniConfig config = do
+    menv <- liftIO $ (configEnvOverride config) minimalEnvSettings
+    manager <- getHttpManager <$> ask
+    ghcVariant <-
+        case configGHCVariant0 config of
+            Just ghcVariant -> return ghcVariant
+            Nothing -> getDefaultGHCVariant menv (configPlatform config)
+    return (MiniConfig manager ghcVariant config)
 
 -- | Load the configuration, using current directory, environment variables,
 -- and defaults as necessary.
@@ -235,7 +280,8 @@ loadBuildConfig :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader env m, H
                 -> m BuildConfig
 loadBuildConfig mproject config stackRoot mresolver = do
     env <- ask
-    let miniConfig = MiniConfig (getHttpManager env) config
+    miniConfig <- loadMiniConfig config
+
     (project', stackYamlFP) <- case mproject of
       Just (project, fp, _) -> return (project, fp)
       Nothing -> do
@@ -283,10 +329,7 @@ loadBuildConfig mproject config stackRoot mresolver = do
         case mresolver of
             Nothing -> return $ projectResolver project'
             Just aresolver -> do
-                manager <- asks getHttpManager
-                runReaderT
-                    (makeConcreteResolver aresolver)
-                    (MiniConfig manager config)
+                runReaderT (makeConcreteResolver aresolver) miniConfig
     let project = project' { projectResolver = resolver }
 
     wantedCompiler <-
@@ -308,6 +351,7 @@ loadBuildConfig mproject config stackRoot mresolver = do
         , bcStackYaml = stackYamlFP
         , bcFlags = projectFlags project
         , bcImplicitGlobal = isNothing mproject
+        , bcGHCVariant = getGHCVariant miniConfig
         }
 
 -- | Resolve a PackageEntry into a list of paths, downloading and cloning as

diff --git a/src/Stack/Constants.hs b/src/Stack/Constants.hs
@@ -200,7 +200,7 @@ distRelativeDir :: (MonadThrow m, MonadReader env m, HasPlatform env, HasEnvConf
                 => m (Path Rel Dir)
 distRelativeDir = do
     cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig)
-    platform <- platformRelDir
+    platform <- platformVariantRelDir
     cabal <-
         parseRelDir $
         packageIdentifierString

diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs
@@ -59,7 +59,7 @@ ignoredDirs = Set.fromList
     ]
 
 -- | Generate stack.yaml
-initProject :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)
+initProject :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, HasGHCVariant env, MonadLogger m, MonadBaseControl IO m)
             => Path Abs Dir
             -> InitOpts
             -> m ()
@@ -126,7 +126,7 @@ getSnapshots' =
         return Nothing
 
 -- | Get the default resolver value
-getDefaultResolver :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)
+getDefaultResolver :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, HasGHCVariant env, MonadLogger m, MonadBaseControl IO m)
                    => [Path Abs File] -- ^ cabal files
                    -> [C.GenericPackageDescription] -- ^ cabal descriptions
                    -> InitOpts
@@ -163,7 +163,7 @@ getDefaultResolver cabalfps gpds initOpts =
                 , fmap fst extraDeps
                 )
 
-getRecommendedSnapshots :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)
+getRecommendedSnapshots :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, HasGHCVariant env, MonadLogger m, MonadBaseControl IO m)
                         => Snapshots
                         -> SnapPref
                         -> m [SnapName]

diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs
@@ -216,13 +216,14 @@ readFlag = do
 -- | Command-line arguments parser for configuration.
 configOptsParser :: Bool -> Parser ConfigMonoid
 configOptsParser docker =
-    (\opts systemGHC installGHC arch os jobs includes libs skipGHCCheck skipMsys localBin -> mempty
+    (\opts systemGHC installGHC arch os ghcVariant jobs includes libs skipGHCCheck skipMsys localBin -> mempty
         { configMonoidDockerOpts = opts
         , configMonoidSystemGHC = systemGHC
         , configMonoidInstallGHC = installGHC
         , configMonoidSkipGHCCheck = skipGHCCheck
         , configMonoidArch = arch
         , configMonoidOS = os
+        , configMonoidGHCVariant = ghcVariant
         , configMonoidJobs = jobs
         , configMonoidExtraIncludeDirs = includes
         , configMonoidExtraLibDirs = libs
@@ -248,6 +249,7 @@ configOptsParser docker =
            <> metavar "OS"
            <> help "Operating system, e.g. linux, windows"
             ))
+    <*> optional ghcVariantParser
     <*> optional (option auto
             ( long "jobs"
            <> short 'j'
@@ -595,6 +597,21 @@ readAbstractResolver = do
                 Left e -> readerError $ show e
                 Right x -> return $ ARResolver x
 
+-- | GHC variant parser
+ghcVariantParser :: Parser GHCVariant
+ghcVariantParser =
+    option
+        readGHCVariant
+        (long "ghc-variant" <> metavar "VARIANT" <>
+         help
+             "Specialized GHC variant, e.g. integersimple (implies --no-system-ghc)")
+  where
+    readGHCVariant = do
+        s <- readerAsk
+        case parseGHCVariant s of
+            Left e -> readerError (show e)
+            Right v -> return v
+
 -- | Parser for @solverCmd@
 solverOptsParser :: Parser Bool
 solverOptsParser = boolFlags False

diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs
@@ -727,7 +727,7 @@ mkResolveConditions :: CompilerVersion -- ^ Compiler version
 mkResolveConditions compilerVersion (Platform arch os) flags = ResolveConditions
     { rcFlags = flags
     , rcCompilerVersion = compilerVersion
-    , rcOS = if isWindows os then Windows else os
+    , rcOS = os
     , rcArch = arch
     }