From e9246f75195b1388926f6d08234676a2e9a50e1d Mon Sep 17 00:00:00 2001 From: Emanuel Borsboom Date: Tue, 18 Aug 2015 08:15:05 -0700 Subject: [PATCH 1/7] Support specialized GHC bindists, initial WIP (#530) --- src/Stack/Build/ConstructPlan.hs | 1 + src/Stack/Config.hs | 40 +++++++++++++++-- src/Stack/Options.hs | 8 +++- src/Stack/Package.hs | 2 +- src/Stack/Setup.hs | 76 +++++++++++++++----------------- src/Stack/Types/BuildPlan.hs | 7 --- src/Stack/Types/Config.hs | 75 +++++++++++++++++++++++++++---- src/Stack/Types/Internal.hs | 2 + src/System/Process/Read.hs | 3 +- 9 files changed, 150 insertions(+), 64 deletions(-) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 5b3b2f3e4d..e337e507ab 100644 --- 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/Config.hs b/src/Stack/Config.hs index bc52ca714e..49c47d58b8 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -46,7 +46,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 +59,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 @@ -89,9 +91,16 @@ getLatestResolver = do defaultStackGlobalConfig :: Maybe (Path Abs File) defaultStackGlobalConfig = parseAbsFile "/etc/stack/config" +-- | Used to get the @dist@ directory before the full Config is available. +data PlatformGHCVariant = PlatformGHCVariant Platform GHCVariant +instance HasPlatform PlatformGHCVariant where + getPlatform (PlatformGHCVariant platform _) = platform +instance HasGHCVariant PlatformGHCVariant where + getGHCVariant (PlatformGHCVariant _ ghcVariant) = ghcVariant + -- Interprets ConfigMonoid options. configFromConfigMonoid - :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader env m, HasHttpManager env) + :: (MonadBaseControl IO m, MonadLogger m, MonadIO m, MonadCatch m, MonadReader env m, HasHttpManager env) => Path Abs Dir -- ^ stack root, e.g. ~/.stack -> Maybe Project -> ConfigMonoid @@ -147,7 +156,11 @@ configFromConfigMonoid configStackRoot mproject configMonoid@ConfigMonoid{..} = $ map (T.pack *** T.pack) rawEnv let configEnvOverride _ = return origEnv - platform <- runReaderT platformRelDir configPlatform + configGHCVariant <- case parseGHCVariant <$> configMonoidGHCVariant of + Just ghcVariant -> return ghcVariant + Nothing -> getDefaultGHCVariant origEnv os + + platform <- runReaderT platformRelDir (PlatformGHCVariant configPlatform configGHCVariant) configLocalPrograms <- case configPlatform of @@ -179,6 +192,26 @@ configFromConfigMonoid configStackRoot mproject configMonoid@ConfigMonoid{..} = return Config {..} +-- | Get the default 'GHCVariant'. On older Linux systems with libgmp4, returns 'Gmp4'. +getDefaultGHCVariant + :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadLogger m) + => EnvOverride -> OS -> m GHCVariant +getDefaultGHCVariant menv Linux = do + executablePath <- liftIO getExecutablePath + elddOut <- tryProcessStdout Nothing menv "ldd" [executablePath] + return $ + case elddOut of + Left _ -> StandardGHC + Right lddOut -> + if hasLineWithFirstWord "libgmp.so.3" lddOut + then Gmp4 + else StandardGHC + where + hasLineWithFirstWord w = + elem (Just w) . + map (headMay . T.words) . T.lines . decodeUtf8With lenientDecode +getDefaultGHCVariant _ _ = return StandardGHC + -- | 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 @@ -200,6 +233,7 @@ instance HasStackRoot MiniConfig instance HasHttpManager MiniConfig where getHttpManager (MiniConfig man _) = man instance HasPlatform MiniConfig +instance HasGHCVariant MiniConfig -- | Load the configuration, using current directory, environment variables, -- and defaults as necessary. diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index f40021f65b..0799e4536e 100644 --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -207,13 +207,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 @@ -239,6 +240,11 @@ configOptsParser docker = <> metavar "OS" <> help "Operating system, e.g. linux, windows" )) + <*> optional (strOption + ( long "ghc-variant" + <> metavar "VARIANT" + <> help "Specialized GHC variant, e.g. integersimple" + )) <*> optional (option auto ( long "jobs" <> short 'j' diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index 491d8fb2e3..1ef25e82c9 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -624,7 +624,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 } diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index bdf3dcf1c6..772ee251fc 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -60,7 +60,7 @@ import Network.HTTP.Download.Verified import Path import Path.IO import Prelude hiding (concat, elem) -- Fix AMP warning -import Safe (headMay, readMay) +import Safe (readMay) import Stack.Types.Build import Stack.Config (resolvePackageEntry) import Stack.Constants (distRelativeDir) @@ -100,7 +100,7 @@ data SetupOpts = SetupOpts -- ^ Message shown to user for how to resolve the missing GHC } deriving Show -data SetupException = UnsupportedSetupCombo OS Arch +data SetupException = UnsupportedSetupCombo OS Arch GHCVariant | MissingDependencies [String] | UnknownCompilerVersion Text CompilerVersion (Set Version) | UnknownOSKey Text @@ -108,9 +108,11 @@ data SetupException = UnsupportedSetupCombo OS Arch deriving Typeable instance Exception SetupException instance Show SetupException where - show (UnsupportedSetupCombo os arch) = concat + show (UnsupportedSetupCombo os arch ghcVariant) = concat [ "I don't know how to install GHC for " - , show (os, arch) + , case ghcVariant of + StandardGHC -> show (os, arch) + _ -> show (os, arch, ghcVariant) , ", please install manually" ] show (MissingDependencies tools) = @@ -291,7 +293,7 @@ ensureGHC sopts = do Nothing | soptsInstallIfMissing sopts -> do si <- getSetupInfo' - downloadAndInstallGHC menv0 si (soptsWantedCompiler sopts) (soptsCompilerCheck sopts) + downloadAndInstallGHC si (soptsWantedCompiler sopts) (soptsCompilerCheck sopts) | otherwise -> do Platform arch _ <- asks getPlatform throwM $ CompilerVersionMismatch @@ -305,7 +307,7 @@ ensureGHC sopts = do -- Install git on windows, if necessary mgitIdent <- case configPlatform config of - Platform _ os | isWindows os && not (soptsSkipMsys sopts) -> + Platform _ Cabal.Windows | not (soptsSkipMsys sopts) -> case getInstalledTool installed $(mkPackageName "git") (const True) of Just ident -> return (Just ident) Nothing @@ -536,11 +538,11 @@ binDirs ident = do config <- asks getConfig dir <- installDir ident case (configPlatform config, packageNameString $ packageIdentifierName ident) of - (Platform _ (isWindows -> True), "ghc") -> return + (Platform _ Cabal.Windows, "ghc") -> return [ dir $(mkRelDir "bin") , dir $(mkRelDir "mingw") $(mkRelDir "bin") ] - (Platform _ (isWindows -> True), "git") -> return + (Platform _ Cabal.Windows, "git") -> return [ dir $(mkRelDir "cmd") , dir $(mkRelDir "usr") $(mkRelDir "bin") ] @@ -582,13 +584,12 @@ downloadAndInstallTool si downloadInfo name version installer = do return ident downloadAndInstallGHC :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) - => EnvOverride - -> SetupInfo + => SetupInfo -> CompilerVersion -> VersionCheck -> m PackageIdentifier -downloadAndInstallGHC menv si wanted versionCheck = do - osKey <- getOSKey menv +downloadAndInstallGHC si wanted versionCheck = do + osKey <- getOSKey pairs <- case Map.lookup osKey $ siGHCs si of Nothing -> throwM $ UnknownOSKey osKey @@ -604,39 +605,32 @@ downloadAndInstallGHC menv si wanted versionCheck = do platform <- asks $ configPlatform . getConfig let installer = case platform of - Platform _ os | isWindows os -> installGHCWindows + Platform _ Cabal.Windows -> installGHCWindows _ -> installGHCPosix downloadAndInstallTool si downloadInfo $(mkPackageName "ghc") selectedVersion installer getOSKey :: (MonadReader env m, MonadThrow m, HasConfig env, MonadLogger m, MonadIO m, MonadCatch m, MonadBaseControl IO m) - => EnvOverride -> m Text -getOSKey menv = do - platform <- asks $ configPlatform . getConfig - case platform of - Platform I386 Cabal.Linux -> ("linux32" <>) <$> getLinuxSuffix - Platform X86_64 Cabal.Linux -> ("linux64" <>) <$> getLinuxSuffix - Platform I386 Cabal.OSX -> return "macosx" - Platform X86_64 Cabal.OSX -> return "macosx" - Platform I386 Cabal.FreeBSD -> return "freebsd32" - Platform X86_64 Cabal.FreeBSD -> return "freebsd64" - Platform I386 Cabal.OpenBSD -> return "openbsd32" - Platform X86_64 Cabal.OpenBSD -> return "openbsd64" - Platform I386 Cabal.Windows -> return "windows32" - Platform X86_64 Cabal.Windows -> return "windows64" - - Platform I386 (Cabal.OtherOS "windowsintegersimple") -> return "windowsintegersimple32" - Platform X86_64 (Cabal.OtherOS "windowsintegersimple") -> return "windowsintegersimple64" - - Platform arch os -> throwM $ UnsupportedSetupCombo os arch - where - getLinuxSuffix = do - executablePath <- liftIO getExecutablePath - elddOut <- tryProcessStdout Nothing menv "ldd" [executablePath] - return $ case elddOut of - Left _ -> "" - Right lddOut -> if hasLineWithFirstWord "libgmp.so.3" lddOut then "-gmp4" else "" - hasLineWithFirstWord w = - elem (Just w) . map (headMay . T.words) . T.lines . T.decodeUtf8With T.lenientDecode + => m Text +getOSKey = do + platform <- asks getPlatform + ghcVariant <- asks getGHCVariant + case (platform, ghcVariant) of + (Platform I386 Cabal.Linux, Gmp4) -> return "linux32-gmp4" + (Platform X86_64 Cabal.Linux, Gmp4) -> return "linux64-gmp4" + (Platform I386 Cabal.Linux, StandardGHC) -> return "linux32" + (Platform X86_64 Cabal.Linux, StandardGHC) -> return "linux64" + (Platform I386 Cabal.OSX, StandardGHC) -> return "macosx" + (Platform X86_64 Cabal.OSX, StandardGHC) -> return "macosx" + (Platform I386 Cabal.FreeBSD, StandardGHC) -> return "freebsd32" + (Platform X86_64 Cabal.FreeBSD, StandardGHC) -> return "freebsd64" + (Platform I386 Cabal.OpenBSD, StandardGHC) -> return "openbsd32" + (Platform X86_64 Cabal.OpenBSD, StandardGHC) -> return "openbsd64" + (Platform I386 Cabal.Windows, IntegerSimple) -> return "windowsintegersimple32" + (Platform X86_64 Cabal.Windows, IntegerSimple) -> return "windowsintegersimple64" + (Platform I386 Cabal.Windows, StandardGHC) -> return "windows32" + (Platform X86_64 Cabal.Windows, StandardGHC) -> return "windows64" + + (Platform arch os, _) -> throwM $ UnsupportedSetupCombo os arch ghcVariant downloadFromInfo :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) => DownloadInfo diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index 83dac4db17..3d847becaa 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -22,7 +22,6 @@ module Stack.Types.BuildPlan , MiniPackageInfo (..) , renderSnapName , parseSnapName - , isWindows ) where import Control.Applicative @@ -400,9 +399,3 @@ data MiniPackageInfo = MiniPackageInfo instance Binary MiniPackageInfo instance NFData MiniPackageInfo where rnf = genericRnf - - -isWindows :: OS -> Bool -isWindows Windows = True -isWindows (OtherOS "windowsintegersimple") = True -isWindows _ = False diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 3d4932e1a0..c4e9a69779 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -73,6 +74,8 @@ data Config = -- console ,configPlatform :: !Platform -- ^ The platform we're building for, used in many directory names + ,configGHCVariant :: !GHCVariant + -- ^ The variant of GHC we're using ,configLatestSnapshotUrl :: !Text -- ^ URL for a JSON file containing information on the latest -- snapshots available. @@ -278,6 +281,7 @@ instance HasBuildConfig EnvConfig where getBuildConfig = envConfigBuildConfig instance HasConfig EnvConfig instance HasPlatform EnvConfig +instance HasGHCVariant EnvConfig instance HasStackRoot EnvConfig class HasBuildConfig r => HasEnvConfig r where getEnvConfig :: r -> EnvConfig @@ -453,14 +457,24 @@ class HasPlatform env where instance HasPlatform Platform where getPlatform = id +-- | Class for environment values which have a GHCVariant +class HasGHCVariant env where + getGHCVariant :: env -> GHCVariant + default getGHCVariant :: HasConfig env => env -> GHCVariant + getGHCVariant = configGHCVariant . getConfig + {-# INLINE getGHCVariant #-} +instance HasGHCVariant GHCVariant where + getGHCVariant = id + -- | Class for environment values that can provide a 'Config'. -class (HasStackRoot env, HasPlatform env) => HasConfig env where +class (HasStackRoot env, HasPlatform env, HasGHCVariant env) => HasConfig env where getConfig :: env -> Config default getConfig :: HasBuildConfig env => env -> Config getConfig = bcConfig . getBuildConfig {-# INLINE getConfig #-} instance HasStackRoot Config instance HasPlatform Config +instance HasGHCVariant Config instance HasConfig Config where getConfig = id {-# INLINE getConfig #-} @@ -470,6 +484,7 @@ class HasConfig env => HasBuildConfig env where getBuildConfig :: env -> BuildConfig instance HasStackRoot BuildConfig instance HasPlatform BuildConfig +instance HasGHCVariant BuildConfig instance HasConfig BuildConfig instance HasBuildConfig BuildConfig where getBuildConfig = id @@ -505,6 +520,8 @@ data ConfigMonoid = -- ^ Used for overriding the platform ,configMonoidArch :: !(Maybe String) -- ^ Used for overriding the platform + ,configMonoidGHCVariant :: !(Maybe String) + -- ^ Used for overriding the GHC variant ,configMonoidJobs :: !(Maybe Int) -- ^ See: 'configJobs' ,configMonoidExtraIncludeDirs :: !(Set Text) @@ -542,6 +559,7 @@ instance Monoid ConfigMonoid where , configMonoidRequireStackVersion = anyVersion , configMonoidOS = Nothing , configMonoidArch = Nothing + , configMonoidGHCVariant = Nothing , configMonoidJobs = Nothing , configMonoidExtraIncludeDirs = Set.empty , configMonoidExtraLibDirs = Set.empty @@ -568,6 +586,7 @@ instance Monoid ConfigMonoid where (configMonoidRequireStackVersion r) , configMonoidOS = configMonoidOS l <|> configMonoidOS r , configMonoidArch = configMonoidArch l <|> configMonoidArch r + , configMonoidGHCVariant = configMonoidGHCVariant l <|> configMonoidGHCVariant r , configMonoidJobs = configMonoidJobs l <|> configMonoidJobs r , configMonoidExtraIncludeDirs = Set.union (configMonoidExtraIncludeDirs l) (configMonoidExtraIncludeDirs r) , configMonoidExtraLibDirs = Set.union (configMonoidExtraLibDirs l) (configMonoidExtraLibDirs r) @@ -603,6 +622,7 @@ parseConfigMonoidJSON obj = do ..!= VersionRangeJSON anyVersion configMonoidOS <- obj ..:? "os" configMonoidArch <- obj ..:? "arch" + configMonoidGHCVariant <- obj ..:? "ghc-variant" configMonoidJobs <- obj ..:? "jobs" configMonoidExtraIncludeDirs <- obj ..:? "extra-include-dirs" ..!= Set.empty configMonoidExtraLibDirs <- obj ..:? "extra-lib-dirs" ..!= Set.empty @@ -767,8 +787,18 @@ configInstalledCache :: (HasBuildConfig env, MonadReader env m) => m (Path Abs F configInstalledCache = liftM ( $(mkRelFile "installed-cache.bin")) configProjectWorkDir -- | Relative directory for the platform identifier -platformRelDir :: (MonadReader env m, HasPlatform env, MonadThrow m) => m (Path Rel Dir) -platformRelDir = asks getPlatform >>= parseRelDir . Distribution.Text.display +platformRelDir + :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadThrow m) + => m (Path Rel Dir) +platformRelDir = do + platform <- asks getPlatform + ghcVariant <- asks getGHCVariant + parseRelDir $ + concat + [ Distribution.Text.display platform + , case ghcVariant of + StandardGHC -> "" + _ -> "-" ++ renderGHCVariant ghcVariant] -- | Path to .shake files. configShakeFilesDir :: (MonadReader env m, HasBuildConfig env) => m (Path Abs Dir) @@ -829,7 +859,7 @@ flagCacheLocal = do return $ root $(mkRelDir "flag-cache") -- | Where to store mini build plan caches -configMiniBuildPlanCache :: (MonadThrow m, MonadReader env m, HasStackRoot env, HasPlatform env) +configMiniBuildPlanCache :: (MonadThrow m, MonadReader env m, HasConfig env) => SnapName -> m (Path Abs File) configMiniBuildPlanCache name = do @@ -868,11 +898,15 @@ extraBinDirs = do getMinimalEnvOverride :: (MonadReader env m, HasConfig env, MonadIO m) => m EnvOverride getMinimalEnvOverride = do config <- asks getConfig - liftIO $ configEnvOverride config EnvSettings - { esIncludeLocals = False - , esIncludeGhcPackagePath = False - , esStackExe = False - } + liftIO $ configEnvOverride config minimalEnvSettings + +minimalEnvSettings :: EnvSettings +minimalEnvSettings = + EnvSettings + { esIncludeLocals = False + , esIncludeGhcPackagePath = False + , esStackExe = False + } getWhichCompiler :: (MonadReader env m, HasEnvConfig env) => m WhichCompiler getWhichCompiler = asks (whichCompiler . envConfigCompilerVersion . getEnvConfig) @@ -939,3 +973,26 @@ instance FromJSON SCM where instance ToJSON SCM where toJSON Git = toJSON ("git" :: Text) + +-- | Specialized bariant of GHC (e.g. libgmp4 or integer-simple) +data GHCVariant + = StandardGHC -- ^ Standard bindist + | Gmp4 -- ^ Bindist that supports libgmp4 (centos66) + | IntegerSimple -- ^ Bindist that uses integer-simple + | OtherGHC String -- ^ Other bindists. + deriving (Eq,Ord,Show) + +-- | Render a GHC variant to a String. +renderGHCVariant :: GHCVariant -> String +renderGHCVariant StandardGHC = "standard" +renderGHCVariant Gmp4 = "gmp4" +renderGHCVariant IntegerSimple = "integersimple" +renderGHCVariant (OtherGHC other) = other + +-- | Parse GHC variant from a String. +parseGHCVariant :: String -> GHCVariant +parseGHCVariant s = + if | s == "standard" -> StandardGHC + | s == "gmp4" -> Gmp4 + | s == "integersimple" -> IntegerSimple + | otherwise -> OtherGHC s diff --git a/src/Stack/Types/Internal.hs b/src/Stack/Types/Internal.hs index a08fb6d15b..ff9fd3047b 100644 --- a/src/Stack/Types/Internal.hs +++ b/src/Stack/Types/Internal.hs @@ -21,6 +21,8 @@ instance HasStackRoot config => HasStackRoot (Env config) where getStackRoot = getStackRoot . envConfig instance HasPlatform config => HasPlatform (Env config) where getPlatform = getPlatform . envConfig +instance HasGHCVariant config => HasGHCVariant (Env config) where + getGHCVariant = getGHCVariant . envConfig instance HasConfig config => HasConfig (Env config) where getConfig = getConfig . envConfig instance HasBuildConfig config => HasBuildConfig (Env config) where diff --git a/src/System/Process/Read.hs b/src/System/Process/Read.hs index 370b8b448a..03d8bfac80 100644 --- a/src/System/Process/Read.hs +++ b/src/System/Process/Read.hs @@ -59,7 +59,7 @@ import Data.Text.Encoding.Error (lenientDecode) import qualified Data.Text.Lazy.Encoding as LT import qualified Data.Text.Lazy as LT import Data.Typeable (Typeable) -import Distribution.System (OS (Windows, OtherOS), Platform (Platform)) +import Distribution.System (OS (Windows), Platform (Platform)) import Path (Path, Abs, Dir, toFilePath, File, parseAbsFile) import Path.IO (createTree) import Prelude -- Fix AMP warning @@ -111,7 +111,6 @@ mkEnvOverride platform tm' = do isWindows = case platform of Platform _ Windows -> True - Platform _ (OtherOS "windowsintegersimple") -> True _ -> False -- | Helper conversion function From df5876647ab3624923d95282bbc8d3ab296b44b1 Mon Sep 17 00:00:00 2001 From: Emanuel Borsboom Date: Sat, 22 Aug 2015 12:01:38 -0700 Subject: [PATCH 2/7] Move GHC variant autodetection to BuildConfig (#530) --- src/Stack/Build/ConstructPlan.hs | 1 + src/Stack/BuildPlan.hs | 4 +- src/Stack/Config.hs | 73 ++++++++++++++++++++------------ src/Stack/Init.hs | 6 +-- src/Stack/Setup.hs | 72 +++++++++++++++---------------- src/Stack/Types/Config.hs | 34 ++++++++++----- src/Stack/Types/Internal.hs | 2 + src/main/Main.hs | 15 ++++--- 8 files changed, 122 insertions(+), 85 deletions(-) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index e9f2edd464..719f49c444 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -109,6 +109,7 @@ data Ctx = Ctx instance HasStackRoot Ctx instance HasPlatform Ctx instance HasGHCVariant Ctx +instance HasLocalPrograms Ctx instance HasConfig Ctx instance HasBuildConfig Ctx where getBuildConfig = getBuildConfig . getEnvConfig diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 903dac6c81..c05bbecd3b 100644 --- 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 index 49c47d58b8..d5662ad35d 100644 --- 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 @@ -141,6 +143,8 @@ configFromConfigMonoid configStackRoot mproject configMonoid@ConfigMonoid{..} = $ configMonoidOS >>= Distribution.Text.simpleParse configPlatform = Platform arch os + configGHCVariant0 = fmap parseGHCVariant configMonoidGHCVariant + configRequireStackVersion = simplifyVersionRange configMonoidRequireStackVersion configConfigMonoid = configMonoid @@ -156,19 +160,6 @@ configFromConfigMonoid configStackRoot mproject configMonoid@ConfigMonoid{..} = $ map (T.pack *** T.pack) rawEnv let configEnvOverride _ = return origEnv - configGHCVariant <- case parseGHCVariant <$> configMonoidGHCVariant of - Just ghcVariant -> return ghcVariant - Nothing -> getDefaultGHCVariant origEnv os - - platform <- runReaderT platformRelDir (PlatformGHCVariant configPlatform configGHCVariant) - - configLocalPrograms <- - case configPlatform of - Platform _ Windows -> do - progsDir <- getWindowsProgsDir configStackRoot origEnv - return $ progsDir $(mkRelDir stackProgName) platform - _ -> return $ configStackRoot $(mkRelDir "programs") platform - configLocalBin <- case configMonoidLocalBinPath of Nothing -> do @@ -195,8 +186,8 @@ configFromConfigMonoid configStackRoot mproject configMonoid@ConfigMonoid{..} = -- | Get the default 'GHCVariant'. On older Linux systems with libgmp4, returns 'Gmp4'. getDefaultGHCVariant :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadLogger m) - => EnvOverride -> OS -> m GHCVariant -getDefaultGHCVariant menv Linux = do + => EnvOverride -> Platform -> m GHCVariant +getDefaultGHCVariant menv (Platform _ Linux) = do executablePath <- liftIO getExecutablePath elddOut <- tryProcessStdout Nothing menv "ldd" [executablePath] return $ @@ -226,14 +217,44 @@ 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 (Path Abs Dir) 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 +instance HasGHCVariant MiniConfig where + getGHCVariant (MiniConfig _ v _ _) = v +instance HasLocalPrograms MiniConfig where + getLocalPrograms (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) + platformDir <- + runReaderT + platformRelDir + (PlatformGHCVariant (configPlatform config) ghcVariant) + localPrograms <- + case configPlatform config of + Platform _ Windows -> do + progsDir <- getWindowsProgsDir (configStackRoot config) menv + return $ progsDir $(mkRelDir stackProgName) platformDir + _ -> + return $ + (configStackRoot config) $(mkRelDir "programs") + platformDir + return (MiniConfig manager ghcVariant localPrograms config) -- | Load the configuration, using current directory, environment variables, -- and defaults as necessary. @@ -269,7 +290,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 @@ -317,10 +339,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 <- @@ -342,6 +361,8 @@ loadBuildConfig mproject config stackRoot mresolver = do , bcStackYaml = stackYamlFP , bcFlags = projectFlags project , bcImplicitGlobal = isNothing mproject + , bcGHCVariant = getGHCVariant miniConfig + , bcLocalPrograms = getLocalPrograms miniConfig } -- | Resolve a PackageEntry into a list of paths, downloading and cloning as diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index b83ba76b33..077bc91c26 100644 --- 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 () @@ -125,7 +125,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 @@ -162,7 +162,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/Setup.hs b/src/Stack/Setup.hs index 405d65e12a..ca63d62761 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -137,7 +137,7 @@ instance Show SetupException where ] -- | Modify the environment variables (like PATH) appropriately, possibly doing installation too -setupEnv :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasBuildConfig env, HasHttpManager env, MonadBaseControl IO m) +setupEnv :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasBuildConfig env, HasHttpManager env, HasGHCVariant env, HasLocalPrograms env, MonadBaseControl IO m) => Maybe Text -- ^ Message to give user when necessary GHC is not available -> m EnvConfig setupEnv mResolveMissingGHC = do @@ -251,7 +251,7 @@ setupEnv mResolveMissingGHC = do } -- | Ensure GHC is installed and provide the PATHs to add if necessary -ensureGHC :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) +ensureGHC :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, HasPlatform env, HasGHCVariant env, HasLocalPrograms env, MonadBaseControl IO m) => SetupOpts -> m (Maybe [FilePath]) ensureGHC sopts = do @@ -288,8 +288,7 @@ ensureGHC sopts = do then do getSetupInfo' <- runOnce (getSetupInfo =<< asks getHttpManager) - config <- asks getConfig - installed <- runReaderT listInstalled config + installed <- listInstalled -- Install GHC ghcIdent <- case getInstalledTool installed $(mkPackageName "ghc") (isWanted . GhcVersion) of @@ -310,7 +309,8 @@ ensureGHC sopts = do $ soptsResolveMissingGHC sopts) -- Install git on windows, if necessary - mgitIdent <- case configPlatform config of + platform <- asks getPlatform + mgitIdent <- case platform of Platform _ Cabal.Windows | not (soptsSkipMsys sopts) -> case getInstalledTool installed $(mkPackageName "git") (const True) of Just ident -> return (Just ident) @@ -325,7 +325,7 @@ ensureGHC sopts = do _ -> return Nothing let idents = catMaybes [Just ghcIdent, mgitIdent] - paths <- runReaderT (mapM binDirs idents) config + paths <- mapM binDirs idents return $ Just $ map toFilePathNoTrailingSlash $ concat paths else return Nothing @@ -498,26 +498,26 @@ getSetupInfo manager = do where req = "https://raw.githubusercontent.com/fpco/stackage-content/master/stack/stack-setup-2.yaml" -markInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m) +markInstalled :: (MonadIO m, MonadReader env m, HasLocalPrograms env, MonadThrow m) => PackageIdentifier -- ^ e.g., ghc-7.8.4, git-2.4.0.1 -> m () markInstalled ident = do - dir <- asks $ configLocalPrograms . getConfig + dir <- asks getLocalPrograms fpRel <- parseRelFile $ packageIdentifierString ident ++ ".installed" liftIO $ writeFile (toFilePath $ dir fpRel) "installed" -unmarkInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m) +unmarkInstalled :: (MonadIO m, MonadReader env m, HasLocalPrograms env, MonadThrow m) => PackageIdentifier -> m () unmarkInstalled ident = do - dir <- asks $ configLocalPrograms . getConfig + dir <- asks getLocalPrograms fpRel <- parseRelFile $ packageIdentifierString ident ++ ".installed" removeFileIfExists $ dir fpRel -listInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m) +listInstalled :: (MonadIO m, MonadReader env m, HasLocalPrograms env, MonadThrow m) => m [PackageIdentifier] listInstalled = do - dir <- asks $ configLocalPrograms . getConfig + dir <- asks getLocalPrograms createTree dir (_, files) <- listDirectory dir return $ mapMaybe toIdent files @@ -526,22 +526,22 @@ listInstalled = do x <- T.stripSuffix ".installed" $ T.pack $ toFilePath $ filename fp parsePackageIdentifierFromString $ T.unpack x -installDir :: (MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m) +installDir :: (MonadReader env m, HasLocalPrograms env, MonadThrow m, MonadLogger m) => PackageIdentifier -> m (Path Abs Dir) installDir ident = do - config <- asks getConfig + localPrograms <- asks getLocalPrograms reldir <- parseRelDir $ packageIdentifierString ident - return $ configLocalPrograms config reldir + return $ localPrograms reldir -- | Binary directories for the given installed package -binDirs :: (MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m) +binDirs :: (MonadReader env m, HasPlatform env, HasLocalPrograms env, MonadThrow m, MonadLogger m) => PackageIdentifier -> m [Path Abs Dir] binDirs ident = do - config <- asks getConfig + platform <- asks getPlatform dir <- installDir ident - case (configPlatform config, packageNameString $ packageIdentifierName ident) of + case (platform, packageNameString $ packageIdentifierName ident) of (Platform _ Cabal.Windows, "ghc") -> return [ dir $(mkRelDir "bin") , dir $(mkRelDir "mingw") $(mkRelDir "bin") @@ -571,7 +571,7 @@ getInstalledTool installed name goodVersion = packageIdentifierName pi' == name && goodVersion (packageIdentifierVersion pi') -downloadAndInstallTool :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) +downloadAndInstallTool :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasLocalPrograms env, HasHttpManager env, MonadBaseControl IO m) => SetupInfo -> DownloadInfo -> PackageName @@ -587,7 +587,7 @@ downloadAndInstallTool si downloadInfo name version installer = do markInstalled ident return ident -downloadAndInstallGHC :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) +downloadAndInstallGHC :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasPlatform env, HasGHCVariant env, HasLocalPrograms env, HasHttpManager env, MonadBaseControl IO m) => SetupInfo -> CompilerVersion -> VersionCheck @@ -606,14 +606,14 @@ downloadAndInstallGHC si wanted versionCheck = do case mpair of Just pair -> return pair Nothing -> throwM $ UnknownCompilerVersion osKey wanted (Map.keysSet pairs) - platform <- asks $ configPlatform . getConfig + platform <- asks getPlatform let installer = case platform of Platform _ Cabal.Windows -> installGHCWindows _ -> installGHCPosix downloadAndInstallTool si downloadInfo $(mkPackageName "ghc") selectedVersion installer -getOSKey :: (MonadReader env m, MonadThrow m, HasConfig env, MonadLogger m, MonadIO m, MonadCatch m, MonadBaseControl IO m) +getOSKey :: (MonadReader env m, MonadThrow m, HasPlatform env, HasGHCVariant env, MonadLogger m, MonadIO m, MonadCatch m, MonadBaseControl IO m) => m Text getOSKey = do platform <- asks getPlatform @@ -636,12 +636,12 @@ getOSKey = do (Platform arch os, _) -> throwM $ UnsupportedSetupCombo os arch ghcVariant -downloadFromInfo :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) +downloadFromInfo :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasLocalPrograms env, HasHttpManager env, MonadBaseControl IO m) => DownloadInfo -> PackageIdentifier -> m (Path Abs File, ArchiveType) downloadFromInfo downloadInfo ident = do - config <- asks getConfig + localPrograms <- asks getLocalPrograms at <- case extension of ".tar.xz" -> return TarXz @@ -649,7 +649,7 @@ downloadFromInfo downloadInfo ident = do ".7z.exe" -> return SevenZ _ -> error $ "Unknown extension: " ++ extension relfile <- parseRelFile $ packageIdentifierString ident ++ extension - let path = configLocalPrograms config relfile + let path = localPrograms relfile chattyDownload (packageIdentifierText ident) downloadInfo path return (path, at) where @@ -746,7 +746,7 @@ instance Alternative CheckDependency where Left _ -> y menv Right x' -> return $ Right x' -installGHCWindows :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) +installGHCWindows :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasHttpManager env, HasLocalPrograms env, MonadBaseControl IO m) => SetupInfo -> Path Abs File -> ArchiveType @@ -764,8 +764,7 @@ installGHCWindows si archiveFile archiveType destDir _ = do Nothing -> error $ "Invalid GHC filename: " ++ show archiveFile Just x -> parseAbsFile $ T.unpack x - config <- asks getConfig - run7z <- setup7z si config + run7z <- setup7z si run7z (parent archiveFile) archiveFile run7z (parent archiveFile) tarFile @@ -779,7 +778,7 @@ installGHCWindows si archiveFile archiveType destDir _ = do $logInfo $ "GHC installed to " <> T.pack (toFilePath destDir) -installGitWindows :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) +installGitWindows :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasHttpManager env, HasLocalPrograms env, MonadBaseControl IO m) => SetupInfo -> Path Abs File -> ArchiveType @@ -791,18 +790,19 @@ installGitWindows si archiveFile archiveType destDir _ = do SevenZ -> return () _ -> error $ "Git on Windows must be a 7z archive" - config <- asks getConfig - run7z <- setup7z si config + run7z <- setup7z si run7z destDir archiveFile -- | Download 7z as necessary, and get a function for unpacking things. -- -- Returned function takes an unpack directory and archive. -setup7z :: (MonadReader env m, HasHttpManager env, MonadThrow m, MonadIO m, MonadIO n, MonadLogger m, MonadBaseControl IO m) +setup7z :: (MonadReader env m, HasHttpManager env, HasLocalPrograms env, MonadThrow m, MonadIO m, MonadIO n, MonadLogger m, MonadBaseControl IO m) => SetupInfo - -> Config -> m (Path Abs Dir -> Path Abs File -> n ()) -setup7z si config = do +setup7z si = do + dir <- asks getLocalPrograms + let exe = dir $(mkRelFile "7z.exe") + dll = dir $(mkRelFile "7z.dll") chattyDownload "7z.dll" (siSevenzDll si) dll chattyDownload "7z.exe" (siSevenzExe si) exe return $ \outdir archive -> liftIO $ do @@ -814,10 +814,6 @@ setup7z si config = do ] when (ec /= ExitSuccess) $ error $ "Problem while decompressing " ++ toFilePath archive - where - dir = configLocalPrograms config $(mkRelDir "7z") - exe = dir $(mkRelFile "7z.exe") - dll = dir $(mkRelFile "7z.dll") chattyDownload :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m, MonadThrow m, MonadBaseControl IO m) => Text -- ^ label diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 8db36fe229..6adb9025d6 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -65,8 +65,6 @@ data Config = ,configDocker :: !DockerOpts ,configEnvOverride :: !(EnvSettings -> IO EnvOverride) -- ^ Environment variables to be passed to external tools - ,configLocalPrograms :: !(Path Abs Dir) - -- ^ Path containing local installations (mainly GHC) ,configConnectionCount :: !Int -- ^ How many concurrent connections are allowed when downloading ,configHideTHLoading :: !Bool @@ -74,8 +72,10 @@ data Config = -- console ,configPlatform :: !Platform -- ^ The platform we're building for, used in many directory names - ,configGHCVariant :: !GHCVariant - -- ^ The variant of GHC we're using + ,configGHCVariant0 :: !(Maybe GHCVariant) + -- ^ The variant of GHC requested by the user. + -- In most cases, use 'BuildConfig' or 'MiniConfig's version instead, + -- which will have an auto-detected default. ,configLatestSnapshotUrl :: !Text -- ^ URL for a JSON file containing information on the latest -- snapshots available. @@ -263,6 +263,10 @@ data BuildConfig = BuildConfig , bcImplicitGlobal :: !Bool -- ^ Are we loading from the implicit global stack.yaml? This is useful -- for providing better error messages. + , bcGHCVariant :: !GHCVariant + -- ^ The variant of GHC used to select a GHC bindist. + , bcLocalPrograms :: !(Path Abs Dir) + -- ^ Path containing local installations (mainly GHC) } -- | Directory containing the project's stack.yaml file @@ -284,8 +288,9 @@ instance HasBuildConfig EnvConfig where instance HasConfig EnvConfig instance HasPlatform EnvConfig instance HasGHCVariant EnvConfig +instance HasLocalPrograms EnvConfig instance HasStackRoot EnvConfig -class HasBuildConfig r => HasEnvConfig r where +class (HasBuildConfig r, HasGHCVariant r) => HasEnvConfig r where getEnvConfig :: r -> EnvConfig instance HasEnvConfig EnvConfig where getEnvConfig = id @@ -462,21 +467,27 @@ instance HasPlatform Platform where -- | Class for environment values which have a GHCVariant class HasGHCVariant env where getGHCVariant :: env -> GHCVariant - default getGHCVariant :: HasConfig env => env -> GHCVariant - getGHCVariant = configGHCVariant . getConfig + default getGHCVariant :: HasBuildConfig env => env -> GHCVariant + getGHCVariant = bcGHCVariant . getBuildConfig {-# INLINE getGHCVariant #-} instance HasGHCVariant GHCVariant where getGHCVariant = id +-- | Class for environment values which have a local programs path. +class HasLocalPrograms env where + getLocalPrograms :: env -> Path Abs Dir + default getLocalPrograms :: HasBuildConfig env => env -> Path Abs Dir + getLocalPrograms = bcLocalPrograms . getBuildConfig + {-# INLINE getLocalPrograms #-} + -- | Class for environment values that can provide a 'Config'. -class (HasStackRoot env, HasPlatform env, HasGHCVariant env) => HasConfig env where +class (HasStackRoot env, HasPlatform env) => HasConfig env where getConfig :: env -> Config default getConfig :: HasBuildConfig env => env -> Config getConfig = bcConfig . getBuildConfig {-# INLINE getConfig #-} instance HasStackRoot Config instance HasPlatform Config -instance HasGHCVariant Config instance HasConfig Config where getConfig = id {-# INLINE getConfig #-} @@ -487,6 +498,7 @@ class HasConfig env => HasBuildConfig env where instance HasStackRoot BuildConfig instance HasPlatform BuildConfig instance HasGHCVariant BuildConfig +instance HasLocalPrograms BuildConfig instance HasConfig BuildConfig instance HasBuildConfig BuildConfig where getBuildConfig = id @@ -811,7 +823,7 @@ configLocalUnpackDir :: (MonadReader env m, HasBuildConfig env) => m (Path Abs D configLocalUnpackDir = liftM ( $(mkRelDir "unpacked")) configProjectWorkDir -- | Directory containing snapshots -snapshotsDir :: (MonadReader env m, HasConfig env, MonadThrow m) => m (Path Abs Dir) +snapshotsDir :: (MonadReader env m, HasConfig env, HasGHCVariant env, MonadThrow m) => m (Path Abs Dir) snapshotsDir = do config <- asks getConfig platform <- platformRelDir @@ -861,7 +873,7 @@ flagCacheLocal = do return $ root $(mkRelDir "flag-cache") -- | Where to store mini build plan caches -configMiniBuildPlanCache :: (MonadThrow m, MonadReader env m, HasConfig env) +configMiniBuildPlanCache :: (MonadThrow m, MonadReader env m, HasConfig env, HasGHCVariant env) => SnapName -> m (Path Abs File) configMiniBuildPlanCache name = do diff --git a/src/Stack/Types/Internal.hs b/src/Stack/Types/Internal.hs index ff9fd3047b..bd3c7484c9 100644 --- a/src/Stack/Types/Internal.hs +++ b/src/Stack/Types/Internal.hs @@ -23,6 +23,8 @@ instance HasPlatform config => HasPlatform (Env config) where getPlatform = getPlatform . envConfig instance HasGHCVariant config => HasGHCVariant (Env config) where getGHCVariant = getGHCVariant . envConfig +instance HasLocalPrograms config => HasLocalPrograms (Env config) where + getLocalPrograms = getLocalPrograms . envConfig instance HasConfig config => HasConfig (Env config) where getConfig = getConfig . envConfig instance HasBuildConfig config => HasBuildConfig (Env config) where diff --git a/src/main/Main.hs b/src/main/Main.hs index 7a62205b1f..8e8da84b95 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -16,7 +16,7 @@ import Control.Monad hiding (mapM, forM) import qualified Control.Monad.Catch as Catch import Control.Monad.IO.Class import Control.Monad.Logger -import Control.Monad.Reader (ask, asks) +import Control.Monad.Reader (ask, asks, runReaderT) import Control.Monad.Trans.Control (MonadBaseControl) import Data.Attoparsec.Args (withInterpreterArgs) import qualified Data.ByteString.Lazy as L @@ -432,7 +432,7 @@ paths = , ( "Installed GHCs (unpacked and archives)" , "ghc-paths" , \pi -> - T.pack (toFilePathNoTrailing (configLocalPrograms (bcConfig (piBuildConfig pi))))) + T.pack (toFilePathNoTrailing (bcLocalPrograms (piBuildConfig pi)))) , ( "Local bin path where stack installs executables" , "local-bin-path" , \pi -> @@ -522,7 +522,8 @@ setupCmd SetupCmdOpts{..} go@GlobalOpts{..} = do , configCompilerCheck (lcConfig lc) , Just $ bcStackYaml bc ) - mpaths <- runStackTGlobal manager (lcConfig lc) go $ + miniConfig <- loadMiniConfig (lcConfig lc) + mpaths <- runStackTGlobal manager miniConfig go $ ensureGHC SetupOpts { soptsInstallIfMissing = True , soptsUseSystem = @@ -879,14 +880,18 @@ initCmd :: InitOpts -> GlobalOpts -> IO () initCmd initOpts go = withConfigAndLock go $ do pwd <- getWorkingDir - initProject pwd initOpts + config <- asks getConfig + miniConfig <- loadMiniConfig config + runReaderT (initProject pwd initOpts) miniConfig -- | Create a project directory structure and initialize the stack config. newCmd :: (NewOpts,InitOpts) -> GlobalOpts -> IO () newCmd (newOpts,initOpts) go@GlobalOpts{..} = withConfigAndLock go $ do dir <- new newOpts - initProject dir initOpts + config <- asks getConfig + miniConfig <- loadMiniConfig config + runReaderT (initProject dir initOpts) miniConfig -- | List the available templates. templatesCmd :: () -> GlobalOpts -> IO () From 29d91f3caecfcf5628b0160fbecc9c4e6806675f Mon Sep 17 00:00:00 2001 From: Emanuel Borsboom Date: Sat, 22 Aug 2015 12:21:54 -0700 Subject: [PATCH 3/7] --ghc-variant implies --no-system-ghc (#530) --- src/Stack/Config.hs | 6 +++--- src/Stack/Options.hs | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index d5662ad35d..2a7d21ef6b 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -126,7 +126,9 @@ configFromConfigMonoid configStackRoot mproject configMonoid@ConfigMonoid{..} = }] configMonoidPackageIndices - configSystemGHC = fromMaybe True configMonoidSystemGHC + configGHCVariant0 = fmap parseGHCVariant configMonoidGHCVariant + + configSystemGHC = fromMaybe (isNothing configGHCVariant0) configMonoidSystemGHC configInstallGHC = fromMaybe False configMonoidInstallGHC configSkipGHCCheck = fromMaybe False configMonoidSkipGHCCheck configSkipMsys = fromMaybe False configMonoidSkipMsys @@ -143,8 +145,6 @@ configFromConfigMonoid configStackRoot mproject configMonoid@ConfigMonoid{..} = $ configMonoidOS >>= Distribution.Text.simpleParse configPlatform = Platform arch os - configGHCVariant0 = fmap parseGHCVariant configMonoidGHCVariant - configRequireStackVersion = simplifyVersionRange configMonoidRequireStackVersion configConfigMonoid = configMonoid diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index 4a36afa23d..6f3340c9b5 100644 --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -243,7 +243,7 @@ configOptsParser docker = <*> optional (strOption ( long "ghc-variant" <> metavar "VARIANT" - <> help "Specialized GHC variant, e.g. integersimple" + <> help "Specialized GHC variant, e.g. integersimple (implies --no-system-ghc)" )) <*> optional (option auto ( long "jobs" From 791ff37a24947e4e283235076ff14daca55dbfc2 Mon Sep 17 00:00:00 2001 From: Emanuel Borsboom Date: Sat, 22 Aug 2015 21:21:08 -0700 Subject: [PATCH 4/7] Support downloading custom GHC variant (#530) --- src/Stack/Config.hs | 12 ++-- src/Stack/Options.hs | 21 +++++-- src/Stack/Setup.hs | 114 ++++++++++++++++---------------------- src/Stack/Types/Config.hs | 81 ++++++++++++++++++++------- 4 files changed, 132 insertions(+), 96 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 2a7d21ef6b..f37d643636 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -126,7 +126,7 @@ configFromConfigMonoid configStackRoot mproject configMonoid@ConfigMonoid{..} = }] configMonoidPackageIndices - configGHCVariant0 = fmap parseGHCVariant configMonoidGHCVariant + configGHCVariant0 = configMonoidGHCVariant configSystemGHC = fromMaybe (isNothing configGHCVariant0) configMonoidSystemGHC configInstallGHC = fromMaybe False configMonoidInstallGHC @@ -183,7 +183,7 @@ configFromConfigMonoid configStackRoot mproject configMonoid@ConfigMonoid{..} = return Config {..} --- | Get the default 'GHCVariant'. On older Linux systems with libgmp4, returns 'Gmp4'. +-- | 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 @@ -192,16 +192,16 @@ getDefaultGHCVariant menv (Platform _ Linux) = do elddOut <- tryProcessStdout Nothing menv "ldd" [executablePath] return $ case elddOut of - Left _ -> StandardGHC + Left _ -> GHCStandard Right lddOut -> if hasLineWithFirstWord "libgmp.so.3" lddOut - then Gmp4 - else StandardGHC + then GHCGMP4 + else GHCStandard where hasLineWithFirstWord w = elem (Just w) . map (headMay . T.words) . T.lines . decodeUtf8With lenientDecode -getDefaultGHCVariant _ _ = return StandardGHC +getDefaultGHCVariant _ _ = return GHCStandard -- | Get the directory on Windows where we should install extra programs. For -- more information, see discussion at: diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index 6f3340c9b5..4a69bb90e4 100644 --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -240,11 +240,7 @@ configOptsParser docker = <> metavar "OS" <> help "Operating system, e.g. linux, windows" )) - <*> optional (strOption - ( long "ghc-variant" - <> metavar "VARIANT" - <> help "Specialized GHC variant, e.g. integersimple (implies --no-system-ghc)" - )) + <*> optional ghcVariantParser <*> optional (option auto ( long "jobs" <> short 'j' @@ -591,6 +587,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/Setup.hs b/src/Stack/Setup.hs index ca63d62761..9dc5d6169e 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -27,7 +27,6 @@ import Control.Monad.State (get, put, modify) import Control.Monad.Trans.Control import Crypto.Hash (SHA1(SHA1)) import Data.Aeson.Extended -import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Data.Conduit (Conduit, ($$), (=$), await, yield, awaitForever) @@ -105,13 +104,14 @@ data SetupException = UnsupportedSetupCombo OS Arch GHCVariant | UnknownCompilerVersion Text CompilerVersion (Set Version) | UnknownOSKey Text | GHCSanityCheckCompileFailed ReadProcessException (Path Abs File) + | WantedMustBeGHC deriving Typeable instance Exception SetupException instance Show SetupException where show (UnsupportedSetupCombo os arch ghcVariant) = concat [ "I don't know how to install GHC for " , case ghcVariant of - StandardGHC -> show (os, arch) + GHCStandard -> show (os, arch) _ -> show (os, arch, ghcVariant) , ", please install manually" ] @@ -135,6 +135,8 @@ instance Show SetupException where , "for more information. Exception was:\n" , show e ] + show (WantedMustBeGHC) = + "The wanted compiler must be GHC" -- | Modify the environment variables (like PATH) appropriately, possibly doing installation too setupEnv :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasBuildConfig env, HasHttpManager env, HasGHCVariant env, HasLocalPrograms env, MonadBaseControl IO m) @@ -439,32 +441,12 @@ getSystemCompiler menv wc = do (_, Nothing) -> return Nothing else return Nothing -data DownloadInfo = DownloadInfo - { downloadInfoUrl :: Text - , downloadInfoContentLength :: Int - , downloadInfoSha1 :: Maybe ByteString - } - deriving Show - data VersionedDownloadInfo = VersionedDownloadInfo { vdiVersion :: Version , vdiDownloadInfo :: DownloadInfo } deriving Show -parseDownloadInfoFromObject :: Yaml.Object -> Yaml.Parser DownloadInfo -parseDownloadInfoFromObject o = do - url <- o .: "url" - contentLength <- o .: "content-length" - sha1TextMay <- o .:? "sha1" - return DownloadInfo - { downloadInfoUrl = url - , downloadInfoContentLength = contentLength - , downloadInfoSha1 = fmap T.encodeUtf8 sha1TextMay - } - -instance FromJSON DownloadInfo where - parseJSON = withObject "DownloadInfo" parseDownloadInfoFromObject instance FromJSON VersionedDownloadInfo where parseJSON = withObject "VersionedDownloadInfo" $ \o -> do version <- o .: "version" @@ -593,19 +575,25 @@ downloadAndInstallGHC :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env -> VersionCheck -> m PackageIdentifier downloadAndInstallGHC si wanted versionCheck = do - osKey <- getOSKey - pairs <- - case Map.lookup osKey $ siGHCs si of - Nothing -> throwM $ UnknownOSKey osKey - Just pairs -> return pairs - let mpair = - listToMaybe $ - sortBy (flip (comparing fst)) $ - filter (\(v, _) -> isWantedCompiler versionCheck wanted (GhcVersion v)) (Map.toList pairs) - (selectedVersion, downloadInfo) <- - case mpair of - Just pair -> return pair - Nothing -> throwM $ UnknownCompilerVersion osKey wanted (Map.keysSet pairs) + ghcVariant <- asks getGHCVariant + (selectedVersion, downloadInfo) <- case ghcVariant of + GHCCustom _ downloadInfo -> do + case wanted of + GhcVersion version -> return (version, downloadInfo) + _ -> throwM WantedMustBeGHC + _ -> do + osKey <- getOSKey + pairs <- + case Map.lookup osKey $ siGHCs si of + Nothing -> throwM $ UnknownOSKey osKey + Just pairs -> return pairs + let mpair = + listToMaybe $ + sortBy (flip (comparing fst)) $ + filter (\(v, _) -> isWantedCompiler versionCheck wanted (GhcVersion v)) (Map.toList pairs) + case mpair of + Just pair -> return pair + Nothing -> throwM $ UnknownCompilerVersion osKey wanted (Map.keysSet pairs) platform <- asks getPlatform let installer = case platform of @@ -619,20 +607,20 @@ getOSKey = do platform <- asks getPlatform ghcVariant <- asks getGHCVariant case (platform, ghcVariant) of - (Platform I386 Cabal.Linux, Gmp4) -> return "linux32-gmp4" - (Platform X86_64 Cabal.Linux, Gmp4) -> return "linux64-gmp4" - (Platform I386 Cabal.Linux, StandardGHC) -> return "linux32" - (Platform X86_64 Cabal.Linux, StandardGHC) -> return "linux64" - (Platform I386 Cabal.OSX, StandardGHC) -> return "macosx" - (Platform X86_64 Cabal.OSX, StandardGHC) -> return "macosx" - (Platform I386 Cabal.FreeBSD, StandardGHC) -> return "freebsd32" - (Platform X86_64 Cabal.FreeBSD, StandardGHC) -> return "freebsd64" - (Platform I386 Cabal.OpenBSD, StandardGHC) -> return "openbsd32" - (Platform X86_64 Cabal.OpenBSD, StandardGHC) -> return "openbsd64" - (Platform I386 Cabal.Windows, IntegerSimple) -> return "windowsintegersimple32" - (Platform X86_64 Cabal.Windows, IntegerSimple) -> return "windowsintegersimple64" - (Platform I386 Cabal.Windows, StandardGHC) -> return "windows32" - (Platform X86_64 Cabal.Windows, StandardGHC) -> return "windows64" + (Platform I386 Cabal.Linux, GHCGMP4) -> return "linux32-gmp4" + (Platform X86_64 Cabal.Linux, GHCGMP4) -> return "linux64-gmp4" + (Platform I386 Cabal.Linux, GHCStandard) -> return "linux32" + (Platform X86_64 Cabal.Linux, GHCStandard) -> return "linux64" + (Platform I386 Cabal.OSX, GHCStandard) -> return "macosx" + (Platform X86_64 Cabal.OSX, GHCStandard) -> return "macosx" + (Platform I386 Cabal.FreeBSD, GHCStandard) -> return "freebsd32" + (Platform X86_64 Cabal.FreeBSD, GHCStandard) -> return "freebsd64" + (Platform I386 Cabal.OpenBSD, GHCStandard) -> return "openbsd32" + (Platform X86_64 Cabal.OpenBSD, GHCStandard) -> return "openbsd64" + (Platform I386 Cabal.Windows, GHCIntegerSimple) -> return "windowsintegersimple32" + (Platform X86_64 Cabal.Windows, GHCIntegerSimple) -> return "windowsintegersimple64" + (Platform I386 Cabal.Windows, GHCStandard) -> return "windows32" + (Platform X86_64 Cabal.Windows, GHCStandard) -> return "windows64" (Platform arch os, _) -> throwM $ UnsupportedSetupCombo os arch ghcVariant @@ -852,7 +840,7 @@ chattyDownload label downloadInfo path = do let dReq = DownloadRequest { drRequest = req , drHashChecks = hashChecks - , drLengthCheck = Just totalSize + , drLengthCheck = mtotalSize , drRetryPolicy = drRetryPolicyDefault } runInBase <- liftBaseWith $ \run -> return (void . run) @@ -861,7 +849,7 @@ chattyDownload label downloadInfo path = do then $logStickyDone ("Downloaded " <> label <> ".") else $logStickyDone "Already downloaded." where - totalSize = downloadInfoContentLength downloadInfo + mtotalSize = downloadInfoContentLength downloadInfo chattyDownloadProgress runInBase _ = do _ <- liftIO $ runInBase $ $logSticky $ label <> ": download has begun" @@ -873,21 +861,15 @@ chattyDownload label downloadInfo path = do modify (+ size) totalSoFar <- get liftIO $ runInBase $ $logSticky $ T.pack $ - chattyProgressWithTotal totalSoFar totalSize - - -- Note(DanBurton): Total size is now always known in this file. - -- However, printing in the case where it isn't known may still be - -- useful in other parts of the codebase. - -- So I'm just commenting out the code rather than deleting it. - - -- case mcontentLength of - -- Nothing -> chattyProgressNoTotal totalSoFar - -- Just 0 -> chattyProgressNoTotal totalSoFar - -- Just total -> chattyProgressWithTotal totalSoFar total - ---- Example: ghc: 42.13 KiB downloaded... - --chattyProgressNoTotal totalSoFar = - -- printf ("%s: " <> bytesfmt "%7.2f" totalSoFar <> " downloaded...") - -- (T.unpack label) + case mtotalSize of + Nothing -> chattyProgressNoTotal totalSoFar + Just 0 -> chattyProgressNoTotal totalSoFar + Just totalSize -> chattyProgressWithTotal totalSoFar totalSize + + -- Example: ghc: 42.13 KiB downloaded... + chattyProgressNoTotal totalSoFar = + printf ("%s: " <> bytesfmt "%7.2f" totalSoFar <> " downloaded...") + (T.unpack label) -- Example: ghc: 50.00 MiB / 100.00 MiB (50.00%) downloaded... chattyProgressWithTotal totalSoFar total = diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 6adb9025d6..6566bc5d5a 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -18,9 +18,10 @@ import Control.Monad (liftM, mzero, forM) import Control.Monad.Catch (MonadThrow, throwM) import Control.Monad.Logger (LogLevel(..)) import Control.Monad.Reader (MonadReader, ask, asks, MonadIO, liftIO) +import Data.Aeson.Types (Parser) import Data.Aeson.Extended (ToJSON, toJSON, FromJSON, parseJSON, withText, withObject, object, - (.=), (.:), (..:), (..:?), (..!=), Value(String, Object), + (.=), (.:), (.:?), (..:), (..:?), (..!=), Value(String, Object), withObjectWarnings, WarningParser, Object, jsonSubWarnings, JSONWarning, jsonSubWarningsMT) import Data.Attoparsec.Args @@ -534,7 +535,7 @@ data ConfigMonoid = -- ^ Used for overriding the platform ,configMonoidArch :: !(Maybe String) -- ^ Used for overriding the platform - ,configMonoidGHCVariant :: !(Maybe String) + ,configMonoidGHCVariant :: !(Maybe GHCVariant) -- ^ Used for overriding the GHC variant ,configMonoidJobs :: !(Maybe Int) -- ^ See: 'configJobs' @@ -696,6 +697,7 @@ data ConfigException | BadStackVersionException VersionRange | NoMatchingSnapshot [SnapName] | NoSuchDirectory FilePath + | ParseGHCVariantException String deriving Typeable instance Show ConfigException where show (ParseConfigFileException configFile exception) = concat @@ -749,6 +751,10 @@ instance Show ConfigException where ["No directory could be located matching the supplied path: " ,dir ] + show (ParseGHCVariantException v) = concat + [ "Invalid ghc-variant value: " + , v + ] instance Exception ConfigException -- | Helper function to ask the environment and apply getConfig @@ -811,8 +817,8 @@ platformRelDir = do concat [ Distribution.Text.display platform , case ghcVariant of - StandardGHC -> "" - _ -> "-" ++ renderGHCVariant ghcVariant] + GHCStandard -> "" + _ -> "-" ++ ghcVariantName ghcVariant] -- | Path to .shake files. configShakeFilesDir :: (MonadReader env m, HasBuildConfig env) => m (Path Abs Dir) @@ -991,23 +997,60 @@ instance ToJSON SCM where -- | Specialized bariant of GHC (e.g. libgmp4 or integer-simple) data GHCVariant - = StandardGHC -- ^ Standard bindist - | Gmp4 -- ^ Bindist that supports libgmp4 (centos66) - | IntegerSimple -- ^ Bindist that uses integer-simple - | OtherGHC String -- ^ Other bindists. - deriving (Eq,Ord,Show) + = GHCStandard -- ^ Standard bindist + | GHCGMP4 -- ^ Bindist that supports libgmp4 (centos66) + | GHCIntegerSimple -- ^ Bindist that uses integer-simple + | GHCCustom String DownloadInfo -- ^ Other bindists. + deriving (Show) + +instance FromJSON GHCVariant where + -- Strange structuring is to give consistent error messages + parseJSON v@(Object _) = withObject "GHCVariant" (\o -> do + name <- o .: "name" + downloadInfo <- parseDownloadInfoFromObject o + return (GHCCustom name downloadInfo) + ) v + parseJSON (String t) = either (fail . show) return (parseGHCVariant (T.unpack t)) + parseJSON _ = fail $ "Invalid Resolver, must be Object or String" -- | Render a GHC variant to a String. -renderGHCVariant :: GHCVariant -> String -renderGHCVariant StandardGHC = "standard" -renderGHCVariant Gmp4 = "gmp4" -renderGHCVariant IntegerSimple = "integersimple" -renderGHCVariant (OtherGHC other) = other +ghcVariantName :: GHCVariant -> String +ghcVariantName GHCStandard = "standard" +ghcVariantName GHCGMP4 = "gmp4" +ghcVariantName GHCIntegerSimple = "integersimple" +ghcVariantName (GHCCustom name _) = "custom-" ++ name -- | Parse GHC variant from a String. -parseGHCVariant :: String -> GHCVariant +parseGHCVariant :: (MonadThrow m) => String -> m GHCVariant parseGHCVariant s = - if | s == "standard" -> StandardGHC - | s == "gmp4" -> Gmp4 - | s == "integersimple" -> IntegerSimple - | otherwise -> OtherGHC s + case break (== ':') s of + (name,':':location) -> + return (GHCCustom name (DownloadInfo (T.pack location) Nothing Nothing)) + _ + | s == "standard" -> return GHCStandard + | s == "gmp4" -> return GHCGMP4 + | s == "integersimple" -> return GHCIntegerSimple + | otherwise -> throwM $ ParseGHCVariantException s + +-- | Information for a file to download. +data DownloadInfo = DownloadInfo + { downloadInfoUrl :: Text + , downloadInfoContentLength :: Maybe Int + , downloadInfoSha1 :: Maybe ByteString + } deriving (Show) + +instance FromJSON DownloadInfo where + parseJSON = withObject "DownloadInfo" parseDownloadInfoFromObject + +-- | Parse JSON in existing object for 'DownloadInfo' +parseDownloadInfoFromObject :: Object -> Parser DownloadInfo +parseDownloadInfoFromObject o = do + url <- o .: "url" + contentLength <- o .:? "content-length" + sha1TextMay <- o .:? "sha1" + return + DownloadInfo + { downloadInfoUrl = url + , downloadInfoContentLength = contentLength + , downloadInfoSha1 = fmap encodeUtf8 sha1TextMay + } From 0a8eae0ee2e05a5bd63a717eb5d6e0dec97acd7e Mon Sep 17 00:00:00 2001 From: Emanuel Borsboom Date: Sun, 23 Aug 2015 07:17:49 -0700 Subject: [PATCH 5/7] Unrecognized field warnings for resolver and ghc-variant config --- src/Data/Aeson/Extended.hs | 17 +++++++---- src/Stack/Setup.hs | 3 +- src/Stack/Types/Config.hs | 58 ++++++++++++++++++++++---------------- 3 files changed, 48 insertions(+), 30 deletions(-) diff --git a/src/Data/Aeson/Extended.hs b/src/Data/Aeson/Extended.hs index 6b7a938ab6..783670c5fd 100644 --- a/src/Data/Aeson/Extended.hs +++ b/src/Data/Aeson/Extended.hs @@ -10,13 +10,14 @@ module Data.Aeson.Extended ( , WarningParser , JSONWarning (..) , withObjectWarnings - , (..:) - , (..:?) - , (..!=) , jsonSubWarnings , jsonSubWarningsT , jsonSubWarningsMT , logJSONWarnings + , unWarningParser + , (..:) + , (..:?) + , (..!=) ) where import Control.Monad.Logger (MonadLogger, logWarn) @@ -69,7 +70,7 @@ wp ..!= d = tellField :: Text -> WarningParser () tellField key = tell (mempty { wpmExpectedFields = Set.singleton key}) --- | 'MonadParser' version of 'withObject'. +-- | 'WarningParser' version of 'withObject'. withObjectWarnings :: String -> (Object -> WarningParser a) -> Value @@ -90,6 +91,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 @@ -128,7 +135,7 @@ jsonSubWarningsMT f = do -- | 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/Setup.hs b/src/Stack/Setup.hs index 9dc5d6169e..fdf65b6d18 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -6,6 +6,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TupleSections #-} @@ -450,7 +451,7 @@ data VersionedDownloadInfo = VersionedDownloadInfo instance FromJSON VersionedDownloadInfo where parseJSON = withObject "VersionedDownloadInfo" $ \o -> do version <- o .: "version" - downloadInfo <- parseDownloadInfoFromObject o + downloadInfo <- unWarningParser (parseDownloadInfoFromObject o) return VersionedDownloadInfo { vdiVersion = version , vdiDownloadInfo = downloadInfo diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 6566bc5d5a..39ca1743bb 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -5,6 +5,7 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RecordWildCards #-} @@ -18,12 +19,11 @@ import Control.Monad (liftM, mzero, forM) import Control.Monad.Catch (MonadThrow, throwM) import Control.Monad.Logger (LogLevel(..)) import Control.Monad.Reader (MonadReader, ask, asks, MonadIO, liftIO) -import Data.Aeson.Types (Parser) import Data.Aeson.Extended (ToJSON, toJSON, FromJSON, parseJSON, withText, withObject, object, - (.=), (.:), (.:?), (..:), (..:?), (..!=), Value(String, Object), + (.=), (.:), (..:), (..:?), (..!=), Value(String, Object), withObjectWarnings, WarningParser, Object, jsonSubWarnings, JSONWarning, - jsonSubWarningsMT) + jsonSubWarningsMT, jsonSubWarningsT, unWarningParser) import Data.Attoparsec.Args import Data.Binary (Binary) import Data.ByteString (ByteString) @@ -425,13 +425,13 @@ instance ToJSON Resolver where , "location" .= location ] toJSON x = toJSON $ resolverName x -instance FromJSON Resolver where +instance FromJSON (Resolver,[JSONWarning]) where -- Strange structuring is to give consistent error messages - parseJSON v@(Object _) = withObject "Resolver" (\o -> ResolverCustom - <$> o .: "name" - <*> o .: "location") v + parseJSON v@(Object _) = withObjectWarnings "Resolver" (\o -> ResolverCustom + <$> o ..: "name" + <*> o ..: "location") v - parseJSON (String t) = either (fail . show) return (parseResolverText t) + parseJSON (String t) = either (fail . show) return ((,[]) <$> parseResolverText t) parseJSON _ = fail $ "Invalid Resolver, must be Object or String" @@ -637,7 +637,7 @@ parseConfigMonoidJSON obj = do ..!= VersionRangeJSON anyVersion configMonoidOS <- obj ..:? "os" configMonoidArch <- obj ..:? "arch" - configMonoidGHCVariant <- obj ..:? "ghc-variant" + configMonoidGHCVariant <- jsonSubWarningsT (obj ..:? "ghc-variant") configMonoidJobs <- obj ..:? "jobs" configMonoidExtraIncludeDirs <- obj ..:? "extra-include-dirs" ..!= Set.empty configMonoidExtraLibDirs <- obj ..:? "extra-lib-dirs" ..!= Set.empty @@ -945,7 +945,7 @@ instance (warnings ~ [JSONWarning]) => FromJSON (ProjectAndConfigMonoid, warning (errs, _) -> fail $ unlines errs flags <- o ..:? "flags" ..!= mempty - resolver <- o ..: "resolver" + resolver <- jsonSubWarnings (o ..: "resolver") config <- parseConfigMonoidJSON o let project = Project { projectPackages = dirs @@ -1003,15 +1003,19 @@ data GHCVariant | GHCCustom String DownloadInfo -- ^ Other bindists. deriving (Show) -instance FromJSON GHCVariant where +instance FromJSON (GHCVariant, [JSONWarning]) where -- Strange structuring is to give consistent error messages - parseJSON v@(Object _) = withObject "GHCVariant" (\o -> do - name <- o .: "name" - downloadInfo <- parseDownloadInfoFromObject o - return (GHCCustom name downloadInfo) - ) v - parseJSON (String t) = either (fail . show) return (parseGHCVariant (T.unpack t)) - parseJSON _ = fail $ "Invalid Resolver, must be Object or String" + parseJSON v@(Object _) = + withObjectWarnings + "GHCVariant" + (\o -> + do name <- o ..: "name" + downloadInfo <- parseDownloadInfoFromObject o + return (GHCCustom name downloadInfo)) + v + parseJSON (String t) = + either (fail . show) return ((,[]) <$> parseGHCVariant (T.unpack t)) + parseJSON _ = fail "Invalid Resolver, must be Object or String" -- | Render a GHC variant to a String. ghcVariantName :: GHCVariant -> String @@ -1025,7 +1029,10 @@ parseGHCVariant :: (MonadThrow m) => String -> m GHCVariant parseGHCVariant s = case break (== ':') s of (name,':':location) -> - return (GHCCustom name (DownloadInfo (T.pack location) Nothing Nothing)) + return + (GHCCustom + name + (DownloadInfo (T.pack location) Nothing Nothing)) _ | s == "standard" -> return GHCStandard | s == "gmp4" -> return GHCGMP4 @@ -1039,15 +1046,18 @@ data DownloadInfo = DownloadInfo , downloadInfoSha1 :: Maybe ByteString } deriving (Show) +instance FromJSON (DownloadInfo, [JSONWarning]) where + parseJSON = withObjectWarnings "DownloadInfo" parseDownloadInfoFromObject + instance FromJSON DownloadInfo where - parseJSON = withObject "DownloadInfo" parseDownloadInfoFromObject + parseJSON = withObject "DownloadInfo" (unWarningParser . parseDownloadInfoFromObject) -- | Parse JSON in existing object for 'DownloadInfo' -parseDownloadInfoFromObject :: Object -> Parser DownloadInfo +parseDownloadInfoFromObject :: Object -> WarningParser DownloadInfo parseDownloadInfoFromObject o = do - url <- o .: "url" - contentLength <- o .:? "content-length" - sha1TextMay <- o .:? "sha1" + url <- o ..: "url" + contentLength <- o ..:? "content-length" + sha1TextMay <- o ..:? "sha1" return DownloadInfo { downloadInfoUrl = url From 84cbbe8cba70e1e32b38ddb35976ed618141d265 Mon Sep 17 00:00:00 2001 From: Emanuel Borsboom Date: Wed, 16 Sep 2015 15:37:06 -0700 Subject: [PATCH 6/7] Custom GHC bindist support improvements - Don't require separate msys2 installation for each GHC variant (local programs directory no longer includes GHC variant, instead each GHC variant is installed in a separate subdirectory of local programs) - Specify additional SetupInfo in stack.yaml, either inline or pointing to external file/URL - Add `stack setup --ghc-bindist` argument, instead of including the bindist URL with custom `--ghc-variant` - `stack setup` messages include GHC variant name - stack-setup.yaml GHC key generated for any GHC variant, not just "known" combinations --- src/Data/Aeson/Extended.hs | 28 ++-- src/Stack/Build/ConstructPlan.hs | 1 - src/Stack/Config.hs | 47 ++---- src/Stack/Constants.hs | 2 +- src/Stack/Setup.hs | 280 +++++++++++++++++-------------- src/Stack/Types/Build.hs | 4 +- src/Stack/Types/Config.hs | 166 ++++++++++++------ src/Stack/Types/Internal.hs | 2 - src/main/Main.hs | 11 +- 9 files changed, 315 insertions(+), 226 deletions(-) diff --git a/src/Data/Aeson/Extended.hs b/src/Data/Aeson/Extended.hs index 783670c5fd..343fb7f57f 100644 --- a/src/Data/Aeson/Extended.hs +++ b/src/Data/Aeson/Extended.hs @@ -12,8 +12,9 @@ module Data.Aeson.Extended ( , withObjectWarnings , jsonSubWarnings , jsonSubWarningsT - , jsonSubWarningsMT + , jsonSubWarningsTT , logJSONWarnings + , tellJSONField , unWarningParser , (..:) , (..:?) @@ -50,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 @@ -66,9 +67,9 @@ 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}) -- | 'WarningParser' version of 'withObject'. withObjectWarnings :: String @@ -122,15 +123,12 @@ 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 diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index eb49188210..c2c095223f 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -109,7 +109,6 @@ data Ctx = Ctx instance HasStackRoot Ctx instance HasPlatform Ctx instance HasGHCVariant Ctx -instance HasLocalPrograms Ctx instance HasConfig Ctx instance HasBuildConfig Ctx where getBuildConfig = getBuildConfig . getEnvConfig diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index f37d643636..aaff5c5a4b 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -93,16 +93,9 @@ getLatestResolver = do defaultStackGlobalConfig :: Maybe (Path Abs File) defaultStackGlobalConfig = parseAbsFile "/etc/stack/config" --- | Used to get the @dist@ directory before the full Config is available. -data PlatformGHCVariant = PlatformGHCVariant Platform GHCVariant -instance HasPlatform PlatformGHCVariant where - getPlatform (PlatformGHCVariant platform _) = platform -instance HasGHCVariant PlatformGHCVariant where - getGHCVariant (PlatformGHCVariant _ ghcVariant) = ghcVariant - -- Interprets ConfigMonoid options. configFromConfigMonoid - :: (MonadBaseControl IO m, MonadLogger m, MonadIO m, MonadCatch m, MonadReader env m, HasHttpManager env) + :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader env m, HasHttpManager env) => Path Abs Dir -- ^ stack root, e.g. ~/.stack -> Maybe Project -> ConfigMonoid @@ -160,6 +153,17 @@ configFromConfigMonoid configStackRoot mproject configMonoid@ConfigMonoid{..} = $ map (T.pack *** T.pack) rawEnv let configEnvOverride _ = return origEnv + platformOnlyDir <- runReaderT platformOnlyRelDir configPlatform + configLocalPrograms <- + case configPlatform of + Platform _ Windows -> do + progsDir <- getWindowsProgsDir configStackRoot origEnv + return $ progsDir $(mkRelDir stackProgName) platformOnlyDir + _ -> + return $ + configStackRoot $(mkRelDir "programs") + platformOnlyDir + configLocalBin <- case configMonoidLocalBinPath of Nothing -> do @@ -180,6 +184,7 @@ configFromConfigMonoid configStackRoot mproject configMonoid@ConfigMonoid{..} = let configTemplateParams = configMonoidTemplateParameters configScmInit = configMonoidScmInit configGhcOptions = configMonoidGhcOptions + configSetupInfoLocations = configMonoidSetupInfoLocations return Config {..} @@ -218,17 +223,15 @@ getWindowsProgsDir stackRoot m = Nothing -> return $ stackRoot $(mkRelDir "Programs") -- | An environment with a subset of BuildConfig used for setup. -data MiniConfig = MiniConfig Manager GHCVariant (Path Abs Dir) Config +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 -instance HasLocalPrograms MiniConfig where - getLocalPrograms (MiniConfig _ _ v _) = v + getGHCVariant (MiniConfig _ v _) = v -- | Load the 'MiniConfig'. loadMiniConfig @@ -241,20 +244,7 @@ loadMiniConfig config = do case configGHCVariant0 config of Just ghcVariant -> return ghcVariant Nothing -> getDefaultGHCVariant menv (configPlatform config) - platformDir <- - runReaderT - platformRelDir - (PlatformGHCVariant (configPlatform config) ghcVariant) - localPrograms <- - case configPlatform config of - Platform _ Windows -> do - progsDir <- getWindowsProgsDir (configStackRoot config) menv - return $ progsDir $(mkRelDir stackProgName) platformDir - _ -> - return $ - (configStackRoot config) $(mkRelDir "programs") - platformDir - return (MiniConfig manager ghcVariant localPrograms config) + return (MiniConfig manager ghcVariant config) -- | Load the configuration, using current directory, environment variables, -- and defaults as necessary. @@ -362,7 +352,6 @@ loadBuildConfig mproject config stackRoot mresolver = do , bcFlags = projectFlags project , bcImplicitGlobal = isNothing mproject , bcGHCVariant = getGHCVariant miniConfig - , bcLocalPrograms = getLocalPrograms 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 index 4a9f9ee033..df277ca733 100644 --- 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/Setup.hs b/src/Stack/Setup.hs index 089a9e17bf..4b9c94ca38 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -79,6 +79,7 @@ import System.IO.Temp (withSystemTempDirectory) import System.Process (rawSystem) import System.Process.Read import System.Process.Run (runIn) +import System.IO.Temp (withTempDirectory) import Text.Printf (printf) -- | Default location of the stack-setup.yaml file @@ -106,22 +107,26 @@ data SetupOpts = SetupOpts , soptsResolveMissingGHC :: !(Maybe Text) -- ^ Message shown to user for how to resolve the missing GHC , soptsStackSetupYaml :: !String + -- ^ Location of the main stack-setup.yaml file + , soptsGHCBindistURL :: !(Maybe String) + -- ^ Alternate GHC binary distribution (requires custom GHCVariant) } deriving Show -data SetupException = UnsupportedSetupCombo OS Arch GHCVariant +data SetupException = UnsupportedSetupCombo OS Arch | MissingDependencies [String] | UnknownCompilerVersion Text CompilerVersion (Set Version) | UnknownOSKey Text | GHCSanityCheckCompileFailed ReadProcessException (Path Abs File) | WantedMustBeGHC + | RequireCustomGHCVariant + | ProblemWhileDecompressing (Path Abs File) + | SetupInfoMissingSevenz deriving Typeable instance Exception SetupException instance Show SetupException where - show (UnsupportedSetupCombo os arch ghcVariant) = concat + show (UnsupportedSetupCombo os arch) = concat [ "I don't know how to install GHC for " - , case ghcVariant of - GHCStandard -> show (os, arch) - _ -> show (os, arch, ghcVariant) + , show (os, arch) , ", please install manually" ] show (MissingDependencies tools) = @@ -144,11 +149,17 @@ instance Show SetupException where , "for more information. Exception was:\n" , show e ] - show (WantedMustBeGHC) = + show WantedMustBeGHC = "The wanted compiler must be GHC" + show RequireCustomGHCVariant = + "A custom --ghc-variant must be specified to use --ghc-bindist" + show (ProblemWhileDecompressing archive) = + "Problem while decompressing " ++ toFilePath archive + show SetupInfoMissingSevenz = + "SetupInfo missing Sevenz EXE/DLL" -- | Modify the environment variables (like PATH) appropriately, possibly doing installation too -setupEnv :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasBuildConfig env, HasHttpManager env, HasGHCVariant env, HasLocalPrograms env, MonadBaseControl IO m) +setupEnv :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasBuildConfig env, HasHttpManager env, HasGHCVariant env, MonadBaseControl IO m) => Maybe Text -- ^ Message to give user when necessary GHC is not available -> m EnvConfig setupEnv mResolveMissingGHC = do @@ -168,6 +179,7 @@ setupEnv mResolveMissingGHC = do , soptsUpgradeCabal = False , soptsResolveMissingGHC = mResolveMissingGHC , soptsStackSetupYaml = defaultStackSetupYaml + , soptsGHCBindistURL = Nothing } mghcBin <- ensureGHC sopts @@ -288,7 +300,7 @@ instance Monoid ExtraDirs where (c ++ z) -- | Ensure GHC is installed and provide the PATHs to add if necessary -ensureGHC :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, HasPlatform env, HasGHCVariant env, HasLocalPrograms env, MonadBaseControl IO m) +ensureGHC :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, HasGHCVariant env, MonadBaseControl IO m) => SetupOpts -> m (Maybe ExtraDirs) ensureGHC sopts = do @@ -328,17 +340,24 @@ ensureGHC sopts = do installed <- listInstalled -- Install GHC - ghcIdent <- case getInstalledTool installed $(mkPackageName "ghc") (isWanted . GhcVersion) of + ghcVariant <- asks getGHCVariant + ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant) + ghcIdent <- case getInstalledTool installed ghcPkgName (isWanted . GhcVersion) of Just ident -> return ident Nothing | soptsInstallIfMissing sopts -> do si <- getSetupInfo' - downloadAndInstallGHC si (soptsWantedCompiler sopts) (soptsCompilerCheck sopts) + downloadAndInstallGHC + si + (soptsWantedCompiler sopts) + (soptsCompilerCheck sopts) + (soptsGHCBindistURL sopts) | otherwise -> do Platform arch _ <- asks getPlatform throwM $ CompilerVersionMismatch msystem (soptsWantedCompiler sopts, arch) + ghcVariant (soptsCompilerCheck sopts) (soptsStackYaml sopts) (fromMaybe @@ -480,67 +499,57 @@ getSystemCompiler menv wc = do (_, Nothing) -> return Nothing else return Nothing -data VersionedDownloadInfo = VersionedDownloadInfo - { vdiVersion :: Version - , vdiDownloadInfo :: DownloadInfo - } - deriving Show - -instance FromJSON VersionedDownloadInfo where - parseJSON = withObject "VersionedDownloadInfo" $ \o -> do - version <- o .: "version" - downloadInfo <- unWarningParser (parseDownloadInfoFromObject o) - return VersionedDownloadInfo - { vdiVersion = version - , vdiDownloadInfo = downloadInfo - } - -data SetupInfo = SetupInfo - { siSevenzExe :: DownloadInfo - , siSevenzDll :: DownloadInfo - , siMsys2 :: Map Text VersionedDownloadInfo - , siGHCs :: Map Text (Map Version DownloadInfo) - } - deriving Show -instance FromJSON SetupInfo where - parseJSON = withObject "SetupInfo" $ \o -> SetupInfo - <$> o .: "sevenzexe-info" - <*> o .: "sevenzdll-info" - <*> o .: "msys2" - <*> o .: "ghc" - -- | Download the most recent SetupInfo -getSetupInfo :: (MonadIO m, MonadThrow m) => SetupOpts -> Manager -> m SetupInfo +getSetupInfo + :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasConfig env) + => SetupOpts -> Manager -> m SetupInfo getSetupInfo sopts manager = do - bs <- - case parseUrl $ soptsStackSetupYaml sopts of - Just req -> do - bss <- liftIO $ flip runReaderT manager - $ withResponse req $ \res -> responseBody res $$ CL.consume - return $ S8.concat bss - Nothing -> liftIO $ S.readFile $ soptsStackSetupYaml sopts - either throwM return $ Yaml.decodeEither' bs - -markInstalled :: (MonadIO m, MonadReader env m, HasLocalPrograms env, MonadThrow m) + config <- asks getConfig + setupInfos <- + mapM + loadSetupInfo + (SetupInfoFileOrURL (soptsStackSetupYaml sopts) : + configSetupInfoLocations config) + return + (mconcat setupInfos) + where + loadSetupInfo (SetupInfoInline si) = return si + loadSetupInfo (SetupInfoFileOrURL urlOrFile) = do + bs <- + case parseUrl urlOrFile of + Just req -> do + bss <- + liftIO $ + flip runReaderT manager $ + withResponse req $ + \res -> + responseBody res $$ CL.consume + return $ S8.concat bss + Nothing -> liftIO $ S.readFile urlOrFile + (si,warnings) <- either throwM return (Yaml.decodeEither' bs) + logJSONWarnings urlOrFile warnings + return si + +markInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m) => PackageIdentifier -- ^ e.g., ghc-7.8.4, msys2-20150512 -> m () markInstalled ident = do - dir <- asks getLocalPrograms + dir <- asks $ configLocalPrograms . getConfig fpRel <- parseRelFile $ packageIdentifierString ident ++ ".installed" liftIO $ writeFile (toFilePath $ dir fpRel) "installed" -unmarkInstalled :: (MonadIO m, MonadReader env m, HasLocalPrograms env, MonadThrow m) +unmarkInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m) => PackageIdentifier -> m () unmarkInstalled ident = do - dir <- asks getLocalPrograms + dir <- asks $ configLocalPrograms . getConfig fpRel <- parseRelFile $ packageIdentifierString ident ++ ".installed" removeFileIfExists $ dir fpRel -listInstalled :: (MonadIO m, MonadReader env m, HasLocalPrograms env, MonadThrow m) +listInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m) => m [PackageIdentifier] listInstalled = do - dir <- asks getLocalPrograms + dir <- asks $ configLocalPrograms . getConfig createTree dir (_, files) <- listDirectory dir return $ mapMaybe toIdent files @@ -549,23 +558,23 @@ listInstalled = do x <- T.stripSuffix ".installed" $ T.pack $ toFilePath $ filename fp parsePackageIdentifierFromString $ T.unpack x -installDir :: (MonadReader env m, HasLocalPrograms env, MonadThrow m, MonadLogger m) +installDir :: (MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m) => PackageIdentifier -> m (Path Abs Dir) installDir ident = do - localPrograms <- asks getLocalPrograms + config <- asks getConfig reldir <- parseRelDir $ packageIdentifierString ident - return $ localPrograms reldir + return $ configLocalPrograms config reldir -- | Binary directories for the given installed package -extraDirs :: (MonadReader env m, HasPlatform env, HasLocalPrograms env, MonadThrow m, MonadLogger m) +extraDirs :: (MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m) => PackageIdentifier -> m ExtraDirs extraDirs ident = do platform <- asks getPlatform dir <- installDir ident case (platform, packageNameString $ packageIdentifierName ident) of - (Platform _ Cabal.Windows, "ghc") -> return mempty + (Platform _ Cabal.Windows, isGHC -> True) -> return mempty { edBins = goList [ dir $(mkRelDir "bin") , dir $(mkRelDir "mingw") $(mkRelDir "bin") @@ -584,7 +593,7 @@ extraDirs ident = do , dir $(mkRelDir "mingw32") $(mkRelDir "lib") ] } - (_, "ghc") -> return mempty + (_, isGHC -> True) -> return mempty { edBins = goList [ dir $(mkRelDir "bin") ] @@ -594,6 +603,7 @@ extraDirs ident = do return mempty where goList = map toFilePathNoTrailingSlash + isGHC n = "ghc" == n || "ghc-" `isPrefixOf` n getInstalledTool :: [PackageIdentifier] -- ^ already installed -> PackageName -- ^ package to find @@ -609,7 +619,7 @@ getInstalledTool installed name goodVersion = packageIdentifierName pi' == name && goodVersion (packageIdentifierVersion pi') -downloadAndInstallTool :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasLocalPrograms env, HasHttpManager env, MonadBaseControl IO m) +downloadAndInstallTool :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) => SetupInfo -> DownloadInfo -> PackageName @@ -625,23 +635,29 @@ downloadAndInstallTool si downloadInfo name version installer = do markInstalled ident return ident -downloadAndInstallGHC :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasPlatform env, HasGHCVariant env, HasLocalPrograms env, HasHttpManager env, MonadBaseControl IO m) +downloadAndInstallGHC :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasGHCVariant env, HasHttpManager env, MonadBaseControl IO m) => SetupInfo -> CompilerVersion -> VersionCheck + -> (Maybe String) -> m PackageIdentifier -downloadAndInstallGHC si wanted versionCheck = do +downloadAndInstallGHC si wanted versionCheck mbindistURL = do ghcVariant <- asks getGHCVariant - (selectedVersion, downloadInfo) <- case ghcVariant of - GHCCustom _ downloadInfo -> do + (selectedVersion, downloadInfo) <- case mbindistURL of + Just bindistURL -> do + case ghcVariant of + GHCCustom _ -> return () + _ -> throwM RequireCustomGHCVariant case wanted of - GhcVersion version -> return (version, downloadInfo) - _ -> throwM WantedMustBeGHC + GhcVersion version -> + return (version, DownloadInfo (T.pack bindistURL) Nothing Nothing) + _ -> + throwM WantedMustBeGHC _ -> do - osKey <- getOSKey + ghcKey <- getGhcKey pairs <- - case Map.lookup osKey $ siGHCs si of - Nothing -> throwM $ UnknownOSKey osKey + case Map.lookup ghcKey $ siGHCs si of + Nothing -> throwM $ UnknownOSKey ghcKey Just pairs -> return pairs let mpair = listToMaybe $ @@ -649,45 +665,52 @@ downloadAndInstallGHC si wanted versionCheck = do filter (\(v, _) -> isWantedCompiler versionCheck wanted (GhcVersion v)) (Map.toList pairs) case mpair of Just pair -> return pair - Nothing -> throwM $ UnknownCompilerVersion osKey wanted (Map.keysSet pairs) + Nothing -> throwM $ UnknownCompilerVersion ghcKey wanted (Map.keysSet pairs) platform <- asks getPlatform let installer = case platform of Platform _ Cabal.Windows -> installGHCWindows _ -> installGHCPosix - $logInfo "Preparing to install GHC to an isolated location." + $logInfo $ + "Preparing to install GHC" <> + (case ghcVariant of + GHCStandard -> "" + v -> " (" <> T.pack (ghcVariantName v) <> ")") <> + " to an isolated location." $logInfo "This will not interfere with any system-level installation." - downloadAndInstallTool si downloadInfo $(mkPackageName "ghc") selectedVersion installer + ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant) + downloadAndInstallTool si downloadInfo ghcPkgName selectedVersion installer + +getGhcKey :: (MonadReader env m, MonadThrow m, HasPlatform env, HasGHCVariant env, MonadLogger m, MonadIO m, MonadCatch m, MonadBaseControl IO m) + => m Text +getGhcKey = do + ghcVariant <- asks getGHCVariant + osKey <- getOSKey + return $ osKey <> T.pack (ghcVariantSuffix ghcVariant) -getOSKey :: (MonadReader env m, MonadThrow m, HasPlatform env, HasGHCVariant env, MonadLogger m, MonadIO m, MonadCatch m, MonadBaseControl IO m) +getOSKey :: (MonadReader env m, MonadThrow m, HasPlatform env, MonadLogger m, MonadIO m, MonadCatch m, MonadBaseControl IO m) => m Text getOSKey = do platform <- asks getPlatform - ghcVariant <- asks getGHCVariant - case (platform, ghcVariant) of - (Platform I386 Cabal.Linux, GHCGMP4) -> return "linux32-gmp4" - (Platform X86_64 Cabal.Linux, GHCGMP4) -> return "linux64-gmp4" - (Platform I386 Cabal.Linux, GHCStandard) -> return "linux32" - (Platform X86_64 Cabal.Linux, GHCStandard) -> return "linux64" - (Platform I386 Cabal.OSX, GHCStandard) -> return "macosx" - (Platform X86_64 Cabal.OSX, GHCStandard) -> return "macosx" - (Platform I386 Cabal.FreeBSD, GHCStandard) -> return "freebsd32" - (Platform X86_64 Cabal.FreeBSD, GHCStandard) -> return "freebsd64" - (Platform I386 Cabal.OpenBSD, GHCStandard) -> return "openbsd32" - (Platform X86_64 Cabal.OpenBSD, GHCStandard) -> return "openbsd64" - (Platform I386 Cabal.Windows, GHCIntegerSimple) -> return "windowsintegersimple32" - (Platform X86_64 Cabal.Windows, GHCIntegerSimple) -> return "windowsintegersimple64" - (Platform I386 Cabal.Windows, GHCStandard) -> return "windows32" - (Platform X86_64 Cabal.Windows, GHCStandard) -> return "windows64" - - (Platform arch os, _) -> throwM $ UnsupportedSetupCombo os arch ghcVariant - -downloadFromInfo :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasLocalPrograms env, HasHttpManager env, MonadBaseControl IO m) + case platform of + Platform I386 Cabal.Linux -> return "linux32" + Platform X86_64 Cabal.Linux -> return "linux64" + Platform I386 Cabal.OSX -> return "macosx" + Platform X86_64 Cabal.OSX -> return "macosx" + Platform I386 Cabal.FreeBSD -> return "freebsd32" + Platform X86_64 Cabal.FreeBSD -> return "freebsd64" + Platform I386 Cabal.OpenBSD -> return "openbsd32" + Platform X86_64 Cabal.OpenBSD -> return "openbsd64" + Platform I386 Cabal.Windows -> return "windows32" + Platform X86_64 Cabal.Windows -> return "windows64" + Platform arch os -> throwM $ UnsupportedSetupCombo os arch + +downloadFromInfo :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) => DownloadInfo -> PackageIdentifier -> m (Path Abs File, ArchiveType) downloadFromInfo downloadInfo ident = do - localPrograms <- asks getLocalPrograms + config <- asks getConfig at <- case extension of ".tar.xz" -> return TarXz @@ -695,7 +718,7 @@ downloadFromInfo downloadInfo ident = do ".7z.exe" -> return SevenZ _ -> error $ "Unknown extension: " ++ extension relfile <- parseRelFile $ packageIdentifierString ident ++ extension - let path = localPrograms relfile + let path = configLocalPrograms config relfile chattyDownload (packageIdentifierText ident) downloadInfo path return (path, at) where @@ -742,7 +765,10 @@ installGHCPosix _ archiveFile archiveType destDir ident = do withSystemTempDirectory "stack-setup" $ \root' -> do root <- parseAbsDir root' - dir <- liftM (root Path.) $ parseRelDir $ packageIdentifierString ident + dir <- + liftM (root Path.) $ + parseRelDir $ + "ghc-" ++ versionString (packageIdentifierVersion ident) $logSticky $ T.concat ["Unpacking GHC into ", (T.pack . toFilePath $ root), " ..."] $logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile) @@ -792,14 +818,14 @@ instance Alternative CheckDependency where Left _ -> y menv Right x' -> return $ Right x' -installGHCWindows :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasHttpManager env, HasLocalPrograms env, MonadBaseControl IO m) +installGHCWindows :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) => SetupInfo -> Path Abs File -> ArchiveType -> Path Abs Dir -> PackageIdentifier -> m () -installGHCWindows si archiveFile archiveType destDir _ = do +installGHCWindows si archiveFile archiveType destDir ident = do suffix <- case archiveType of TarXz -> return ".xz" @@ -812,19 +838,24 @@ installGHCWindows si archiveFile archiveType destDir _ = do run7z <- setup7z si - run7z (parent archiveFile) archiveFile - run7z (parent archiveFile) tarFile - removeFile tarFile `catchIO` \e -> - $logWarn (T.concat - [ "Exception when removing " - , T.pack $ toFilePath tarFile - , ": " - , T.pack $ show e - ]) + withTempDirectory (toFilePath $ parent destDir) + ((FP.dropTrailingPathSeparator $ toFilePath $ dirname destDir) ++ "-tmp") $ \tmpDir0 -> do + tmpDir <- parseAbsDir tmpDir0 + run7z (parent archiveFile) archiveFile + run7z tmpDir tarFile + removeFile tarFile `catchIO` \e -> + $logWarn (T.concat + [ "Exception when removing " + , T.pack $ toFilePath tarFile + , ": " + , T.pack $ show e + ]) + tarComponent <- parseRelDir $ "ghc-" ++ versionString (packageIdentifierVersion ident) + renameDir (tmpDir tarComponent) destDir $logInfo $ "GHC installed to " <> T.pack (toFilePath destDir) -installMsys2Windows :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, HasLocalPrograms env, HasPlatform env, MonadBaseControl IO m) +installMsys2Windows :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) => Text -- ^ OS Key -> SetupInfo -> Path Abs File @@ -886,24 +917,27 @@ installMsys2Windows osKey si archiveFile archiveType destDir _ = do -- | Download 7z as necessary, and get a function for unpacking things. -- -- Returned function takes an unpack directory and archive. -setup7z :: (MonadReader env m, HasHttpManager env, HasLocalPrograms env, MonadThrow m, MonadIO m, MonadIO n, MonadLogger m, MonadBaseControl IO m) +setup7z :: (MonadReader env m, HasHttpManager env, HasConfig env, MonadThrow m, MonadIO m, MonadIO n, MonadLogger m, MonadBaseControl IO m) => SetupInfo -> m (Path Abs Dir -> Path Abs File -> n ()) setup7z si = do - dir <- asks getLocalPrograms + dir <- asks $ configLocalPrograms . getConfig let exe = dir $(mkRelFile "7z.exe") dll = dir $(mkRelFile "7z.dll") - chattyDownload "7z.dll" (siSevenzDll si) dll - chattyDownload "7z.exe" (siSevenzExe si) exe - return $ \outdir archive -> liftIO $ do - ec <- rawSystem (toFilePath exe) - [ "x" - , "-o" ++ toFilePath outdir - , "-y" - , toFilePath archive - ] - when (ec /= ExitSuccess) - $ error $ "Problem while decompressing " ++ toFilePath archive + case (siSevenzDll si, siSevenzExe si) of + (Just sevenzDll, Just sevenzExe) -> do + chattyDownload "7z.dll" sevenzDll dll + chattyDownload "7z.exe" sevenzExe exe + return $ \outdir archive -> liftIO $ do + ec <- rawSystem (toFilePath exe) + [ "x" + , "-o" ++ toFilePath outdir + , "-y" + , toFilePath archive + ] + when (ec /= ExitSuccess) + $ throwM (ProblemWhileDecompressing archive) + _ -> throwM SetupInfoMissingSevenz chattyDownload :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m, MonadThrow m, MonadBaseControl IO m) => Text -- ^ label diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index 185dde2c26..a8b0d206fe 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -86,6 +86,7 @@ data StackBuildException | CompilerVersionMismatch (Maybe (CompilerVersion, Arch)) (CompilerVersion, Arch) + GHCVariant VersionCheck (Maybe (Path Abs File)) Text -- recommended resolution @@ -131,7 +132,7 @@ instance Show StackBuildException where ", the package id couldn't be found " <> "(via ghc-pkg describe " <> packageNameString name <> "). This shouldn't happen, " <> "please report as a bug") - show (CompilerVersionMismatch mactual (expected, earch) check mstack resolution) = concat + show (CompilerVersionMismatch mactual (expected, earch) ghcVariant check mstack resolution) = concat [ case mactual of Nothing -> "No compiler found, expected " Just (actual, arch) -> concat @@ -149,6 +150,7 @@ instance Show StackBuildException where , T.unpack (compilerVersionName expected) , " (" , display earch + , ghcVariantSuffix ghcVariant , ") (based on " , case mstack of Nothing -> "command line arguments" diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 3d2c2bc654..685d329efe 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -21,15 +21,16 @@ import Control.Monad.Catch (MonadThrow, throwM) import Control.Monad.Logger (LogLevel(..)) import Control.Monad.Reader (MonadReader, ask, asks, MonadIO, liftIO) import Data.Aeson.Extended - (ToJSON, toJSON, FromJSON, parseJSON, withText, withObject, object, + (ToJSON, toJSON, FromJSON, parseJSON, withText, object, (.=), (..:), (..:?), (..!=), Value(String, Object), withObjectWarnings, WarningParser, Object, jsonSubWarnings, JSONWarning, - jsonSubWarningsMT, jsonSubWarningsT, unWarningParser) + jsonSubWarningsT, jsonSubWarningsTT, tellJSONField) import Data.Attoparsec.Args import Data.Binary (Binary) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 import Data.Either (partitionEithers) +import Data.List (stripPrefix) import Data.Hashable (Hashable) import Data.Map (Map) import qualified Data.Map as Map @@ -67,6 +68,8 @@ data Config = ,configDocker :: !DockerOpts ,configEnvOverride :: !(EnvSettings -> IO EnvOverride) -- ^ Environment variables to be passed to external tools + ,configLocalPrograms :: !(Path Abs Dir) + -- ^ Path containing local installations (mainly GHC) ,configConnectionCount :: !Int -- ^ How many concurrent connections are allowed when downloading ,configHideTHLoading :: !Bool @@ -130,6 +133,8 @@ data Config = ,configGhcOptions :: !(Map (Maybe PackageName) [Text]) -- ^ Additional GHC options to apply to either all packages (Nothing) -- or a specific package (Just). + ,configSetupInfoLocations :: ![SetupInfoLocation] + -- ^ Additional SetupInfo (inline or remote) to use to find tools. } -- | Information on a single package index @@ -270,8 +275,6 @@ data BuildConfig = BuildConfig -- for providing better error messages. , bcGHCVariant :: !GHCVariant -- ^ The variant of GHC used to select a GHC bindist. - , bcLocalPrograms :: !(Path Abs Dir) - -- ^ Path containing local installations (mainly GHC) } -- | Directory containing the project's stack.yaml file @@ -293,7 +296,6 @@ instance HasBuildConfig EnvConfig where instance HasConfig EnvConfig instance HasPlatform EnvConfig instance HasGHCVariant EnvConfig -instance HasLocalPrograms EnvConfig instance HasStackRoot EnvConfig class (HasBuildConfig r, HasGHCVariant r) => HasEnvConfig r where getEnvConfig :: r -> EnvConfig @@ -373,7 +375,7 @@ instance ToJSON PackageLocation where toJSON (PLHttpTarball t) = toJSON t toJSON (PLGit x y) = toJSON $ T.unwords ["git", x, y] instance FromJSON (PackageLocation, [JSONWarning]) where - parseJSON v = git v <|> ((,[]) <$> withText "PackageLocation" (\t -> http t <|> file t) v) + parseJSON v = ((,[]) <$> withText "PackageLocation" (\t -> http t <|> file t) v) <|> git v where file t = pure $ PLFilePath $ T.unpack t http t = @@ -478,13 +480,6 @@ class HasGHCVariant env where instance HasGHCVariant GHCVariant where getGHCVariant = id --- | Class for environment values which have a local programs path. -class HasLocalPrograms env where - getLocalPrograms :: env -> Path Abs Dir - default getLocalPrograms :: HasBuildConfig env => env -> Path Abs Dir - getLocalPrograms = bcLocalPrograms . getBuildConfig - {-# INLINE getLocalPrograms #-} - -- | Class for environment values that can provide a 'Config'. class (HasStackRoot env, HasPlatform env) => HasConfig env where getConfig :: env -> Config @@ -503,7 +498,6 @@ class HasConfig env => HasBuildConfig env where instance HasStackRoot BuildConfig instance HasPlatform BuildConfig instance HasGHCVariant BuildConfig -instance HasLocalPrograms BuildConfig instance HasConfig BuildConfig instance HasBuildConfig BuildConfig where getBuildConfig = id @@ -561,6 +555,8 @@ data ConfigMonoid = -- ^ See 'configGhcOptions' ,configMonoidExtraPath :: ![Path Abs Dir] -- ^ Additional paths to search for executables in + ,configMonoidSetupInfoLocations :: ![SetupInfoLocation] + -- ^ Additional setup info (inline or remote) to use for installing tools } deriving Show @@ -590,6 +586,7 @@ instance Monoid ConfigMonoid where , configMonoidCompilerCheck = Nothing , configMonoidGhcOptions = mempty , configMonoidExtraPath = [] + , configMonoidSetupInfoLocations = mempty } mappend l r = ConfigMonoid { configMonoidDockerOpts = configMonoidDockerOpts l <> configMonoidDockerOpts r @@ -617,6 +614,7 @@ instance Monoid ConfigMonoid where , configMonoidCompilerCheck = configMonoidCompilerCheck l <|> configMonoidCompilerCheck r , configMonoidGhcOptions = Map.unionWith (++) (configMonoidGhcOptions l) (configMonoidGhcOptions r) , configMonoidExtraPath = configMonoidExtraPath l ++ configMonoidExtraPath r + , configMonoidSetupInfoLocations = configMonoidSetupInfoLocations l ++ configMonoidSetupInfoLocations r } instance FromJSON (ConfigMonoid, [JSONWarning]) where @@ -631,7 +629,7 @@ parseConfigMonoidJSON obj = do configMonoidConnectionCount <- obj ..:? "connection-count" configMonoidHideTHLoading <- obj ..:? "hide-th-loading" configMonoidLatestSnapshotUrl <- obj ..:? "latest-snapshot-url" - configMonoidPackageIndices <- jsonSubWarningsMT (obj ..:? "package-indices") + configMonoidPackageIndices <- jsonSubWarningsTT (obj ..:? "package-indices") configMonoidSystemGHC <- obj ..:? "system-ghc" configMonoidInstallGHC <- obj ..:? "install-ghc" configMonoidSkipGHCCheck <- obj ..:? "skip-ghc-check" @@ -641,7 +639,7 @@ parseConfigMonoidJSON obj = do ..!= VersionRangeJSON anyVersion configMonoidOS <- obj ..:? "os" configMonoidArch <- obj ..:? "arch" - configMonoidGHCVariant <- jsonSubWarningsT (obj ..:? "ghc-variant") + configMonoidGHCVariant <- obj ..:? "ghc-variant" configMonoidJobs <- obj ..:? "jobs" configMonoidExtraIncludeDirs <- obj ..:? "extra-include-dirs" ..!= Set.empty configMonoidExtraLibDirs <- obj ..:? "extra-lib-dirs" ..!= Set.empty @@ -668,6 +666,9 @@ parseConfigMonoidJSON obj = do configMonoidExtraPath <- forM extraPath $ either (fail . show) return . parseAbsDir . T.unpack + configMonoidSetupInfoLocations <- + maybeToList <$> jsonSubWarningsT (obj ..:? "setup-info") + return ConfigMonoid {..} where handleGhcOptions :: Monad m => (Text, Text) -> m (Maybe PackageName, [Text]) @@ -811,18 +812,21 @@ configInstalledCache :: (HasBuildConfig env, MonadReader env m) => m (Path Abs F configInstalledCache = liftM ( $(mkRelFile "installed-cache.bin")) configProjectWorkDir -- | Relative directory for the platform identifier -platformRelDir +platformOnlyRelDir + :: (MonadReader env m, HasPlatform env, MonadThrow m) + => m (Path Rel Dir) +platformOnlyRelDir = do + platform <- asks getPlatform + parseRelDir (Distribution.Text.display platform) + +-- | Relative directory for the platform identifier +platformVariantRelDir :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadThrow m) => m (Path Rel Dir) -platformRelDir = do +platformVariantRelDir = do platform <- asks getPlatform ghcVariant <- asks getGHCVariant - parseRelDir $ - concat - [ Distribution.Text.display platform - , case ghcVariant of - GHCStandard -> "" - _ -> "-" ++ ghcVariantName ghcVariant] + parseRelDir (Distribution.Text.display platform <> ghcVariantSuffix ghcVariant) -- | Path to .shake files. configShakeFilesDir :: (MonadReader env m, HasBuildConfig env) => m (Path Abs Dir) @@ -836,7 +840,7 @@ configLocalUnpackDir = liftM ( $(mkRelDir "unpacked")) configProjectWorkDir snapshotsDir :: (MonadReader env m, HasConfig env, HasGHCVariant env, MonadThrow m) => m (Path Abs Dir) snapshotsDir = do config <- asks getConfig - platform <- platformRelDir + platform <- platformVariantRelDir return $ configStackRoot config $(mkRelDir "snapshots") platform -- | Installation root for dependencies @@ -854,7 +858,7 @@ installationRootLocal = do bc <- asks getBuildConfig name <- parseRelDir $ T.unpack $ resolverName $ bcResolver bc ghc <- compilerVersionDir - platform <- platformRelDir + platform <- platformVariantRelDir return $ configProjectWorkDir bc $(mkRelDir "install") platform name ghc compilerVersionDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Rel Dir) @@ -888,7 +892,7 @@ configMiniBuildPlanCache :: (MonadThrow m, MonadReader env m, HasConfig env, Has -> m (Path Abs File) configMiniBuildPlanCache name = do root <- asks getStackRoot - platform <- platformRelDir + platform <- platformVariantRelDir file <- parseRelFile $ T.unpack (renderSnapName name) ++ ".cache" -- Yes, cached plans differ based on platform return (root $(mkRelDir "build-plan-cache") platform file) @@ -941,7 +945,7 @@ data ProjectAndConfigMonoid instance (warnings ~ [JSONWarning]) => FromJSON (ProjectAndConfigMonoid, warnings) where parseJSON = withObjectWarnings "ProjectAndConfigMonoid" $ \o -> do - dirs <- jsonSubWarningsMT (o ..:? "packages") ..!= [packageEntryCurrDir] + dirs <- jsonSubWarningsTT (o ..:? "packages") ..!= [packageEntryCurrDir] extraDeps' <- o ..:? "extra-deps" ..!= [] extraDeps <- case partitionEithers $ goDeps extraDeps' of @@ -1004,44 +1008,39 @@ data GHCVariant = GHCStandard -- ^ Standard bindist | GHCGMP4 -- ^ Bindist that supports libgmp4 (centos66) | GHCIntegerSimple -- ^ Bindist that uses integer-simple - | GHCCustom String DownloadInfo -- ^ Other bindists. + | GHCCustom String -- ^ Other bindists deriving (Show) -instance FromJSON (GHCVariant, [JSONWarning]) where +instance FromJSON GHCVariant where -- Strange structuring is to give consistent error messages - parseJSON v@(Object _) = - withObjectWarnings + parseJSON = + withText "GHCVariant" - (\o -> - do name <- o ..: "name" - downloadInfo <- parseDownloadInfoFromObject o - return (GHCCustom name downloadInfo)) - v - parseJSON (String t) = - either (fail . show) return ((,[]) <$> parseGHCVariant (T.unpack t)) - parseJSON _ = fail "Invalid Resolver, must be Object or String" + (either (fail . show) return . parseGHCVariant . T.unpack) -- | Render a GHC variant to a String. ghcVariantName :: GHCVariant -> String ghcVariantName GHCStandard = "standard" ghcVariantName GHCGMP4 = "gmp4" ghcVariantName GHCIntegerSimple = "integersimple" -ghcVariantName (GHCCustom name _) = "custom-" ++ name +ghcVariantName (GHCCustom name) = "custom-" ++ name + +-- | Render a GHC variant to a String suffix. +ghcVariantSuffix :: GHCVariant -> String +ghcVariantSuffix GHCStandard = "" +ghcVariantSuffix v = "-" ++ ghcVariantName v -- | Parse GHC variant from a String. parseGHCVariant :: (MonadThrow m) => String -> m GHCVariant parseGHCVariant s = - case break (== ':') s of - (name,':':location) -> - return - (GHCCustom - name - (DownloadInfo (T.pack location) Nothing Nothing)) - _ + case stripPrefix "custom-" s of + Just name -> return (GHCCustom name) + Nothing + | s == "" -> return GHCStandard | s == "standard" -> return GHCStandard | s == "gmp4" -> return GHCGMP4 | s == "integersimple" -> return GHCIntegerSimple - | otherwise -> throwM $ ParseGHCVariantException s + | otherwise -> return (GHCCustom s) -- | Information for a file to download. data DownloadInfo = DownloadInfo @@ -1053,18 +1052,81 @@ data DownloadInfo = DownloadInfo instance FromJSON (DownloadInfo, [JSONWarning]) where parseJSON = withObjectWarnings "DownloadInfo" parseDownloadInfoFromObject -instance FromJSON DownloadInfo where - parseJSON = withObject "DownloadInfo" (unWarningParser . parseDownloadInfoFromObject) - -- | Parse JSON in existing object for 'DownloadInfo' parseDownloadInfoFromObject :: Object -> WarningParser DownloadInfo parseDownloadInfoFromObject o = do url <- o ..: "url" contentLength <- o ..:? "content-length" sha1TextMay <- o ..:? "sha1" + -- Don't warn about 'version' field that is sometimes included + tellJSONField "version" return DownloadInfo { downloadInfoUrl = url , downloadInfoContentLength = contentLength , downloadInfoSha1 = fmap encodeUtf8 sha1TextMay } + +data VersionedDownloadInfo = VersionedDownloadInfo + { vdiVersion :: Version + , vdiDownloadInfo :: DownloadInfo + } + deriving Show + +instance FromJSON (VersionedDownloadInfo, [JSONWarning]) where + parseJSON = withObjectWarnings "VersionedDownloadInfo" $ \o -> do + version <- o ..: "version" + downloadInfo <- parseDownloadInfoFromObject o + return VersionedDownloadInfo + { vdiVersion = version + , vdiDownloadInfo = downloadInfo + } + +data SetupInfo = SetupInfo + { siSevenzExe :: Maybe DownloadInfo + , siSevenzDll :: Maybe DownloadInfo + , siMsys2 :: Map Text VersionedDownloadInfo + , siGHCs :: Map Text (Map Version DownloadInfo) + } + deriving Show + +instance FromJSON (SetupInfo, [JSONWarning]) where + parseJSON = withObjectWarnings "SetupInfo" $ \o -> do + siSevenzExe <- jsonSubWarningsT (o ..:? "sevenzexe-info") + siSevenzDll <- jsonSubWarningsT (o ..:? "sevenzdll-info") + siMsys2 <- jsonSubWarningsT (o ..:? "msys2" ..!= mempty) + siGHCs <- jsonSubWarningsTT (o ..:? "ghc" ..!= mempty) + -- Don't warn about 'portable-git' that is no-longer used + tellJSONField "portable-git" + return SetupInfo {..} + +instance Monoid SetupInfo where + mempty = + SetupInfo + { siSevenzExe = Nothing + , siSevenzDll = Nothing + , siMsys2 = Map.empty + , siGHCs = Map.empty + } + mappend l r = + SetupInfo + { siSevenzExe = siSevenzExe l <|> siSevenzExe r + , siSevenzDll = siSevenzDll l <|> siSevenzDll r + , siMsys2 = siMsys2 l <> siMsys2 r + , siGHCs = siGHCs l <> siGHCs r } + +-- | Remote or inline 'SetupInfo' +data SetupInfoLocation + = SetupInfoFileOrURL String + | SetupInfoInline SetupInfo + deriving (Show) + +instance FromJSON (SetupInfoLocation, [JSONWarning]) where + parseJSON v = + ((, []) <$> + withText "SetupInfoFileOrURL" (pure . SetupInfoFileOrURL . T.unpack) v) <|> + inline + where + inline = do + (si,w) <- parseJSON v + return (SetupInfoInline si, w) diff --git a/src/Stack/Types/Internal.hs b/src/Stack/Types/Internal.hs index 557426a232..e25b2657f5 100644 --- a/src/Stack/Types/Internal.hs +++ b/src/Stack/Types/Internal.hs @@ -24,8 +24,6 @@ instance HasPlatform config => HasPlatform (Env config) where getPlatform = getPlatform . envConfig instance HasGHCVariant config => HasGHCVariant (Env config) where getGHCVariant = getGHCVariant . envConfig -instance HasLocalPrograms config => HasLocalPrograms (Env config) where - getLocalPrograms = getLocalPrograms . envConfig instance HasConfig config => HasConfig (Env config) where getConfig = getConfig . envConfig instance HasBuildConfig config => HasBuildConfig (Env config) where diff --git a/src/main/Main.hs b/src/main/Main.hs index f103accdfe..a0a3b48065 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -440,7 +440,7 @@ paths = , ( "Installed GHCs (unpacked and archives)" , "ghc-paths" , \pi -> - T.pack (toFilePathNoTrailing (bcLocalPrograms (piBuildConfig pi)))) + T.pack (toFilePathNoTrailing (configLocalPrograms (bcConfig (piBuildConfig pi))))) , ( "Local bin path where stack installs executables" , "local-bin-path" , \pi -> @@ -497,6 +497,7 @@ data SetupCmdOpts = SetupCmdOpts , scoForceReinstall :: !Bool , scoUpgradeCabal :: !Bool , scoStackSetupYaml :: !String + , scoGHCBindistURL :: !(Maybe String) } setupParser :: Parser SetupCmdOpts @@ -515,10 +516,15 @@ setupParser = SetupCmdOpts idm <*> strOption ( long "stack-setup-yaml" - <> help "Location of the stack-setup.yaml file" + <> help "Location of the main stack-setup.yaml file" <> value defaultStackSetupYaml <> showDefault ) + <*> (optional $ strOption + (long "ghc-bindist" + <> metavar "URL" + <> help "Alternate GHC binary distribution (requires custom --ghc-variant)" + )) where readVersion = do s <- readerAsk @@ -561,6 +567,7 @@ setupCmd SetupCmdOpts{..} go@GlobalOpts{..} = do , soptsUpgradeCabal = scoUpgradeCabal , soptsResolveMissingGHC = Nothing , soptsStackSetupYaml = scoStackSetupYaml + , soptsGHCBindistURL = scoGHCBindistURL } case mpaths of Nothing -> $logInfo "stack will use the GHC on your PATH" From 1bab31b840918714372740a32d23aec91eb817a6 Mon Sep 17 00:00:00 2001 From: Emanuel Borsboom Date: Fri, 18 Sep 2015 08:43:23 -0700 Subject: [PATCH 7/7] Update changelog --- ChangeLog.md | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/ChangeLog.md b/ChangeLog.md index 7ca9ce4a4a..5f51336e25 100644 --- 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: