Refactor pretty, so it goes via intermediate format

Something to do: Go from Parsec.Field to Pretty.Field directly,
that's may be useful for some tools

Cabal/Cabal.cabal

@@ -319,6 +319,7 @@ library
     Distribution.TestSuite
     Distribution.Text
     Distribution.Pretty
+    Distribution.Pretty.Field
     Distribution.Types.AbiHash
     Distribution.Types.AnnotatedId
     Distribution.Types.Benchmark

Cabal/Distribution/FieldGrammar/Pretty.hs

@@ -7,68 +7,69 @@ module Distribution.FieldGrammar.Pretty (
 import           Distribution.Compat.Lens
 import           Distribution.Compat.Newtype
 import           Distribution.Compat.Prelude
+import           Distribution.Parsec.Field   (FieldName)
 import           Distribution.Pretty         (Pretty (..))
-import           Distribution.Simple.Utils   (fromUTF8BS)
+import           Distribution.Pretty.Field   (Field (..))
+import           Distribution.Simple.Utils   (toUTF8BS)
 import           Prelude ()
 import           Text.PrettyPrint            (Doc)
 import qualified Text.PrettyPrint            as PP
 
 import Distribution.FieldGrammar.Class
-import Distribution.ParseUtils         (ppField)
 
 newtype PrettyFieldGrammar s a = PrettyFG
-    { fieldGrammarPretty :: s -> Doc
+    { fieldGrammarPretty :: s -> [Field]
     }
   deriving (Functor)
 
 instance Applicative (PrettyFieldGrammar s) where
     pure _ = PrettyFG (\_ -> mempty)
-    PrettyFG f <*> PrettyFG x = PrettyFG (\s -> f s PP.$$ x s)
+    PrettyFG f <*> PrettyFG x = PrettyFG (\s -> f s <> x s)
 
 -- | We can use 'PrettyFieldGrammar' to pp print the @s@.
 --
 -- /Note:/ there is not trailing @($+$ text "")@.
-prettyFieldGrammar :: PrettyFieldGrammar s a -> s -> Doc
+prettyFieldGrammar :: PrettyFieldGrammar s a -> s -> [Field]
 prettyFieldGrammar = fieldGrammarPretty
 
 instance FieldGrammar PrettyFieldGrammar where
     blurFieldGrammar f (PrettyFG pp) = PrettyFG (pp . aview f)
 
     uniqueFieldAla fn _pack l = PrettyFG $ \s ->
-        ppField (fromUTF8BS fn) (pretty (pack' _pack (aview l s)))
+        ppField fn (pretty (pack' _pack (aview l s)))
 
     booleanFieldDef fn l def = PrettyFG pp
       where
         pp s
             | b == def  = mempty
-            | otherwise = ppField (fromUTF8BS fn) (PP.text (show b))
+            | otherwise = ppField fn (PP.text (show b))
           where
             b = aview l s
 
     optionalFieldAla fn _pack l = PrettyFG pp
       where
         pp s = case aview l s of
             Nothing -> mempty
-            Just a  -> ppField (fromUTF8BS fn) (pretty (pack' _pack a))
+            Just a  -> ppField fn (pretty (pack' _pack a))
 
     optionalFieldDefAla fn _pack l def = PrettyFG pp
       where
         pp s
             | x == def  = mempty
-            | otherwise = ppField (fromUTF8BS fn) (pretty (pack' _pack x))
+            | otherwise = ppField fn (pretty (pack' _pack x))
           where
             x = aview l s
 
     monoidalFieldAla fn _pack l = PrettyFG pp
       where
-        pp s = ppField  (fromUTF8BS fn) (pretty (pack' _pack (aview l s)))
+        pp s = ppField fn (pretty (pack' _pack (aview l s)))
 
     prefixedFields _fnPfx l = PrettyFG (pp . aview l)
       where
-        pp xs = PP.vcat
-            -- always print the field, even its Doc is empty
+        pp xs =
+            -- always print the field, even its Doc is empty.
             -- i.e. don't use ppField
-            [ PP.text n <<>> PP.colon PP.<+> (PP.vcat $ map PP.text $ lines s)
+            [ Field (toUTF8BS n) $ PP.vcat $ map PP.text $ lines s
             | (n, s) <- xs
             -- fnPfx `isPrefixOf` n
             ]
@@ -77,3 +78,8 @@ instance FieldGrammar PrettyFieldGrammar where
     deprecatedSince _  _ x = x
     availableSince _ _     = id
     hiddenField _          = PrettyFG (\_ -> mempty)
+
+ppField :: FieldName -> Doc -> [Field]
+ppField name fielddoc
+    | PP.isEmpty fielddoc = []
+    | otherwise        = [ Field name fielddoc ]

Cabal/Distribution/InstalledPackageInfo.hs

@@ -52,7 +52,8 @@ import Distribution.FieldGrammar
 import Distribution.FieldGrammar.FieldDescrs
 import Distribution.ModuleName
 import Distribution.Package                  hiding (installedPackageId, installedUnitId)
-import Distribution.ParseUtils
+import Distribution.ParseUtils               hiding (showFields)
+import Distribution.Pretty.Field             (showFields)
 import Distribution.Types.ComponentName
 import Distribution.Types.LibraryName
 import Distribution.Utils.Generic            (toUTF8BS)
@@ -133,7 +134,7 @@ showInstalledPackageInfo ipi =
 
 -- | The variant of 'showInstalledPackageInfo' which outputs @pkgroot@ field too.
 showFullInstalledPackageInfo :: InstalledPackageInfo -> String
-showFullInstalledPackageInfo = Disp.render . (Disp.$+$ Disp.text "") . prettyFieldGrammar ipiFieldGrammar
+showFullInstalledPackageInfo = showFields . prettyFieldGrammar ipiFieldGrammar
 
 -- |
 --

Cabal/Distribution/PackageDescription/PrettyPrint.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Distribution.PackageDescription.PrettyPrint
@@ -26,31 +27,29 @@ module Distribution.PackageDescription.PrettyPrint (
      showHookedBuildInfo,
 ) where
 
-import Prelude ()
 import Distribution.Compat.Prelude
+import Prelude ()
 
+import Distribution.Types.CondTree
 import Distribution.Types.Dependency
-import Distribution.Types.ForeignLib (ForeignLib (foreignLibName))
+import Distribution.Types.ForeignLib          (ForeignLib (foreignLibName))
 import Distribution.Types.UnqualComponentName
-import Distribution.Types.CondTree
 
 import Distribution.PackageDescription
-import Distribution.Simple.Utils
-import Distribution.ParseUtils
+import Distribution.ParseUtils ()
 import Distribution.Pretty
+import Distribution.Pretty.Field
+import Distribution.Simple.Utils
 
-import Distribution.FieldGrammar (PrettyFieldGrammar', prettyFieldGrammar)
+import Distribution.FieldGrammar                    (PrettyFieldGrammar', prettyFieldGrammar)
 import Distribution.PackageDescription.FieldGrammar
-       (packageDescriptionFieldGrammar, buildInfoFieldGrammar,
-        flagFieldGrammar, foreignLibFieldGrammar, libraryFieldGrammar,
-        benchmarkFieldGrammar, testSuiteFieldGrammar,
-        setupBInfoFieldGrammar, sourceRepoFieldGrammar, executableFieldGrammar)
+       (benchmarkFieldGrammar, buildInfoFieldGrammar, executableFieldGrammar, flagFieldGrammar,
+       foreignLibFieldGrammar, libraryFieldGrammar, packageDescriptionFieldGrammar,
+       setupBInfoFieldGrammar, sourceRepoFieldGrammar, testSuiteFieldGrammar)
 
 import qualified Distribution.PackageDescription.FieldGrammar as FG
 
-import Text.PrettyPrint
-       (hsep, space, parens, char, nest, ($$), (<+>),
-        text, vcat, ($+$), Doc, render)
+import Text.PrettyPrint (Doc, char, hsep, parens, text, (<+>))
 
 import qualified Data.ByteString.Lazy.Char8 as BS.Char8
 
@@ -60,116 +59,113 @@ writeGenericPackageDescription fpath pkg = writeUTF8File fpath (showGenericPacka
 
 -- | Writes a generic package description to a string
 showGenericPackageDescription :: GenericPackageDescription -> String
-showGenericPackageDescription            = render . ($+$ text "") . ppGenericPackageDescription
-
-ppGenericPackageDescription :: GenericPackageDescription -> Doc
-ppGenericPackageDescription gpd          =
-        ppPackageDescription (packageDescription gpd)
-        $+$ ppSetupBInfo (setupBuildInfo (packageDescription gpd))
-        $+$ ppGenPackageFlags (genPackageFlags gpd)
-        $+$ ppCondLibrary (condLibrary gpd)
-        $+$ ppCondSubLibraries (condSubLibraries gpd)
-        $+$ ppCondForeignLibs (condForeignLibs gpd)
-        $+$ ppCondExecutables (condExecutables gpd)
-        $+$ ppCondTestSuites (condTestSuites gpd)
-        $+$ ppCondBenchmarks (condBenchmarks gpd)
-
-ppPackageDescription :: PackageDescription -> Doc
+showGenericPackageDescription = showFields . ppGenericPackageDescription
+
+ppGenericPackageDescription :: GenericPackageDescription -> [Field]
+ppGenericPackageDescription gpd = concat
+    [ ppPackageDescription (packageDescription gpd)
+    , ppSetupBInfo (setupBuildInfo (packageDescription gpd))
+    , ppGenPackageFlags (genPackageFlags gpd)
+    , ppCondLibrary (condLibrary gpd)
+    , ppCondSubLibraries (condSubLibraries gpd)
+    , ppCondForeignLibs (condForeignLibs gpd)
+    , ppCondExecutables (condExecutables gpd)
+    , ppCondTestSuites (condTestSuites gpd)
+    , ppCondBenchmarks (condBenchmarks gpd)
+    ]
+
+ppPackageDescription :: PackageDescription -> [Field]
 ppPackageDescription pd =
     prettyFieldGrammar packageDescriptionFieldGrammar pd
-    $+$ ppSourceRepos (sourceRepos pd)
+    ++ ppSourceRepos (sourceRepos pd)
 
-ppSourceRepos :: [SourceRepo] -> Doc
-ppSourceRepos []                         = mempty
-ppSourceRepos (hd:tl)                    = ppSourceRepo hd $+$ ppSourceRepos tl
+ppSourceRepos :: [SourceRepo] -> [Field]
+ppSourceRepos = map ppSourceRepo
 
-ppSourceRepo :: SourceRepo -> Doc
-ppSourceRepo repo =
-    emptyLine $ text "source-repository" <+> pretty kind $+$
-    nest indentWith (prettyFieldGrammar (sourceRepoFieldGrammar kind) repo)
+ppSourceRepo :: SourceRepo -> Field
+ppSourceRepo repo = Section "source-repository" [pretty kind] $
+    prettyFieldGrammar (sourceRepoFieldGrammar kind) repo
   where
     kind = repoKind repo
 
-ppSetupBInfo :: Maybe SetupBuildInfo -> Doc
+ppSetupBInfo :: Maybe SetupBuildInfo -> [Field]
 ppSetupBInfo Nothing = mempty
 ppSetupBInfo (Just sbi)
     | defaultSetupDepends sbi = mempty
-    | otherwise =
-        emptyLine $ text "custom-setup" $+$
-        nest indentWith (prettyFieldGrammar (setupBInfoFieldGrammar False) sbi)
+    | otherwise = pure $ Section "custom-setup" [] $
+        prettyFieldGrammar (setupBInfoFieldGrammar False) sbi
 
-ppGenPackageFlags :: [Flag] -> Doc
-ppGenPackageFlags flds = vcat [ppFlag f | f <- flds]
+ppGenPackageFlags :: [Flag] -> [Field]
+ppGenPackageFlags = map ppFlag
 
-ppFlag :: Flag -> Doc
-ppFlag flag@(MkFlag name _ _ _)  =
-    emptyLine $ text "flag" <+> ppFlagName name $+$
-    nest indentWith (prettyFieldGrammar (flagFieldGrammar name) flag)
+ppFlag :: Flag -> Field
+ppFlag flag@(MkFlag name _ _ _)  = Section "flag" [ppFlagName name] $
+    prettyFieldGrammar (flagFieldGrammar name) flag
 
-ppCondTree2 :: PrettyFieldGrammar' s -> CondTree ConfVar [Dependency] s -> Doc
+ppCondTree2 :: PrettyFieldGrammar' s -> CondTree ConfVar [Dependency] s -> [Field]
 ppCondTree2 grammar = go
   where
     -- TODO: recognise elif opportunities
     go (CondNode it _ ifs) =
-        prettyFieldGrammar grammar it
-        $+$ vcat (map ppIf ifs)
+        prettyFieldGrammar grammar it ++
+        concatMap ppIf ifs
 
     ppIf (CondBranch c thenTree Nothing)
 --        | isEmpty thenDoc = mempty
-        | otherwise       = ppIfCondition c $$ nest indentWith thenDoc
+        | otherwise       = [ppIfCondition c thenDoc]
       where
         thenDoc = go thenTree
 
     ppIf (CondBranch c thenTree (Just elseTree)) =
           case (False, False) of
  --       case (isEmpty thenDoc, isEmpty elseDoc) of
               (True,  True)  -> mempty
-              (False, True)  -> ppIfCondition c $$ nest indentWith thenDoc
-              (True,  False) -> ppIfCondition (cNot c) $$ nest indentWith elseDoc
-              (False, False) -> (ppIfCondition c $$ nest indentWith thenDoc)
-                                $+$ (text "else" $$ nest indentWith elseDoc)
+              (False, True)  -> [ ppIfCondition c thenDoc ]
+              (True,  False) -> [ ppIfCondition (cNot c) elseDoc ]
+              (False, False) -> [ ppIfCondition c thenDoc
+                                , Section "else" [] elseDoc
+                                ]
       where
         thenDoc = go thenTree
         elseDoc = go elseTree
 
-ppCondLibrary :: Maybe (CondTree ConfVar [Dependency] Library) -> Doc
+ppCondLibrary :: Maybe (CondTree ConfVar [Dependency] Library) -> [Field]
 ppCondLibrary Nothing = mempty
-ppCondLibrary (Just condTree) =
-    emptyLine $ text "library" $+$
-    nest indentWith (ppCondTree2 (libraryFieldGrammar Nothing) condTree)
-
-ppCondSubLibraries :: [(UnqualComponentName, CondTree ConfVar [Dependency] Library)] -> Doc
-ppCondSubLibraries libs = vcat
-    [ emptyLine $ (text "library" <+> pretty n) $+$
-      nest indentWith (ppCondTree2 (libraryFieldGrammar $ Just n) condTree)
+ppCondLibrary (Just condTree) = pure $ Section "library" [] $
+    ppCondTree2 (libraryFieldGrammar Nothing) condTree
+
+ppCondSubLibraries :: [(UnqualComponentName, CondTree ConfVar [Dependency] Library)] -> [Field]
+ppCondSubLibraries libs =
+    [ Section "library" [pretty n]
+    $ ppCondTree2 (libraryFieldGrammar $ Just n) condTree
     | (n, condTree) <- libs
     ]
 
-ppCondForeignLibs :: [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)] -> Doc
-ppCondForeignLibs flibs = vcat
-    [ emptyLine $ (text "foreign-library" <+> pretty n) $+$
-      nest indentWith (ppCondTree2 (foreignLibFieldGrammar n) condTree)
+ppCondForeignLibs :: [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)] -> [Field]
+ppCondForeignLibs flibs =
+    [ Section "foreign-library" [pretty n]
+    $ ppCondTree2 (foreignLibFieldGrammar n) condTree
     | (n, condTree) <- flibs
     ]
 
-ppCondExecutables :: [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)] -> Doc
-ppCondExecutables exes = vcat
-    [ emptyLine $ (text "executable" <+> pretty n) $+$
-      nest indentWith (ppCondTree2 (executableFieldGrammar n) condTree)
+ppCondExecutables :: [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)] -> [Field]
+ppCondExecutables exes =
+    [ Section "executable" [pretty n]
+    $ ppCondTree2 (executableFieldGrammar n) condTree
     | (n, condTree) <- exes
     ]
 
-ppCondTestSuites :: [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)] -> Doc
-ppCondTestSuites suites = vcat
-    [ emptyLine $ (text "test-suite" <+> pretty n) $+$
-      nest indentWith (ppCondTree2 testSuiteFieldGrammar (fmap FG.unvalidateTestSuite condTree))
+ppCondTestSuites :: [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)] -> [Field]
+ppCondTestSuites suites =
+    [ Section "test-suite" [pretty n]
+    $ ppCondTree2 testSuiteFieldGrammar (fmap FG.unvalidateTestSuite condTree)
     | (n, condTree) <- suites
     ]
 
-ppCondBenchmarks :: [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)] -> Doc
-ppCondBenchmarks suites = vcat
-    [ emptyLine $ (text "benchmark" <+> pretty n) $+$
-      nest indentWith (ppCondTree2 benchmarkFieldGrammar (fmap FG.unvalidateBenchmark condTree))
+ppCondBenchmarks :: [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)] -> [Field]
+ppCondBenchmarks suites =
+    [ Section "benchmark" [pretty n]
+    $ ppCondTree2 benchmarkFieldGrammar (fmap FG.unvalidateBenchmark condTree)
     | (n, condTree) <- suites
     ]
 
@@ -190,11 +186,8 @@ ppConfVar (Impl c v)                     = text "impl" <<>> parens (pretty c <+>
 ppFlagName :: FlagName -> Doc
 ppFlagName                               = text . unFlagName
 
-ppIfCondition :: (Condition ConfVar) -> Doc
-ppIfCondition c = (emptyLine $ text "if" <+> ppCondition c)
-
-emptyLine :: Doc -> Doc
-emptyLine d                              = text "" $+$ d
+ppIfCondition :: (Condition ConfVar) -> [Field] -> Field
+ppIfCondition c = Section "if" [ppCondition c]
 
 -- | @since 2.0.0.2
 writePackageDescription :: FilePath -> PackageDescription -> NoCallStackIO ()
@@ -236,12 +229,9 @@ writeHookedBuildInfo fpath = writeFileAtomic fpath . BS.Char8.pack
 
 -- | @since 2.0.0.2
 showHookedBuildInfo :: HookedBuildInfo -> String
-showHookedBuildInfo (mb_lib_bi, ex_bis) = render $
-    maybe mempty (prettyFieldGrammar buildInfoFieldGrammar) mb_lib_bi
-    $$ vcat
-        [ space
-        $$ (text "executable:" <+> pretty name)
-        $$  prettyFieldGrammar buildInfoFieldGrammar bi
-        | (name, bi) <- ex_bis
-        ]
-    $+$ text ""
+showHookedBuildInfo (mb_lib_bi, ex_bis) = showFields $
+    maybe mempty (prettyFieldGrammar buildInfoFieldGrammar) mb_lib_bi ++
+    [ Section "executable:" [pretty name]
+    $ prettyFieldGrammar buildInfoFieldGrammar bi
+    | (name, bi) <- ex_bis
+    ]