Make the modular solver the default always, and deprecate the top-down solver

Cabal/Distribution/PackageDescription.hs

@@ -104,6 +104,9 @@ module Distribution.PackageDescription (
         RepoKind(..),
         RepoType(..),
         knownRepoTypes,
+
+        -- * Custom setup build information
+        SetupBuildInfo(..),
   ) where
 
 import Distribution.Compat.Binary (Binary)
@@ -186,6 +189,7 @@ data PackageDescription
         -- transitioning to specifying just a single version, not a range.
         specVersionRaw :: Either Version VersionRange,
         buildType      :: Maybe BuildType,
+        setupBuildInfo :: Maybe SetupBuildInfo,
         -- components
         library        :: Maybe Library,
         executables    :: [Executable],
@@ -253,6 +257,7 @@ emptyPackageDescription
                       description  = "",
                       category     = "",
                       customFieldsPD = [],
+                      setupBuildInfo = Nothing,
                       library      = Nothing,
                       executables  = [],
                       testSuites   = [],
@@ -297,6 +302,29 @@ instance Text BuildType where
       "Make"      -> Make
       _           -> UnknownBuildType name
 
+-- ---------------------------------------------------------------------------
+-- The SetupBuildInfo type
+
+-- One can see this as a very cut-down version of BuildInfo below.
+-- To keep things simple for tools that compile Setup.hs we limit the
+-- options authors can specify to just Haskell package dependencies.
+
+data SetupBuildInfo = SetupBuildInfo {
+        setupDepends :: [Dependency]
+    }
+    deriving (Generic, Show, Eq, Read, Typeable, Data)
+
+instance Binary SetupBuildInfo
+
+instance Monoid SetupBuildInfo where
+  mempty = SetupBuildInfo {
+    setupDepends = mempty
+  }
+  mappend a b = SetupBuildInfo {
+    setupDepends = combine setupDepends
+  }
+    where combine field = field a `mappend` field b
+
 -- ---------------------------------------------------------------------------
 -- Module renaming
 

Cabal/Distribution/PackageDescription/Check.hs

@@ -411,6 +411,12 @@ checkFields pkg =
           ++ commaSep (map display knownBuildTypes)
       _ -> Nothing
 
+  , check (isJust (setupBuildInfo pkg) && buildType pkg /= Just Custom) $
+      PackageBuildWarning $
+           "Ignoring the 'custom-setup' section because the 'build-type' is "
+        ++ "not 'Custom'. Use 'build-type: Custom' if you need to use a "
+        ++ "custom Setup.hs script."
+
   , check (not (null unknownCompilers)) $
       PackageBuildWarning $
         "Unknown compiler " ++ commaSep (map quote unknownCompilers)
@@ -1083,6 +1089,16 @@ checkCabalVersion pkg =
         ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require "
         ++ "compatibility with earlier Cabal versions then you may be able to "
         ++ "use an equivalent compiler-specific flag."
+
+  , check (specVersion pkg >= Version [1,21] []
+           && isNothing (setupBuildInfo pkg)
+           && buildType pkg == Just Custom) $
+      PackageBuildWarning $
+           "Packages using 'cabal-version: >= 1.22' with 'build-type: Custom' "
+        ++ "must use a 'custom-setup' section with a 'setup-depends' field "
+        ++ "that specifies the dependencies of the Setup.hs script itself. "
+        ++ "The 'setup-depends' field uses the same syntax as 'build-depends', "
+        ++ "so a simple example would be 'setup-depends: base, Cabal'."
   ]
   where
     -- Perform a check on packages that use a version of the spec less than

Cabal/Distribution/PackageDescription/Parse.hs

@@ -528,6 +528,15 @@ sourceRepoFieldDescrs =
         repoSubdir                 (\val repo -> repo { repoSubdir = val })
     ]
 
+------------------------------------------------------------------------------
+
+setupBInfoFieldDescrs :: [FieldDescr SetupBuildInfo]
+setupBInfoFieldDescrs =
+    [ commaListFieldWithSep vcat "setup-depends"
+        disp         parse
+        setupDepends (\xs binfo -> binfo{setupDepends=xs})
+    ]
+
 -- ---------------------------------------------------------------
 -- Parsing
 
@@ -739,13 +748,13 @@ parsePackageDescription file = do
 
           -- 'getBody' assumes that the remaining fields only consist of
           -- flags, lib and exe sections.
-        (repos, flags, mlib, exes, tests, bms) <- getBody
+        (repos, flags, mcsetup, mlib, exes, tests, bms) <- getBody
         warnIfRest  -- warn if getBody did not parse up to the last field.
           -- warn about using old/new syntax with wrong cabal-version:
         maybeWarnCabalVersion (not $ oldSyntax fields0) pkg
         checkForUndefinedFlags flags mlib exes tests
         return $ GenericPackageDescription
-                   pkg { sourceRepos = repos }
+                   pkg { sourceRepos = repos, setupBuildInfo = mcsetup }
                    flags mlib exes tests bms
 
   where
@@ -851,6 +860,7 @@ parsePackageDescription file = do
     -- The body consists of an optional sequence of declarations of flags and
     -- an arbitrary number of executables and at most one library.
     getBody :: PM ([SourceRepo], [Flag]
+                  ,Maybe SetupBuildInfo
                   ,Maybe (CondTree ConfVar [Dependency] Library)
                   ,[(String, CondTree ConfVar [Dependency] Executable)]
                   ,[(String, CondTree ConfVar [Dependency] TestSuite)]
@@ -863,8 +873,8 @@ parsePackageDescription file = do
             exename <- lift $ runP line_no "executable" parseTokenQ sec_label
             flds <- collectFields parseExeFields sec_fields
             skipField
-            (repos, flags, lib, exes, tests, bms) <- getBody
-            return (repos, flags, lib, (exename, flds): exes, tests, bms)
+            (repos, flags, csetup, lib, exes, tests, bms) <- getBody
+            return (repos, flags, csetup, lib, (exename, flds): exes, tests, bms)
 
         | sec_type == "test-suite" -> do
             when (null sec_label) $ lift $ syntaxError line_no
@@ -905,8 +915,9 @@ parsePackageDescription file = do
             if checkTestType emptyTestSuite flds
                 then do
                     skipField
-                    (repos, flags, lib, exes, tests, bms) <- getBody
-                    return (repos, flags, lib, exes, (testname, flds) : tests, bms)
+                    (repos, flags, csetup, lib, exes, tests, bms) <- getBody
+                    return (repos, flags, csetup, lib, exes,
+                            (testname, flds) : tests, bms)
                 else lift $ syntaxError line_no $
                          "Test suite \"" ++ testname
                       ++ "\" is missing required field \"type\" or the field "
@@ -953,8 +964,9 @@ parsePackageDescription file = do
             if checkBenchmarkType emptyBenchmark flds
                 then do
                     skipField
-                    (repos, flags, lib, exes, tests, bms) <- getBody
-                    return (repos, flags, lib, exes, tests, (benchname, flds) : bms)
+                    (repos, flags, csetup, lib, exes, tests, bms) <- getBody
+                    return (repos, flags, csetup, lib, exes,
+                            tests, (benchname, flds) : bms)
                 else lift $ syntaxError line_no $
                          "Benchmark \"" ++ benchname
                       ++ "\" is missing required field \"type\" or the field "
@@ -967,10 +979,10 @@ parsePackageDescription file = do
               syntaxError line_no "'library' expects no argument"
             flds <- collectFields parseLibFields sec_fields
             skipField
-            (repos, flags, lib, exes, tests, bms) <- getBody
+            (repos, flags, csetup, lib, exes, tests, bms) <- getBody
             when (isJust lib) $ lift $ syntaxError line_no
               "There can only be one library section in a package description."
-            return (repos, flags, Just flds, exes, tests, bms)
+            return (repos, flags, csetup, Just flds, exes, tests, bms)
 
         | sec_type == "flag" -> do
             when (null sec_label) $ lift $
@@ -981,8 +993,8 @@ parsePackageDescription file = do
                     (MkFlag (FlagName (lowercase sec_label)) "" True False)
                     sec_fields
             skipField
-            (repos, flags, lib, exes, tests, bms) <- getBody
-            return (repos, flag:flags, lib, exes, tests, bms)
+            (repos, flags, csetup, lib, exes, tests, bms) <- getBody
+            return (repos, flag:flags, csetup, lib, exes, tests, bms)
 
         | sec_type == "source-repository" -> do
             when (null sec_label) $ lift $ syntaxError line_no $
@@ -1006,8 +1018,22 @@ parsePackageDescription file = do
                     }
                     sec_fields
             skipField
-            (repos, flags, lib, exes, tests, bms) <- getBody
-            return (repo:repos, flags, lib, exes, tests, bms)
+            (repos, flags, csetup, lib, exes, tests, bms) <- getBody
+            return (repo:repos, flags, csetup, lib, exes, tests, bms)
+
+        | sec_type == "custom-setup" -> do
+            unless (null sec_label) $ lift $
+              syntaxError line_no "'setup' expects no argument"
+            flds <- lift $ parseFields
+                             setupBInfoFieldDescrs
+                             warnUnrec
+                             mempty
+                             sec_fields
+            skipField
+            (repos, flags, csetup0, lib, exes, tests, bms) <- getBody
+            when (isJust csetup0) $ lift $ syntaxError line_no
+              "There can only be one 'custom-setup' section in a package description."
+            return (repos, flags, Just flds, lib, exes, tests, bms)
 
         | otherwise -> do
             lift $ warning $ "Ignoring unknown section type: " ++ sec_type
@@ -1023,7 +1049,7 @@ parsePackageDescription file = do
               "If-blocks are not allowed in between stanzas: " ++ show f
             skipField
             getBody
-      Nothing -> return ([], [], Nothing, [], [], [])
+      Nothing -> return ([], [], Nothing, Nothing, [], [], [])
 
     -- Extracts all fields in a block and returns a 'CondTree'.
     --

cabal-install/Distribution/Client/BuildReports/Storage.hs

@@ -28,6 +28,7 @@ import Distribution.Client.BuildReports.Anonymous (BuildReport)
 
 import Distribution.Client.Types
 import qualified Distribution.Client.InstallPlan as InstallPlan
+import qualified Distribution.Client.ComponentDeps as CD
 import Distribution.Client.InstallPlan
          ( InstallPlan )
 
@@ -129,13 +130,13 @@ fromPlanPackage :: Platform -> CompilerId
 fromPlanPackage (Platform arch os) comp planPackage = case planPackage of
   InstallPlan.Installed (ReadyPackage srcPkg flags _ deps) result
     -> Just $ ( BuildReport.new os arch comp
-                                (packageId srcPkg) flags (map packageId deps)
+                                (packageId srcPkg) flags (map packageId (CD.nonSetupDeps deps))
                                 (Right result)
               , extractRepo srcPkg)
 
   InstallPlan.Failed (ConfiguredPackage srcPkg flags _ deps) result
     -> Just $ ( BuildReport.new os arch comp
-                                (packageId srcPkg) flags (map confSrcId deps)
+                                (packageId srcPkg) flags (map confSrcId (CD.nonSetupDeps deps))
                                 (Left result)
               , extractRepo srcPkg )
 

cabal-install/Distribution/Client/ComponentDeps.hs

@@ -0,0 +1,142 @@
+-- | Fine-grained package dependencies
+--
+-- Like many others, this module is meant to be "double-imported":
+--
+-- > import Distribution.Client.ComponentDeps (
+-- >     Component
+-- >   , ComponentDep
+-- >   , ComponentDeps
+-- >   )
+-- > import qualified Distribution.Client.ComponentDeps as CD
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
+module Distribution.Client.ComponentDeps (
+    -- * Fine-grained package dependencies
+    Component(..)
+  , ComponentDep
+  , ComponentDeps -- opaque
+    -- ** Constructing ComponentDeps
+  , empty
+  , fromList
+  , singleton
+  , insert
+  , fromLibraryDeps
+  , fromSetupDeps
+  , fromInstalled
+    -- ** Deconstructing ComponentDeps
+  , toList
+  , flatDeps
+  , nonSetupDeps
+  , libraryDeps
+  , setupDeps
+  , select
+  ) where
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Foldable (fold)
+
+#if !MIN_VERSION_base(4,8,0)
+import Data.Foldable (Foldable(foldMap))
+import Data.Monoid (Monoid(..))
+import Data.Traversable (Traversable(traverse))
+#endif
+
+{-------------------------------------------------------------------------------
+  Types
+-------------------------------------------------------------------------------}
+
+-- | Component of a package
+data Component =
+    ComponentLib
+  | ComponentExe   String
+  | ComponentTest  String
+  | ComponentBench String
+  | ComponentSetup
+  deriving (Show, Eq, Ord)
+
+-- | Dependency for a single component
+type ComponentDep a = (Component, a)
+
+-- | Fine-grained dependencies for a package
+newtype ComponentDeps a = ComponentDeps { unComponentDeps :: Map Component a }
+  deriving (Show, Functor, Eq, Ord)
+
+instance Monoid a => Monoid (ComponentDeps a) where
+  mempty =
+    ComponentDeps Map.empty
+  (ComponentDeps d) `mappend` (ComponentDeps d') =
+    ComponentDeps (Map.unionWith mappend d d')
+
+instance Foldable ComponentDeps where
+  foldMap f = foldMap f . unComponentDeps
+
+instance Traversable ComponentDeps where
+  traverse f = fmap ComponentDeps . traverse f . unComponentDeps
+
+{-------------------------------------------------------------------------------
+  Construction
+-------------------------------------------------------------------------------}
+
+empty :: ComponentDeps a
+empty = ComponentDeps $ Map.empty
+
+fromList :: Monoid a => [ComponentDep a] -> ComponentDeps a
+fromList = ComponentDeps . Map.fromListWith mappend
+
+singleton :: Component -> a -> ComponentDeps a
+singleton comp = ComponentDeps . Map.singleton comp
+
+insert :: Monoid a => Component -> a -> ComponentDeps a -> ComponentDeps a
+insert comp a = ComponentDeps . Map.alter aux comp . unComponentDeps
+  where
+    aux Nothing   = Just a
+    aux (Just a') = Just $ a `mappend` a'
+
+-- | ComponentDeps containing library dependencies only
+fromLibraryDeps :: a -> ComponentDeps a
+fromLibraryDeps = singleton ComponentLib
+
+-- | ComponentDeps containing setup dependencies only
+fromSetupDeps :: a -> ComponentDeps a
+fromSetupDeps = singleton ComponentSetup
+
+-- | ComponentDeps for installed packages
+--
+-- We assume that installed packages only record their library dependencies
+fromInstalled :: a -> ComponentDeps a
+fromInstalled = fromLibraryDeps
+
+{-------------------------------------------------------------------------------
+  Deconstruction
+-------------------------------------------------------------------------------}
+
+toList :: ComponentDeps a -> [ComponentDep a]
+toList = Map.toList . unComponentDeps
+
+-- | All dependencies of a package
+--
+-- This is just a synonym for 'fold', but perhaps a use of 'flatDeps' is more
+-- obvious than a use of 'fold', and moreover this avoids introducing lots of
+-- @#ifdef@s for 7.10 just for the use of 'fold'.
+flatDeps :: Monoid a => ComponentDeps a -> a
+flatDeps = fold
+
+-- | All dependencies except the setup dependencies
+--
+-- Prior to the introduction of setup dependencies (TODO: Version? 1.23) this
+-- would have been _all_ dependencies
+nonSetupDeps :: Monoid a => ComponentDeps a -> a
+nonSetupDeps = select (/= ComponentSetup)
+
+-- | Library dependencies proper only
+libraryDeps :: Monoid a => ComponentDeps a -> a
+libraryDeps = select (== ComponentLib)
+
+-- | Setup dependencies
+setupDeps :: Monoid a => ComponentDeps a -> a
+setupDeps = select (== ComponentSetup)
+
+-- | Select dependencies satisfying a given predicate
+select :: Monoid a => (Component -> Bool) -> ComponentDeps a -> a
+select p = foldMap snd . filter (p . fst) . toList