cabal exact-printer

Cabal/src/Distribution/FieldGrammar.hs

@@ -75,6 +75,7 @@ partitionFields = finalize . foldl' f (PS mempty mempty mempty)
       where
         ss' | null s    = ss
             | otherwise = reverse s : ss
+    f a (Comment _ _) = a
     f (PS fs s ss) (Section name sargs sfields) =
         PS fs (MkSection name sargs sfields : s) ss
 

Cabal/src/Distribution/FieldGrammar/Parsec.hs

@@ -374,10 +374,15 @@ runFieldParser' inputPoss p v str = case P.runParser p' [] "<field>" str of
 runFieldParser :: Position -> ParsecParser a -> CabalSpecVersion -> [FieldLine Position] -> ParseResult a
 runFieldParser pp p v ls = runFieldParser' poss p v (fieldLinesToStream ls)
   where
-    poss = map (\(FieldLine pos _) -> pos) ls ++ [pp] -- add "default" position
+    poss = map (\fl -> case fl of
+        FieldLine pos _ -> pos
+        CommentLineInField pos _ -> pos) ls ++ [pp] -- add "default" position
 
 fieldlinesToBS :: [FieldLine ann] -> BS.ByteString
-fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs)
+fieldlinesToBS = BS.intercalate "\n" .
+    map (\fl -> case fl of
+        FieldLine _ bs -> bs
+        CommentLineInField _ _ -> "")
 
 -- Example package with dot lines
 -- http://hackage.haskell.org/package/copilot-cbmc-0.1/copilot-cbmc.cabal

Cabal/src/Distribution/Fields/Field.hs

@@ -13,6 +13,8 @@ module Distribution.Fields.Field (
     FieldLine (..),
     fieldLineAnn,
     fieldLineBS,
+    CommentLine (..),
+    commentLineAnn,
     SectionArg (..),
     sectionArgAnn,
     -- * Name
@@ -42,12 +44,14 @@ import           Prelude ()
 -- | A Cabal-like file consists of a series of fields (@foo: bar@) and sections (@library ...@).
 data Field ann
     = Field   !(Name ann) [FieldLine ann]
+    | Comment !ann !(CommentLine ann)
     | Section !(Name ann) [SectionArg ann] [Field ann]
   deriving (Eq, Show, Functor, Foldable, Traversable)
 
 -- | Section of field name
 fieldName :: Field ann -> Name ann
 fieldName (Field n _ )    = n
+fieldName (Comment ann _) = Name ann (fromString "comment")
 fieldName (Section n _ _) = n
 
 fieldAnn :: Field ann -> ann
@@ -59,22 +63,32 @@ fieldAnn = nameAnn . fieldName
 --
 fieldUniverse :: Field ann -> [Field ann]
 fieldUniverse f@(Section _ _ fs) = f : concatMap fieldUniverse fs
+fieldUniverse (Comment _ _)      = []
 fieldUniverse f@(Field _ _)      = [f]
 
 -- | A line of text representing the value of a field from a Cabal file.
 -- A field may contain multiple lines.
 --
 -- /Invariant:/ 'ByteString' has no newlines.
 data FieldLine ann  = FieldLine  !ann !ByteString
+                    | CommentLineInField !ann !(CommentLine ann)
   deriving (Eq, Show, Functor, Foldable, Traversable)
 
 -- | @since 3.0.0.0
 fieldLineAnn :: FieldLine ann -> ann
 fieldLineAnn (FieldLine ann _) = ann
+fieldLineAnn (CommentLineInField ann _) = ann
 
 -- | @since 3.0.0.0
 fieldLineBS :: FieldLine ann -> ByteString
 fieldLineBS (FieldLine _ bs) = bs
+fieldLineBS (CommentLineInField _ (CommentLine _ bs)) = bs
+
+data CommentLine ann  = CommentLine !ann !ByteString
+  deriving (Eq, Show, Functor, Foldable, Traversable)
+
+commentLineAnn :: CommentLine ann -> ann
+commentLineAnn (CommentLine ann _) = ann
 
 -- | Section arguments, e.g. name of the library
 data SectionArg ann
@@ -139,3 +153,4 @@ fieldLinesToString =
     intercalate "\n" . map toStr
   where
     toStr (FieldLine _ bs) = fromUTF8BS bs
+    toStr (CommentLineInField _ (CommentLine _ bs)) = fromUTF8BS bs

Cabal/src/Distribution/Fields/Parser.hs

@@ -14,6 +14,7 @@ module Distribution.Fields.Parser (
     Field(..),
     Name(..),
     FieldLine(..),
+    CommentLine(..),
     SectionArg(..),
     -- * Grammar and parsing
     -- $grammar
@@ -88,6 +89,7 @@ describeToken :: Token -> String
 describeToken t = case t of
   TokSym   s      -> "symbol "   ++ show s
   TokStr   s      -> "string "   ++ show s
+  TokComment s    -> "comment "   ++ show s
   TokOther s      -> "operator " ++ show s
   Indent _        -> "new line"
   TokFieldLine _  -> "field content"
@@ -103,6 +105,8 @@ tokSym', tokStr, tokOther :: Parser (SectionArg Position)
 tokIndent :: Parser Int
 tokColon, tokOpenBrace, tokCloseBrace :: Parser ()
 tokFieldLine :: Parser (FieldLine Position)
+tokFieldLineComment :: Parser (FieldLine Position)
+tokComment :: Parser (CommentLine Position)
 
 tokSym        = getTokenWithPos $ \t -> case t of L pos (TokSym   x) -> Just (mkName pos x);  _ -> Nothing
 tokSym'       = getTokenWithPos $ \t -> case t of L pos (TokSym   x) -> Just (SecArgName pos x);  _ -> Nothing
@@ -113,6 +117,8 @@ tokColon      = getToken $ \t -> case t of Colon      -> Just (); _ -> Nothing
 tokOpenBrace  = getToken $ \t -> case t of OpenBrace  -> Just (); _ -> Nothing
 tokCloseBrace = getToken $ \t -> case t of CloseBrace -> Just (); _ -> Nothing
 tokFieldLine  = getTokenWithPos $ \t -> case t of L pos (TokFieldLine s) -> Just (FieldLine pos s); _ -> Nothing
+tokFieldLineComment = getTokenWithPos $ \t -> case t of L pos (TokComment s) -> Just (CommentLineInField pos (CommentLine pos s)); _ -> Nothing
+tokComment    = getTokenWithPos $ \t -> case t of L pos (TokComment s) -> Just (CommentLine pos s); _ -> Nothing
 
 colon, openBrace, closeBrace :: Parser ()
 
@@ -129,6 +135,12 @@ closeBrace   = tokCloseBrace <?> "\"}\""
 fieldContent :: Parser (FieldLine Position)
 fieldContent = tokFieldLine <?> "field contents"
 
+fieldCommentLine :: Parser (FieldLine Position)
+fieldCommentLine = tokFieldLineComment <?> "comment in a field line"
+
+commentLine :: Parser (CommentLine Position)
+commentLine = tokComment <?> "comment"
+
 newtype IndentLevel = IndentLevel Int
 
 zeroIndentLevel :: IndentLevel
@@ -226,7 +238,10 @@ elements ilevel = many (element ilevel)
 --           |      name elementInNonLayoutContext
 element :: IndentLevel -> Parser (Field Position)
 element ilevel =
-      (do ilevel' <- indentOfAtLeast ilevel
+      (do comment <- commentLine
+          return $ Comment (commentLineAnn comment) comment
+      )
+  <|> (do ilevel' <- indentOfAtLeast ilevel
           name    <- fieldSecName
           elementInLayoutContext (incIndentLevel ilevel') name)
   <|> (do name    <- fieldSecName
@@ -275,7 +290,9 @@ fieldLayoutOrBraces ilevel name = braces <|> fieldLayout
           return (Field name ls)
     fieldLayout = inLexerMode (LexerMode in_field_layout) $ do
           l  <- optionMaybe fieldContent
-          ls <- many (do _ <- indentOfAtLeast ilevel; fieldContent)
+          ls <- many $
+                (do _ <- indentOfAtLeast ilevel; fieldContent)
+            <|> (do fieldCommentLine)
           return $ case l of
               Nothing -> Field name ls
               Just l' -> Field name (l' : ls)

Cabal/src/Distribution/Fields/Pretty.hs

@@ -19,9 +19,15 @@ module Distribution.Fields.Pretty (
     genericFromParsecFields,
     prettyFieldLines,
     prettySectionArgs,
+    exactShow
     ) where
 
+import Control.Monad (mapM_)
+import Control.Monad.State.Strict (State)
+import qualified Control.Monad.State.Strict as State
+
 import Distribution.Compat.Prelude
+import Distribution.Parsec.Position (Position (..))
 import Distribution.Pretty         (showToken)
 import Prelude ()
 
@@ -155,6 +161,7 @@ genericFromParsecFields f g = goMany where
     goMany = traverse go
 
     go (P.Field (P.Name ann name) fls)          = PrettyField ann name <$> f name fls
+    go (P.Comment _ (P.CommentLine _ _))        = pure PrettyEmpty
     go (P.Section (P.Name ann name) secargs fs) = PrettySection ann name <$> g name secargs <*> goMany fs
 
 -- | Used in 'fromParsecFields'.
@@ -179,3 +186,101 @@ fromParsecFields = runIdentity . genericFromParsecFields
   where
     (.:) :: (a -> b) -> (c -> d -> a) -> (c -> d -> b)
     (f .: g) x y = f (g x y)
+
+------------------------------------------------------------------------------
+-- Exact print ---------------------------------------------------------------
+------------------------------------------------------------------------------
+
+data ExactPrint = ExactPrint
+  { currentPosition :: Position,
+    doc :: [String]
+  }
+  deriving (Eq, Show)
+
+type ExactPrinter a = State ExactPrint a
+
+initialExactPrint :: ExactPrint
+initialExactPrint = ExactPrint (Position 1 1) []
+
+exactShow :: [P.Field Position] -> String
+exactShow fields =
+  let r = State.execState (mapM_ exactShowField fields) initialExactPrint
+   in foldr (++) "" (reverse $ doc r)
+
+reachPos :: Position -> ExactPrinter ()
+reachPos (Position row col) = do
+  reachRow row
+  reachCol col
+
+reachCol :: Int -> ExactPrinter ()
+reachCol n = do
+  ExactPrint {currentPosition = Position row col, doc = _doc} <- State.get
+  if col == n
+    then return ()
+    else
+      State.put $
+        ExactPrint
+          { currentPosition = Position row n,
+            doc = replicate (n - col) ' ' : _doc
+          }
+
+reachRow :: Int -> ExactPrinter ()
+reachRow n = do
+  ExactPrint {currentPosition = Position row _, doc = _doc} <- State.get
+  if row == n
+    then return ()
+    else
+      State.put $
+        ExactPrint
+          { currentPosition = Position n 1,
+            doc = replicate (n - row) '\n' : _doc
+          }
+
+write :: String -> ExactPrinter ()
+write s = do
+  ExactPrint {currentPosition = Position row col, doc = _doc} <- State.get
+  State.put $
+    ExactPrint
+      { currentPosition =
+          Position row (col + length s),
+        doc = s : _doc
+      }
+
+exactShowField :: P.Field Position -> ExactPrinter ()
+exactShowField (P.Field (P.Name p bs) fields) = do
+  reachPos p
+  write (fromUTF8BS bs)
+  write ":"
+  mapM_ exactShowFieldLine fields
+exactShowField (P.Comment p comment) = do
+  reachPos p
+  exactShowComment comment
+exactShowField (P.Section (P.Name p bs) sections fields) = do
+  reachPos p
+  write (fromUTF8BS bs)
+  mapM_ exactShowSection sections
+  mapM_ exactShowField fields
+
+exactShowFieldLine :: P.FieldLine Position -> ExactPrinter ()
+exactShowFieldLine (P.FieldLine p bs) = do
+  reachPos p
+  write (fromUTF8BS bs)
+exactShowFieldLine (P.CommentLineInField p comment) = do
+  reachPos p
+  exactShowComment comment
+
+exactShowComment :: P.CommentLine Position -> ExactPrinter ()
+exactShowComment (P.CommentLine p bs) = do
+  reachPos p
+  write (fromUTF8BS bs)
+
+exactShowSection :: P.SectionArg Position -> ExactPrinter ()
+exactShowSection (P.SecArgName p bs) = do
+  reachPos p
+  write (fromUTF8BS bs)
+exactShowSection (P.SecArgStr p bs) = do
+  reachPos p
+  write (fromUTF8BS bs)
+exactShowSection (P.SecArgOther p bs) = do
+  reachPos p
+  write (fromUTF8BS bs)

Cabal/src/Distribution/PackageDescription/Parsec.hs

@@ -129,7 +129,11 @@ parseGenericPackageDescriptionMaybe =
     either (const Nothing) Just . snd . runParseResult . parseGenericPackageDescription
 
 fieldlinesToBS :: [FieldLine ann] -> BS.ByteString
-fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs)
+fieldlinesToBS = 
+    BS.intercalate "\n" .
+    map (\fl -> case fl of
+        FieldLine _ bs -> bs
+        CommentLineInField _ _ -> "")
 
 -- Monad in which sections are parsed
 type SectionParser = StateT SectionS ParseResult
@@ -243,6 +247,7 @@ goSections specVer = traverse_ process
     process (Field (Name pos name) _) =
         lift $ parseWarning pos PWTTrailingFields $
             "Ignoring trailing fields after sections: " ++ show name
+    process (Comment _ _) = return ()
     process (Section name args secFields) =
         parseSection name args secFields
 

templates/Lexer.x

@@ -93,7 +93,8 @@ tokens :-
 <bol_section, bol_field_layout, bol_field_braces> {
   @nbspspacetab* @nl         { \_pos len inp -> checkWhitespace 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
+  $spacetab* "--" $comment*  { \pos len inp -> return $! L pos (TokComment (B.take len inp)) }
+                                -- TODO: check the lack of @nl works here
                                 -- including counting line numbers
 }
 
@@ -110,7 +111,7 @@ tokens :-
 <in_section> {
   $spacetab+   ; --TODO: don't allow tab as leading space
 
-  "--" $comment* ;
+  "--" $comment*  { \pos len inp -> return $! L pos (TokComment (B.take len inp)) }
 
   @name        { toki TokSym }
   @string      { \pos len inp -> return $! L pos (TokStr (B.take (len - 2) (B.tail inp))) }
@@ -132,6 +133,7 @@ tokens :-
 
 <in_field_layout> {
   $spacetab+;
+  "--" $comment*  { \pos len inp -> return $! L pos (TokComment (B.take len inp)) }
   $field_layout' $field_layout*  { toki TokFieldLine }
   @nl             { \_ _ _ -> adjustPos retPos >> setStartCode bol_field_layout >> lexToken }
 }
@@ -153,6 +155,7 @@ tokens :-
 -- | Tokens of outer cabal file structure. Field values are treated opaquely.
 data Token = TokSym   !ByteString       -- ^ Haskell-like identifier, number or operator
            | TokStr   !ByteString       -- ^ String in quotes
+           | TokComment !ByteString     -- ^ Comment
            | TokOther !ByteString       -- ^ Operators and parens
            | Indent   !Int              -- ^ Indentation token
            | TokFieldLine !ByteString   -- ^ Lines after @:@