Global DB usage

Stackage/GhcPkg.hs

@@ -0,0 +1,24 @@
+module Stackage.GhcPkg where
+
+import Stackage.Types
+import System.Process
+import           Distribution.Text (simpleParse)
+import Data.Char (isSpace)
+import qualified Data.Set as Set
+
+getGlobalPackages :: IO (Set PackageIdentifier)
+getGlobalPackages = do
+    output <- readProcess "ghc-pkg" ["--no-user-package-db", "list"] ""
+    fmap Set.unions $ mapM parse $ drop 1 $ lines output
+  where
+    parse s =
+        case clean s of
+            "" -> return Set.empty
+            s' ->
+                case simpleParse s' of
+                    Just x -> return $ Set.singleton x
+                    Nothing -> error $ "Could not parse ghc-pkg output: " ++ show s
+    clean = stripParens . dropWhile isSpace . reverse . dropWhile isSpace . reverse
+    stripParens x@('(':_:_)
+        | last x == ')' = tail $ init $ x
+    stripParens x = x

Stackage/InstallInfo.hs

@@ -9,12 +9,14 @@ import qualified Data.Map                 as Map
 import qualified Data.Set                 as Set
 import           Data.Version             (showVersion)
 import qualified Distribution.Text
+import           Distribution.Text        (display)
 import           Distribution.Version     (simplifyVersionRange, withinRange)
 import           Stackage.HaskellPlatform
 import           Stackage.LoadDatabase
 import           Stackage.NarrowDatabase
 import           Stackage.Types
 import           Stackage.Util
+import           Stackage.GhcPkg
 
 dropExcluded :: SelectSettings
              -> Map PackageName (VersionRange, Maintainer)
@@ -26,22 +28,34 @@ getInstallInfo :: SelectSettings -> IO InstallInfo
 getInstallInfo settings = do
     putStrLn "Loading Haskell Platform"
     hp <- loadHaskellPlatform settings
+
+    core <-
+        if useGlobalDatabase settings
+            then do
+                putStrLn "Loading core packages from global database"
+                getGlobalPackages
+            else return $ hpcore hp
+    let coreMap = Map.unions
+                $ map (\(PackageIdentifier k v) -> Map.singleton k v)
+                $ Set.toList core
+
     let allPackages'
             | requireHaskellPlatform settings = Map.union (stablePackages settings) $ identsToRanges (hplibs hp)
             | otherwise = stablePackages settings
         allPackages = dropExcluded settings allPackages'
-    let totalCore = extraCore settings `Set.union` Set.map (\(PackageIdentifier p _) -> p) (hpcore hp)
+    let totalCore = extraCore settings `Set.union` Set.map (\(PackageIdentifier p _) -> p) core
 
     putStrLn "Loading package database"
     pdb <- loadPackageDB settings totalCore allPackages
 
     putStrLn "Narrowing package database"
-    final <- narrowPackageDB settings pdb $ Set.fromList $ Map.toList $ Map.map snd $ allPackages
+    final <- narrowPackageDB settings totalCore pdb $ Set.fromList $ Map.toList $ Map.map snd $ allPackages
 
     putStrLn "Printing build plan to build-plan.log"
     writeFile "build-plan.log" $ unlines $ map showDep $ Map.toList final
 
-    case checkBadVersions settings pdb final of
+    putStrLn "Checking for bad versions"
+    case checkBadVersions settings coreMap pdb final of
         badVersions
             | Map.null badVersions -> return ()
             | otherwise -> do
@@ -96,10 +110,11 @@ bpPackageList = map packageVersionString . Map.toList . Map.map spiVersion . bpP
 
 -- | Check for internal mismatches in required and actual package versions.
 checkBadVersions :: SelectSettings
+                 -> Map PackageName Version -- ^ core
                  -> PackageDB
                  -> Map PackageName BuildInfo
                  -> Map String (Map PackageName (Version, VersionRange))
-checkBadVersions settings (PackageDB pdb) buildPlan =
+checkBadVersions settings core (PackageDB pdb) buildPlan =
     Map.unions $ map getBadVersions $ Map.toList $ Map.filterWithKey unexpectedFailure buildPlan
   where
     unexpectedFailure name _ = name `Set.notMember` expectedFailuresSelect settings
@@ -123,9 +138,13 @@ checkBadVersions settings (PackageDB pdb) buildPlan =
     checkPackage :: PackageName -> VersionRange -> Map PackageName (Version, VersionRange)
     checkPackage name vr =
         case Map.lookup name buildPlan of
-            -- Can't find the dependency. Could be part of core, so just ignore
-            -- it.
-            Nothing -> Map.empty
+            Nothing ->
+                case Map.lookup name core of
+                    -- Might be part of extra-core
+                    Nothing -> Map.empty
+                    Just version
+                        | version `withinRange` vr -> Map.empty
+                        | otherwise -> Map.singleton name (version, vr)
             Just bi
                 | biVersion bi `withinRange` vr -> Map.empty
                 | otherwise -> Map.singleton name (biVersion bi, vr)

Stackage/NarrowDatabase.hs

@@ -7,14 +7,16 @@ import           Prelude                    hiding (pi)
 import           Stackage.Types
 import           Stackage.Util
 import           System.Exit                (exitFailure)
+import Distribution.Text (display)
 
 -- | Narrow down the database to only the specified packages and all of
 -- their dependencies.
 narrowPackageDB :: SelectSettings
+                -> Set PackageName -- ^ core packages to be excluded from installation
                 -> PackageDB
                 -> Set (PackageName, Maintainer)
                 -> IO (Map PackageName BuildInfo)
-narrowPackageDB settings (PackageDB pdb) packageSet = do
+narrowPackageDB settings core (PackageDB pdb) packageSet = do
     (res, errs) <- runWriterT $ loop Map.empty $ Set.map (\(name, maintainer) -> ([], name, maintainer)) packageSet
     if Set.null errs
         then return res
@@ -29,6 +31,7 @@ narrowPackageDB settings (PackageDB pdb) packageSet = do
             Just ((users, p, maintainer), toProcess') ->
                 case Map.lookup p pdb of
                     Nothing
+                        | p `Set.member` core -> loop result toProcess'
                         | null users -> error $ "Unknown package: " ++ show p
                         | otherwise -> loop result toProcess'
                     Just pi -> do

Stackage/Select.hs

@@ -24,6 +24,7 @@ defaultSelectSettings = SelectSettings
     , excludedPackages = empty
     , flags = Set.fromList $ words "blaze_html_0_5"
     , allowedPackage = const $ Right ()
+    , useGlobalDatabase = False
     }
 
 select :: SelectSettings -> IO BuildPlan

Stackage/Types.hs

@@ -108,6 +108,10 @@ data SelectSettings = SelectSettings
     -- even if present via the Haskell Platform or @stablePackages@. If these
     -- packages are dependencies of others, they will still be included.
     , stablePackages         :: Map PackageName (VersionRange, Maintainer)
+    , useGlobalDatabase      :: Bool
+    -- ^ Instead of checking the Haskell Platform file for core packages, query
+    -- the global database. For this to be reliable, you should only have
+    -- default packages in your global database. Default is @False@.
     }
 
 data BuildStage = BSBuild | BSTest

app/stackage.hs

@@ -18,6 +18,7 @@ data SelectArgs = SelectArgs
     , onlyPermissive :: Bool
     , allowed        :: [String]
     , buildPlanDest  :: FilePath
+    , globalDB       :: Bool
     }
 
 parseSelectArgs :: [String] -> IO SelectArgs
@@ -28,6 +29,7 @@ parseSelectArgs =
         , onlyPermissive = False
         , allowed = []
         , buildPlanDest = defaultBuildPlan
+        , globalDB = False
         }
   where
     loop x [] = return x
@@ -36,6 +38,7 @@ parseSelectArgs =
     loop x ("--only-permissive":rest) = loop x { onlyPermissive = True } rest
     loop x ("--allow":y:rest) = loop x { allowed = y : allowed x } rest
     loop x ("--build-plan":y:rest) = loop x { buildPlanDest = y } rest
+    loop x ("--use-global-db":rest) = loop x { globalDB = True } rest
     loop _ (y:_) = error $ "Did not understand argument: " ++ y
 
 data BuildArgs = BuildArgs
@@ -85,6 +88,7 @@ main = do
                         if onlyPermissive
                             then allowPermissive allowed
                             else const $ Right ()
+                    , useGlobalDatabase = globalDB
                     }
             writeBuildPlan buildPlanDest bp
         ("check":rest) -> withBuildSettings rest $ const checkPlan

stackage.cabal

@@ -27,6 +27,7 @@ library
                        Stackage.BuildPlan
                        Stackage.CheckCabalVersion
                        Stackage.Select
+                       Stackage.GhcPkg
   build-depends:       base >= 4 && < 5
                      , containers
                      , Cabal