Allow preprocessors to specify extra C sources

Add functionality to allow preprocessors like hsc2hs and C2HS to inform
Cabal of extra C sources that they create that need to be compiled and
linked.  Includes hsc2hs-based test case.

Cabal/Cabal.cabal

@@ -300,6 +300,7 @@ test-suite package-tests
     PackageTests.PathsModule.Executable.Check
     PackageTests.PathsModule.Library.Check
     PackageTests.PreProcess.Check
+    PackageTests.PreProcessExtraSources.Check
     PackageTests.ReexportedModules.Check
     PackageTests.TemplateHaskell.Check
     PackageTests.TestOptions.Check

Cabal/Distribution/Simple/Build.hs

@@ -52,7 +52,7 @@ import Distribution.Simple.Setup
 import Distribution.Simple.BuildTarget
          ( BuildTarget(..), readBuildTargets )
 import Distribution.Simple.PreProcess
-         ( preprocessComponent, PPSuffixHandler )
+         ( preprocessComponent, preprocessExtras, PPSuffixHandler )
 import Distribution.Simple.LocalBuildInfo
          ( LocalBuildInfo(compiler, buildDir, withPackageDB, withPrograms, pkgKey)
          , Component(..), componentName, getComponent, componentBuildInfo
@@ -79,6 +79,7 @@ import Distribution.Text
          ( display )
 
 import qualified Data.Map as Map
+import qualified Data.Set as Set
 import Data.Maybe
          ( maybeToList )
 import Data.Either
@@ -197,36 +198,44 @@ buildComponent :: Verbosity
 buildComponent verbosity numJobs pkg_descr lbi suffixes
                comp@(CLib lib) clbi distPref = do
     preprocessComponent pkg_descr comp lbi False verbosity suffixes
+    extras <- preprocessExtras comp lbi verbosity
     info verbosity "Building library..."
-    buildLib verbosity numJobs pkg_descr lbi lib clbi
+    let libbi = libBuildInfo lib
+        lib' = lib { libBuildInfo = addExtraCSources libbi extras }
+    buildLib verbosity numJobs pkg_descr lbi lib' clbi
 
     -- Register the library in-place, so exes can depend
     -- on internally defined libraries.
     pwd <- getCurrentDirectory
     let -- The in place registration uses the "-inplace" suffix, not an ABI hash
         ipkgid           = inplacePackageId (packageId installedPkgInfo)
         installedPkgInfo = inplaceInstalledPackageInfo pwd distPref pkg_descr
-                                                       ipkgid lib lbi clbi
+                                                       ipkgid lib' lbi clbi
 
     registerPackage verbosity
       installedPkgInfo pkg_descr lbi True -- True meaning in place
       (withPackageDB lbi)
 
-
 buildComponent verbosity numJobs pkg_descr lbi suffixes
                comp@(CExe exe) clbi _ = do
     preprocessComponent pkg_descr comp lbi False verbosity suffixes
+    extras <- preprocessExtras comp lbi verbosity
     info verbosity $ "Building executable " ++ exeName exe ++ "..."
-    buildExe verbosity numJobs pkg_descr lbi exe clbi
+    let ebi = buildInfo exe
+        exe' = exe { buildInfo = addExtraCSources ebi extras }
+    buildExe verbosity numJobs pkg_descr lbi exe' clbi
 
 
 buildComponent verbosity numJobs pkg_descr lbi suffixes
                comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} })
                clbi _distPref = do
     let exe = testSuiteExeV10AsExe test
     preprocessComponent pkg_descr comp lbi False verbosity suffixes
+    extras <- preprocessExtras comp lbi verbosity
     info verbosity $ "Building test suite " ++ testName test ++ "..."
-    buildExe verbosity numJobs pkg_descr lbi exe clbi
+    let ebi = buildInfo exe
+        exe' = exe { buildInfo = addExtraCSources ebi extras }
+    buildExe verbosity numJobs pkg_descr lbi exe' clbi
 
 
 buildComponent verbosity numJobs pkg_descr lbi0 suffixes
@@ -242,10 +251,13 @@ buildComponent verbosity numJobs pkg_descr lbi0 suffixes
     let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) =
           testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd
     preprocessComponent pkg_descr comp lbi False verbosity suffixes
+    extras <- preprocessExtras comp lbi verbosity
     info verbosity $ "Building test suite " ++ testName test ++ "..."
     buildLib verbosity numJobs pkg lbi lib libClbi
     registerPackage verbosity ipi pkg lbi True $ withPackageDB lbi
-    buildExe verbosity numJobs pkg_descr lbi exe exeClbi
+    let ebi = buildInfo exe
+        exe' = exe { buildInfo = addExtraCSources ebi extras }
+    buildExe verbosity numJobs pkg_descr lbi exe' exeClbi
 
 
 buildComponent _ _ _ _ _
@@ -259,8 +271,11 @@ buildComponent verbosity numJobs pkg_descr lbi suffixes
                clbi _ = do
     let (exe, exeClbi) = benchmarkExeV10asExe bm clbi
     preprocessComponent pkg_descr comp lbi False verbosity suffixes
+    extras <- preprocessExtras comp lbi verbosity
     info verbosity $ "Building benchmark " ++ benchmarkName bm ++ "..."
-    buildExe verbosity numJobs pkg_descr lbi exe exeClbi
+    let ebi = buildInfo exe
+        exe' = exe { buildInfo = addExtraCSources ebi extras }
+    buildExe verbosity numJobs pkg_descr lbi exe' exeClbi
 
 
 buildComponent _ _ _ _ _
@@ -269,6 +284,13 @@ buildComponent _ _ _ _ _
     die $ "No support for building benchmark type " ++ display tt
 
 
+addExtraCSources :: BuildInfo -> [FilePath] -> BuildInfo
+addExtraCSources bi extras = bi { cSources = new }
+  where new = Set.toList $ old `Set.union` exs
+        old = Set.fromList $ cSources bi
+        exs = Set.fromList extras
+
+
 replComponent :: Verbosity
               -> PackageDescription
               -> LocalBuildInfo
@@ -280,20 +302,29 @@ replComponent :: Verbosity
 replComponent verbosity pkg_descr lbi suffixes
                comp@(CLib lib) clbi _ = do
     preprocessComponent pkg_descr comp lbi False verbosity suffixes
-    replLib verbosity pkg_descr lbi lib clbi
+    extras <- preprocessExtras comp lbi verbosity
+    let libbi = libBuildInfo lib
+        lib' = lib { libBuildInfo = libbi { cSources = cSources libbi ++ extras } }
+    replLib verbosity pkg_descr lbi lib' clbi
 
 replComponent verbosity pkg_descr lbi suffixes
                comp@(CExe exe) clbi _ = do
     preprocessComponent pkg_descr comp lbi False verbosity suffixes
-    replExe verbosity pkg_descr lbi exe clbi
+    extras <- preprocessExtras comp lbi verbosity
+    let ebi = buildInfo exe
+        exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } }
+    replExe verbosity pkg_descr lbi exe' clbi
 
 
 replComponent verbosity pkg_descr lbi suffixes
                comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} })
                clbi _distPref = do
     let exe = testSuiteExeV10AsExe test
     preprocessComponent pkg_descr comp lbi False verbosity suffixes
-    replExe verbosity pkg_descr lbi exe clbi
+    extras <- preprocessExtras comp lbi verbosity
+    let ebi = buildInfo exe
+        exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } }
+    replExe verbosity pkg_descr lbi exe' clbi
 
 
 replComponent verbosity pkg_descr lbi0 suffixes
@@ -304,7 +335,10 @@ replComponent verbosity pkg_descr lbi0 suffixes
     let (pkg, lib, libClbi, lbi, _, _, _) =
           testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd
     preprocessComponent pkg_descr comp lbi False verbosity suffixes
-    replLib verbosity pkg lbi lib libClbi
+    extras <- preprocessExtras comp lbi verbosity
+    let libbi = libBuildInfo lib
+        lib' = lib { libBuildInfo = libbi { cSources = cSources libbi ++ extras } }
+    replLib verbosity pkg lbi lib' libClbi
 
 
 replComponent _ _ _ _
@@ -318,7 +352,10 @@ replComponent verbosity pkg_descr lbi suffixes
                clbi _ = do
     let (exe, exeClbi) = benchmarkExeV10asExe bm clbi
     preprocessComponent pkg_descr comp lbi False verbosity suffixes
-    replExe verbosity pkg_descr lbi exe exeClbi
+    extras <- preprocessExtras comp lbi verbosity
+    let ebi = buildInfo exe
+        exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } }
+    replExe verbosity pkg_descr lbi exe' exeClbi
 
 
 replComponent _ _ _ _

Cabal/Distribution/Simple/PreProcess.hs

@@ -17,8 +17,9 @@
 -- 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(..),
+module Distribution.Simple.PreProcess (preprocessComponent, preprocessExtras,
+                                knownSuffixHandlers, ppSuffixes,
+                                PPSuffixHandler, PreProcessor(..),
                                 mkSimplePreProcessor, runSimplePreProcessor,
                                 ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs,
                                 ppHappy, ppAlex, ppUnlit, platformDefines
@@ -129,6 +130,14 @@ data PreProcessor = PreProcessor {
                   -> IO ()     -- Should exit if the preprocessor fails
   }
 
+-- Function to determine paths to possible extra C sources for a
+-- preprocessor: same directory and filename arguments ass
+-- runPreProcessor.
+
+type PreProcessorExtras =
+  (FilePath, FilePath) -> (FilePath, FilePath) -> IO [FilePath]
+
+
 mkSimplePreProcessor :: (FilePath -> FilePath -> Verbosity -> IO ())
                       -> (FilePath, FilePath)
                       -> (FilePath, FilePath) -> Verbosity -> IO ()
@@ -455,6 +464,13 @@ ppHsc2hs bi lbi =
            -> PackageIndex.insert rts { Installed.ldOptions = [] } index
         _  -> error "No (or multiple) ghc rts package is registered!!"
 
+ppHsc2hsExtras :: PreProcessorExtras
+ppHsc2hsExtras _ (outBaseDir, outRelativeFile) = do
+  let possCFile = outBaseDir </> dropExtensions outRelativeFile ++ "_hsc.c"
+  exists <- doesFileExist possCFile
+  if exists
+    then return [possCFile]
+    else return []
 
 ppC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor
 ppC2hs bi lbi =
@@ -490,6 +506,14 @@ ppC2hs bi lbi =
   where
     pkgs = PackageIndex.topologicalOrder (installedPkgs lbi)
 
+ppC2hsExtras :: PreProcessorExtras
+ppC2hsExtras _ (outBaseDir, outRelativeFile) = do
+  let possCFile = outBaseDir </> replaceExtension outRelativeFile ".chs.c"
+  exists <- doesFileExist possCFile
+  if exists
+    then return [possCFile]
+    else return []
+
 --TODO: perhaps use this with hsc2hs too
 --TODO: remove cc-options from cpphs for cabal-version: >= 1.10
 getCppOptions :: BuildInfo -> LocalBuildInfo -> [String]
@@ -620,3 +644,86 @@ knownSuffixHandlers =
   , ("ly",     ppHappy)
   , ("cpphs",  ppCpp)
   ]
+
+-- |Standard preprocessors with possible extra C sources: c2hs, hsc2hs.
+knownSuffixExtrasHandlers :: [ (String, PreProcessorExtras) ]
+knownSuffixExtrasHandlers =
+  [ ("chs",    ppC2hsExtras)
+  , ("hsc",    ppHsc2hsExtras)
+  ]
+
+preprocessExtras :: Component
+                 -> LocalBuildInfo
+                 -> Verbosity
+                 -> IO [FilePath]
+preprocessExtras comp lbi verbosity = case comp of
+  (CLib lib@Library{ libBuildInfo = bi }) -> do
+    let dirs = hsSourceDirs bi ++ [autogenModulesDir lbi]
+    extrass <- forM (map ModuleName.toFilePath $ libModules lib) $
+               pre dirs (buildDir lbi)
+    return $ concat extrass
+  (CExe exe@Executable { buildInfo = bi, exeName = nm }) -> do
+    let exeDir = buildDir lbi </> nm </> nm ++ "-tmp"
+        dirs   = hsSourceDirs bi ++ [autogenModulesDir lbi]
+    extrass <- forM (map ModuleName.toFilePath $ otherModules bi) $
+               pre dirs exeDir
+    extras2 <- pre (hsSourceDirs bi) exeDir $ dropExtensions (modulePath exe)
+    return $ concat extrass ++ extras2
+  CTest test -> do
+    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"
+          preProcessTest test (stubFilePath test) testDir
+      TestSuiteUnsupported tt -> die $ "No support for preprocessing test "
+                                    ++ "suite type " ++ display tt
+  CBench bm -> do
+    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
+    pre dirs dir fp = preprocessFileExtras dirs dir fp verbosity
+    preProcessTest test = preProcessExtras (testBuildInfo test)
+                          (testModules test)
+    preProcessBench bm = preProcessExtras (benchmarkBuildInfo bm)
+                         (benchmarkModules bm)
+    preProcessExtras bi modules exePath dir = do
+        let sourceDirs = hsSourceDirs bi ++ [ autogenModulesDir lbi ]
+        extrass <- sequence [ preprocessFileExtras sourceDirs dir
+                          (ModuleName.toFilePath modu) verbosity
+                          | modu <- modules ]
+        extras2 <- preprocessFileExtras (dir : (hsSourceDirs bi)) dir
+                   (dropExtensions $ exePath) verbosity
+        return $ concat extrass ++ extras2
+
+preprocessFileExtras
+    :: [FilePath]               -- ^source directories
+    -> FilePath                 -- ^build directory
+    -> FilePath                 -- ^module file name
+    -> Verbosity                -- ^verbosity
+    -> IO [FilePath]
+preprocessFileExtras searchLoc buildLoc baseFile verbosity = 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 knownSuffixExtrasHandlers)
+                   searchLoc baseFile
+    case psrcFiles of
+      Nothing -> return []
+        -- found a pre-processable file in one of the source dirs
+      Just (psrcLoc, psrcRelFile) -> do
+            let (srcStem, ext) = splitExtension psrcRelFile
+                pp = fromMaybe (error "Internal error in preProcess module: Just expected")
+                               (lookup (tailNotNull ext) knownSuffixExtrasHandlers)
+                destDir = buildLoc </> takeDirectory srcStem
+            createDirectoryIfMissingVerbose verbosity True destDir
+            pp (psrcLoc, psrcRelFile) (buildLoc, srcStem <.> "hs")
+
+  where
+    tailNotNull [] = []
+    tailNotNull x  = tail x

Cabal/changelog

@@ -32,6 +32,7 @@
 	running tests/benchmarks (#1821).
 	* Build shared libraries by default when linking executables dynamically.
 	* Build profiled libraries by default when profiling executables.
+	* Deal with extra C sources from preprocessors (#238).
 
 1.20.0.1 Johan Tibell <[email protected]> May 2014
 	* Fix streaming test output.

Cabal/doc/developing-packages.markdown

@@ -705,8 +705,12 @@ simple build infrastructure understands the extensions:
 * `.x` ([alex][])
 * `.cpphs` ([cpphs][])
 
-When building, Cabal will automatically run the appropriate preprocessor
-and compile the Haskell module it produces.
+When building, Cabal will automatically run the appropriate
+preprocessor and compile the Haskell module it produces.  For the
+`c2hs` and `hsc2hs` preprocessors, Cabal will also automatically add,
+compile and link any C sources generated by the preprocessor (produced
+by `hsc2hs`'s `#def` feature or `c2hs`'s auto-generated wrapper
+functions).
 
 Some fields take lists of values, which are optionally separated by commas,
 except for the `build-depends` field, where the commas are mandatory.

Cabal/tests/PackageTests.hs

@@ -25,6 +25,7 @@ import PackageTests.PackageTester (PackageSpec(..), compileSetup)
 import PackageTests.PathsModule.Executable.Check
 import PackageTests.PathsModule.Library.Check
 import PackageTests.PreProcess.Check
+import PackageTests.PreProcessExtraSources.Check
 import PackageTests.TemplateHaskell.Check
 import PackageTests.CMain.Check
 import PackageTests.DeterministicAr.Check
@@ -69,6 +70,8 @@ tests version inplaceSpec ghcPath ghcPkgPath =
     , testCase "BuildDeps/InternalLibrary0"
       (PackageTests.BuildDeps.InternalLibrary0.Check.suite version ghcPath)
     , testCase "PreProcess" (PackageTests.PreProcess.Check.suite ghcPath)
+    , testCase "PreProcessExtraSources"
+      (PackageTests.PreProcessExtraSources.Check.suite ghcPath)
     , testCase "TestStanza" (PackageTests.TestStanza.Check.suite ghcPath)
       -- ^ The Test stanza test will eventually be required
       -- only for higher versions.

Cabal/tests/PackageTests/PreProcessExtraSources/Check.hs

@@ -0,0 +1,16 @@
+module PackageTests.PreProcessExtraSources.Check (suite) where
+
+import PackageTests.PackageTester
+    (PackageSpec(..), assertBuildSucceeded, cabal_build)
+import System.FilePath
+import Test.Tasty.HUnit
+
+suite :: FilePath -> Assertion
+suite ghcPath = do
+    let spec = PackageSpec
+            { directory = "PackageTests" </> "PreProcessExtraSources"
+            , distPref = Nothing
+            , configOpts = ["--enable-tests", "--enable-benchmarks"]
+            }
+    result <- cabal_build spec ghcPath
+    assertBuildSucceeded result

Cabal/tests/PackageTests/PreProcessExtraSources/Foo.hsc

@@ -0,0 +1,9 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+module Foo where
+
+import Foreign.C.Types
+
+#def int incr(int x) { return x + 1; }
+
+foreign import ccall unsafe "Foo_hsc.h incr"
+  incr :: CInt -> CInt

Cabal/tests/PackageTests/PreProcessExtraSources/Main.hs

@@ -0,0 +1,8 @@
+module Main where
+
+import Foo
+
+main :: IO ()
+main = do
+  let x = incr 4
+  return ()