Commit 6764810d authored by Edward Z. Yang's avatar Edward Z. Yang
Browse files

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


Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>
parent 929679c4
......@@ -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
......
......@@ -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
}
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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,6 +150,7 @@ getProgramInvocationOutput verbosity
progInvokePath = path,
progInvokeArgs = args,
progInvokeEnv = envOverrides,
progInvokePathEnv = extraPath,
progInvokeCwd = mcwd,
progInvokeInput = minputStr,
progInvokeOutputEncoding = encoding
......@@ -148,7 +158,8 @@ getProgramInvocationOutput verbosity
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)]
......
......@@ -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,6 +63,7 @@ data ComponentLocalBuildInfo
componentUnitId :: UnitId,
componentPackageDeps :: [(UnitId, PackageId)],
componentIncludes :: [(UnitId, ModuleRenaming)],
componentExeDeps :: [UnitId],
componentInternalDeps :: [UnitId]
}
| TestComponentLocalBuildInfo {
......@@ -69,6 +71,7 @@ data ComponentLocalBuildInfo
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)
......
......@@ -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
......
......@@ -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.
......
......@@ -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,
......
{-# OPTIONS_GHC -F -pgmF my-custom-preprocessor #-}
module A where
a :: String
a = "0000"
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
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
module Main where
import A
main :: IO ()
main = putStrLn a
......@@ -484,6 +484,12 @@ tests config = do
runExe' "hello-world" []
>>= assertOutputContains "hello from A"
-- Test PATH-munging
tc "BuildToolsPath" $ do
cabal_build []
runExe' "hello-world" []
>>= assertOutputContains "1111"
-- Test that executable recompilation works
-- https://github.com/haskell/cabal/issues/3294
tc "Regression/T3294" $ do
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment