Commit 13a8221c authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺 Committed by Edward Z. Yang

Make 'FlagName' opaque

Construction and destruction follows the usual pattern with `mkFlagName`
& `unFlagName` functions.
parent d731a1c4
......@@ -90,7 +90,9 @@ module Distribution.PackageDescription (
-- * package configuration
GenericPackageDescription(..),
Flag(..), emptyFlag, FlagName(..), FlagAssignment,
Flag(..), emptyFlag,
FlagName, mkFlagName, unFlagName,
FlagAssignment,
CondTree(..), ConfVar(..), Condition(..),
cNot, cAnd, cOr,
......
......@@ -144,7 +144,7 @@ parseCondition = condOr
boolLiteral = fmap Lit parse
archIdent = fmap Arch parse
osIdent = fmap OS parse
flagIdent = fmap (Flag . FlagName . lowercase) (munch1 isIdentChar)
flagIdent = fmap (Flag . mkFlagName . lowercase) (munch1 isIdentChar)
isIdentChar c = isAlphaNum c || c == '_' || c == '-'
oper s = sp >> string s >> sp
sp = skipSpaces
......
......@@ -1006,7 +1006,7 @@ parsePackageDescription file = do
flag <- lift $ parseFields
flagFieldDescrs
warnUnrec
(emptyFlag (FlagName (lowercase sec_label)))
(emptyFlag (mkFlagName (lowercase sec_label)))
sec_fields
skipField
(repos, flags, csetup, mlib, sub_libs, flibs, exes, tests, bms) <- getBody pkg
......@@ -1157,7 +1157,7 @@ parsePackageDescription file = do
let fv = nub $ freeVars ct
unless (all (`elem` definedFlags) fv) $
fail $ "These flags are used without having been defined: "
++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ]
++ intercalate ", " [ unFlagName fn | fn <- fv \\ definedFlags ]
-- Check that a property holds on all branches of a condition tree
onAllBranches :: forall v c a. Monoid a => (a -> Bool) -> CondTree v c a -> Bool
......
......@@ -254,7 +254,7 @@ parseGenericPackageDescription' lexWarnings fs = do
| name == "flag" = do
name' <- parseName pos args
name'' <- runFieldParser' pos parsec name' `recoverWith` FlagName ""
name'' <- runFieldParser' pos parsec name' `recoverWith` mkFlagName ""
flag <- parseFields flagFieldDescrs warnUnrec (emptyFlag name'') fields
-- Check default flag
let gpd' = gpd { genPackageFlags = genPackageFlags gpd ++ [flag] }
......
......@@ -228,7 +228,7 @@ ppConfVar (Flag name) = text "flag" <<>> parens (ppFlagName n
ppConfVar (Impl c v) = text "impl" <<>> parens (disp c <+> disp v)
ppFlagName :: FlagName -> Doc
ppFlagName (FlagName name) = text name
ppFlagName = text . unFlagName
ppCondTree :: CondTree ConfVar [Dependency] a -> Maybe a -> (a -> Maybe a -> Doc) -> Doc
ppCondTree ct@(CondNode it _ ifs) mbIt ppIt =
......
......@@ -42,7 +42,7 @@ import Distribution.Text (display)
import Distribution.Types.BenchmarkType
(BenchmarkType (..))
import Distribution.Types.BuildType (BuildType (..))
import Distribution.Types.GenericPackageDescription (FlagName (..))
import Distribution.Types.GenericPackageDescription (FlagName, mkFlagName)
import Distribution.Types.ModuleReexport
(ModuleReexport (..))
import Distribution.Types.SourceRepo
......@@ -107,7 +107,7 @@ instance Parsec ModuleName where
validModuleChar c = isAlphaNum c || c == '_' || c == '\''
instance Parsec FlagName where
parsec = FlagName . map toLower . intercalate "-" <$> P.sepBy1 component (P.char '-')
parsec = mkFlagName . map toLower . intercalate "-" <$> P.sepBy1 component (P.char '-')
where
-- http://hackage.haskell.org/package/cabal-debian-4.24.8/cabal-debian.cabal
-- has flag with all digit component: pretty-112
......
......@@ -930,8 +930,8 @@ configureFinalizedPackage verbosity cfg enabled
when (not (null flags)) $
info verbosity $ "Flags chosen: "
++ intercalate ", " [ name ++ "=" ++ display value
| (FlagName name, value) <- flags ]
++ intercalate ", " [ unFlagName fn ++ "=" ++ display value
| (fn, value) <- flags ]
return (pkg_descr, flags)
where
......
......@@ -841,12 +841,12 @@ configureOptions showOrParseArgs =
where
readFlagList :: String -> FlagAssignment
readFlagList = map tagWithValue . words
where tagWithValue ('-':fname) = (FlagName (lowercase fname), False)
tagWithValue fname = (FlagName (lowercase fname), True)
where tagWithValue ('-':fname) = (mkFlagName (lowercase fname), False)
tagWithValue fname = (mkFlagName (lowercase fname), True)
showFlagList :: FlagAssignment -> [String]
showFlagList fs = [ if not set then '-':fname else fname
| (FlagName fname, set) <- fs]
showFlagList fs = [ if not set then '-':unFlagName fname else unFlagName fname
| (fname, set) <- fs]
liftInstallDirs =
liftOption configInstallDirs (\v flags -> flags { configInstallDirs = v })
......
......@@ -8,7 +8,9 @@ module Distribution.Types.GenericPackageDescription (
GenericPackageDescription(..),
Flag(..),
emptyFlag,
FlagName(..),
FlagName,
mkFlagName,
unFlagName,
FlagAssignment,
ConfVar(..),
Condition(..),
......@@ -77,9 +79,32 @@ emptyFlag name = MkFlag
}
-- | A 'FlagName' is the name of a user-defined configuration flag
--
-- Use 'mkFlagName' and 'unFlagName' to convert from/to a 'String'.
--
-- This type is opaque since @Cabal-2.0@
--
-- @since 2.0
newtype FlagName = FlagName String
deriving (Eq, Generic, Ord, Show, Read, Typeable, Data)
-- | Construct a 'FlagName' from a 'String'
--
-- 'mkFlagName' is the inverse to 'unFlagName'
--
-- Note: No validations are performed to ensure that the resulting
-- 'FlagName' is valid
--
-- @since 2.0
mkFlagName :: String -> FlagName
mkFlagName = FlagName
-- | Convert 'FlagName' to 'String'
--
-- @since 2.0
unFlagName :: FlagName -> String
unFlagName (FlagName s) = s
instance Binary FlagName
-- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to
......
......@@ -55,6 +55,9 @@
* Backwards incompatible change to 'AbiHash' (#3921):
'AbiHash' is now opaque; conversion to/from 'String' now works
via 'unAbiHash' and 'mkAbiHash' functions.
* Backwards incompatible change to 'FlagName' (#xxxx):
'FlagName' is now opaque; conversion to/from 'String' now works
via 'unFlagName' and 'mkFlagName' functions.
* Backwards incompatible change to 'Version' (#3905):
Version is now opaque; conversion to/from '[Int]' now works
via 'versionNumbers' and 'mkVersion' functions.
......
......@@ -36,7 +36,7 @@ import qualified Paths_cabal_install (version)
import Distribution.Package
( PackageIdentifier(..), mkPackageName )
import Distribution.PackageDescription
( FlagName(..), FlagAssignment )
( FlagName, mkFlagName, unFlagName, FlagAssignment )
import Distribution.Version
( mkVersion' )
import Distribution.System
......@@ -264,15 +264,15 @@ sortedFieldDescrs :: [FieldDescr BuildReport]
sortedFieldDescrs = sortBy (comparing fieldName) fieldDescrs
dispFlag :: (FlagName, Bool) -> Disp.Doc
dispFlag (FlagName name, True) = Disp.text name
dispFlag (FlagName name, False) = Disp.char '-' <> Disp.text name
dispFlag (fname, True) = Disp.text (unFlagName fname)
dispFlag (fname, False) = Disp.char '-' <> Disp.text (unFlagName fname)
parseFlag :: Parse.ReadP r (FlagName, Bool)
parseFlag = do
name <- Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')
case name of
('-':flag) -> return (FlagName flag, False)
flag -> return (FlagName flag, True)
('-':flag) -> return (mkFlagName flag, False)
flag -> return (mkFlagName flag, True)
instance Text.Text InstallOutcome where
disp PlanningFailed = Disp.text "PlanningFailed"
......
......@@ -747,14 +747,14 @@ data PackageProblem = DuplicateFlag PD.FlagName
| InvalidDep Dependency PackageId
showPackageProblem :: PackageProblem -> String
showPackageProblem (DuplicateFlag (PD.FlagName flag)) =
"duplicate flag in the flag assignment: " ++ flag
showPackageProblem (DuplicateFlag flag) =
"duplicate flag in the flag assignment: " ++ PD.unFlagName flag
showPackageProblem (MissingFlag (PD.FlagName flag)) =
"missing an assignment for the flag: " ++ flag
showPackageProblem (MissingFlag flag) =
"missing an assignment for the flag: " ++ PD.unFlagName flag
showPackageProblem (ExtraFlag (PD.FlagName flag)) =
"extra flag given that is not used by the package: " ++ flag
showPackageProblem (ExtraFlag flag) =
"extra flag given that is not used by the package: " ++ PD.unFlagName flag
showPackageProblem (DuplicateDeps pkgids) =
"duplicate packages specified as selected dependencies: "
......
......@@ -150,7 +150,7 @@ import Distribution.Package
import qualified Distribution.PackageDescription as PackageDescription
import Distribution.PackageDescription
( PackageDescription, GenericPackageDescription(..), Flag(..)
, FlagName(..), FlagAssignment )
, unFlagName, FlagAssignment )
import Distribution.PackageDescription.Configuration
( finalizePD )
import Distribution.ParseUtils
......@@ -703,7 +703,7 @@ printPlan dryRun verbosity plan sourcePkgDb = case plan of
showFlagAssignment = concatMap ((' ' :) . showFlagValue)
showFlagValue (f, True) = '+' : showFlagName f
showFlagValue (f, False) = '-' : showFlagName f
showFlagName (FlagName f) = f
showFlagName = unFlagName
change (OnlyInLeft pkgid) = display pkgid ++ " removed"
change (InBoth pkgid pkgid') = display pkgid ++ " -> "
......
......@@ -22,7 +22,7 @@ import Distribution.License (License)
import qualified Distribution.InstalledPackageInfo as Installed
import qualified Distribution.PackageDescription as Source
import Distribution.PackageDescription
( Flag(..), FlagName(..) )
( Flag(..), unFlagName )
import Distribution.PackageDescription.Configuration
( flattenPackageDescription )
......@@ -380,7 +380,7 @@ showPackageDetailedInfo pkginfo =
orNotSpecified = altText null "[ Not specified ]"
commaSep f = Disp.fsep . Disp.punctuate (Disp.char ',') . map f
dispFlag f = case flagName f of FlagName n -> text n
dispFlag = text . unFlagName . flagName
dispYesNo True = text "Yes"
dispYesNo False = text "No"
......
......@@ -33,7 +33,7 @@ import Distribution.Package
import Distribution.System
( Platform, OS(Windows), buildOS )
import Distribution.PackageDescription
( FlagName(..), FlagAssignment )
( unFlagName, FlagAssignment )
import Distribution.Simple.Compiler
( CompilerId, OptimisationLevel(..), DebugInfoLevel(..)
, ProfDetailLevel(..), showProfDetailLevel )
......@@ -261,8 +261,8 @@ renderPackageHashInputs PackageHashInputs{
showFlagAssignment = unwords . map showEntry . sortBy (compare `on` fst)
where
showEntry (FlagName name, False) = '-' : name
showEntry (FlagName name, True) = '+' : name
showEntry (fname, False) = '-' : unFlagName fname
showEntry (fname, True) = '+' : unFlagName fname
-----------------------------------------------
-- The specific choice of hash implementation
......
......@@ -565,7 +565,7 @@ printPlan verbosity
showFlagAssignment = concatMap ((' ' :) . showFlagValue)
showFlagValue (f, True) = '+' : showFlagName f
showFlagValue (f, False) = '-' : showFlagName f
showFlagName (PD.FlagName f) = f
showFlagName = PD.unFlagName
showConfigureFlags elab =
let fullConfigureFlags
......
......@@ -119,9 +119,8 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =
[ "type" J..= J.String (if isInstalled then "installed"
else "configured")
, "id" J..= (jdisplay . installedUnitId) elab
, "flags" J..= J.object [ fn J..= v
| (PD.FlagName fn,v) <-
elabFlagAssignment elab ]
, "flags" J..= J.object [ PD.unFlagName fn J..= v
| (fn,v) <- elabFlagAssignment elab ]
, "style" J..= J.String (style2str (elabLocalToProject elab) (elabBuildStyle elab))
] ++
(case elabBuildStyle elab of
......
......@@ -79,7 +79,7 @@ import Distribution.Client.GlobalFlags
( RepoContext(..) )
import Distribution.PackageDescription
( GenericPackageDescription, FlagName(..), FlagAssignment )
( GenericPackageDescription, mkFlagName, unFlagName, FlagAssignment )
import Distribution.PackageDescription.Parse
( readPackageDescription, parsePackageDescription, ParseResult(..) )
import Distribution.Version
......@@ -788,7 +788,7 @@ dispFlagAssignment = Disp.hsep . map dispFlagValue
where
dispFlagValue (f, True) = Disp.char '+' <<>> dispFlagName f
dispFlagValue (f, False) = Disp.char '-' <<>> dispFlagName f
dispFlagName (FlagName f) = Disp.text f
dispFlagName = Disp.text . unFlagName
parseFlagAssignment :: Parse.ReadP r FlagAssignment
parseFlagAssignment = Parse.sepBy1 parseFlagValue skipSpaces1
......@@ -800,7 +800,7 @@ parseFlagAssignment = Parse.sepBy1 parseFlagValue skipSpaces1
+++ (do _ <- Parse.char '-'
f <- parseFlagName
return (f, False))
parseFlagName = liftM (FlagName . lowercase) ident
parseFlagName = liftM (mkFlagName . lowercase) ident
ident :: Parse.ReadP r String
ident = Parse.munch1 identChar >>= \s -> check s >> return s
......
......@@ -32,7 +32,7 @@ module Distribution.Client.World (
import Distribution.Package
( Dependency(..) )
import Distribution.PackageDescription
( FlagAssignment, FlagName(FlagName) )
( FlagAssignment, mkFlagName, unFlagName )
import Distribution.Verbosity
( Verbosity )
import Distribution.Simple.Utils
......@@ -128,10 +128,10 @@ instance Text WorldPkgInfo where
dispFlags [] = Disp.empty
dispFlags fs = Disp.text "--flags="
<> Disp.doubleQuotes (flagAssToDoc fs)
flagAssToDoc = foldr (\(FlagName fname,val) flagAssDoc ->
flagAssToDoc = foldr (\(fname,val) flagAssDoc ->
(if not val then Disp.char '-'
else Disp.empty)
Disp.<> Disp.text fname
Disp.<> Disp.text (unFlagName fname)
Disp.<+> flagAssDoc)
Disp.empty
parse = do
......@@ -156,7 +156,7 @@ instance Text WorldPkgInfo where
val <- negative Parse.+++ positive
name <- ident
Parse.skipSpaces
return (FlagName name,val)
return (mkFlagName name,val)
negative = do
_ <- Parse.char '-'
return False
......
......@@ -33,10 +33,10 @@ data FN qpn = FN (PI qpn) Flag
type Flag = FlagName
unFlag :: Flag -> String
unFlag (FlagName fn) = fn
unFlag = unFlagName
mkFlag :: String -> Flag
mkFlag fn = FlagName fn
mkFlag = mkFlagName
-- | Flag info. Default value, whether the flag is manual, and
-- whether the flag is weak. Manual flags can only be set explicitly.
......
......@@ -5,7 +5,7 @@ module Distribution.Solver.Types.PackageConstraint (
) where
import Distribution.Compat.Binary (Binary(..))
import Distribution.PackageDescription (FlagAssignment, FlagName(..))
import Distribution.PackageDescription (FlagAssignment, unFlagName)
import Distribution.Package (PackageName)
import Distribution.Solver.Types.OptionalStanza
import Distribution.Text (display)
......@@ -40,8 +40,8 @@ showPackageConstraint (PackageConstraintSource pn) =
showPackageConstraint (PackageConstraintFlags pn fs) =
"flags " ++ display pn ++ " " ++ unwords (map (uncurry showFlag) fs)
where
showFlag (FlagName f) True = "+" ++ f
showFlag (FlagName f) False = "-" ++ f
showFlag f True = "+" ++ unFlagName f
showFlag f False = "-" ++ unFlagName f
showPackageConstraint (PackageConstraintStanzas pn ss) =
"stanzas " ++ display pn ++ " " ++ unwords (map showStanza ss)
where
......
......@@ -202,8 +202,8 @@ hackProjectConfigShared config =
--TODO: [required eventually] parse ambiguity in constraint
-- "pkgname -any" as either any version or disabled flag "any".
let ambiguous ((UserConstraintFlags _pkg flags), _) =
(not . null) [ () | (FlagName name, False) <- flags
, "any" `isPrefixOf` name ]
(not . null) [ () | (name, False) <- flags
, "any" `isPrefixOf` unFlagName name ]
ambiguous _ = False
in filter (not . ambiguous) (projectConfigConstraints config)
}
......@@ -576,7 +576,7 @@ instance Arbitrary OptionalStanza where
arbitrary = elements [minBound..maxBound]
instance Arbitrary FlagName where
arbitrary = FlagName <$> flagident
arbitrary = mkFlagName <$> flagident
where
flagident = lowercase <$> shortListOf1 5 (elements flagChars)
`suchThat` (("-" /=) . take 1)
......
......@@ -374,7 +374,7 @@ exAvSrcPkg ex =
extractFlags (ExBuildToolAny _) = []
extractFlags (ExBuildToolFix _ _) = []
extractFlags (ExFlag f a b) = C.MkFlag {
C.flagName = C.FlagName f
C.flagName = C.mkFlagName f
, C.flagDescription = ""
, C.flagDefault = True
, C.flagManual = False
......@@ -446,7 +446,7 @@ exAvSrcPkg ex =
-> ( C.Condition C.ConfVar
, DependencyTree C.BuildInfo
, Maybe (DependencyTree C.BuildInfo))
mkFlagged (f, a, b) = ( C.Var (C.Flag (C.FlagName f))
mkFlagged (f, a, b) = ( C.Var (C.Flag (C.mkFlagName f))
, mkBuildInfoTree a
, Just (mkBuildInfoTree b)
)
......@@ -563,7 +563,7 @@ exResolve db exts langs pkgConfigDb targets solver mbj indepGoals reorder
toVariable :: ExampleVar -> Variable P.QPN
toVariable (P q pn) = PackageVar (toQPN q pn)
toVariable (F q pn fn) = FlagVar (toQPN q pn) (C.FlagName fn)
toVariable (F q pn fn) = FlagVar (toQPN q pn) (C.mkFlagName fn)
toVariable (S q pn stanza) = StanzaVar (toQPN q pn) stanza
toQPN :: ExampleQualifier -> ExamplePkgName -> P.QPN
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment