feat: implement comment parser

add lexer tokens and rules

remove lexer "Whitespace" token

This token is not needed, we will later use the position information to
pad each token.

implement "Comment" handling

... which is not handling at all for the time being

temporary fix by dropping comments before parseGenericPackageDescription

make metaFields a map of positions

rearrange and simplify field

make lexer emit comment wherever they would occur

stop parser from emitting indentation warning for comments

fix: restore checkIndentation behaviour for Field

test: add dummy tests

test: accept new golden expressions

test: accept new golden expressions

test: rename comment test group

debug: trace tokens

fix: split comments recursively

fix: consume comments after colon in FieldLayoutOrBraces

debug: remove tracing

test: update expected

test: improve comment tests

test: correct comment tests

test: assert interleaving comment parsing

fix: correct interleaving comment parsing

test: update expected

debug: remove tracing

test: assert parsing of fieldline flag

test: update expected

fix: correct parsing fieldLine starting with -- as comment

test: update expected

test: remove test case that doesn't pass on upstream

minor fixes

test: ignore comment in test comparison

docs: improve comments on the grammar

style: whitespace

style: fourmolu

ref: simplification

docs: update grammar specification for comments

ref: run hlint

improve describeToken on comments

ref: make diff smaller

test: fix no-thunks test

test: fix md5Check test

fix compiler errors and warnings

test: add expectation for failing hackage test

We also reintroduced the flag "CABAL_PARSEC_DEBUG" to debug the
lexer/parser.

fix hackage test 001

fix hackage test

test: disable comments in comparison in roundtrip hackage test

refactor parser

refactor test

style: run fourmolu

remove todos

yay

test: remove test dependencies

move ToExpr to orphan module

test: simplify

restore accidently formatted cabal

restore previous debug behaviour

refactor: don't use liftA2 and liftA3

refactor annotation to ([Comment ann], ann)

attempt

test: update expects

fix errors for Deprecated module

fix compilation errors for integration tests

fix grammar while incorrect output

We need to look into how to wire the output for it to hold the comments
in the right position.

refactor parser

style: run fourmolu

fix comment attach post processing

refactor

fix: only discard element comments at top level

test: update expected

fix: derive Eq instance for Comment

This fixes builds for old GHC

use strict either for parser

fix: doctest

define proper WithComments data type

remove exactComment field in GenericPackageDescription

add Lens functions for AnnotatedGenericPackageDescription

test AnnotatedGenericPackageDescription instead

run fourmolu

run hlint

remove redundant imports

tests: test hasktorch

tests: update expected

tests: fix integration tests

tests: fix nothunks test

run fourmolu

fix doctests

ref: keep backward compatibility of exported functions

test: explicitly test *WithComment readFields variant

test: fix doctest

fix: build

undo changes from experiments

ref: clean up the parser code

ref: reduce diff

Author: leana8959

Cabal-syntax/Cabal-syntax.cabal

@@ -18,6 +18,11 @@ build-type:     Simple
 extra-doc-files:
   README.md ChangeLog.md
 
+flag CABAL_PARSEC_DEBUG
+  description: Enable debug build for the cabal field lexer/parser.
+  default:     False
+  manual:      True
+
 source-repository head
   type:     git
   location: https://github.com/haskell/cabal/
@@ -59,6 +64,11 @@ library
   if impl(ghc >= 8.0) && impl(ghc < 8.8)
     ghc-options: -Wnoncanonical-monadfail-instances
 
+  if flag(CABAL_PARSEC_DEBUG)
+    CPP-Options: -DCABAL_PARSEC_DEBUG
+    build-depends:
+      vector
+
   build-tool-depends: alex:alex
 
   exposed-modules:
@@ -148,6 +158,8 @@ library
     Distribution.Types.ForeignLibOption
     Distribution.Types.ForeignLibType
     Distribution.Types.GenericPackageDescription
+    Distribution.Types.AnnotatedGenericPackageDescription
+    Distribution.Types.AnnotatedGenericPackageDescription.Lens
     Distribution.Types.GenericPackageDescription.Lens
     Distribution.Types.HookedBuildInfo
     Distribution.Types.IncludeRenaming

Cabal-syntax/src/Distribution/FieldGrammar.hs

@@ -26,6 +26,7 @@ module Distribution.FieldGrammar
   , Section (..)
   , Fields
   , partitionFields
+  , extractComments
   , takeFields
   , runFieldParser
   , runFieldParser'
@@ -38,6 +39,7 @@ module Distribution.FieldGrammar
 import Distribution.Compat.Prelude
 import Prelude ()
 
+import qualified Data.Bifunctor as Bi
 import qualified Data.Map.Strict as Map
 
 import Distribution.FieldGrammar.Class
@@ -99,10 +101,17 @@ partitionFields = finalize . foldl' f (PS mempty mempty mempty)
       PS fs (MkSection name sargs sfields : s) ss
 
 -- | Take all fields from the front.
+-- Returns a tuple containing the comments, nameless fields, and sections
 takeFields :: [Field ann] -> (Fields ann, [Field ann])
 takeFields = finalize . spanMaybe match
   where
     finalize (fs, rest) = (Map.fromListWith (flip (++)) fs, rest)
 
     match (Field (Name ann name) fs) = Just (name, [MkNamelessField ann fs])
     match _ = Nothing
+
+extractComments :: (Foldable f, Functor f) => [f (WithComments ann)] -> ([Comment ann], [f ann])
+extractComments = Bi.first mconcat . unzip . map extractCommentsStep
+
+extractCommentsStep :: (Foldable f, Functor f) => f (WithComments ann) -> ([Comment ann], f ann)
+extractCommentsStep f = (foldMap justComments f, fmap unComments f)

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

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE StandaloneDeriving #-}
 
@@ -17,6 +18,12 @@ module Distribution.Fields.Field
   , SectionArg (..)
   , sectionArgAnn
 
+    -- * Comment
+  , Comment (..)
+  , WithComments (..)
+  , mapComments
+  , mapCommentedData
+
     -- * Name
   , FieldName
   , Name (..)
@@ -44,11 +51,26 @@ import qualified Data.Foldable1 as F1
 -- Cabal file
 -------------------------------------------------------------------------------
 
+data Comment ann = Comment !ByteString !ann
+  deriving (Show, Generic, Eq, Ord, Functor)
+
+data WithComments ann = WithComments
+  { justComments :: ![Comment ann]
+  , unComments :: !ann
+  }
+  deriving (Show, Generic, Eq, Ord, Functor)
+
+mapComments :: ([Comment ann] -> [Comment ann]) -> WithComments ann -> WithComments ann
+mapComments f (WithComments cs x) = WithComments (f cs) x
+
+mapCommentedData :: (ann -> ann) -> WithComments ann -> WithComments ann
+mapCommentedData f (WithComments cs x) = WithComments cs (f x)
+
 -- | A Cabal-like file consists of a series of fields (@foo: bar@) and sections (@library ...@).
 data Field ann
   = Field !(Name ann) [FieldLine ann]
   | Section !(Name ann) [SectionArg ann] [Field ann]
-  deriving (Eq, Show, Functor, Foldable, Traversable)
+  deriving (Eq, Show, Functor, Foldable, Traversable, Generic)
 
 -- | @since 3.12.0.0
 deriving instance Ord ann => Ord (Field ann)
@@ -73,7 +95,7 @@ fieldUniverse f@(Field _ _) = [f]
 --
 -- /Invariant:/ 'ByteString' has no newlines.
 data FieldLine ann = FieldLine !ann !ByteString
-  deriving (Eq, Show, Functor, Foldable, Traversable)
+  deriving (Eq, Show, Functor, Foldable, Traversable, Generic)
 
 -- | @since 3.12.0.0
 deriving instance Ord ann => Ord (FieldLine ann)
@@ -94,7 +116,7 @@ data SectionArg ann
     SecArgStr !ann !ByteString
   | -- | everything else, mm. operators (e.g. in if-section conditionals)
     SecArgOther !ann !ByteString
-  deriving (Eq, Show, Functor, Foldable, Traversable)
+  deriving (Eq, Show, Functor, Foldable, Traversable, Generic)
 
 -- | @since 3.12.0.0
 deriving instance Ord ann => Ord (SectionArg ann)
@@ -115,7 +137,7 @@ type FieldName = ByteString
 --
 -- /Invariant/: 'ByteString' is lower-case ASCII.
 data Name ann = Name !ann !FieldName
-  deriving (Eq, Show, Functor, Foldable, Traversable)
+  deriving (Eq, Show, Functor, Foldable, Traversable, Generic)
 
 -- | @since 3.12.0.0
 deriving instance Ord ann => Ord (Name ann)

Cabal-syntax/src/Distribution/Fields/Lexer.x

@@ -31,7 +31,6 @@ import qualified Data.ByteString.Char8 as B.Char8
 import qualified Data.Word as Word
 
 #ifdef CABAL_PARSEC_DEBUG
-import Debug.Trace
 import qualified Data.Vector as V
 import qualified Data.Text   as T
 import qualified Data.Text.Encoding as T
@@ -84,8 +83,9 @@ tokens :-
 <bol_section, bol_field_layout, bol_field_braces> {
   @nbspspacetab* @nl         { \pos len inp -> checkWhitespace pos len inp >> adjustPos retPos >> lexToken }
   -- no @nl here to allow for comments on last line of the file with no trailing \n
-  $spacetab* "--" $comment*  ;  -- TODO: check the lack of @nl works here
-                                -- including counting line numbers
+  $spacetab* "--" $comment*  { toki TokComment }
+  -- TODO: check the lack of @nl works here
+  -- including counting line numbers
 }
 
 <bol_section> {
@@ -105,9 +105,8 @@ tokens :-
 }
 
 <in_section> {
-  $spacetab+   ; --TODO: don't allow tab as leading space
-
-  "--" $comment* ;
+  $spacetab+     ; --TODO: don't allow tab as leading space
+  "--" $comment* { toki TokComment }
 
   @name        { toki TokSym }
   @string      { \pos len inp -> return $! L pos (TokStr (B.take (len - 2) (B.tail inp))) }
@@ -161,6 +160,7 @@ data Token = TokSym   !ByteString       -- ^ Haskell-like identifier, number or
            | Colon
            | OpenBrace
            | CloseBrace
+           | TokComment !ByteString
            | EOF
            | LexicalError InputStream --TODO: add separate string lexical error
   deriving Show
@@ -230,7 +230,9 @@ lexToken = do
         setInput inp'
         let !len_bytes = B.length inp - B.length inp'
         t <- action pos len_bytes inp
-        --traceShow t $ return tok
+#ifdef CABAL_PARSEC_DEBUG
+        traceShow t $ return tok
+#endif
         return t
 
 
@@ -241,10 +243,12 @@ checkPosition pos@(Position lineno colno) inp inp' len_chars = do
     let len_bytes = B.length inp - B.length inp'
         pos_txt   | lineno-1 < V.length text_lines = T.take len_chars (T.drop (colno-1) (text_lines V.! (lineno-1)))
                   | otherwise = T.empty
-        real_txt  = B.take len_bytes inp
+        real_txt :: B.ByteString
+        real_txt = B.take len_bytes inp
     when (pos_txt /= T.decodeUtf8 real_txt) $
       traceShow (pos, pos_txt, T.decodeUtf8 real_txt) $
-      traceShow (take 3 (V.toList text_lines)) $ return ()
+      traceShow (take 3 (V.toList text_lines)) $
+      return ()
   where
     getDbgText = Lex $ \s@LexState{ dbgText = txt } -> LexResult s txt
 #else