From 7581b4c8a03f70fc6f799b7e403ed10c82a445cd Mon Sep 17 00:00:00 2001 From: Dave Laing Date: Fri, 8 Dec 2017 16:44:11 +1000 Subject: [PATCH] Makes flags overridable on the command line. This is to fix issue #4452. --- Cabal/Distribution/PackageDescription.hs | 1 + .../Types/GenericPackageDescription.hs | 72 +++++++++++++------ .../Distribution/Client/Dependency.hs | 5 +- .../PackageTests/Regression/T3436/sandbox.out | 2 +- 4 files changed, 56 insertions(+), 24 deletions(-) diff --git a/Cabal/Distribution/PackageDescription.hs b/Cabal/Distribution/PackageDescription.hs index bae173ef7b4..47e0fddee23 100644 --- a/Cabal/Distribution/PackageDescription.hs +++ b/Cabal/Distribution/PackageDescription.hs @@ -99,6 +99,7 @@ module Distribution.PackageDescription ( nullFlagAssignment, showFlagValue, diffFlagAssignment, lookupFlagAssignment, insertFlagAssignment, dispFlagAssignment, parseFlagAssignment, parsecFlagAssignment, + findDuplicateFlagAssignments, CondTree(..), ConfVar(..), Condition(..), cNot, cAnd, cOr, diff --git a/Cabal/Distribution/Types/GenericPackageDescription.hs b/Cabal/Distribution/Types/GenericPackageDescription.hs index 675a2dfdf88..671b3d74e3c 100644 --- a/Cabal/Distribution/Types/GenericPackageDescription.hs +++ b/Cabal/Distribution/Types/GenericPackageDescription.hs @@ -16,6 +16,7 @@ module Distribution.Types.GenericPackageDescription ( lookupFlagAssignment, insertFlagAssignment, diffFlagAssignment, + findDuplicateFlagAssignments, nullFlagAssignment, showFlagValue, dispFlagAssignment, @@ -25,11 +26,11 @@ module Distribution.Types.GenericPackageDescription ( ) where import Prelude () -import Data.List ((\\)) import Distribution.Compat.Prelude import Distribution.Utils.ShortText import Distribution.Utils.Generic (lowercase) import qualified Text.PrettyPrint as Disp +import qualified Data.Map as Map import qualified Distribution.Compat.ReadP as Parse import qualified Distribution.Compat.Parsec as P import Distribution.Compat.ReadP ((+++)) @@ -154,38 +155,58 @@ instance Text FlagName where -- discovered during configuration. For example @--flags=foo --flags=-bar@ -- becomes @[("foo", True), ("bar", False)]@ -- -newtype FlagAssignment = FlagAssignment [(FlagName, Bool)] - deriving (Binary,Eq,Ord,Semigroup,Monoid) +newtype FlagAssignment = FlagAssignment { getFlagAssignment :: Map.Map FlagName (Int, Bool) } + deriving (Binary) --- TODO: the Semigroup/Monoid/Ord/Eq instances would benefit from --- [(FlagName,Bool)] being in a normal form, i.e. sorted. We could --- e.g. switch to a `Data.Map.Map` representation, but see duplicates --- check in `configuredPackageProblems`. +instance Eq FlagAssignment where + (==) (FlagAssignment m1) (FlagAssignment m2) = fmap snd m1 == fmap snd m2 + +instance Ord FlagAssignment where + compare (FlagAssignment m1) (FlagAssignment m2) = fmap snd m1 `compare` fmap snd m2 + +-- | Combines pairs of values contained in the 'FlagAssignment' Map. +-- +-- The last flag specified takes precedence, and we record the number +-- of times we have seen the flag. -- --- Also, the 'Semigroup' instance currently is left-biased as entries --- in the left-hand 'FlagAssignment' shadow those occuring in the --- right-hand side 'FlagAssignment' for the same flagnames. +combineFlagValues :: (Int, Bool) -> (Int, Bool) -> (Int, Bool) +combineFlagValues (c1, _) (c2, b2) = (c1 + c2, b2) + +-- The 'Semigroup' instance currently is right-biased. +-- +-- If duplicate flags are specified, we want the last flag specified to +-- take precedence and we want to know how many times the flag has been +-- specified so that we have the option of warning the user about +-- supplying duplicate flags. +instance Semigroup FlagAssignment where + (<>) (FlagAssignment m1) (FlagAssignment m2) = FlagAssignment (Map.unionWith combineFlagValues m1 m2) + +instance Monoid FlagAssignment where + mempty = FlagAssignment Map.empty + mappend = (<>) -- | Construct a 'FlagAssignment' from a list of flag/value pairs. -- +-- If duplicate flags occur in the input list, the later entries +-- in the list will take precedence. +-- -- @since 2.2.0 mkFlagAssignment :: [(FlagName, Bool)] -> FlagAssignment -mkFlagAssignment = FlagAssignment +mkFlagAssignment = FlagAssignment . Map.fromListWith (flip combineFlagValues) . fmap (fmap (\b -> (1, b))) -- | Deconstruct a 'FlagAssignment' into a list of flag/value pairs. -- --- @ ('mkFlagAssignment' . 'unFlagAssignment') fa == fa @ +-- @ 'null' ('findDuplicateFlagAssignments' fa) ==> ('mkFlagAssignment' . 'unFlagAssignment') fa == fa @ -- -- @since 2.2.0 unFlagAssignment :: FlagAssignment -> [(FlagName, Bool)] -unFlagAssignment (FlagAssignment xs) = xs +unFlagAssignment = fmap (fmap snd) . Map.toList . getFlagAssignment -- | Test whether 'FlagAssignment' is empty. -- -- @since 2.2.0 nullFlagAssignment :: FlagAssignment -> Bool -nullFlagAssignment (FlagAssignment []) = True -nullFlagAssignment _ = False +nullFlagAssignment = Map.null . getFlagAssignment -- | Lookup the value for a flag -- @@ -193,16 +214,21 @@ nullFlagAssignment _ = False -- -- @since 2.2.0 lookupFlagAssignment :: FlagName -> FlagAssignment -> Maybe Bool -lookupFlagAssignment fn = lookup fn . unFlagAssignment +lookupFlagAssignment fn = fmap snd . Map.lookup fn . getFlagAssignment -- | Insert or update the boolean value of a flag. -- +-- If the flag is already present in the 'FlagAssigment', the +-- value will be updated and the fact that multiple values have +-- been provided for that flag will be recorded so that a +-- warning can be generated later on. +-- -- @since 2.2.0 insertFlagAssignment :: FlagName -> Bool -> FlagAssignment -> FlagAssignment -- TODO: this currently just shadows prior values for an existing flag; -- rather than enforcing uniqueness at construction, it's verified lateron via -- `D.C.Dependency.configuredPackageProblems` -insertFlagAssignment flag val = mkFlagAssignment . ((flag,val):) . unFlagAssignment +insertFlagAssignment flag val = FlagAssignment . Map.insertWith (flip combineFlagValues) flag (1, val) . getFlagAssignment -- | Remove all flag-assignments from the first 'FlagAssignment' that -- are contained in the second 'FlagAssignment' @@ -214,7 +240,13 @@ insertFlagAssignment flag val = mkFlagAssignment . ((flag,val):) . unFlagAssignm -- -- @since 2.2.0 diffFlagAssignment :: FlagAssignment -> FlagAssignment -> FlagAssignment -diffFlagAssignment fa1 fa2 = mkFlagAssignment (unFlagAssignment fa1 \\ unFlagAssignment fa2) +diffFlagAssignment fa1 fa2 = FlagAssignment (Map.difference (getFlagAssignment fa1) (getFlagAssignment fa2)) + +-- | Find the 'FlagName's that have been listed more than once. +-- +-- @since 2.2.0 +findDuplicateFlagAssignments :: FlagAssignment -> [FlagName] +findDuplicateFlagAssignments = Map.keys . Map.filter ((> 1) . fst) . getFlagAssignment -- | @since 2.2.0 instance Read FlagAssignment where @@ -235,7 +267,7 @@ dispFlagAssignment = Disp.hsep . map (Disp.text . showFlagValue) . unFlagAssignm -- | Parses a flag assignment. parsecFlagAssignment :: ParsecParser FlagAssignment -parsecFlagAssignment = FlagAssignment <$> P.sepBy (onFlag <|> offFlag) P.skipSpaces1 +parsecFlagAssignment = mkFlagAssignment <$> P.sepBy (onFlag <|> offFlag) P.skipSpaces1 where onFlag = do P.optional (P.char '+') @@ -248,7 +280,7 @@ parsecFlagAssignment = FlagAssignment <$> P.sepBy (onFlag <|> offFlag) P.skipSpa -- | Parses a flag assignment. parseFlagAssignment :: Parse.ReadP r FlagAssignment -parseFlagAssignment = FlagAssignment <$> Parse.sepBy parseFlagValue Parse.skipSpaces1 +parseFlagAssignment = mkFlagAssignment <$> Parse.sepBy parseFlagValue Parse.skipSpaces1 where parseFlagValue = (do Parse.optional (Parse.char '+') diff --git a/cabal-install/Distribution/Client/Dependency.hs b/cabal-install/Distribution/Client/Dependency.hs index 5dfee0e02d8..8f2b1eea532 100644 --- a/cabal-install/Distribution/Client/Dependency.hs +++ b/cabal-install/Distribution/Client/Dependency.hs @@ -96,7 +96,7 @@ import Distribution.Compiler import Distribution.System ( Platform ) import Distribution.Client.Utils - ( duplicates, duplicatesBy, mergeBy, MergeResult(..) ) + ( duplicatesBy, mergeBy, MergeResult(..) ) import Distribution.Simple.Utils ( comparing ) import Distribution.Simple.Setup @@ -891,8 +891,7 @@ configuredPackageProblems :: Platform -> CompilerInfo -> SolverPackage UnresolvedPkgLoc -> [PackageProblem] configuredPackageProblems platform cinfo (SolverPackage pkg specifiedFlags stanzas specifiedDeps' _specifiedExeDeps') = - -- FIXME/TODO: FlagAssignment ought to be duplicate-free as internal invariant - [ DuplicateFlag flag | ((flag,_):_) <- duplicates (PD.unFlagAssignment specifiedFlags) ] + [ DuplicateFlag flag | flag <- PD.findDuplicateFlagAssignments specifiedFlags ] ++ [ MissingFlag flag | OnlyInLeft flag <- mergedFlags ] ++ [ ExtraFlag flag | OnlyInRight flag <- mergedFlags ] ++ [ DuplicateDeps pkgs diff --git a/cabal-testsuite/PackageTests/Regression/T3436/sandbox.out b/cabal-testsuite/PackageTests/Regression/T3436/sandbox.out index 55470fd0fed..37dba14d21f 100644 --- a/cabal-testsuite/PackageTests/Regression/T3436/sandbox.out +++ b/cabal-testsuite/PackageTests/Regression/T3436/sandbox.out @@ -18,5 +18,5 @@ Installing library in Installed Cabal-2.0 Failed to install custom-setup-1.0 cabal: Error: some packages failed to install: -custom-setup-1.0-92JpsxIMpiQHysxYdDtEVq failed during the configure step. The exception was: +custom-setup-1.0-KL06TzJxSBkDtcPp9Xd2v1 failed during the configure step. The exception was: ExitFailure 1