Exactprinter & modification framework, take 2

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/
@@ -60,11 +65,17 @@ 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
 
   exposed-modules:
+    Distribution.Annotation
     Distribution.Backpack
     Distribution.CabalSpecVersion
     Distribution.Compat.Binary
@@ -86,11 +97,14 @@ library
     Distribution.Fields
     Distribution.Fields.ConfVar
     Distribution.Fields.Field
+    Distribution.Fields.Field.Lens
     Distribution.Fields.Lexer
     Distribution.Fields.LexerMonad
+    Distribution.Fields.Transform
     Distribution.Fields.ParseResult
     Distribution.Fields.Parser
     Distribution.Fields.Pretty
+    Distribution.Fields.ExactPretty
     Distribution.InstalledPackageInfo
     Distribution.License
     Distribution.ModuleName
@@ -106,6 +120,7 @@ library
     Distribution.Parsec.Error
     Distribution.Parsec.FieldLineStream
     Distribution.Parsec.Position
+    Distribution.Parsec.Position.Lens
     Distribution.Parsec.Warning
     Distribution.Parsec.Source
     Distribution.Pretty

Cabal-syntax/src/Distribution/Annotation.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Distribution.Annotation where
+
+import Data.List (sortOn)
+import Data.Ord (Down (..))
+import Distribution.Parsec
+
+-- | Designates the source position within a joined 'FieldLineStream'.
+--   Inclusive in the start position, exclusive in the ending position.
+data SrcSpan = SrcSpan {-# UNPACK #-} !Position {-# UNPACK #-} !Position
+  deriving (Show, Eq, Ord)
+
+data Located a = MkLocated {getSrcSpan :: !SrcSpan, unLocated :: !a}
+  deriving (Show, Functor, Foldable, Traversable)
+
+sortBySrcSpanAsc :: [Located a] -> [Located a]
+sortBySrcSpanAsc = sortOn getSrcSpan
+
+sortBySrcSpanDes :: [Located a] -> [Located a]
+sortBySrcSpanDes = sortOn (Down . getSrcSpan)
+
+instance Parsec a => Parsec (Located a) where
+  parsec = do
+    begin <- getPosition
+    x <- parsec
+    end <- getPosition
+    pure (MkLocated (SrcSpan begin end) x)

Cabal-syntax/src/Distribution/FieldGrammar.hs

@@ -85,7 +85,7 @@ partitionFields = finalize . foldl' f (PS mempty mempty mempty)
       | otherwise = (fs, reverse (reverse s : ss))
 
     f :: PS ann -> Field ann -> PS ann
-    f (PS fs s ss) (Field (Name ann name) fss) =
+    f (PS fs s ss) (Field _ (Name ann name) fss) =
       PS (Map.insertWith (flip (++)) name [MkNamelessField ann fss] fs) [] ss'
       where
         ss'
@@ -95,10 +95,11 @@ 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 (Field _ (Name ann name) fs) = Just (name, [MkNamelessField ann fs])
     match _ = Nothing

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

@@ -66,6 +66,7 @@ import Distribution.Version
   )
 import Text.PrettyPrint (Doc, comma, fsep, punctuate, text, vcat)
 
+import qualified Data.ByteString as BS
 import Data.Coerce (Coercible, coerce)
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Set as Set
@@ -88,12 +89,21 @@ data FSep = FSep
 data NoCommaFSep = NoCommaFSep
 
 class Sep sep where
+  -- | Detect whether a string is considered valid separator.
+  --   Used in exactprint modification.
+  isSeparator :: Proxy sep -> Char -> Bool
+
+  sepToChar :: Proxy sep -> BS.ByteString
+
   prettySep :: Proxy sep -> [Doc] -> Doc
 
   parseSep :: CabalParsing m => Proxy sep -> m a -> m [a]
   parseSepNE :: CabalParsing m => Proxy sep -> m a -> m (NonEmpty a)
 
 instance Sep CommaVCat where
+  isSeparator _ = (== ',')
+  sepToChar _ = ",\n"
+
   prettySep _ = vcat . punctuate comma
   parseSep _ p = do
     v <- askCabalSpecVersion
@@ -102,6 +112,9 @@ instance Sep CommaVCat where
     v <- askCabalSpecVersion
     if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmpty p else parsecCommaNonEmpty p
 instance Sep CommaFSep where
+  isSeparator _ = (== ',')
+  sepToChar _ = ","
+
   prettySep _ = fsep . punctuate comma
   parseSep _ p = do
     v <- askCabalSpecVersion
@@ -110,18 +123,27 @@ instance Sep CommaFSep where
     v <- askCabalSpecVersion
     if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmpty p else parsecCommaNonEmpty p
 instance Sep VCat where
+  isSeparator _ c = c == ',' || isSpace c
+  sepToChar _ = "\n"
+
   prettySep _ = vcat
   parseSep _ p = do
     v <- askCabalSpecVersion
     if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p
   parseSepNE _ p = NE.some1 (p <* P.spaces)
 instance Sep FSep where
+  isSeparator _ c = c == ',' || isSpace c
+  sepToChar _ = " "
+
   prettySep _ = fsep
   parseSep _ p = do
     v <- askCabalSpecVersion
     if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p
   parseSepNE _ p = NE.some1 (p <* P.spaces)
 instance Sep NoCommaFSep where
+  isSeparator _ = isSpace
+  sepToChar _ = " "
+
   prettySep _ = fsep
   parseSep _ p = many (p <* P.spaces)
   parseSepNE _ p = NE.some1 (p <* P.spaces)

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

@@ -1,4 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -- | This module provides a 'FieldGrammarParser', one way to parse
 -- @.cabal@ -like files.
@@ -63,6 +66,11 @@
   , runFieldParser'
   , fieldLinesToStream
   , freeTextIgnoreDotlineVers
+  , joinFieldLines
+  , splitFieldLines
+  , extractComments
+  , removeComments
+  , interleaveComments
   ) where
 
 import Distribution.Compat.Prelude
@@ -71,10 +79,14 @@
 import Prelude ()
 
 import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
 import Data.Coerce (Coercible, coerce)
+import Data.Foldable1
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
+import qualified Distribution.Compat.Lens as L
+import qualified Distribution.Parsec.Position.Lens as L
 import qualified Distribution.Utils.ShortText as ShortText
 import qualified Text.Parsec as P
 import qualified Text.Parsec.Error as P
@@ -495,3 +507,61 @@
 fieldLinesToStream [] = fieldLineStreamEnd
 fieldLinesToStream [FieldLine _ bs] = FLSLast bs
 fieldLinesToStream (FieldLine _ bs : fs) = FLSCons bs (fieldLinesToStream fs)
+
+-- | Take all comments out from a structure
+extractComments :: Foldable t => t (WithComments ann) -> [Comment ann]
+extractComments = foldMap justComments
+
+-- | Remove all comments from a structure
+removeComments :: Functor f => f (WithComments ann) -> f ann
+removeComments = fmap unComments
+
+-- | Biased to put comments as trailing.
+--   Precondition: both list are sorted by 'Position' (asc).
+interleaveComments :: [FieldLine Position] -> [Comment Position] -> [FieldLine (WithComments Position)]
+interleaveComments [] _ = [] -- We have nothing to attach the comment to, considered it deleted.
+interleaveComments [FieldLine pos bs] cmts = [FieldLine (WithComments cmts pos) bs]
+interleaveComments (FieldLine pos bs : fls) cmts =
+  let (pre, post) = span (\(Comment _ cpos) -> pos < cpos) cmts
+   in FieldLine (WithComments pre pos) bs : interleaveComments fls post
+
+-- TODO(leana8959): add property tests
+
+joinFieldLines :: NonEmpty (FieldLine Position) -> FieldLine Position
+-- No indentation needed
+joinFieldLines (FieldLine ann bs :| []) = FieldLine ann bs
+-- Fixup missing whitespaces, then join
+joinFieldLines fsNE =
+  let leftmostCol = foldl1' min $ fmap (L.view L.positionCol . fieldLineAnn) fsNE
+      ann0 = fieldLineAnn (NE.head fsNE)
+      indented = map (indentFieldLine leftmostCol) (NE.toList fsNE)
+      bss = toBSWithNewlines (L.view L.positionRow ann0) indented
+   in FieldLine (L.set L.positionCol leftmostCol ann0) bss
+
+-- | Indent a FieldLine while preserving 'FieldLine' invariants.
+indentFieldLine :: L.HasPosition ann => Int -> FieldLine ann -> FieldLine ann
+indentFieldLine leftmostCol (FieldLine ann bs) =
+  let myCol = L.view L.positionCol ann
+      indent = myCol - leftmostCol
+   in FieldLine (L.set L.positionCol leftmostCol ann) (BS8.replicate indent ' ' <> bs)
+
+toBSWithNewlines :: L.HasPosition ann => Int -> [FieldLine ann] -> BS.ByteString
+toBSWithNewlines row0 = mconcat . mealy go row0
+  where
+    go row (FieldLine ann bs) =
+      let myRow = L.view L.positionRow ann
+          newlines = myRow - row
+       in (myRow, BS8.replicate newlines '\n' <> bs)
+
+-- | Lines the inner 'ByteString', remove empty lines, distributing start colomn numbers and enumerate row numbers.
+--   We assume that the joined field lines have been aligned to the same column.
+splitFieldLines :: FieldLine Position -> [FieldLine Position]
+splitFieldLines (FieldLine ann bs0) =
+  let ls = BS8.lines bs0
+      Position startRow startCol = L.view L.position ann
+      rowNs = [startRow ..]
+   in zipWith
+        ( \bs row -> FieldLine (Position row startCol) bs
+        )
+        ls
+        rowNs

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

@@ -1,19 +1,30 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-module Distribution.Fields.ConfVar (parseConditionConfVar, parseConditionConfVarFromClause) where
+module Distribution.Fields.ConfVar
+  ( -- * Parsers
+    parseConditionConfVar
+  , parseConditionConfVarFromClause
+  , confVarParser
+
+    -- * Printers
+  , ppConfVar
+  , ppFlagName
+  , ppCondition
+  )
+where
 
 import Data.Functor ((<&>))
 import Distribution.Compat.CharParsing (char, integral)
 import Distribution.Compat.Prelude
 import Distribution.Fields.Field (Field (..), SectionArg (..), sectionArgAnn)
 import Distribution.Fields.ParseResult
 import Distribution.Fields.Parser (readFields)
-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.Types.Flag
 import Distribution.Version
   ( anyVersion
   , earlierVersion
@@ -31,10 +42,15 @@ import Distribution.Version
 import Prelude ()
 
 import qualified Data.ByteString.Char8 as B8
+import Distribution.Parsec
 import qualified Text.Parsec as P
 import qualified Text.Parsec.Error as P
 import qualified Text.Parsec.Pos as P
 
+import Distribution.Pretty
+import Text.PrettyPrint (Doc)
+import qualified Text.PrettyPrint as PP
+
 parseConditionConfVarFromClause :: B8.ByteString -> Either P.ParseError (Condition ConfVar)
 parseConditionConfVarFromClause x =
   readFields x >>= \case
@@ -71,6 +87,40 @@ type Parser = P.Parsec [SectionArg Position] ()
 sepByNonEmpty :: Parser a -> Parser sep -> Parser (NonEmpty a)
 sepByNonEmpty p sep = (:|) <$> p <*> many (sep *> p)
 
+-- TODO(leana8959): make the parser and pretty printer a class
+confVarParser :: Parser (Condition ConfVar)
+confVarParser = parser
+
+ppCondition :: Condition ConfVar -> Doc
+ppCondition (Var x) = ppConfVar x
+ppCondition (Lit b) = PP.text (show b)
+ppCondition (CNot c) = PP.char '!' <<>> ppCondition c
+ppCondition (COr c1 c2) =
+  PP.parens
+    ( PP.hsep
+        [ ppCondition c1
+        , PP.text "||"
+            <+> ppCondition c2
+        ]
+    )
+ppCondition (CAnd c1 c2) =
+  PP.parens
+    ( PP.hsep
+        [ ppCondition c1
+        , PP.text "&&"
+            <+> ppCondition c2
+        ]
+    )
+
+ppConfVar :: ConfVar -> Doc
+ppConfVar (OS os) = PP.text "os" <<>> PP.parens (pretty os)
+ppConfVar (Arch arch) = PP.text "arch" <<>> PP.parens (pretty arch)
+ppConfVar (PackageFlag name) = PP.text "flag" <<>> PP.parens (ppFlagName name)
+ppConfVar (Impl c v) = PP.text "impl" <<>> PP.parens (pretty c <+> pretty v)
+
+ppFlagName :: FlagName -> Doc
+ppFlagName = PP.text . unFlagName
+
 parser :: Parser (Condition ConfVar)
 parser = condOr
   where