diff --git a/cabal-install/Distribution/Client/ParseUtils.hs b/cabal-install/Distribution/Client/ParseUtils.hs
index c2cb1c5661708e8e17ac46713352f39ba65fc0f3..d54b3be1003ff2ed953980fe5738675a308ff138 100644
--- a/cabal-install/Distribution/Client/ParseUtils.hs
+++ b/cabal-install/Distribution/Client/ParseUtils.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE ExistentialQuantification, NamedFieldPuns #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.ParseUtils
@@ -7,13 +9,41 @@
-- Parsing utilities.
-----------------------------------------------------------------------------
-module Distribution.Client.ParseUtils ( parseFields, ppFields, ppSection )
+module Distribution.Client.ParseUtils (
+
+ -- * Fields and field utilities
+ FieldDescr(..),
+ liftField,
+ liftFields,
+ filterFields,
+ mapFieldNames,
+ commandOptionToField,
+ commandOptionsToFields,
+
+ -- * Sections and utilities
+ SectionDescr(..),
+ liftSection,
+
+ -- * Parsing and printing flat config
+ parseFields,
+ ppFields,
+ ppSection,
+
+ -- * Parsing and printing config with sections and subsections
+ parseFieldsAndSections,
+ ppFieldsAndSections,
+
+ -- ** Top level of config files
+ parseConfig,
+ showConfig,
+ )
where
import Distribution.ParseUtils
- ( FieldDescr(..), ParseResult(..), warning, lineNo )
-import qualified Distribution.ParseUtils as ParseUtils
- ( Field(..) )
+ ( FieldDescr(..), ParseResult(..), warning, LineNo, lineNo
+ , Field(..), liftField, readFieldsFlat )
+import Distribution.Simple.Command
+ ( OptionField, viewAsFieldDescr )
import Control.Monad ( foldM )
import Text.PrettyPrint ( (<>), (<+>), ($+$) )
@@ -21,17 +51,101 @@ import qualified Data.Map as Map
import qualified Text.PrettyPrint as Disp
( Doc, text, colon, vcat, empty, isEmpty, nest )
-parseFields :: [FieldDescr a] -> a -> [ParseUtils.Field] -> ParseResult a
-parseFields fields = foldM setField
+
+-------------------------
+-- FieldDescr utilities
+--
+
+liftFields :: (b -> a)
+ -> (a -> b -> b)
+ -> [FieldDescr a]
+ -> [FieldDescr b]
+liftFields get set = map (liftField get set)
+
+
+-- | Given a collection of field descriptions, keep only a given list of them,
+-- identified by name.
+--
+filterFields :: [String] -> [FieldDescr a] -> [FieldDescr a]
+filterFields includeFields = filter ((`elem` includeFields) . 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]
+mapFieldNames mangleName =
+ map (\descr -> descr { fieldName = mangleName (fieldName descr) })
+
+
+-- | Reuse a command line 'OptionField' as a config file 'FieldDescr'.
+--
+commandOptionToField :: OptionField a -> FieldDescr a
+commandOptionToField = viewAsFieldDescr
+
+-- | Reuse a bunch of command line 'OptionField's as config file 'FieldDescr's.
+--
+commandOptionsToFields :: [OptionField a] -> [FieldDescr a]
+commandOptionsToFields = map viewAsFieldDescr
+
+
+------------------------------------------
+-- SectionDescr definition and utilities
+--
+
+-- | The description of a section in a config file. It can contains both
+-- fields and optionally further subsections. See also 'FieldDescr'.
+--
+data SectionDescr a = forall b. SectionDescr {
+ sectionName :: String,
+ sectionFields :: [FieldDescr b],
+ sectionSubsections :: [SectionDescr b],
+ sectionGet :: a -> [(String, b)],
+ sectionSet :: LineNo -> String -> b -> a -> ParseResult a,
+ sectionEmpty :: b
+ }
+
+-- | To help construction of config file descriptions in a modular way it is
+-- useful to define fields and sections on local types and then hoist them
+-- into the parent types when combining them in bigger descriptions.
+--
+-- This is essentially a lens operation for 'SectionDescr' to help embedding
+-- one inside another.
+--
+liftSection :: (b -> a)
+ -> (a -> b -> b)
+ -> SectionDescr a
+ -> SectionDescr b
+liftSection get' set' (SectionDescr name fields sections get set empty) =
+ let sectionGet' = get . get'
+ sectionSet' lineno param x y = do
+ x' <- set lineno param x (get' y)
+ return (set' x' y)
+ in SectionDescr name fields sections sectionGet' sectionSet' empty
+
+
+-------------------------------------
+-- Parsing and printing flat config
+--
+
+-- | Parse a bunch of semi-parsed 'Field's according to a set of field
+-- descriptions. It accumulates the result on top of a given initial value.
+--
+-- This only covers the case of flat configuration without subsections. See
+-- also 'parseFieldsAndSections'.
+--
+parseFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a
+parseFields fieldDescrs =
+ foldM setField
where
- fieldMap = Map.fromList
- [ (name, f) | f@(FieldDescr name _ _) <- fields ]
- setField accum (ParseUtils.F line name value) =
+ fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ]
+
+ setField accum (F line name value) =
case Map.lookup name fieldMap of
Just (FieldDescr _ _ set) -> set line value accum
Nothing -> do
warning $ "Unrecognized field " ++ name ++ " on line " ++ show line
return accum
+
setField accum f = do
warning $ "Unrecognized stanza on line " ++ show (lineNo f)
return accum
@@ -40,8 +154,9 @@ parseFields fields = foldM setField
-- that also optionally print default values for empty fields as comments.
--
ppFields :: [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc
-ppFields fields def cur = Disp.vcat [ ppField name (fmap getter def) (getter cur)
- | FieldDescr name getter _ <- fields]
+ppFields fields def cur =
+ Disp.vcat [ ppField name (fmap getter def) (getter cur)
+ | FieldDescr name getter _ <- fields]
ppField :: String -> (Maybe Disp.Doc) -> Disp.Doc -> Disp.Doc
ppField name mdef cur
@@ -50,6 +165,11 @@ ppField name mdef cur
<> Disp.colon <+> def) mdef
| otherwise = Disp.text name <> Disp.colon <+> cur
+-- | Pretty print a section.
+--
+-- Since 'ppFields' does not cover subsections you can use this to add them.
+-- Or alternatively use a 'SectionDescr' and use 'ppFieldsAndSections'.
+--
ppSection :: String -> String -> [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc
ppSection name arg fields def cur
| Disp.isEmpty fieldsDoc = Disp.empty
@@ -59,3 +179,101 @@ ppSection name arg fields def cur
fieldsDoc = ppFields fields def cur
argDoc | arg == "" = Disp.empty
| otherwise = Disp.text arg
+
+
+-----------------------------------------
+-- Parsing and printing non-flat config
+--
+
+-- | Much like 'parseFields' but it also allows subsections. The permitted
+-- subsections are given by a list of 'SectionDescr's.
+--
+parseFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> a
+ -> [Field] -> ParseResult a
+parseFieldsAndSections fieldDescrs sectionDescrs =
+ foldM setField
+ where
+ fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ]
+ sectionMap = Map.fromList [ (sectionName s, s) | s <- sectionDescrs ]
+
+ setField a (F line name value) =
+ case Map.lookup name fieldMap of
+ Just (FieldDescr _ _ set) -> set line value a
+ Nothing -> do
+ warning $ "Unrecognized field '" ++ name
+ ++ "' on line " ++ show line
+ return a
+
+ setField a (Section line name param fields) =
+ case Map.lookup name sectionMap of
+ Just (SectionDescr _ fieldDescrs' sectionDescrs' _ set sectionEmpty) -> do
+ b <- parseFieldsAndSections fieldDescrs' sectionDescrs' sectionEmpty fields
+ set line param b a
+ Nothing -> do
+ warning $ "Unrecognized section '" ++ name
+ ++ "' on line " ++ show line
+ return a
+
+ setField accum (block@IfBlock {}) = do
+ warning $ "Unrecognized stanza on line " ++ show (lineNo block)
+ return accum
+
+-- | Much like 'ppFields' but also pretty prints any subsections. Subsection
+-- are only shown if they are non-empty.
+--
+-- Note that unlike 'ppFields', at present it does not support printing
+-- default values. If needed, adding such support would be quite reasonable.
+--
+ppFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> a -> Disp.Doc
+ppFieldsAndSections fieldDescrs sectionDescrs val =
+ ppFields fieldDescrs Nothing val
+ $+$
+ Disp.vcat
+ [ Disp.text "" $+$ sectionDoc
+ | SectionDescr {
+ sectionName, sectionGet,
+ sectionFields, sectionSubsections
+ } <- sectionDescrs
+ , (param, x) <- sectionGet val
+ , let sectionDoc = ppSectionAndSubsections
+ sectionName param
+ sectionFields sectionSubsections x
+ , not (Disp.isEmpty sectionDoc)
+ ]
+
+-- | Unlike 'ppSection' which has to be called directly, this gets used via
+-- 'ppFieldsAndSections' and so does not need to be exported.
+--
+ppSectionAndSubsections :: String -> String
+ -> [FieldDescr a] -> [SectionDescr a] -> a -> Disp.Doc
+ppSectionAndSubsections name arg fields sections cur
+ | Disp.isEmpty fieldsDoc = Disp.empty
+ | otherwise = Disp.text name <+> argDoc
+ $+$ (Disp.nest 2 fieldsDoc)
+ where
+ fieldsDoc = showConfig fields sections cur
+ argDoc | arg == "" = Disp.empty
+ | otherwise = Disp.text arg
+
+
+-----------------------------------------------
+-- Top level config file parsing and printing
+--
+
+-- | Parse a string in the config file syntax into a value, based on a
+-- description of the configuration file in terms of its fields and sections.
+--
+-- It accumulates the result on top of a given initial (typically empty) value.
+--
+parseConfig :: [FieldDescr a] -> [SectionDescr a] -> a
+ -> String -> ParseResult a
+parseConfig fieldDescrs sectionDescrs empty str =
+ parseFieldsAndSections fieldDescrs sectionDescrs empty
+ =<< readFieldsFlat str
+
+-- | Render a value in the config file syntax, based on a description of the
+-- configuration file in terms of its fields and sections.
+--
+showConfig :: [FieldDescr a] -> [SectionDescr a] -> a -> Disp.Doc
+showConfig = ppFieldsAndSections
+