Commit 6cb6a516 authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺

Make `FlagAssignment` an opaque `newtype`

This is a refactoring abstracting `FlagAssignment` while retaining its
external appearance as much as possible (i.e. same Read/Show/Binary
instances etc).

Later we can attach new instances, enforce internal invariants (like
e.g. uniqueness of flagnames), switch out the internal
representation (maybe to `Data.Map`), etc more easily.
parent a6d86089
......@@ -94,8 +94,9 @@ module Distribution.PackageDescription (
GenericPackageDescription(..),
Flag(..), emptyFlag,
FlagName, mkFlagName, unFlagName,
FlagAssignment,
showFlagValue,
FlagAssignment, mkFlagAssignment, unFlagAssignment,
nullFlagAssignment, showFlagValue,
diffFlagAssignment, lookupFlagAssignment, insertFlagAssignment,
dispFlagAssignment, parseFlagAssignment, parsecFlagAssignment,
CondTree(..), ConfVar(..), Condition(..),
cNot, cAnd, cOr,
......
......@@ -1532,7 +1532,7 @@ checkPackageVersions pkg =
-- open upper bound. To get a typical configuration we finalise
-- using no package index and the current platform.
finalised = finalizePD
[] defaultComponentRequestedSpec (const True)
mempty defaultComponentRequestedSpec (const True)
buildPlatform
(unknownCompilerInfo
(CompilerId buildCompilerFlavor nullVersion)
......
......@@ -174,7 +174,7 @@ resolveWithFlags ::
-- ^ Either the missing dependencies (error case), or a pair of
-- (set of build targets with dependencies, chosen flag assignments)
resolveWithFlags dom enabled os arch impl constrs trees checkDeps =
either (Left . fromDepMapUnion) Right $ explore (build [] dom)
either (Left . fromDepMapUnion) Right $ explore (build mempty dom)
where
extraConstrs = toDepMap constrs
......@@ -209,7 +209,7 @@ resolveWithFlags dom enabled os arch impl constrs trees checkDeps =
build :: FlagAssignment -> [(FlagName, [Bool])] -> Tree FlagAssignment
build assigned [] = Node assigned []
build assigned ((fn, vals) : unassigned) =
Node assigned $ map (\v -> build ((fn, v) : assigned) unassigned) vals
Node assigned $ map (\v -> build (insertFlagAssignment fn v assigned) unassigned) vals
tryAll :: [Either DepMapUnion a] -> Either DepMapUnion a
tryAll = foldr mp mz
......@@ -229,7 +229,7 @@ resolveWithFlags dom enabled os arch impl constrs trees checkDeps =
mz = Left (DepMapUnion Map.empty)
env :: FlagAssignment -> FlagName -> Either FlagName Bool
env flags flag = (maybe (Left flag) Right . lookup flag) flags
env flags flag = (maybe (Left flag) Right . lookupFlagAssignment flag) flags
-- | Transforms a 'CondTree' by putting the input under the "then" branch of a
-- conditional that is True when Buildable is True. If 'addBuildableCondition'
......@@ -460,7 +460,7 @@ finalizePD userflags enabled satisfyDep
++ map (\(name,tree) -> mapTreeData (SubComp name . CBench) tree) bms0
flagChoices = map (\(MkFlag n _ d manual) -> (n, d2c manual n d)) flags
d2c manual n b = case lookup n userflags of
d2c manual n b = case lookupFlagAssignment n userflags of
Just val -> [val]
Nothing
| manual -> [b]
......
......@@ -794,7 +794,7 @@ checkDeprecatedFlags verbosity cfg = do
checkExactConfiguration :: Verbosity -> GenericPackageDescription -> ConfigFlags -> IO ()
checkExactConfiguration verbosity pkg_descr0 cfg =
when (fromFlagOrDefault False (configExactConfiguration cfg)) $ do
let cmdlineFlags = map fst (configConfigurationsFlags cfg)
let cmdlineFlags = map fst (unFlagAssignment (configConfigurationsFlags cfg))
allFlags = map flagName . genPackageFlags $ pkg_descr0
diffFlags = allFlags \\ cmdlineFlags
when (not . null $ diffFlags) $
......@@ -922,10 +922,10 @@ configureFinalizedPackage verbosity cfg enabled
-- we do it here so that those get checked too
let pkg_descr = addExtraIncludeLibDirs pkg_descr0'
when (not (null flags)) $
unless (nullFlagAssignment flags) $
info verbosity $ "Flags chosen: "
++ intercalate ", " [ unFlagName fn ++ "=" ++ display value
| (fn, value) <- flags ]
| (fn, value) <- unFlagAssignment flags ]
return (pkg_descr, flags)
where
......
......@@ -677,7 +677,7 @@ configureOptions showOrParseArgs =
configConfigurationsFlags (\v flags -> flags { configConfigurationsFlags = v })
(reqArg "FLAGS"
(parsecToReadE (\err -> "Invalid flag assignment: " ++ err) parsecFlagAssignment)
(map showFlagValue'))
showFlagAssignment)
,option "" ["extra-include-dirs"]
"A list of directories to search for header files"
......@@ -781,6 +781,9 @@ configureOptions showOrParseArgs =
reqArgFlag title _sf _lf d
(fmap fromPathTemplate . get) (set . fmap toPathTemplate)
showFlagAssignment :: FlagAssignment -> [String]
showFlagAssignment = map showFlagValue' . unFlagAssignment
where
-- We can't use 'showFlagValue' because legacy custom-setups don't
-- support the '+' prefix in --flags; so we omit the (redundant) + prefix;
-- NB: we assume that we never have to set/enable '-'-prefixed flags here.
......
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Distribution.Types.GenericPackageDescription (
GenericPackageDescription(..),
......@@ -10,6 +11,12 @@ module Distribution.Types.GenericPackageDescription (
mkFlagName,
unFlagName,
FlagAssignment,
mkFlagAssignment,
unFlagAssignment,
lookupFlagAssignment,
insertFlagAssignment,
diffFlagAssignment,
nullFlagAssignment,
showFlagValue,
dispFlagAssignment,
parseFlagAssignment,
......@@ -18,6 +25,7 @@ module Distribution.Types.GenericPackageDescription (
) where
import Prelude ()
import Data.List ((\\))
import Distribution.Compat.Prelude
import Distribution.Utils.ShortText
import Distribution.Utils.Generic (lowercase)
......@@ -146,7 +154,75 @@ instance Text FlagName where
-- discovered during configuration. For example @--flags=foo --flags=-bar@
-- becomes @[("foo", True), ("bar", False)]@
--
type FlagAssignment = [(FlagName, Bool)]
newtype FlagAssignment = FlagAssignment [(FlagName, Bool)]
deriving (Binary,Eq,Ord,Semigroup,Monoid)
-- 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`.
--
-- 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.
-- | Construct a 'FlagAssignment' from a list of flag/value pairs.
--
-- @since 2.2.0
mkFlagAssignment :: [(FlagName, Bool)] -> FlagAssignment
mkFlagAssignment = FlagAssignment
-- | Deconstruct a 'FlagAssignment' into a list of flag/value pairs.
--
-- @ ('mkFlagAssignment' . 'unFlagAssignment') fa == fa @
--
-- @since 2.2.0
unFlagAssignment :: FlagAssignment -> [(FlagName, Bool)]
unFlagAssignment (FlagAssignment xs) = xs
-- | Test whether 'FlagAssignment' is empty.
--
-- @since 2.2.0
nullFlagAssignment :: FlagAssignment -> Bool
nullFlagAssignment (FlagAssignment []) = True
nullFlagAssignment _ = False
-- | Lookup the value for a flag
--
-- Returns 'Nothing' if the flag isn't contained in the 'FlagAssignment'.
--
-- @since 2.2.0
lookupFlagAssignment :: FlagName -> FlagAssignment -> Maybe Bool
lookupFlagAssignment fn = lookup fn . unFlagAssignment
-- | Insert or update the boolean value of a flag.
--
-- @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
-- | Remove all flag-assignments from the first 'FlagAssignment' that
-- are contained in the second 'FlagAssignment'
--
-- NB/TODO: This currently only removes flag assignments which also
-- match the value assignment! We should review the code which uses
-- this operation to figure out if this it's not enough to only
-- compare the flagnames without the values.
--
-- @since 2.2.0
diffFlagAssignment :: FlagAssignment -> FlagAssignment -> FlagAssignment
diffFlagAssignment fa1 fa2 = mkFlagAssignment (unFlagAssignment fa1 \\ unFlagAssignment fa2)
-- | @since 2.2.0
instance Read FlagAssignment where
readsPrec p s = [ (FlagAssignment x, rest) | (x,rest) <- readsPrec p s ]
-- | @since 2.2.0
instance Show FlagAssignment where
showsPrec p (FlagAssignment xs) = showsPrec p xs
-- | String representation of a flag-value pair.
showFlagValue :: (FlagName, Bool) -> String
......@@ -155,11 +231,11 @@ showFlagValue (f, False) = '-' : unFlagName f
-- | Pretty-prints a flag assignment.
dispFlagAssignment :: FlagAssignment -> Disp.Doc
dispFlagAssignment = Disp.hsep . map (Disp.text . showFlagValue)
dispFlagAssignment = Disp.hsep . map (Disp.text . showFlagValue) . unFlagAssignment
-- | Parses a flag assignment.
parsecFlagAssignment :: ParsecParser FlagAssignment
parsecFlagAssignment = P.sepBy (onFlag <|> offFlag) P.skipSpaces1
parsecFlagAssignment = FlagAssignment <$> P.sepBy (onFlag <|> offFlag) P.skipSpaces1
where
onFlag = do
P.optional (P.char '+')
......@@ -172,7 +248,7 @@ parsecFlagAssignment = P.sepBy (onFlag <|> offFlag) P.skipSpaces1
-- | Parses a flag assignment.
parseFlagAssignment :: Parse.ReadP r FlagAssignment
parseFlagAssignment = Parse.sepBy parseFlagValue Parse.skipSpaces1
parseFlagAssignment = FlagAssignment <$> Parse.sepBy parseFlagValue Parse.skipSpaces1
where
parseFlagValue =
(do Parse.optional (Parse.char '+')
......
......@@ -4,6 +4,7 @@
* Added cxx-options and cxx-sources build info fields for seperate
compilation of C++ source files (#3700)
* Remove unused '--allow-newer'/'--allow-older' support (#4527)
* Change `FlagAssignment` to be an opaque `newtype`.
* Change `rawSystemStdInOut` to use proper type to represent
binary and textual data; new 'Distribution.Utils.IOData' module;
removed obsolete 'startsWithBOM', 'fileHasBOM', 'fromUTF8',
......
......@@ -26,6 +26,9 @@ module Distribution.Client.BuildReports.Anonymous (
-- showList,
) where
import Prelude ()
import Distribution.Client.Compat.Prelude hiding (show)
import qualified Distribution.Client.Types as BR
( BuildOutcome, BuildFailure(..), BuildResult(..)
, DocsResult(..), TestsResult(..) )
......@@ -36,7 +39,8 @@ import qualified Paths_cabal_install (version)
import Distribution.Package
( PackageIdentifier(..), mkPackageName )
import Distribution.PackageDescription
( FlagName, mkFlagName, unFlagName, FlagAssignment )
( FlagName, mkFlagName, unFlagName
, FlagAssignment, mkFlagAssignment, unFlagAssignment )
import Distribution.Version
( mkVersion' )
import Distribution.System
......@@ -57,15 +61,11 @@ import qualified Distribution.Compat.ReadP as Parse
import qualified Text.PrettyPrint as Disp
( Doc, render, char, text )
import Text.PrettyPrint
( (<+>), (<>) )
( (<+>) )
import Data.List
( unfoldr, sortBy )
import Data.Char as Char
( isAlpha, isAlphaNum )
import Prelude hiding (show)
data BuildReport
= BuildReport {
-- | The package this build report is about
......@@ -173,7 +173,7 @@ initialBuildReport = BuildReport {
arch = requiredField "arch",
compiler = requiredField "compiler",
client = requiredField "client",
flagAssignment = [],
flagAssignment = mempty,
dependencies = [],
installOutcome = requiredField "install-outcome",
-- cabalVersion = Nothing,
......@@ -194,7 +194,7 @@ parse s = case parseFields s of
parseFields :: String -> ParseResult BuildReport
parseFields input = do
fields <- mapM extractField =<< readFields input
fields <- traverse extractField =<< readFields input
let merged = mergeBy (\desc (_,name,_) -> compare (fieldName desc) name)
sortedFieldDescrs
(sortBy (comparing (\(_,name,_) -> name)) fields)
......@@ -249,7 +249,8 @@ fieldDescrs =
, simpleField "client" Text.disp Text.parse
client (\v r -> r { client = v })
, listField "flags" dispFlag parseFlag
flagAssignment (\v r -> r { flagAssignment = v })
(unFlagAssignment . flagAssignment)
(\v r -> r { flagAssignment = mkFlagAssignment v })
, listField "dependencies" Text.disp Text.parse
dependencies (\v r -> r { dependencies = v })
, simpleField "install-outcome" Text.disp Text.parse
......@@ -265,7 +266,7 @@ sortedFieldDescrs = sortBy (comparing fieldName) fieldDescrs
dispFlag :: (FlagName, Bool) -> Disp.Doc
dispFlag (fname, True) = Disp.text (unFlagName fname)
dispFlag (fname, False) = Disp.char '-' <> Disp.text (unFlagName fname)
dispFlag (fname, False) = Disp.char '-' <<>> Disp.text (unFlagName fname)
parseFlag :: Parse.ReadP r (FlagName, Bool)
parseFlag = do
......
......@@ -29,7 +29,7 @@ import Distribution.Version
( VersionRange, thisVersion
, unionVersionRanges, simplifyVersionRange )
import Distribution.PackageDescription
( FlagAssignment )
( FlagAssignment, nullFlagAssignment )
import Distribution.Client.Setup
( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags
, applyFlagDefaults )
......@@ -202,7 +202,7 @@ projectFreezeConstraints plan =
| InstallPlan.Configured elab <- InstallPlan.toList plan
, let flags = elabFlagAssignment elab
pkgname = packageName elab
, not (null flags) ]
, not (nullFlagAssignment flags) ]
-- As described above, remove the version constraints on local packages,
-- but leave any flag constraints.
......
......@@ -204,6 +204,12 @@ instance Semigroup SavedConfig where
in case b' of [] -> a'
_ -> b'
lastNonMempty' :: (Eq a, Monoid a) => (SavedConfig -> flags) -> (flags -> a) -> a
lastNonMempty' field subfield =
let a' = subfield . field $ a
b' = subfield . field $ b
in if b' == mempty then a' else b'
lastNonEmptyNL' :: (SavedConfig -> flags) -> (flags -> NubList a)
-> NubList a
lastNonEmptyNL' field subfield =
......@@ -326,7 +332,7 @@ instance Semigroup SavedConfig where
-- TODO: NubListify
configDependencies = lastNonEmpty configDependencies,
-- TODO: NubListify
configConfigurationsFlags = lastNonEmpty configConfigurationsFlags,
configConfigurationsFlags = lastNonMempty configConfigurationsFlags,
configTests = combine configTests,
configBenchmarks = combine configBenchmarks,
configCoverage = combine configCoverage,
......@@ -340,6 +346,7 @@ instance Semigroup SavedConfig where
combine = combine' savedConfigureFlags
lastNonEmpty = lastNonEmpty' savedConfigureFlags
lastNonEmptyNL = lastNonEmptyNL' savedConfigureFlags
lastNonMempty = lastNonMempty' savedConfigureFlags
combinedSavedConfigureExFlags = ConfigExFlags {
configCabalVersion = combine configCabalVersion,
......
......@@ -898,7 +898,8 @@ configuredPackageProblems :: Platform -> CompilerInfo
-> SolverPackage UnresolvedPkgLoc -> [PackageProblem]
configuredPackageProblems platform cinfo
(SolverPackage pkg specifiedFlags stanzas specifiedDeps' _specifiedExeDeps') =
[ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ]
-- FIXME/TODO: FlagAssignment ought to be duplicate-free as internal invariant
[ DuplicateFlag flag | ((flag,_):_) <- duplicates (PD.unFlagAssignment specifiedFlags) ]
++ [ MissingFlag flag | OnlyInLeft flag <- mergedFlags ]
++ [ ExtraFlag flag | OnlyInRight flag <- mergedFlags ]
++ [ DuplicateDeps pkgs
......@@ -915,7 +916,7 @@ configuredPackageProblems platform cinfo
mergedFlags = mergeBy compare
(sort $ map PD.flagName (PD.genPackageFlags (packageDescription pkg)))
(sort $ map fst specifiedFlags)
(sort $ map fst (PD.unFlagAssignment specifiedFlags)) -- TODO
packageSatisfiesDependency
(PackageIdentifier name version)
......
......@@ -15,6 +15,9 @@ module Distribution.Client.GenBounds (
genBounds
) where
import Prelude ()
import Distribution.Client.Compat.Prelude
import Distribution.Client.Init
( incVersion )
import Distribution.Client.Freeze
......@@ -113,7 +116,7 @@ genBounds verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo
gpd <- readGenericPackageDescription verbosity path
-- NB: We don't enable tests or benchmarks, since often they
-- don't really have useful bounds.
let epd = finalizePD [] defaultComponentRequestedSpec
let epd = finalizePD mempty defaultComponentRequestedSpec
(const True) platform cinfo [] gpd
case epd of
Left _ -> putStrLn "finalizePD failed"
......@@ -138,7 +141,7 @@ genBounds verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo
let thePkgs = filter isNeeded pkgs
let padTo = maximum $ map (length . unPackageName . packageName) pkgs
mapM_ (putStrLn . (++",") . showBounds padTo) thePkgs
traverse_ (putStrLn . (++",") . showBounds padTo) thePkgs
depName :: Dependency -> String
depName (Dependency pn _) = unPackageName pn
......
......@@ -32,8 +32,6 @@ module Distribution.Client.Install (
import Prelude ()
import Distribution.Client.Compat.Prelude
import Data.List
( (\\) )
import qualified Data.Map as Map
import qualified Data.Set as S
import Control.Exception as Exception
......@@ -149,7 +147,8 @@ import Distribution.Types.MungedPackageId
import qualified Distribution.PackageDescription as PackageDescription
import Distribution.PackageDescription
( PackageDescription, GenericPackageDescription(..), Flag(..)
, FlagAssignment, showFlagValue )
, FlagAssignment, mkFlagAssignment, unFlagAssignment
, showFlagValue, diffFlagAssignment, nullFlagAssignment )
import Distribution.PackageDescription.Configuration
( finalizePD )
import Distribution.ParseUtils
......@@ -419,7 +418,7 @@ planPackages verbosity comp platform mSandboxPkgInfo solver
(PackagePropertyFlags flags)
in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
| let flags = configConfigurationsFlags configFlags
, not (null flags)
, not (nullFlagAssignment flags)
, pkgSpecifier <- pkgSpecifiers ]
. addConstraints
......@@ -695,7 +694,7 @@ printPlan dryRun verbosity plan sourcePkgDb = case plan of
x -> Just $ packageVersion $ last x
toFlagAssignment :: [Flag] -> FlagAssignment
toFlagAssignment = map (\ f -> (flagName f, flagDefault f))
toFlagAssignment = mkFlagAssignment . map (\ f -> (flagName f, flagDefault f))
nonDefaultFlags :: ConfiguredPackage loc -> FlagAssignment
nonDefaultFlags cpkg =
......@@ -703,13 +702,13 @@ printPlan dryRun verbosity plan sourcePkgDb = case plan of
toFlagAssignment
(genPackageFlags (SourcePackage.packageDescription $
confPkgSource cpkg))
in confPkgFlags cpkg \\ defaultAssignment
in confPkgFlags cpkg `diffFlagAssignment` defaultAssignment
showStanzas :: [OptionalStanza] -> String
showStanzas = concatMap ((" *" ++) . showStanza)
showFlagAssignment :: FlagAssignment -> String
showFlagAssignment = concatMap ((' ' :) . showFlagValue)
showFlagAssignment = concatMap ((' ' :) . showFlagValue) . unFlagAssignment
change (OnlyInLeft pkgid) = display pkgid ++ " removed"
change (InBoth pkgid pkgid') = display pkgid ++ " -> "
......@@ -825,7 +824,7 @@ postInstallActions verbosity
unless oneShot $
World.insert verbosity worldFile
--FIXME: does not handle flags
[ World.WorldPkgInfo dep []
[ World.WorldPkgInfo dep mempty
| UserTargetNamed dep <- targets ]
let buildReports = BuildReports.fromInstallPlan platform (compilerId comp)
......
......@@ -147,7 +147,7 @@ depsFromPkgDesc verbosity comp platform = do
path <- tryFindPackageDesc cwd
gpd <- readGenericPackageDescription verbosity path
let cinfo = compilerInfo comp
epd = finalizePD [] (ComponentRequestedSpec True True)
epd = finalizePD mempty (ComponentRequestedSpec True True)
(const True) platform cinfo [] gpd
case epd of
Left _ -> die' verbosity "finalizePD failed"
......
......@@ -29,13 +29,16 @@ module Distribution.Client.PackageHash (
hashFromTUF,
) where
import Prelude ()
import Distribution.Client.Compat.Prelude
import Distribution.Package
( PackageId, PackageIdentifier(..), mkComponentId
, PkgconfigName )
import Distribution.System
( Platform, OS(Windows, OSX), buildOS )
import Distribution.PackageDescription
( FlagAssignment, showFlagValue )
( FlagAssignment, unFlagAssignment, showFlagValue )
import Distribution.Simple.Compiler
( CompilerId, OptimisationLevel(..), DebugInfoLevel(..)
, ProfDetailLevel(..), showProfDetailLevel )
......@@ -58,12 +61,7 @@ import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Set (Set)
import Data.Typeable
import Data.Maybe (catMaybes)
import Data.List (sortBy, intercalate)
import Data.Map (Map)
import Data.Function (on)
import Distribution.Compat.Binary (Binary(..))
import Control.Exception (evaluate)
import System.IO (withBinaryFile, IOMode(..))
......@@ -269,7 +267,7 @@ renderPackageHashInputs PackageHashInputs{
-- and then all the config
, entry "compilerid" display pkgHashCompilerId
, entry "platform" display pkgHashPlatform
, opt "flags" [] showFlagAssignment pkgHashFlagAssignment
, opt "flags" mempty showFlagAssignment pkgHashFlagAssignment
, opt "configure-script" [] unwords pkgHashConfigureScriptArgs
, opt "vanilla-lib" True display pkgHashVanillaLib
, opt "shared-lib" False display pkgHashSharedLib
......@@ -298,7 +296,7 @@ renderPackageHashInputs PackageHashInputs{
| value == def = Nothing
| otherwise = entry key format value
showFlagAssignment = unwords . map showFlagValue . sortBy (compare `on` fst)
showFlagAssignment = unwords . map showFlagValue . sortBy (compare `on` fst) . unFlagAssignment
-----------------------------------------------
-- The specific choice of hash implementation
......
......@@ -118,7 +118,9 @@ import Distribution.Solver.Types.OptionalStanza
import Distribution.Package
hiding (InstalledPackageId, installedPackageId)
import Distribution.PackageDescription (FlagAssignment, showFlagValue)
import Distribution.PackageDescription
( FlagAssignment, unFlagAssignment, showFlagValue
, diffFlagAssignment )
import Distribution.Simple.LocalBuildInfo
( ComponentName(..), pkgComponents )
import qualified Distribution.Simple.Setup as Setup
......@@ -703,7 +705,7 @@ printPlan verbosity
| (k,v) <- Map.toList (elabInstantiatedWith elab) ]
nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment
nonDefaultFlags elab = elabFlagAssignment elab \\ elabFlagDefaults elab
nonDefaultFlags elab = elabFlagAssignment elab `diffFlagAssignment` elabFlagDefaults elab
showStanzas pkg = concat
$ [ " *test"
......@@ -718,7 +720,7 @@ printPlan verbosity
++ ")"
showFlagAssignment :: FlagAssignment -> String
showFlagAssignment = concatMap ((' ' :) . showFlagValue)
showFlagAssignment = concatMap ((' ' :) . showFlagValue) . unFlagAssignment
showConfigureFlags elab =
let fullConfigureFlags
......
......@@ -137,7 +137,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =
, "pkg-name" J..= (jdisplay . pkgName . packageId) elab
, "pkg-version" J..= (jdisplay . pkgVersion . packageId) elab
, "flags" J..= J.object [ PD.unFlagName fn J..= v
| (fn,v) <- elabFlagAssignment elab ]
| (fn,v) <- PD.unFlagAssignment (elabFlagAssignment elab) ]
, "style" J..= J.String (style2str (elabLocalToProject elab) (elabBuildStyle elab))
] ++
[ "pkg-src-sha256" J..= J.String (showHashValue hash)
......
......@@ -1008,7 +1008,7 @@ planPackages verbosity comp platform solver SolverSettings{..}
(PackagePropertyFlags flags))
ConstraintSourceConfigFlagOrTarget
| let flags = solverSettingFlagAssignment
, not (null flags)
, not (PD.nullFlagAssignment flags)
, pkg <- localPackages
, let pkgname = packageName pkg ]
......@@ -1614,7 +1614,8 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB
[] gdesc
in desc
elabFlagAssignment = flags
elabFlagDefaults = [ (Cabal.flagName flag, Cabal.flagDefault flag)
elabFlagDefaults = PD.mkFlagAssignment
[ (Cabal.flagName flag, Cabal.flagDefault flag)
| flag <- PD.genPackageFlags gdesc ]
elabEnabledSpec = enableStanzas stanzas
......
......@@ -82,7 +82,7 @@ import Distribution.Client.GlobalFlags
( RepoContext(..) )
import Distribution.PackageDescription
( GenericPackageDescription, parseFlagAssignment )
( GenericPackageDescription, parseFlagAssignment, nullFlagAssignment )
import Distribution.Version
( nullVersion, thisVersion, anyVersion, isAnyVersion )
import Distribution.Text
......@@ -436,7 +436,7 @@ expandUserTarget verbosity worldFile userTarget = case userTarget of
, let props = [ PackagePropertyVersion vrange