Skip to content

Commit 1f5426c

Browse files
phadejphadej
committed
Add FGSectionDescrs so cabal.project sections can be parsed using FieldGrammar
1 parent 0b7db2b commit 1f5426c

File tree

3 files changed

+135
-48
lines changed

3 files changed

+135
-48
lines changed

‎cabal-install/Distribution/Client/ParseUtils.hs

Lines changed: 114 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
{-# LANGUAGE ExistentialQuantification, NamedFieldPuns #-}
1+
{-# LANGUAGE ExistentialQuantification, NamedFieldPuns, RankNTypes #-}
22

33
-----------------------------------------------------------------------------
44
-- |
@@ -24,6 +24,9 @@ module Distribution.Client.ParseUtils (
2424
SectionDescr(..),
2525
liftSection,
2626

27+
-- * FieldGrammar sections
28+
FGSectionDescr(..),
29+
2730
-- * Parsing and printing flat config
2831
parseFields,
2932
ppFields,
@@ -39,6 +42,9 @@ module Distribution.Client.ParseUtils (
3942
)
4043
where
4144

45+
import Distribution.Client.Compat.Prelude hiding (empty, get)
46+
import Prelude ()
47+
4248
import Distribution.Deprecated.ParseUtils
4349
( FieldDescr(..), ParseResult(..), warning, LineNo, lineNo
4450
, Field(..), liftField, readFieldsFlat )
@@ -48,12 +54,22 @@ import Distribution.Deprecated.ViewAsFieldDescr
4854
import Distribution.Simple.Command
4955
( OptionField )
5056

51-
import Control.Monad ( foldM )
5257
import Text.PrettyPrint ( (<+>), ($+$) )
5358
import qualified Data.Map as Map
5459
import qualified Text.PrettyPrint as Disp
5560
( (<>), Doc, text, colon, vcat, empty, isEmpty, nest )
5661

62+
-- For new parser stuff
63+
import Distribution.CabalSpecVersion (cabalSpecLatest)
64+
import Distribution.FieldGrammar (FieldGrammar, partitionFields, parseFieldGrammar)
65+
import Distribution.Fields.ParseResult (runParseResult)
66+
import Distribution.Parsec.Error (showPError)
67+
import Distribution.Parsec.Position (Position (..))
68+
import Distribution.Parsec.Warning (showPWarning)
69+
import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS)
70+
import qualified Distribution.Fields as F
71+
import qualified Distribution.FieldGrammar as FG
72+
5773

5874
-------------------------
5975
-- FieldDescr utilities
@@ -107,6 +123,15 @@ data SectionDescr a = forall b. SectionDescr {
107123
sectionEmpty :: b
108124
}
109125

126+
-- | 'FieldGrammar' section description
127+
data FGSectionDescr a = forall s. FGSectionDescr
128+
{ fgSectionName :: String
129+
, fgSectionGrammar :: forall g. (FieldGrammar g, Applicative (g s)) => g s s
130+
-- todo: add subsections?
131+
, fgSectionGet :: a -> [(String, s)]
132+
, fgSectionSet :: LineNo -> String -> s -> a -> ParseResult a
133+
}
134+
110135
-- | To help construction of config file descriptions in a modular way it is
111136
-- useful to define fields and sections on local types and then hoist them
112137
-- into the parent types when combining them in bigger descriptions.
@@ -191,13 +216,18 @@ ppSection name arg fields def cur
191216
-- | Much like 'parseFields' but it also allows subsections. The permitted
192217
-- subsections are given by a list of 'SectionDescr's.
193218
--
194-
parseFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> a
195-
-> [Field] -> ParseResult a
196-
parseFieldsAndSections fieldDescrs sectionDescrs =
219+
parseFieldsAndSections
220+
:: [FieldDescr a] -- ^ field
221+
-> [SectionDescr a] -- ^ legacy sections
222+
-> [FGSectionDescr a] -- ^ FieldGrammar sections
223+
-> a
224+
-> [Field] -> ParseResult a
225+
parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs =
197226
foldM setField
198227
where
199-
fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ]
200-
sectionMap = Map.fromList [ (sectionName s, s) | s <- sectionDescrs ]
228+
fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ]
229+
sectionMap = Map.fromList [ (sectionName s, s) | s <- sectionDescrs ]
230+
fgSectionMap = Map.fromList [ (fgSectionName s, s) | s <- fgSectionDescrs ]
201231

202232
setField a (F line name value) =
203233
case Map.lookup name fieldMap of
@@ -208,10 +238,25 @@ parseFieldsAndSections fieldDescrs sectionDescrs =
208238
return a
209239

210240
setField a (Section line name param fields) =
211-
case Map.lookup name sectionMap of
212-
Just (SectionDescr _ fieldDescrs' sectionDescrs' _ set sectionEmpty) -> do
213-
b <- parseFieldsAndSections fieldDescrs' sectionDescrs' sectionEmpty fields
241+
case Left <$> Map.lookup name sectionMap <|> Right <$> Map.lookup name fgSectionMap of
242+
Just (Left (SectionDescr _ fieldDescrs' sectionDescrs' _ set sectionEmpty)) -> do
243+
b <- parseFieldsAndSections fieldDescrs' sectionDescrs' [] sectionEmpty fields
214244
set line param b a
245+
Just (Right (FGSectionDescr _ grammar _getter setter)) -> do
246+
let fields1 = mapMaybe convertField fields
247+
(fields2, sections) = partitionFields fields1
248+
-- TODO: recurse into sections
249+
for_ (concat sections) $ \(FG.MkSection (F.Name (Position line' _) name') _ _) ->
250+
warning $ "Unrecognized section '" ++ fromUTF8BS name'
251+
++ "' on line " ++ show line'
252+
case runParseResult $ parseFieldGrammar cabalSpecLatest fields2 grammar of
253+
(warnings, Right b) -> do
254+
for_ warnings $ \w -> warning $ showPWarning "???" w
255+
setter line param b a
256+
(warnings, Left (_, errs)) -> do
257+
for_ warnings $ \w -> warning $ showPWarning "???" w
258+
case errs of
259+
err :| _errs -> fail $ showPError "???" err
215260
Nothing -> do
216261
warning $ "Unrecognized section '" ++ name
217262
++ "' on line " ++ show line
@@ -221,17 +266,31 @@ parseFieldsAndSections fieldDescrs sectionDescrs =
221266
warning $ "Unrecognized stanza on line " ++ show (lineNo block)
222267
return accum
223268

269+
convertField :: Field -> Maybe (F.Field Position)
270+
convertField (F line name str) = Just $
271+
F.Field (F.Name pos (toUTF8BS name)) [ F.FieldLine pos $ toUTF8BS str ]
272+
where
273+
pos = Position line 0
274+
-- arguments omitted
275+
convertField (Section line name _arg fields) = Just $
276+
F.Section (F.Name pos (toUTF8BS name)) [] (mapMaybe convertField fields)
277+
where
278+
pos = Position line 0
279+
-- silently omitted.
280+
convertField IfBlock {} = Nothing
281+
282+
224283
-- | Much like 'ppFields' but also pretty prints any subsections. Subsection
225284
-- are only shown if they are non-empty.
226285
--
227286
-- Note that unlike 'ppFields', at present it does not support printing
228287
-- default values. If needed, adding such support would be quite reasonable.
229288
--
230-
ppFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> a -> Disp.Doc
231-
ppFieldsAndSections fieldDescrs sectionDescrs val =
289+
ppFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr a] -> a -> Disp.Doc
290+
ppFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs val =
232291
ppFields fieldDescrs Nothing val
233292
$+$
234-
Disp.vcat
293+
Disp.vcat (
235294
[ Disp.text "" $+$ sectionDoc
236295
| SectionDescr {
237296
sectionName, sectionGet,
@@ -240,24 +299,57 @@ ppFieldsAndSections fieldDescrs sectionDescrs val =
240299
, (param, x) <- sectionGet val
241300
, let sectionDoc = ppSectionAndSubsections
242301
sectionName param
243-
sectionFields sectionSubsections x
302+
sectionFields sectionSubsections [] x
303+
, not (Disp.isEmpty sectionDoc)
304+
] ++
305+
[ Disp.text "" $+$ sectionDoc
306+
| FGSectionDescr { fgSectionName, fgSectionGrammar, fgSectionGet } <- fgSectionDescrs
307+
, (param, x) <- fgSectionGet val
308+
, let sectionDoc = ppFgSection fgSectionName param fgSectionGrammar x
244309
, not (Disp.isEmpty sectionDoc)
245-
]
310+
])
246311

247312
-- | Unlike 'ppSection' which has to be called directly, this gets used via
248313
-- 'ppFieldsAndSections' and so does not need to be exported.
249314
--
250315
ppSectionAndSubsections :: String -> String
251-
-> [FieldDescr a] -> [SectionDescr a] -> a -> Disp.Doc
252-
ppSectionAndSubsections name arg fields sections cur
316+
-> [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr a] -> a -> Disp.Doc
317+
ppSectionAndSubsections name arg fields sections fgSections cur
253318
| Disp.isEmpty fieldsDoc = Disp.empty
254319
| otherwise = Disp.text name <+> argDoc
255320
$+$ (Disp.nest 2 fieldsDoc)
256321
where
257-
fieldsDoc = showConfig fields sections cur
322+
fieldsDoc = showConfig fields sections fgSections cur
258323
argDoc | arg == "" = Disp.empty
259324
| otherwise = Disp.text arg
260325

326+
-- |
327+
--
328+
-- TODO: subsections
329+
-- TODO: this should simply build 'PrettyField'
330+
ppFgSection
331+
:: String -- ^ section name
332+
-> String -- ^ parameter
333+
-> FG.PrettyFieldGrammar a a
334+
-> a
335+
-> Disp.Doc
336+
ppFgSection secName arg grammar x
337+
| null prettyFields = Disp.empty
338+
| otherwise =
339+
Disp.text secName <+> argDoc
340+
$+$ (Disp.nest 2 fieldsDoc)
341+
where
342+
prettyFields = FG.prettyFieldGrammar cabalSpecLatest grammar x
343+
344+
argDoc | arg == "" = Disp.empty
345+
| otherwise = Disp.text arg
346+
347+
fieldsDoc = Disp.vcat
348+
[ Disp.text fname' <<>> Disp.colon <<>> doc
349+
| F.PrettyField _ fname doc <- prettyFields -- TODO: this skips sections
350+
, let fname' = fromUTF8BS fname
351+
]
352+
261353

262354
-----------------------------------------------
263355
-- Top level config file parsing and printing
@@ -268,15 +360,15 @@ ppSectionAndSubsections name arg fields sections cur
268360
--
269361
-- It accumulates the result on top of a given initial (typically empty) value.
270362
--
271-
parseConfig :: [FieldDescr a] -> [SectionDescr a] -> a
363+
parseConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr a] -> a
272364
-> String -> ParseResult a
273-
parseConfig fieldDescrs sectionDescrs empty str =
274-
parseFieldsAndSections fieldDescrs sectionDescrs empty
365+
parseConfig fieldDescrs sectionDescrs fgSectionDescrs empty str =
366+
parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs empty
275367
=<< readFieldsFlat str
276368

277369
-- | Render a value in the config file syntax, based on a description of the
278370
-- configuration file in terms of its fields and sections.
279371
--
280-
showConfig :: [FieldDescr a] -> [SectionDescr a] -> a -> Disp.Doc
372+
showConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr a] -> a -> Disp.Doc
281373
showConfig = ppFieldsAndSections
282374

‎cabal-install/Distribution/Client/ProjectConfig/Legacy.hs

Lines changed: 17 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -43,8 +43,7 @@ import Distribution.Package
4343
import Distribution.PackageDescription
4444
( SourceRepo(..), RepoKind(..)
4545
, dispFlagAssignment )
46-
import Distribution.Client.SourceRepoParse
47-
( sourceRepoFieldDescrs )
46+
import Distribution.PackageDescription.FieldGrammar (sourceRepoFieldGrammar)
4847
import Distribution.Simple.Compiler
4948
( OptimisationLevel(..), DebugInfoLevel(..) )
5049
import Distribution.Simple.InstallDirs ( CopyDest (NoCopyDest) )
@@ -812,13 +811,15 @@ parseLegacyProjectConfig :: String -> ParseResult LegacyProjectConfig
812811
parseLegacyProjectConfig =
813812
parseConfig legacyProjectConfigFieldDescrs
814813
legacyPackageConfigSectionDescrs
814+
legacyPackageConfigFGSectionDescrs
815815
mempty
816816

817817
showLegacyProjectConfig :: LegacyProjectConfig -> String
818818
showLegacyProjectConfig config =
819819
Disp.render $
820820
showConfig legacyProjectConfigFieldDescrs
821821
legacyPackageConfigSectionDescrs
822+
legacyPackageConfigFGSectionDescrs
822823
config
823824
$+$
824825
Disp.text ""
@@ -1166,10 +1167,14 @@ legacyPackageConfigFieldDescrs =
11661167
| otherwise = "test-" ++ name
11671168

11681169

1170+
legacyPackageConfigFGSectionDescrs :: [FGSectionDescr LegacyProjectConfig]
1171+
legacyPackageConfigFGSectionDescrs =
1172+
[ packageRepoSectionDescr
1173+
]
1174+
11691175
legacyPackageConfigSectionDescrs :: [SectionDescr LegacyProjectConfig]
11701176
legacyPackageConfigSectionDescrs =
1171-
[ packageRepoSectionDescr
1172-
, packageSpecificOptionsSectionDescr
1177+
[ packageSpecificOptionsSectionDescr
11731178
, liftSection
11741179
legacyLocalConfig
11751180
(\flags conf -> conf { legacyLocalConfig = flags })
@@ -1187,31 +1192,19 @@ legacyPackageConfigSectionDescrs =
11871192
remoteRepoSectionDescr
11881193
]
11891194

1190-
packageRepoSectionDescr :: SectionDescr LegacyProjectConfig
1191-
packageRepoSectionDescr =
1192-
SectionDescr {
1193-
sectionName = "source-repository-package",
1194-
sectionFields = sourceRepoFieldDescrs,
1195-
sectionSubsections = [],
1196-
sectionGet = map (\x->("", x))
1197-
. legacyPackagesRepo,
1198-
sectionSet =
1195+
packageRepoSectionDescr :: FGSectionDescr LegacyProjectConfig
1196+
packageRepoSectionDescr = FGSectionDescr
1197+
{ fgSectionName = "source-repository-package"
1198+
, fgSectionGrammar = sourceRepoFieldGrammar (RepoKindUnknown "unused")
1199+
, fgSectionGet = map (\x->("", x)) . legacyPackagesRepo
1200+
, fgSectionSet =
11991201
\lineno unused pkgrepo projconf -> do
12001202
unless (null unused) $
12011203
syntaxError lineno "the section 'source-repository-package' takes no arguments"
12021204
return projconf {
12031205
legacyPackagesRepo = legacyPackagesRepo projconf ++ [pkgrepo]
1204-
},
1205-
sectionEmpty = SourceRepo {
1206-
repoKind = RepoThis, -- hopefully unused
1207-
repoType = Nothing,
1208-
repoLocation = Nothing,
1209-
repoModule = Nothing,
1210-
repoBranch = Nothing,
1211-
repoTag = Nothing,
1212-
repoSubdir = Nothing
1213-
}
1214-
}
1206+
}
1207+
}
12151208

12161209
-- | The definitions of all the fields that can appear in the @package pkgfoo@
12171210
-- and @package *@ sections of the @cabal.project@-format files.

‎cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -763,14 +763,16 @@ instance Arbitrary TestShowDetails where
763763
arbitrary = arbitraryBoundedEnum
764764

765765
instance Arbitrary SourceRepo where
766-
arbitrary = (SourceRepo RepoThis
766+
arbitrary = (SourceRepo kind
767767
<$> arbitrary
768768
<*> (fmap getShortToken <$> arbitrary)
769769
<*> (fmap getShortToken <$> arbitrary)
770770
<*> (fmap getShortToken <$> arbitrary)
771771
<*> (fmap getShortToken <$> arbitrary)
772772
<*> (fmap getShortToken <$> arbitrary))
773-
`suchThat` (/= emptySourceRepo RepoThis)
773+
`suchThat` (/= emptySourceRepo kind)
774+
where
775+
kind = RepoKindUnknown "unused"
774776

775777
shrink (SourceRepo _ x1 x2 x3 x4 x5 x6) =
776778
[ repo

0 commit comments

Comments
 (0)