Remove globals that do not have their deps met commercialhaskell#949

snoyberg · snoyberg · commit efe11b2d33a5 · 2015-09-08T14:21:31.000+03:00
diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs
@@ -99,7 +99,7 @@ build setLocalFiles mbuildLk bopts = do
     if boptsDryrun bopts
         then printPlan plan
         else executePlan menv bopts baseConfigOpts locals
-                         (Map.fromList $ map (\(x, y) -> (y, x)) $ Map.toList globallyRegistered)
+                         globallyRegistered
                          sourceMap
                          installedMap
                          plan
diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs
@@ -17,6 +17,7 @@ module Stack.Build.Execute
     ) where
 
 import           Control.Applicative
+import           Control.Arrow ((&&&))
 import           Control.Concurrent.Execute
 import           Control.Concurrent.Async       (withAsync, wait)
 import           Control.Concurrent.MVar.Lifted
@@ -69,6 +70,7 @@ import           Stack.Types.Build
 import           Stack.Fetch                    as Fetch
 import           Stack.GhcPkg
 import           Stack.Package
+import           Stack.PackageDump
 import           Stack.Constants
 import           Stack.Types
 import           Stack.Types.StackT
@@ -205,7 +207,7 @@ data ExecuteEnv = ExecuteEnv
     , eeLocals         :: ![LocalPackage]
     , eeSourceMap      :: !SourceMap
     , eeGlobalDB       :: !(Path Abs Dir)
-    , eeGlobalPackages :: !(Map PackageIdentifier GhcPkgId)
+    , eeGlobalPackages :: ![DumpPackage () ()]
     }
 
 -- | Get a compiled Setup exe
@@ -278,7 +280,7 @@ withExecuteEnv :: M env m
                -> BuildOpts
                -> BaseConfigOpts
                -> [LocalPackage]
-               -> Map PackageIdentifier GhcPkgId -- ^ global packages
+               -> [DumpPackage () ()] -- ^ global packages
                -> SourceMap
                -> (ExecuteEnv -> m a)
                -> m a
@@ -322,7 +324,7 @@ executePlan :: M env m
             -> BuildOpts
             -> BaseConfigOpts
             -> [LocalPackage]
-            -> Map PackageIdentifier GhcPkgId -- ^ globals
+            -> [DumpPackage () ()] -- ^ globals
             -> SourceMap
             -> InstalledMap
             -> Plan
@@ -701,19 +703,10 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
                         Just deps ->
                             -- Stack always builds with the global Cabal for various
                             -- reproducibility issues.
-                            let depsMinusCabal = filter (not . isPrefixOf "Cabal-")
-                                                 . map ghcPkgIdString
-                                                 . Map.elems
-                                                 . uniqueByName
-                                                 $ Map.union deps eeGlobalPackages
-                                    -- We also provide all global packages to
-                                    -- the Setup.hs file, see:
-                                    -- https://github.com/commercialhaskell/stack/issues/941
-
-                                -- We only want a single installation of each package name
-                                uniqueByName = Map.mapKeysWith
-                                    const
-                                    packageIdentifierName
+                            let depsMinusCabal
+                                 = map ghcPkgIdString
+                                 $ Set.toList
+                                 $ addGlobalPackages deps eeGlobalPackages
                             in
                               "-clear-package-db"
                             : "-global-package-db"
@@ -1289,3 +1282,71 @@ extraBuildOptions :: M env m => m [String]
 extraBuildOptions = do
     hpcIndexDir <- toFilePath . (</> dotHpc) <$> hpcRelativeDir
     return ["--ghc-options", "-hpcdir " ++ hpcIndexDir ++ " -ddump-hi -ddump-to-file"]
+
+-- | Take the given list of package dependencies and the contents of the global
+-- package database, and construct a set of installed package IDs that:
+--
+-- * Excludes the Cabal library (it's added later)
+--
+-- * Includes all packages depended on by this package
+--
+-- * Includes all global packages, unless: (1) it's hidden, (2) it's shadowed
+--   by a depended-on package, or (3) one of its dependencies is not met.
+--
+-- See:
+--
+-- * https://github.com/commercialhaskell/stack/issues/941
+--
+-- * https://github.com/commercialhaskell/stack/issues/944
+--
+-- * https://github.com/commercialhaskell/stack/issues/949
+addGlobalPackages :: Map PackageIdentifier GhcPkgId -- ^ dependencies of the package
+                  -> [DumpPackage () ()] -- ^ global packages
+                  -> Set GhcPkgId
+addGlobalPackages deps globals0 =
+    res
+  where
+    -- Initial set of packages: the installed IDs of all dependencies
+    res0 = Map.elems $ Map.filterWithKey (\ident _ -> not $ isCabal ident) deps
+
+    -- First check on globals: it's not shadowed by a dep, it's not Cabal, and
+    -- it's exposed
+    goodGlobal1 dp = not (isDep dp)
+                  && not (isCabal $ dpPackageIdent dp)
+                  && dpIsExposed dp
+    globals1 = filter goodGlobal1 globals0
+
+    -- Create a Map of unique package names in the global database
+    globals2 = Map.fromListWith chooseBest
+             $ map (packageIdentifierName . dpPackageIdent &&& id) globals1
+
+    -- Final result: add in globals that have their dependencies met
+    res = loop id (Map.elems globals2) $ Set.fromList res0
+
+    ----------------------------------
+    -- Some auxiliary helper functions
+    ----------------------------------
+
+    -- Is the given package identifier for any version of Cabal
+    isCabal (PackageIdentifier name _) = name == $(mkPackageName "Cabal")
+
+    -- Is the given package name provided by the package dependencies?
+    isDep dp = packageIdentifierName (dpPackageIdent dp) `Set.member` depNames
+    depNames = Set.map packageIdentifierName $ Map.keysSet deps
+
+    -- Choose the best of two competing global packages (the newest version)
+    chooseBest dp1 dp2
+        | getVer dp1 < getVer dp2 = dp2
+        | otherwise               = dp1
+      where
+        getVer = packageIdentifierVersion . dpPackageIdent
+
+    -- Are all dependencies of the given package met by the given Set of
+    -- installed packages
+    depsMet dp gids = all (`Set.member` gids) (dpDepends dp)
+
+    -- Find all globals that have all of their dependencies met
+    loop _ [] gids = gids
+    loop front (dp:dps) gids
+        | depsMet dp gids = loop id (front dps) (Set.insert (dpGhcPkgId dp) gids)
+        | otherwise = loop (front . (dp:)) dps gids
diff --git a/src/Stack/Build/Installed.hs b/src/Stack/Build/Installed.hs
@@ -57,15 +57,13 @@ data GetInstalledOpts = GetInstalledOpts
       -- ^ Require haddocks?
     }
 
-type IsExposed = Bool
-
 -- | Returns the new InstalledMap and all of the locally registered packages.
 getInstalled :: (M env m, PackageInstallInfo pii)
              => EnvOverride
              -> GetInstalledOpts
              -> Map PackageName pii -- ^ does not contain any installed information
              -> m ( InstalledMap
-                  , Map GhcPkgId PackageIdentifier -- globally installed
+                  , [DumpPackage () ()] -- globally installed
                   , Map GhcPkgId PackageIdentifier -- locally installed
                   )
 getInstalled menv opts sourceMap = do
@@ -114,8 +112,8 @@ getInstalled menv opts sourceMap = do
             ]
 
     return ( installedMap
-           , Map.map fst $ Map.filter snd globalInstalled
-           , Map.map fst localInstalled
+           , globalInstalled
+           , Map.fromList $ map (dpGhcPkgId &&& dpPackageIdent) localInstalled
            )
 
 -- | Outputs both the modified InstalledMap and the Set of all installed packages in this database
@@ -130,18 +128,18 @@ loadDatabase :: (M env m, PackageInstallInfo pii)
              -> Map PackageName pii -- ^ to determine which installed things we should include
              -> Maybe (InstallLocation, Path Abs Dir) -- ^ package database, Nothing for global
              -> [LoadHelper] -- ^ from parent databases
-             -> m ([LoadHelper], Map GhcPkgId (PackageIdentifier, IsExposed))
+             -> m ([LoadHelper], [DumpPackage () ()])
 loadDatabase menv opts mcache sourceMap mdb lhs0 = do
     wc <- getWhichCompiler
-    (lhs1, gids) <- ghcPkgDump menv wc (fmap snd mdb)
+    (lhs1, dps) <- ghcPkgDump menv wc (fmap snd mdb)
                   $ conduitDumpPackage =$ sink
     let lhs = pruneDeps
             id
             lhId
             lhDeps
             const
             (lhs0 ++ lhs1)
-    return (map (\lh -> lh { lhDeps = [] }) $ Map.elems lhs, Map.fromList gids)
+    return (map (\lh -> lh { lhDeps = [] }) $ Map.elems lhs, dps)
   where
     conduitProfilingCache =
         case mcache of
@@ -159,10 +157,9 @@ loadDatabase menv opts mcache sourceMap mdb lhs0 = do
           =$ conduitHaddockCache
           =$ CL.mapMaybe (isAllowed opts mcache sourceMap (fmap fst mdb))
           =$ CL.consume
-    sinkGIDs = CL.map (dpGhcPkgId &&& (dpPackageIdent &&& dpIsExposed)) =$ CL.consume
     sink = getZipSink $ (,)
         <$> ZipSink sinkDP
-        <*> ZipSink sinkGIDs
+        <*> ZipSink CL.consume
 
 -- | Check if a can be included in the set of installed packages or not, based
 -- on the package selections made by the user. This does not perform any
diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs
@@ -114,7 +114,7 @@ getSDistFileList lp =
         (_, _mbp, locals, _extraToBuild, sourceMap) <- loadSourceMap NeedTargets bopts
         runInBase <- liftBaseWith $ \run -> return (void . run)
         withExecuteEnv menv bopts baseConfigOpts locals
-            Map.empty -- provide empty list of globals. This is a hack around custom Setup.hs files
+            [] -- provide empty list of globals. This is a hack around custom Setup.hs files
             sourceMap $ \ee -> do
             withSingleContext runInBase ac ee task Nothing (Just "sdist") $ \_package _cabalfp _pkgDir cabal _announce _console _mlogFile -> do
                 let outFile = tmpdir FP.</> "source-files-list"
