Commit 306210bc authored by Duncan Coutts's avatar Duncan Coutts Committed by Mikhail Glushenkov

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.

(cherry picked from commit 2f743b6d)
parent c47fbe7c
{-# 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
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