feat: implement comment parser

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/
@@ -58,6 +63,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:
     -- https://github.com/haskell/alex/issues/288
     alex:alex < 3.5.4.1 || > 3.5.4.1

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