From a9d7c3006acd0be1da4c3b03ed075c24590f378b Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Thu, 17 Apr 2014 19:18:36 +0300
Subject: [PATCH] Constrain core packages

---
 Stackage/BuildPlan.hs   | 14 ++++++++++++--
 Stackage/InstallInfo.hs | 10 ++++++----
 Stackage/ServerFiles.hs |  1 +
 Stackage/Tarballs.hs    |  2 +-
 Stackage/Types.hs       |  4 ++--
 5 files changed, 22 insertions(+), 9 deletions(-)

diff --git a/Stackage/BuildPlan.hs b/Stackage/BuildPlan.hs
index d6463a0f..352b8428 100644
--- a/Stackage/BuildPlan.hs
+++ b/Stackage/BuildPlan.hs
@@ -11,6 +11,7 @@ import qualified Data.Set          as Set
 import           Distribution.Text (display, simpleParse)
 import           Stackage.Types
 import qualified System.IO.UTF8
+import           Data.Char         (isSpace)
 
 readBuildPlan :: FilePath -> IO BuildPlan
 readBuildPlan fp = do
@@ -31,7 +32,7 @@ instance AsString BuildPlan where
     toString BuildPlan {..} = concat
         [ makeSection "tools" bpTools
         , makeSection "packages" $ Map.toList bpPackages
-        , makeSection "core" $ Set.toList bpCore
+        , makeSection "core" $ Map.toList bpCore
         , makeSection "optional-core" $ Map.toList bpOptionalCore
         , makeSection "skipped-tests" $ Set.toList bpSkippedTests
         ]
@@ -44,7 +45,7 @@ instance AsString BuildPlan where
         let bp = BuildPlan
                 { bpTools = tools
                 , bpPackages = Map.fromList packages
-                , bpCore = Set.fromList core
+                , bpCore = Map.fromList core
                 , bpOptionalCore = Map.fromList optionalCore
                 , bpSkippedTests = Set.fromList skipped
                 }
@@ -64,6 +65,15 @@ instance AsString PackageName where
     toString (PackageName pn) = pn
     fromString s = Right (PackageName s, "")
 
+instance AsString (Maybe Version) where
+    toString Nothing = ""
+    toString (Just x) = toString x
+    fromString s
+        | all isSpace s = return (Nothing, s)
+        | otherwise = do
+            (v, s') <- fromString s
+            return (Just v, s')
+
 instance AsString a => AsString (PackageName, a) where
     toString (PackageName pn, s) = concat [pn, " ", toString s]
     fromString s = do
diff --git a/Stackage/InstallInfo.hs b/Stackage/InstallInfo.hs
index d4f5e78c..980fad44 100644
--- a/Stackage/InstallInfo.hs
+++ b/Stackage/InstallInfo.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TupleSections #-}
 module Stackage.InstallInfo
     ( getInstallInfo
     , bpPackageList
@@ -54,15 +55,16 @@ getInstallInfo settings = do
         allPackages = dropExcluded settings allPackages'
     let totalCore
             | ignoreUpgradeableCore settings =
-                Set.fromList $ map PackageName $ words "base containers template-haskell"
+                Map.fromList $ map (\n -> (PackageName n, Nothing)) $ words "base containers template-haskell"
             | otherwise =
-                extraCore settings `Set.union` Set.map (\(PackageIdentifier p _) -> p) core
+                Map.fromList (map (\(PackageIdentifier p v) -> (p, Just v)) (Set.toList core))
+                `Map.union` Map.fromList (map (, Nothing) (Set.toList $ extraCore settings))
 
     putStrLn "Loading package database"
-    pdb <- loadPackageDB settings coreMap totalCore allPackages
+    pdb <- loadPackageDB settings coreMap (Map.keysSet totalCore) allPackages
 
     putStrLn "Narrowing package database"
-    (final, errs) <- narrowPackageDB settings totalCore pdb $ Set.fromList $ Map.toList $ Map.map snd $ allPackages
+    (final, errs) <- narrowPackageDB settings (Map.keysSet totalCore) pdb $ Set.fromList $ Map.toList $ Map.map snd $ allPackages
 
     putStrLn "Printing build plan to build-plan.log"
     System.IO.UTF8.writeFile "build-plan.log" $ unlines $ map showDep $ Map.toList final
diff --git a/Stackage/ServerFiles.hs b/Stackage/ServerFiles.hs
index 4282b72a..7464b1dc 100644
--- a/Stackage/ServerFiles.hs
+++ b/Stackage/ServerFiles.hs
@@ -22,6 +22,7 @@ createHackageFile ii h = do
     selected = Map.fromList . map toStrs . Map.toList $
         fmap spiVersion (iiPackages ii)
         `Map.union` iiOptionalCore ii
+        `Map.union` Map.mapMaybe id (iiCore ii)
 
     toStrs (PackageName name, version) = (name, display version)
 
diff --git a/Stackage/Tarballs.hs b/Stackage/Tarballs.hs
index caf48471..df48f839 100644
--- a/Stackage/Tarballs.hs
+++ b/Stackage/Tarballs.hs
@@ -41,5 +41,5 @@ makeTarballs bp = do
                             | version == spiVersion spi -> (stable . (e:), extra)
                             | otherwise -> (stable, extra)
                         Nothing
-                            | package `Set.member` bpCore bp -> (stable, extra)
+                            | package `Map.member` bpCore bp -> (stable, extra)
                             | otherwise -> (stable, extra . (e:))
diff --git a/Stackage/Types.hs b/Stackage/Types.hs
index a3682d7f..80e8de92 100644
--- a/Stackage/Types.hs
+++ b/Stackage/Types.hs
@@ -61,7 +61,7 @@ instance Monoid HaskellPlatform where
     HaskellPlatform a x `mappend` HaskellPlatform b y = HaskellPlatform (mappend a b) (mappend x y)
 
 data InstallInfo = InstallInfo
-    { iiCore         :: Set PackageName
+    { iiCore         :: Map PackageName (Maybe Version)
     , iiPackages     :: Map PackageName SelectedPackageInfo
     , iiOptionalCore :: Map PackageName Version
       -- ^ This is intended to hold onto packages which might be automatically
@@ -81,7 +81,7 @@ data SelectedPackageInfo = SelectedPackageInfo
 data BuildPlan = BuildPlan
     { bpTools        :: [String]
     , bpPackages     :: Map PackageName SelectedPackageInfo
-    , bpCore         :: Set PackageName
+    , bpCore         :: Map PackageName (Maybe Version)
     , bpOptionalCore :: Map PackageName Version
       -- ^ See 'iiOptionalCore'
     , bpSkippedTests :: Set PackageName