diff --git a/ChangeLog.md b/ChangeLog.md index df1a21bbff..e9eb826616 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -37,6 +37,10 @@ Major changes: their exact versions. * The `ignore-revision-mismatch` setting is no longer needed, and has been removed. + * Overriding GHC boot packages results in any other GHC boot + packages depending on it being no longer available as a dependency, + such packages need to be added explicitly when needed. See + [#4510] (https://github.com/commercialhaskell/stack/issues/4510). * Upgrade to Cabal 2.4 * Note that, in this process, the behavior of file globbing has been modified to match that of Cabal. In particular, this means diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 4b9babac13..b453b0ca04 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -219,7 +219,8 @@ constructPlan baseConfigOpts0 localDumpPkgs loadPackage0 sourceMap installedMap planDebug $ show errs stackYaml <- view stackYamlL stackRoot <- view stackRootL - prettyErrorNoIndent $ pprintExceptions errs stackYaml stackRoot parents (wanted ctx) + prettyErrorNoIndent $ + pprintExceptions errs stackYaml stackRoot parents (wanted ctx) prunedGlobalDeps throwM $ ConstructPlanFailed "Plan construction failed." where hasBaseInDeps = Map.member (mkPackageName "base") (smDeps sourceMap) @@ -234,28 +235,21 @@ constructPlan baseConfigOpts0 localDumpPkgs loadPackage0 sourceMap installedMap , localNames = Map.keysSet (smProject sourceMap) } + prunedGlobalDeps = flip Map.mapMaybe (smGlobal sourceMap) $ \gp -> + case gp of + ReplacedGlobalPackage deps -> + let pruned = filter (not . inSourceMap) deps + in if null pruned then Nothing else Just pruned + GlobalPackage _ -> Nothing + + inSourceMap pname = pname `Map.member` smDeps sourceMap || + pname `Map.member` smProject sourceMap + getSources = do pPackages <- for (smProject sourceMap) $ \pp -> do lp <- loadLocalPackage sourceMap pp return $ PSFilePath lp bopts <- view $ configL.to configBuild - env <- ask - let buildHaddocks = shouldHaddockDeps bopts - globalToSource name gp | name `Set.member` wiredInPackages = pure Nothing - | otherwise = do - let version = gpVersion gp - mrev <- getLatestHackageRevision name version - forM mrev $ \(_rev, cfKey, treeKey) -> - let loc = PLIHackage (PackageIdentifier name version) cfKey treeKey - common = CommonPackage - { cpGPD = runRIO env $ loadCabalFile (PLImmutable loc) - , cpName = name - , cpFlags = mempty - , cpGhcOptions = mempty - , cpHaddocks = buildHaddocks - } - in pure $ PSRemote loc version NotFromSnapshot common - globalDeps <- Map.traverseMaybeWithKey globalToSource $ smGlobal sourceMap deps <- for (smDeps sourceMap) $ \dp -> case dpLocation dp of PLImmutable loc -> @@ -264,7 +258,7 @@ constructPlan baseConfigOpts0 localDumpPkgs loadPackage0 sourceMap installedMap pp <- mkProjectPackage YesPrintWarnings dir (shouldHaddockDeps bopts) lp <- loadLocalPackage sourceMap pp return $ PSFilePath lp - return $ pPackages <> deps <> globalDeps + return $ pPackages <> deps -- | State to be maintained during the calculation of local packages -- to unregister. @@ -972,8 +966,9 @@ pprintExceptions -> Path Abs Dir -> ParentMap -> Set PackageName + -> Map PackageName [PackageName] -> StyleDoc -pprintExceptions exceptions stackYaml stackRoot parentMap wanted' = +pprintExceptions exceptions stackYaml stackRoot parentMap wanted' prunedGlobalDeps = mconcat $ [ flow "While constructing the build plan, the following exceptions were encountered:" , line <> line @@ -1070,6 +1065,13 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted' = | name `Set.member` allNotInBuildPlan = Nothing | name `Set.member` wiredInPackages = Just $ flow "Can't build a package with same name as a wired-in-package:" <+> (style Current . fromString . packageNameString $ name) + | Just pruned <- Map.lookup name prunedGlobalDeps = + let prunedDeps = map (style Current . fromString . packageNameString) pruned + in Just $ flow "Can't use GHC boot package" <+> + (style Current . fromString . packageNameString $ name) <+> + flow "when it has an overriden dependency, " <+> + flow "you need to add the following as explicit dependencies to the project:" <+> + line <+> encloseSep "" "" ", " prunedDeps | otherwise = Just $ flow "Unknown package:" <+> (style Current . fromString . packageNameString $ name) pprintFlags flags diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index 1613b242df..402e4c83ca 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -70,7 +70,7 @@ localDependencies = do loadSourceMap :: HasBuildConfig env => SMTargets -> BuildOptsCLI - -> SMActual + -> SMActual DumpedGlobalPackage -> RIO env SourceMap loadSourceMap smt boptsCli sma = do bconfig <- view buildConfigL @@ -100,12 +100,12 @@ loadSourceMap smt boptsCli sma = do then boptsHaddock bopts else shouldHaddockDeps bopts } - globals = smaGlobal sma `M.difference` smtDeps smt packageCliFlags = Map.fromList $ mapMaybe maybeProjectFlags $ Map.toList (boptsCLIFlags boptsCli) maybeProjectFlags (ACFByName name, fs) = Just (name, fs) maybeProjectFlags _ = Nothing + globals = pruneGlobals (smaGlobal sma) (Map.keysSet deps) checkFlagsUsedThrowing packageCliFlags FSCommandLine project deps smh <- hashSourceMapData (whichCompiler compiler) deps return diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index 0d1639b301..39cecdda65 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -211,7 +211,7 @@ data ResolveResult = ResolveResult -- the module). resolveRawTarget :: (HasLogFunc env, HasPantryConfig env, HasProcessContext env) - => SMActual + => SMActual GlobalPackage -> Map PackageName PackageLocation -> (RawInput, RawTarget) -> RIO env (Either Text ResolveResult) @@ -304,26 +304,13 @@ resolveRawTarget sma allLocs (ri, rt) = , rrAddedDep = Nothing , rrPackageType = PTProject } - | Map.member name deps || - Map.member name globals = return $ Right ResolveResult - { rrName = name - , rrRaw = ri - , rrComponent = Nothing - , rrAddedDep = Nothing - , rrPackageType = PTDependency - } - | otherwise = do - mloc <- getLatestHackageLocation name UsePreferredVersions - pure $ case mloc of - Nothing -> deferToConstructPlan name - Just loc -> do - Right ResolveResult - { rrName = name - , rrRaw = ri - , rrComponent = Nothing - , rrAddedDep = Just loc - , rrPackageType = PTDependency - } + | Map.member name deps = + pure $ deferToConstructPlan name + | Just gp <- Map.lookup name globals = + case gp of + GlobalPackage _ -> pure $ deferToConstructPlan name + ReplacedGlobalPackage _ -> hackageLatest name + | otherwise = hackageLatest name -- Note that we use CFILatest below, even though it's -- non-reproducible, to avoid user confusion. In any event, @@ -341,20 +328,10 @@ resolveRawTarget sma allLocs (ri, rt) = case Map.lookup name allLocs of -- Installing it from the package index, so we're cool -- with overriding it if necessary - Just (PLImmutable (PLIHackage (PackageIdentifier _name versionLoc) cfKey treeKey)) -> - pure $ Right ResolveResult - { rrName = name - , rrRaw = ri - , rrComponent = Nothing - , rrAddedDep = - if version == versionLoc - -- But no need to override anyway, this is already the - -- version we have - then Nothing - -- OK, we'll override it - else Just $ PLIHackage (PackageIdentifier name version) cfKey treeKey - , rrPackageType = PTDependency - } + Just (PLImmutable (PLIHackage (PackageIdentifier _name versionLoc) _cfKey _treeKey)) -> + if version == versionLoc + then pure $ deferToConstructPlan name + else hackageLatestRevision name version -- The package was coming from something besides the -- index, so refuse to do the override Just loc' -> pure $ Left $ T.concat @@ -377,6 +354,31 @@ resolveRawTarget sma allLocs (ri, rt) = , rrPackageType = PTDependency } + hackageLatest name = do + mloc <- getLatestHackageLocation name UsePreferredVersions + pure $ case mloc of + Nothing -> deferToConstructPlan name + Just loc -> do + Right ResolveResult + { rrName = name + , rrRaw = ri + , rrComponent = Nothing + , rrAddedDep = Just loc + , rrPackageType = PTDependency + } + + hackageLatestRevision name version = do + mrev <- getLatestHackageRevision name version + pure $ case mrev of + Nothing -> deferToConstructPlan name + Just (_rev, cfKey, treeKey) -> Right ResolveResult + { rrName = name + , rrRaw = ri + , rrComponent = Nothing + , rrAddedDep = Just $ PLIHackage (PackageIdentifier name version) cfKey treeKey + , rrPackageType = PTDependency + } + -- This is actually an error case. We _could_ return a -- Left value here, but it turns out to be better to defer -- this until the ConstructPlan phase, and let it complain @@ -432,7 +434,7 @@ parseTargets :: HasBuildConfig env => NeedTargets -> Bool -> BuildOptsCLI - -> SMActual + -> SMActual GlobalPackage -> RIO env SMTargets parseTargets needTargets haddockDeps boptscli smActual = do logDebug "Parsing the targets" @@ -446,8 +448,8 @@ parseTargets needTargets haddockDeps boptscli smActual = do let deps = smaDeps smActual globals = smaGlobal smActual - latestGlobal name gp = do - let version = gpVersion gp + latestGlobal _ (ReplacedGlobalPackage _) = pure Nothing + latestGlobal name (GlobalPackage version) = do mrev <- getLatestHackageRevision name version forM mrev $ \(_rev, cfKey, treeKey) -> do let ident = PackageIdentifier name version diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index 04c38040e8..e42e118a1f 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -198,7 +198,7 @@ ghci opts@GhciOpts{..} = do preprocessTargets :: HasEnvConfig env => BuildOptsCLI - -> SMActual + -> SMActual GlobalPackage -> [Text] -> RIO env (Either [Path Abs File] (Map PackageName Target)) preprocessTargets buildOptsCLI sma rawTargets = do @@ -229,7 +229,7 @@ preprocessTargets buildOptsCLI sma rawTargets = do parseMainIsTargets :: HasEnvConfig env => BuildOptsCLI - -> SMActual + -> SMActual GlobalPackage -> Maybe Text -> RIO env (Maybe (Map PackageName Target)) parseMainIsTargets buildOptsCLI sma mtarget = forM mtarget $ \target -> do diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 7c423e2e64..21015e631b 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -63,7 +63,7 @@ import qualified Data.Yaml as Yaml import Distribution.System (OS, Arch (..), Platform (..)) import qualified Distribution.System as Cabal import Distribution.Text (simpleParse) -import Distribution.Types.PackageName (mkPackageName) +import Distribution.Types.PackageName (mkPackageName, unPackageName) import Distribution.Version (mkVersion) import Lens.Micro (set) import Network.HTTP.StackClient (CheckHexDigest (..), DownloadRequest (..), HashCheck (..), @@ -87,6 +87,7 @@ import Stack.Config (loadConfig) import Stack.Constants import Stack.Constants.Config (distRelativeDir) import Stack.GhcPkg (createDatabase, getCabalPkgVer, getGlobalDB, mkGhcPackagePath, ghcPkgPathEnvVar) +import Stack.PackageDump (DumpPackage (..)) import Stack.Prelude hiding (Display (..)) import Stack.SourceMap import Stack.Setup.Installed @@ -95,6 +96,7 @@ import Stack.Types.Compiler import Stack.Types.CompilerBuild import Stack.Types.Config import Stack.Types.Docker +import Stack.Types.GhcPkgId (parseGhcPkgId) import Stack.Types.Runner import Stack.Types.SourceMap import Stack.Types.Version @@ -258,6 +260,7 @@ setupEnv needTargets boptsCLI mResolveMissingGHC = do (view envVarsL menv0) menv <- mkProcessContext env + -- FIXME currently this fails with SkipDownloadcompiler (compilerVer, cabalVer, globaldb) <- withProcessContext menv $ runConcurrently $ (,,) <$> Concurrently (getCompilerVersion wc) <*> Concurrently (getCabalPkgVer wc) @@ -272,9 +275,49 @@ setupEnv needTargets boptsCLI mResolveMissingGHC = do bcPath = set envOverrideSettingsL (\_ -> return menv) $ set processContextL menv bc sourceMap <- runRIO bcPath $ do - smActual <- toActual (bcSMWanted bc) (bcDownloadCompiler bc) compilerVer + (smActual, prunedActual) <- case bcDownloadCompiler bc of + SkipDownloadCompiler -> do + -- FIXME temprorary version, should be resolved the same way as getCompilerVersion above + sma <- actualFromHints (bcSMWanted bc) compilerVer + let noDepsDump :: PackageName -> a -> DumpedGlobalPackage + noDepsDump pname _ = DumpPackage + { dpGhcPkgId = fromMaybe (error "bad package name") $ + parseGhcPkgId (T.pack $ unPackageName pname) + , dpPackageIdent = PackageIdentifier pname (mkVersion []) + , dpParentLibIdent = Nothing + , dpLicense = Nothing + , dpLibDirs = [] + , dpLibraries = [] + , dpHasExposedModules = True + , dpExposedModules = mempty + , dpDepends = [] + , dpHaddockInterfaces = [] + , dpHaddockHtml = Nothing + , dpProfiling = () + , dpHaddock = () + , dpSymbols = () + , dpIsExposed = True + } + fakeDump = sma { + smaGlobal = Map.mapWithKey noDepsDump (smaGlobal sma) + } + fakePruned = sma { + smaGlobal = Map.map (\(GlobalPackageVersion v) -> GlobalPackage v) + (smaGlobal sma) + } + return (fakeDump, fakePruned) + WithDownloadCompiler -> do + sma <- actualFromGhc (bcSMWanted bc) compilerVer + let actualPkgs = Map.keysSet (smaDeps sma) <> + Map.keysSet (smaProject sma) + return ( sma + , sma { + smaGlobal = pruneGlobals (smaGlobal sma) actualPkgs + } + ) + let haddockDeps = shouldHaddockDeps (configBuild config) - targets <- parseTargets needTargets haddockDeps boptsCLI smActual + targets <- parseTargets needTargets haddockDeps boptsCLI prunedActual loadSourceMap targets boptsCLI smActual let envConfig0 = EnvConfig @@ -384,8 +427,12 @@ rebuildEnv envConfig needTargets haddockDeps boptsCLI = do let bc = envConfigBuildConfig envConfig compilerVer = smCompiler $ envConfigSourceMap envConfig runRIO bc $ do - smActual <- toActual (bcSMWanted bc) (bcDownloadCompiler bc) compilerVer - targets <- parseTargets needTargets haddockDeps boptsCLI smActual + smActual <- actualFromGhc (bcSMWanted bc) compilerVer + let actualPkgs = Map.keysSet (smaDeps smActual) <> Map.keysSet (smaProject smActual) + prunedActual = smActual { + smaGlobal = pruneGlobals (smaGlobal smActual) actualPkgs + } + targets <- parseTargets needTargets haddockDeps boptsCLI prunedActual sourceMap <- loadSourceMap targets boptsCLI smActual return $ envConfig diff --git a/src/Stack/SourceMap.hs b/src/Stack/SourceMap.hs index 3a8136d682..6a4ddea2de 100644 --- a/src/Stack/SourceMap.hs +++ b/src/Stack/SourceMap.hs @@ -8,12 +8,17 @@ module Stack.SourceMap , loadVersion , getPLIVersion , loadGlobalHints - , toActual + , DumpedGlobalPackage + , actualFromGhc + , actualFromHints , checkFlagsUsedThrowing + , globalCondCheck + , pruneGlobals ) where import qualified Data.Conduit.List as CL import qualified Distribution.PackageDescription as PD +import Distribution.System (Platform(..)) import Pantry import qualified RIO import qualified RIO.Map as Map @@ -111,43 +116,37 @@ getPLIVersion (PLIRepo _ pm) = pkgVersion $ pmIdent pm globalsFromDump :: (HasLogFunc env, HasProcessContext env) => ActualCompiler - -> RIO env (Map PackageName GlobalPackage) + -> RIO env (Map PackageName DumpedGlobalPackage) globalsFromDump compiler = do let pkgConduit = conduitDumpPackage .| CL.foldMap (\dp -> Map.singleton (dpGhcPkgId dp) dp) - toGlobals ds = Map.fromList $ map toGlobal $ Map.elems ds - toGlobal d = - ( pkgName $ dpPackageIdent d - , GlobalPackage (pkgVersion $ dpPackageIdent d)) + toGlobals ds = + Map.fromList $ map (pkgName . dpPackageIdent &&& id) $ Map.elems ds toGlobals <$> ghcPkgDump (whichCompiler compiler) [] pkgConduit globalsFromHints :: HasConfig env => WantedCompiler - -> RIO env (Map PackageName GlobalPackage) + -> RIO env (Map PackageName Version) globalsFromHints compiler = do ghfp <- globalHintsFile mglobalHints <- loadGlobalHints ghfp compiler case mglobalHints of - Just hints -> pure $ Map.map GlobalPackage hints + Just hints -> pure hints Nothing -> do logWarn $ "Unable to load global hints for " <> RIO.display compiler pure mempty -toActual :: +type DumpedGlobalPackage = DumpPackage () () () + +actualFromGhc :: (HasConfig env) => SMWanted - -> WithDownloadCompiler -> ActualCompiler - -> RIO env SMActual -toActual smw downloadCompiler ac = do - allGlobals <- - case downloadCompiler of - WithDownloadCompiler -> globalsFromDump ac - SkipDownloadCompiler -> globalsFromHints (actualToWanted ac) - let globals = - allGlobals `Map.difference` smwProject smw `Map.difference` smwDeps smw + -> RIO env (SMActual DumpedGlobalPackage) +actualFromGhc smw ac = do + globals <- globalsFromDump ac return SMActual { smaCompiler = ac @@ -156,6 +155,30 @@ toActual smw downloadCompiler ac = do , smaGlobal = globals } +actualFromHints :: + (HasConfig env) + => SMWanted + -> ActualCompiler + -> RIO env (SMActual GlobalPackageVersion) +actualFromHints smw ac = do + globals <- globalsFromHints (actualToWanted ac) + return + SMActual + { smaCompiler = ac + , smaProject = smwProject smw + , smaDeps = smwDeps smw + , smaGlobal = Map.map GlobalPackageVersion globals + } + +-- | Simple cond check for boot packages - checks only OS and Arch +globalCondCheck :: (HasConfig env) => RIO env (PD.ConfVar -> Either PD.ConfVar Bool) +globalCondCheck = do + Platform arch os <- view platformL + let condCheck (PD.OS os') = pure $ os' == os + condCheck (PD.Arch arch') = pure $ arch' == arch + condCheck c = Left c + return condCheck + checkFlagsUsedThrowing :: (MonadIO m, MonadThrow m) => Map PackageName (Map FlagName Bool) @@ -196,3 +219,14 @@ getUnusedPackageFlags (name, userFlags) source prj deps = then pure Nothing -- Error about the undefined flags else pure $ Just $ UFFlagsNotDefined source pname pkgFlags unused + +pruneGlobals :: + Map PackageName DumpedGlobalPackage + -> Set PackageName + -> Map PackageName GlobalPackage +pruneGlobals globals deps = + let (prunedGlobals, keptGlobals) = + partitionReplacedDependencies globals (pkgName . dpPackageIdent) + dpGhcPkgId dpDepends deps + in Map.map (GlobalPackage . pkgVersion . dpPackageIdent) keptGlobals <> + Map.map ReplacedGlobalPackage prunedGlobals diff --git a/src/Stack/Types/SourceMap.hs b/src/Stack/Types/SourceMap.hs index a2f94196a5..d36a297cbf 100644 --- a/src/Stack/Types/SourceMap.hs +++ b/src/Stack/Types/SourceMap.hs @@ -16,7 +16,9 @@ module Stack.Types.SourceMap , DepPackage (..) , ProjectPackage (..) , CommonPackage (..) + , GlobalPackageVersion (..) , GlobalPackage (..) + , isReplacedGlobal , SourceMapHash (..) ) where @@ -61,10 +63,17 @@ data ProjectPackage = ProjectPackage , ppResolvedDir :: !(ResolvedPath Dir) } --- | A view of a package installed in the global package database. -newtype GlobalPackage = GlobalPackage - { gpVersion :: Version - } +-- | A view of a package installed in the global package database also +-- could include marker for a replaced global package (could be replaced +-- because of a replaced dependency) +data GlobalPackage + = GlobalPackage !Version + | ReplacedGlobalPackage ![PackageName] + deriving Eq + +isReplacedGlobal :: GlobalPackage -> Bool +isReplacedGlobal (ReplacedGlobalPackage _) = True +isReplacedGlobal (GlobalPackage _) = False -- | A source map with information on the wanted (but not actual) -- compiler. This is derived by parsing the @stack.yaml@ file for @@ -84,13 +93,15 @@ data SMWanted = SMWanted -- the contents of the global package database. -- -- Invariant: a @PackageName@ appears in only one of the @Map@s. -data SMActual = SMActual +data SMActual global = SMActual { smaCompiler :: !ActualCompiler , smaProject :: !(Map PackageName ProjectPackage) , smaDeps :: !(Map PackageName DepPackage) - , smaGlobal :: !(Map PackageName GlobalPackage) + , smaGlobal :: !(Map PackageName global) } +newtype GlobalPackageVersion = GlobalPackageVersion Version + -- | How a package is intended to be built data Target = TargetAll !PackageType diff --git a/subs/curator/src/Curator/Snapshot.hs b/subs/curator/src/Curator/Snapshot.hs index d9017552f2..fda357f465 100644 --- a/subs/curator/src/Curator/Snapshot.hs +++ b/subs/curator/src/Curator/Snapshot.hs @@ -9,16 +9,24 @@ module Curator.Snapshot import Curator.GithubPings import Curator.Types import Distribution.Compiler (CompilerFlavor(..)) +import Distribution.InstalledPackageInfo (InstalledPackageInfo(..)) import qualified Distribution.PackageDescription as C +import Distribution.Simple.Compiler (PackageDB(GlobalPackageDB)) +import Distribution.Simple.GHC (hcPkgInfo) +import Distribution.Simple.Program.Builtin (ghcProgram) +import Distribution.Simple.Program.Db + (configureAllKnownPrograms, defaultProgramDb, lookupProgramVersion) +import Distribution.Simple.Program.HcPkg (dump) import Distribution.System (Arch(..), OS(..)) import qualified Distribution.Text as DT import qualified Distribution.Types.CondTree as C import Distribution.Types.Dependency (depPkgName, depVerRange, Dependency(..)) import Distribution.Types.ExeDependency (ExeDependency(..)) +import Distribution.Types.UnitId import Distribution.Types.UnqualComponentName (unqualComponentNameToPackageName) -import Distribution.Types.VersionRange (withinRange, VersionRange) +import Distribution.Types.VersionRange (thisVersion, withinRange, VersionRange) +import Distribution.Verbosity (silent) import Pantry -import Path.IO (resolveFile') import RIO hiding (display) import RIO.List (find, partition) import qualified RIO.Map as Map @@ -127,23 +135,18 @@ checkDependencyGraph :: -> RawSnapshot -> RIO env () checkDependencyGraph constraints snapshot = do - globalHintsYaml <- resolveFile' "global-hints.yaml" let compiler = rsCompiler snapshot compilerVer = case compiler of WCGhc v -> v WCGhcjs _ _ -> error "GHCJS is not supported" - mhints <- loadGlobalHints globalHintsYaml compiler - ghcBootPackages <- case mhints of - Nothing -> - error $ "Cannot load global hints for GHC " <> DT.display compilerVer - Just hints -> - return $ Map.map Just hints - let declared = + let snapshotPackages = Map.fromList [ (pn, snapshotVersion (rspLocation sp)) | (pn, sp) <- Map.toList (rsPackages snapshot) - ] <> - ghcBootPackages + ] + ghcBootPackages0 <- liftIO $ getBootPackages compilerVer + let ghcBootPackages = prunedBootPackages ghcBootPackages0 (Map.keysSet snapshotPackages) + declared = snapshotPackages <> Map.map (Just . bpVersion) ghcBootPackages cabalName = "Cabal" cabalError err = pure . Map.singleton cabalName $ [OtherError err] pkgErrors <- case Map.lookup cabalName declared of @@ -152,18 +155,28 @@ checkDependencyGraph constraints snapshot = do Just Nothing -> cabalError "Cabal version in snapshot is not defined" Just (Just cabalVersion) -> do - pkgInfos <- Map.traverseWithKey (getPkgInfo constraints compilerVer) - (rsPackages snapshot) - let depTree = - Map.map (piVersion &&& piTreeDeps) pkgInfos - <> Map.map (, []) ghcBootPackages - return $ Map.mapWithKey (validateDeps constraints depTree cabalVersion) pkgInfos + let isWiredIn pn _ = pn `Set.member` wiredInGhcPackages + (wiredIn, packages) = + Map.partitionWithKey isWiredIn (rsPackages snapshot) + if not (Map.null wiredIn) + then do + let errMsg = "GHC wired-in package can not be overriden" + pure $ Map.map (const [OtherError errMsg]) wiredIn + else do + pkgInfos <- Map.traverseWithKey (getPkgInfo constraints compilerVer) + packages + let depTree = + Map.map (piVersion &&& piTreeDeps) pkgInfos + <> Map.map ((, []) . Just . bpVersion) ghcBootPackages + return $ Map.mapWithKey (validatePackage constraints depTree cabalVersion) pkgInfos let (rangeErrors, otherErrors) = splitErrors pkgErrors + rangeErrors' = + Map.mapWithKey (\(pname, _, _) bs -> (Map.member pname ghcBootPackages0, bs)) rangeErrors unless (Map.null rangeErrors && Map.null otherErrors) $ - throwM (BrokenDependencyGraph rangeErrors otherErrors) + throwM (BrokenDependencyGraph rangeErrors' otherErrors) data BrokenDependencyGraph = BrokenDependencyGraph - (Map (PackageName, Set Text, Maybe Version) (Map DependingPackage DepBounds)) + (Map (PackageName, Set Text, Maybe Version) (Bool, Map DependingPackage DepBounds)) (Map PackageName (Seq String)) instance Exception BrokenDependencyGraph @@ -175,8 +188,8 @@ instance Show BrokenDependencyGraph where shownOtherErrors where shownBoundsErrors = - flip map (Map.toList rangeErrors) $ \((dep, maintainers, mver), users) -> - pkgBoundsError dep maintainers mver users + flip map (Map.toList rangeErrors) $ \((dep, maintainers, mver), (isBoot, users)) -> + pkgBoundsError dep maintainers mver isBoot users shownOtherErrors = flip map (Map.toList otherErrors) $ \(pname, errors) -> T.unlines $ T.pack (packageNameString pname) : flip map (toList errors) (\err -> " " <> fromString err) @@ -185,9 +198,10 @@ pkgBoundsError :: PackageName -> Set Text -> Maybe Version + -> Bool -> Map DependingPackage DepBounds -> Text -pkgBoundsError dep maintainers mdepVer users = +pkgBoundsError dep maintainers mdepVer isBoot users = T.unlines $ "" : showDepVer : map showUser (Map.toList users) @@ -199,7 +213,9 @@ pkgBoundsError dep maintainers mdepVer users = ] | otherwise = T.concat [ display dep, displayMaintainers maintainers - , " (not present) depended on by:" + , " (not present" + , if isBoot then ", GHC boot library" else "" + , ") depended on by:" ] displayMaintainers ms | Set.null ms = "" @@ -296,6 +312,15 @@ splitErrors = Map.foldrWithKey go (mempty, mempty) res , oes) +targetOS :: OS +targetOS = Linux + +targetArch :: Arch +targetArch = X86_64 + +targetFlavor :: CompilerFlavor +targetFlavor = GHC + checkConditions :: (Monad m) => Version @@ -304,21 +329,18 @@ checkConditions :: -> C.ConfVar -> m Bool checkConditions compilerVer pname flags confVar = - let targetOS = Linux - targetArch = X86_64 - targetFlavor = GHC - in case confVar of - C.OS os -> return $ os == targetOS - C.Arch arch -> return $ arch == targetArch - C.Flag flag -> - case Map.lookup flag flags of - Nothing -> - error $ - "Flag " <> show flag <> " for " <> show pname <> - " is not defined" - Just b -> return b - C.Impl flavor range -> - return $ (flavor == targetFlavor) && (compilerVer `withinRange` range) + case confVar of + C.OS os -> return $ os == targetOS + C.Arch arch -> return $ arch == targetArch + C.Flag flag -> + case Map.lookup flag flags of + Nothing -> + error $ + "Flag " <> show flag <> " for " <> show pname <> + " is not defined" + Just b -> return b + C.Impl flavor range -> + return $ (flavor == targetFlavor) && (compilerVer `withinRange` range) getPkgInfo :: (HasProcessContext env, HasLogFunc env, HasPantryConfig env) @@ -381,14 +403,14 @@ getPkgInfo constraints compilerVer pname rsp = do , piGithubPings = applyGithubMapping constraints $ getGithubPings gpd } -validateDeps :: +validatePackage :: Constraints -> Map PackageName (Maybe Version, [PackageName]) -> Version -> PackageName -> PkgInfo -> [DependencyError] -validateDeps constraints depTree cabalVersion pname pkg = +validatePackage constraints depTree cabalVersion pname pkg = checkCabalVersion <> checkCycles <> catMaybes [ checkDependency component dep | (component, deps) <- piAllDeps pkg @@ -465,3 +487,52 @@ occursCheck allPackages = go | pname' /= pname -> go pname' deps' seen' _ -> [] where seen' = Set.insert pname seen + +data BootPackage = BootPackage + { bpName :: !PackageName + , bpVersion :: !Version + , bpId :: !UnitId + , bpDepends :: ![UnitId] + } + +getBootPackages :: Version -> IO (Map PackageName BootPackage) +getBootPackages ghcVersion = do + db <- configureAllKnownPrograms silent defaultProgramDb + rslt <- lookupProgramVersion silent ghcProgram (thisVersion ghcVersion) db + case rslt of + Left err -> error $ "Can't get proper GHC version: " ++ err + Right _ -> return () + let toBootPackage ipi = + let PackageIdentifier name version = sourcePackageId ipi + in (name, BootPackage name version (installedUnitId ipi) (depends ipi)) + Map.fromList . map toBootPackage <$> dump (hcPkgInfo db) silent GlobalPackageDB + +prunedBootPackages :: + Map PackageName BootPackage + -> Set PackageName + -> Map PackageName BootPackage +prunedBootPackages ghcBootPackages0 overrides = + snd $ + partitionReplacedDependencies + ghcBootPackages0 + bpName + bpId + bpDepends + overrides + +-- | GHC wired-in packages, list taken from Stack.Constants +-- see also ghc\/compiler\/basicTypes\/Module.hs +wiredInGhcPackages :: Set PackageName +wiredInGhcPackages = + Set.fromList + [ "ghc-prim" + , "integer-gmp" + , "integer-simple" + , "base" + , "rts" + , "template-haskell" + , "dph-seq" + , "dph-par" + , "ghc" + , "interactive" + ] diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index dc08d53736..a526245211 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -61,6 +61,7 @@ dependencies: - text-metrics - resourcet - rio-prettyprint +- mtl # FIXME remove when we drop store - integer-gmp diff --git a/subs/pantry/pantry.cabal b/subs/pantry/pantry.cabal index 448815e3cb..147beb3578 100644 --- a/subs/pantry/pantry.cabal +++ b/subs/pantry/pantry.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 097f1c956c3050b63f58c0a2ce38f9eebb02d7e1bfabc081d945a42936608f8b +-- hash: e07cbc430962c6f97d47cabc25ad162a437b0286c8c77ff49ce54337ebedac86 name: pantry version: 0.1.0.0 @@ -82,6 +82,7 @@ library , integer-gmp , memory , mono-traversable + , mtl , network , network-uri , path @@ -181,6 +182,7 @@ test-suite spec , integer-gmp , memory , mono-traversable + , mtl , network , network-uri , pantry diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index ded266482c..d6d08fcf7d 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -159,10 +159,12 @@ module Pantry , getLatestHackageRevision , getHackageTypoCorrections , loadGlobalHints + , partitionReplacedDependencies ) where import RIO import Conduit +import Control.Monad.State.Strict (State, execState, get, modify') import qualified RIO.Map as Map import qualified RIO.Set as Set import qualified RIO.ByteString as B @@ -1467,3 +1469,48 @@ loadGlobalHints dest wc = inner2 = liftIO $ Map.lookup wc . fmap (fmap unCabalString . unCabalStringMap) <$> Yaml.decodeFileThrow (toFilePath dest) + +-- | Partition a map of global packages with its versions into a Set of +-- replaced packages and its dependencies and a map of remaining (untouched) packages. +-- +-- @since 0.1.0.0 +partitionReplacedDependencies :: + Ord id + => Map PackageName a -- ^ global packages + -> (a -> PackageName) -- ^ package name getter + -> (a -> id) -- ^ returns unique package id used for dependency pruning + -> (a -> [id]) -- ^ returns unique package ids of direct package dependencies + -> Set PackageName -- ^ overrides which global dependencies should get pruned + -> (Map PackageName [PackageName], Map PackageName a) +partitionReplacedDependencies globals getName getId getDeps overrides = + flip execState (replaced, mempty) $ + for (Map.toList globals) $ prunePackageWithDeps globals' getName getDeps + where + globals' = Map.fromList $ map (getId &&& id) (Map.elems globals) + replaced = Map.map (const []) $ Map.restrictKeys globals overrides + +prunePackageWithDeps :: + Ord id + => Map id a + -> (a -> PackageName) + -> (a -> [id]) + -> (PackageName, a) + -> State (Map PackageName [PackageName], Map PackageName a) Bool +prunePackageWithDeps pkgs getName getDeps (pname, a) = do + (pruned, kept) <- get + if Map.member pname pruned + then return True + else if Map.member pname kept + then return False + else do + let deps = Map.elems $ Map.restrictKeys pkgs (Set.fromList $ getDeps a) + prunedDeps <- forMaybeM deps $ \dep -> do + let depName = getName dep + isPruned <- prunePackageWithDeps pkgs getName getDeps (depName, dep) + pure $ if isPruned then Just depName else Nothing + if null prunedDeps + then do + modify' $ second (Map.insert pname a) + else do + modify' $ first (Map.insert pname prunedDeps) + return $ not (null prunedDeps) diff --git a/test/integration/tests/345-override-bytestring/files/stack.yaml b/test/integration/tests/345-override-bytestring/files/stack.yaml index 39105962ad..57f27dba10 100644 --- a/test/integration/tests/345-override-bytestring/files/stack.yaml +++ b/test/integration/tests/345-override-bytestring/files/stack.yaml @@ -1,5 +1,6 @@ resolver: lts-11.22 extra-deps: - bytestring-0.10.6.0 +- binary-0.7.5.0 packages: - .