Formatter poc

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/
@@ -47,6 +52,8 @@ library
     -- See also https://github.com/ekmett/transformers-compat/issues/35
     , transformers (>= 0.3      && < 0.4) || (>=0.4.1.0 && <0.7)
 
+    , pretty-simple
+
   ghc-options:
     -Wall
     -fno-ignore-asserts
@@ -60,11 +67,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
@@ -83,14 +96,19 @@ library
     Distribution.FieldGrammar.Newtypes
     Distribution.FieldGrammar.Parsec
     Distribution.FieldGrammar.Pretty
+    Distribution.FieldGrammar.Format
     Distribution.Fields
     Distribution.Fields.ConfVar
     Distribution.Fields.Field
+    Distribution.Fields.Field.Lens
+    Distribution.Fields.Field.Relative
     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
@@ -99,13 +117,15 @@ library
     Distribution.PackageDescription.Configuration
     Distribution.PackageDescription.FieldGrammar
     Distribution.PackageDescription.Parsec
+    Distribution.PackageDescription.Format
     Distribution.PackageDescription.PrettyPrint
     Distribution.PackageDescription.Quirks
     Distribution.PackageDescription.Utils
     Distribution.Parsec
     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,31 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Distribution.Annotation where
+
+import Data.List (sortOn)
+import Data.Ord (Down (..))
+import Distribution.Parsec
+import Distribution.Parsec.Position
+
+-- | 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

@@ -16,6 +16,8 @@ module Distribution.FieldGrammar
   , PrettyFieldGrammar
   , PrettyFieldGrammar'
   , prettyFieldGrammar
+  , FormatterFieldGrammar
+  , formatFieldGrammar
 
     -- * Auxiliary
   , (^^^)
@@ -37,6 +39,7 @@ import Prelude ()
 import qualified Data.Map.Strict as Map
 
 import Distribution.FieldGrammar.Class
+import Distribution.FieldGrammar.Format
 import Distribution.FieldGrammar.Newtypes
 import Distribution.FieldGrammar.Parsec
 import Distribution.FieldGrammar.Pretty
@@ -85,7 +88,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 +98,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/Format.hs

@@ -0,0 +1,98 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MonoLocalBinds #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | This is a field formatter directed by
+module Distribution.FieldGrammar.Format where
+
+import Distribution.FieldGrammar.Class
+import Distribution.Fields.Field
+import Distribution.Fields.Transform
+import Distribution.Parsec
+import Distribution.Pretty
+
+import Data.Coerce
+import Data.Kind
+
+import Data.Map (Map)
+import qualified Data.Map as M
+import Distribution.CabalSpecVersion
+import Distribution.Compat.Lens
+
+data FormatterFieldGrammar s a = FormatterFG
+  { fieldGrammarFormatter
+      :: CabalSpecVersion
+      -> Map FieldName ([FieldLine (WithComments Position)] -> [FieldLine (WithComments Position)])
+  }
+  deriving (Functor)
+
+formatFieldGrammar :: CabalSpecVersion -> FormatterFieldGrammar s a -> Field (WithComments Position) -> Field (WithComments Position)
+formatFieldGrammar spec (FormatterFG versionedFormatter) = go
+  where
+    go section@(Section{}) = section
+    go (Field colonPos fname fls) =
+      let newField = case versionedFormatter spec M.!? getName fname of
+            Just f -> Field colonPos fname (f fls)
+            Nothing -> Field colonPos fname fls
+       in newField
+
+-- TODO(leana8959): how to do this properly
+class (Pretty a, Parsec a) => Formattable a
+instance (Pretty a, Parsec a) => Formattable a
+
+instance Applicative (FormatterFieldGrammar s) where
+  pure _ = FormatterFG $ \_ -> M.empty
+  FormatterFG x <*> FormatterFG y = FormatterFG (x <> y)
+
+-- | Naive implementation, doesn't put comments back.
+formatFieldLines
+  :: forall (a :: Type)
+   . (Parsec a, Pretty a)
+  => (CabalSpecVersion -> [FieldLine (WithComments Position)] -> [FieldLine (WithComments Position)])
+formatFieldLines = formatFieldLinesAla @a @a
+
+-- | Naive implementation, doesn't put comments back.
+formatFieldLinesAla
+  :: forall (b :: Type) (a :: Type)
+   . (Coercible a b, Parsec b, Pretty b)
+  => (CabalSpecVersion -> [FieldLine (WithComments Position)] -> [FieldLine (WithComments Position)])
+formatFieldLinesAla spec fls = case modifyValueAtomAla @b @a Just spec fls of
+  EditOk ok -> ok
+  EditUnchanged u -> u
+  EditErr _ -> error $ "formatting failed"
+
+instance FieldGrammar Formattable FormatterFieldGrammar where
+  uniqueFieldAla
+    :: forall b a s proxy. (Formattable b, Coercible a b) => FieldName -> proxy a b -> ALens' s a -> FormatterFieldGrammar s a
+  uniqueFieldAla fn _ _extract = FormatterFG $ \spec -> M.singleton fn $ formatFieldLinesAla @b @a spec
+
+  booleanFieldDef fn _ _def = FormatterFG $ \spec -> M.singleton fn $ formatFieldLines @Bool spec
+
+  optionalFieldAla
+    :: forall b a s proxy. (Formattable b, Coercible a b) => FieldName -> proxy a b -> ALens' s (Maybe a) -> FormatterFieldGrammar s (Maybe a)
+  optionalFieldAla fn _ _extract = FormatterFG $ \spec -> M.singleton fn $ formatFieldLinesAla @b @a spec
+
+  optionalFieldDefAla
+    :: forall b a s proxy. (Formattable b, Coercible a b) => FieldName -> proxy a b -> ALens' s a -> a -> FormatterFieldGrammar s a
+  optionalFieldDefAla fn _ _extract _def = FormatterFG $ \spec -> M.singleton fn $ formatFieldLinesAla @b @a spec
+
+  monoidalFieldAla
+    :: forall b a proxy s. (Formattable b, Coercible a b) => FieldName -> proxy a b -> ALens' s a -> FormatterFieldGrammar s a
+  monoidalFieldAla fn _ _extract = FormatterFG $ \spec -> M.singleton fn $ formatFieldLinesAla @b @a spec
+
+  -- Nothing to format?
+  freeTextField _fn _ = FormatterFG $ \_ -> M.empty
+  freeTextFieldDef _fn _ = FormatterFG $ \_ -> M.empty
+  freeTextFieldDefST _fn _ = FormatterFG $ \_ -> M.empty
+  prefixedFields _fn _ = FormatterFG $ \_ -> M.empty
+
+  knownField _ = FormatterFG $ \_ -> M.empty
+  hiddenField _ = FormatterFG $ \_ -> M.empty
+
+  deprecatedSince _ _ = id
+  removedIn _ _ = id
+  availableSince _ _ = id
+  availableSinceWarn _ = id
+
+  blurFieldGrammar _ (FormatterFG formatter) = FormatterFG formatter

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

@@ -66,10 +66,13 @@
   )
 import Text.PrettyPrint (Doc, comma, fsep, punctuate, text, vcat)
 
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
 import Data.Coerce (Coercible, coerce)
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Set as Set
 import qualified Distribution.Compat.CharParsing as P
+import Distribution.Fields.ExactPretty (LineEnding, lineEndingChar)
 import qualified Distribution.SPDX as SPDX
 
 -- | Vertical list with commas. Displayed with 'vcat'
@@ -88,12 +91,21 @@
 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 +114,9 @@
     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 +125,27 @@
     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)