Merge pull request haskell#8889 from jgotoh/parse-cabal-project-parsec

Replace cabal project parsing with Parsec

Author: mergify[bot]

Cabal-syntax/Cabal-syntax.cabal

@@ -107,6 +107,7 @@ library
     Distribution.Parsec.FieldLineStream
     Distribution.Parsec.Position
     Distribution.Parsec.Warning
+    Distribution.Parsec.Source
     Distribution.Pretty
     Distribution.SPDX
     Distribution.SPDX.License

Cabal-syntax/src/Distribution/FieldGrammar.hs

@@ -15,6 +15,7 @@ module Distribution.FieldGrammar
   , ParsecFieldGrammar
   , ParsecFieldGrammar'
   , parseFieldGrammar
+  , parseFieldGrammarCheckingStanzas
   , fieldGrammarKnownFieldList
   , PrettyFieldGrammar
   , PrettyFieldGrammar'
@@ -65,6 +66,20 @@ x ^^^ f = f x
 data PS ann = PS (Fields ann) [Section ann] [[Section ann]]
 
 -- | Partition field list into field map and groups of sections.
+-- Groups sections between fields. This means that the following snippet contains
+-- two section groups:
+--
+-- @
+-- -- first group
+-- some-section
+--     field: value
+-- another-section
+--     field: value
+-- foo: bar
+-- -- second group
+-- yet-another-section
+--     field: value
+-- @
 partitionFields :: [Field ann] -> (Fields ann, [[Section ann]])
 partitionFields = finalize . foldl' f (PS mempty mempty mempty)
   where

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

@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 -- | This module provides a 'FieldGrammarParser', one way to parse
@@ -54,6 +55,7 @@
 module Distribution.FieldGrammar.Parsec
   ( ParsecFieldGrammar
   , parseFieldGrammar
+  , parseFieldGrammarCheckingStanzas
   , fieldGrammarKnownFieldList
 
     -- * Auxiliary
@@ -112,24 +114,35 @@ data Section ann = MkSection !(Name ann) [SectionArg ann] [Field ann]
 data ParsecFieldGrammar s a = ParsecFG
   { fieldGrammarKnownFields :: !(Set FieldName)
   , fieldGrammarKnownPrefixes :: !(Set FieldName)
-  , fieldGrammarParser :: !(CabalSpecVersion -> Fields Position -> ParseResult a)
+  , fieldGrammarParser :: forall src. (CabalSpecVersion -> Fields Position -> ParseResult src a)
   }
   deriving (Functor)
 
-parseFieldGrammar :: CabalSpecVersion -> Fields Position -> ParsecFieldGrammar s a -> ParseResult a
+parseFieldGrammar :: CabalSpecVersion -> Fields Position -> ParsecFieldGrammar s a -> ParseResult src a
 parseFieldGrammar v fields grammar = do
-  for_ (Map.toList (Map.filterWithKey isUnknownField fields)) $ \(name, nfields) ->
+  for_ (Map.toList (Map.filterWithKey (isUnknownField grammar) fields)) $ \(name, nfields) ->
     for_ nfields $ \(MkNamelessField pos _) ->
       parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name
   -- TODO: fields allowed in this section
 
   -- parse
   fieldGrammarParser grammar v fields
-  where
-    isUnknownField k _ =
-      not $
-        k `Set.member` fieldGrammarKnownFields grammar
-          || any (`BS.isPrefixOf` k) (fieldGrammarKnownPrefixes grammar)
+
+isUnknownField :: ParsecFieldGrammar s a -> FieldName -> [NamelessField Position] -> Bool
+isUnknownField grammar k _ =
+  not $
+    k `Set.member` fieldGrammarKnownFields grammar
+      || any (`BS.isPrefixOf` k) (fieldGrammarKnownPrefixes grammar)
+
+-- | Parse a ParsecFieldGrammar and check for fields that should be stanzas.
+parseFieldGrammarCheckingStanzas :: CabalSpecVersion -> Fields Position -> ParsecFieldGrammar s a -> Set BS.ByteString -> ParseResult src a
+parseFieldGrammarCheckingStanzas v fields grammar sections = do
+  for_ (Map.toList (Map.filterWithKey (isUnknownField grammar) fields)) $ \(name, nfields) ->
+    for_ nfields $ \(MkNamelessField pos _) ->
+      if name `Set.member` sections
+        then parseFailure pos $ "'" ++ fromUTF8BS name ++ "' is a stanza, not a field. Remove the trailing ':' to parse a stanza."
+        else parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name
+  fieldGrammarParser grammar v fields
 
 fieldGrammarKnownFieldList :: ParsecFieldGrammar s a -> [FieldName]
 fieldGrammarKnownFieldList = Set.toList . fieldGrammarKnownFields
@@ -145,7 +158,7 @@ instance Applicative (ParsecFieldGrammar s) where
       (\v fields -> f'' v fields <*> x'' v fields)
   {-# INLINE (<*>) #-}
 
-warnMultipleSingularFields :: FieldName -> [NamelessField Position] -> ParseResult ()
+warnMultipleSingularFields :: FieldName -> [NamelessField Position] -> ParseResult src ()
 warnMultipleSingularFields _ [] = pure ()
 warnMultipleSingularFields fn (x : xs) = do
   let pos = namelessFieldAnn x
@@ -349,7 +362,7 @@ instance FieldGrammar Parsec ParsecFieldGrammar where
 -- Parsec
 -------------------------------------------------------------------------------
 
-runFieldParser' :: [Position] -> ParsecParser a -> CabalSpecVersion -> FieldLineStream -> ParseResult a
+runFieldParser' :: [Position] -> ParsecParser a -> CabalSpecVersion -> FieldLineStream -> ParseResult src a
 runFieldParser' inputPoss p v str = case P.runParser p' [] "<field>" str of
   Right (pok, ws) -> do
     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
         go n (Position row col : _) | n <= 0 = Position row (col + pcol - 1)
         go n (_ : ps) = go (n - 1) ps
 
-runFieldParser :: Position -> ParsecParser a -> CabalSpecVersion -> [FieldLine Position] -> ParseResult a
+runFieldParser :: Position -> ParsecParser a -> CabalSpecVersion -> [FieldLine Position] -> ParseResult src a
 runFieldParser pp p v ls = runFieldParser' poss p v (fieldLinesToStream ls)
   where
     poss = map (\(FieldLine pos _) -> pos) ls ++ [pp] -- add "default" position

Cabal-syntax/src/Distribution/Fields.hs

@@ -25,11 +25,16 @@ module Distribution.Fields
     -- ** Warnings
   , PWarnType (..)
   , PWarning (..)
+  , PWarningWithSource (..)
+  , PSource (..)
   , showPWarning
+  , showPWarningWithSource
 
     -- ** Errors
   , PError (..)
+  , PErrorWithSource (..)
   , showPError
+  , showPErrorWithSource
 
     -- * Pretty printing
   , CommentPosition (..)

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

@@ -4,11 +4,12 @@ module Distribution.Fields.ConfVar (parseConditionConfVar, parseConditionConfVar
 
 import Distribution.Compat.CharParsing (char, integral)
 import Distribution.Compat.Prelude
-import Distribution.Fields.Field (Field (..), SectionArg (..))
+import Distribution.Fields.Field (Field (..), SectionArg (..), sectionArgAnn)
 import Distribution.Fields.ParseResult
 import Distribution.Fields.Parser (readFields)
-import Distribution.Parsec (Parsec (..), Position (..), runParsecParser)
+import Distribution.Parsec (Parsec (..), runParsecParser)
 import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS)
+import Distribution.Parsec.Position
 import Distribution.Types.Condition
 import Distribution.Types.ConfVar (ConfVar (..))
 import Distribution.Version
@@ -40,10 +41,10 @@ parseConditionConfVarFromClause x =
 
 -- | Parse @'Condition' 'ConfVar'@ from section arguments provided by parsec
 -- based outline parser.
-parseConditionConfVar :: [SectionArg Position] -> ParseResult (Condition ConfVar)
-parseConditionConfVar args =
+parseConditionConfVar :: Position -> [SectionArg Position] -> ParseResult src (Condition ConfVar)
+parseConditionConfVar start_pos args =
   -- The name of the input file is irrelevant, as we reformat the error message.
-  case P.runParser (parser <* P.eof) () "<condition>" args of
+  case P.runParser (P.setPosition startPos >> parser <* P.eof) () "<condition>" args of
     Right x -> pure x
     Left err -> do
       -- Mangle the position to the actual one
@@ -59,7 +60,10 @@ parseConditionConfVar args =
               (P.errorMessages err)
       parseFailure epos msg
       pure $ Lit True
+  where
+    startPos = P.newPos "<condition>" (positionRow start_pos) (positionCol start_pos)
 
+-- | Parser for 'Condition' 'ConfVar'
 type Parser = P.Parsec [SectionArg Position] ()
 
 sepByNonEmpty :: Parser a -> Parser sep -> Parser (NonEmpty a)
@@ -132,6 +136,7 @@ parser = condOr
         | s == "false" -> Just False
       _ -> Nothing
 
+    string :: B8.ByteString -> Parser ()
     string s = tokenPrim $ \t -> case t of
       SecArgName _ s' | s == s' -> Just ()
       _ -> Nothing
@@ -142,9 +147,12 @@ parser = condOr
 
     parens = P.between (oper "(") (oper ")")
 
+    tokenPrim :: (SectionArg Position -> Maybe a) -> Parser a
     tokenPrim = P.tokenPrim prettySectionArg updatePosition
-    -- TODO: check where the errors are reported
-    updatePosition x _ _ = x
+    updatePosition :: P.SourcePos -> SectionArg Position -> [SectionArg Position] -> P.SourcePos
+    updatePosition x s _ =
+      let Position line col = sectionArgAnn s
+       in P.setSourceLine (P.setSourceColumn x col) (line)
     prettySectionArg = show
 
     fromParsec :: Parsec a => Parser a