{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE 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
  ( Field (..)
  , FieldDescr (..)
  , LineNo
  , ParseResult (..)
  , liftField
  , lineNo
  , readFields
  , warning
  )
import Distribution.Deprecated.ViewAsFieldDescr
  ( viewAsFieldDescr
  )

import Distribution.Simple.Command
  ( OptionField
  )

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

-- For new parser stuff
import Distribution.CabalSpecVersion (cabalSpecLatest)
import Distribution.FieldGrammar (parseFieldGrammar, partitionFields)
import qualified Distribution.FieldGrammar as FG
import qualified Distribution.Fields as F
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)

-------------------------
-- 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 = (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 :: forall a. [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 a. Eq a => a -> [a] -> 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 :: forall a. (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 = mangleName (fieldName descr)})

-- | Reuse a command line 'OptionField' as a config file 'FieldDescr'.
commandOptionToField :: OptionField a -> FieldDescr a
commandOptionToField :: forall a. 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 :: forall a. [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
  { 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 (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 a. a -> ParseResult a
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 :: forall a. [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 a. 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 a. 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 :: 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 ((a -> Doc) -> Maybe a -> Maybe Doc
forall a b. (a -> b) -> Maybe a -> Maybe b
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 :: 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 = [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 :: 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 -> 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 a. 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 a. Maybe a -> Maybe a -> Maybe 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 a. 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 a. 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 :: forall a.
[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 :: forall a. SectionDescr a -> String
sectionName :: String
sectionName
            , a -> [(String, b)]
sectionGet :: ()
sectionGet :: a -> [(String, b)]
sectionGet
            , [FieldDescr b]
sectionFields :: ()
sectionFields :: [FieldDescr b]
sectionFields
            , [SectionDescr b]
sectionSubsections :: ()
sectionSubsections :: [SectionDescr b]
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 :: forall (g :: * -> * -> *) a. FGSectionDescr g a -> String
fgSectionName :: String
fgSectionName, PrettyFieldGrammar s s
fgSectionGrammar :: ()
fgSectionGrammar :: PrettyFieldGrammar s s
fgSectionGrammar, a -> [(String, s)]
fgSectionGet :: ()
fgSectionGet :: a -> [(String, s)]
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 :: 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 = [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 :: forall a. String -> String -> PrettyFieldGrammar a a -> a -> Doc
ppFgSection String
secName String
arg PrettyFieldGrammar a a
grammar a
x
  | [PrettyField ()] -> Bool
forall a. [a] -> 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 :: 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 =
  [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 :: forall a.
[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