From fe9a5243b48de8081320d3c771fd31e29a2960ce Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Wed, 22 Jul 2020 11:57:50 +0300 Subject: [PATCH] Generate Paths module using zinza template --- Cabal/Cabal.cabal | 1 + .../Distribution/Simple/Build/PathsModule.hs | 421 +++++------------- .../Simple/Build/PathsModule/Z.hs | 316 +++++++++++++ Makefile | 6 +- cabal-dev-scripts/cabal-dev-scripts.cabal | 14 + cabal-dev-scripts/src/GenPathsModule.hs | 103 +++++ templates/Paths_pkg.template.hs | 183 ++++++++ 7 files changed, 737 insertions(+), 307 deletions(-) create mode 100644 Cabal/src/Distribution/Simple/Build/PathsModule/Z.hs create mode 100644 cabal-dev-scripts/src/GenPathsModule.hs create mode 100644 templates/Paths_pkg.template.hs diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index 3ce98211c42..ecd7ce2647e 100644 --- a/Cabal/Cabal.cabal +++ b/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 diff --git a/Cabal/src/Distribution/Simple/Build/PathsModule.hs b/Cabal/src/Distribution/Simple/Build/PathsModule.hs index 5e660e8d655..8288d287900 100644 --- a/Cabal/src/Distribution/Simple/Build/PathsModule.hs +++ b/Cabal/src/Distribution/Simple/Build/PathsModule.hs @@ -18,337 +18,146 @@ module Distribution.Simple.Build.PathsModule ( generatePathsModule, pkgPathEnvVar ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.System -import Distribution.Simple.Compiler import Distribution.Package import Distribution.PackageDescription +import Distribution.Simple.Compiler import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.BuildPaths -import Distribution.Simple.Utils -import Distribution.Pretty +import Distribution.Simple.Utils (shortRelativePath) +import Distribution.System import Distribution.Version -import System.FilePath ( pathSeparator ) +import qualified Distribution.Simple.Build.PathsModule.Z as Z -- ------------------------------------------------------------ -- * Building Paths_.hs -- ------------------------------------------------------------ generatePathsModule :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> String -generatePathsModule pkg_descr lbi clbi = - let pragmas = - cpp_pragma - ++ no_rebindable_syntax_pragma - ++ ffi_pragmas - ++ warning_pragmas - - cpp_pragma - | supports_cpp = "{-# LANGUAGE CPP #-}\n" - | otherwise = "" - - -- -XRebindableSyntax is problematic because when paired with - -- -XOverloadedLists, 'fromListN' is not in scope, - -- or -XOverloadedStrings 'fromString' is not in scope, - -- so we disable 'RebindableSyntax'. - no_rebindable_syntax_pragma - | supports_rebindable_syntax = "{-# LANGUAGE NoRebindableSyntax #-}\n" - | otherwise = "" - - ffi_pragmas - | absolute = "" - | supports_language_pragma = - "{-# LANGUAGE ForeignFunctionInterface #-}\n" - | otherwise = - "{-# OPTIONS_GHC -fffi #-}\n" - - warning_pragmas = - "{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}\n" - - foreign_imports - | absolute = "" - | otherwise = - "import Foreign\n"++ - "import Foreign.C\n" - - reloc_imports - | reloc = - "import System.Environment (getExecutablePath)\n" - | otherwise = "" - - header = - pragmas++ - "module " ++ prettyShow paths_modulename ++ " (\n"++ - " version,\n"++ - " getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,\n"++ - " getDataFileName, getSysconfDir\n"++ - " ) where\n"++ - "\n"++ - foreign_imports++ - "import qualified Control.Exception as Exception\n"++ - "import Data.Version (Version(..))\n"++ - "import System.Environment (getEnv)\n"++ - reloc_imports ++ - "import Prelude\n"++ - "\n"++ - (if supports_cpp - then - ("#if defined(VERSION_base)\n"++ - "\n"++ - "#if MIN_VERSION_base(4,0,0)\n"++ - "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"++ - "#else\n"++ - "catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a\n"++ - "#endif\n"++ - "\n"++ - "#else\n"++ - "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"++ - "#endif\n") - else - "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n")++ - "catchIO = Exception.catch\n" ++ - "\n"++ - "version :: Version"++ - "\nversion = Version " ++ show branch ++ " []" - where branch = versionNumbers $ packageVersion pkg_descr - - body - | reloc = - "\n\nbindirrel :: FilePath\n" ++ - "bindirrel = " ++ show flat_bindirreloc ++ - "\n"++ - "\ngetBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n"++ - "getBinDir = "++mkGetEnvOrReloc "bindir" flat_bindirreloc++"\n"++ - "getLibDir = "++mkGetEnvOrReloc "libdir" flat_libdirreloc++"\n"++ - "getDynLibDir = "++mkGetEnvOrReloc "libdir" flat_dynlibdirreloc++"\n"++ - "getDataDir = "++mkGetEnvOrReloc "datadir" flat_datadirreloc++"\n"++ - "getLibexecDir = "++mkGetEnvOrReloc "libexecdir" flat_libexecdirreloc++"\n"++ - "getSysconfDir = "++mkGetEnvOrReloc "sysconfdir" flat_sysconfdirreloc++"\n"++ - "\n"++ - "getDataFileName :: FilePath -> IO FilePath\n"++ - "getDataFileName name = do\n"++ - " dir <- getDataDir\n"++ - " return (dir `joinFileName` name)\n"++ - "\n"++ - get_prefix_reloc_stuff++ - "\n"++ - filename_stuff - | absolute = - "\nbindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath\n"++ - "\nbindir = " ++ show flat_bindir ++ - "\nlibdir = " ++ show flat_libdir ++ - "\ndynlibdir = " ++ show flat_dynlibdir ++ - "\ndatadir = " ++ show flat_datadir ++ - "\nlibexecdir = " ++ show flat_libexecdir ++ - "\nsysconfdir = " ++ show flat_sysconfdir ++ - "\n"++ - "\ngetBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n"++ - "getBinDir = "++mkGetEnvOr "bindir" "return bindir"++"\n"++ - "getLibDir = "++mkGetEnvOr "libdir" "return libdir"++"\n"++ - "getDynLibDir = "++mkGetEnvOr "dynlibdir" "return dynlibdir"++"\n"++ - "getDataDir = "++mkGetEnvOr "datadir" "return datadir"++"\n"++ - "getLibexecDir = "++mkGetEnvOr "libexecdir" "return libexecdir"++"\n"++ - "getSysconfDir = "++mkGetEnvOr "sysconfdir" "return sysconfdir"++"\n"++ - "\n"++ - "getDataFileName :: FilePath -> IO FilePath\n"++ - "getDataFileName name = do\n"++ - " dir <- getDataDir\n"++ - " return (dir ++ "++path_sep++" ++ name)\n" - | otherwise = - "\nprefix, bindirrel :: FilePath" ++ - "\nprefix = " ++ show flat_prefix ++ - "\nbindirrel = " ++ show (fromMaybe (error "PathsModule.generate") flat_bindirrel) ++ - "\n\n"++ - "getBinDir :: IO FilePath\n"++ - "getBinDir = getPrefixDirRel bindirrel\n\n"++ - "getLibDir :: IO FilePath\n"++ - "getLibDir = "++mkGetDir flat_libdir flat_libdirrel++"\n\n"++ - "getDynLibDir :: IO FilePath\n"++ - "getDynLibDir = "++mkGetDir flat_dynlibdir flat_dynlibdirrel++"\n\n"++ - "getDataDir :: IO FilePath\n"++ - "getDataDir = "++ mkGetEnvOr "datadir" - (mkGetDir flat_datadir flat_datadirrel)++"\n\n"++ - "getLibexecDir :: IO FilePath\n"++ - "getLibexecDir = "++mkGetDir flat_libexecdir flat_libexecdirrel++"\n\n"++ - "getSysconfDir :: IO FilePath\n"++ - "getSysconfDir = "++mkGetDir flat_sysconfdir flat_sysconfdirrel++"\n\n"++ - "getDataFileName :: FilePath -> IO FilePath\n"++ - "getDataFileName name = do\n"++ - " dir <- getDataDir\n"++ - " return (dir `joinFileName` name)\n"++ - "\n"++ - get_prefix_stuff++ - "\n"++ - filename_stuff - in header++body - - where - cid = componentUnitId clbi +generatePathsModule pkg_descr lbi clbi = Z.render Z.Z + { Z.zPackageName = packageName pkg_descr + , Z.zVersionDigits = show $ versionNumbers $ packageVersion pkg_descr + , Z.zSupportsCpp = supports_cpp + , Z.zSupportsNoRebindableSyntax = supports_rebindable_syntax + , Z.zAbsolute = absolute + , Z.zRelocatable = relocatable lbi + , Z.zIsWindows = isWindows + , Z.zIsI386 = buildArch == I386 + , Z.zIsX8664 = buildArch == X86_64 + , Z.zNot = not + , Z.zManglePkgName = showPkgName + + , Z.zPrefix = show flat_prefix + , Z.zBindir = zBindir + , Z.zLibdir = zLibdir + , Z.zDynlibdir = zDynlibdir + , Z.zDatadir = zDatadir + , Z.zLibexecdir = zLibexecdir + , Z.zSysconfdir = zSysconfdir + } + where + supports_cpp = supports_language_pragma + supports_rebindable_syntax = ghc_newer_than (mkVersion [7,0,1]) + supports_language_pragma = ghc_newer_than (mkVersion [6,6,1]) + + ghc_newer_than minVersion = + case compilerCompatVersion GHC (compiler lbi) of + Nothing -> False + Just version -> version `withinRange` orLaterVersion minVersion - InstallDirs { - prefix = flat_prefix, - bindir = flat_bindir, - libdir = flat_libdir, - dynlibdir = flat_dynlibdir, - datadir = flat_datadir, - libexecdir = flat_libexecdir, - sysconfdir = flat_sysconfdir + -- In several cases we cannot make relocatable installations + absolute = + hasLibs pkg_descr -- we can only make progs relocatable + || isNothing flat_bindirrel -- if the bin dir is an absolute path + || not (supportsRelocatableProgs (compilerFlavor (compiler lbi))) + + -- TODO: Here, and with zIsI386 & zIs8664 we should use TARGET platform + isWindows = case buildOS of + Windows -> True + _ -> False + + supportsRelocatableProgs GHC = isWindows + supportsRelocatableProgs GHCJS = isWindows + supportsRelocatableProgs _ = False + + cid = componentUnitId clbi + + InstallDirs + { bindir = flat_bindir + , libdir = flat_libdir + , dynlibdir = flat_dynlibdir + , datadir = flat_datadir + , libexecdir = flat_libexecdir + , sysconfdir = flat_sysconfdir + , prefix = flat_prefix } = absoluteInstallCommandDirs pkg_descr lbi cid NoCopyDest - InstallDirs { - bindir = flat_bindirrel, - libdir = flat_libdirrel, - dynlibdir = flat_dynlibdirrel, - datadir = flat_datadirrel, - libexecdir = flat_libexecdirrel, - sysconfdir = flat_sysconfdirrel + InstallDirs + { bindir = flat_bindirrel + , libdir = flat_libdirrel + , dynlibdir = flat_dynlibdirrel + , datadir = flat_datadirrel + , libexecdir = flat_libexecdirrel + , sysconfdir = flat_sysconfdirrel } = prefixRelativeComponentInstallDirs (packageId pkg_descr) lbi cid - flat_bindirreloc = shortRelativePath flat_prefix flat_bindir - flat_libdirreloc = shortRelativePath flat_prefix flat_libdir - flat_dynlibdirreloc = shortRelativePath flat_prefix flat_dynlibdir - flat_datadirreloc = shortRelativePath flat_prefix flat_datadir - flat_libexecdirreloc = shortRelativePath flat_prefix flat_libexecdir - flat_sysconfdirreloc = shortRelativePath flat_prefix flat_sysconfdir - - mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel - mkGetDir dir Nothing = "return " ++ show dir - - mkGetEnvOrReloc var dirrel = "catchIO (getEnv \""++var'++"\")" ++ - " (\\_ -> getPrefixDirReloc \"" ++ dirrel ++ - "\")" - where var' = pkgPathEnvVar pkg_descr var - - mkGetEnvOr var expr = "catchIO (getEnv \""++var'++"\")"++ - " (\\_ -> "++expr++")" - where var' = pkgPathEnvVar pkg_descr var - - -- In several cases we cannot make relocatable installations - absolute = - hasLibs pkg_descr -- we can only make progs relocatable - || isNothing flat_bindirrel -- if the bin dir is an absolute path - || not (supportsRelocatableProgs (compilerFlavor (compiler lbi))) - - reloc = relocatable lbi - - supportsRelocatableProgs GHC = case buildOS of - Windows -> True - _ -> False - supportsRelocatableProgs GHCJS = case buildOS of - Windows -> True - _ -> False - supportsRelocatableProgs _ = False - - paths_modulename = autogenPathsModuleName pkg_descr - - get_prefix_stuff = get_prefix_win32 supports_cpp buildArch - - path_sep = show [pathSeparator] - - supports_cpp = supports_language_pragma - supports_rebindable_syntax= ghc_newer_than (mkVersion [7,0,1]) - supports_language_pragma = ghc_newer_than (mkVersion [6,6,1]) - - ghc_newer_than minVersion = - case compilerCompatVersion GHC (compiler lbi) of - Nothing -> False - Just version -> version `withinRange` orLaterVersion minVersion + zBindir, zLibdir, zDynlibdir, zDatadir, zLibexecdir, zSysconfdir :: String + (zBindir, zLibdir, zDynlibdir, zDatadir, zLibexecdir, zSysconfdir) + | relocatable lbi = + ( show flat_bindir_reloc + , show flat_libdir_reloc + , show flat_dynlibdir_reloc + , show flat_datadir_reloc + , show flat_libexecdir_reloc + , show flat_sysconfdir_reloc + ) + | absolute = + ( show flat_bindir + , show flat_libdir + , show flat_dynlibdir + , show flat_datadir + , show flat_libexecdir + , show flat_sysconfdir + ) + | isWindows = + ( "maybe (error \"PathsModule.generate\") id (" ++ show flat_bindirrel ++ ")" + , mkGetDir flat_libdir flat_libdirrel + , mkGetDir flat_dynlibdir flat_dynlibdirrel + , mkGetDir flat_datadir flat_datadirrel + , mkGetDir flat_libexecdir flat_libexecdirrel + , mkGetDir flat_sysconfdir flat_sysconfdirrel + ) + | otherwise = + error "panic! generatePathsModule: should never happen" + + mkGetDir :: FilePath -> Maybe FilePath -> String + mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel + mkGetDir dir Nothing = "return " ++ show dir + + flat_bindir_reloc = shortRelativePath flat_prefix flat_bindir + flat_libdir_reloc = shortRelativePath flat_prefix flat_libdir + flat_dynlibdir_reloc = shortRelativePath flat_prefix flat_dynlibdir + flat_datadir_reloc = shortRelativePath flat_prefix flat_datadir + flat_libexecdir_reloc = shortRelativePath flat_prefix flat_libexecdir + flat_sysconfdir_reloc = shortRelativePath flat_prefix flat_sysconfdir -- | Generates the name of the environment variable controlling the path -- component of interest. -- -- Note: The format of these strings is part of Cabal's public API; -- changing this function constitutes a *backwards-compatibility* break. -pkgPathEnvVar :: PackageDescription - -> String -- ^ path component; one of \"bindir\", \"libdir\", - -- \"datadir\", \"libexecdir\", or \"sysconfdir\" - -> String -- ^ environment variable name +pkgPathEnvVar + :: PackageDescription + -> String -- ^ path component; one of \"bindir\", \"libdir\", -- \"datadir\", \"libexecdir\", or \"sysconfdir\" + -> String -- ^ environment variable name pkgPathEnvVar pkg_descr var = showPkgName (packageName pkg_descr) ++ "_" ++ var - where - showPkgName = map fixchar . prettyShow - fixchar '-' = '_' - fixchar c = c - -get_prefix_reloc_stuff :: String -get_prefix_reloc_stuff = - "getPrefixDirReloc :: FilePath -> IO FilePath\n"++ - "getPrefixDirReloc dirRel = do\n"++ - " exePath <- getExecutablePath\n"++ - " let (bindir,_) = splitFileName exePath\n"++ - " return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n" -get_prefix_win32 :: Bool -> Arch -> String -get_prefix_win32 supports_cpp arch = - "getPrefixDirRel :: FilePath -> IO FilePath\n"++ - "getPrefixDirRel dirRel = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.\n"++ - " where\n"++ - " try_size size = allocaArray (fromIntegral size) $ \\buf -> do\n"++ - " ret <- c_GetModuleFileName nullPtr buf size\n"++ - " case ret of\n"++ - " 0 -> return (prefix `joinFileName` dirRel)\n"++ - " _ | ret < size -> do\n"++ - " exePath <- peekCWString buf\n"++ - " let (bindir,_) = splitFileName exePath\n"++ - " return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n"++ - " | otherwise -> try_size (size * 2)\n"++ - "\n"++ - (case supports_cpp of - False -> "" - True -> "#if defined(i386_HOST_ARCH)\n"++ - "# define WINDOWS_CCONV stdcall\n"++ - "#elif defined(x86_64_HOST_ARCH)\n"++ - "# define WINDOWS_CCONV ccall\n"++ - "#else\n"++ - "# error Unknown mingw32 arch\n"++ - "#endif\n")++ - "foreign import " ++ cconv ++ " unsafe \"windows.h GetModuleFileNameW\"\n"++ - " c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" - where cconv = if supports_cpp - then "WINDOWS_CCONV" - else case arch of - I386 -> "stdcall" - X86_64 -> "ccall" - _ -> error "win32 supported only with I386, X86_64" +showPkgName :: PackageName -> String +showPkgName = map fixchar . unPackageName -filename_stuff :: String -filename_stuff = - "minusFileName :: FilePath -> String -> FilePath\n"++ - "minusFileName dir \"\" = dir\n"++ - "minusFileName dir \".\" = dir\n"++ - "minusFileName dir suffix =\n"++ - " minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix))\n"++ - "\n"++ - "joinFileName :: String -> String -> FilePath\n"++ - "joinFileName \"\" fname = fname\n"++ - "joinFileName \".\" fname = fname\n"++ - "joinFileName dir \"\" = dir\n"++ - "joinFileName dir fname\n"++ - " | isPathSeparator (last dir) = dir++fname\n"++ - " | otherwise = dir++pathSeparator:fname\n"++ - "\n"++ - "splitFileName :: FilePath -> (String, String)\n"++ - "splitFileName p = (reverse (path2++drive), reverse fname)\n"++ - " where\n"++ - " (path,drive) = case p of\n"++ - " (c:':':p') -> (reverse p',[':',c])\n"++ - " _ -> (reverse p ,\"\")\n"++ - " (fname,path1) = break isPathSeparator path\n"++ - " path2 = case path1 of\n"++ - " [] -> \".\"\n"++ - " [_] -> path1 -- don't remove the trailing slash if \n"++ - " -- there is only one character\n"++ - " (c:path') | isPathSeparator c -> path'\n"++ - " _ -> path1\n"++ - "\n"++ - "pathSeparator :: Char\n"++ - (case buildOS of - Windows -> "pathSeparator = '\\\\'\n" - _ -> "pathSeparator = '/'\n") ++ - "\n"++ - "isPathSeparator :: Char -> Bool\n"++ - (case buildOS of - Windows -> "isPathSeparator c = c == '/' || c == '\\\\'\n" - _ -> "isPathSeparator c = c == '/'\n") +fixchar :: Char -> Char +fixchar '-' = '_' +fixchar c = c diff --git a/Cabal/src/Distribution/Simple/Build/PathsModule/Z.hs b/Cabal/src/Distribution/Simple/Build/PathsModule/Z.hs new file mode 100644 index 00000000000..03bf83e5366 --- /dev/null +++ b/Cabal/src/Distribution/Simple/Build/PathsModule/Z.hs @@ -0,0 +1,316 @@ +{-# 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, + zPrefix :: FilePath, + 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 "getDataFileName :: FilePath -> IO FilePath\n" + tell "getDataFileName name = do\n" + tell " dir <- getDataDir\n" + tell " return (dir `joinFileName` name)\n" + tell "\n" + tell "getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n" + tell "\n" + tell "\n" + if (zRelocatable z_root) + then do + tell "\n" + tell "getPrefixDirReloc :: FilePath -> IO FilePath\n" + tell "getPrefixDirReloc dirRel = do\n" + tell " exePath <- getExecutablePath\n" + tell " let (dir,_) = splitFileName exePath\n" + tell " return ((dir `minusFileName` " + tell (zBindir z_root) + tell ") `joinFileName` dirRel)\n" + tell "\n" + tell "getBinDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_bindir\") (\\_ -> getPrefixDirReloc $ " + tell (zBindir z_root) + tell ")\n" + tell "getLibDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_libdir\") (\\_ -> getPrefixDirReloc $ " + tell (zLibdir z_root) + tell ")\n" + tell "getDynLibDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_dynlibdir\") (\\_ -> getPrefixDirReloc $ " + tell (zDynlibdir z_root) + tell ")\n" + tell "getDataDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_datadir\") (\\_ -> getPrefixDirReloc $ " + tell (zDatadir z_root) + tell ")\n" + tell "getLibexecDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_libexecdir\") (\\_ -> getPrefixDirReloc $ " + tell (zLibexecdir z_root) + tell ")\n" + tell "getSysconfDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_sysconfdir\") (\\_ -> getPrefixDirReloc $ " + tell (zSysconfdir z_root) + tell ")\n" + tell "\n" + return () + else do + if (zAbsolute z_root) + then do + tell "\n" + tell "bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath\n" + 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 = 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" + return () + else do + if (zIsWindows z_root) + then do + tell "\n" + tell "prefix :: FilePath\n" + tell "prefix = " + tell (zPrefix z_root) + tell "\n" + tell "\n" + tell "getBinDir = getPrefixDirRel $ " + tell (zBindir z_root) + tell "\n" + tell "getLibDir = " + tell (zLibdir z_root) + tell "\n" + tell "getDynLibDir = " + tell (zDynlibdir z_root) + tell "\n" + tell "getDataDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_datadir\") (\\_ -> " + tell (zDatadir z_root) + tell ")\n" + tell "getLibexecDir = " + tell (zLibexecdir z_root) + tell "\n" + tell "getSysconfDir = " + tell (zSysconfdir z_root) + tell "\n" + tell "\n" + tell "getPrefixDirRel :: FilePath -> IO FilePath\n" + tell "getPrefixDirRel dirRel = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.\n" + tell " where\n" + tell " try_size size = allocaArray (fromIntegral size) $ \\buf -> do\n" + tell " ret <- c_GetModuleFileName nullPtr buf size\n" + tell " case ret of\n" + tell " 0 -> return (prefix `joinFileName` dirRel)\n" + tell " _ | ret < size -> do\n" + tell " exePath <- peekCWString buf\n" + tell " let (bindir,_) = splitFileName exePath\n" + tell " return ((bindir `minusFileName` " + tell (zBindir z_root) + tell ") `joinFileName` dirRel)\n" + tell " | otherwise -> try_size (size * 2)\n" + tell "\n" + if (zIsI386 z_root) + then do + tell "foreign import stdcall unsafe \"windows.h GetModuleFileNameW\"\n" + tell " c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" + return () + else do + if (zIsX8664 z_root) + then do + tell "foreign import ccall unsafe \"windows.h GetModuleFileNameW\"\n" + tell " c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" + return () + else do + tell "-- win32 supported only with I386, X86_64\n" + tell "c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" + tell "c_GetModuleFileName = _\n" + return () + return () + tell "\n" + return () + else do + tell "\n" + tell "notRelocAbsoluteOrWindows :: ()\n" + tell "notRelocAbsoluteOrWindows = _\n" + tell "\n" + return () + return () + return () + tell "\n" + tell "\n" + if (zNot z_root (zAbsolute z_root)) + then do + 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 "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" + return () + else do + return () + 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 "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 () diff --git a/Makefile b/Makefile index 1274ea7e694..2ae15f2da84 100644 --- a/Makefile +++ b/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 diff --git a/cabal-dev-scripts/cabal-dev-scripts.cabal b/cabal-dev-scripts/cabal-dev-scripts.cabal index 3787e8cc80c..c13e714c840 100644 --- a/cabal-dev-scripts/cabal-dev-scripts.cabal +++ b/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 diff --git a/cabal-dev-scripts/src/GenPathsModule.hs b/cabal-dev-scripts/src/GenPathsModule.hs new file mode 100644 index 00000000000..e4b930635c4 --- /dev/null +++ b/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 + + , zPrefix :: FilePath + , 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" diff --git a/templates/Paths_pkg.template.hs b/templates/Paths_pkg.template.hs new file mode 100644 index 00000000000..15bbf6e4dca --- /dev/null +++ b/templates/Paths_pkg.template.hs @@ -0,0 +1,183 @@ +{% if supportsCpp %} +{-# LANGUAGE CPP #-} +{% endif %} +{% if supportsNoRebindableSyntax %} +{-# LANGUAGE NoRebindableSyntax #-} +{% endif %} +{% if not absolute %} +{-# LANGUAGE ForeignFunctionInterface #-} +{% endif %} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} +module Paths_{{ manglePkgName packageName }} ( + version, + getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, + getDataFileName, getSysconfDir + ) where + +{% if not absolute %} +import Foreign +import Foreign.C +{% endif %} + +import qualified Control.Exception as Exception +import Data.Version (Version(..)) +import System.Environment (getEnv) +import Prelude + +{% if relocatable %} +import System.Environment (getExecutablePath) +{% endif %} + +{% if supportsCpp %} +#if defined(VERSION_base) + +#if MIN_VERSION_base(4,0,0) +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#else +catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a +#endif + +#else +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#endif +catchIO = Exception.catch +{% else %} +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +catchIO = Exception.catch +{% endif %} + +version :: Version +version = Version {{ versionDigits }} [] + +getDataFileName :: FilePath -> IO FilePath +getDataFileName name = do + dir <- getDataDir + return (dir `joinFileName` name) + +getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath + +{# body #} +{# ######################################################################### #} + +{% if relocatable %} + +getPrefixDirReloc :: FilePath -> IO FilePath +getPrefixDirReloc dirRel = do + exePath <- getExecutablePath + let (dir,_) = splitFileName exePath + return ((dir `minusFileName` {{ bindir }}) `joinFileName` dirRel) + +getBinDir = catchIO (getEnv "{{ manglePkgName packageName }}_bindir") (\_ -> getPrefixDirReloc $ {{ bindir }}) +getLibDir = catchIO (getEnv "{{ manglePkgName packageName }}_libdir") (\_ -> getPrefixDirReloc $ {{ libdir }}) +getDynLibDir = catchIO (getEnv "{{ manglePkgName packageName }}_dynlibdir") (\_ -> getPrefixDirReloc $ {{ dynlibdir }}) +getDataDir = catchIO (getEnv "{{ manglePkgName packageName }}_datadir") (\_ -> getPrefixDirReloc $ {{ datadir }}) +getLibexecDir = catchIO (getEnv "{{ manglePkgName packageName }}_libexecdir") (\_ -> getPrefixDirReloc $ {{ libexecdir }}) +getSysconfDir = catchIO (getEnv "{{ manglePkgName packageName }}_sysconfdir") (\_ -> getPrefixDirReloc $ {{ sysconfdir }}) + +{% elif absolute %} + +bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath +bindir = {{ bindir }} +libdir = {{ libdir }} +dynlibdir = {{ dynlibdir }} +datadir = {{ datadir }} +libexecdir = {{ libexecdir }} +sysconfdir = {{ sysconfdir }} + +getBinDir = catchIO (getEnv "{{ manglePkgName packageName }}_bindir") (\_ -> return bindir) +getLibDir = catchIO (getEnv "{{ manglePkgName packageName }}_libdir") (\_ -> return libdir) +getDynLibDir = catchIO (getEnv "{{ manglePkgName packageName }}_dynlibdir") (\_ -> return dynlibdir) +getDataDir = catchIO (getEnv "{{ manglePkgName packageName }}_datadir") (\_ -> return datadir) +getLibexecDir = catchIO (getEnv "{{ manglePkgName packageName }}_libexecdir") (\_ -> return libexecdir) +getSysconfDir = catchIO (getEnv "{{ manglePkgName packageName }}_sysconfdir") (\_ -> return sysconfdir) + +{% elif isWindows %} + +prefix :: FilePath +prefix = {{ prefix }} + +getBinDir = getPrefixDirRel $ {{ bindir }} +getLibDir = {{ libdir }} +getDynLibDir = {{ dynlibdir }} +getDataDir = catchIO (getEnv "{{ manglePkgName packageName }}_datadir") (\_ -> {{ datadir }}) +getLibexecDir = {{ libexecdir }} +getSysconfDir = {{ sysconfdir }} + +getPrefixDirRel :: FilePath -> IO FilePath +getPrefixDirRel dirRel = try_size 2048 -- plenty, PATH_MAX is 512 under Win32. + where + try_size size = allocaArray (fromIntegral size) $ \buf -> do + ret <- c_GetModuleFileName nullPtr buf size + case ret of + 0 -> return (prefix `joinFileName` dirRel) + _ | ret < size -> do + exePath <- peekCWString buf + let (bindir,_) = splitFileName exePath + return ((bindir `minusFileName` {{ bindir}}) `joinFileName` dirRel) + | otherwise -> try_size (size * 2) + +{% if isI386 %} +foreign import stdcall unsafe "windows.h GetModuleFileNameW" + c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32 +{% elif isX8664 %} +foreign import ccall unsafe "windows.h GetModuleFileNameW" + c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32 +{% else %} +-- win32 supported only with I386, X86_64 +c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32 +c_GetModuleFileName = _ +{% endif %} + +{% else %} + +notRelocAbsoluteOrWindows :: () +notRelocAbsoluteOrWindows = _ + +{% endif %} + +{# filename stuff #} +{# ######################################################################### #} + +{% if not absolute %} +minusFileName :: FilePath -> String -> FilePath +minusFileName dir "" = dir +minusFileName dir "." = dir +minusFileName dir suffix = + minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix)) + +splitFileName :: FilePath -> (String, String) +splitFileName p = (reverse (path2++drive), reverse fname) + where + (path,drive) = case p of + (c:':':p') -> (reverse p',[':',c]) + _ -> (reverse p ,"") + (fname,path1) = break isPathSeparator path + path2 = case path1 of + [] -> "." + [_] -> path1 -- don't remove the trailing slash if + -- there is only one character + (c:path') | isPathSeparator c -> path' + _ -> path1 +{% endif %} + +joinFileName :: String -> String -> FilePath +joinFileName "" fname = fname +joinFileName "." fname = fname +joinFileName dir "" = dir +joinFileName dir fname + | isPathSeparator (last dir) = dir ++ fname + | otherwise = dir ++ pathSeparator : fname + +pathSeparator :: Char +{% if isWindows %} +pathSeparator = '\\' +{% else %} +pathSeparator = '/' +{% endif %} + +isPathSeparator :: Char -> Bool +{% if isWindows %} +isPathSeparator c = c == '/' || c == '\\' +{% else %} +isPathSeparator c = c == '/' +{% endif %}