Skip to content

Commit f0d7245

Browse files
phadejphadej
committed
Versioned
1 parent 907b49c commit f0d7245

File tree

6 files changed

+117
-62
lines changed

6 files changed

+117
-62
lines changed

‎Cabal/Distribution/FieldGrammar.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -40,8 +40,8 @@ import Distribution.FieldGrammar.Pretty
4040
import Distribution.Parsec.Field
4141
import Distribution.Utils.Generic (spanMaybe)
4242

43-
type ParsecFieldGrammar' a = ParsecFieldGrammar a a
44-
type PrettyFieldGrammar' a = PrettyFieldGrammar a a
43+
type ParsecFieldGrammar' v a = ParsecFieldGrammar v a a
44+
type PrettyFieldGrammar' a = PrettyFieldGrammar a a
4545

4646
infixl 5 ^^^
4747

‎Cabal/Distribution/FieldGrammar/Parsec.hs

Lines changed: 13 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
1-
{-# LANGUAGE DeriveFunctor #-}
2-
{-# LANGUAGE OverloadedStrings #-}
1+
{-# LANGUAGE DeriveFunctor #-}
2+
{-# LANGUAGE OverloadedStrings #-}
3+
{-# LANGUAGE ScopedTypeVariables #-}
34
-- | This module provides a 'FieldGrammarParser', one way to parse
45
-- @.cabal@ -like files.
56
--
@@ -98,14 +99,14 @@ data Section ann = MkSection !(Name ann) [SectionArg ann] [Field ann]
9899
-- ParsecFieldGrammar
99100
-------------------------------------------------------------------------------
100101

101-
data ParsecFieldGrammar s a = ParsecFG
102+
data ParsecFieldGrammar v s a = ParsecFG
102103
{ fieldGrammarKnownFields :: !(Set FieldName)
103104
, fieldGrammarKnownPrefixes :: !(Set FieldName)
104105
, fieldGrammarParser :: !(Fields Position -> ParseResult a)
105106
}
106107
deriving (Functor)
107108

108-
parseFieldGrammar :: Fields Position -> ParsecFieldGrammar s a -> ParseResult a
109+
parseFieldGrammar :: Fields Position -> ParsecFieldGrammar v s a -> ParseResult a
109110
parseFieldGrammar fields grammar = do
110111
for_ (Map.toList (Map.filterWithKey isUnknownField fields)) $ \(name, nfields) ->
111112
for_ nfields $ \(MkNamelessField pos _) ->
@@ -120,10 +121,10 @@ parseFieldGrammar fields grammar = do
120121
k `Set.member` fieldGrammarKnownFields grammar
121122
|| any (`BS.isPrefixOf` k) (fieldGrammarKnownPrefixes grammar)
122123

123-
fieldGrammarKnownFieldList :: ParsecFieldGrammar s a -> [FieldName]
124+
fieldGrammarKnownFieldList :: ParsecFieldGrammar v s a -> [FieldName]
124125
fieldGrammarKnownFieldList = Set.toList . fieldGrammarKnownFields
125126

126-
instance Applicative (ParsecFieldGrammar s) where
127+
instance Applicative (ParsecFieldGrammar v s) where
127128
pure x = ParsecFG mempty mempty (\_ -> pure x)
128129
{-# INLINE pure #-}
129130

@@ -133,7 +134,7 @@ instance Applicative (ParsecFieldGrammar s) where
133134
(\fields -> f'' fields <*> x'' fields)
134135
{-# INLINE (<*>) #-}
135136

136-
instance FieldGrammar ParsecFieldGrammar where
137+
instance Versioned v => FieldGrammar (ParsecFieldGrammar v) where
137138
blurFieldGrammar _ (ParsecFG s s' parser) = ParsecFG s s' parser
138139

139140
uniqueFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser
@@ -147,7 +148,7 @@ instance FieldGrammar ParsecFieldGrammar where
147148
Just xs-> parseOne (last xs)
148149

149150
parseOne (MkNamelessField pos fls) =
150-
unpack' _pack <$> runFieldParser pos parsec fls
151+
unpack' _pack <$> runFieldParser pos (versionedParsec ([] :: [v])) fls
151152

152153
booleanFieldDef fn _extract def = ParsecFG (Set.singleton fn) Set.empty parser
153154
where
@@ -160,7 +161,7 @@ instance FieldGrammar ParsecFieldGrammar where
160161
-- TODO: warn about duplicate optional fields?
161162
Just xs -> parseOne (last xs)
162163

163-
parseOne (MkNamelessField pos fls) = runFieldParser pos parsec fls
164+
parseOne (MkNamelessField pos fls) = runFieldParser pos (versionedParsec ([] :: [v])) fls
164165

165166
optionalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser
166167
where
@@ -173,15 +174,15 @@ instance FieldGrammar ParsecFieldGrammar where
173174

174175
parseOne (MkNamelessField pos fls)
175176
| null fls = pure Nothing
176-
| otherwise = Just . (unpack' _pack) <$> runFieldParser pos parsec fls
177+
| otherwise = Just . (unpack' _pack) <$> runFieldParser pos (versionedParsec ([] :: [v])) fls
177178

178179
monoidalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser
179180
where
180181
parser fields = case Map.lookup fn fields of
181182
Nothing -> pure mempty
182183
Just xs -> foldMap (unpack' _pack) <$> traverse parseOne xs
183184

184-
parseOne (MkNamelessField pos fls) = runFieldParser pos parsec fls
185+
parseOne (MkNamelessField pos fls) = runFieldParser pos (versionedParsec ([] :: [v])) fls
185186

186187
prefixedFields fnPfx _extract = ParsecFG mempty (Set.singleton fnPfx) (pure . parser)
187188
where
@@ -199,6 +200,7 @@ instance FieldGrammar ParsecFieldGrammar where
199200
trim :: String -> String
200201
trim = dropWhile isSpace . dropWhileEnd isSpace
201202

203+
-- TODO: use versionedAvailable to drop parsing if old field.
202204
availableSince _ = id
203205

204206
deprecatedSince (_ : _) _ grammar = grammar -- pass on non-empty version

‎Cabal/Distribution/PackageDescription/FieldGrammar.hs

Lines changed: 15 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -49,6 +49,7 @@ import Distribution.License (License (..))
4949
import Distribution.ModuleName (ModuleName)
5050
import Distribution.Package
5151
import Distribution.PackageDescription
52+
import Distribution.Parsec.Class (SpecVersion22, SpecVersionOld)
5253
import Distribution.Parsec.Common
5354
import Distribution.Parsec.Newtypes
5455
import Distribution.Parsec.ParseResult
@@ -127,7 +128,8 @@ libraryFieldGrammar n = Library n
127128
<*> monoidalFieldAla "signatures" (alaList' VCat MQuoted) L.signatures
128129
<*> booleanFieldDef "exposed" L.libExposed True
129130
<*> blurFieldGrammar L.libBuildInfo buildInfoFieldGrammar
130-
{-# SPECIALIZE libraryFieldGrammar :: Maybe UnqualComponentName -> ParsecFieldGrammar' Library #-}
131+
{-# SPECIALIZE libraryFieldGrammar :: Maybe UnqualComponentName -> ParsecFieldGrammar' SpecVersionOld Library #-}
132+
{-# SPECIALIZE libraryFieldGrammar :: Maybe UnqualComponentName -> ParsecFieldGrammar' SpecVersion22 Library #-}
131133
{-# SPECIALIZE libraryFieldGrammar :: Maybe UnqualComponentName -> PrettyFieldGrammar' Library #-}
132134

133135
-------------------------------------------------------------------------------
@@ -144,7 +146,8 @@ foreignLibFieldGrammar n = ForeignLib n
144146
<*> optionalField "lib-version-info" L.foreignLibVersionInfo
145147
<*> optionalField "lib-version-linux" L.foreignLibVersionLinux
146148
<*> monoidalFieldAla "mod-def-file" (alaList' FSep FilePathNT) L.foreignLibModDefFile
147-
{-# SPECIALIZE foreignLibFieldGrammar :: UnqualComponentName -> ParsecFieldGrammar' ForeignLib #-}
149+
{-# SPECIALIZE foreignLibFieldGrammar :: UnqualComponentName -> ParsecFieldGrammar' SpecVersionOld ForeignLib #-}
150+
{-# SPECIALIZE foreignLibFieldGrammar :: UnqualComponentName -> ParsecFieldGrammar' SpecVersion22 ForeignLib #-}
148151
{-# SPECIALIZE foreignLibFieldGrammar :: UnqualComponentName -> PrettyFieldGrammar' ForeignLib #-}
149152

150153
-------------------------------------------------------------------------------
@@ -159,7 +162,8 @@ executableFieldGrammar n = Executable n
159162
<$> optionalFieldDefAla "main-is" FilePathNT L.modulePath ""
160163
<*> monoidalField "scope" L.exeScope
161164
<*> blurFieldGrammar L.buildInfo buildInfoFieldGrammar
162-
{-# SPECIALIZE executableFieldGrammar :: UnqualComponentName -> ParsecFieldGrammar' Executable #-}
165+
{-# SPECIALIZE executableFieldGrammar :: UnqualComponentName -> ParsecFieldGrammar' SpecVersionOld Executable #-}
166+
{-# SPECIALIZE executableFieldGrammar :: UnqualComponentName -> ParsecFieldGrammar' SpecVersion22 Executable #-}
163167
{-# SPECIALIZE executableFieldGrammar :: UnqualComponentName -> PrettyFieldGrammar' Executable #-}
164168

165169
-------------------------------------------------------------------------------
@@ -398,7 +402,8 @@ buildInfoFieldGrammar = BuildInfo
398402
<*> prefixedFields "x-" L.customFieldsBI
399403
<*> monoidalFieldAla "build-depends" (alaList CommaVCat) L.targetBuildDepends
400404
<*> monoidalFieldAla "mixins" (alaList CommaVCat) L.mixins
401-
{-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' BuildInfo #-}
405+
{-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' SpecVersionOld BuildInfo #-}
406+
{-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' SpecVersion22 BuildInfo #-}
402407
{-# SPECIALIZE buildInfoFieldGrammar :: PrettyFieldGrammar' BuildInfo #-}
403408

404409
hsSourceDirsGrammar
@@ -481,7 +486,8 @@ flagFieldGrammar name = MkFlag name
481486
<$> optionalFieldDefAla "description" FreeText L.flagDescription ""
482487
<*> booleanFieldDef "default" L.flagDefault True
483488
<*> booleanFieldDef "manual" L.flagManual False
484-
{-# SPECIALIZE flagFieldGrammar :: FlagName -> ParsecFieldGrammar' Flag #-}
489+
{-# SPECIALIZE flagFieldGrammar :: FlagName -> ParsecFieldGrammar' SpecVersionOld Flag #-}
490+
{-# SPECIALIZE flagFieldGrammar :: FlagName -> ParsecFieldGrammar' SpecVersion22 Flag #-}
485491
{-# SPECIALIZE flagFieldGrammar :: FlagName -> PrettyFieldGrammar' Flag #-}
486492

487493
-------------------------------------------------------------------------------
@@ -498,7 +504,8 @@ sourceRepoFieldGrammar kind = SourceRepo kind
498504
<*> optionalFieldAla "branch" Token L.repoBranch
499505
<*> optionalFieldAla "tag" Token L.repoTag
500506
<*> optionalFieldAla "subdir" FilePathNT L.repoSubdir
501-
{-# SPECIALIZE sourceRepoFieldGrammar :: RepoKind -> ParsecFieldGrammar' SourceRepo #-}
507+
{-# SPECIALIZE sourceRepoFieldGrammar :: RepoKind -> ParsecFieldGrammar' SpecVersionOld SourceRepo #-}
508+
{-# SPECIALIZE sourceRepoFieldGrammar :: RepoKind -> ParsecFieldGrammar' SpecVersion22 SourceRepo #-}
502509
{-# SPECIALIZE sourceRepoFieldGrammar :: RepoKind ->PrettyFieldGrammar' SourceRepo #-}
503510

504511
-------------------------------------------------------------------------------
@@ -510,5 +517,6 @@ setupBInfoFieldGrammar
510517
=> Bool -> g SetupBuildInfo SetupBuildInfo
511518
setupBInfoFieldGrammar def = flip SetupBuildInfo def
512519
<$> monoidalFieldAla "setup-depends" (alaList CommaVCat) L.setupDepends
513-
{-# SPECIALIZE setupBInfoFieldGrammar :: Bool -> ParsecFieldGrammar' SetupBuildInfo #-}
520+
{-# SPECIALIZE setupBInfoFieldGrammar :: Bool -> ParsecFieldGrammar' SpecVersionOld SetupBuildInfo #-}
521+
{-# SPECIALIZE setupBInfoFieldGrammar :: Bool -> ParsecFieldGrammar' SpecVersion22 SetupBuildInfo #-}
514522
{-# SPECIALIZE setupBInfoFieldGrammar :: Bool ->PrettyFieldGrammar' SetupBuildInfo #-}

‎Cabal/Distribution/PackageDescription/Parsec.hs

Lines changed: 35 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -42,7 +42,7 @@ import Distribution.FieldGrammar
4242
import Distribution.PackageDescription
4343
import Distribution.PackageDescription.FieldGrammar
4444
import Distribution.PackageDescription.Quirks (patchQuirks)
45-
import Distribution.Parsec.Class (parsec)
45+
import Distribution.Parsec.Class (parsec, Versioned, SpecVersionOld, SpecVersion22)
4646
import Distribution.Parsec.Common
4747
import Distribution.Parsec.ConfVar (parseConditionConfVar)
4848
import Distribution.Parsec.Field (FieldName, getName)
@@ -141,15 +141,20 @@ parseGenericPackageDescription' lexWarnings fs = do
141141

142142
-- PackageDescription
143143
let (fields, sectionFields) = takeFields fs'
144-
pd <- parseFieldGrammar fields packageDescriptionFieldGrammar
144+
pd <- parseFieldGrammar fields (packageDescriptionFieldGrammar :: ParsecFieldGrammar' SpecVersionOld PackageDescription)
145145
maybeWarnCabalVersion syntax pd
146146

147147
-- Sections
148148
let gpd = emptyGpd & L.packageDescription .~ pd
149149

150150
-- elif conditional is accepted if spec version is >= 2.1
151151
let hasElif = if specVersion pd >= mkVersion [2,1] then HasElif else NoElif
152-
execStateT (goSections hasElif sectionFields) gpd
152+
let goSections' =
153+
if specVersion pd >= mkVersion [2,1]
154+
then goSections ([] :: [SpecVersion22])
155+
else goSections ([] :: [SpecVersionOld])
156+
157+
execStateT (goSections' hasElif sectionFields) gpd
153158
where
154159
emptyGpd :: GenericPackageDescription
155160
emptyGpd = GenericPackageDescription emptyPackageDescription [] Nothing [] [] [] [] []
@@ -180,8 +185,8 @@ parseGenericPackageDescription' lexWarnings fs = do
180185
maybeWarnCabalVersion _ _ = return ()
181186

182187
-- Sections
183-
goSections :: HasElif -> [Field Position] -> SectionParser ()
184-
goSections hasElif = traverse_ process
188+
goSections :: forall proxy v. Versioned v => proxy v -> HasElif -> [Field Position] -> SectionParser ()
189+
goSections proxyV hasElif = traverse_ process
185190
where
186191
process (Field (Name pos name) _) =
187192
lift $ parseWarning pos PWTTrailingFields $
@@ -191,56 +196,58 @@ goSections hasElif = traverse_ process
191196

192197
snoc x xs = xs ++ [x]
193198

199+
parseCondTree' = parseCondTree proxyV
200+
194201
parseSection :: Name Position -> [SectionArg Position] -> [Field Position] -> SectionParser ()
195202
parseSection (Name pos name) args fields
196203
| name == "library" && null args = do
197-
lib <- lift $ parseCondTree hasElif (libraryFieldGrammar Nothing) (targetBuildDepends . libBuildInfo) fields
204+
lib <- lift $ parseCondTree' hasElif (libraryFieldGrammar Nothing) (targetBuildDepends . libBuildInfo) fields
198205
-- TODO: check that library is defined once
199206
L.condLibrary ?= lib
200207

201208
-- Sublibraries
202209
| name == "library" = do
203210
-- TODO: check cabal-version
204211
name' <- parseUnqualComponentName pos args
205-
lib <- lift $ parseCondTree hasElif (libraryFieldGrammar $ Just name') (targetBuildDepends . libBuildInfo) fields
212+
lib <- lift $ parseCondTree' hasElif (libraryFieldGrammar $ Just name') (targetBuildDepends . libBuildInfo) fields
206213
-- TODO check duplicate name here?
207214
L.condSubLibraries %= snoc (name', lib)
208215

209216
| name == "foreign-library" = do
210217
name' <- parseUnqualComponentName pos args
211-
flib <- lift $ parseCondTree hasElif (foreignLibFieldGrammar name') (targetBuildDepends . foreignLibBuildInfo) fields
218+
flib <- lift $ parseCondTree' hasElif (foreignLibFieldGrammar name') (targetBuildDepends . foreignLibBuildInfo) fields
212219
-- TODO check duplicate name here?
213220
L.condForeignLibs %= snoc (name', flib)
214221

215222
| name == "executable" = do
216223
name' <- parseUnqualComponentName pos args
217-
exe <- lift $ parseCondTree hasElif (executableFieldGrammar name') (targetBuildDepends . buildInfo) fields
224+
exe <- lift $ parseCondTree' hasElif (executableFieldGrammar name') (targetBuildDepends . buildInfo) fields
218225
-- TODO check duplicate name here?
219226
L.condExecutables %= snoc (name', exe)
220227

221228
| name == "test-suite" = do
222229
name' <- parseUnqualComponentName pos args
223-
testStanza <- lift $ parseCondTree hasElif testSuiteFieldGrammar (targetBuildDepends . _testStanzaBuildInfo) fields
230+
testStanza <- lift $ parseCondTree' hasElif testSuiteFieldGrammar (targetBuildDepends . _testStanzaBuildInfo) fields
224231
testSuite <- lift $ traverse (validateTestSuite pos) testStanza
225232
-- TODO check duplicate name here?
226233
L.condTestSuites %= snoc (name', testSuite)
227234

228235
| name == "benchmark" = do
229236
name' <- parseUnqualComponentName pos args
230-
benchStanza <- lift $ parseCondTree hasElif benchmarkFieldGrammar (targetBuildDepends . _benchmarkStanzaBuildInfo) fields
237+
benchStanza <- lift $ parseCondTree' hasElif benchmarkFieldGrammar (targetBuildDepends . _benchmarkStanzaBuildInfo) fields
231238
bench <- lift $ traverse (validateBenchmark pos) benchStanza
232239
-- TODO check duplicate name here?
233240
L.condBenchmarks %= snoc (name', bench)
234241

235242
| name == "flag" = do
236243
name' <- parseName pos args
237244
name'' <- lift $ runFieldParser' pos parsec name' `recoverWith` mkFlagName ""
238-
flag <- lift $ parseFields fields (flagFieldGrammar name'')
245+
flag <- lift $ parseFields proxyV fields (flagFieldGrammar name'')
239246
-- Check default flag
240247
L.genPackageFlags %= snoc flag
241248

242249
| name == "custom-setup" && null args = do
243-
sbi <- lift $ parseFields fields (setupBInfoFieldGrammar False)
250+
sbi <- lift $ parseFields proxyV fields (setupBInfoFieldGrammar False)
244251
L.packageDescription . L.setupBuildInfo ?= sbi
245252

246253
| name == "source-repository" = do
@@ -254,7 +261,7 @@ goSections hasElif = traverse_ process
254261
parseFailure pos $ "Invalid source-repository kind " ++ show args
255262
pure RepoHead
256263

257-
sr <- lift $ parseFields fields (sourceRepoFieldGrammar kind)
264+
sr <- lift $ parseFields proxyV fields (sourceRepoFieldGrammar kind)
258265
L.packageDescription . L.sourceRepos %= snoc sr
259266

260267
| otherwise = lift $
@@ -279,10 +286,11 @@ parseUnqualComponentName pos args = mkUnqualComponentName <$> parseName pos args
279286

280287
-- | Parse a non-recursive list of fields.
281288
parseFields
282-
:: [Field Position] -- ^ fields to be parsed
283-
-> ParsecFieldGrammar' a
289+
:: proxy v
290+
-> [Field Position] -- ^ fields to be parsed
291+
-> ParsecFieldGrammar' v a
284292
-> ParseResult a
285-
parseFields fields grammar = do
293+
parseFields _ fields grammar = do
286294
let (fs0, ss) = partitionFields fields
287295
traverse_ (traverse_ warnInvalidSubsection) ss
288296
parseFieldGrammar fs0 grammar
@@ -296,13 +304,14 @@ data HasElif = HasElif | NoElif
296304
deriving (Eq, Show)
297305

298306
parseCondTree
299-
:: forall a c.
300-
HasElif -- ^ accept @elif@
301-
-> ParsecFieldGrammar' a -- ^ grammar
302-
-> (a -> c) -- ^ condition extractor
307+
:: forall a c proxy v.
308+
proxy v
309+
-> HasElif -- ^ accept @elif@
310+
-> ParsecFieldGrammar' v a -- ^ grammar
311+
-> (a -> c) -- ^ condition extractor
303312
-> [Field Position]
304313
-> ParseResult (CondTree ConfVar c a)
305-
parseCondTree hasElif grammar cond = go
314+
parseCondTree _ hasElif grammar cond = go
306315
where
307316
go fields = do
308317
let (fs, ss) = partitionFields fields
@@ -432,8 +441,9 @@ sectionizeFields fs = case classifyFields fs of
432441
data Syntax = OldSyntax | NewSyntax
433442
deriving (Eq, Show)
434443

444+
-- TODO:
435445
libFieldNames :: [FieldName]
436-
libFieldNames = fieldGrammarKnownFieldList (libraryFieldGrammar Nothing)
446+
libFieldNames = fieldGrammarKnownFieldList (libraryFieldGrammar Nothing :: ParsecFieldGrammar' SpecVersionOld Library)
437447

438448
-------------------------------------------------------------------------------
439449
-- Suplementary build information
@@ -467,11 +477,11 @@ parseHookedBuildInfo' lexWarnings fs = do
467477
parseLib :: Fields Position -> ParseResult (Maybe BuildInfo)
468478
parseLib fields
469479
| Map.null fields = pure Nothing
470-
| otherwise = Just <$> parseFieldGrammar fields buildInfoFieldGrammar
480+
| otherwise = Just <$> parseFieldGrammar fields (buildInfoFieldGrammar :: ParsecFieldGrammar' SpecVersion22 BuildInfo)
471481

472482
parseExe :: (UnqualComponentName, Fields Position) -> ParseResult (UnqualComponentName, BuildInfo)
473483
parseExe (n, fields) = do
474-
bi <- parseFieldGrammar fields buildInfoFieldGrammar
484+
bi <- parseFieldGrammar fields (buildInfoFieldGrammar :: ParsecFieldGrammar' SpecVersion22 BuildInfo)
475485
pure (n, bi)
476486

477487
stanzas :: [Field Position] -> ParseResult (Fields Position, [(UnqualComponentName, Fields Position)])

0 commit comments

Comments
 (0)