From fcedab062b78f8a209adeee6a878861930c1fb6b Mon Sep 17 00:00:00 2001 From: Michael Sloan Date: Thu, 13 Aug 2015 16:35:35 -0700 Subject: [PATCH 1/3] Finer specification of compiler versions #736 * Stack now defaults to matching the minor version specified in the resolver / snapshot, whereas before only the major version was significant. * Adds a 'compiler-check' field which specifies a policy for checking the GHC version. * Changes the format of stack-setup.yaml, and so changes which URL is used to find it (in order to not break old stack versions). * Refactors ensureTool code, as it already had a lot of special cases, which I found confusing. Main cause is that I needed to pass in a 'CompilerVersion' instead of 'Version', but just for installing ghc, not for git. * Introduces a 'CompilerVersion' type, and changes some naming to specify that compiler versions are being passed around rather than ghc versions. The change could be a simpler without this, but this will be helpful for GHCJS support. --- src/Stack/Build/Source.hs | 11 +- src/Stack/BuildPlan.hs | 4 +- src/Stack/Config.hs | 12 +- src/Stack/Fetch.hs | 4 +- src/Stack/Init.hs | 4 +- src/Stack/Setup.hs | 218 +++++++++++++++++++----------------- src/Stack/Solver.hs | 14 +-- src/Stack/Types.hs | 1 + src/Stack/Types/Build.hs | 21 +++- src/Stack/Types/Compiler.hs | 33 ++++++ src/Stack/Types/Config.hs | 29 +++-- src/Stack/Types/Version.hs | 105 ++++++++--------- src/main/Main.hs | 20 ++-- stack.cabal | 1 + 14 files changed, 271 insertions(+), 206 deletions(-) create mode 100644 src/Stack/Types/Compiler.hs diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index beba94fad8..a3fec86ed3 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -143,10 +143,13 @@ parseTargetsFromBuildOpts needTargets bopts = do ResolverSnapshot snapName -> do $logDebug $ "Checking resolver: " <> renderSnapName snapName loadMiniBuildPlan snapName - ResolverGhc ghc -> - return - MiniBuildPlan - { mbpGhcVersion = fromMajorVersion ghc + ResolverCompiler _ -> do + -- We ignore the resolver version, as it might be + -- GhcMajorVersion, and we want the exact version + -- we're using. + version <- asks (envConfigGhcVersion . getEnvConfig) + return MiniBuildPlan + { mbpGhcVersion = version , mbpPackages = Map.empty } ResolverCustom _ url -> do diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index d5514e0691..67bbcdd5ca 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -735,7 +735,7 @@ data CustomSnapshot = CustomSnapshot instance FromJSON CustomSnapshot where parseJSON = withObject "CustomSnapshot" $ \o -> CustomSnapshot <$> ((o .: "compiler") >>= (\t -> maybe (fail $ "Invalid compiler: " ++ T.unpack t) return $ do - t' <- T.stripPrefix "ghc-" t - parseVersionFromString $ T.unpack t')) + GhcVersion v <- parseCompilerVersion t + return v)) <*> o .: "packages" <*> o .:? "flags" .!= Map.empty diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 4f1e0da9ac..d181714758 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -137,6 +137,8 @@ configFromConfigMonoid configStackRoot mproject configMonoid@ConfigMonoid{..} = configImage = Image.imgOptsFromMonoid configMonoidImageOpts + configCompilerCheck = fromMaybe MatchMinor configMonoidCompilerCheck + origEnv <- getEnvOverride configPlatform let configEnvOverride _ = return origEnv @@ -281,20 +283,20 @@ loadBuildConfig mproject config stackRoot mresolver = do (MiniConfig manager config) let project = project' { projectResolver = resolver } - ghcVersion <- + wantedCompiler <- case projectResolver project of ResolverSnapshot snapName -> do mbp <- runReaderT (loadMiniBuildPlan snapName) miniConfig - return $ mbpGhcVersion mbp - ResolverGhc m -> return $ fromMajorVersion m + return $ GhcVersion $ mbpGhcVersion mbp ResolverCustom _name url -> do mbp <- runReaderT (parseCustomMiniBuildPlan stackYamlFP url) miniConfig - return $ mbpGhcVersion mbp + return $ GhcVersion $ mbpGhcVersion mbp + ResolverCompiler wantedCompiler -> return wantedCompiler return BuildConfig { bcConfig = config , bcResolver = projectResolver project - , bcGhcVersionExpected = ghcVersion + , bcWantedCompiler = wantedCompiler , bcPackageEntries = projectPackages project , bcExtraDeps = projectExtraDeps project , bcStackYaml = stackYamlFP diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs index 41e8f0a08f..b82ed84c30 100644 --- a/src/Stack/Fetch.hs +++ b/src/Stack/Fetch.hs @@ -335,14 +335,14 @@ fuzzyLookupCandidates (PackageIdentifier name ver) caches = if null sameMajor then Nothing else Just (map fst sameMajor) where sameMajor = filter (\(PackageIdentifier _ v, _) -> - getMajorVersion ver == getMajorVersion v) + toMajorVersion ver == toMajorVersion v) sameIdentCaches sameIdentCaches = maybe biggerFiltered (\z -> (zeroIdent, z) : biggerFiltered) zeroVer biggerFiltered = takeWhile (\(PackageIdentifier n _, _) -> name == n) (Map.toList bigger) - zeroIdent = PackageIdentifier name (fromMajorVersion (MajorVersion 0 0)) + zeroIdent = PackageIdentifier name $(mkVersion "0.0") (_, zeroVer, bigger) = Map.splitLookup zeroIdent caches -- | Figure out where to fetch from. diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 720dc81966..dd9a638527 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -148,7 +148,7 @@ getDefaultResolver cabalfps gpds initOpts = mpair <- case resolver of ResolverSnapshot name -> findBuildPlan gpds [name] - ResolverGhc _ -> return Nothing + ResolverCompiler _ -> return Nothing ResolverCustom _ _ -> return Nothing case mpair of Just (snap, flags) -> @@ -157,7 +157,7 @@ getDefaultResolver cabalfps gpds initOpts = MethodSolver -> do (ghcVersion, extraDeps) <- cabalSolver (map parent cabalfps) Map.empty [] return - ( ResolverGhc ghcVersion + ( ResolverCompiler (GhcVersion ghcVersion) , Map.filter (not . Map.null) $ fmap snd extraDeps , fmap fst extraDeps ) diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 37de0cc381..ae4d261b23 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -8,6 +8,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TupleSections #-} module Stack.Setup ( setupEnv @@ -33,12 +34,14 @@ import Data.Conduit (Conduit, ($$), (=$), await, yield, awaitForever) import Data.Conduit.Lift (evalStateC) import qualified Data.Conduit.List as CL import Data.Either +import Data.Foldable (forM_) import Data.IORef -import Data.List (intercalate) +import Data.List (intercalate, sortBy, maximumBy) import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (mapMaybe, catMaybes, fromMaybe) +import Data.Maybe import Data.Monoid +import Data.Ord (comparing) import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) @@ -77,7 +80,8 @@ import Text.Printf (printf) data SetupOpts = SetupOpts { soptsInstallIfMissing :: !Bool , soptsUseSystem :: !Bool - , soptsExpected :: !Version + , soptsWantedCompiler :: !CompilerVersion + , soptsCompilerCheck :: !VersionCheck , soptsStackYaml :: !(Maybe (Path Abs File)) -- ^ If we got the desired GHC version from that file , soptsForceReinstall :: !Bool @@ -96,7 +100,7 @@ data SetupOpts = SetupOpts deriving Show data SetupException = UnsupportedSetupCombo OS Arch | MissingDependencies [String] - | UnknownGHCVersion Text Version (Set MajorVersion) + | UnknownGHCVersion Text CompilerVersion (Set Version) | UnknownOSKey Text | GHCSanityCheckCompileFailed ReadProcessException (Path Abs File) deriving Typeable @@ -110,9 +114,9 @@ instance Show SetupException where show (MissingDependencies tools) = "The following executables are missing and must be installed: " ++ intercalate ", " tools - show (UnknownGHCVersion oskey version known) = concat + show (UnknownGHCVersion oskey wanted known) = concat [ "No information found for GHC version " - , versionString version + , T.unpack (compilerVersionName wanted) , ".\nSupported GHC major versions for OS key '" ++ T.unpack oskey ++ "': " , intercalate ", " (map show $ Set.toList known) ] @@ -138,7 +142,8 @@ setupEnv mResolveMissingGHC = do sopts = SetupOpts { soptsInstallIfMissing = configInstallGHC $ bcConfig bconfig , soptsUseSystem = configSystemGHC $ bcConfig bconfig - , soptsExpected = bcGhcVersionExpected bconfig + , soptsWantedCompiler = bcWantedCompiler bconfig + , soptsCompilerCheck = configCompilerCheck $ bcConfig bconfig , soptsStackYaml = Just $ bcStackYaml bconfig , soptsForceReinstall = False , soptsSanityCheck = False @@ -259,11 +264,13 @@ ensureGHC :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfi => SetupOpts -> m (Maybe [FilePath]) ensureGHC sopts = do - when (getMajorVersion expected < MajorVersion 7 8) $ do - $logWarn "stack will almost certainly fail with GHC below version 7.8" - $logWarn "Valiantly attempting to run anyway, but I know this is doomed" - $logWarn "For more information, see: https://github.com/commercialhaskell/stack/issues/648" - $logWarn "" + case soptsWantedCompiler sopts of + GhcVersion v | v < $(mkVersion "7.8") -> do + $logWarn "stack will almost certainly fail with GHC below version 7.8" + $logWarn "Valiantly attempting to run anyway, but I know this is doomed" + $logWarn "For more information, see: https://github.com/commercialhaskell/stack/issues/648" + $logWarn "" + _ -> return () -- Check the available GHCs menv0 <- getMinimalEnvOverride @@ -279,26 +286,13 @@ ensureGHC sopts = do Nothing -> True Just _ | soptsSkipGhcCheck sopts -> False Just (system, arch) -> - -- we allow a newer version of GHC within the same major series - getMajorVersion system /= getMajorVersion expected || - expected > system || + not (isWanted system) || arch /= expectedArch + isWanted = isWantedCompiler (soptsCompilerCheck sopts) (soptsWantedCompiler sopts) . GhcVersion -- If we need to install a GHC, try to do so mpaths <- if needLocal then do - config <- asks getConfig - let tools = - case configPlatform config of - Platform _ os | isWindows os -> - ($(mkPackageName "ghc"), Just expected) - : (if soptsSkipMsys sopts - then [] - else [($(mkPackageName "git"), Nothing)]) - _ -> - [ ($(mkPackageName "ghc"), Just expected) - ] - -- Avoid having to load it twice siRef <- liftIO $ newIORef Nothing manager <- asks getHttpManager @@ -311,9 +305,44 @@ ensureGHC sopts = do writeIORef siRef $ Just si return si + config <- asks getConfig installed <- runReaderT listInstalled config - idents <- mapM (ensureTool menv0 sopts installed getSetupInfo' msystem) tools - paths <- runReaderT (mapM binDirs $ catMaybes idents) config + + -- Install GHC + ghcIdent <- case getInstalledTool installed $(mkPackageName "ghc") isWanted of + Just ident -> return ident + Nothing + | soptsInstallIfMissing sopts -> do + si <- getSetupInfo' + downloadAndInstallGHC menv0 si (soptsWantedCompiler sopts) (soptsCompilerCheck sopts) + | otherwise -> do + Platform arch _ <- asks getPlatform + throwM $ GHCVersionMismatch + msystem + (soptsWantedCompiler sopts, arch) + (soptsCompilerCheck sopts) + (soptsStackYaml sopts) + (fromMaybe + "Try running stack setup to locally install the correct GHC" + $ soptsResolveMissingGHC sopts) + + -- Install git on windows, if necessary + mgitIdent <- case configPlatform config of + Platform _ os | isWindows os && not (soptsSkipMsys sopts) -> + case getInstalledTool installed $(mkPackageName "git") (const True) of + Just ident -> return (Just ident) + Nothing + | soptsInstallIfMissing sopts -> do + si <- getSetupInfo' + let VersionedDownloadInfo version info = siPortableGit si + Just <$> downloadAndInstallTool si info $(mkPackageName "git") version installGitWindows + | otherwise -> do + $logWarn "Continuing despite missing tool: git" + return Nothing + _ -> return Nothing + + let idents = catMaybes [Just ghcIdent, mgitIdent] + paths <- runReaderT (mapM binDirs idents) config return $ Just $ map toFilePathNoTrailingSlash $ concat paths else return Nothing @@ -338,8 +367,6 @@ ensureGHC sopts = do when (soptsSanityCheck sopts) $ sanityCheck menv return mpaths - where - expected = soptsExpected sopts -- | Install the newest version of Cabal globally upgradeCabal :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m, MonadMask m) @@ -456,7 +483,7 @@ data SetupInfo = SetupInfo { siSevenzExe :: DownloadInfo , siSevenzDll :: DownloadInfo , siPortableGit :: VersionedDownloadInfo - , siGHCs :: Map Text (Map MajorVersion VersionedDownloadInfo) + , siGHCs :: Map Text (Map Version DownloadInfo) } deriving Show instance FromJSON SetupInfo where @@ -474,7 +501,7 @@ getSetupInfo manager = do let bs = S8.concat bss either throwM return $ Yaml.decodeEither' bs where - req = "https://raw.githubusercontent.com/fpco/stackage-content/master/stack/stack-setup.yaml" + req = "https://raw.githubusercontent.com/fpco/stackage-content/master/stack/stack-setup-2.yaml" markInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m) => PackageIdentifier -- ^ e.g., ghc-7.8.4, git-2.4.0.1 @@ -535,77 +562,62 @@ binDirs ident = do $logWarn $ "binDirs: unexpected OS/tool combo: " <> T.pack (show (x, tool)) return [] -ensureTool :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) - => EnvOverride - -> SetupOpts - -> [PackageIdentifier] -- ^ already installed - -> m SetupInfo - -> Maybe (Version, Arch) -- ^ installed GHC - -> (PackageName, Maybe Version) - -> m (Maybe PackageIdentifier) -ensureTool menv sopts installed getSetupInfo' msystem (name, mversion) - | not $ null available = return $ Just $ PackageIdentifier name $ maximum available - | not $ soptsInstallIfMissing sopts = - if name == $(mkPackageName "ghc") - then do - Platform arch _ <- asks getPlatform - throwM $ GHCVersionMismatch msystem (soptsExpected sopts, arch) (soptsStackYaml sopts) - (fromMaybe - "Try running stack setup to locally install the correct GHC" - $ soptsResolveMissingGHC sopts) - else do - $logWarn $ "Continuing despite missing tool: " <> T.pack (packageNameString name) - return Nothing - | otherwise = do - si <- getSetupInfo' - (VersionedDownloadInfo version downloadInfo, installer) <- - case packageNameString name of - "git" -> do - let pair = siPortableGit si - return (pair, installGitWindows) - "ghc" -> do - osKey <- getOSKey menv - pairs <- - case Map.lookup osKey $ siGHCs si of - Nothing -> throwM $ UnknownOSKey osKey - Just pairs -> return pairs - version <- - case mversion of - Nothing -> error "invariant violated: ghc must have a version" - Just version -> return version - pair <- - case Map.lookup (getMajorVersion version) pairs of - Nothing -> throwM $ UnknownGHCVersion osKey version (Map.keysSet pairs) - Just pair -> return pair - platform <- asks $ configPlatform . getConfig - let installer = - case platform of - Platform _ os | isWindows os -> installGHCWindows - _ -> installGHCPosix - return (pair, installer) - x -> error $ "Invariant violated: ensureTool on " ++ x - let ident = PackageIdentifier name version - - (file, at) <- downloadFromInfo downloadInfo ident - dir <- installDir ident - unmarkInstalled ident - installer si file at dir ident - - markInstalled ident - return $ Just ident +getInstalledTool :: [PackageIdentifier] -- ^ already installed + -> PackageName -- ^ package to find + -> (Version -> Bool) -- ^ which versions are acceptable + -> Maybe PackageIdentifier +getInstalledTool installed name goodVersion = + if null available + then Nothing + else Just $ maximumBy (comparing packageIdentifierVersion) available where - available - | soptsForceReinstall sopts = [] - | otherwise = filter goodVersion - $ map packageIdentifierVersion - $ filter (\pi' -> packageIdentifierName pi' == name) installed - - goodVersion = - case mversion of - Nothing -> const True - Just expected -> \actual -> - getMajorVersion expected == getMajorVersion actual && - actual >= expected + available = filter goodPackage installed + goodPackage pi' = + packageIdentifierName pi' == name && + goodVersion (packageIdentifierVersion pi') + +downloadAndInstallTool :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) + => SetupInfo + -> DownloadInfo + -> PackageName + -> Version + -> (SetupInfo -> Path Abs File -> ArchiveType -> Path Abs Dir -> PackageIdentifier -> m ()) + -> m PackageIdentifier +downloadAndInstallTool si downloadInfo name version installer = do + let ident = PackageIdentifier name version + (file, at) <- downloadFromInfo downloadInfo ident + dir <- installDir ident + unmarkInstalled ident + installer si file at dir ident + markInstalled ident + return ident + +downloadAndInstallGHC :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) + => EnvOverride + -> SetupInfo + -> CompilerVersion + -> VersionCheck + -> m PackageIdentifier +downloadAndInstallGHC menv si wanted versionCheck = do + osKey <- getOSKey menv + 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 $ UnknownGHCVersion osKey wanted (Map.keysSet pairs) + platform <- asks $ configPlatform . getConfig + let installer = + case platform of + Platform _ os | isWindows os -> 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 diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 4af7adf955..89a06758d5 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -40,14 +40,14 @@ cabalSolver :: (MonadIO m, MonadLogger m, MonadMask m, MonadBaseControl IO m, Mo => [Path Abs Dir] -- ^ cabal files -> Map PackageName Version -- ^ constraints -> [String] -- ^ additional arguments - -> m (MajorVersion, Map PackageName (Version, Map FlagName Bool)) + -> m (Version, Map PackageName (Version, Map FlagName Bool)) cabalSolver cabalfps constraints cabalArgs = withSystemTempDirectory "cabal-solver" $ \dir -> do configLines <- getCabalConfig dir constraints let configFile = dir FP. "cabal.config" liftIO $ S.writeFile configFile $ encodeUtf8 $ T.unlines configLines menv <- getMinimalEnvOverride - ghcMajorVersion <- getGhcMajorVersion menv + ghcVersion <- getGhcVersion menv -- Run from a temporary directory to avoid cabal getting confused by any -- sandbox files, see: @@ -78,7 +78,7 @@ cabalSolver cabalfps constraints cabalArgs = withSystemTempDirectory "cabal-solv $ decodeUtf8 bs (errs, pairs) = partitionEithers $ map parseLine ls if null errs - then return (ghcMajorVersion, Map.fromList pairs) + then return (ghcVersion, Map.fromList pairs) else error $ "Could not parse cabal-install output: " ++ show errs where parseLine t0 = maybe (Left t0) Right $ do @@ -108,12 +108,6 @@ getGhcVersion menv = do where isValid c = c == '.' || ('0' <= c && c <= '9') -getGhcMajorVersion :: (MonadLogger m, MonadCatch m, MonadBaseControl IO m, MonadIO m) - => EnvOverride -> m MajorVersion -getGhcMajorVersion menv = do - version <- getGhcVersion menv - return $ getMajorVersion version - getCabalConfig :: (MonadReader env m, HasConfig env, MonadIO m, MonadThrow m) => FilePath -- ^ temp dir -> Map PackageName Version -- ^ constraints @@ -156,7 +150,7 @@ solveExtraDeps modStackYaml = do snapshot <- case bcResolver bconfig of ResolverSnapshot snapName -> liftM mbpPackages $ loadMiniBuildPlan snapName - ResolverGhc _ -> return Map.empty + ResolverCompiler _ -> return Map.empty ResolverCustom _ url -> liftM mbpPackages $ parseCustomMiniBuildPlan (bcStackYaml bconfig) url diff --git a/src/Stack/Types.hs b/src/Stack/Types.hs index 390b4ef19b..89260c124b 100644 --- a/src/Stack/Types.hs +++ b/src/Stack/Types.hs @@ -15,3 +15,4 @@ import Stack.Types.Docker as X import Stack.Types.Image as X import Stack.Types.Build as X import Stack.Types.Package as X +import Stack.Types.Compiler as X diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index 455589fd66..5fbe528ebf 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -66,6 +66,7 @@ import Path (Path, Abs, File, Dir, mkRelDir, toFilePath, parseRelDir, import Prelude import Stack.Types.FlagName import Stack.Types.GhcPkgId +import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.Package import Stack.Types.PackageIdentifier @@ -78,8 +79,12 @@ import System.FilePath (dropTrailingPathSeparator, pathSeparator) -- Exceptions data StackBuildException = Couldn'tFindPkgId PackageName - | GHCVersionMismatch (Maybe (Version, Arch)) (Version, Arch) (Maybe (Path Abs File)) - Text -- recommended resolution + | GHCVersionMismatch + (Maybe (Version, Arch)) + (CompilerVersion, Arch) + VersionCheck + (Maybe (Path Abs File)) + Text -- recommended resolution -- ^ Path to the stack.yaml file | Couldn'tParseTargets [Text] | UnknownTargets @@ -120,18 +125,22 @@ 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 (GHCVersionMismatch mactual (expected, earch) mstack resolution) = concat + show (GHCVersionMismatch mactual (expected, earch) check mstack resolution) = concat [ case mactual of - Nothing -> "No GHC found, expected version " + Nothing -> "No GHC found, expected " Just (actual, arch) -> concat [ "GHC version mismatched, found " , versionString actual , " (" , display arch , ")" - , ", but expected version " + , ", but expected " ] - , versionString expected + , case check of + MatchMinor -> "minor version match with " + MatchExact -> "exact version " + NewerMinor -> "minor version match or newer with " + , T.unpack (compilerVersionName expected) , " (" , display earch , ") (based on " diff --git a/src/Stack/Types/Compiler.hs b/src/Stack/Types/Compiler.hs new file mode 100644 index 0000000000..775aa16a5e --- /dev/null +++ b/src/Stack/Types/Compiler.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ViewPatterns #-} + +module Stack.Types.Compiler where + +import Data.Monoid ((<>)) +import qualified Data.Text as T +import Stack.Types.Version + +-- | Specifies a compiler and its version number(s). +-- +-- Note that despite having this datatype, stack isn't in a hurry to +-- support compilers other than GHC. +data CompilerVersion + = GhcVersion {-# UNPACK #-} !Version + deriving (Show, Eq, Ord) + +parseCompilerVersion :: T.Text -> Maybe CompilerVersion +parseCompilerVersion t + | Just t' <- T.stripPrefix "ghc-" t + , Just v <- parseVersionFromString $ T.unpack t' + = Just (GhcVersion v) + | otherwise + = Nothing + +compilerVersionName :: CompilerVersion -> T.Text +compilerVersionName (GhcVersion vghc) = + "ghc-" <> versionText vghc + +isWantedCompiler :: VersionCheck -> CompilerVersion -> CompilerVersion -> Bool +isWantedCompiler check (GhcVersion wanted) (GhcVersion actual) = + checkVersion check wanted actual diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index c699a6eec0..6a1d6ae203 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -47,6 +47,7 @@ import Network.HTTP.Client (parseUrl) import Path import qualified Paths_stack as Meta import Stack.Types.BuildPlan (SnapName, renderSnapName, parseSnapName) +import Stack.Types.Compiler import Stack.Types.Docker import Stack.Types.FlagName import Stack.Types.Image @@ -99,6 +100,8 @@ data Config = -- ^ Don't bother checking the GHC version or architecture. ,configSkipMsys :: !Bool -- ^ On Windows: don't use a locally installed MSYS + ,configCompilerCheck :: !VersionCheck + -- ^ Specifies which versions of the compiler are acceptable. ,configLocalBin :: !(Path Abs Dir) -- ^ Directory we should install executables into ,configRequireStackVersion :: !VersionRange @@ -230,8 +233,8 @@ data BuildConfig = BuildConfig , bcResolver :: !Resolver -- ^ How we resolve which dependencies to install given a set of -- packages. - , bcGhcVersionExpected :: !Version - -- ^ Version of GHC we expected for this build + , bcWantedCompiler :: !CompilerVersion + -- ^ Compiler version wanted for this build , bcPackageEntries :: ![PackageEntry] -- ^ Local packages identified by a path, Bool indicates whether it is -- a non-dependency (the opposite of 'peExtraDep') @@ -389,9 +392,9 @@ data Resolver -- ^ Use an official snapshot from the Stackage project, either an LTS -- Haskell or Stackage Nightly - | ResolverGhc {-# UNPACK #-} !MajorVersion - -- ^ Require a specific GHC major version, but otherwise provide no build - -- plan. Intended for use cases where end user wishes to specify all upstream + | ResolverCompiler !CompilerVersion + -- ^ Require a specific compiler version, but otherwise provide no build plan. + -- Intended for use cases where end user wishes to specify all upstream -- dependencies manually, such as using a dependency solver. | ResolverCustom !Text !Text @@ -400,12 +403,11 @@ data Resolver deriving (Show) instance ToJSON Resolver where - toJSON (ResolverSnapshot name) = toJSON $ renderSnapName name - toJSON (ResolverGhc (MajorVersion x y)) = toJSON $ T.pack $ concat ["ghc-", show x, ".", show y] toJSON (ResolverCustom name location) = object [ "name" .= name , "location" .= location ] + toJSON x = toJSON $ resolverName x instance FromJSON Resolver where -- Strange structuring is to give consistent error messages parseJSON v@(Object _) = withObject "Resolver" (\o -> ResolverCustom @@ -420,16 +422,14 @@ instance FromJSON Resolver where -- directory names resolverName :: Resolver -> Text resolverName (ResolverSnapshot name) = renderSnapName name -resolverName (ResolverGhc (MajorVersion x y)) = T.pack $ concat ["ghc-", show x, ".", show y] +resolverName (ResolverCompiler v) = compilerVersionName v resolverName (ResolverCustom name _) = "custom-" <> name -- | Try to parse a @Resolver@ from a @Text@. Won't work for complex resolvers (like custom). parseResolverText :: MonadThrow m => Text -> m Resolver parseResolverText t | Right x <- parseSnapName t = return $ ResolverSnapshot x - | Just t' <- T.stripPrefix "ghc-" t - , Just v <- parseMajorVersionFromString $ T.unpack t' - = return $ ResolverGhc v + | Just v <- parseCompilerVersion t = return $ ResolverCompiler v | otherwise = throwM $ ParseResolverException t -- | Class for environment values which have access to the stack root @@ -492,6 +492,8 @@ data ConfigMonoid = -- ^ See: 'configSkipGHCCheck' ,configMonoidSkipMsys :: !(Maybe Bool) -- ^ See: 'configSkipMsys' + ,configMonoidCompilerCheck :: !(Maybe VersionCheck) + -- ^ See: 'configCompilerCheck' ,configMonoidRequireStackVersion :: !VersionRange -- ^ See: 'configRequireStackVersion' ,configMonoidOS :: !(Maybe String) @@ -539,6 +541,7 @@ instance Monoid ConfigMonoid where , configMonoidImageOpts = mempty , configMonoidTemplateParameters = mempty , configMonoidScmInit = Nothing + , configMonoidCompilerCheck = Nothing } mappend l r = ConfigMonoid { configMonoidDockerOpts = configMonoidDockerOpts l <> configMonoidDockerOpts r @@ -562,6 +565,7 @@ instance Monoid ConfigMonoid where , configMonoidImageOpts = configMonoidImageOpts l <> configMonoidImageOpts r , configMonoidTemplateParameters = configMonoidTemplateParameters l <> configMonoidTemplateParameters r , configMonoidScmInit = configMonoidScmInit l <|> configMonoidScmInit r + , configMonoidCompilerCheck = configMonoidCompilerCheck l <|> configMonoidCompilerCheck r } instance FromJSON (ConfigMonoid, [JSONWarning]) where @@ -600,6 +604,7 @@ parseConfigMonoidJSON obj = do scmInit <- tobj ..:? "scm-init" params <- tobj ..:? "params" return (scmInit,fromMaybe M.empty params) + configMonoidCompilerCheck <- obj ..:? "compiler-check" return ConfigMonoid {..} -- | Newtype for non-orphan FromJSON instance. @@ -632,7 +637,7 @@ instance Show ConfigException where show (ParseResolverException t) = concat [ "Invalid resolver value: " , T.unpack t - , ". Possible valid values include lts-2.12, nightly-YYYY-MM-DD, and ghc-7.10. " + , ". Possible valid values include lts-2.12, nightly-YYYY-MM-DD, and ghc-7.10.2. " , "See https://www.stackage.org/snapshots for a complete list." ] show (NoProjectConfigFound dir mcmd) = concat diff --git a/src/Stack/Types/Version.hs b/src/Stack/Types/Version.hs index d5ac3cb066..f38b02334a 100644 --- a/src/Stack/Types/Version.hs +++ b/src/Stack/Types/Version.hs @@ -11,10 +11,7 @@ module Stack.Types.Version (Version ,Cabal.VersionRange -- TODO in the future should have a newtype wrapper - ,MajorVersion (..) - ,getMajorVersion - ,fromMajorVersion - ,parseMajorVersionFromString + ,VersionCheck(..) ,versionParser ,parseVersion ,parseVersionFromString @@ -25,7 +22,9 @@ module Stack.Types.Version ,mkVersion ,versionRangeText ,withinRange - ,Stack.Types.Version.intersectVersionRanges) + ,Stack.Types.Version.intersectVersionRanges + ,toMajorVersion + ,checkVersion) where import Control.Applicative @@ -58,63 +57,16 @@ import Text.PrettyPrint (render) -- | A parse fail. data VersionParseFail = VersionParseFail ByteString - | NotAMajorVersion Version deriving (Typeable) instance Exception VersionParseFail instance Show VersionParseFail where show (VersionParseFail bs) = "Invalid version: " ++ show bs - show (NotAMajorVersion v) = concat - [ "Not a major version: " - , versionString v - , ", expecting exactly two numbers (e.g. 7.10)" - ] -- | A package version. newtype Version = Version {unVersion :: Vector Word} deriving (Eq,Ord,Typeable,Data,Generic,Binary,NFData) --- | The first two components of a version. -data MajorVersion = MajorVersion !Word !Word - deriving (Typeable, Eq, Ord) -instance Show MajorVersion where - show (MajorVersion x y) = concat [show x, ".", show y] -instance ToJSON MajorVersion where - toJSON = toJSON . fromMajorVersion - --- | Parse major version from @String@ -parseMajorVersionFromString :: MonadThrow m => String -> m MajorVersion -parseMajorVersionFromString s = do - Version v <- parseVersionFromString s - if V.length v == 2 - then return $ getMajorVersion (Version v) - else throwM $ NotAMajorVersion (Version v) - -instance FromJSON MajorVersion where - parseJSON = withText "MajorVersion" - $ either (fail . show) return - . parseMajorVersionFromString - . T.unpack -instance FromJSON a => FromJSON (Map MajorVersion a) where - parseJSON val = do - m <- parseJSON val - fmap Map.fromList $ mapM go $ Map.toList m - where - go (k, v) = do - k' <- either (fail . show) return $ parseMajorVersionFromString k - return (k', v) - --- | Returns the first two components, defaulting to 0 if not present -getMajorVersion :: Version -> MajorVersion -getMajorVersion (Version v) = - case V.length v of - 0 -> MajorVersion 0 0 - 1 -> MajorVersion (V.head v) 0 - _ -> MajorVersion (V.head v) (v V.! 1) - --- | Convert a two-component version into a @Version@ -fromMajorVersion :: MajorVersion -> Version -fromMajorVersion (MajorVersion x y) = Version $ V.fromList [x, y] instance Hashable Version where hashWithSalt i = hashWithSalt i . V.toList . unVersion @@ -140,6 +92,14 @@ instance FromJSON Version where Nothing -> fail ("Couldn't parse package version: " ++ s) Just ver -> return ver +instance FromJSON a => FromJSON (Map Version a) where + parseJSON val = do + m <- parseJSON val + fmap Map.fromList $ mapM go $ Map.toList m + where + go (k, v) = do + k' <- either (fail . show) return $ parseVersionFromString k + return (k', v) -- | Attoparsec parser for a package version from bytestring. versionParser :: Parser Version @@ -206,3 +166,44 @@ withinRange v r = toCabalVersion v `Cabal.withinRange` r -- | A modified intersection which also simplifies, for better display. intersectVersionRanges :: Cabal.VersionRange -> Cabal.VersionRange -> Cabal.VersionRange intersectVersionRanges x y = Cabal.simplifyVersionRange $ Cabal.intersectVersionRanges x y + +-- | Returns the first two components, defaulting to 0 if not present +toMajorVersion :: Version -> Version +toMajorVersion (Version v) = + case V.length v of + 0 -> Version (V.fromList [0, 0]) + 1 -> Version (V.fromList [V.head v, 0]) + _ -> Version (V.fromList [V.head v, v V.! 1]) + +data VersionCheck + = MatchMinor + | MatchExact + | NewerMinor + deriving (Show, Eq, Ord) +instance ToJSON VersionCheck where + toJSON MatchMinor = String "match-minor" + toJSON MatchExact = String "match-exact" + toJSON NewerMinor = String "newer-minor" +instance FromJSON VersionCheck where + parseJSON = withText expected $ \t -> + case t of + "match-minor" -> return MatchMinor + "match-exact" -> return MatchExact + "newer-minor" -> return NewerMinor + _ -> fail ("Expected " ++ expected ++ ", but got " ++ show t) + where + expected = "VersionCheck value (match-minor, match-exact, or newer-minor)" + +checkVersion :: VersionCheck -> Version -> Version -> Bool +checkVersion check (Version wanted) (Version actual) = + case check of + MatchMinor -> V.and (V.take 3 matching) + MatchExact -> V.length wanted == V.length actual && V.and matching + NewerMinor -> V.and (V.take 2 matching) && newerMinor + where + matching = V.zipWith (==) wanted actual + newerMinor = + case (wanted V.!? 2, actual V.!? 2) of + (Nothing, _) -> True + (Just _, Nothing) -> False + (Just w, Just a) -> a >= w diff --git a/src/main/Main.hs b/src/main/Main.hs index 9335012624..e210f774dd 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -483,7 +483,7 @@ paths = where toFilePathNoTrailing = dropTrailingPathSeparator . toFilePath data SetupCmdOpts = SetupCmdOpts - { scoGhcVersion :: !(Maybe Version) + { scoCompilerVersion :: !(Maybe CompilerVersion) , scoForceReinstall :: !Bool , scoUpgradeCabal :: !Bool } @@ -492,7 +492,7 @@ setupParser :: Parser SetupCmdOpts setupParser = SetupCmdOpts <$> (optional $ argument readVersion (metavar "GHC_MAJOR_VERSION" <> - help ("Major version of GHC to install, e.g. 7.10. " ++ + help ("Version of GHC to install, e.g. 7.10.2. " ++ "The default is to install the version implied by the resolver."))) <*> boolFlags False "reinstall" @@ -505,7 +505,7 @@ setupParser = SetupCmdOpts where readVersion = do s <- readerAsk - case parseVersionFromString s of + case parseCompilerVersion ("ghc-" <> T.pack s) of Nothing -> readerError $ "Invalid version: " ++ s Just x -> return x @@ -518,19 +518,23 @@ setupCmd SetupCmdOpts{..} go@GlobalOpts{..} = do (lcProjectRoot lc) Nothing (runStackLoggingTGlobal manager go $ do - (ghc, mstack) <- - case scoGhcVersion of - Just v -> return (v, Nothing) + (wantedCompiler, compilerCheck, mstack) <- + case scoCompilerVersion of + Just v -> return (v, MatchMinor, Nothing) Nothing -> do bc <- lcLoadBuildConfig lc globalResolver - return (bcGhcVersionExpected bc, Just $ bcStackYaml bc) + return ( bcWantedCompiler bc + , configCompilerCheck (lcConfig lc) + , Just $ bcStackYaml bc + ) mpaths <- runStackTGlobal manager (lcConfig lc) go $ ensureGHC SetupOpts { soptsInstallIfMissing = True , soptsUseSystem = (configSystemGHC $ lcConfig lc) && not scoForceReinstall - , soptsExpected = ghc + , soptsWantedCompiler = wantedCompiler + , soptsCompilerCheck = compilerCheck , soptsStackYaml = mstack , soptsForceReinstall = scoForceReinstall , soptsSanityCheck = True diff --git a/stack.cabal b/stack.cabal index d8fce38076..027c80e3ae 100644 --- a/stack.cabal +++ b/stack.cabal @@ -60,6 +60,7 @@ library Stack.Types Stack.Types.Internal Stack.Types.BuildPlan + Stack.Types.Compiler Stack.Types.Config Stack.Types.Docker Stack.Types.FlagName From 9c88664c1059360de7923686f834e9abb8a3e742 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 14 Aug 2015 12:15:11 +0300 Subject: [PATCH 2/3] More explicit pattern match (get GHC warning for match failure when more constructors added) --- src/Stack/BuildPlan.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 67bbcdd5ca..8300974a36 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -735,7 +735,8 @@ data CustomSnapshot = CustomSnapshot instance FromJSON CustomSnapshot where parseJSON = withObject "CustomSnapshot" $ \o -> CustomSnapshot <$> ((o .: "compiler") >>= (\t -> maybe (fail $ "Invalid compiler: " ++ T.unpack t) return $ do - GhcVersion v <- parseCompilerVersion t - return v)) + cv <- parseCompilerVersion t + case cv of + GhcVersion v -> return v)) <*> o .: "packages" <*> o .:? "flags" .!= Map.empty From ff24fb94afecb16521c2b471dff2f4f06935c279 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 14 Aug 2015 12:23:49 +0300 Subject: [PATCH 3/3] Update changelog for #736 and #784 --- ChangeLog.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ChangeLog.md b/ChangeLog.md index 11937af918..f6f02c52cb 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ ## 0.1.3.1 +Major changes: + +* You now have more control over how GHC versions are matched, e.g. "use exactly this version," "use the specified minor version, but allow patches," or "use the given minor version or any later minor in the given major release." The default has switched from allowing newer later minor versions to a specific minor version allowing patches. For more information, see [#736](https://github.com/commercialhaskell/stack/issues/736) and [#784](https://github.com/commercialhaskell/stack/pull/784). + Bug fixes: * Ignore disabled executables [#763](https://github.com/commercialhaskell/stack/issues/763)