{-# 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 :: (b -> a) -> (a -> b -> b) -> [FieldDescr a] -> [FieldDescr b]
liftFields b -> a
get a -> b -> b
set = (FieldDescr a -> FieldDescr b) -> [FieldDescr a] -> [FieldDescr b]
forall a b. (a -> b) -> [a] -> [b]
map ((b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
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 :: [String] -> [FieldDescr a] -> [FieldDescr a]
filterFields [String]
includeFields = (FieldDescr a -> Bool) -> [FieldDescr a] -> [FieldDescr a]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
includeFields) (String -> Bool)
-> (FieldDescr a -> String) -> FieldDescr a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDescr a -> String
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 :: (String -> String) -> [FieldDescr a] -> [FieldDescr a]
mapFieldNames String -> String
mangleName =
    (FieldDescr a -> FieldDescr a) -> [FieldDescr a] -> [FieldDescr a]
forall a b. (a -> b) -> [a] -> [b]
map (\FieldDescr a
descr -> FieldDescr a
descr { fieldName :: String
fieldName = String -> String
mangleName (FieldDescr a -> String
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 :: OptionField a -> FieldDescr a
commandOptionToField = OptionField a -> FieldDescr a
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 :: [OptionField a] -> [FieldDescr a]
commandOptionsToFields = (OptionField a -> FieldDescr a)
-> [OptionField a] -> [FieldDescr a]
forall a b. (a -> b) -> [a] -> [b]
map OptionField a -> FieldDescr a
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 {
       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
    { 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 :: (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 (a -> [(String, b)]) -> (b -> a) -> b -> [(String, b)]
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)
          b -> ParseResult b
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b -> b
set' a
x' b
y)
     in String
-> [FieldDescr b]
-> [SectionDescr b]
-> (b -> [(String, b)])
-> (LineNo -> String -> b -> b -> ParseResult b)
-> b
-> SectionDescr b
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 :: [FieldDescr a] -> a -> [Field] -> ParseResult a
parseFields [FieldDescr a]
fieldDescrs =
    (a -> Field -> ParseResult a) -> a -> [Field] -> ParseResult a
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 = [(String, FieldDescr a)] -> Map String (FieldDescr a)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (FieldDescr a -> String
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 String -> Map String (FieldDescr a) -> Maybe (FieldDescr a)
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
          Bool -> ParseResult () -> ParseResult ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"world-file") (ParseResult () -> ParseResult ())
-> ParseResult () -> ParseResult ()
forall a b. (a -> b) -> a -> b
$
            String -> ParseResult ()
warning (String -> ParseResult ()) -> String -> ParseResult ()
forall a b. (a -> b) -> a -> b
$ String
"Unrecognized field " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" on line " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LineNo -> String
forall a. Show a => a -> String
show LineNo
line
          a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return a
accum

    setField a
accum Field
f = do
      String -> ParseResult ()
warning (String -> ParseResult ()) -> String -> ParseResult ()
forall a b. (a -> b) -> a -> b
$ String
"Unrecognized stanza on line " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LineNo -> String
forall a. Show a => a -> String
show (Field -> LineNo
lineNo Field
f)
      a -> ParseResult a
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 :: [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 ((a -> Doc) -> Maybe a -> Maybe Doc
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 = Doc -> (Doc -> Doc) -> Maybe Doc -> Doc
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 :: 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 = [FieldDescr a] -> Maybe a -> a -> Doc
forall a. [FieldDescr a] -> Maybe a -> a -> Doc
ppFields [FieldDescr a]
fields Maybe a
def a
cur
    argDoc :: Doc
argDoc | String
arg String -> String -> Bool
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 :: [FieldDescr a]
-> [SectionDescr a]
-> [FGSectionDescr ParsecFieldGrammar a]
-> a
-> [Field]
-> ParseResult a
parseFieldsAndSections [FieldDescr a]
fieldDescrs [SectionDescr a]
sectionDescrs [FGSectionDescr ParsecFieldGrammar a]
fgSectionDescrs =
    (a -> Field -> ParseResult a) -> a -> [Field] -> ParseResult a
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     = [(String, FieldDescr a)] -> Map String (FieldDescr a)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (FieldDescr a -> String
forall a. FieldDescr a -> String
fieldName     FieldDescr a
f, FieldDescr a
f) | FieldDescr a
f <- [FieldDescr a]
fieldDescrs     ]
    sectionMap :: Map String (SectionDescr a)
sectionMap   = [(String, SectionDescr a)] -> Map String (SectionDescr a)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (SectionDescr a -> String
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 = [(String, FGSectionDescr ParsecFieldGrammar a)]
-> Map String (FGSectionDescr ParsecFieldGrammar a)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (FGSectionDescr ParsecFieldGrammar a -> String
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 String -> Map String (FieldDescr a) -> Maybe (FieldDescr a)
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 (String -> ParseResult ()) -> String -> ParseResult ()
forall a b. (a -> b) -> a -> b
$ String
"Unrecognized field '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' on line " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LineNo -> String
forall a. Show a => a -> String
show LineNo
line
          a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

    setField a
a (Section LineNo
line String
name String
param [Field]
fields) =
      case SectionDescr a
-> Either (SectionDescr a) (FGSectionDescr ParsecFieldGrammar a)
forall a b. a -> Either a b
Left (SectionDescr a
 -> Either (SectionDescr a) (FGSectionDescr ParsecFieldGrammar a))
-> Maybe (SectionDescr a)
-> Maybe
     (Either (SectionDescr a) (FGSectionDescr ParsecFieldGrammar a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Map String (SectionDescr a) -> Maybe (SectionDescr a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
name Map String (SectionDescr a)
sectionMap Maybe
  (Either (SectionDescr a) (FGSectionDescr ParsecFieldGrammar a))
-> Maybe
     (Either (SectionDescr a) (FGSectionDescr ParsecFieldGrammar a))
-> Maybe
     (Either (SectionDescr a) (FGSectionDescr ParsecFieldGrammar a))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> FGSectionDescr ParsecFieldGrammar a
-> Either (SectionDescr a) (FGSectionDescr ParsecFieldGrammar a)
forall a b. b -> Either a b
Right (FGSectionDescr ParsecFieldGrammar a
 -> Either (SectionDescr a) (FGSectionDescr ParsecFieldGrammar a))
-> Maybe (FGSectionDescr ParsecFieldGrammar a)
-> Maybe
     (Either (SectionDescr a) (FGSectionDescr ParsecFieldGrammar a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> Map String (FGSectionDescr ParsecFieldGrammar a)
-> Maybe (FGSectionDescr ParsecFieldGrammar a)
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 <- [FieldDescr b]
-> [SectionDescr b]
-> [FGSectionDescr ParsecFieldGrammar b]
-> b
-> [Field]
-> ParseResult 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 = (Field -> Field Position) -> [Field] -> [Field Position]
forall a b. (a -> b) -> [a] -> [b]
map Field -> Field Position
convertField [Field]
fields
              (Fields Position
fields2, [[Section Position]]
sections) = [Field Position] -> (Fields Position, [[Section Position]])
forall ann. [Field ann] -> (Fields ann, [[Section ann]])
partitionFields [Field Position]
fields1
          -- TODO: recurse into sections
          [Section Position]
-> (Section Position -> ParseResult ()) -> ParseResult ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([[Section Position]] -> [Section Position]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Section Position]]
sections) ((Section Position -> ParseResult ()) -> ParseResult ())
-> (Section Position -> ParseResult ()) -> ParseResult ()
forall a b. (a -> b) -> a -> b
$ \(FG.MkSection (F.Name (Position LineNo
line' LineNo
_) FieldName
name') [SectionArg Position]
_ [Field Position]
_) ->
            String -> ParseResult ()
warning (String -> ParseResult ()) -> String -> ParseResult ()
forall a b. (a -> b) -> a -> b
$ String
"Unrecognized section '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ FieldName -> String
fromUTF8BS FieldName
name'
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' on line " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LineNo -> String
forall a. Show a => a -> String
show LineNo
line'
          case ParseResult s
-> ([PWarning], Either (Maybe Version, NonEmpty PError) s)
forall a.
ParseResult a
-> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
runParseResult (ParseResult s
 -> ([PWarning], Either (Maybe Version, NonEmpty PError) s))
-> ParseResult s
-> ([PWarning], Either (Maybe Version, NonEmpty PError) s)
forall a b. (a -> b) -> a -> b
$ CabalSpecVersion
-> Fields Position -> ParsecFieldGrammar s s -> ParseResult s
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
              [PWarning] -> (PWarning -> ParseResult ()) -> ParseResult ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [PWarning]
warnings ((PWarning -> ParseResult ()) -> ParseResult ())
-> (PWarning -> ParseResult ()) -> ParseResult ()
forall a b. (a -> b) -> a -> b
$ \PWarning
w -> String -> ParseResult ()
warning (String -> ParseResult ()) -> String -> ParseResult ()
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
              [PWarning] -> (PWarning -> ParseResult ()) -> ParseResult ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [PWarning]
warnings ((PWarning -> ParseResult ()) -> ParseResult ())
-> (PWarning -> ParseResult ()) -> ParseResult ()
forall a b. (a -> b) -> a -> b
$ \PWarning
w -> String -> ParseResult ()
warning (String -> ParseResult ()) -> String -> ParseResult ()
forall a b. (a -> b) -> a -> b
$ String -> PWarning -> String
showPWarning String
"???" PWarning
w
              case NonEmpty PError
errs of
                PError
err :| [PError]
_errs -> String -> ParseResult a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParseResult a) -> String -> ParseResult a
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 (String -> ParseResult ()) -> String -> ParseResult ()
forall a b. (a -> b) -> a -> b
$ String
"Unrecognized section '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' on line " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LineNo -> String
forall a. Show a => a -> String
show LineNo
line
          a -> ParseResult a
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) =
    Name Position -> [FieldLine Position] -> Field Position
forall ann. Name ann -> [FieldLine ann] -> Field ann
F.Field (Position -> FieldName -> Name Position
forall ann. ann -> FieldName -> Name ann
F.Name Position
pos (String -> FieldName
toUTF8BS String
name)) [ Position -> FieldName -> FieldLine Position
forall ann. ann -> FieldName -> FieldLine ann
F.FieldLine Position
pos (FieldName -> FieldLine Position)
-> FieldName -> FieldLine Position
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) =
    Name Position
-> [SectionArg Position] -> [Field Position] -> Field Position
forall ann.
Name ann -> [SectionArg ann] -> [Field ann] -> Field ann
F.Section (Position -> FieldName -> Name Position
forall ann. ann -> FieldName -> Name ann
F.Name Position
pos (String -> FieldName
toUTF8BS String
name)) [] ((Field -> Field Position) -> [Field] -> [Field Position]
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 :: [FieldDescr a]
-> [SectionDescr a]
-> [FGSectionDescr PrettyFieldGrammar a]
-> a
-> Doc
ppFieldsAndSections [FieldDescr a]
fieldDescrs [SectionDescr a]
sectionDescrs [FGSectionDescr PrettyFieldGrammar a]
fgSectionDescrs a
val =
    [FieldDescr a] -> Maybe a -> a -> Doc
forall a. [FieldDescr a] -> Maybe a -> a -> Doc
ppFields [FieldDescr a]
fieldDescrs Maybe a
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 = String
-> String
-> [FieldDescr b]
-> [SectionDescr b]
-> [FGSectionDescr PrettyFieldGrammar b]
-> b
-> Doc
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)
      ] [Doc] -> [Doc] -> [Doc]
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 = String -> String -> PrettyFieldGrammar s s -> s -> Doc
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 :: 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 = [FieldDescr a]
-> [SectionDescr a]
-> [FGSectionDescr PrettyFieldGrammar a]
-> a
-> Doc
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 String -> String -> Bool
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 :: String -> String -> PrettyFieldGrammar a a -> a -> Doc
ppFgSection String
secName String
arg PrettyFieldGrammar a a
grammar a
x
    | [PrettyField ()] -> Bool
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 = CabalSpecVersion -> PrettyFieldGrammar a a -> a -> [PrettyField ()]
forall s a.
CabalSpecVersion -> PrettyFieldGrammar s a -> s -> [PrettyField ()]
FG.prettyFieldGrammar CabalSpecVersion
cabalSpecLatest PrettyFieldGrammar a a
grammar a
x

    argDoc :: Doc
argDoc | String
arg String -> String -> Bool
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 :: [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 =
      [FieldDescr a]
-> [SectionDescr a]
-> [FGSectionDescr ParsecFieldGrammar a]
-> a
-> [Field]
-> ParseResult a
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
  ([Field] -> ParseResult a) -> ParseResult [Field] -> ParseResult a
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 :: [FieldDescr a]
-> [SectionDescr a]
-> [FGSectionDescr PrettyFieldGrammar a]
-> a
-> Doc
showConfig = [FieldDescr a]
-> [SectionDescr a]
-> [FGSectionDescr PrettyFieldGrammar a]
-> a
-> Doc
forall a.
[FieldDescr a]
-> [SectionDescr a]
-> [FGSectionDescr PrettyFieldGrammar a]
-> a
-> Doc
ppFieldsAndSections