Add fieldPAla to factor out newtype wrapper logic.

Author: m-renaud

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Distribution.Client.Init.FileCreators
@@ -50,7 +51,7 @@ import System.Directory
   ( getCurrentDirectory, doesFileExist, copyFile
   , createDirectoryIfMissing )
 
-import Text.PrettyPrint hiding (mode, cat)
+import Text.PrettyPrint hiding ((<>), mode, cat)
 
 import Distribution.Client.Init.Defaults
   ( defaultCabalVersion, myLibModule )
@@ -62,8 +63,12 @@ import Distribution.Client.Init.Types
   ( InitFlags(..), BuildType(..), PackageType(..) )
 
 import Distribution.CabalSpecVersion
+import Distribution.Compat.Newtype
+  ( Newtype )
 import Distribution.Deprecated.Text
   ( display, Text(..) )
+import Distribution.Fields.Field
+  ( FieldName )
 import Distribution.License
   ( licenseFromSPDX )
 import qualified Distribution.ModuleName as ModuleName
@@ -417,7 +422,7 @@ generateCabalFile fileName c =
            []
            False
 
-  , fieldP "extra-source-files" (maybeToFlag $ (formatExtraSourceFiles <$> extraSrc c))
+  , fieldPAla "extra-source-files" formatExtraSourceFiles (maybeToFlag (extraSrc c))
            ["Extra files to be distributed with the package, such as examples or a README."]
            True
   ]
@@ -439,22 +444,22 @@ generateCabalFile fileName c =
 
    generateBuildInfo :: BuildType -> InitFlags -> [PrettyField [String]]
    generateBuildInfo buildType c' = catMaybes
-     [ fieldP "other-modules" (formatOtherModules <$> maybeToFlag otherMods)
+     [ fieldPAla "other-modules" formatOtherModules (maybeToFlag otherMods)
        [ case buildType of
                  LibBuild    -> "Modules included in this library but not exported."
                  ExecBuild -> "Modules included in this executable, other than Main."]
        True
 
-     , fieldP "other-extensions" (maybeToFlag (formatOtherExtensions <$> otherExts c))
+     , fieldPAla "other-extensions" formatOtherExtensions (maybeToFlag (otherExts c))
        ["LANGUAGE extensions used by modules in this package."]
        True
 
-     , fieldP "build-depends" (maybeToFlag (formatDependencyList <$> buildDependencies))
+     , fieldPAla "build-depends" formatDependencyList (maybeToFlag buildDependencies)
        ["Other library packages from which modules are imported."]
        True
 
-     , fieldP "hs-source-dirs"
-       (maybeToFlag (formatHsSourceDirs <$> case buildType of
+     , fieldPAla "hs-source-dirs" formatHsSourceDirs
+       (maybeToFlag (case buildType of
                                               LibBuild -> sourceDirs c
                                               ExecBuild -> applicationDirs c))
        ["Directories containing source files."]
@@ -494,16 +499,16 @@ generateCabalFile fileName c =
 
    -- | Construct a 'PrettyField' from a field that can be automatically
    --   converted to a 'Doc' via 'display'.
-   field :: Text t =>
-            String
+   field :: Text t
+         => FieldName
          -> Flag t
          -> [String]
          -> Bool
          -> Maybe (PrettyField [String])
    field fieldName fieldContentsFlag = fieldS fieldName (display <$> fieldContentsFlag)
 
    -- | Construct a 'PrettyField' from a 'String' field.
-   fieldS :: String      -- ^ Name of the field
+   fieldS :: FieldName   -- ^ Name of the field
           -> Flag String -- ^ Field contents
           -> [String]    -- ^ Comment to explain the field
           -> Bool        -- ^ Should the field be included (commented out) even if blank?
@@ -512,16 +517,28 @@ generateCabalFile fileName c =
 
    -- | Construct a 'PrettyField' from a Flag which can be 'pretty'-ied.
    fieldP :: Pretty a
-          => String
+          => FieldName
           -> Flag a
           -> [String]
           -> Bool
           -> Maybe (PrettyField [String])
    fieldP fieldName fieldContentsFlag fieldComments includeField =
-     fieldD fieldName (pretty <$> fieldContentsFlag) fieldComments includeField
+     fieldPAla fieldName Identity fieldContentsFlag fieldComments includeField
+
+   -- | Construct a 'PrettyField' from a flag which can be 'pretty'-ied, wrapped in newtypeWrapper.
+   fieldPAla
+     :: (Pretty b, Newtype a b)
+     => FieldName
+     -> (a -> b)
+     -> Flag a
+     -> [String]
+     -> Bool
+     -> Maybe (PrettyField [String])
+   fieldPAla fieldName newtypeWrapper fieldContentsFlag fieldComments includeField =
+     fieldD fieldName (pretty . newtypeWrapper <$> fieldContentsFlag) fieldComments includeField
 
    -- | Construct a 'PrettyField' from a 'Doc' Flag.
-   fieldD :: String     -- ^ Name of the field
+   fieldD :: FieldName   -- ^ Name of the field
           -> Flag Doc    -- ^ Field contents
           -> [String]    -- ^ Comment to explain the field
           -> Bool        -- ^ Should the field be included (commented out) even if blank?
@@ -551,23 +568,23 @@ generateCabalFile fileName c =
                fieldSWithContents fieldName fieldContents fieldComments
 
    -- | Optionally produce a field with no content (depending on flags).
-   fieldSEmptyContents :: String
+   fieldSEmptyContents :: FieldName
                        -> [String]
                        -> Bool
                        -> Maybe (PrettyField [String])
    fieldSEmptyContents fieldName fieldComments includeField
      | not includeField || (minimal c == Flag True) =
          Nothing
      | otherwise =
-         Just (PrettyFieldCommentedOut (map ("-- " ++) fieldComments) (toUTF8BS fieldName))
+         Just (PrettyFieldCommentedOut (map ("-- " ++) fieldComments) fieldName)
 
    -- | Produce a field with content.
-   fieldSWithContents :: String
+   fieldSWithContents :: FieldName
                       -> Doc
                       -> [String]
                       -> PrettyField [String]
    fieldSWithContents fieldName fieldContents fieldComments =
-     PrettyField (map ("-- " ++) fieldComments) (toUTF8BS fieldName) fieldContents
+     PrettyField (map ("-- " ++) fieldComments) fieldName fieldContents
 
    executableStanza :: PrettyField [String]
    executableStanza = PrettySection [] (toUTF8BS "executable") [exeName] $ catMaybes
@@ -582,7 +599,7 @@ generateCabalFile fileName c =
 
    libraryStanza :: PrettyField [String]
    libraryStanza = PrettySection [] (toUTF8BS "library") [] $ catMaybes
-     [ fieldP "exposed-modules" (maybeToFlag (formatExposedModules <$> exposedModules c))
+     [ fieldPAla "exposed-modules" formatExposedModules (maybeToFlag (exposedModules c))
        ["Modules exported by the library."]
        True
      ]
@@ -600,16 +617,16 @@ generateCabalFile fileName c =
        ["The interface type and version of the test suite."]
        True
 
-     , fieldP "hs-source-dirs"
-       (maybeToFlag (formatHsSourceDirs <$> testDirs c))
+     , fieldPAla "hs-source-dirs" formatHsSourceDirs
+       (maybeToFlag (testDirs c))
        ["Directories containing source files."]
        True
 
      , fieldS "main-is" (Flag testFile)
        ["The entrypoint to the test suite."]
        True
 
-     , fieldP "build-depends" (maybeToFlag (formatDependencyList <$> dependencies c))
+     , fieldPAla  "build-depends" formatDependencyList (maybeToFlag (dependencies c))
        ["Test dependencies."]
        True
      ]

tests/fixtures/init/lib-and-exe-golden.cabal

@@ -25,7 +25,7 @@ executable foo
         base ^>=4.13.0.0,
         containers ^>=5.7.0.0,
         unordered-containers ^>=2.7.0.0,
-        foo -any
+        foo
 
     hs-source-dirs:   app
     default-language: Haskell2010

tests/fixtures/init/lib-exe-and-test-with-comments-golden.cabal

@@ -1,14 +1,15 @@
 cabal-version:      2.4
 
--- Initial package description
--- 'lib-exe-and-test-with-comments-golden.cabal' generated by 'cabal init'.
---   For further documentation, see http://haskell.org/cabal/users-guide/
-
+-- Initial package description 'lib-exe-and-test-with-comments-golden.cabal' generated by
+-- 'cabal init'. For further documentation, see:
+--   http://haskell.org/cabal/users-guide/
+-- 
 -- The name of the package.
 name:               foo
 
--- The package version.  See the Haskell package versioning policy (PVP)
--- for standards guiding when and how versions should be incremented.
+-- The package version.
+-- See the Haskell package versioning policy (PVP) for standards
+-- guiding when and how versions should be incremented.
 -- https://pvp.haskell.org
 -- PVP summary:      +-+------- breaking API changes
 --                   | | +----- non-breaking API additions
@@ -17,13 +18,11 @@ version:            3.2.1
 
 -- A short (one-line) description of the package.
 synopsis:           The foo package
-
 -- A longer description of the package.
 -- description:
 
 -- URL for the project homepage or repository.
 homepage:           https://github.com/foo/foo
-
 -- A URL where users can report bugs.
 -- bug-reports:
 
@@ -33,73 +32,73 @@ license:            NONE
 -- The package author(s).
 author:             me
 
--- An email address to which users can send suggestions, bug reports, and
--- patches.
+-- An email address to which users can send suggestions, bug reports, and patches.
 maintainer:         me@me.me
-
 -- A copyright notice.
 -- copyright:
-
 category:           SomeCat
 
--- Extra files to be distributed with the package, such as examples or a
--- README.
+-- Extra files to be distributed with the package, such as examples or a README.
 extra-source-files: CHANGELOG.md
 
-
 library
-  -- Modules exported by the library.
-  exposed-modules:    A, B
+    -- Modules exported by the library.
+    exposed-modules:
+        A
+        B
 
-  -- Modules included in this library but not exported.
-  -- other-modules:
+    -- Modules included in this library but not exported.
+    -- other-modules:
+    -- LANGUAGE extensions used by modules in this package.
+    -- other-extensions:
 
-  -- LANGUAGE extensions used by modules in this package.
-  -- other-extensions:
+    -- Other library packages from which modules are imported.
+    build-depends:
+        base ^>=4.13.0.0,
+        containers ^>=5.7.0.0,
+        unordered-containers ^>=2.7.0.0
 
-  -- Other library packages from which modules are imported.
-  build-depends:      base ^>=4.13.0.0, containers ^>=5.7.0.0, unordered-containers ^>=2.7.0.0
-
-  -- Directories containing source files.
-  hs-source-dirs:     src
-
-  -- Base language which the package is written in.
-  default-language:   Haskell2010
+    -- Directories containing source files.
+    hs-source-dirs:   src
 
+    -- Base language which the package is written in.
+    default-language: Haskell2010
 
 executable foo
-  -- .hs or .lhs file containing the Main module.
-  main-is:            Main.hs
-
-  -- Modules included in this executable, other than Main.
-  -- other-modules:
+    -- .hs or .lhs file containing the Main module.
+    main-is:          Main.hs
+    -- Modules included in this executable, other than Main.
+    -- other-modules:
+    -- LANGUAGE extensions used by modules in this package.
+    -- other-extensions:
 
-  -- LANGUAGE extensions used by modules in this package.
-  -- other-extensions:
+    -- Other library packages from which modules are imported.
+    build-depends:
+        base ^>=4.13.0.0,
+        containers ^>=5.7.0.0,
+        unordered-containers ^>=2.7.0.0
 
-  -- Other library packages from which modules are imported.
-  build-depends:      base ^>=4.13.0.0, containers ^>=5.7.0.0, unordered-containers ^>=2.7.0.0
-
-  -- Directories containing source files.
-  hs-source-dirs:     app
-
-  -- Base language which the package is written in.
-  default-language:   Haskell2010
+    -- Directories containing source files.
+    hs-source-dirs:   app
 
+    -- Base language which the package is written in.
+    default-language: Haskell2010
 
 test-suite foo-test
-  -- Base language which the package is written in.
-  default-language:   Haskell2010
-
-  -- The interface type and version of the test suite.
-  type:               exitcode-stdio-1.0
+    -- Base language which the package is written in.
+    default-language: Haskell2010
 
-  -- The directory where the test specifications are found.
-  hs-source-dirs:     tests
+    -- The interface type and version of the test suite.
+    type:             exitcode-stdio-1.0
 
-  -- The entrypoint to the test suite.
-  main-is:            MyLibTest.hs
+    -- Directories containing source files.
+    hs-source-dirs:   tests
 
-  -- Test dependencies.
-  build-depends:      base ^>=4.13.0.0, containers ^>=5.7.0.0, unordered-containers ^>=2.7.0.0
+    -- The entrypoint to the test suite.
+    main-is:          MyLibTest.hs
 
+    -- Test dependencies.
+    build-depends:
+        base ^>=4.13.0.0,
+        containers ^>=5.7.0.0,
+        unordered-containers ^>=2.7.0.0