----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Build.Macros -- Copyright : Isaac Jones 2003-2005, -- Ross Paterson 2006, -- Duncan Coutts 2007-2008 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- Generating the Paths_pkgname module. -- -- This is a module that Cabal generates for the benefit of packages. It -- enables them to find their version number and find any installed data files -- at runtime. This code should probably be split off into another module. -- module Distribution.Simple.Build.PathsModule ( generate ) where import Distribution.System ( OS(Windows), buildOS ) import Distribution.Simple.Compiler ( CompilerFlavor(..), compilerFlavor, compilerVersion ) import Distribution.Package ( packageId, packageName, packageVersion ) import Distribution.PackageDescription ( PackageDescription(..), hasLibs ) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), InstallDirs(..) , absoluteInstallDirs, prefixRelativeInstallDirs ) import Distribution.Simple.Setup ( CopyDest(NoCopyDest) ) import Distribution.Simple.BuildPaths ( autogenModuleName ) import Distribution.Text ( display ) import Distribution.Version ( Version(..), orLaterVersion, withinRange ) import System.FilePath ( pathSeparator ) import Data.Maybe ( fromJust, isNothing ) -- ------------------------------------------------------------ -- * Building Paths_.hs -- ------------------------------------------------------------ generate :: PackageDescription -> LocalBuildInfo -> String generate pkg_descr lbi = let pragmas | absolute || isHugs = "" | supports_language_pragma = "{-# LANGUAGE ForeignFunctionInterface #-}\n" | otherwise = "{-# OPTIONS_GHC -fffi #-}\n"++ "{-# OPTIONS_JHC -fffi #-}\n" foreign_imports | absolute = "" | isHugs = "import System.Environment\n" | otherwise = "import Foreign\n"++ "import Foreign.C\n" header = pragmas++ "module " ++ display paths_modulename ++ " (\n"++ " version,\n"++ " getBinDir, getLibDir, getDataDir, getLibexecDir,\n"++ " getDataFileName\n"++ " ) where\n"++ "\n"++ foreign_imports++ "import Data.Version (Version(..))\n"++ "import System.Environment (getEnv)"++ "\n"++ "\nversion :: Version"++ "\nversion = " ++ show (packageVersion pkg_descr)++ "\n" body | absolute = "\nbindir, libdir, datadir, libexecdir :: FilePath\n"++ "\nbindir = " ++ show flat_bindir ++ "\nlibdir = " ++ show flat_libdir ++ "\ndatadir = " ++ show flat_datadir ++ "\nlibexecdir = " ++ show flat_libexecdir ++ "\n"++ "\ngetBinDir, getLibDir, getDataDir, getLibexecDir :: IO FilePath\n"++ "getBinDir = "++mkGetEnvOr "bindir" "return bindir"++"\n"++ "getLibDir = "++mkGetEnvOr "libdir" "return libdir"++"\n"++ "getDataDir = "++mkGetEnvOr "datadir" "return datadir"++"\n"++ "getLibexecDir = "++mkGetEnvOr "libexecdir" "return libexecdir"++"\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 (fromJust 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"++ "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"++ "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 InstallDirs { prefix = flat_prefix, bindir = flat_bindir, libdir = flat_libdir, datadir = flat_datadir, libexecdir = flat_libexecdir } = absoluteInstallDirs pkg_descr lbi NoCopyDest InstallDirs { bindir = flat_bindirrel, libdir = flat_libdirrel, datadir = flat_datadirrel, libexecdir = flat_libexecdirrel, progdir = flat_progdirrel } = prefixRelativeInstallDirs (packageId pkg_descr) lbi mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel mkGetDir dir Nothing = "return " ++ show dir mkGetEnvOr var expr = "catch (getEnv \""++var'++"\")"++ " (\\_ -> "++expr++")" where var' = showPkgName (packageName pkg_descr) ++ "_" ++ var showPkgName = map fixchar . display fixchar '-' = '_' fixchar c = c -- 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 || (isHugs && isNothing flat_progdirrel) || not (supportsRelocatableProgs (compilerFlavor (compiler lbi))) supportsRelocatableProgs Hugs = True supportsRelocatableProgs GHC = case buildOS of Windows -> True _ -> False supportsRelocatableProgs _ = False paths_modulename = autogenModuleName pkg_descr isHugs = compilerFlavor (compiler lbi) == Hugs get_prefix_stuff | isHugs = "progdirrel :: String\n"++ "progdirrel = "++show (fromJust flat_progdirrel)++"\n\n"++ get_prefix_hugs | otherwise = get_prefix_win32 path_sep = show [pathSeparator] supports_language_pragma = compilerFlavor (compiler lbi) == GHC && (compilerVersion (compiler lbi) `withinRange` orLaterVersion (Version [6,6,1] [])) get_prefix_win32 :: String get_prefix_win32 = "getPrefixDirRel :: FilePath -> IO FilePath\n"++ "getPrefixDirRel dirRel = do \n"++ " let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.\n"++ " buf <- mallocArray len\n"++ " ret <- getModuleFileName nullPtr buf len\n"++ " if ret == 0 \n"++ " then do free buf;\n"++ " return (prefix `joinFileName` dirRel)\n"++ " else do exePath <- peekCString buf\n"++ " free buf\n"++ " let (bindir,_) = splitFileName exePath\n"++ " return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n"++ "\n"++ "foreign import stdcall unsafe \"windows.h GetModuleFileNameA\"\n"++ " getModuleFileName :: Ptr () -> CString -> Int -> IO Int32\n" get_prefix_hugs :: String get_prefix_hugs = "getPrefixDirRel :: FilePath -> IO FilePath\n"++ "getPrefixDirRel dirRel = do\n"++ " mainPath <- getProgName\n"++ " let (progPath,_) = splitFileName mainPath\n"++ " let (progdir,_) = splitFileName progPath\n"++ " return ((progdir `minusFileName` progdirrel) `joinFileName` dirRel)\n" 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")