diff --git a/cabal-install/src/Distribution/Client/Config.hs b/cabal-install/src/Distribution/Client/Config.hs index 2faf9e1756d..f7b01512ca4 100644 --- a/cabal-install/src/Distribution/Client/Config.hs +++ b/cabal-install/src/Distribution/Client/Config.hs @@ -160,6 +160,7 @@ import qualified Distribution.Deprecated.ParseUtils as ParseUtils import Distribution.Parsec (ParsecParser, parsecFilePath, parsecOptCommaList, parsecToken) import Distribution.Simple.Command ( CommandUI (commandOptions) + , OptionField , ShowOrParseArgs (..) , commandDefaultFlags ) @@ -1314,6 +1315,19 @@ configFieldDescriptions src = ParseArgs ] where + toSavedConfig + :: (FieldDescr a -> FieldDescr SavedConfig) + -- Lifting function. + -> [OptionField a] + -- Option fields. + -> [String] + -- Fields to exclude, by name. + -> [FieldDescr a] + -- Field replacements. + -- + -- If an option is found with the same name as one of these replacement + -- fields, the replacement field is used instead of the option. + -> [FieldDescr SavedConfig] toSavedConfig lift options exclusions replacements = [ lift (fromMaybe field replacement) | opt <- options diff --git a/cabal-install/src/Distribution/Client/ParseUtils.hs b/cabal-install/src/Distribution/Client/ParseUtils.hs index 44cdc4ccc22..18062b7428f 100644 --- a/cabal-install/src/Distribution/Client/ParseUtils.hs +++ b/cabal-install/src/Distribution/Client/ParseUtils.hs @@ -17,6 +17,8 @@ module Distribution.Client.ParseUtils FieldDescr (..) , liftField , liftFields + , addFields + , aliasField , filterFields , mapFieldNames , commandOptionToField @@ -103,9 +105,15 @@ liftFields get set = map (liftField get set) -- | Given a collection of field descriptions, keep only a given list of them, -- identified by name. +-- +-- TODO: This makes it easy to footgun by providing a non-existent field name. filterFields :: [String] -> [FieldDescr a] -> [FieldDescr a] filterFields includeFields = filter ((`elem` includeFields) . fieldName) +-- | Given a collection of field descriptions, get a field with a given name. +getField :: String -> [FieldDescr a] -> Maybe (FieldDescr a) +getField name = find ((== name) . fieldName) + -- | Apply a name mangling function to the field names of all the field -- descriptions. The typical use case is to apply some prefix. mapFieldNames :: (String -> String) -> [FieldDescr a] -> [FieldDescr a] @@ -120,6 +128,30 @@ commandOptionToField = viewAsFieldDescr commandOptionsToFields :: [OptionField a] -> [FieldDescr a] commandOptionsToFields = map viewAsFieldDescr +-- | Add fields to a field list. +addFields + :: [FieldDescr a] + -> ([FieldDescr a] -> [FieldDescr a]) +addFields = (++) + +-- | Add a new field which is identical to an existing field but with a +-- different name. +aliasField + :: String + -- ^ The existing field name. + -> String + -- ^ The new field name. + -> [FieldDescr a] + -> [FieldDescr a] +aliasField oldName newName fields = + let fieldToRename = getField oldName fields + in case fieldToRename of + -- TODO: Should this throw? + Nothing -> fields + Just fieldToRename' -> + let newField = fieldToRename'{fieldName = newName} + in newField : fields + ------------------------------------------ -- SectionDescr definition and utilities -- diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs index a4191325f8b..1a2e202be5e 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -2073,9 +2073,3 @@ showTokenQ "" = Disp.empty showTokenQ x@('-' : '-' : _) = Disp.text (show x) showTokenQ x@('.' : []) = Disp.text (show x) showTokenQ x = showToken x - --- Handy util -addFields - :: [FieldDescr a] - -> ([FieldDescr a] -> [FieldDescr a]) -addFields = (++)