Skip to content

Commit

Permalink
Merge pull request #3362 from 23Skidoo/issue-3199-master
Browse files Browse the repository at this point in the history 
Merge #3337 into master
  • Loading branch information
@23Skidoo
23Skidoo committed Apr 20, 2016
2 parents 3784e1f + 2048bf7 commit 851829e
Show file tree
Hide file tree
Showing 12 changed files with 205 additions and 68 deletions.
37 changes: 32 additions & 5 deletions Cabal/Distribution/PackageDescription.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -100,7 +100,7 @@ module Distribution.PackageDescription (
GenericPackageDescription(..),
Flag(..), FlagName(..), FlagAssignment,
CondTree(..), ConfVar(..), Condition(..),
cNot,
cNot, cAnd, cOr,

-- * Source repositories
SourceRepo(..),
Expand All @@ -114,7 +114,7 @@ module Distribution.PackageDescription (

import Distribution.Compat.Binary
import qualified Distribution.Compat.Semigroup as Semi ((<>))
import Distribution.Compat.Semigroup as Semi (Monoid(..), Semigroup, gmempty, gmappend)
import Distribution.Compat.Semigroup as Semi (Monoid(..), Semigroup, gmempty)
import qualified Distribution.Compat.ReadP as Parse
import Distribution.Compat.ReadP ((<++))
import Distribution.Package
Expand Down Expand Up @@ -310,18 +310,24 @@ instance Text BuildType where
-- options authors can specify to just Haskell package dependencies.

data SetupBuildInfo = SetupBuildInfo {
setupDepends :: [Dependency]
setupDepends :: [Dependency],
defaultSetupDepends :: Bool
-- ^ Is this a default 'custom-setup' section added by the cabal-install
-- code (as opposed to user-provided)? This field is only used
-- internally, and doesn't correspond to anything in the .cabal
-- file. See #3199.
}
deriving (Generic, Show, Eq, Read, Typeable, Data)

instance Binary SetupBuildInfo

instance Semi.Monoid SetupBuildInfo where
mempty = gmempty
mempty = SetupBuildInfo [] False
mappend = (Semi.<>)

instance Semigroup SetupBuildInfo where
(<>) = gmappend
a <> b = SetupBuildInfo (setupDepends a Semi.<> setupDepends b)
(defaultSetupDepends a || defaultSetupDepends b)

-- ---------------------------------------------------------------------------
-- Module renaming
Expand Down Expand Up @@ -1225,11 +1231,32 @@ data Condition c = Var c
| CAnd (Condition c) (Condition c)
deriving (Show, Eq, Typeable, Data, Generic)

-- | Boolean negation of a 'Condition' value.
cNot :: Condition a -> Condition a
cNot (Lit b) = Lit (not b)
cNot (CNot c) = c
cNot c = CNot c

-- | Boolean AND of two 'Condtion' values.
cAnd :: Condition a -> Condition a -> Condition a
cAnd (Lit False) _ = Lit False
cAnd _ (Lit False) = Lit False
cAnd (Lit True) x = x
cAnd x (Lit True) = x
cAnd x y = CAnd x y

-- | Boolean OR of two 'Condition' values.
cOr :: Eq v => Condition v -> Condition v -> Condition v
cOr (Lit True) _ = Lit True
cOr _ (Lit True) = Lit True
cOr (Lit False) x = x
cOr x (Lit False) = x
cOr c (CNot d)
| c == d = Lit True
cOr (CNot c) d
| c == d = Lit True
cOr x y = COr x y

instance Functor Condition where
f `fmap` Var c = Var (f c)
_ `fmap` Lit c = Lit c
Expand Down
59 changes: 35 additions & 24 deletions Cabal/Distribution/PackageDescription/Configuration.hs
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
-- -fno-warn-deprecations for use of Map.foldWithKey
{-# OPTIONS_GHC -fno-warn-deprecations #-}
-----------------------------------------------------------------------------
Expand All @@ -23,6 +24,7 @@ module Distribution.PackageDescription.Configuration (
parseCondition,
freeVars,
extractCondition,
extractConditions,
addBuildableCondition,
mapCondTree,
mapTreeData,
Expand All @@ -32,6 +34,9 @@ module Distribution.PackageDescription.Configuration (
transformAllBuildDepends,
) where

import Control.Applicative -- 7.10 -Werror workaround.
import Prelude

import Distribution.Package
import Distribution.PackageDescription
import Distribution.PackageDescription.Utils
Expand Down Expand Up @@ -293,17 +298,24 @@ addBuildableCondition getInfo t =
Lit False -> CondNode mempty mempty []
c -> CondNode mempty mempty [(c, t, Nothing)]

-- | Extract buildable condition from a cond tree.
-- Note: extracting buildable conditions.
-- --------------------------------------
--
-- Background: If the conditions in a cond tree lead to Buildable being set to False,
-- then none of the dependencies for this cond tree should actually be taken into
-- account. On the other hand, some of the flags may only be decided in the solver,
-- so we cannot necessarily make the decision whether a component is Buildable or not
-- prior to solving.
-- If the conditions in a cond tree lead to Buildable being set to False, then
-- none of the dependencies for this cond tree should actually be taken into
-- account. On the other hand, some of the flags may only be decided in the
-- solver, so we cannot necessarily make the decision whether a component is
-- Buildable or not prior to solving.
--
-- What we are doing here is to partially evaluate a condition tree in order to extract
-- the condition under which Buildable is True. The predicate determines whether data
-- under a 'CondTree' is buildable.
-- What we are doing here is to partially evaluate a condition tree in order to
-- extract the condition under which Buildable is True. The predicate determines
-- whether data under a 'CondTree' is buildable.


-- | Extract the condition matched by the given predicate from a cond tree.
--
-- We use this mainly for extracting buildable conditions (see the Note above),
-- but the function is in fact more general.
extractCondition :: Eq v => (a -> Bool) -> CondTree v c a -> Condition v
extractCondition p = go
where
Expand All @@ -316,21 +328,20 @@ extractCondition p = go
ct = go t
ce = maybe (Lit True) go e
in
((c `cand` ct) `cor` (CNot c `cand` ce)) `cand` goList cs

cand (Lit False) _ = Lit False
cand _ (Lit False) = Lit False
cand (Lit True) x = x
cand x (Lit True) = x
cand x y = CAnd x y

cor (Lit True) _ = Lit True
cor _ (Lit True) = Lit True
cor (Lit False) x = x
cor x (Lit False) = x
cor c (CNot d)
| c == d = Lit True
cor x y = COr x y
((c `cAnd` ct) `cOr` (CNot c `cAnd` ce)) `cAnd` goList cs

-- | Extract conditions matched by the given predicate from all cond trees in a
-- 'GenericPackageDescription'.
extractConditions :: (BuildInfo -> Bool) -> GenericPackageDescription
-> [Condition ConfVar]
extractConditions f gpkg =
concat [
extractCondition (f . libBuildInfo) . snd <$> condLibraries gpkg
, extractCondition (f . buildInfo) . snd <$> condExecutables gpkg
, extractCondition (f . testBuildInfo) . snd <$> condTestSuites gpkg
, extractCondition (f . benchmarkBuildInfo) . snd <$> condBenchmarks gpkg
]


-- | A map of dependencies that combines version ranges using 'unionVersionRanges'.
newtype DepMapUnion = DepMapUnion { unDepMapUnion :: Map PackageName VersionRange }
Expand Down
47 changes: 29 additions & 18 deletions cabal-install/Distribution/Client/Configure.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -187,18 +187,18 @@ configureSetupScript packageDBs
index
mpkg
= SetupScriptOptions {
useCabalVersion = cabalVersion
, useCabalSpecVersion = Nothing
, useCompiler = Just comp
, usePlatform = Just platform
, usePackageDB = packageDBs'
, usePackageIndex = index'
, useProgramConfig = conf
, useDistPref = distPref
, useLoggingHandle = Nothing
, useWorkingDir = Nothing
, setupCacheLock = lock
, useWin32CleanHack = False
useCabalVersion = cabalVersion
, useCabalSpecVersion = Nothing
, useCompiler = Just comp
, usePlatform = Just platform
, usePackageDB = packageDBs'
, usePackageIndex = index'
, useProgramConfig = conf
, useDistPref = distPref
, useLoggingHandle = Nothing
, useWorkingDir = Nothing
, setupCacheLock = lock
, useWin32CleanHack = False
, forceExternalSetupMethod = forceExternal
-- If we have explicit setup dependencies, list them; otherwise, we give
-- the empty list of dependencies; ideally, we would fix the version of
Expand All @@ -207,8 +207,8 @@ configureSetupScript packageDBs
-- know the version of Cabal at this point, but only find this there.
-- Therefore, for now, we just leave this blank.
, useDependencies = fromMaybe [] explicitSetupDeps
, useDependenciesExclusive = isJust explicitSetupDeps
, useVersionMacros = isJust explicitSetupDeps
, useDependenciesExclusive = not defaultSetupDeps && isJust explicitSetupDeps
, useVersionMacros = not defaultSetupDeps && isJust explicitSetupDeps
}
where
-- When we are compiling a legacy setup script without an explicit
Expand All @@ -226,13 +226,24 @@ configureSetupScript packageDBs
-- but if the user is using an odd db stack, don't touch it
_otherwise -> (packageDBs, Just index)

explicitSetupDeps :: Maybe [(UnitId, PackageId)]
explicitSetupDeps = do
maybeSetupBuildInfo :: Maybe PkgDesc.SetupBuildInfo
maybeSetupBuildInfo = do
ReadyPackage cpkg <- mpkg
let gpkg = packageDescription (confPkgSource cpkg)
-- Check if there is an explicit setup stanza
_buildInfo <- PkgDesc.setupBuildInfo (PkgDesc.packageDescription gpkg)
PkgDesc.setupBuildInfo (PkgDesc.packageDescription gpkg)

-- Was a default 'custom-setup' stanza added by 'cabal-install' itself? If
-- so, 'setup-depends' must not be exclusive. See #3199.
defaultSetupDeps :: Bool
defaultSetupDeps = maybe False PkgDesc.defaultSetupDepends
maybeSetupBuildInfo

explicitSetupDeps :: Maybe [(UnitId, PackageId)]
explicitSetupDeps = do
-- Check if there is an explicit setup stanza.
_buildInfo <- maybeSetupBuildInfo
-- Return the setup dependencies computed by the solver
ReadyPackage cpkg <- mpkg
return [ ( uid, srcid )
| ConfiguredId srcid uid <- CD.setupDeps (confPkgDeps cpkg)
]
Expand Down
48 changes: 39 additions & 9 deletions cabal-install/Distribution/Client/Dependency.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -94,16 +94,14 @@ import Distribution.Package
, Package(..), packageName, packageVersion
, UnitId, Dependency(Dependency))
import qualified Distribution.PackageDescription as PD
( PackageDescription(..), SetupBuildInfo(..)
, GenericPackageDescription(..)
, Flag(flagName), FlagName(..) )
import qualified Distribution.PackageDescription.Configuration as PD
import Distribution.PackageDescription.Configuration
( finalizePackageDescription )
import Distribution.Client.PackageUtils
( externalBuildDepends )
import Distribution.Version
( VersionRange, anyVersion, thisVersion, withinRange
, simplifyVersionRange )
( Version(..), VersionRange, anyVersion, thisVersion, orLaterVersion
, withinRange, simplifyVersionRange )
import Distribution.Compiler
( CompilerInfo(..) )
import Distribution.System
Expand Down Expand Up @@ -394,7 +392,7 @@ removeUpperBounds allowNewer params =
-- 'addSourcePackages'. Otherwise, the packages inserted by
-- 'addSourcePackages' won't have upper bounds in dependencies relaxed.
--
addDefaultSetupDependencies :: (UnresolvedSourcePackage -> [Dependency])
addDefaultSetupDependencies :: (UnresolvedSourcePackage -> Maybe [Dependency])
-> DepResolverParams -> DepResolverParams
addDefaultSetupDependencies defaultSetupDeps params =
params {
Expand All @@ -410,9 +408,12 @@ addDefaultSetupDependencies defaultSetupDeps params =
PD.setupBuildInfo =
case PD.setupBuildInfo pkgdesc of
Just sbi -> Just sbi
Nothing -> Just PD.SetupBuildInfo {
PD.setupDepends = defaultSetupDeps srcpkg
}
Nothing -> case defaultSetupDeps srcpkg of
Nothing -> Nothing
Just deps -> Just PD.SetupBuildInfo {
PD.defaultSetupDepends = True,
PD.setupDepends = deps
}
}
}
}
Expand Down Expand Up @@ -451,12 +452,41 @@ standardInstallPolicy
. hideInstalledPackagesSpecificBySourcePackageId
[ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ]

. addDefaultSetupDependencies mkDefaultSetupDeps

. addSourcePackages
[ pkg | SpecificSourcePackage pkg <- pkgSpecifiers ]

$ basicDepResolverParams
installedPkgIndex sourcePkgIndex

where
-- Force Cabal >= 1.24 dep when the package is affected by #3199.
mkDefaultSetupDeps :: UnresolvedSourcePackage -> Maybe [Dependency]
mkDefaultSetupDeps srcpkg | affected =
Just [Dependency (PackageName "Cabal")
(orLaterVersion $ Version [1,24] [])]
| otherwise = Nothing
where
gpkgdesc = packageDescription srcpkg
pkgdesc = PD.packageDescription gpkgdesc
bt = fromMaybe PD.Custom (PD.buildType pkgdesc)
affected = bt == PD.Custom && hasBuildableFalse gpkgdesc

-- Does this package contain any components with non-empty 'build-depends'
-- and a 'buildable' field that could potentially be set to 'False'? False
-- positives are possible.
hasBuildableFalse :: PD.GenericPackageDescription -> Bool
hasBuildableFalse gpkg =
not (all alwaysTrue (zipWith PD.cOr buildableConditions noDepConditions))
where
buildableConditions = PD.extractConditions PD.buildable gpkg
noDepConditions = PD.extractConditions
(null . PD.targetBuildDepends) gpkg
alwaysTrue (PD.Lit True) = True
alwaysTrue _ = False


applySandboxInstallPolicy :: SandboxPackageInfo
-> DepResolverParams
-> DepResolverParams
Expand Down
9 changes: 5 additions & 4 deletions cabal-install/Distribution/Client/ProjectPlanning.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1629,14 +1629,15 @@ packageSetupScriptStylePreSolver pkg
-- we still need to distinguish the case of explicit and implict setup deps.
-- See 'rememberImplicitSetupDeps'.
--
defaultSetupDeps :: Platform -> PD.PackageDescription -> [Dependency]
defaultSetupDeps :: Platform -> PD.PackageDescription -> Maybe [Dependency]
defaultSetupDeps platform pkg =
case packageSetupScriptStylePreSolver pkg of

-- For packages with build type custom that do not specify explicit
-- setup dependencies, we add a dependency on Cabal and a number
-- of other packages.
SetupCustomImplicitDeps ->
Just $
[ Dependency depPkgname anyVersion
| depPkgname <- legacyCustomSetupPkgs platform ] ++
-- The Cabal dep is slightly special:
Expand All @@ -1663,13 +1664,13 @@ defaultSetupDeps platform pkg =
-- external Setup.hs, it'll be one of the simple ones that only depends
-- on Cabal and base.
SetupNonCustomExternalLib ->
[ Dependency cabalPkgname cabalConstraint
, Dependency basePkgname anyVersion ]
Just [ Dependency cabalPkgname cabalConstraint
, Dependency basePkgname anyVersion ]
where
cabalConstraint = orLaterVersion (PD.specVersion pkg)

-- The internal setup wrapper method has no deps at all.
SetupNonCustomInternalLib -> []
SetupNonCustomInternalLib -> Just []

SetupCustomExplicitDeps ->
error $ "defaultSetupDeps: called for a package with explicit "
Expand Down
Loading

0 comments on commit 851829e

Please sign in to comment.