Use Zinza to generate .../PackageInfoModule/z.hs

Cabal/src/Distribution/Simple/Build/PackageInfoModule.hs

@@ -38,13 +38,15 @@ generatePackageInfoModule :: PackageDescription -> LocalBuildInfo -> String
 generatePackageInfoModule pkg_descr lbi =
   Z.render
     Z.Z
-      { Z.zPackageName = showPkgName $ packageName pkg_descr
+      { Z.zPackageName = packageName pkg_descr
       , Z.zVersionDigits = show $ versionNumbers $ packageVersion pkg_descr
-      , Z.zSynopsis = fromShortText $ synopsis pkg_descr
-      , Z.zCopyright = fromShortText $ copyright pkg_descr
-      , Z.zLicense = prettyShow $ license pkg_descr
-      , Z.zHomepage = fromShortText $ homepage pkg_descr
+      , Z.zSynopsis = show $ fromShortText $ synopsis pkg_descr
+      , Z.zCopyright = show $ fromShortText $ copyright pkg_descr
+      , Z.zLicense = show $ prettyShow $ license pkg_descr
+      , Z.zHomepage = show $ fromShortText $ homepage pkg_descr
       , Z.zSupportsNoRebindableSyntax = supports_rebindable_syntax
+      , Z.zManglePkgName = showPkgName
+      , Z.zShow = show
       }
   where
     supports_rebindable_syntax = ghc_newer_than (mkVersion [7, 0, 1])

Cabal/src/Distribution/Simple/Build/PackageInfoModule/Z.hs

@@ -1,47 +1,46 @@
+{- FOURMOLU_DISABLE -}
 {-# LANGUAGE DeriveGeneric #-}
-
-module Distribution.Simple.Build.PackageInfoModule.Z (render, Z (..)) where
-
+module Distribution.Simple.Build.PackageInfoModule.Z (render, Z(..)) where
 import Distribution.ZinzaPrelude
-
-data Z = Z
-  { zPackageName :: String
-  , zVersionDigits :: String
-  , zSynopsis :: String
-  , zCopyright :: String
-  , zLicense :: String
-  , zHomepage :: String
-  , zSupportsNoRebindableSyntax :: Bool
-  }
-  deriving (Generic)
-
+data Z
+    = Z {zPackageName :: PackageName,
+         zVersionDigits :: String,
+         zSynopsis :: String,
+         zCopyright :: String,
+         zLicense :: String,
+         zHomepage :: String,
+         zSupportsNoRebindableSyntax :: Bool,
+         zManglePkgName :: (PackageName -> String),
+         zShow :: (String -> String)}
+    deriving Generic
 render :: Z -> String
 render z_root = execWriter $ do
   if (zSupportsNoRebindableSyntax z_root)
-    then do
-      tell "{-# LANGUAGE NoRebindableSyntax #-}\n"
-      return ()
-    else do
-      return ()
+  then do
+    tell "{-# LANGUAGE NoRebindableSyntax #-}\n"
+    return ()
+  else do
+    return ()
   tell "{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}\n"
   tell "{-# OPTIONS_GHC -w #-}\n"
   tell "module PackageInfo_"
-  tell (zPackageName z_root)
-  tell " (\n"
-  tell "    name,\n"
-  tell "    version,\n"
-  tell "    synopsis,\n"
-  tell "    copyright,\n"
-  tell "    license, \n"
-  tell "    homepage,\n"
+  tell (zManglePkgName z_root (zPackageName z_root))
+  tell "\n"
+  tell "  ( name\n"
+  tell "  , version\n"
+  tell "  , synopsis\n"
+  tell "  , copyright\n"
+  tell "  , license\n"
+  tell "  , homepage\n"
   tell "  ) where\n"
   tell "\n"
   tell "import Data.Version (Version(..))\n"
   tell "import Prelude\n"
   tell "\n"
   tell "name :: String\n"
   tell "name = "
-  tell (show $ zPackageName z_root)
+  tell (zShow z_root (zManglePkgName z_root (zPackageName z_root)))
+  tell "\n"
   tell "\n"
   tell "version :: Version\n"
   tell "version = Version "
@@ -50,17 +49,21 @@ render z_root = execWriter $ do
   tell "\n"
   tell "synopsis :: String\n"
   tell "synopsis = "
-  tell (show $ zSynopsis z_root)
+  tell (zSynopsis z_root)
+  tell "\n"
   tell "\n"
   tell "copyright :: String\n"
   tell "copyright = "
-  tell (show $ zCopyright z_root)
+  tell (zCopyright z_root)
+  tell "\n"
   tell "\n"
   tell "license :: String\n"
   tell "license = "
-  tell (show $ zLicense z_root)
+  tell (zLicense z_root)
+  tell "\n"
   tell "\n"
   tell "homepage :: String\n"
   tell "homepage = "
-  tell (show $ zHomepage z_root)
+  tell (zHomepage z_root)
+  tell "\n"
   tell "\n"

Makefile

@@ -44,15 +44,19 @@ $(SPDX_EXCEPTION_HS) : templates/SPDX.LicenseExceptionId.template.hs cabal-dev-s
 
 TEMPLATE_MACROS:=Cabal/src/Distribution/Simple/Build/Macros/Z.hs
 TEMPLATE_PATHS:=Cabal/src/Distribution/Simple/Build/PathsModule/Z.hs
+TEMPLATE_PKGINFO:=Cabal/src/Distribution/Simple/Build/PackageInfoModule/Z.hs
 
-templates : phony $(TEMPLATE_MACROS) $(TEMPLATE_PATHS)
+templates : phony $(TEMPLATE_MACROS) $(TEMPLATE_PATHS) $(TEMPLATE_PKGINFO)
 
 $(TEMPLATE_MACROS) : templates/cabal_macros.template.h cabal-dev-scripts/src/GenCabalMacros.hs
 	cabal run --builddir=dist-newstyle-meta --project-file=cabal.project.meta gen-cabal-macros -- $< $@
 
 $(TEMPLATE_PATHS) : templates/Paths_pkg.template.hs cabal-dev-scripts/src/GenPathsModule.hs
 	cabal run --builddir=dist-newstyle-meta --project-file=cabal.project.meta gen-paths-module -- $< $@
 
+$(TEMPLATE_PKGINFO) : templates/PackageInfo_pkg.template.hs cabal-dev-scripts/src/GenPackageInfoModule.hs
+	cabal run --builddir=dist-newstyle-meta --project-file=cabal.project.meta gen-pkg-info-module -- $< $@
+
 # generated docs
 
 buildinfo-fields-reference : phony

cabal-dev-scripts/cabal-dev-scripts.cabal

@@ -18,7 +18,7 @@ executable gen-spdx
   ghc-options:      -Wall
   build-depends:
     , aeson                 ^>=1.4.1.0 || ^>=1.5.2.0 || ^>=2.1.1.0
-    , base                  >=4.10     && <4.17
+    , base                  >=4.10
     , bytestring
     , containers
     , Diff                  ^>=0.4
@@ -35,7 +35,7 @@ executable gen-spdx-exc
   ghc-options:      -Wall
   build-depends:
     , aeson                 ^>=1.4.1.0 || ^>=1.5.2.0 || ^>=2.1.1.0
-    , base                  >=4.10     && <4.17
+    , base                  >=4.10
     , bytestring
     , containers
     , Diff                  ^>=0.4
@@ -84,6 +84,20 @@ executable gen-paths-module
     , template-haskell
     , zinza             ^>=0.2
 
+executable gen-pkg-info-module
+  default-language: Haskell2010
+  main-is:          GenPackageInfoModule.hs
+  other-modules:    Capture
+  hs-source-dirs:   src
+  ghc-options:      -Wall
+  build-depends:
+    , base
+    , bytestring
+    , Cabal
+    , syb               ^>=0.7.1
+    , template-haskell
+    , zinza             ^>=0.2
+
 executable gen-cabal-install-cabal
   default-language: Haskell2010
   main-is:          GenCabalInstallCabal.hs

cabal-dev-scripts/src/GenPackageInfoModule.hs

@@ -0,0 +1,89 @@
+{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE GADTs               #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+module Main (main) where
+
+import Control.Exception              (SomeException (..), catch, displayException)
+import Distribution.Types.PackageName (PackageName)
+import GHC.Generics                   (Generic)
+import System.Environment             (getArgs)
+import System.Exit                    (exitFailure)
+import Zinza
+       (ModuleConfig (..), Ty (..), Zinza (..), genericFromValueSFP, genericToTypeSFP,
+       genericToValueSFP, parseAndCompileModuleIO)
+
+import Capture
+
+-------------------------------------------------------------------------------
+-- Inputs
+-------------------------------------------------------------------------------
+
+$(capture "decls" [d|
+    data Z = Z
+        { zPackageName                :: PackageName
+        , zVersionDigits              :: String
+        , zSynopsis                   :: String
+        , zCopyright                  :: String
+        , zLicense                    :: String
+        , zHomepage                   :: String
+
+        , zSupportsNoRebindableSyntax :: Bool
+
+        , zManglePkgName              :: PackageName -> String
+        , zShow                       :: String -> String
+        }
+      deriving (Generic)
+    |])
+
+-------------------------------------------------------------------------------
+-- Main
+-------------------------------------------------------------------------------
+
+withIO :: (FilePath -> FilePath -> IO a) -> IO a
+withIO k = do
+    args <- getArgs
+    case args of
+        [src,tgt] -> k src tgt `catch` \(SomeException e) -> do
+            putStrLn $ "Exception: " ++ displayException e
+            exitFailure
+        _         -> do
+            putStrLn "Usage cabal run ... source.temeplate.ext target.ext"
+            exitFailure
+
+main :: IO ()
+main = withIO $ \src tgt -> do
+    mdl <- parseAndCompileModuleIO config src
+    writeFile tgt mdl
+
+config :: ModuleConfig Z
+config = ModuleConfig
+    { mcRender = "render"
+    , mcHeader =
+        [ "{- FOURMOLU_DISABLE -}"
+        , "{-# LANGUAGE DeriveGeneric #-}"
+        , "module Distribution.Simple.Build.PackageInfoModule.Z (render, Z(..)) where"
+        , "import Distribution.ZinzaPrelude"
+        , decls
+        , "render :: Z -> String"
+        ]
+    }
+
+-------------------------------------------------------------------------------
+-- Zinza instances
+-------------------------------------------------------------------------------
+
+instance Zinza Z where
+    toType    = genericToTypeSFP
+    toValue   = genericToValueSFP
+    fromValue = genericFromValueSFP
+
+-------------------------------------------------------------------------------
+-- Orphans
+-------------------------------------------------------------------------------
+
+instance Zinza PackageName where
+    toType _    = TyString (Just "prettyShow")
+    toValue _   = error "not needed"
+    fromValue _ = error "not needed"

templates/PackageInfo_pkg.template.hs

@@ -0,0 +1,35 @@
+{% if supportsNoRebindableSyntax %}
+{-# LANGUAGE NoRebindableSyntax #-}
+{% endif %}
+{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}
+{-# OPTIONS_GHC -w #-}
+module PackageInfo_{{ manglePkgName packageName }}
+  ( name
+  , version
+  , synopsis
+  , copyright
+  , license
+  , homepage
+  ) where
+
+import Data.Version (Version(..))
+import Prelude
+
+name :: String
+name = {{ show (manglePkgName packageName) }}
+
+version :: Version
+version = Version {{ versionDigits }} []
+
+synopsis :: String
+synopsis = {{ synopsis }}
+
+copyright :: String
+copyright = {{ copyright }}
+
+license :: String
+license = {{ license }}
+
+homepage :: String
+homepage = {{ homepage }}
+