Fix #1541, by adding internal build-tools to PATH.

ezyang · ezyang · commit 6764810df3f7 · 2016-08-21T02:02:18.000-07:00
Signed-off-by: Edward Z. Yang &lt;ezyang@cs.stanford.edu&gt;
diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal
@@ -98,6 +98,10 @@ extra-source-files:
   tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs
   tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal
   tests/PackageTests/BuildTestSuiteDetailedV09/Dummy2.hs
+  tests/PackageTests/BuildToolsPath/A.hs
+  tests/PackageTests/BuildToolsPath/MyCustomPreprocessor.hs
+  tests/PackageTests/BuildToolsPath/build-tools-path.cabal
+  tests/PackageTests/BuildToolsPath/hello/Hello.hs
   tests/PackageTests/BuildableField/BuildableField.cabal
   tests/PackageTests/BuildableField/Main.hs
   tests/PackageTests/CMain/Bar.hs
diff --git a/Cabal/Distribution/Simple/Build.hs b/Cabal/Distribution/Simple/Build.hs
@@ -425,6 +425,7 @@ testSuiteLibV09AsLibAndExe pkg_descr
     libClbi = LibComponentLocalBuildInfo
                 { componentPackageDeps = componentPackageDeps clbi
                 , componentInternalDeps = componentInternalDeps clbi
+                , componentExeDeps = componentExeDeps clbi
                 , componentLocalName = CSubLibName (testName test)
                 , componentIsPublic = False
                 , componentIncludes = componentIncludes clbi
@@ -465,6 +466,7 @@ testSuiteLibV09AsLibAndExe pkg_descr
                 -- (doesn't clobber something) we won't run into trouble
                 componentUnitId = mkUnitId (stubName test),
                 componentInternalDeps = [componentUnitId clbi],
+                componentExeDeps = [],
                 componentLocalName = CExeName (stubName test),
                 componentPackageDeps = deps,
                 componentIncludes = zip (map fst deps) (repeat defaultRenaming)
@@ -488,6 +490,7 @@ benchmarkExeV10asExe bm@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f }
                 componentUnitId = componentUnitId clbi,
                 componentLocalName = CExeName (benchmarkName bm),
                 componentInternalDeps = componentInternalDeps clbi,
+                componentExeDeps = componentExeDeps clbi,
                 componentPackageDeps = componentPackageDeps clbi,
                 componentIncludes = componentIncludes clbi
               }
diff --git a/Cabal/Distribution/Simple/Configure.hs b/Cabal/Distribution/Simple/Configure.hs
@@ -1777,14 +1777,7 @@ mkComponentsLocalBuildInfo cfg use_external_internal comp installedPackages pkg_
     foldM go [] graph
   where
     go z (component, dep_cnames) = do
-        -- NB: We want to preserve cdeps because it contains extra
-        -- information like build-tools ordering
-        let dep_uids = [ componentUnitId dep_clbi
-                       | cname <- dep_cnames
-                       -- Being in z relies on topsort!
-                       , dep_clbi <- z
-                       , componentLocalName dep_clbi == cname ]
-        clbi <- componentLocalBuildInfo z component dep_uids
+        clbi <- componentLocalBuildInfo z component dep_cnames
         return (clbi:z)
 
     -- The allPkgDeps contains all the package deps for the whole package
@@ -1793,8 +1786,19 @@ mkComponentsLocalBuildInfo cfg use_external_internal comp installedPackages pkg_
     -- needs. Note, this only works because we cannot yet depend on two
     -- versions of the same package.
     componentLocalBuildInfo :: [ComponentLocalBuildInfo]
-                            -> Component -> [UnitId] -> IO ComponentLocalBuildInfo
-    componentLocalBuildInfo internalComps component dep_uids =
+                            -> Component -> [ComponentName] -> IO ComponentLocalBuildInfo
+    componentLocalBuildInfo internalComps component dep_cnames =
+      -- NB: We want to preserve cdeps because it contains extra
+      -- information like build-tools ordering
+      let dep_uids = [ componentUnitId dep_clbi
+                     | cname <- dep_cnames
+                     , dep_clbi <- internalComps
+                     , componentLocalName dep_clbi == cname ]
+          dep_exes = [ componentUnitId dep_clbi
+                     | cname@(CExeName _) <- dep_cnames
+                     , dep_clbi <- internalComps
+                     , componentLocalName dep_clbi == cname ]
+      in
       -- (putStrLn $ "configuring " ++ display (componentName component)) >>
       case component of
       CLib lib -> do
@@ -1811,6 +1815,7 @@ mkComponentsLocalBuildInfo cfg use_external_internal comp installedPackages pkg_
         return LibComponentLocalBuildInfo {
           componentPackageDeps = cpds,
           componentInternalDeps = dep_uids,
+          componentExeDeps = dep_exes,
           componentUnitId = uid,
           componentLocalName = componentName component,
           componentIsPublic = libName lib == Nothing,
@@ -1823,6 +1828,7 @@ mkComponentsLocalBuildInfo cfg use_external_internal comp installedPackages pkg_
         return ExeComponentLocalBuildInfo {
           componentUnitId = uid,
           componentInternalDeps = dep_uids,
+          componentExeDeps = dep_exes,
           componentLocalName = componentName component,
           componentPackageDeps = cpds,
           componentIncludes = includes
@@ -1831,6 +1837,7 @@ mkComponentsLocalBuildInfo cfg use_external_internal comp installedPackages pkg_
         return TestComponentLocalBuildInfo {
           componentUnitId = uid,
           componentInternalDeps = dep_uids,
+          componentExeDeps = dep_exes,
           componentLocalName = componentName component,
           componentPackageDeps = cpds,
           componentIncludes = includes
@@ -1839,6 +1846,7 @@ mkComponentsLocalBuildInfo cfg use_external_internal comp installedPackages pkg_
         return BenchComponentLocalBuildInfo {
           componentUnitId = uid,
           componentInternalDeps = dep_uids,
+          componentExeDeps = dep_exes,
           componentLocalName = componentName component,
           componentPackageDeps = cpds,
           componentIncludes = includes
diff --git a/Cabal/Distribution/Simple/GHC/Internal.hs b/Cabal/Distribution/Simple/GHC/Internal.hs
@@ -46,6 +46,8 @@ import Distribution.Simple.Setup
 import qualified Distribution.ModuleName as ModuleName
 import Distribution.Simple.Program
 import Distribution.Simple.LocalBuildInfo
+import Distribution.Types.LocalBuildInfo
+import Distribution.Types.TargetInfo
 import Distribution.Simple.Utils
 import Distribution.Simple.BuildPaths
 import Distribution.System
@@ -304,6 +306,7 @@ componentGhcOptions verbosity lbi bi clbi odir =
       ghcOptOptimisation    = toGhcOptimisation (withOptimization lbi),
       ghcOptDebugInfo       = toGhcDebugInfo (withDebugInfo lbi),
       ghcOptExtra           = toNubListR $ hcOptions GHC bi,
+      ghcOptExtraPath       = toNubListR $ exe_paths,
       ghcOptLanguage        = toFlag (fromMaybe Haskell98 (defaultLanguage bi)),
       -- Unsupported extensions have already been checked by configure
       ghcOptExtensions      = toNubListR $ usedExtensions bi,
@@ -320,6 +323,11 @@ componentGhcOptions verbosity lbi bi clbi odir =
     toGhcDebugInfo NormalDebugInfo  = toFlag True
     toGhcDebugInfo MaximalDebugInfo = toFlag True
 
+    exe_paths = [ componentBuildDir lbi (targetCLBI exe_tgt)
+                | uid <- componentExeDeps clbi
+                -- TODO: Ugh, localPkgDescr
+                , Just exe_tgt <- [unitIdTarget' (localPkgDescr lbi) lbi uid] ]
+
 -- | Strip out flags that are not supported in ghci
 filterGhciFlags :: [String] -> [String]
 filterGhciFlags = filter supported
diff --git a/Cabal/Distribution/Simple/Program/GHC.hs b/Cabal/Distribution/Simple/Program/GHC.hs
@@ -210,6 +210,10 @@ data GhcOptions = GhcOptions {
   -- | Get GHC to be quiet or verbose with what it's doing; the @ghc -v@ flag.
   ghcOptVerbosity     :: Flag Verbosity,
 
+  -- | Put the extra folders in the PATH environment variable we invoke
+  -- GHC with
+  ghcOptExtraPath     :: NubListR FilePath,
+
   -- | Let GHC know that it is Cabal that's calling it.
   -- Modifies some of the GHC error messages.
   ghcOptCabal         :: Flag Bool
@@ -251,7 +255,9 @@ runGHC verbosity ghcProg comp platform opts = do
 ghcInvocation :: ConfiguredProgram -> Compiler -> Platform -> GhcOptions
               -> ProgramInvocation
 ghcInvocation prog comp platform opts =
-    programInvocation prog (renderGhcOptions comp platform opts)
+    (programInvocation prog (renderGhcOptions comp platform opts)) {
+        progInvokePathEnv = fromNubListR (ghcOptExtraPath opts)
+    }
 
 renderGhcOptions :: Compiler -> Platform -> GhcOptions -> [String]
 renderGhcOptions comp _platform@(Platform _arch os) opts
diff --git a/Cabal/Distribution/Simple/Program/Run.hs b/Cabal/Distribution/Simple/Program/Run.hs
@@ -32,6 +32,7 @@ import Distribution.Verbosity
 import Distribution.Compat.Environment
 
 import qualified Data.Map as Map
+import System.FilePath
 import System.Exit
          ( ExitCode(..), exitWith )
 
@@ -46,6 +47,8 @@ data ProgramInvocation = ProgramInvocation {
        progInvokePath  :: FilePath,
        progInvokeArgs  :: [String],
        progInvokeEnv   :: [(String, Maybe String)],
+       -- Extra paths to add to PATH
+       progInvokePathEnv :: [FilePath],
        progInvokeCwd   :: Maybe FilePath,
        progInvokeInput :: Maybe String,
        progInvokeInputEncoding  :: IOEncoding,
@@ -61,6 +64,7 @@ emptyProgramInvocation =
     progInvokePath  = "",
     progInvokeArgs  = [],
     progInvokeEnv   = [],
+    progInvokePathEnv = [],
     progInvokeCwd   = Nothing,
     progInvokeInput = Nothing,
     progInvokeInputEncoding  = IOEncodingText,
@@ -91,6 +95,7 @@ runProgramInvocation verbosity
     progInvokePath  = path,
     progInvokeArgs  = args,
     progInvokeEnv   = [],
+    progInvokePathEnv = [],
     progInvokeCwd   = Nothing,
     progInvokeInput = Nothing
   } =
@@ -101,10 +106,12 @@ runProgramInvocation verbosity
     progInvokePath  = path,
     progInvokeArgs  = args,
     progInvokeEnv   = envOverrides,
+    progInvokePathEnv = extraPath,
     progInvokeCwd   = mcwd,
     progInvokeInput = Nothing
   } = do
-    menv <- getEffectiveEnvironment envOverrides
+    pathOverride <- getExtraPathEnv envOverrides extraPath
+    menv <- getEffectiveEnvironment (envOverrides ++ pathOverride)
     exitCode <- rawSystemIOWithEnv verbosity
                                    path args
                                    mcwd menv
@@ -117,11 +124,13 @@ runProgramInvocation verbosity
     progInvokePath  = path,
     progInvokeArgs  = args,
     progInvokeEnv   = envOverrides,
+    progInvokePathEnv = extraPath,
     progInvokeCwd   = mcwd,
     progInvokeInput = Just inputStr,
     progInvokeInputEncoding = encoding
   } = do
-    menv <- getEffectiveEnvironment envOverrides
+    pathOverride <- getExtraPathEnv envOverrides extraPath
+    menv <- getEffectiveEnvironment (envOverrides ++ pathOverride)
     (_, errors, exitCode) <- rawSystemStdInOut verbosity
                                     path args
                                     mcwd menv
@@ -141,14 +150,16 @@ getProgramInvocationOutput verbosity
     progInvokePath  = path,
     progInvokeArgs  = args,
     progInvokeEnv   = envOverrides,
+    progInvokePathEnv = extraPath,
     progInvokeCwd   = mcwd,
     progInvokeInput = minputStr,
     progInvokeOutputEncoding = encoding
   } = do
     let utf8 = case encoding of IOEncodingUTF8 -> True; _ -> False
         decode | utf8      = fromUTF8 . normaliseLineEndings
                | otherwise = id
-    menv <- getEffectiveEnvironment envOverrides
+    pathOverride <- getExtraPathEnv envOverrides extraPath
+    menv <- getEffectiveEnvironment (envOverrides ++ pathOverride)
     (output, errors, exitCode) <- rawSystemStdInOut verbosity
                                     path args
                                     mcwd menv
@@ -166,6 +177,18 @@ getProgramInvocationOutput verbosity
             IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for utf8
 
 
+getExtraPathEnv :: [(String, Maybe String)] -> [FilePath] -> IO [(String, Maybe String)]
+getExtraPathEnv _ [] = return []
+getExtraPathEnv env extras = do
+    mb_path <- case lookup "PATH" env of
+                Just x  -> return x
+                Nothing -> lookupEnv "PATH"
+    let extra = intercalate [searchPathSeparator] extras
+        path' = case mb_path of
+                    Nothing   -> extra
+                    Just path -> extra ++ searchPathSeparator : path
+    return [("PATH", Just path')]
+
 -- | Return the current environment extended with the given overrides.
 --
 getEffectiveEnvironment :: [(String, Maybe String)]
diff --git a/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs b/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs
@@ -40,6 +40,7 @@ data ComponentLocalBuildInfo
     -- @-package-id@ arguments.  This is a modernized version of
     -- 'componentPackageDeps', which is kept around for BC purposes.
     componentIncludes :: [(UnitId, ModuleRenaming)],
+    componentExeDeps :: [UnitId],
     -- | The internal dependencies which induce a graph on the
     -- 'ComponentLocalBuildInfo' of this package.  This does NOT
     -- coincide with 'componentPackageDeps' because it ALSO records
@@ -62,13 +63,15 @@ data ComponentLocalBuildInfo
     componentUnitId :: UnitId,
     componentPackageDeps :: [(UnitId, PackageId)],
     componentIncludes :: [(UnitId, ModuleRenaming)],
+    componentExeDeps :: [UnitId],
     componentInternalDeps :: [UnitId]
   }
   | TestComponentLocalBuildInfo {
     componentLocalName :: ComponentName,
     componentUnitId :: UnitId,
     componentPackageDeps :: [(UnitId, PackageId)],
     componentIncludes :: [(UnitId, ModuleRenaming)],
+    componentExeDeps :: [UnitId],
     componentInternalDeps :: [UnitId]
 
   }
@@ -77,6 +80,7 @@ data ComponentLocalBuildInfo
     componentUnitId :: UnitId,
     componentPackageDeps :: [(UnitId, PackageId)],
     componentIncludes :: [(UnitId, ModuleRenaming)],
+    componentExeDeps :: [UnitId],
     componentInternalDeps :: [UnitId]
   }
   deriving (Generic, Read, Show)
diff --git a/Cabal/Distribution/Types/LocalBuildInfo.hs b/Cabal/Distribution/Types/LocalBuildInfo.hs
@@ -29,6 +29,7 @@ module Distribution.Types.LocalBuildInfo (
     -- details.
 
     componentNameTargets',
+    unitIdTarget',
     allTargetsInBuildOrder',
     withAllTargetsInBuildOrder',
     neededTargetsInBuildOrder',
@@ -39,6 +40,7 @@ module Distribution.Types.LocalBuildInfo (
     -- prevent someone from accidentally defining them
 
     componentNameTargets,
+    unitIdTarget,
     allTargetsInBuildOrder,
     withAllTargetsInBuildOrder,
     neededTargetsInBuildOrder,
@@ -210,6 +212,12 @@ componentNameTargets' pkg_descr lbi cname =
         Just clbis -> map (mkTargetInfo pkg_descr lbi) clbis
         Nothing -> []
 
+unitIdTarget' :: PackageDescription -> LocalBuildInfo -> UnitId -> Maybe TargetInfo
+unitIdTarget' pkg_descr lbi uid =
+    case Graph.lookup uid (componentGraph lbi) of
+        Just clbi -> Just (mkTargetInfo pkg_descr lbi clbi)
+        Nothing -> Nothing
+
 -- | Return all 'ComponentLocalBuildInfo's associated with 'ComponentName'.
 -- In the presence of Backpack there may be more than one!
 componentNameCLBIs :: LocalBuildInfo -> ComponentName -> [ComponentLocalBuildInfo]
@@ -262,11 +270,14 @@ testCoverage lbi = exeCoverage lbi && libCoverage lbi
 -------------------------------------------------------------------------------
 -- Stub functions to prevent someone from accidentally defining them
 
-{-# WARNING componentNameTargets, allTargetsInBuildOrder, withAllTargetsInBuildOrder, neededTargetsInBuildOrder, withNeededTargetsInBuildOrder "By using this function, you may be introducing a bug where you retrieve a 'Component' which does not have 'HookedBuildInfo' applied to it.  See the documentation for 'HookedBuildInfo' for an explanation of the issue.  If you have a 'PakcageDescription' handy (NOT from the 'LocalBuildInfo'), try using the primed version of the function, which takes it as an extra argument." #-}
+{-# WARNING componentNameTargets, unitIdTarget, allTargetsInBuildOrder, withAllTargetsInBuildOrder, neededTargetsInBuildOrder, withNeededTargetsInBuildOrder "By using this function, you may be introducing a bug where you retrieve a 'Component' which does not have 'HookedBuildInfo' applied to it.  See the documentation for 'HookedBuildInfo' for an explanation of the issue.  If you have a 'PakcageDescription' handy (NOT from the 'LocalBuildInfo'), try using the primed version of the function, which takes it as an extra argument." #-}
 
 componentNameTargets :: LocalBuildInfo -> ComponentName -> [TargetInfo]
 componentNameTargets lbi = componentNameTargets' (localPkgDescr lbi) lbi
 
+unitIdTarget :: LocalBuildInfo -> UnitId -> Maybe TargetInfo
+unitIdTarget lbi = unitIdTarget' (localPkgDescr lbi) lbi
+
 allTargetsInBuildOrder :: LocalBuildInfo -> [TargetInfo]
 allTargetsInBuildOrder lbi = allTargetsInBuildOrder' (localPkgDescr lbi) lbi
 
diff --git a/Cabal/changelog b/Cabal/changelog
@@ -70,6 +70,9 @@
 	  the component to be configured.  The semantics of this mode
 	  of operation are described in
 	  <https://github.com/ghc-proposals/ghc-proposals/pull/4>
+	* Internal 'build-tools' dependencies are now added to PATH
+	  upon invocation of GHC, so that they can be conveniently
+	  used via `-pgmF`. (#1541)
 
 1.24.0.0 Ryan Thomas <ryan@ryant.org> March 2016
 	* Support GHC 8.
diff --git a/Cabal/doc/developing-packages.markdown b/Cabal/doc/developing-packages.markdown
@@ -1416,7 +1416,8 @@ for these fields.
     build this package, e.g. `c2hs >= 0.15, cpphs`.  If no version
     constraint is specified, any version is assumed to be acceptable.
     `build-tools` can refer to locally defined executables, in which
-    case Cabal will make sure that executable is built first.
+    case Cabal will make sure that executable is built first and
+    add it to the PATH upon invocations to the compiler.
 
 `buildable:` _boolean_ (default: `True`)
 :   Is the component buildable? Like some of the other fields below,
diff --git a/Cabal/tests/PackageTests/BuildToolsPath/A.hs b/Cabal/tests/PackageTests/BuildToolsPath/A.hs
@@ -0,0 +1,5 @@
+{-# OPTIONS_GHC -F -pgmF my-custom-preprocessor #-}
+module A where
+
+a :: String
+a = "0000"
diff --git a/Cabal/tests/PackageTests/BuildToolsPath/MyCustomPreprocessor.hs b/Cabal/tests/PackageTests/BuildToolsPath/MyCustomPreprocessor.hs
@@ -0,0 +1,11 @@
+module Main where
+
+import System.Environment
+import System.IO
+
+main :: IO ()
+main = do
+  (_:source:target:_) <- getArgs
+  let f '0' = '1'
+      f c = c
+  writeFile target . map f  =<< readFile source
diff --git a/Cabal/tests/PackageTests/BuildToolsPath/build-tools-path.cabal b/Cabal/tests/PackageTests/BuildToolsPath/build-tools-path.cabal
@@ -0,0 +1,25 @@
+name:                build-tools-path
+version:             0.1.0.0
+synopsis:            Checks build-tools are put in PATH
+license:             BSD3
+category:            Testing
+build-type:          Simple
+cabal-version:       >=1.10
+
+executable             my-custom-preprocessor
+  main-is:             MyCustomPreprocessor.hs
+  build-depends:       base, directory
+  default-language:    Haskell2010
+
+library
+  exposed-modules:     A
+  build-depends:       base
+  build-tools:         my-custom-preprocessor
+  -- ^ Note the internal dependency.
+  default-language:    Haskell2010
+
+executable             hello-world
+  main-is:             Hello.hs
+  build-depends:       base, build-tools-path
+  default-language:    Haskell2010
+  hs-source-dirs:      hello
diff --git a/Cabal/tests/PackageTests/BuildToolsPath/hello/Hello.hs b/Cabal/tests/PackageTests/BuildToolsPath/hello/Hello.hs
diff --git a/Cabal/tests/PackageTests/Tests.hs b/Cabal/tests/PackageTests/Tests.hs
