Use a hard-coded tool dependency map (fixes #4125)

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).
 
 Other enhancements:
 

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 [])
@@ -236,23 +232,18 @@ 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
         , getVersions = runRIO econfig . getPackageVersions
         , 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.
@@ -375,13 +366,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
--- <https://github.com/commercialhaskell/stack/issues/2195>
-data DepType = AsLibrary | AsBuildTool
-  deriving (Show, Eq)
-
 -- | Given a 'PackageName', adds all of the build tasks to build the
 -- package, if needed.
 --
@@ -623,7 +607,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
@@ -850,61 +834,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

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

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

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,54 @@ 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 = map 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 -> (PackageName, DepValue)
+        go2 (Cabal.ExeDependency pkg _name range) =
+          ( 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")
+  , ("gtk2hsC2hs", Distribution.Package.mkPackageName "gtk2hs-buildtools")
+  , ("gtk2hsHookGenerator", Distribution.Package.mkPackageName "gtk2hs-buildtools")
+  , ("gtk2hsTypeGen", Distribution.Package.mkPackageName "gtk2hs-buildtools")
+  ]
 
 -- | Variant of 'allBuildInfo' from Cabal that, like versions before
 -- 2.2, only includes buildable components.