Distribution/Simple/PreProcess.hs

    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Distribution.Simple.PreProcess
    -- Copyright   :  (c) 2003-2005, Isaac Jones, Malcolm Wallace
    -- License     :  BSD3
    --
    -- Maintainer  :  cabal-devel@haskell.org
    -- Portability :  portable
    --
    -- This defines a 'PreProcessor' abstraction which represents a pre-processor
    -- that can transform one kind of file into another. There is also a
    -- 'PPSuffixHandler' which is a combination of a file extension and a function
    -- for configuring a 'PreProcessor'. It defines a bunch of known built-in
    -- preprocessors like @cpp@, @cpphs@, @c2hs@, @hsc2hs@, @happy@, @alex@ etc and
    -- lists them in 'knownSuffixHandlers'. On top of this it provides a function
    -- for actually preprocessing some sources given a bunch of known suffix
    -- handlers. This module is not as good as it could be, it could really do with
    -- a rewrite to address some of the problems we have with pre-processors.

    module Distribution.Simple.PreProcess (preprocessComponent, knownSuffixHandlers,
                                    ppSuffixes, PPSuffixHandler, PreProcessor(..),
                                    mkSimplePreProcessor, runSimplePreProcessor,
                                    ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs,
                                    ppHappy, ppAlex, ppUnlit, platformDefines
                                   )
        where

    import Control.Monad
    import Distribution.Simple.PreProcess.Unlit (unlit)
    import Distribution.Package
             ( Package(..), PackageName(..) )
    import qualified Distribution.ModuleName as ModuleName
    import Distribution.PackageDescription as PD
             ( PackageDescription(..), BuildInfo(..)
             , Executable(..)
             , Library(..), libModules
             , TestSuite(..), testModules
             , TestSuiteInterface(..)
             , Benchmark(..), benchmarkModules, BenchmarkInterface(..) )
    import qualified Distribution.InstalledPackageInfo as Installed
             ( InstalledPackageInfo_(..) )
    import qualified Distribution.Simple.PackageIndex as PackageIndex
    import Distribution.Simple.CCompiler
             ( cSourceExtensions )
    import Distribution.Simple.Compiler
             ( CompilerFlavor(..)
             , compilerFlavor, compilerCompatVersion, compilerVersion )
    import Distribution.Simple.LocalBuildInfo
             ( LocalBuildInfo(..), Component(..) )
    import Distribution.Simple.BuildPaths (autogenModulesDir,cppHeaderName)
    import Distribution.Simple.Utils
             ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File
             , die, setupMessage, intercalate, copyFileVerbose, moreRecentFile
             , findFileWithExtension, findFileWithExtension' )
    import Distribution.Simple.Program
             ( Program(..), ConfiguredProgram(..), programPath
             , requireProgram, requireProgramVersion
             , rawSystemProgramConf, rawSystemProgram
             , greencardProgram, cpphsProgram, hsc2hsProgram, c2hsProgram
             , happyProgram, alexProgram, ghcProgram, ghcjsProgram, gccProgram )
    import Distribution.Simple.Test.LibV09
             ( writeSimpleTestStub, stubFilePath, stubName )
    import Distribution.System
             ( OS(..), buildOS, Arch(..), Platform(..) )
    import Distribution.Text
    import Distribution.Version
             ( Version(..), anyVersion, orLaterVersion )
    import Distribution.Verbosity

    import Data.Maybe (fromMaybe)
    import Data.List (nub)
    import System.Directory (doesFileExist)
    import System.Info (os, arch)
    import System.FilePath (splitExtension, dropExtensions, (</>), (<.>),
                            takeDirectory, normalise, replaceExtension)

    -- |The interface to a preprocessor, which may be implemented using an
    -- external program, but need not be.  The arguments are the name of
    -- the input file, the name of the output file and a verbosity level.
    -- Here is a simple example that merely prepends a comment to the given
    -- source file:
    --
    -- > ppTestHandler :: PreProcessor
    -- > ppTestHandler =
    -- >   PreProcessor {
    -- >     platformIndependent = True,
    -- >     runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->
    -- >       do info verbosity (inFile++" has been preprocessed to "++outFile)
    -- >          stuff <- readFile inFile
    -- >          writeFile outFile ("-- preprocessed as a test\n\n" ++ stuff)
    -- >          return ExitSuccess
    --
    -- We split the input and output file names into a base directory and the
    -- rest of the file name. The input base dir is the path in the list of search
    -- dirs that this file was found in. The output base dir is the build dir where
    -- all the generated source files are put.
    --
    -- The reason for splitting it up this way is that some pre-processors don't
    -- simply generate one output .hs file from one input file but have
    -- dependencies on other generated files (notably c2hs, where building one
    -- .hs file may require reading other .chi files, and then compiling the .hs
    -- file may require reading a generated .h file). In these cases the generated
    -- files need to embed relative path names to each other (eg the generated .hs
    -- file mentions the .h file in the FFI imports). This path must be relative to
    -- the base directory where the generated files are located, it cannot be
    -- relative to the top level of the build tree because the compilers do not
    -- look for .h files relative to there, ie we do not use \"-I .\", instead we
    -- use \"-I dist\/build\" (or whatever dist dir has been set by the user)
    --
    -- Most pre-processors do not care of course, so mkSimplePreProcessor and
    -- runSimplePreProcessor functions handle the simple case.
    --
    data PreProcessor = PreProcessor {

      -- Is the output of the pre-processor platform independent? eg happy output
      -- is portable haskell but c2hs's output is platform dependent.
      -- This matters since only platform independent generated code can be
      -- inlcuded into a source tarball.
      platformIndependent :: Bool,

      -- TODO: deal with pre-processors that have implementaion dependent output
      --       eg alex and happy have --ghc flags. However we can't really inlcude
      --       ghc-specific code into supposedly portable source tarballs.

      runPreProcessor :: (FilePath, FilePath) -- Location of the source file relative to a base dir
                      -> (FilePath, FilePath) -- Output file name, relative to an output base dir
                      -> Verbosity -- verbosity
                      -> IO ()     -- Should exit if the preprocessor fails
      }

    mkSimplePreProcessor :: (FilePath -> FilePath -> Verbosity -> IO ())
                          -> (FilePath, FilePath)
                          -> (FilePath, FilePath) -> Verbosity -> IO ()
    mkSimplePreProcessor simplePP
      (inBaseDir, inRelativeFile)
      (outBaseDir, outRelativeFile) verbosity = simplePP inFile outFile verbosity
      where inFile  = normalise (inBaseDir  </> inRelativeFile)
            outFile = normalise (outBaseDir </> outRelativeFile)

    runSimplePreProcessor :: PreProcessor -> FilePath -> FilePath -> Verbosity
                          -> IO ()
    runSimplePreProcessor pp inFile outFile verbosity =
      runPreProcessor pp (".", inFile) (".", outFile) verbosity

    -- |A preprocessor for turning non-Haskell files with the given extension
    -- into plain Haskell source files.
    type PPSuffixHandler
        = (String, BuildInfo -> LocalBuildInfo -> PreProcessor)

    -- | Apply preprocessors to the sources from 'hsSourceDirs' for a given
    -- component (lib, exe, or test suite).
    preprocessComponent :: PackageDescription
                        -> Component
                        -> LocalBuildInfo
                        -> Bool
                        -> Verbosity
                        -> [PPSuffixHandler]
                        -> IO ()
    preprocessComponent pd comp lbi isSrcDist verbosity handlers = case comp of
      (CLib lib@Library{ libBuildInfo = bi }) -> do
        let dirs = hsSourceDirs bi ++ [autogenModulesDir lbi]
        setupMessage verbosity "Preprocessing library" (packageId pd)
        forM_ (map ModuleName.toFilePath $ libModules lib) $
          pre dirs (buildDir lbi) (localHandlers bi)
      (CExe exe@Executable { buildInfo = bi, exeName = nm }) -> do
        let exeDir = buildDir lbi </> nm </> nm ++ "-tmp"
            dirs   = hsSourceDirs bi ++ [autogenModulesDir lbi]
        setupMessage verbosity ("Preprocessing executable '" ++ nm ++ "' for") (packageId pd)
        forM_ (map ModuleName.toFilePath $ otherModules bi) $
          pre dirs exeDir (localHandlers bi)
        pre (hsSourceDirs bi) exeDir (localHandlers bi) $
          dropExtensions (modulePath exe)
      CTest test@TestSuite{ testName = nm } -> do
        setupMessage verbosity ("Preprocessing test suite '" ++ nm ++ "' for") (packageId pd)
        case testInterface test of
          TestSuiteExeV10 _ f ->
              preProcessTest test f $ buildDir lbi </> testName test
                  </> testName test ++ "-tmp"
          TestSuiteLibV09 _ _ -> do
              let testDir = buildDir lbi </> stubName test
                      </> stubName test ++ "-tmp"
              writeSimpleTestStub test testDir
              preProcessTest test (stubFilePath test) testDir
          TestSuiteUnsupported tt -> die $ "No support for preprocessing test "
                                        ++ "suite type " ++ display tt
      CBench bm@Benchmark{ benchmarkName = nm } -> do
        setupMessage verbosity ("Preprocessing benchmark '" ++ nm ++ "' for") (packageId pd)
        case benchmarkInterface bm of
          BenchmarkExeV10 _ f ->
              preProcessBench bm f $ buildDir lbi </> benchmarkName bm
                  </> benchmarkName bm ++ "-tmp"
          BenchmarkUnsupported tt -> die $ "No support for preprocessing benchmark "
                                     ++ "type " ++ display tt
      where
        builtinHaskellSuffixes = ["hs", "lhs", "hsig", "lhsig"]
        builtinCSuffixes       = cSourceExtensions
        builtinSuffixes        = builtinHaskellSuffixes ++ builtinCSuffixes
        localHandlers bi = [(ext, h bi lbi) | (ext, h) <- handlers]
        pre dirs dir lhndlrs fp =
          preprocessFile dirs dir isSrcDist fp verbosity builtinSuffixes lhndlrs
        preProcessTest test = preProcessComponent (testBuildInfo test)
                              (testModules test)
        preProcessBench bm = preProcessComponent (benchmarkBuildInfo bm)
                             (benchmarkModules bm)
        preProcessComponent bi modules exePath dir = do
            let biHandlers = localHandlers bi
                sourceDirs = hsSourceDirs bi ++ [ autogenModulesDir lbi ]
            sequence_ [ preprocessFile sourceDirs dir isSrcDist
                    (ModuleName.toFilePath modu) verbosity builtinSuffixes
                    biHandlers
                    | modu <- modules ]
            preprocessFile (dir : (hsSourceDirs bi)) dir isSrcDist
                (dropExtensions $ exePath) verbosity
                builtinSuffixes biHandlers

    --TODO: try to list all the modules that could not be found
    --      not just the first one. It's annoying and slow due to the need
    --      to reconfigure after editing the .cabal file each time.

    -- |Find the first extension of the file that exists, and preprocess it
    -- if required.
    preprocessFile
        :: [FilePath]               -- ^source directories
        -> FilePath                 -- ^build directory
        -> Bool                     -- ^preprocess for sdist
        -> FilePath                 -- ^module file name
        -> Verbosity                -- ^verbosity
        -> [String]                 -- ^builtin suffixes
        -> [(String, PreProcessor)] -- ^possible preprocessors
        -> IO ()
    preprocessFile searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers = do
        -- look for files in the various source dirs with this module name
        -- and a file extension of a known preprocessor
        psrcFiles <- findFileWithExtension' (map fst handlers) searchLoc baseFile
        case psrcFiles of
            -- no preprocessor file exists, look for an ordinary source file
            -- just to make sure one actually exists at all for this module.
            -- Note: by looking in the target/output build dir too, we allow
            -- source files to appear magically in the target build dir without
            -- any corresponding "real" source file. This lets custom Setup.hs
            -- files generate source modules directly into the build dir without
            -- the rest of the build system being aware of it (somewhat dodgy)
          Nothing -> do
                     bsrcFiles <- findFileWithExtension builtinSuffixes (buildLoc : searchLoc) baseFile
                     case bsrcFiles of
                      Nothing -> die $ "can't find source for " ++ baseFile
                                    ++ " in " ++ intercalate ", " searchLoc
                      _       -> return ()
            -- found a pre-processable file in one of the source dirs
          Just (psrcLoc, psrcRelFile) -> do
                let (srcStem, ext) = splitExtension psrcRelFile
                    psrcFile = psrcLoc </> psrcRelFile
                    pp = fromMaybe (error "Internal error in preProcess module: Just expected")
                                   (lookup (tailNotNull ext) handlers)
                -- Preprocessing files for 'sdist' is different from preprocessing
                -- for 'build'.  When preprocessing for sdist we preprocess to
                -- avoid that the user has to have the preprocessors available.
                -- ATM, we don't have a way to specify which files are to be
                -- preprocessed and which not, so for sdist we only process
                -- platform independent files and put them into the 'buildLoc'
                -- (which we assume is set to the temp. directory that will become
                -- the tarball).
                --TODO: eliminate sdist variant, just supply different handlers
                when (not forSDist || forSDist && platformIndependent pp) $ do
                  -- look for existing pre-processed source file in the dest dir to
                  -- see if we really have to re-run the preprocessor.
                  ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] baseFile
                  recomp <- case ppsrcFiles of
                              Nothing -> return True
                              Just ppsrcFile ->
                                  psrcFile `moreRecentFile` ppsrcFile
                  when recomp $ do
                    let destDir = buildLoc </> dirName srcStem
                    createDirectoryIfMissingVerbose verbosity True destDir
                    runPreProcessorWithHsBootHack pp
                       (psrcLoc, psrcRelFile)
                       (buildLoc, srcStem <.> "hs")

      where
        dirName = takeDirectory
        tailNotNull [] = []
        tailNotNull x  = tail x

        -- FIXME: This is a somewhat nasty hack. GHC requires that hs-boot files
        -- be in the same place as the hs files, so if we put the hs file in dist/
        -- then we need to copy the hs-boot file there too. This should probably be
        -- done another way. Possibly we should also be looking for .lhs-boot
        -- files, but I think that preprocessors only produce .hs files.
        runPreProcessorWithHsBootHack pp
          (inBaseDir,  inRelativeFile)
          (outBaseDir, outRelativeFile) = do
            runPreProcessor pp
              (inBaseDir, inRelativeFile)
              (outBaseDir, outRelativeFile) verbosity

            exists <- doesFileExist inBoot
            when exists $ copyFileVerbose verbosity inBoot outBoot

          where
            inBoot  = replaceExtension inFile  "hs-boot"
            outBoot = replaceExtension outFile "hs-boot"

            inFile  = normalise (inBaseDir  </> inRelativeFile)
            outFile = normalise (outBaseDir </> outRelativeFile)

    -- ------------------------------------------------------------
    -- * known preprocessors
    -- ------------------------------------------------------------

    ppGreenCard :: BuildInfo -> LocalBuildInfo -> PreProcessor
    ppGreenCard _ lbi
        = PreProcessor {
            platformIndependent = False,
            runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->
              rawSystemProgramConf verbosity greencardProgram (withPrograms lbi)
                  (["-tffi", "-o" ++ outFile, inFile])
          }

    -- This one is useful for preprocessors that can't handle literate source.
    -- We also need a way to chain preprocessors.
    ppUnlit :: PreProcessor
    ppUnlit =
      PreProcessor {
        platformIndependent = True,
        runPreProcessor = mkSimplePreProcessor $ \inFile outFile _verbosity ->
          withUTF8FileContents inFile $ \contents ->
            either (writeUTF8File outFile) die (unlit inFile contents)
      }

    ppCpp :: BuildInfo -> LocalBuildInfo -> PreProcessor
    ppCpp = ppCpp' []

    ppCpp' :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor
    ppCpp' extraArgs bi lbi =
      case compilerFlavor (compiler lbi) of
        GHC   -> ppGhcCpp ghcProgram   (>= Version [6,6] []) args bi lbi
        GHCJS -> ppGhcCpp ghcjsProgram (const True)          args bi lbi
        _     -> ppCpphs  args bi lbi
      where cppArgs = getCppOptions bi lbi
            args    = cppArgs ++ extraArgs

    ppGhcCpp :: Program -> (Version -> Bool)
             -> [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor
    ppGhcCpp program xHs extraArgs _bi lbi =
      PreProcessor {
        platformIndependent = False,
        runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do
          (prog, version, _) <- requireProgramVersion verbosity
                                  program anyVersion (withPrograms lbi)
          rawSystemProgram verbosity prog $
              ["-E", "-cpp"]
              -- This is a bit of an ugly hack. We're going to
              -- unlit the file ourselves later on if appropriate,
              -- so we need GHC not to unlit it now or it'll get
              -- double-unlitted. In the future we might switch to
              -- using cpphs --unlit instead.
           ++ (if xHs version then ["-x", "hs"] else [])
           ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi </> cppHeaderName) ]
           ++ ["-o", outFile, inFile]
           ++ extraArgs
      }

    ppCpphs :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor
    ppCpphs extraArgs _bi lbi =
      PreProcessor {
        platformIndependent = False,
        runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do
          (cpphsProg, cpphsVersion, _) <- requireProgramVersion verbosity
                                            cpphsProgram anyVersion (withPrograms lbi)
          rawSystemProgram verbosity cpphsProg $
              ("-O" ++ outFile) : inFile
            : "--noline" : "--strip"
            : (if cpphsVersion >= Version [1,6] []
                 then ["--include="++ (autogenModulesDir lbi </> cppHeaderName)]
                 else [])
            ++ extraArgs
      }

    ppHsc2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor
    ppHsc2hs bi lbi =
      PreProcessor {
        platformIndependent = False,
        runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do
          (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi)
          rawSystemProgramConf verbosity hsc2hsProgram (withPrograms lbi) $
              [ "--cc=" ++ programPath gccProg
              , "--ld=" ++ programPath gccProg ]

              -- Additional gcc options
           ++ [ "--cflag=" ++ opt | opt <- programDefaultArgs  gccProg
                                        ++ programOverrideArgs gccProg ]
           ++ [ "--lflag=" ++ opt | opt <- programDefaultArgs  gccProg
                                        ++ programOverrideArgs gccProg ]

              -- OSX frameworks:
           ++ [ what ++ "=-F" ++ opt
              | isOSX
              , opt <- nub (concatMap Installed.frameworkDirs pkgs)
              , what <- ["--cflag", "--lflag"] ]
           ++ [ "--lflag=" ++ arg
              | isOSX
              , opt <- PD.frameworks bi ++ concatMap Installed.frameworks pkgs
              , arg <- ["-framework", opt] ]

              -- Note that on ELF systems, wherever we use -L, we must also use -R
              -- because presumably that -L dir is not on the normal path for the
              -- system's dynamic linker. This is needed because hsc2hs works by
              -- compiling a C program and then running it.

           ++ [ "--cflag="   ++ opt | opt <- platformDefines lbi ]

              -- Options from the current package:
           ++ [ "--cflag=-I" ++ dir | dir <- PD.includeDirs  bi ]
           ++ [ "--cflag="   ++ opt | opt <- PD.ccOptions    bi
                                          ++ PD.cppOptions   bi ]
           ++ [ "--cflag="   ++ opt | opt <-
                   [ "-I" ++ autogenModulesDir lbi,
                     "-include", autogenModulesDir lbi </> cppHeaderName ] ]
           ++ [ "--lflag=-L" ++ opt | opt <- PD.extraLibDirs bi ]
           ++ [ "--lflag=-Wl,-R," ++ opt | isELF
                                    , opt <- PD.extraLibDirs bi ]
           ++ [ "--lflag=-l" ++ opt | opt <- PD.extraLibs    bi ]
           ++ [ "--lflag="   ++ opt | opt <- PD.ldOptions    bi ]

              -- Options from dependent packages
           ++ [ "--cflag=" ++ opt
              | pkg <- pkgs
              , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ]
                    ++ [         opt | opt <- Installed.ccOptions   pkg ] ]
           ++ [ "--lflag=" ++ opt
              | pkg <- pkgs
              , opt <- [ "-L" ++ opt | opt <- Installed.libraryDirs    pkg ]
                    ++ [ "-Wl,-R," ++ opt | isELF
                                     , opt <- Installed.libraryDirs    pkg ]
                    ++ [ "-l" ++ opt | opt <- Installed.extraLibraries pkg ]
                    ++ [         opt | opt <- Installed.ldOptions      pkg ] ]
           ++ ["-o", outFile, inFile]
      }
      where
        pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi))
        isOSX = case buildOS of OSX -> True; _ -> False
        isELF = case buildOS of OSX -> False; Windows -> False; _ -> True;
        packageHacks = case compilerFlavor (compiler lbi) of
          GHC   -> hackRtsPackage
          GHCJS -> hackRtsPackage
          _     -> id
        -- We don't link in the actual Haskell libraries of our dependencies, so
        -- the -u flags in the ldOptions of the rts package mean linking fails on
        -- OS X (it's ld is a tad stricter than gnu ld). Thus we remove the
        -- ldOptions for GHC's rts package:
        hackRtsPackage index =
          case PackageIndex.lookupPackageName index (PackageName "rts") of
            [(_, [rts])]
               -> PackageIndex.insert rts { Installed.ldOptions = [] } index
            _  -> error "No (or multiple) ghc rts package is registered!!"

    ppC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor
    ppC2hs bi lbi =
      PreProcessor {
        platformIndependent = False,
        runPreProcessor = \(inBaseDir, inRelativeFile)
                           (outBaseDir, outRelativeFile) verbosity -> do
          (c2hsProg, _, _) <- requireProgramVersion verbosity
                                c2hsProgram (orLaterVersion (Version [0,15] []))
                                (withPrograms lbi)
          (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi)
          rawSystemProgram verbosity c2hsProg $

              -- Options from the current package:
               [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ]
            ++ [ "--cppopts=" ++ opt | opt <- getCppOptions bi lbi ]
            ++ [ "--include=" ++ outBaseDir ]

              -- Options from dependent packages
           ++ [ "--cppopts=" ++ opt
              | pkg <- pkgs
              , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ]
                    ++ [         opt | opt@('-':c:_) <- Installed.ccOptions pkg
                                     , c `elem` "DIU" ] ]
              --TODO: install .chi files for packages, so we can --include
              -- those dirs here, for the dependencies

               -- input and output files
            ++ [ "--output-dir=" ++ outBaseDir
               , "--output=" ++ outRelativeFile
               , inBaseDir </> inRelativeFile ]
      }
      where
        pkgs = PackageIndex.topologicalOrder (installedPkgs lbi)

    --TODO: perhaps use this with hsc2hs too
    --TODO: remove cc-options from cpphs for cabal-version: >= 1.10
    getCppOptions :: BuildInfo -> LocalBuildInfo -> [String]
    getCppOptions bi lbi
        = platformDefines lbi
       ++ cppOptions bi
       ++ ["-I" ++ dir | dir <- PD.includeDirs bi]
       ++ [opt | opt@('-':c:_) <- PD.ccOptions bi, c `elem` "DIU"]

    platformDefines :: LocalBuildInfo -> [String]
    platformDefines lbi =
      case compilerFlavor comp of
        GHC  ->
          ["-D__GLASGOW_HASKELL__=" ++ versionInt version] ++
          ["-D" ++ os   ++ "_BUILD_OS=1"] ++
          ["-D" ++ arch ++ "_BUILD_ARCH=1"] ++
          map (\os'   -> "-D" ++ os'   ++ "_HOST_OS=1")   osStr ++
          map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr
        GHCJS ->
          compatGlasgowHaskell ++
          ["-D__GHCJS__=" ++ versionInt version] ++
          ["-D" ++ os   ++ "_BUILD_OS=1"] ++
          ["-D" ++ arch ++ "_BUILD_ARCH=1"] ++
          map (\os'   -> "-D" ++ os'   ++ "_HOST_OS=1")   osStr ++
          map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr
        JHC  -> ["-D__JHC__=" ++ versionInt version]
        HaskellSuite {} ->
          ["-D__HASKELL_SUITE__"] ++
            map (\os'   -> "-D" ++ os'   ++ "_HOST_OS=1")   osStr ++
            map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr
        _    -> []
      where
        comp = compiler lbi
        Platform hostArch hostOS = hostPlatform lbi
        version = compilerVersion comp
        compatGlasgowHaskell =
          maybe [] (\v -> ["-D__GLASGOW_HASKELL__=" ++ versionInt v])
                   (compilerCompatVersion GHC comp)
        -- TODO: move this into the compiler abstraction
        -- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all
        -- the other compilers. Check if that's really what they want.
        versionInt :: Version -> String
        versionInt (Version { versionBranch = [] }) = "1"
        versionInt (Version { versionBranch = [n] }) = show n
        versionInt (Version { versionBranch = n1:n2:_ })
          = -- 6.8.x -> 608
            -- 6.10.x -> 610
            let s1 = show n1
                s2 = show n2
                middle = case s2 of
                         _ : _ : _ -> ""
                         _         -> "0"
            in s1 ++ middle ++ s2
        osStr = case hostOS of
          Linux     -> ["linux"]
          Windows   -> ["mingw32"]
          OSX       -> ["darwin"]
          FreeBSD   -> ["freebsd"]
          OpenBSD   -> ["openbsd"]
          NetBSD    -> ["netbsd"]
          DragonFly -> ["dragonfly"]
          Solaris   -> ["solaris2"]
          AIX       -> ["aix"]
          HPUX      -> ["hpux"]
          IRIX      -> ["irix"]
          HaLVM     -> []
          IOS       -> ["ios"]
          Ghcjs     -> ["ghcjs"]
          OtherOS _ -> []
        archStr = case hostArch of
          I386        -> ["i386"]
          X86_64      -> ["x86_64"]
          PPC         -> ["powerpc"]
          PPC64       -> ["powerpc64"]
          Sparc       -> ["sparc"]
          Arm         -> ["arm"]
          Mips        -> ["mips"]
          SH          -> []
          IA64        -> ["ia64"]
          S390        -> ["s390"]
          Alpha       -> ["alpha"]
          Hppa        -> ["hppa"]
          Rs6000      -> ["rs6000"]
          M68k        -> ["m68k"]
          Vax         -> ["vax"]
          JavaScript  -> ["javascript"]
          OtherArch _ -> []

    ppHappy :: BuildInfo -> LocalBuildInfo -> PreProcessor
    ppHappy _ lbi = pp { platformIndependent = True }
      where pp = standardPP lbi happyProgram (hcFlags hc)
            hc = compilerFlavor (compiler lbi)
            hcFlags GHC = ["-agc"]
            hcFlags GHCJS = ["-agc"]
            hcFlags _ = []

    ppAlex :: BuildInfo -> LocalBuildInfo -> PreProcessor
    ppAlex _ lbi = pp { platformIndependent = True }
      where pp = standardPP lbi alexProgram (hcFlags hc)
            hc = compilerFlavor (compiler lbi)
            hcFlags GHC = ["-g"]
            hcFlags GHCJS = ["-g"]
            hcFlags _ = []

    standardPP :: LocalBuildInfo -> Program -> [String] -> PreProcessor
    standardPP lbi prog args =
      PreProcessor {
        platformIndependent = False,
        runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->
          rawSystemProgramConf verbosity prog (withPrograms lbi)
                               (args ++ ["-o", outFile, inFile])
      }

    -- |Convenience function; get the suffixes of these preprocessors.
    ppSuffixes :: [ PPSuffixHandler ] -> [String]
    ppSuffixes = map fst

    -- |Standard preprocessors: GreenCard, c2hs, hsc2hs, happy, alex and cpphs.
    knownSuffixHandlers :: [ PPSuffixHandler ]
    knownSuffixHandlers =
      [ ("gc",     ppGreenCard)
      , ("chs",    ppC2hs)
      , ("hsc",    ppHsc2hs)
      , ("x",      ppAlex)
      , ("y",      ppHappy)
      , ("ly",     ppHappy)
      , ("cpphs",  ppCpp)
      ]