Skip to content

Commit ef1a05a

Browse files
jgotohmpickering
authored andcommitted
Replace cabal project parsing with parsec implementation
The new parser replicates the grammar of the legacy parser while providing better error reporting and more maintainable code structure. The fallback strategy ensures smooth transition while the legacy parser is phased out. The flag `--project-file-parser` allows you to select which project file parser to use. * `legacy` - the old parser (will be removed in a future release) * `default` - the default parser (uses `fallback` unless compiled with `-f+legacy-comparison`) * `parsec` - the new parser using Parsec * `fallback` - the new parser using Parsec, but falling back to the old parser if it fails * `compare` - the new parser using Parsec, but comparing the results with the old parser When `cabal-install` is compiled, then the `-f+legacy-comparision` flag can be passed which changes the default parser mode to `compare`. Fixes #6101 #7748 #10611
1 parent 9a343d1 commit ef1a05a

File tree

88 files changed

+3826
-506
lines changed

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

88 files changed

+3826
-506
lines changed

Cabal-syntax/Cabal-syntax.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -107,6 +107,7 @@ library
107107
Distribution.Parsec.FieldLineStream
108108
Distribution.Parsec.Position
109109
Distribution.Parsec.Warning
110+
Distribution.Parsec.Source
110111
Distribution.Pretty
111112
Distribution.SPDX
112113
Distribution.SPDX.License

Cabal-syntax/src/Distribution/FieldGrammar.hs

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -15,6 +15,7 @@ module Distribution.FieldGrammar
1515
, ParsecFieldGrammar
1616
, ParsecFieldGrammar'
1717
, parseFieldGrammar
18+
, parseFieldGrammarCheckingStanzas
1819
, fieldGrammarKnownFieldList
1920
, PrettyFieldGrammar
2021
, PrettyFieldGrammar'
@@ -65,6 +66,20 @@ x ^^^ f = f x
6566
data PS ann = PS (Fields ann) [Section ann] [[Section ann]]
6667

6768
-- | Partition field list into field map and groups of sections.
69+
-- Groups sections between fields. This means that the following snippet contains
70+
-- two section groups:
71+
--
72+
-- @
73+
-- -- first group
74+
-- some-section
75+
-- field: value
76+
-- another-section
77+
-- field: value
78+
-- foo: bar
79+
-- -- second group
80+
-- yet-another-section
81+
-- field: value
82+
-- @
6883
partitionFields :: [Field ann] -> (Fields ann, [[Section ann]])
6984
partitionFields = finalize . foldl' f (PS mempty mempty mempty)
7085
where

Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs

Lines changed: 24 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
{-# LANGUAGE DeriveFunctor #-}
22
{-# LANGUAGE MultiParamTypeClasses #-}
33
{-# LANGUAGE OverloadedStrings #-}
4+
{-# LANGUAGE RankNTypes #-}
45
{-# LANGUAGE ScopedTypeVariables #-}
56

67
-- | This module provides a 'FieldGrammarParser', one way to parse
@@ -54,6 +55,7 @@
5455
module Distribution.FieldGrammar.Parsec
5556
( ParsecFieldGrammar
5657
, parseFieldGrammar
58+
, parseFieldGrammarCheckingStanzas
5759
, fieldGrammarKnownFieldList
5860

5961
-- * Auxiliary
@@ -112,24 +114,35 @@ data Section ann = MkSection !(Name ann) [SectionArg ann] [Field ann]
112114
data ParsecFieldGrammar s a = ParsecFG
113115
{ fieldGrammarKnownFields :: !(Set FieldName)
114116
, fieldGrammarKnownPrefixes :: !(Set FieldName)
115-
, fieldGrammarParser :: !(CabalSpecVersion -> Fields Position -> ParseResult a)
117+
, fieldGrammarParser :: forall src. (CabalSpecVersion -> Fields Position -> ParseResult src a)
116118
}
117119
deriving (Functor)
118120

119-
parseFieldGrammar :: CabalSpecVersion -> Fields Position -> ParsecFieldGrammar s a -> ParseResult a
121+
parseFieldGrammar :: CabalSpecVersion -> Fields Position -> ParsecFieldGrammar s a -> ParseResult src a
120122
parseFieldGrammar v fields grammar = do
121-
for_ (Map.toList (Map.filterWithKey isUnknownField fields)) $ \(name, nfields) ->
123+
for_ (Map.toList (Map.filterWithKey (isUnknownField grammar) fields)) $ \(name, nfields) ->
122124
for_ nfields $ \(MkNamelessField pos _) ->
123125
parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name
124126
-- TODO: fields allowed in this section
125127

126128
-- parse
127129
fieldGrammarParser grammar v fields
128-
where
129-
isUnknownField k _ =
130-
not $
131-
k `Set.member` fieldGrammarKnownFields grammar
132-
|| any (`BS.isPrefixOf` k) (fieldGrammarKnownPrefixes grammar)
130+
131+
isUnknownField :: ParsecFieldGrammar s a -> FieldName -> [NamelessField Position] -> Bool
132+
isUnknownField grammar k _ =
133+
not $
134+
k `Set.member` fieldGrammarKnownFields grammar
135+
|| any (`BS.isPrefixOf` k) (fieldGrammarKnownPrefixes grammar)
136+
137+
-- | Parse a ParsecFieldGrammar and check for fields that should be stanzas.
138+
parseFieldGrammarCheckingStanzas :: CabalSpecVersion -> Fields Position -> ParsecFieldGrammar s a -> Set BS.ByteString -> ParseResult src a
139+
parseFieldGrammarCheckingStanzas v fields grammar sections = do
140+
for_ (Map.toList (Map.filterWithKey (isUnknownField grammar) fields)) $ \(name, nfields) ->
141+
for_ nfields $ \(MkNamelessField pos _) ->
142+
if name `Set.member` sections
143+
then parseFailure pos $ "'" ++ fromUTF8BS name ++ "' is a stanza, not a field. Remove the trailing ':' to parse a stanza."
144+
else parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name
145+
fieldGrammarParser grammar v fields
133146

134147
fieldGrammarKnownFieldList :: ParsecFieldGrammar s a -> [FieldName]
135148
fieldGrammarKnownFieldList = Set.toList . fieldGrammarKnownFields
@@ -145,7 +158,7 @@ instance Applicative (ParsecFieldGrammar s) where
145158
(\v fields -> f'' v fields <*> x'' v fields)
146159
{-# INLINE (<*>) #-}
147160

148-
warnMultipleSingularFields :: FieldName -> [NamelessField Position] -> ParseResult ()
161+
warnMultipleSingularFields :: FieldName -> [NamelessField Position] -> ParseResult src ()
149162
warnMultipleSingularFields _ [] = pure ()
150163
warnMultipleSingularFields fn (x : xs) = do
151164
let pos = namelessFieldAnn x
@@ -349,7 +362,7 @@ instance FieldGrammar Parsec ParsecFieldGrammar where
349362
-- Parsec
350363
-------------------------------------------------------------------------------
351364

352-
runFieldParser' :: [Position] -> ParsecParser a -> CabalSpecVersion -> FieldLineStream -> ParseResult a
365+
runFieldParser' :: [Position] -> ParsecParser a -> CabalSpecVersion -> FieldLineStream -> ParseResult src a
353366
runFieldParser' inputPoss p v str = case P.runParser p' [] "<field>" str of
354367
Right (pok, ws) -> do
355368
traverse_ (\(PWarning t pos w) -> parseWarning (mapPosition pos) t w) ws
@@ -378,7 +391,7 @@ runFieldParser' inputPoss p v str = case P.runParser p' [] "<field>" str of
378391
go n (Position row col : _) | n <= 0 = Position row (col + pcol - 1)
379392
go n (_ : ps) = go (n - 1) ps
380393

381-
runFieldParser :: Position -> ParsecParser a -> CabalSpecVersion -> [FieldLine Position] -> ParseResult a
394+
runFieldParser :: Position -> ParsecParser a -> CabalSpecVersion -> [FieldLine Position] -> ParseResult src a
382395
runFieldParser pp p v ls = runFieldParser' poss p v (fieldLinesToStream ls)
383396
where
384397
poss = map (\(FieldLine pos _) -> pos) ls ++ [pp] -- add "default" position

Cabal-syntax/src/Distribution/Fields.hs

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -25,11 +25,16 @@ module Distribution.Fields
2525
-- ** Warnings
2626
, PWarnType (..)
2727
, PWarning (..)
28+
, PWarningWithSource (..)
29+
, PSource (..)
2830
, showPWarning
31+
, showPWarningWithSource
2932

3033
-- ** Errors
3134
, PError (..)
35+
, PErrorWithSource (..)
3236
, showPError
37+
, showPErrorWithSource
3338

3439
-- * Pretty printing
3540
, CommentPosition (..)

Cabal-syntax/src/Distribution/Fields/ConfVar.hs

Lines changed: 15 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -4,11 +4,12 @@ module Distribution.Fields.ConfVar (parseConditionConfVar, parseConditionConfVar
44

55
import Distribution.Compat.CharParsing (char, integral)
66
import Distribution.Compat.Prelude
7-
import Distribution.Fields.Field (Field (..), SectionArg (..))
7+
import Distribution.Fields.Field (Field (..), SectionArg (..), sectionArgAnn)
88
import Distribution.Fields.ParseResult
99
import Distribution.Fields.Parser (readFields)
10-
import Distribution.Parsec (Parsec (..), Position (..), runParsecParser)
10+
import Distribution.Parsec (Parsec (..), runParsecParser)
1111
import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS)
12+
import Distribution.Parsec.Position
1213
import Distribution.Types.Condition
1314
import Distribution.Types.ConfVar (ConfVar (..))
1415
import Distribution.Version
@@ -40,10 +41,10 @@ parseConditionConfVarFromClause x =
4041

4142
-- | Parse @'Condition' 'ConfVar'@ from section arguments provided by parsec
4243
-- based outline parser.
43-
parseConditionConfVar :: [SectionArg Position] -> ParseResult (Condition ConfVar)
44-
parseConditionConfVar args =
44+
parseConditionConfVar :: Position -> [SectionArg Position] -> ParseResult src (Condition ConfVar)
45+
parseConditionConfVar start_pos args =
4546
-- The name of the input file is irrelevant, as we reformat the error message.
46-
case P.runParser (parser <* P.eof) () "<condition>" args of
47+
case P.runParser (P.setPosition startPos >> parser <* P.eof) () "<condition>" args of
4748
Right x -> pure x
4849
Left err -> do
4950
-- Mangle the position to the actual one
@@ -59,7 +60,10 @@ parseConditionConfVar args =
5960
(P.errorMessages err)
6061
parseFailure epos msg
6162
pure $ Lit True
63+
where
64+
startPos = P.newPos "<condition>" (positionRow start_pos) (positionCol start_pos)
6265

66+
-- | Parser for 'Condition' 'ConfVar'
6367
type Parser = P.Parsec [SectionArg Position] ()
6468

6569
sepByNonEmpty :: Parser a -> Parser sep -> Parser (NonEmpty a)
@@ -132,6 +136,7 @@ parser = condOr
132136
| s == "false" -> Just False
133137
_ -> Nothing
134138

139+
string :: B8.ByteString -> Parser ()
135140
string s = tokenPrim $ \t -> case t of
136141
SecArgName _ s' | s == s' -> Just ()
137142
_ -> Nothing
@@ -142,9 +147,12 @@ parser = condOr
142147

143148
parens = P.between (oper "(") (oper ")")
144149

150+
tokenPrim :: (SectionArg Position -> Maybe a) -> Parser a
145151
tokenPrim = P.tokenPrim prettySectionArg updatePosition
146-
-- TODO: check where the errors are reported
147-
updatePosition x _ _ = x
152+
updatePosition :: P.SourcePos -> SectionArg Position -> [SectionArg Position] -> P.SourcePos
153+
updatePosition x s _ =
154+
let Position line col = sectionArgAnn s
155+
in P.setSourceLine (P.setSourceColumn x col) (line)
148156
prettySectionArg = show
149157

150158
fromParsec :: Parsec a => Parser a

0 commit comments

Comments
 (0)