diff --git a/ChangeLog.md b/ChangeLog.md index 7f2c1e1171..3801155118 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -28,6 +28,13 @@ Behavior changes: [help file](https://github.com/commercialhaskell/stack-templates/blob/master/STACK_HELP.md) with more information on how to discover templates. See: [#4039](https://github.com/commercialhaskell/stack/issues/4039) +* Build tools are now handled in a similar way to `cabal-install`. In + particular, for legacy `build-tools` fields, we use a hard-coded + list of build tools in place of looking up build tool packages in a + tool map. This both brings Stack's behavior closer into line with + `cabal-install`, avoids some bugs, and opens up some possible + optimizations/laziness. See: + [#4125](https://github.com/commercialhaskell/stack/issues/4125). * Mustache templating is not applied to large files (over 50kb) to avoid performance degredation. See: [#4133](https://github.com/commercialhaskell/stack/issues/4133). diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index f1ad973844..d219acaf40 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -40,8 +40,6 @@ import Stack.Build.Cache import Stack.Build.Haddock import Stack.Build.Installed import Stack.Build.Source -import Stack.BuildPlan -import Stack.Config (getLocalPackages) import Stack.Constants import Stack.Package import Stack.PackageDump @@ -133,7 +131,6 @@ data Ctx = Ctx , baseConfigOpts :: !BaseConfigOpts , loadPackage :: !(PackageLocationIndex FilePath -> Map FlagName Bool -> [Text] -> M Package) , combinedMap :: !CombinedMap - , toolToPackages :: !(ExeName -> Map PackageName VersionRange) , ctxEnvConfig :: !EnvConfig , callStack :: ![PackageName] , extraToBuild :: !(Set PackageName) @@ -196,8 +193,7 @@ constructPlan ls0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage let inner = do mapM_ onWanted $ filter lpWanted locals mapM_ (addDep False) $ Set.toList extraToBuild0 - lp <- getLocalPackages - let ctx = mkCtx econfig lp + let ctx = mkCtx econfig ((), m, W efinals installExes dirtyReason deps warnings parents) <- liftIO $ runRWST inner ctx M.empty mapM_ (logWarn . RIO.display) (warnings []) @@ -237,14 +233,11 @@ constructPlan ls0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage elem $(mkPackageName "base") $ map (packageIdentifierName . pirIdent) [i | (PLIndex i) <- bcDependencies bconfig] - mkCtx econfig lp = Ctx + mkCtx econfig = Ctx { ls = ls0 , baseConfigOpts = baseConfigOpts0 , loadPackage = \x y z -> runRIO econfig $ loadPackage0 x y z , combinedMap = combineMap sourceMap installedMap - , toolToPackages = \name -> - maybe Map.empty (Map.fromSet (const Cabal.anyVersion)) $ - Map.lookup name toolMap , ctxEnvConfig = econfig , callStack = [] , extraToBuild = extraToBuild0 @@ -252,8 +245,6 @@ constructPlan ls0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage , wanted = wantedLocalPackages locals <> extraToBuild0 , localNames = Set.fromList $ map (packageName . lpPackage) locals } - where - toolMap = getToolMap ls0 lp -- | State to be maintained during the calculation of local packages -- to unregister. @@ -376,13 +367,6 @@ addFinal lp package isAllInOne = do } tell mempty { wFinals = Map.singleton (packageName package) res } --- | Is this package being used as a library, or just as a build tool? --- If the former, we need to ensure that a library actually --- exists. See --- -data DepType = AsLibrary | AsBuildTool - deriving (Show, Eq) - -- | Given a 'PackageName', adds all of the build tasks to build the -- package, if needed. -- @@ -624,7 +608,7 @@ addPackageDeps :: Bool -- ^ is this being used by a dependency? addPackageDeps treatAsDep package = do ctx <- ask deps' <- packageDepsWithTools package - deps <- forM (Map.toList deps') $ \(depname, (range, depType)) -> do + deps <- forM (Map.toList deps') $ \(depname, DepValue range depType) -> do eres <- addDep treatAsDep depname let getLatestApplicableVersionAndRev = do vsAndRevs <- liftIO $ getVersions ctx depname @@ -851,61 +835,32 @@ psLocal PSIndex{} = False -- | Get all of the dependencies for a given package, including build -- tool dependencies. -packageDepsWithTools :: Package -> M (Map PackageName (VersionRange, DepType)) +packageDepsWithTools :: Package -> M (Map PackageName DepValue) packageDepsWithTools p = do - ctx <- ask - let toEither name mp = - case Map.toList mp of - [] -> Left (ToolWarning name (packageName p) Nothing) - [_] -> Right mp - ((x, _):(y, _):zs) -> - Left (ToolWarning name (packageName p) (Just (x, y, map fst zs))) - (warnings0, toolDeps) = - partitionEithers $ - map (\dep -> toEither dep (toolToPackages ctx dep)) (Map.keys (packageTools p)) -- Check whether the tool is on the PATH before warning about it. - warnings <- fmap catMaybes $ forM warnings0 $ \warning@(ToolWarning (ExeName toolName) _ _) -> do + warnings <- fmap catMaybes $ forM (Set.toList $ packageUnknownTools p) $ + \name@(ExeName toolName) -> do let settings = minimalEnvSettings { esIncludeLocals = True } config <- view configL menv <- liftIO $ configProcessContextSettings config settings mfound <- runRIO menv $ findExecutable $ T.unpack toolName case mfound of - Left _ -> return (Just warning) + Left _ -> return $ Just $ ToolWarning name (packageName p) Right _ -> return Nothing tell mempty { wWarnings = (map toolWarningText warnings ++) } - return $ Map.unionsWith - (\(vr1, dt1) (vr2, dt2) -> - ( intersectVersionRanges vr1 vr2 - , case dt1 of - AsLibrary -> AsLibrary - AsBuildTool -> dt2 - ) - ) - $ ((, AsLibrary) <$> packageDeps p) - : (Map.map (, AsBuildTool) <$> toolDeps) + return $ packageDeps p -- | Warn about tools in the snapshot definition. States the tool name --- expected, the package name using it, and found packages. If the --- last value is Nothing, it means the tool was not found --- anywhere. For a Just value, it was found in at least two packages. -data ToolWarning = ToolWarning ExeName PackageName (Maybe (PackageName, PackageName, [PackageName])) +-- expected and the package name using it. +data ToolWarning = ToolWarning ExeName PackageName deriving Show toolWarningText :: ToolWarning -> Text -toolWarningText (ToolWarning (ExeName toolName) pkgName Nothing) = +toolWarningText (ToolWarning (ExeName toolName) pkgName) = "No packages found in snapshot which provide a " <> T.pack (show toolName) <> " executable, which is a build-tool dependency of " <> T.pack (show (packageNameString pkgName)) -toolWarningText (ToolWarning (ExeName toolName) pkgName (Just (option1, option2, options))) = - "Multiple packages found in snapshot which provide a " <> - T.pack (show toolName) <> - " executable, which is a build-tool dependency of " <> - T.pack (show (packageNameString pkgName)) <> - ", so none will be installed.\n" <> - "Here's the list of packages which provide it: " <> - T.intercalate ", " (map packageNameText (option1:option2:options)) <> - "\nSince there's no good way to choose, you may need to install it manually." -- | Strip out anything from the @Plan@ intended for the local database stripLocals :: Plan -> Plan diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index 6defa8f6a0..b4c5777ba1 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -286,8 +286,8 @@ loadLocalPackage isLocal boptsCli targets (name, lpv) = do return LocalPackage { lpPackage = pkg - , lpTestDeps = packageDeps testpkg - , lpBenchDeps = packageDeps benchpkg + , lpTestDeps = dvVersionRange <$> packageDeps testpkg + , lpBenchDeps = dvVersionRange <$> packageDeps benchpkg , lpTestBench = btpkg , lpComponentFiles = componentFiles , lpForceDirty = boptsForceDirty bopts diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index f88fbb19dc..cf068b573b 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -20,7 +20,6 @@ module Stack.BuildPlan , gpdPackages , removeSrcPkgDefaultFlags , selectBestSnapshot - , getToolMap , showItems ) where @@ -36,10 +35,8 @@ import qualified Data.Text as T import qualified Distribution.Package as C import Distribution.PackageDescription (GenericPackageDescription, flagDefault, flagManual, - flagName, genPackageFlags, - condExecutables) + flagName, genPackageFlags) import qualified Distribution.PackageDescription as C -import qualified Distribution.Types.UnqualComponentName as C import Distribution.System (Platform) import Distribution.Text (display) import qualified Distribution.Version as C @@ -49,7 +46,6 @@ import Stack.Package import Stack.Snapshot import Stack.Types.BuildPlan import Stack.Types.FlagName -import Stack.Types.NamedComponent import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version @@ -145,47 +141,6 @@ instance Show BuildPlanException where T.unpack url ++ ", because no 'compiler' or 'resolver' is specified." --- | Map from tool name to package providing it. This accounts for --- both snapshot and local packages (deps and project packages). -getToolMap :: LoadedSnapshot - -> LocalPackages - -> Map ExeName (Set PackageName) -getToolMap ls locals = - - {- We no longer do this, following discussion at: - - https://github.com/commercialhaskell/stack/issues/308#issuecomment-112076704 - - -- First grab all of the package names, for times where a build tool is - -- identified by package name - $ Map.fromList (map (packageNameByteString &&& Set.singleton) (Map.keys ps)) - -} - - Map.unionsWith Set.union $ concat - [ concatMap goSnap $ Map.toList $ lsPackages ls - , concatMap goLocalProj $ Map.toList $ lpProject locals - , concatMap goLocalDep $ Map.toList $ lpDependencies locals - ] - where - goSnap (pname, lpi) = - map (flip Map.singleton (Set.singleton pname)) - $ Set.toList - $ lpiProvidedExes lpi - - goLocalProj (pname, lpv) = - map (flip Map.singleton (Set.singleton pname)) - [ExeName t | CExe t <- Set.toList (lpvComponents lpv)] - - goLocalDep (pname, (gpd, _loc)) = - map (flip Map.singleton (Set.singleton pname)) - $ gpdExes gpd - - -- TODO consider doing buildable checking. Not a big deal though: - -- worse case scenario is we build an extra package that wasn't - -- strictly needed. - gpdExes :: GenericPackageDescription -> [ExeName] - gpdExes = map (ExeName . T.pack . C.unUnqualComponentName . fst) . condExecutables - gpdPackages :: [GenericPackageDescription] -> Map PackageName Version gpdPackages gpds = Map.fromList $ map (fromCabalIdent . C.package . C.packageDescription) gpds diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index d452e51739..c9f15dfc7e 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -31,7 +31,6 @@ module Stack.Package ,buildLogPath ,PackageException (..) ,resolvePackageDescription - ,packageDescTools ,packageDependencies ,cabalFilePackageId ,gpdPackageIdentifier @@ -41,7 +40,7 @@ module Stack.Package import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Char8 as CL8 -import Data.List (isSuffixOf, isPrefixOf) +import Data.List (isSuffixOf, isPrefixOf, unzip) import Data.Maybe (maybe) import qualified Data.Map.Strict as M import qualified Data.Set as S @@ -264,7 +263,7 @@ packageFromPackageDescription packageConfig pkgFlags (PackageDescriptionPair pkg , packageLicense = licenseRaw pkg , packageDeps = deps , packageFiles = pkgFiles - , packageTools = packageDescTools pkg + , packageUnknownTools = unknownTools , packageGhcOptions = packageConfigGhcOptions packageConfig , packageFlags = packageConfigFlags packageConfig , packageDefaultFlags = M.fromList @@ -364,18 +363,28 @@ packageFromPackageDescription packageConfig pkgFlags (PackageDescriptionPair pkg return (componentModules, componentFiles, buildFiles <> dataFiles', warnings) pkgId = package pkg name = fromCabalPackageName (pkgName pkgId) - deps = M.filterWithKey (const . not . isMe) (M.union - (packageDependencies packageConfig pkg) + + (unknownTools, knownTools) = packageDescTools pkg + + deps = M.filterWithKey (const . not . isMe) (M.unionsWith (<>) + [ asLibrary <$> packageDependencies packageConfig pkg -- We include all custom-setup deps - if present - in the -- package deps themselves. Stack always works with the -- invariant that there will be a single installed package -- relating to a package name, and this applies at the setup -- dependency level as well. - (fromMaybe M.empty msetupDeps)) + , asLibrary <$> fromMaybe M.empty msetupDeps + , knownTools + ]) msetupDeps = fmap (M.fromList . map (depName &&& depRange) . setupDepends) (setupBuildInfo pkg) + asLibrary range = DepValue + { dvVersionRange = range + , dvType = AsLibrary + } + -- Is the package dependency mentioned here me: either the package -- name itself, or the name of one of the sub libraries isMe name' = name' == name || packageNameText name' `S.member` extraLibNames @@ -678,17 +687,67 @@ packageDependencies pkgConfig pkg' = -- -- This uses both the new 'buildToolDepends' and old 'buildTools' -- information. -packageDescTools :: PackageDescription -> Map ExeName VersionRange -packageDescTools = - M.fromList . concatMap tools . allBuildInfo' +packageDescTools + :: PackageDescription + -> (Set ExeName, Map PackageName DepValue) +packageDescTools pd = + (S.fromList $ concat unknowns, M.fromListWith (<>) $ concat knowns) where - tools bi = map go1 (buildTools bi) ++ map go2 (buildToolDepends bi) - - go1 :: Cabal.LegacyExeDependency -> (ExeName, VersionRange) - go1 (Cabal.LegacyExeDependency name range) = (ExeName $ T.pack name, range) + (unknowns, knowns) = unzip $ map perBI $ allBuildInfo' pd - go2 :: Cabal.ExeDependency -> (ExeName, VersionRange) - go2 (Cabal.ExeDependency _pkg name range) = (ExeName $ T.pack $ Cabal.unUnqualComponentName name, range) + perBI :: BuildInfo -> ([ExeName], [(PackageName, DepValue)]) + perBI bi = + (unknownTools, tools) + where + (unknownTools, knownTools) = partitionEithers $ map go1 (buildTools bi) + + tools = mapMaybe go2 (knownTools ++ buildToolDepends bi) + + -- This is similar to desugarBuildTool from Cabal, however it + -- uses our own hard-coded map which drops tools shipped with + -- GHC (like hsc2hs), and includes some tools from Stackage. + go1 :: Cabal.LegacyExeDependency -> Either ExeName Cabal.ExeDependency + go1 (Cabal.LegacyExeDependency name range) = + case M.lookup name hardCodedMap of + Just pkgName -> Right $ Cabal.ExeDependency pkgName (Cabal.mkUnqualComponentName name) range + Nothing -> Left $ ExeName $ T.pack name + + go2 :: Cabal.ExeDependency -> Maybe (PackageName, DepValue) + go2 (Cabal.ExeDependency pkg _name range) + | pkg `S.member` preInstalledPackages = Nothing + | otherwise = Just + ( fromCabalPackageName pkg + , DepValue + { dvVersionRange = range + , dvType = AsBuildTool + } + ) + +-- | A hard-coded map for tool dependencies +hardCodedMap :: Map String D.PackageName +hardCodedMap = M.fromList + [ ("alex", Distribution.Package.mkPackageName "alex") + , ("happy", Distribution.Package.mkPackageName "happy") + , ("cpphs", Distribution.Package.mkPackageName "cpphs") + , ("greencard", Distribution.Package.mkPackageName "greencard") + , ("c2hs", Distribution.Package.mkPackageName "c2hs") + , ("hscolour", Distribution.Package.mkPackageName "hscolour") + , ("hspec-discover", Distribution.Package.mkPackageName "hspec-discover") + , ("hsx2hs", Distribution.Package.mkPackageName "hsx2hs") + , ("gtk2hsC2hs", Distribution.Package.mkPackageName "gtk2hs-buildtools") + , ("gtk2hsHookGenerator", Distribution.Package.mkPackageName "gtk2hs-buildtools") + , ("gtk2hsTypeGen", Distribution.Package.mkPackageName "gtk2hs-buildtools") + ] + +-- | Executable-only packages which come pre-installed with GHC and do +-- not need to be built. Without this exception, we would either end +-- up unnecessarily rebuilding these packages, or failing because the +-- packages do not appear in the Stackage snapshot. +preInstalledPackages :: Set D.PackageName +preInstalledPackages = S.fromList + [ D.mkPackageName "hsc2hs" + , D.mkPackageName "haddock" + ] -- | Variant of 'allBuildInfo' from Cabal that, like versions before -- 2.2, only includes buildable components. diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index 05db62e28d..81df12d45f 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -39,7 +39,6 @@ import Data.Yaml (decodeFileEither, ParseException (AesonException)) import Distribution.InstalledPackageInfo (PError) import Distribution.PackageDescription (GenericPackageDescription) import qualified Distribution.PackageDescription as C -import qualified Distribution.Types.UnqualComponentName as C import Distribution.System (Platform) import Distribution.Text (display) import qualified Distribution.Version as C @@ -579,8 +578,6 @@ fromGlobalHints = , lpiFlags = Map.empty , lpiGhcOptions = [] , lpiPackageDeps = Map.empty - , lpiProvidedExes = Set.empty - , lpiNeededExes = Map.empty , lpiExposedModules = Set.empty , lpiHide = False } @@ -654,8 +651,6 @@ loadCompiler cv = do , lpiFlags = Map.empty , lpiGhcOptions = [] , lpiPackageDeps = Map.unions $ map goDep $ dpDepends dp - , lpiProvidedExes = Set.empty - , lpiNeededExes = Map.empty , lpiExposedModules = Set.fromList $ map (ModuleName . encodeUtf8) $ dpExposedModules dp , lpiHide = not $ dpIsExposed dp } @@ -819,12 +814,6 @@ calculate gpd platform compilerVersion loc flags hide options = , lpiPackageDeps = Map.map fromVersionRange $ Map.filterWithKey (const . (/= name)) $ packageDependencies pconfig pd - , lpiProvidedExes = - Set.fromList - $ map (ExeName . T.pack . C.unUnqualComponentName . C.exeName) - $ C.executables pd - , lpiNeededExes = Map.map fromVersionRange - $ packageDescTools pd , lpiExposedModules = maybe Set.empty (Set.fromList . map fromCabalModuleName . C.exposedModules) diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index 04cf01e2e4..414788ddb6 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -310,7 +310,7 @@ instance Store LoadedSnapshot instance NFData LoadedSnapshot loadedSnapshotVC :: VersionConfig LoadedSnapshot -loadedSnapshotVC = storeVersionConfig "ls-v4" "a_ljrJRo8hA_-gcIDP9c6NXJ2pE=" +loadedSnapshotVC = storeVersionConfig "ls-v5" "CeSRWh1VU8v0__kwA__msbe6WlU=" -- | Information on a single package for the 'LoadedSnapshot' which -- can be installed. @@ -340,11 +340,6 @@ data LoadedPackageInfo loc = LoadedPackageInfo , lpiPackageDeps :: !(Map PackageName VersionIntervals) -- ^ All packages which must be built/copied/registered before -- this package. - , lpiProvidedExes :: !(Set ExeName) - -- ^ The names of executables provided by this package, for - -- performing build tool lookups. - , lpiNeededExes :: !(Map ExeName VersionIntervals) - -- ^ Executables needed by this package. , lpiExposedModules :: !(Set ModuleName) -- ^ Modules exposed by this package's library , lpiHide :: !Bool diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index 6eb77567ae..e6b403f76f 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -122,8 +122,8 @@ data Package = ,packageVersion :: !Version -- ^ Version of the package ,packageLicense :: !(Either SPDX.License License) -- ^ The license the package was released under. ,packageFiles :: !GetPackageFiles -- ^ Get all files of the package. - ,packageDeps :: !(Map PackageName VersionRange) -- ^ Packages that the package depends on. - ,packageTools :: !(Map ExeName VersionRange) -- ^ A build tool name. + ,packageDeps :: !(Map PackageName DepValue) -- ^ Packages that the package depends on, both as libraries and build tools. + ,packageUnknownTools :: !(Set ExeName) -- ^ Build tools specified in the legacy manner (build-tools:) that failed the hard-coded lookup. ,packageAllDeps :: !(Set PackageName) -- ^ Original dependencies (not sieved). ,packageGhcOptions :: ![Text] -- ^ Ghc options used on package. ,packageFlags :: !(Map FlagName Bool) -- ^ Flags used on package. @@ -141,6 +141,27 @@ data Package = } deriving (Show,Typeable) +-- | The value for a map from dependency name. This contains both the +-- version range and the type of dependency, and provides a semigroup +-- instance. +data DepValue = DepValue + { dvVersionRange :: !VersionRange + , dvType :: !DepType + } + deriving (Show,Typeable) +instance Semigroup DepValue where + DepValue a x <> DepValue b y = DepValue (intersectVersionRanges a b) (x <> y) + +-- | Is this package being used as a library, or just as a build tool? +-- If the former, we need to ensure that a library actually +-- exists. See +-- +data DepType = AsLibrary | AsBuildTool + deriving (Show, Eq) +instance Semigroup DepType where + AsLibrary <> _ = AsLibrary + AsBuildTool <> x = x + packageIdentifier :: Package -> PackageIdentifier packageIdentifier pkg = PackageIdentifier (packageName pkg) (packageVersion pkg)