diff --git a/cabal-install/Distribution/Client/ParseUtils.hs b/cabal-install/Distribution/Client/ParseUtils.hs
index 56eebf37569056330757acbe3ca099c5cca5c72c..23d5e32b12126a65bed2aaa322af3fe6b4272f42 100644
--- a/cabal-install/Distribution/Client/ParseUtils.hs
+++ b/cabal-install/Distribution/Client/ParseUtils.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE ExistentialQuantification, NamedFieldPuns #-}
+{-# LANGUAGE ExistentialQuantification, NamedFieldPuns, RankNTypes #-}
-----------------------------------------------------------------------------
-- |
@@ -24,6 +24,9 @@ module Distribution.Client.ParseUtils (
SectionDescr(..),
liftSection,
+ -- * FieldGrammar sections
+ FGSectionDescr(..),
+
-- * Parsing and printing flat config
parseFields,
ppFields,
@@ -39,6 +42,9 @@ module Distribution.Client.ParseUtils (
)
where
+import Distribution.Client.Compat.Prelude hiding (empty, get)
+import Prelude ()
+
import Distribution.Deprecated.ParseUtils
( FieldDescr(..), ParseResult(..), warning, LineNo, lineNo
, Field(..), liftField, readFieldsFlat )
@@ -48,12 +54,22 @@ import Distribution.Deprecated.ViewAsFieldDescr
import Distribution.Simple.Command
( OptionField )
-import Control.Monad ( foldM )
import Text.PrettyPrint ( (<+>), ($+$) )
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 (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
@@ -107,6 +123,15 @@ data SectionDescr a = forall b. SectionDescr {
sectionEmpty :: b
}
+-- | 'FieldGrammar' section description
+data FGSectionDescr a = forall s. FGSectionDescr
+ { fgSectionName :: String
+ , fgSectionGrammar :: forall g. (FieldGrammar g, Applicative (g s)) => 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.
@@ -191,13 +216,18 @@ ppSection name arg fields def cur
-- | 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 =
+parseFieldsAndSections
+ :: [FieldDescr a] -- ^ field
+ -> [SectionDescr a] -- ^ legacy sections
+ -> [FGSectionDescr a] -- ^ FieldGrammar sections
+ -> a
+ -> [Field] -> ParseResult a
+parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs =
foldM setField
where
- fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ]
- sectionMap = Map.fromList [ (sectionName s, s) | s <- sectionDescrs ]
+ fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ]
+ sectionMap = Map.fromList [ (sectionName s, s) | s <- sectionDescrs ]
+ fgSectionMap = Map.fromList [ (fgSectionName s, s) | s <- fgSectionDescrs ]
setField a (F line name value) =
case Map.lookup name fieldMap of
@@ -208,10 +238,25 @@ parseFieldsAndSections fieldDescrs sectionDescrs =
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
+ case Left <$> Map.lookup name sectionMap <|> Right <$> Map.lookup name fgSectionMap of
+ Just (Left (SectionDescr _ fieldDescrs' sectionDescrs' _ set sectionEmpty)) -> do
+ b <- parseFieldsAndSections fieldDescrs' sectionDescrs' [] sectionEmpty fields
set line param b a
+ Just (Right (FGSectionDescr _ grammar _getter setter)) -> do
+ let fields1 = mapMaybe convertField fields
+ (fields2, sections) = partitionFields fields1
+ -- TODO: recurse into sections
+ for_ (concat sections) $ \(FG.MkSection (F.Name (Position line' _) name') _ _) ->
+ warning $ "Unrecognized section '" ++ fromUTF8BS name'
+ ++ "' on line " ++ show line'
+ case runParseResult $ parseFieldGrammar cabalSpecLatest fields2 grammar of
+ (warnings, Right b) -> do
+ for_ warnings $ \w -> warning $ showPWarning "???" w
+ setter line param b a
+ (warnings, Left (_, errs)) -> do
+ for_ warnings $ \w -> warning $ showPWarning "???" w
+ case errs of
+ err :| _errs -> fail $ showPError "???" err
Nothing -> do
warning $ "Unrecognized section '" ++ name
++ "' on line " ++ show line
@@ -221,17 +266,31 @@ parseFieldsAndSections fieldDescrs sectionDescrs =
warning $ "Unrecognized stanza on line " ++ show (lineNo block)
return accum
+convertField :: Field -> Maybe (F.Field Position)
+convertField (F line name str) = Just $
+ F.Field (F.Name pos (toUTF8BS name)) [ F.FieldLine pos $ toUTF8BS str ]
+ where
+ pos = Position line 0
+-- arguments omitted
+convertField (Section line name _arg fields) = Just $
+ F.Section (F.Name pos (toUTF8BS name)) [] (mapMaybe convertField fields)
+ where
+ pos = Position line 0
+-- silently omitted.
+convertField IfBlock {} = Nothing
+
+
-- | 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 =
+ppFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr a] -> a -> Disp.Doc
+ppFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs val =
ppFields fieldDescrs Nothing val
$+$
- Disp.vcat
+ Disp.vcat (
[ Disp.text "" $+$ sectionDoc
| SectionDescr {
sectionName, sectionGet,
@@ -240,24 +299,57 @@ ppFieldsAndSections fieldDescrs sectionDescrs val =
, (param, x) <- sectionGet val
, let sectionDoc = ppSectionAndSubsections
sectionName param
- sectionFields sectionSubsections x
+ sectionFields sectionSubsections [] x
+ , not (Disp.isEmpty sectionDoc)
+ ] ++
+ [ Disp.text "" $+$ sectionDoc
+ | FGSectionDescr { fgSectionName, fgSectionGrammar, fgSectionGet } <- fgSectionDescrs
+ , (param, x) <- fgSectionGet val
+ , let sectionDoc = ppFgSection fgSectionName param fgSectionGrammar 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
+ -> [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr a] -> a -> Disp.Doc
+ppSectionAndSubsections name arg fields sections fgSections cur
| Disp.isEmpty fieldsDoc = Disp.empty
| otherwise = Disp.text name <+> argDoc
$+$ (Disp.nest 2 fieldsDoc)
where
- fieldsDoc = showConfig fields sections cur
+ fieldsDoc = showConfig fields sections fgSections cur
argDoc | arg == "" = Disp.empty
| otherwise = Disp.text arg
+-- |
+--
+-- TODO: subsections
+-- TODO: this should simply build 'PrettyField'
+ppFgSection
+ :: String -- ^ section name
+ -> String -- ^ parameter
+ -> FG.PrettyFieldGrammar a a
+ -> a
+ -> Disp.Doc
+ppFgSection secName arg grammar x
+ | null prettyFields = Disp.empty
+ | otherwise =
+ Disp.text secName <+> argDoc
+ $+$ (Disp.nest 2 fieldsDoc)
+ where
+ prettyFields = FG.prettyFieldGrammar cabalSpecLatest grammar x
+
+ argDoc | arg == "" = Disp.empty
+ | otherwise = Disp.text arg
+
+ fieldsDoc = Disp.vcat
+ [ Disp.text fname' <<>> Disp.colon <<>> doc
+ | F.PrettyField _ fname doc <- prettyFields -- TODO: this skips sections
+ , let fname' = fromUTF8BS fname
+ ]
+
-----------------------------------------------
-- Top level config file parsing and printing
@@ -268,15 +360,15 @@ ppSectionAndSubsections name arg fields sections cur
--
-- It accumulates the result on top of a given initial (typically empty) value.
--
-parseConfig :: [FieldDescr a] -> [SectionDescr a] -> a
+parseConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr a] -> a
-> String -> ParseResult a
-parseConfig fieldDescrs sectionDescrs empty str =
- parseFieldsAndSections fieldDescrs sectionDescrs empty
+parseConfig fieldDescrs sectionDescrs fgSectionDescrs empty str =
+ parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs 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 :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr a] -> a -> Disp.Doc
showConfig = ppFieldsAndSections
diff --git a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs
index 4aa68231cace9d98b0815bac801c57387d8d1b8d..865305a0873e8b7d2f715403561b71fed8c51dee 100644
--- a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs
+++ b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs
@@ -43,8 +43,7 @@ import Distribution.Package
import Distribution.PackageDescription
( SourceRepo(..), RepoKind(..)
, dispFlagAssignment )
-import Distribution.Client.SourceRepoParse
- ( sourceRepoFieldDescrs )
+import Distribution.PackageDescription.FieldGrammar (sourceRepoFieldGrammar)
import Distribution.Simple.Compiler
( OptimisationLevel(..), DebugInfoLevel(..) )
import Distribution.Simple.InstallDirs ( CopyDest (NoCopyDest) )
@@ -812,6 +811,7 @@ parseLegacyProjectConfig :: String -> ParseResult LegacyProjectConfig
parseLegacyProjectConfig =
parseConfig legacyProjectConfigFieldDescrs
legacyPackageConfigSectionDescrs
+ legacyPackageConfigFGSectionDescrs
mempty
showLegacyProjectConfig :: LegacyProjectConfig -> String
@@ -819,6 +819,7 @@ showLegacyProjectConfig config =
Disp.render $
showConfig legacyProjectConfigFieldDescrs
legacyPackageConfigSectionDescrs
+ legacyPackageConfigFGSectionDescrs
config
$+$
Disp.text ""
@@ -1166,10 +1167,14 @@ legacyPackageConfigFieldDescrs =
| otherwise = "test-" ++ name
+legacyPackageConfigFGSectionDescrs :: [FGSectionDescr LegacyProjectConfig]
+legacyPackageConfigFGSectionDescrs =
+ [ packageRepoSectionDescr
+ ]
+
legacyPackageConfigSectionDescrs :: [SectionDescr LegacyProjectConfig]
legacyPackageConfigSectionDescrs =
- [ packageRepoSectionDescr
- , packageSpecificOptionsSectionDescr
+ [ packageSpecificOptionsSectionDescr
, liftSection
legacyLocalConfig
(\flags conf -> conf { legacyLocalConfig = flags })
@@ -1187,31 +1192,19 @@ legacyPackageConfigSectionDescrs =
remoteRepoSectionDescr
]
-packageRepoSectionDescr :: SectionDescr LegacyProjectConfig
-packageRepoSectionDescr =
- SectionDescr {
- sectionName = "source-repository-package",
- sectionFields = sourceRepoFieldDescrs,
- sectionSubsections = [],
- sectionGet = map (\x->("", x))
- . legacyPackagesRepo,
- sectionSet =
+packageRepoSectionDescr :: FGSectionDescr LegacyProjectConfig
+packageRepoSectionDescr = FGSectionDescr
+ { fgSectionName = "source-repository-package"
+ , fgSectionGrammar = sourceRepoFieldGrammar (RepoKindUnknown "unused")
+ , fgSectionGet = map (\x->("", x)) . legacyPackagesRepo
+ , fgSectionSet =
\lineno unused pkgrepo projconf -> do
unless (null unused) $
syntaxError lineno "the section 'source-repository-package' takes no arguments"
return projconf {
legacyPackagesRepo = legacyPackagesRepo projconf ++ [pkgrepo]
- },
- sectionEmpty = SourceRepo {
- repoKind = RepoThis, -- hopefully unused
- repoType = Nothing,
- repoLocation = Nothing,
- repoModule = Nothing,
- repoBranch = Nothing,
- repoTag = Nothing,
- repoSubdir = Nothing
- }
- }
+ }
+ }
-- | The definitions of all the fields that can appear in the @package pkgfoo@
-- and @package *@ sections of the @cabal.project@-format files.
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs
index 360b9f5533f950803580412d7ad4a14172e41803..f8c4969d2e7b2dca23781e6cdf4c500db9f97b0f 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs
@@ -763,14 +763,16 @@ instance Arbitrary TestShowDetails where
arbitrary = arbitraryBoundedEnum
instance Arbitrary SourceRepo where
- arbitrary = (SourceRepo RepoThis
+ arbitrary = (SourceRepo kind
<$> arbitrary
<*> (fmap getShortToken <$> arbitrary)
<*> (fmap getShortToken <$> arbitrary)
<*> (fmap getShortToken <$> arbitrary)
<*> (fmap getShortToken <$> arbitrary)
<*> (fmap getShortToken <$> arbitrary))
- `suchThat` (/= emptySourceRepo RepoThis)
+ `suchThat` (/= emptySourceRepo kind)
+ where
+ kind = RepoKindUnknown "unused"
shrink (SourceRepo _ x1 x2 x3 x4 x5 x6) =
[ repo