Generate Paths module using zinza template

Cabal/Cabal.cabal

@@ -603,6 +603,7 @@ library
     Distribution.Lex
     Distribution.Utils.String
     Distribution.Simple.Build.Macros.Z
+    Distribution.Simple.Build.PathsModule.Z
     Distribution.Simple.GHC.EnvironmentParser
     Distribution.Simple.GHC.Internal
     Distribution.Simple.GHC.ImplInfo

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

@@ -0,0 +1,210 @@
+{-# LANGUAGE DeriveGeneric #-}
+module Distribution.Simple.Build.PathsModule.Z (render, Z(..)) where
+import Distribution.ZinzaPrelude
+data Z
+    = Z {zPackageName :: PackageName,
+         zVersionDigits :: String,
+         zSupportsCpp :: Bool,
+         zSupportsNoRebindableSyntax :: Bool,
+         zAbsolute :: Bool,
+         zRelocatable :: Bool,
+         zIsWindows :: Bool,
+         zIsI386 :: Bool,
+         zIsX8664 :: Bool,
+         zBindir :: FilePath,
+         zLibdir :: FilePath,
+         zDynlibdir :: FilePath,
+         zDatadir :: FilePath,
+         zLibexecdir :: FilePath,
+         zSysconfdir :: FilePath,
+         zNot :: (Bool -> Bool),
+         zManglePkgName :: (PackageName -> String)}
+    deriving Generic
+render :: Z -> String
+render z_root = execWriter $ do
+  if (zSupportsCpp z_root)
+  then do
+    tell "{-# LANGUAGE CPP #-}\n"
+    return ()
+  else do
+    return ()
+  if (zSupportsNoRebindableSyntax z_root)
+  then do
+    tell "{-# LANGUAGE NoRebindableSyntax #-}\n"
+    return ()
+  else do
+    return ()
+  if (zNot z_root (zAbsolute z_root))
+  then do
+    tell "{-# LANGUAGE ForeignFunctionInterface #-}\n"
+    return ()
+  else do
+    return ()
+  tell "{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}\n"
+  tell "module Paths_"
+  tell (zManglePkgName z_root (zPackageName z_root))
+  tell " (\n"
+  tell "    version,\n"
+  tell "    getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,\n"
+  tell "    getDataFileName, getSysconfDir\n"
+  tell "  ) where\n"
+  tell "\n"
+  if (zNot z_root (zAbsolute z_root))
+  then do
+    tell "import Foreign\n"
+    tell "import Foreign.C\n"
+    return ()
+  else do
+    return ()
+  tell "\n"
+  tell "import qualified Control.Exception as Exception\n"
+  tell "import Data.Version (Version(..))\n"
+  tell "import System.Environment (getEnv)\n"
+  tell "import Prelude\n"
+  tell "\n"
+  if (zRelocatable z_root)
+  then do
+    tell "import System.Environment (getExecutablePath)\n"
+    return ()
+  else do
+    return ()
+  tell "\n"
+  if (zSupportsCpp z_root)
+  then do
+    tell "#if defined(VERSION_base)\n"
+    tell "\n"
+    tell "#if MIN_VERSION_base(4,0,0)\n"
+    tell "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"
+    tell "#else\n"
+    tell "catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a\n"
+    tell "#endif\n"
+    tell "\n"
+    tell "#else\n"
+    tell "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"
+    tell "#endif\n"
+    tell "catchIO = Exception.catch\n"
+    return ()
+  else do
+    tell "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"
+    tell "catchIO = Exception.catch\n"
+    return ()
+  tell "\n"
+  tell "version :: Version\n"
+  tell "version = Version "
+  tell (zVersionDigits z_root)
+  tell " []\n"
+  tell "\n"
+  tell "bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath\n"
+  tell "\n"
+  tell "\n"
+  if (zRelocatable z_root)
+  then do
+    tell "\n"
+    tell "relocatableImpl = _\n"
+    tell "\n"
+    return ()
+  else do
+    if (zAbsolute z_root)
+    then do
+      tell "bindir     = "
+      tell (zBindir z_root)
+      tell "\n"
+      tell "libdir     = "
+      tell (zLibdir z_root)
+      tell "\n"
+      tell "dynlibdir  = "
+      tell (zDynlibdir z_root)
+      tell "\n"
+      tell "datadir    = "
+      tell (zDatadir z_root)
+      tell "\n"
+      tell "libexecdir = "
+      tell (zLibexecdir z_root)
+      tell "\n"
+      tell "sysconfdir = "
+      tell (zSysconfdir z_root)
+      tell "\n"
+      tell "\n"
+      tell "getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n"
+      tell "getBinDir     = catchIO (getEnv \""
+      tell (zManglePkgName z_root (zPackageName z_root))
+      tell "_bindir\")     (\\_ -> return bindir)\n"
+      tell "getLibDir     = catchIO (getEnv \""
+      tell (zManglePkgName z_root (zPackageName z_root))
+      tell "_libdir\")     (\\_ -> return libdir)\n"
+      tell "getDynLibDir  = catchIO (getEnv \""
+      tell (zManglePkgName z_root (zPackageName z_root))
+      tell "_dynlibdir\")  (\\_ -> return dynlibdir)\n"
+      tell "getDataDir    = catchIO (getEnv \""
+      tell (zManglePkgName z_root (zPackageName z_root))
+      tell "_datadir\")    (\\_ -> return datadir)\n"
+      tell "getLibexecDir = catchIO (getEnv \""
+      tell (zManglePkgName z_root (zPackageName z_root))
+      tell "_libexecdir\") (\\_ -> return libexecdir)\n"
+      tell "getSysconfDir = catchIO (getEnv \""
+      tell (zManglePkgName z_root (zPackageName z_root))
+      tell "_sysconfdir\") (\\_ -> return sysconfdir)\n"
+      tell "\n"
+      tell "getDataFileName :: FilePath -> IO FilePath\n"
+      tell "getDataFileName name = do\n"
+      tell "  dir <- getDataDir\n"
+      tell "  return (dir ++ \"/\" ++ name)\n"
+      return ()
+    else do
+      tell "\n"
+      tell "absoluteImpl = _\n"
+      tell "\n"
+      return ()
+    return ()
+  tell "\n"
+  if (zNot z_root (zAbsolute z_root))
+  then do
+    tell "\n"
+    tell "minusFileName :: FilePath -> String -> FilePath\n"
+    tell "minusFileName dir \"\"     = dir\n"
+    tell "minusFileName dir \".\"    = dir\n"
+    tell "minusFileName dir suffix =\n"
+    tell "  minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix))\n"
+    tell "\n"
+    tell "joinFileName :: String -> String -> FilePath\n"
+    tell "joinFileName \"\"  fname = fname\n"
+    tell "joinFileName \".\" fname = fname\n"
+    tell "joinFileName dir \"\"    = dir\n"
+    tell "joinFileName dir fname\n"
+    tell "  | isPathSeparator (last dir) = dir++fname\n"
+    tell "  | otherwise                  = dir++pathSeparator:fname\n"
+    tell "\n"
+    tell "splitFileName :: FilePath -> (String, String)\n"
+    tell "splitFileName p = (reverse (path2++drive), reverse fname)\n"
+    tell "  where\n"
+    tell "    (path,drive) = case p of\n"
+    tell "       (c:':':p') -> (reverse p',[':',c])\n"
+    tell "       _          -> (reverse p ,\"\")\n"
+    tell "    (fname,path1) = break isPathSeparator path\n"
+    tell "    path2 = case path1 of\n"
+    tell "      []                           -> \".\"\n"
+    tell "      [_]                          -> path1   -- don't remove the trailing slash if\n"
+    tell "                                              -- there is only one character\n"
+    tell "      (c:path') | isPathSeparator c -> path'\n"
+    tell "      _                             -> path1\n"
+    tell "\n"
+    tell "pathSeparator :: Char\n"
+    if (zIsWindows z_root)
+    then do
+      tell "pathSeparator = '\\\\'\n"
+      return ()
+    else do
+      tell "pathSeparator = '/'\n"
+      return ()
+    tell "\n"
+    tell "isPathSeparator :: Char -> Bool\n"
+    if (zIsWindows z_root)
+    then do
+      tell "isPathSeparator c = c == '/' || c == '\\\\'\n"
+      return ()
+    else do
+      tell "isPathSeparator c = c == '/'\n"
+      return ()
+    return ()
+  else do
+    return ()

Makefile

@@ -50,12 +50,16 @@ $(SPDX_EXCEPTION_HS) : templates/SPDX.LicenseExceptionId.template.hs cabal-dev-s
 # source generation: templates
 
 TEMPLATE_MACROS:=Cabal/src/Distribution/Simple/Build/Macros/Z.hs
+TEMPLATE_PATHS:=Cabal/src/Distribution/Simple/Build/PathsModule/Z.hs
 
-templates : phony $(TEMPLATE_MACROS)
+templates : phony $(TEMPLATE_MACROS) $(TEMPLATE_PATHS)
 
 $(TEMPLATE_MACROS) : templates/cabal_macros.template.h cabal-dev-scripts/src/GenCabalMacros.hs
 	cabal v2-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 v2-run --builddir=dist-newstyle-meta --project-file=cabal.project.meta gen-paths-module -- $< $@
+
 # generated docs
 
 buildinfo-fields-reference : phony

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

@@ -93,6 +93,20 @@ executable gen-cabal-macros
     , template-haskell
     , zinza             ^>=0.2
 
+executable gen-paths-module
+  default-language: Haskell2010
+  main-is:          GenPathsModule.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/GenPathsModule.hs

@@ -0,0 +1,103 @@
+{-# 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 Distribution.Types.Version     (Version)
+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
+        , zSupportsCpp                :: Bool
+        , zSupportsNoRebindableSyntax :: Bool
+        , zAbsolute                   :: Bool
+        , zRelocatable                :: Bool
+        , zIsWindows                  :: Bool
+        , zIsI386                     :: Bool
+        , zIsX8664                    :: Bool
+
+
+        , zBindir     :: FilePath
+        , zLibdir     :: FilePath
+        , zDynlibdir  :: FilePath
+        , zDatadir    :: FilePath
+        , zLibexecdir :: FilePath
+        , zSysconfdir :: FilePath
+
+        , zNot                        :: Bool -> Bool
+        , zManglePkgName              :: PackageName -> 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 v2-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 =
+        [ "{-# LANGUAGE DeriveGeneric #-}"
+        , "module Distribution.Simple.Build.PathsModule.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"
+
+instance Zinza Version where
+    toType _    = TyString (Just "prettyShow")
+    toValue _   = error "not needed"
+    fromValue _ = error "not needed"