New parse utils to help with subsections

The existing approach has been to parse top level fields and then
separately parse each top level section, and similarly for pretty
printing. A better approach is to follow the pattern for fields and have
a section description. Then we just parse or print fields+sections in
one call. And as a bonus, secitons can have subsections (and could even
do so recursively).

This patch just adds the new functionality. No existing config parsing
is switched over.

cabal-install/Distribution/Client/ParseUtils.hs

+{-# 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
+