Replace hand-formatted generateCabalFile code with PrettyField.

Author: m-renaud

Cabal/Distribution/Fields/Pretty.hs

@@ -45,11 +45,21 @@ data PrettyField ann
 -- between comment lines.
 --
 showFields :: (ann -> [String]) -> [PrettyField ann] -> String
-showFields rann = showFields' rann 4
+showFields rann = showFields' rann (const id) 4
 
 -- | 'showFields' with user specified indentation.
-showFields' :: (ann -> [String]) -> Int -> [PrettyField ann] -> String
-showFields' rann n = unlines . renderFields (Opts rann indent) where
+showFields'
+  :: (ann -> [String])
+     -- ^ Convert an annotation to lined to preceed the field or section.
+  -> (ann -> [String] -> [String])
+     -- ^ Post-process non-annotation produced lines.
+  -> Int
+     -- ^ Indentation level.
+  -> [PrettyField ann]
+     -- ^ Fields/sections to show.
+  -> String
+showFields' rann post n = unlines . renderFields (Opts rann indent post)
+  where
     -- few hardcoded, "unrolled"  variants.
     indent | n == 4    = indent4
            | n == 2    = indent2
@@ -63,7 +73,11 @@ showFields' rann n = unlines . renderFields (Opts rann indent) where
     indent2 [] = []
     indent2 xs = ' ' : ' ' : xs
 
-data Opts ann = Opts (ann -> [String]) (String -> String)
+data Opts ann = Opts
+  { _optAnnotation ::(ann -> [String])
+  , _optIndent ::(String -> String)
+  , _optPostprocess :: ann -> [String] -> [String]
+  }
 
 renderFields :: Opts ann -> [PrettyField ann] -> [String]
 renderFields opts fields = flattenBlocks $ map (renderField opts len) fields
@@ -97,8 +111,8 @@ flattenBlocks = go0 where
             | otherwise                 = id
 
 renderField :: Opts ann -> Int -> PrettyField ann -> Block
-renderField (Opts rann indent) fw (PrettyField ann name doc) =
-    Block before after $ comments ++ lines'
+renderField (Opts rann indent post) fw (PrettyField ann name doc) =
+    Block before after $ comments ++ post ann lines'
   where
     comments = rann ann
     before = if null comments then NoMargin else Margin
@@ -115,10 +129,10 @@ renderField (Opts rann indent) fw (PrettyField ann name doc) =
     narrowStyle :: PP.Style
     narrowStyle = PP.style { PP.lineLength = PP.lineLength PP.style - fw }
 
-renderField opts@(Opts rann indent) _ (PrettySection ann name args fields) = Block Margin Margin $
+renderField opts@(Opts rann indent post) _ (PrettySection ann name args fields) = Block Margin Margin $
     rann ann
-    ++ 
-    [ PP.render $ PP.hsep $ PP.text (fromUTF8BS name) : args ]
+    ++
+    post ann [ PP.render $ PP.hsep $ PP.text (fromUTF8BS name) : args ]
     ++
     (map indent $ renderFields opts fields)
 

Cabal/Distribution/PackageDescription/FieldGrammar.hs

@@ -24,6 +24,14 @@ module Distribution.PackageDescription.FieldGrammar (
     benchmarkFieldGrammar,
     validateBenchmark,
     unvalidateBenchmark,
+    -- * Field grammars
+    formatDependencyList,
+    formatExposedModules,
+    formatExtraSourceFiles,
+    formatHsSourceDirs,
+    formatMixinList,
+    formatOtherExtensions,
+    formatOtherModules,
     -- ** Lenses
     benchmarkStanzaBenchmarkType,
     benchmarkStanzaMainIs,
@@ -41,6 +49,7 @@ module Distribution.PackageDescription.FieldGrammar (
 
 import Distribution.Compat.Lens
 import Distribution.Compat.Prelude
+import Language.Haskell.Extension
 import Prelude ()
 
 import Distribution.CabalSpecVersion
@@ -57,6 +66,7 @@ import Distribution.Types.ExecutableScope
 import Distribution.Types.ForeignLib
 import Distribution.Types.ForeignLibType
 import Distribution.Types.LibraryVisibility
+import Distribution.Types.Mixin
 import Distribution.Types.UnqualComponentName
 
 import qualified Distribution.SPDX as SPDX
@@ -100,7 +110,7 @@ packageDescriptionFieldGrammar = PackageDescription
     --  * Files
     <*> monoidalFieldAla    "data-files"         (alaList' VCat FilePathNT) L.dataFiles
     <*> optionalFieldDefAla "data-dir"           FilePathNT                 L.dataDir ""
-    <*> monoidalFieldAla    "extra-source-files" (alaList' VCat FilePathNT) L.extraSrcFiles
+    <*> monoidalFieldAla    "extra-source-files" formatExtraSourceFiles     L.extraSrcFiles
     <*> monoidalFieldAla    "extra-tmp-files"    (alaList' VCat FilePathNT) L.extraTmpFiles
     <*> monoidalFieldAla    "extra-doc-files"    (alaList' VCat FilePathNT) L.extraDocFiles
   where
@@ -125,7 +135,7 @@ libraryFieldGrammar
     => LibraryName
     -> g Library Library
 libraryFieldGrammar n = Library n
-    <$> monoidalFieldAla  "exposed-modules"    (alaList' VCat MQuoted) L.exposedModules
+    <$> monoidalFieldAla  "exposed-modules"    formatExposedModules    L.exposedModules
     <*> monoidalFieldAla  "reexported-modules" (alaList  CommaVCat)    L.reexportedModules
     <*> monoidalFieldAla  "signatures"         (alaList' VCat MQuoted) L.signatures
         ^^^ availableSince CabalSpecV2_0 []
@@ -408,14 +418,14 @@ buildInfoFieldGrammar = BuildInfo
         ^^^ availableSince CabalSpecV2_2 []
     <*> monoidalFieldAla "js-sources"           (alaList' VCat FilePathNT)    L.jsSources
     <*> hsSourceDirsGrammar
-    <*> monoidalFieldAla "other-modules"        (alaList' VCat MQuoted)       L.otherModules
+    <*> monoidalFieldAla "other-modules"        formatOtherModules            L.otherModules
     <*> monoidalFieldAla "virtual-modules"      (alaList' VCat MQuoted)       L.virtualModules
         ^^^ availableSince CabalSpecV2_2 []
     <*> monoidalFieldAla "autogen-modules"      (alaList' VCat MQuoted)       L.autogenModules
     <*> optionalFieldAla "default-language"     MQuoted                       L.defaultLanguage
     <*> monoidalFieldAla "other-languages"      (alaList' FSep MQuoted)       L.otherLanguages
     <*> monoidalFieldAla "default-extensions"   (alaList' FSep MQuoted)       L.defaultExtensions
-    <*> monoidalFieldAla "other-extensions"     (alaList' FSep MQuoted)       L.otherExtensions
+    <*> monoidalFieldAla "other-extensions"     formatOtherExtensions         L.otherExtensions
     <*> monoidalFieldAla "extensions"           (alaList' FSep MQuoted)       L.oldExtensions
         ^^^ deprecatedSince CabalSpecV1_12
             "Please use 'default-extensions' or 'other-extensions' fields."
@@ -438,8 +448,8 @@ buildInfoFieldGrammar = BuildInfo
     <*> sharedOptionsFieldGrammar
     <*> pure mempty -- static-options ???
     <*> prefixedFields   "x-"                                                 L.customFieldsBI
-    <*> monoidalFieldAla "build-depends"        (alaList  CommaVCat)          L.targetBuildDepends
-    <*> monoidalFieldAla "mixins"               (alaList  CommaVCat)          L.mixins
+    <*> monoidalFieldAla "build-depends"        formatDependencyList          L.targetBuildDepends
+    <*> monoidalFieldAla "mixins"               formatMixinList               L.mixins
         ^^^ availableSince CabalSpecV2_0 []
 {-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' BuildInfo #-}
 {-# SPECIALIZE buildInfoFieldGrammar :: PrettyFieldGrammar' BuildInfo #-}
@@ -448,7 +458,7 @@ hsSourceDirsGrammar
     :: (FieldGrammar g, Applicative (g BuildInfo))
     => g BuildInfo [FilePath]
 hsSourceDirsGrammar = (++)
-    <$> monoidalFieldAla "hs-source-dirs" (alaList' FSep FilePathNT) L.hsSourceDirs
+    <$> monoidalFieldAla "hs-source-dirs" formatHsSourceDirs L.hsSourceDirs
     <*> monoidalFieldAla "hs-source-dir"  (alaList' FSep FilePathNT) wrongLens
         --- https://github.com/haskell/cabal/commit/49e3cdae3bdf21b017ccd42e66670ca402e22b44
         ^^^ deprecatedSince CabalSpecV1_2 "Please use 'hs-source-dirs'"
@@ -542,3 +552,28 @@ setupBInfoFieldGrammar def = flip SetupBuildInfo def
     <$> monoidalFieldAla "setup-depends" (alaList CommaVCat) L.setupDepends
 {-# SPECIALIZE setupBInfoFieldGrammar :: Bool -> ParsecFieldGrammar' SetupBuildInfo #-}
 {-# SPECIALIZE setupBInfoFieldGrammar :: Bool ->PrettyFieldGrammar' SetupBuildInfo #-}
+
+-------------------------------------------------------------------------------
+-- Define how field values should be formatted for 'pretty'.
+-------------------------------------------------------------------------------
+
+formatDependencyList :: [Dependency] -> List CommaVCat (Identity Dependency) Dependency
+formatDependencyList = alaList CommaVCat
+
+formatMixinList :: [Mixin] -> List CommaVCat (Identity Mixin) Mixin
+formatMixinList = alaList CommaVCat
+
+formatExtraSourceFiles :: [FilePath] -> List VCat FilePathNT FilePath
+formatExtraSourceFiles = alaList' VCat FilePathNT
+
+formatExposedModules :: [ModuleName] -> List VCat (MQuoted ModuleName) ModuleName
+formatExposedModules = alaList' VCat MQuoted
+
+formatHsSourceDirs :: [FilePath] -> List FSep FilePathNT FilePath
+formatHsSourceDirs = alaList' FSep FilePathNT
+
+formatOtherExtensions :: [Extension] -> List FSep (MQuoted Extension) Extension
+formatOtherExtensions = alaList' FSep MQuoted
+
+formatOtherModules :: [ModuleName] -> List VCat (MQuoted ModuleName) ModuleName
+formatOtherModules = alaList' VCat MQuoted

cabal-install/Distribution/Client/Init/Command.hs

@@ -67,7 +67,7 @@ import Distribution.Client.Init.Prompt
   ( prompt, promptYesNo, promptStr, promptList, maybePrompt
   , promptListOptional )
 import Distribution.Client.Init.Utils
-  ( eligibleForTestSuite, message )
+  ( eligibleForTestSuite,  message )
 import Distribution.Client.Init.Types
   ( InitFlags(..), PackageType(..), Category(..)
   , displayPackageType )
@@ -76,6 +76,8 @@ import Distribution.Client.Init.Heuristics
     SourceFileEntry(..),
     scanForModules, neededBuildPrograms )
 
+import Distribution.Simple.Flag
+  ( maybeToFlag )
 import Distribution.Simple.Setup
   ( Flag(..), flagToMaybe )
 import Distribution.Simple.Configure
@@ -169,10 +171,6 @@ f ?>> g = do
     then return ma
     else g
 
--- | Witness the isomorphism between Maybe and Flag.
-maybeToFlag :: Maybe a -> Flag a
-maybeToFlag = maybe NoFlag Flag
-
 -- | Ask if a simple project with sensible defaults should be created.
 getSimpleProject :: InitFlags -> IO InitFlags
 getSimpleProject flags = do