Skip to content

Commit

Permalink
Move Paths_pkgname and cabal_macros.h generation into their own modules
Browse files Browse the repository at this point in the history
  • Loading branch information
@dcoutts
dcoutts committed Aug 13, 2008
1 parent d1cd731 commit e6f4785
Show file tree
Hide file tree
Showing 5 changed files with 337 additions and 275 deletions.
2 changes: 2 additions & 0 deletions Cabal.cabal
View file
Expand Up @@ -62,6 +62,8 @@ Library
Distribution.ReadE,
Distribution.Simple,
Distribution.Simple.Build,
Distribution.Simple.Build.Macros,
Distribution.Simple.Build.PathsModule,
Distribution.Simple.BuildPaths,
Distribution.Simple.Command,
Distribution.Simple.Compiler,
Expand Down
325 changes: 51 additions & 274 deletions Distribution/Simple/Build.hs
View file
@@ -1,7 +1,9 @@
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.Build
-- Copyright : Isaac Jones 2003-2005
-- Copyright : Isaac Jones 2003-2005,
-- Ross Paterson 2006,
-- Duncan Coutts 2007-2008
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
Expand All @@ -16,10 +18,6 @@
-- we'd like to kill off and replace with something better (doing our own
-- dependency analysis properly).
--
-- Half the module is dedicated to 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.

{- Copyright (c) 2003-2005, Isaac Jones
All rights reserved.
Expand Down Expand Up @@ -53,52 +51,53 @@ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}

module Distribution.Simple.Build (
build, makefile, initialBuildSteps
build,
makefile,

initialBuildSteps,
writeAutogenFiles,
) where

import qualified Distribution.Simple.GHC as GHC
import qualified Distribution.Simple.JHC as JHC
import qualified Distribution.Simple.NHC as NHC
import qualified Distribution.Simple.Hugs as Hugs

import qualified Distribution.Simple.Build.Macros as Build.Macros
import qualified Distribution.Simple.Build.PathsModule as Build.PathsModule

import Distribution.Package
( Package(..) )
import Distribution.Simple.Compiler
( CompilerFlavor(..), compilerFlavor )
import Distribution.PackageDescription
( PackageDescription(..), BuildInfo(..),
Executable(..), Library(..) )
import Distribution.Package
( PackageIdentifier, Package(..), packageName, packageVersion )
( PackageDescription(..), BuildInfo(..)
, Executable(..), Library(..), hasLibs )
import qualified Distribution.ModuleName as ModuleName
import Distribution.Simple.Setup ( CopyDest(..), BuildFlags(..),
MakefileFlags(..), fromFlag )
import Distribution.Simple.PreProcess ( preprocessSources, PPSuffixHandler )

import Distribution.Simple.Setup
( BuildFlags(..), MakefileFlags(..), fromFlag )
import Distribution.Simple.PreProcess
( preprocessSources, PPSuffixHandler )
import Distribution.Simple.LocalBuildInfo
( LocalBuildInfo(..),
InstallDirs(..), absoluteInstallDirs,
prefixRelativeInstallDirs )
( LocalBuildInfo(compiler, buildDir) )
import Distribution.Simple.BuildPaths
( autogenModulesDir, autogenModuleName,
cppHeaderName )
import Distribution.Simple.Configure
( localBuildInfoFile )
( autogenModulesDir, autogenModuleName, cppHeaderName )
import Distribution.Simple.Utils
( createDirectoryIfMissingVerbose, die, setupMessage, writeUTF8File )
import Distribution.System
import Distribution.Version ( Version(versionBranch) )
( createDirectoryIfMissingVerbose, die, setupMessage, rewriteFile )

import System.FilePath ( (</>), (<.>), pathSeparator )

import Data.Maybe ( maybeToList, fromJust, isNothing )
import Control.Monad ( unless, when )
import System.Directory ( getModificationTime, doesFileExist )
import Text.Printf ( printf, PrintfType, HPrintfType,
PrintfArg, IsChar )

import qualified Distribution.Simple.GHC as GHC
import qualified Distribution.Simple.JHC as JHC
import qualified Distribution.Simple.NHC as NHC
import qualified Distribution.Simple.Hugs as Hugs

import Distribution.PackageDescription (hasLibs)
import Distribution.Verbosity
( Verbosity )
import Distribution.Text
( display )

import Data.Maybe
( maybeToList )
import Control.Monad
( unless, when )
import System.FilePath
( (</>), (<.>) )

-- -----------------------------------------------------------------------------
-- |Build the libraries and executables in this package.

Expand Down Expand Up @@ -142,7 +141,7 @@ initialBuildSteps :: FilePath -- ^"dist" prefix
-> Verbosity -- ^The verbosity to use
-> [ PPSuffixHandler ] -- ^preprocessors to run before compiling
-> IO ()
initialBuildSteps distPref pkg_descr lbi verbosity suffixes = do
initialBuildSteps _distPref pkg_descr lbi verbosity suffixes = do
-- check that there's something to build
let buildInfos =
map libBuildInfo (maybeToList (library pkg_descr)) ++
Expand All @@ -153,244 +152,22 @@ initialBuildSteps distPref pkg_descr lbi verbosity suffixes = do

createDirectoryIfMissingVerbose verbosity True (buildDir lbi)

-- construct and write the Paths_<pkg>.hs file
createDirectoryIfMissingVerbose verbosity True (autogenModulesDir lbi)
buildPathsModule distPref pkg_descr lbi
buildCPPHeader distPref pkg_descr lbi
writeAutogenFiles verbosity pkg_descr lbi

preprocessSources pkg_descr lbi False verbosity suffixes

-- ------------------------------------------------------------
-- * Building cabal_macros.h
-- ------------------------------------------------------------

buildCPPHeader :: FilePath -> PackageDescription -> LocalBuildInfo -> IO ()
buildCPPHeader distPref _pkg_descr lbi =
let
cpp_header_filepath = autogenModulesDir lbi </> cppHeaderName

preface = "/* DO NOT EDIT: This file is automatically generated by Cabal */"

version_macro :: PackageIdentifier -> String
version_macro pkgid =
printf ("#define MIN_VERSION_%s(major1,major2,minor) \\\n" ++
" (major1) < %d || \\\n" ++
" (major1) == %d && (major2) < %d || \\\n" ++
" (major1) == %d && (major2) == %d && (minor) <= %d")
(display (packageName pkgid)) major1
major1 major2
major1 major2 minor
where
vs = versionBranch (packageVersion pkgid)
(major1:major2:minor:_) = vs ++ repeat 0

contents = unlines (preface : map version_macro (packageDeps lbi))

in do
btime <- getModificationTime (localBuildInfoFile distPref)
exists <- doesFileExist cpp_header_filepath
ptime <- if exists
then getModificationTime cpp_header_filepath
else return btime
if btime >= ptime
then writeFile cpp_header_filepath contents
else return ()

-- ------------------------------------------------------------
-- * Building Paths_<pkg>.hs
-- ------------------------------------------------------------

buildPathsModule :: FilePath -> PackageDescription -> LocalBuildInfo -> IO ()
buildPathsModule distPref pkg_descr lbi =
let pragmas
| absolute || isHugs = ""
| otherwise =
"{-# LANGUAGE ForeignFunctionInterface #-}\n" ++
"{-# 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 do btime <- getModificationTime (localBuildInfoFile distPref)
exists <- doesFileExist paths_filepath
ptime <- if exists
then getModificationTime paths_filepath
else return btime
if btime >= ptime
then writeUTF8File paths_filepath (header++body)
else return ()
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 pkg_descr lbi

mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel
mkGetDir dir Nothing = "return " ++ show dir

mkGetEnvOr var expr = "catch (getEnv \""++var'++"\")"++
" (\\_ -> "++expr++")"
where var' = display (packageName 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)))

supportsRelocatableProgs Hugs = True
supportsRelocatableProgs GHC = case buildOS of
Windows -> True
_ -> False
supportsRelocatableProgs _ = False

paths_modulename = autogenModuleName pkg_descr
paths_filename = ModuleName.toFilePath paths_modulename <.> "hs"
paths_filepath = autogenModulesDir lbi </> paths_filename

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]

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"
-- | Generate and write out the Paths_<pkg>.hs and cabal_macros.h files
--
writeAutogenFiles :: Verbosity
-> PackageDescription
-> LocalBuildInfo
-> IO ()
writeAutogenFiles verbosity pkg lbi = do
createDirectoryIfMissingVerbose verbosity True (autogenModulesDir lbi)

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"
let pathsModulePath = autogenModulesDir lbi
</> ModuleName.toFilePath (autogenModuleName pkg) <.> "hs"
rewriteFile pathsModulePath (Build.PathsModule.generate pkg lbi)

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")
let cppHeaderPath = autogenModulesDir lbi </> cppHeaderName
rewriteFile cppHeaderPath (Build.Macros.generate pkg lbi)

0 comments on commit e6f4785

Please sign in to comment.