{-# LANGUAGE ExistentialQuantification, NamedFieldPuns, RankNTypes #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Client.ParseUtils
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- Parsing utilities.
-----------------------------------------------------------------------------

module Distribution.Client.ParseUtils (

    -- * Fields and field utilities
    FieldDescr(..),
    liftField,
    liftFields,
    filterFields,
    mapFieldNames,
    commandOptionToField,
    commandOptionsToFields,

    -- * Sections and utilities
    SectionDescr(..),
    liftSection,

    -- * FieldGrammar sections
    FGSectionDescr(..),

    -- * 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.Client.Compat.Prelude hiding (empty, get)
import Prelude ()

import Distribution.Deprecated.ParseUtils
         ( FieldDescr(..), ParseResult(..), warning, LineNo, lineNo
         , Field(..), liftField, readFields )
import Distribution.Deprecated.ViewAsFieldDescr
         ( viewAsFieldDescr )

import Distribution.Simple.Command
         ( OptionField  )

import Text.PrettyPrint ( ($+$) )
import qualified Data.ByteString as BS
import qualified Data.Map as Map
import qualified Text.PrettyPrint as Disp
         ( (<>), Doc, text, colon, vcat, empty, isEmpty, nest )

-- For new parser stuff
import Distribution.CabalSpecVersion (cabalSpecLatest)
import Distribution.FieldGrammar (partitionFields, parseFieldGrammar)
import Distribution.Fields.ParseResult (runParseResult)
import Distribution.Parsec.Error (showPError)
import Distribution.Parsec.Position (Position (..))
import Distribution.Parsec.Warning (showPWarning)
import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS)
import qualified Distribution.Fields as F
import qualified Distribution.FieldGrammar as FG


-------------------------
-- FieldDescr utilities
--

liftFields :: (b -> a)
           -> (a -> b -> b)
           -> [FieldDescr a]
           -> [FieldDescr b]
liftFields :: forall b a.
(b -> a) -> (a -> b -> b) -> [FieldDescr a] -> [FieldDescr b]
liftFields b -> a
get a -> b -> b
set = forall a b. (a -> b) -> [a] -> [b]
map (forall b a.
(b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField b -> a
get a -> b -> b
set)


-- | Given a collection of field descriptions, keep only a given list of them,
-- identified by name.
--
filterFields :: [String] -> [FieldDescr a] -> [FieldDescr a]
filterFields :: forall a. [String] -> [FieldDescr a] -> [FieldDescr a]
filterFields [String]
includeFields = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
includeFields) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FieldDescr a -> String
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 :: forall a. (String -> String) -> [FieldDescr a] -> [FieldDescr a]
mapFieldNames String -> String
mangleName =
    forall a b. (a -> b) -> [a] -> [b]
map (\FieldDescr a
descr -> FieldDescr a
descr { fieldName :: String
fieldName = String -> String
mangleName (forall a. FieldDescr a -> String
fieldName FieldDescr a
descr) })


-- | Reuse a command line 'OptionField' as a config file 'FieldDescr'.
--
commandOptionToField :: OptionField a -> FieldDescr a
commandOptionToField :: forall a. OptionField a -> FieldDescr a
commandOptionToField = forall a. OptionField a -> FieldDescr a
viewAsFieldDescr

-- | Reuse a bunch of command line 'OptionField's as config file 'FieldDescr's.
--
commandOptionsToFields :: [OptionField a] -> [FieldDescr a]
commandOptionsToFields :: forall a. [OptionField a] -> [FieldDescr a]
commandOptionsToFields = forall a b. (a -> b) -> [a] -> [b]
map forall a. OptionField a -> FieldDescr a
viewAsFieldDescr


------------------------------------------
-- SectionDescr definition and utilities
--

-- | The description of a section in a config file. It can contain both
-- fields and optionally further subsections. See also 'FieldDescr'.
--
data SectionDescr a = forall b. SectionDescr {
       forall a. SectionDescr a -> String
sectionName        :: String,
       ()
sectionFields      :: [FieldDescr b],
       ()
sectionSubsections :: [SectionDescr b],
       ()
sectionGet         :: a -> [(String, b)],
       ()
sectionSet         :: LineNo -> String -> b -> a -> ParseResult a,
       ()
sectionEmpty       :: b
     }

-- | 'FieldGrammar' section description
data FGSectionDescr g a = forall s. FGSectionDescr
    { forall (g :: * -> * -> *) a. FGSectionDescr g a -> String
fgSectionName    :: String
    , ()
fgSectionGrammar :: g s s
    -- todo: add subsections?
    , ()
fgSectionGet     :: a -> [(String, s)]
    , ()
fgSectionSet     :: LineNo -> String -> s -> a -> ParseResult a
    }

-- | 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 :: forall b a.
(b -> a) -> (a -> b -> b) -> SectionDescr a -> SectionDescr b
liftSection b -> a
get' a -> b -> b
set' (SectionDescr String
name [FieldDescr b]
fields [SectionDescr b]
sections a -> [(String, b)]
get LineNo -> String -> b -> a -> ParseResult a
set b
empty) =
    let sectionGet' :: b -> [(String, b)]
sectionGet' = a -> [(String, b)]
get forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
get'
        sectionSet' :: LineNo -> String -> b -> b -> ParseResult b
sectionSet' LineNo
lineno String
param b
x b
y = do
          a
x' <- LineNo -> String -> b -> a -> ParseResult a
set LineNo
lineno String
param b
x (b -> a
get' b
y)
          forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b -> b
set' a
x' b
y)
     in forall a b.
String
-> [FieldDescr b]
-> [SectionDescr b]
-> (a -> [(String, b)])
-> (LineNo -> String -> b -> a -> ParseResult a)
-> b
-> SectionDescr a
SectionDescr String
name [FieldDescr b]
fields [SectionDescr b]
sections b -> [(String, b)]
sectionGet' LineNo -> String -> b -> b -> ParseResult b
sectionSet' b
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 :: forall a. [FieldDescr a] -> a -> [Field] -> ParseResult a
parseFields [FieldDescr a]
fieldDescrs =
    forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM a -> Field -> ParseResult a
setField
  where
    fieldMap :: Map String (FieldDescr a)
fieldMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (forall a. FieldDescr a -> String
fieldName FieldDescr a
f, FieldDescr a
f) | FieldDescr a
f <- [FieldDescr a]
fieldDescrs ]

    setField :: a -> Field -> ParseResult a
setField a
accum (F LineNo
line String
name String
value) =
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
name Map String (FieldDescr a)
fieldMap of
        Just (FieldDescr String
_ a -> Doc
_ LineNo -> String -> a -> ParseResult a
set) -> LineNo -> String -> a -> ParseResult a
set LineNo
line String
value a
accum
        Maybe (FieldDescr a)
Nothing -> do
          -- the 'world-file' field was removed in 3.8, however
          -- it was automatically added to many config files
          -- before that, so its warning is silently ignored
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String
name forall a. Eq a => a -> a -> Bool
== String
"world-file") forall a b. (a -> b) -> a -> b
$
            String -> ParseResult ()
warning forall a b. (a -> b) -> a -> b
$ String
"Unrecognized field " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
" on line " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show LineNo
line
          forall (m :: * -> *) a. Monad m => a -> m a
return a
accum

    setField a
accum Field
f = do
      String -> ParseResult ()
warning forall a b. (a -> b) -> a -> b
$ String
"Unrecognized stanza on line " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Field -> LineNo
lineNo Field
f)
      forall (m :: * -> *) a. Monad m => a -> m a
return a
accum

-- | This is a customised version of the functions from Distribution.Deprecated.ParseUtils
-- that also optionally print default values for empty fields as comments.
--
ppFields :: [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc
ppFields :: forall a. [FieldDescr a] -> Maybe a -> a -> Doc
ppFields [FieldDescr a]
fields Maybe a
def a
cur =
    [Doc] -> Doc
Disp.vcat [ String -> Maybe Doc -> Doc -> Doc
ppField String
name (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Doc
getter Maybe a
def) (a -> Doc
getter a
cur)
              | FieldDescr String
name a -> Doc
getter LineNo -> String -> a -> ParseResult a
_ <- [FieldDescr a]
fields]

ppField :: String -> (Maybe Disp.Doc) -> Disp.Doc -> Disp.Doc
ppField :: String -> Maybe Doc -> Doc -> Doc
ppField String
name Maybe Doc
mdef Doc
cur
  | Doc -> Bool
Disp.isEmpty Doc
cur = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
Disp.empty
                       (\Doc
def -> String -> Doc
Disp.text String
"--" Doc -> Doc -> Doc
<+> String -> Doc
Disp.text String
name
                                Doc -> Doc -> Doc
Disp.<> Doc
Disp.colon Doc -> Doc -> Doc
<+> Doc
def) Maybe Doc
mdef
  | Bool
otherwise        = String -> Doc
Disp.text String
name Doc -> Doc -> Doc
Disp.<> Doc
Disp.colon Doc -> Doc -> Doc
<+> Doc
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 :: forall a. String -> String -> [FieldDescr a] -> Maybe a -> a -> Doc
ppSection String
name String
arg [FieldDescr a]
fields Maybe a
def a
cur
  | Doc -> Bool
Disp.isEmpty Doc
fieldsDoc = Doc
Disp.empty
  | Bool
otherwise              = String -> Doc
Disp.text String
name Doc -> Doc -> Doc
<+> Doc
argDoc
                             Doc -> Doc -> Doc
$+$ (LineNo -> Doc -> Doc
Disp.nest LineNo
2 Doc
fieldsDoc)
  where
    fieldsDoc :: Doc
fieldsDoc = forall a. [FieldDescr a] -> Maybe a -> a -> Doc
ppFields [FieldDescr a]
fields Maybe a
def a
cur
    argDoc :: Doc
argDoc | String
arg forall a. Eq a => a -> a -> Bool
== String
"" = Doc
Disp.empty
           | Bool
otherwise = String -> Doc
Disp.text String
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]      -- ^ field
    -> [SectionDescr a]    -- ^ legacy sections
    -> [FGSectionDescr FG.ParsecFieldGrammar a]  -- ^ FieldGrammar sections
    -> a
    -> [Field] -> ParseResult a
parseFieldsAndSections :: forall a.
[FieldDescr a]
-> [SectionDescr a]
-> [FGSectionDescr ParsecFieldGrammar a]
-> a
-> [Field]
-> ParseResult a
parseFieldsAndSections [FieldDescr a]
fieldDescrs [SectionDescr a]
sectionDescrs [FGSectionDescr ParsecFieldGrammar a]
fgSectionDescrs =
    forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM a -> Field -> ParseResult a
setField
  where
    fieldMap :: Map String (FieldDescr a)
fieldMap     = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (forall a. FieldDescr a -> String
fieldName     FieldDescr a
f, FieldDescr a
f) | FieldDescr a
f <- [FieldDescr a]
fieldDescrs     ]
    sectionMap :: Map String (SectionDescr a)
sectionMap   = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (forall a. SectionDescr a -> String
sectionName   SectionDescr a
s, SectionDescr a
s) | SectionDescr a
s <- [SectionDescr a]
sectionDescrs   ]
    fgSectionMap :: Map String (FGSectionDescr ParsecFieldGrammar a)
fgSectionMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (forall (g :: * -> * -> *) a. FGSectionDescr g a -> String
fgSectionName FGSectionDescr ParsecFieldGrammar a
s, FGSectionDescr ParsecFieldGrammar a
s) | FGSectionDescr ParsecFieldGrammar a
s <- [FGSectionDescr ParsecFieldGrammar a]
fgSectionDescrs ]

    setField :: a -> Field -> ParseResult a
setField a
a (F LineNo
line String
name String
value) =
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
name Map String (FieldDescr a)
fieldMap of
        Just (FieldDescr String
_ a -> Doc
_ LineNo -> String -> a -> ParseResult a
set) -> LineNo -> String -> a -> ParseResult a
set LineNo
line String
value a
a
        Maybe (FieldDescr a)
Nothing -> do
          String -> ParseResult ()
warning forall a b. (a -> b) -> a -> b
$ String
"Unrecognized field '" forall a. [a] -> [a] -> [a]
++ String
name
                 forall a. [a] -> [a] -> [a]
++ String
"' on line " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show LineNo
line
          forall (m :: * -> *) a. Monad m => a -> m a
return a
a

    setField a
a (Section LineNo
line String
name String
param [Field]
fields) =
      case forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
name Map String (SectionDescr a)
sectionMap forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
name Map String (FGSectionDescr ParsecFieldGrammar a)
fgSectionMap of
        Just (Left (SectionDescr String
_ [FieldDescr b]
fieldDescrs' [SectionDescr b]
sectionDescrs' a -> [(String, b)]
_ LineNo -> String -> b -> a -> ParseResult a
set b
sectionEmpty)) -> do
          b
b <- forall a.
[FieldDescr a]
-> [SectionDescr a]
-> [FGSectionDescr ParsecFieldGrammar a]
-> a
-> [Field]
-> ParseResult a
parseFieldsAndSections [FieldDescr b]
fieldDescrs' [SectionDescr b]
sectionDescrs' [] b
sectionEmpty [Field]
fields
          LineNo -> String -> b -> a -> ParseResult a
set LineNo
line String
param b
b a
a
        Just (Right (FGSectionDescr String
_ ParsecFieldGrammar s s
grammar a -> [(String, s)]
_getter LineNo -> String -> s -> a -> ParseResult a
setter)) -> do
          let fields1 :: [Field Position]
fields1 = forall a b. (a -> b) -> [a] -> [b]
map Field -> Field Position
convertField [Field]
fields
              (Fields Position
fields2, [[Section Position]]
sections) = forall ann. [Field ann] -> (Fields ann, [[Section ann]])
partitionFields [Field Position]
fields1
          -- TODO: recurse into sections
          forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Section Position]]
sections) forall a b. (a -> b) -> a -> b
$ \(FG.MkSection (F.Name (Position LineNo
line' LineNo
_) FieldName
name') [SectionArg Position]
_ [Field Position]
_) ->
            String -> ParseResult ()
warning forall a b. (a -> b) -> a -> b
$ String
"Unrecognized section '" forall a. [a] -> [a] -> [a]
++ FieldName -> String
fromUTF8BS FieldName
name'
              forall a. [a] -> [a] -> [a]
++ String
"' on line " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show LineNo
line'
          case forall a.
ParseResult a
-> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
runParseResult forall a b. (a -> b) -> a -> b
$ forall s a.
CabalSpecVersion
-> Fields Position -> ParsecFieldGrammar s a -> ParseResult a
parseFieldGrammar CabalSpecVersion
cabalSpecLatest Fields Position
fields2 ParsecFieldGrammar s s
grammar of
            ([PWarning]
warnings, Right s
b) -> do
              forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [PWarning]
warnings forall a b. (a -> b) -> a -> b
$ \PWarning
w -> String -> ParseResult ()
warning forall a b. (a -> b) -> a -> b
$ String -> PWarning -> String
showPWarning String
"???" PWarning
w
              LineNo -> String -> s -> a -> ParseResult a
setter LineNo
line String
param s
b a
a
            ([PWarning]
warnings, Left (Maybe Version
_, NonEmpty PError
errs)) -> do
              forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [PWarning]
warnings forall a b. (a -> b) -> a -> b
$ \PWarning
w -> String -> ParseResult ()
warning forall a b. (a -> b) -> a -> b
$ String -> PWarning -> String
showPWarning String
"???" PWarning
w
              case NonEmpty PError
errs of
                PError
err :| [PError]
_errs -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String -> PError -> String
showPError String
"???" PError
err
        Maybe
  (Either (SectionDescr a) (FGSectionDescr ParsecFieldGrammar a))
Nothing -> do
          String -> ParseResult ()
warning forall a b. (a -> b) -> a -> b
$ String
"Unrecognized section '" forall a. [a] -> [a] -> [a]
++ String
name
                 forall a. [a] -> [a] -> [a]
++ String
"' on line " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show LineNo
line
          forall (m :: * -> *) a. Monad m => a -> m a
return a
a

convertField :: Field -> F.Field Position
convertField :: Field -> Field Position
convertField (F LineNo
line String
name String
str) =
    forall ann. Name ann -> [FieldLine ann] -> Field ann
F.Field (forall ann. ann -> FieldName -> Name ann
F.Name Position
pos (String -> FieldName
toUTF8BS String
name)) [ forall ann. ann -> FieldName -> FieldLine ann
F.FieldLine Position
pos forall a b. (a -> b) -> a -> b
$ String -> FieldName
toUTF8BS String
str ]
  where
    pos :: Position
pos = LineNo -> LineNo -> Position
Position LineNo
line LineNo
0
-- arguments omitted
convertField (Section LineNo
line String
name String
_arg [Field]
fields) =
    forall ann.
Name ann -> [SectionArg ann] -> [Field ann] -> Field ann
F.Section (forall ann. ann -> FieldName -> Name ann
F.Name Position
pos (String -> FieldName
toUTF8BS String
name)) [] (forall a b. (a -> b) -> [a] -> [b]
map Field -> Field Position
convertField [Field]
fields)
  where
    pos :: Position
pos = LineNo -> LineNo -> Position
Position LineNo
line LineNo
0

-- | 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] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc
ppFieldsAndSections :: forall a.
[FieldDescr a]
-> [SectionDescr a]
-> [FGSectionDescr PrettyFieldGrammar a]
-> a
-> Doc
ppFieldsAndSections [FieldDescr a]
fieldDescrs [SectionDescr a]
sectionDescrs [FGSectionDescr PrettyFieldGrammar a]
fgSectionDescrs a
val =
    forall a. [FieldDescr a] -> Maybe a -> a -> Doc
ppFields [FieldDescr a]
fieldDescrs forall a. Maybe a
Nothing a
val
      Doc -> Doc -> Doc
$+$
    [Doc] -> Doc
Disp.vcat (
      [ String -> Doc
Disp.text String
"" Doc -> Doc -> Doc
$+$ Doc
sectionDoc
      | SectionDescr {
          String
sectionName :: String
sectionName :: forall a. SectionDescr a -> String
sectionName, a -> [(String, b)]
sectionGet :: a -> [(String, b)]
sectionGet :: ()
sectionGet,
          [FieldDescr b]
sectionFields :: [FieldDescr b]
sectionFields :: ()
sectionFields, [SectionDescr b]
sectionSubsections :: [SectionDescr b]
sectionSubsections :: ()
sectionSubsections
        } <- [SectionDescr a]
sectionDescrs
      , (String
param, b
x) <- a -> [(String, b)]
sectionGet a
val
      , let sectionDoc :: Doc
sectionDoc = forall a.
String
-> String
-> [FieldDescr a]
-> [SectionDescr a]
-> [FGSectionDescr PrettyFieldGrammar a]
-> a
-> Doc
ppSectionAndSubsections
                           String
sectionName String
param
                           [FieldDescr b]
sectionFields [SectionDescr b]
sectionSubsections [] b
x
      , Bool -> Bool
not (Doc -> Bool
Disp.isEmpty Doc
sectionDoc)
      ] forall a. [a] -> [a] -> [a]
++
      [ String -> Doc
Disp.text String
"" Doc -> Doc -> Doc
$+$ Doc
sectionDoc
      | FGSectionDescr { String
fgSectionName :: String
fgSectionName :: forall (g :: * -> * -> *) a. FGSectionDescr g a -> String
fgSectionName, PrettyFieldGrammar s s
fgSectionGrammar :: PrettyFieldGrammar s s
fgSectionGrammar :: ()
fgSectionGrammar, a -> [(String, s)]
fgSectionGet :: a -> [(String, s)]
fgSectionGet :: ()
fgSectionGet } <- [FGSectionDescr PrettyFieldGrammar a]
fgSectionDescrs
      , (String
param, s
x) <- a -> [(String, s)]
fgSectionGet a
val
      , let sectionDoc :: Doc
sectionDoc = forall a. String -> String -> PrettyFieldGrammar a a -> a -> Doc
ppFgSection String
fgSectionName String
param PrettyFieldGrammar s s
fgSectionGrammar s
x
      , Bool -> Bool
not (Doc -> Bool
Disp.isEmpty Doc
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] -> [FGSectionDescr FG.PrettyFieldGrammar  a] -> a -> Disp.Doc
ppSectionAndSubsections :: forall a.
String
-> String
-> [FieldDescr a]
-> [SectionDescr a]
-> [FGSectionDescr PrettyFieldGrammar a]
-> a
-> Doc
ppSectionAndSubsections String
name String
arg [FieldDescr a]
fields [SectionDescr a]
sections [FGSectionDescr PrettyFieldGrammar a]
fgSections a
cur
  | Doc -> Bool
Disp.isEmpty Doc
fieldsDoc = Doc
Disp.empty
  | Bool
otherwise              = String -> Doc
Disp.text String
name Doc -> Doc -> Doc
<+> Doc
argDoc
                             Doc -> Doc -> Doc
$+$ (LineNo -> Doc -> Doc
Disp.nest LineNo
2 Doc
fieldsDoc)
  where
    fieldsDoc :: Doc
fieldsDoc = forall a.
[FieldDescr a]
-> [SectionDescr a]
-> [FGSectionDescr PrettyFieldGrammar a]
-> a
-> Doc
showConfig [FieldDescr a]
fields [SectionDescr a]
sections [FGSectionDescr PrettyFieldGrammar a]
fgSections a
cur
    argDoc :: Doc
argDoc | String
arg forall a. Eq a => a -> a -> Bool
== String
"" = Doc
Disp.empty
           | Bool
otherwise = String -> Doc
Disp.text String
arg

-- |
--
-- TODO: subsections
-- TODO: this should simply build 'PrettyField'
ppFgSection
    :: String  -- ^ section name
    -> String  -- ^ parameter
    -> FG.PrettyFieldGrammar a a
    -> a
    -> Disp.Doc
ppFgSection :: forall a. String -> String -> PrettyFieldGrammar a a -> a -> Doc
ppFgSection String
secName String
arg PrettyFieldGrammar a a
grammar a
x
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PrettyField ()]
prettyFields = Doc
Disp.empty
    | Bool
otherwise         =
        String -> Doc
Disp.text String
secName Doc -> Doc -> Doc
<+> Doc
argDoc
        Doc -> Doc -> Doc
$+$ (LineNo -> Doc -> Doc
Disp.nest LineNo
2 Doc
fieldsDoc)
  where
    prettyFields :: [PrettyField ()]
prettyFields = forall s a.
CabalSpecVersion -> PrettyFieldGrammar s a -> s -> [PrettyField ()]
FG.prettyFieldGrammar CabalSpecVersion
cabalSpecLatest PrettyFieldGrammar a a
grammar a
x

    argDoc :: Doc
argDoc | String
arg forall a. Eq a => a -> a -> Bool
== String
"" = Doc
Disp.empty
           | Bool
otherwise = String -> Doc
Disp.text String
arg

    fieldsDoc :: Doc
fieldsDoc = [Doc] -> Doc
Disp.vcat
        [ String -> Doc
Disp.text String
fname' Doc -> Doc -> Doc
<<>> Doc
Disp.colon Doc -> Doc -> Doc
<<>> Doc
doc
        | F.PrettyField ()
_ FieldName
fname Doc
doc <- [PrettyField ()]
prettyFields -- TODO: this skips sections
        , let fname' :: String
fname' = FieldName -> String
fromUTF8BS FieldName
fname
        ]


-----------------------------------------------
-- 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] -> [FGSectionDescr FG.ParsecFieldGrammar a] -> a
            -> BS.ByteString -> ParseResult a
parseConfig :: forall a.
[FieldDescr a]
-> [SectionDescr a]
-> [FGSectionDescr ParsecFieldGrammar a]
-> a
-> FieldName
-> ParseResult a
parseConfig [FieldDescr a]
fieldDescrs [SectionDescr a]
sectionDescrs [FGSectionDescr ParsecFieldGrammar a]
fgSectionDescrs a
empty FieldName
str =
      forall a.
[FieldDescr a]
-> [SectionDescr a]
-> [FGSectionDescr ParsecFieldGrammar a]
-> a
-> [Field]
-> ParseResult a
parseFieldsAndSections [FieldDescr a]
fieldDescrs [SectionDescr a]
sectionDescrs [FGSectionDescr ParsecFieldGrammar a]
fgSectionDescrs a
empty
  forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FieldName -> ParseResult [Field]
readFields FieldName
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] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc
showConfig :: forall a.
[FieldDescr a]
-> [SectionDescr a]
-> [FGSectionDescr PrettyFieldGrammar a]
-> a
-> Doc
showConfig = forall a.
[FieldDescr a]
-> [SectionDescr a]
-> [FGSectionDescr PrettyFieldGrammar a]
-> a
-> Doc
ppFieldsAndSections