Skip to content

Commit 51493a4

Browse files
phadejphadej
committed
WIP [ci skip]
- Parse custom-setup. Fixes haskell#4697 [ci skip] - Rename PPP to FieldGrammar. Flatten D.PackageDescription namespace - Add booleanFieldDef, flagFieldGrammar - Correct FreeText parsec - WIP: FieldGrammar BuildInfo and Library [ci skip] - More newtypes [ci skip] - Unknown and deprecated fields - NoCommaFSep - extra-libraries [ci skip] - Parse 'else' [ci skip] - WIP - More BuildInfo opts [ci skip] - ReadP parses 'location:\n' as location = Just "" [ci skip] - Known fields [ci skip] - monoidalField [ci skip] - ^^^ operator - RFC: Add elif [ci skip] - Make FieldGrammar into a type class [ci skip] - Parse sublibraries with FieldGrammar [ci skip] - Use prettyFieldGrammar for library sections [ci skip] - executableFieldGrammar [ci skip] - ForeignLib grammar - PackageDescription grammar [ci skip] - Remove unused imports - shake regression - Update extra-source-files [ci skip] - TestSuite & Benchmark grammars [ci skip] - Change readp license-files setter [ci skip] - Add hiddenField - Add GPD parse . pretty roundtrip tests. Fixes haskell#4719 - Roundtrip hackage tests [ci skip] - Roundtrip fixes [ci skip] - More pretty-printing fixes - More pp fixes [ci skip]
1 parent cfa2619 commit 51493a4

35 files changed

+2825
-1324
lines changed

‎Cabal/Cabal.cabal

Lines changed: 12 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -33,9 +33,12 @@ extra-source-files:
3333
-- Do NOT edit this section manually; instead, run the script.
3434
-- BEGIN gen-extra-source-files
3535
tests/ParserTests/regressions/Octree-0.5.cabal
36+
tests/ParserTests/regressions/elif.cabal
3637
tests/ParserTests/regressions/encoding-0.8.cabal
38+
tests/ParserTests/regressions/generics-sop.cabal
3739
tests/ParserTests/regressions/issue-774.cabal
3840
tests/ParserTests/regressions/nothing-unicode.cabal
41+
tests/ParserTests/regressions/shake.cabal
3942
tests/ParserTests/warnings/bom.cabal
4043
tests/ParserTests/warnings/bool.cabal
4144
tests/ParserTests/warnings/deprecatedfield.cabal
@@ -274,17 +277,21 @@ library
274277
parsec >= 3.1.9 && <3.2
275278
exposed-modules:
276279
Distribution.Compat.Parsec
280+
Distribution.FieldGrammar
281+
Distribution.FieldGrammar.Class
282+
Distribution.FieldGrammar.Parsec
283+
Distribution.FieldGrammar.Pretty
284+
Distribution.PackageDescription.FieldGrammar
277285
Distribution.PackageDescription.Parsec
278-
Distribution.PackageDescription.Parsec.FieldDescr
279-
Distribution.PackageDescription.Parsec.Quirks
286+
Distribution.PackageDescription.Quirks
280287
Distribution.Parsec.Class
281288
Distribution.Parsec.ConfVar
282289
Distribution.Parsec.Lexer
283290
Distribution.Parsec.LexerMonad
291+
Distribution.Parsec.Newtypes
284292
Distribution.Parsec.Parser
285293
Distribution.Parsec.Types.Common
286294
Distribution.Parsec.Types.Field
287-
Distribution.Parsec.Types.FieldDescr
288295
Distribution.Parsec.Types.ParseResult
289296

290297
-- Lens functionality
@@ -400,6 +407,7 @@ test-suite parser-tests
400407
type: exitcode-stdio-1.0
401408
hs-source-dirs: tests
402409
main-is: ParserTests.hs
410+
build-depends: containers
403411
build-depends:
404412
base,
405413
bytestring,
@@ -450,7 +458,7 @@ test-suite parser-hackage-tests
450458

451459
if flag(parsec-struct-diff)
452460
build-depends:
453-
generics-sop >= 0.2.5 && <0.3,
461+
generics-sop >= 0.3.1.0 && <0.4,
454462
these >=0.7.1 && <0.8,
455463
singleton-bool >=0.1.1.0 && <0.2,
456464
keys

‎Cabal/Distribution/FieldGrammar.hs

Lines changed: 141 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,141 @@
1+
{-# LANGUAGE DeriveFunctor #-}
2+
{-# LANGUAGE FlexibleContexts #-}
3+
{-# LANGUAGE FlexibleInstances #-}
4+
{-# LANGUAGE OverloadedStrings #-}
5+
{-# LANGUAGE ScopedTypeVariables #-}
6+
-- | This module provides one way to specify 'FieldGrammar',
7+
-- to parse lists of 'Field' and pretty print the structures.
8+
--
9+
-- Fields can be specified multiple times in the .cabal files.
10+
-- The order of such entries is important, but the mutual ordering of different
11+
-- fields is non important. (The only exception is @hs-source-dirs@ and
12+
-- @hs-source-dir@, but it can be fixed with preprocessing).
13+
--
14+
-- Also conditional sections are considered after non-conditional data.
15+
-- The example of this silent-commutation quirck is the fact that
16+
--
17+
-- @
18+
-- buildable: True
19+
-- if os(linux)
20+
-- buildable: False
21+
-- @
22+
--
23+
-- and
24+
--
25+
-- @
26+
-- if os(linux)
27+
-- buildable: False
28+
-- buildable: True
29+
-- @
30+
--
31+
-- behave the same! This is the limitation of 'GeneralPackageDescription'
32+
-- structure.
33+
--
34+
-- So we transform the list of fields @['Field' ann]@ into
35+
-- a map of grouped ordinary fields and a list of lists of sections:
36+
-- @'Fields' ann = 'Map' 'FieldName' ['NamelessField' ann]@ and @[['Section' ann]]@.
37+
--
38+
-- We need list of list of sections, because we need to distinguish situations
39+
-- where there are fields in between. For example
40+
--
41+
-- @
42+
-- if flag(bytestring-lt-0_10_4)
43+
-- build-depends: bytestring < 0.10.4
44+
--
45+
-- default-language: Haskell2020
46+
--
47+
-- else
48+
-- build-depends: bytestring >= 0.10.4
49+
--
50+
-- @
51+
--
52+
-- is obviously invalid specification.
53+
--
54+
-- We can parse 'Fields' like we parse @aeson@ objects, yet we use
55+
-- slighly higher-level API, so we can process unspecified fields,
56+
-- to report unknown fields and save custom @x-fields@.
57+
--
58+
module Distribution.FieldGrammar (
59+
-- * Field grammar type
60+
FieldGrammar (..),
61+
uniqueField,
62+
optionalField,
63+
optionalFieldDef,
64+
optionalFieldDefAla,
65+
monoidalField,
66+
deprecatedField',
67+
-- * Concrete grammar implementations
68+
ParsecFieldGrammar,
69+
ParsecFieldGrammar',
70+
parseFieldGrammar,
71+
fieldGrammarKnownFieldList,
72+
PrettyFieldGrammar,
73+
PrettyFieldGrammar',
74+
prettyFieldGrammar,
75+
-- * Auxlilary
76+
(^^^),
77+
Section(..),
78+
partitionFields,
79+
takeFields,
80+
) where
81+
82+
import Distribution.Compat.Prelude
83+
import Prelude ()
84+
85+
import qualified Distribution.Compat.Map.Strict as Map
86+
87+
import Distribution.FieldGrammar.Class
88+
import Distribution.FieldGrammar.Parsec
89+
import Distribution.FieldGrammar.Pretty
90+
import Distribution.Parsec.Types.Field
91+
92+
type ParsecFieldGrammar' a = ParsecFieldGrammar a a
93+
type PrettyFieldGrammar' a = PrettyFieldGrammar a a
94+
95+
infixl 5 ^^^
96+
97+
-- | Reverse function application which binds tighter than '<$>' and '<*>'.
98+
-- Useful for refining grammar specification.
99+
--
100+
-- @
101+
-- \<*\> 'monoidalFieldAla' "extensions" (alaList' FSep MQuoted) oldExtensions
102+
-- ^^^ 'deprecatedSince' [1,12] "Please use 'default-extensions' or 'other-extensions' fields."
103+
-- @
104+
(^^^) :: a -> (a -> b) -> b
105+
x ^^^ f = f x
106+
107+
-- | Partitionin state
108+
data PS ann = PS (Fields ann) [Section ann] [[Section ann]]
109+
110+
-- | Partition field list into field map and groups of sections.
111+
partitionFields :: [Field ann] -> (Fields ann, [[Section ann]])
112+
partitionFields = finalize . foldl' f (PS mempty mempty mempty)
113+
where
114+
finalize :: PS ann -> (Fields ann, [[Section ann]])
115+
finalize (PS fs s ss)
116+
| null s = (fs, reverse ss)
117+
| otherwise = (fs, reverse (reverse s : ss))
118+
119+
f :: PS ann -> Field ann -> PS ann
120+
f (PS fs s ss) (Field (Name ann name) fss) =
121+
PS (Map.insertWith (flip (++)) name [MkNamelessField ann fss] fs) [] ss'
122+
where
123+
ss' | null s = ss
124+
| otherwise = reverse s : ss
125+
f (PS fs s ss) (Section name sargs sfields) =
126+
PS fs (MkSection name sargs sfields : s) ss
127+
128+
-- | Take all fields from the front.
129+
takeFields :: [Field ann] -> (Fields ann, [Field ann])
130+
takeFields = finalize . spanMaybe match
131+
where
132+
finalize (fs, rest) = (Map.fromListWith (flip (++)) fs, rest)
133+
134+
match (Field (Name ann name) fs) = Just (name, [MkNamelessField ann fs])
135+
match _ = Nothing
136+
137+
spanMaybe :: (a -> Maybe b) -> [a] -> ([b],[a])
138+
spanMaybe _ xs@[] = ([], xs)
139+
spanMaybe p xs@(x:xs') = case p x of
140+
Just y -> let (ys, zs) = spanMaybe p xs' in (y : ys, zs)
141+
Nothing -> ([], xs)

‎Cabal/Distribution/FieldGrammar/Class.hs

Lines changed: 149 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,149 @@
1+
module Distribution.FieldGrammar.Class (
2+
FieldGrammar (..),
3+
uniqueField,
4+
optionalField,
5+
optionalFieldDef,
6+
optionalFieldDefAla,
7+
monoidalField,
8+
deprecatedField',
9+
) where
10+
11+
import Distribution.Compat.Lens
12+
import Distribution.Compat.Prelude
13+
import Prelude ()
14+
15+
import Data.Functor.Identity (Identity (..))
16+
17+
import Distribution.Compat.Newtype (Newtype)
18+
import Distribution.Parsec.Class (Parsec)
19+
import Distribution.Parsec.Types.Field
20+
import Distribution.Pretty (Pretty)
21+
22+
-- | 'FieldGrammar' is parametrised by
23+
--
24+
-- * @s@ which is a structure we are parsing. We need this to provide prettyprinter
25+
-- functionality
26+
--
27+
-- * @a@ type of the field.
28+
--
29+
-- /Note:/ We'd like to have @forall s. Applicative (f s)@ context.
30+
--
31+
class FieldGrammar g where
32+
-- | Unfocus, zoom out, /blur/ 'FieldGrammar'.
33+
blurFieldGrammar :: ALens' a b -> g b c -> g a c
34+
35+
-- | Field which should be defined, exactly once.
36+
uniqueFieldAla
37+
:: (Parsec b, Pretty b, Newtype b a)
38+
=> FieldName -- ^ field name
39+
-> (a -> b) -- ^ 'Newtype' pack
40+
-> ALens' s a -- ^ lens into the field
41+
-> g s a
42+
43+
-- | Boolean field with a default value.
44+
booleanFieldDef
45+
:: FieldName -- ^ field name
46+
-> ALens' s Bool -- ^ lens into the field
47+
-> Bool -- ^ default
48+
-> g s Bool
49+
50+
-- | Optional field.
51+
optionalFieldAla
52+
:: (Parsec b, Pretty b, Newtype b a)
53+
=> FieldName -- ^ field name
54+
-> (a -> b) -- ^ 'pack'
55+
-> ALens' s (Maybe a) -- ^ lens into the field
56+
-> g s (Maybe a)
57+
58+
-- | Monoidal field.
59+
--
60+
-- Values are combined with 'mappend'.
61+
--
62+
-- /Note:/ 'optionalFieldAla' is a @monoidalField@ with 'Last' monoid.
63+
--
64+
monoidalFieldAla
65+
:: (Parsec b, Pretty b, Monoid a, Newtype b a)
66+
=> FieldName -- ^ field name
67+
-> (a -> b) -- ^ 'pack'
68+
-> ALens' s a -- ^ lens into the field
69+
-> g s a
70+
71+
-- | Parser matching all fields with a name starting with a prefix.
72+
prefixedFields
73+
:: FieldName -- ^ field name prefix
74+
-> ALens' s [(String, String)] -- ^ lens into the field
75+
-> g s [(String, String)]
76+
77+
-- | Known field, which we don't parse, neither pretty print.
78+
knownField :: FieldName -> g s ()
79+
80+
-- | Field which is parsed but not pretty printed.
81+
hiddenField :: g s a -> g s a
82+
83+
-- | Deprecated since
84+
deprecatedSince
85+
:: [Int] -- ^ version
86+
-> String -- ^ deprecation message
87+
-> g s a
88+
-> g s a
89+
90+
-- | Annotate field with since spec-version.
91+
availableSince
92+
:: [Int] -- ^ spec version
93+
-> g s a
94+
-> g s a
95+
96+
-- | Field which can be defined at most once.
97+
uniqueField
98+
:: (FieldGrammar g, Parsec a, Pretty a)
99+
=> FieldName -- ^ field name
100+
-> ALens' s a -- ^ lens into the field
101+
-> g s a
102+
uniqueField fn = uniqueFieldAla fn Identity
103+
104+
-- | Field which can be defined at most once.
105+
optionalField
106+
:: (FieldGrammar g, Parsec a, Pretty a)
107+
=> FieldName -- ^ field name
108+
-> ALens' s (Maybe a) -- ^ lens into the field
109+
-> g s (Maybe a)
110+
optionalField fn = optionalFieldAla fn Identity
111+
112+
-- | Optional field with default value.
113+
optionalFieldDef
114+
:: (FieldGrammar g, Functor (g s), Parsec a, Pretty a, Eq a, Show a)
115+
=> FieldName -- ^ field name
116+
-> LensLike' (Pretext (Maybe a) (Maybe a)) s a -- ^ @'Lens'' s a@: lens into the field
117+
-> a -- ^ default value
118+
-> g s a
119+
optionalFieldDef fn = optionalFieldDefAla fn Identity
120+
121+
-- | Optional field with default value.
122+
optionalFieldDefAla
123+
:: (FieldGrammar g, Functor (g s), Parsec b, Pretty b, Newtype b a, Eq a, Show a)
124+
=> FieldName -- ^ field name
125+
-> (a -> b) -- ^ 'Newtype' pack
126+
-> LensLike' (Pretext (Maybe a) (Maybe a)) s a -- ^ @'Lens'' s a@: lens into the field
127+
-> a -- ^ default value
128+
-> g s a
129+
optionalFieldDefAla fn pack l def =
130+
fromMaybe def <$> optionalFieldAla fn pack (l . fromNon def)
131+
132+
-- | Field which can be define multiple times, and the results are @mappend@ed.
133+
monoidalField
134+
:: (FieldGrammar g, Parsec a, Pretty a, Monoid a)
135+
=> FieldName -- ^ field name
136+
-> ALens' s a -- ^ lens into the field
137+
-> g s a
138+
monoidalField fn = monoidalFieldAla fn Identity
139+
140+
-- | Deprecated field. If found, warning is issued.
141+
--
142+
-- /Note:/ also it's not pretty printed!
143+
--
144+
deprecatedField'
145+
:: FieldGrammar g
146+
=> String -- ^ deprecation message
147+
-> g s a
148+
-> g s a
149+
deprecatedField' = deprecatedSince []

0 commit comments

Comments
 (0)