Unverified Commit 2683445c authored by Andrey Mokhov's avatar Andrey Mokhov Committed by GitHub
Browse files

Fix Windows build (#563)

Fix copyFile failure on Windows plus minor revision
parent 3465caf8
......@@ -10,201 +10,183 @@
-- Extracting Haskell package metadata stored in Cabal files.
-----------------------------------------------------------------------------
module Hadrian.Haskell.Cabal.Parse
( PackageData (..), parseCabal, parsePackageData
, parseCabalPkgId
( PackageData (..), parseCabal, parsePackageData, parseCabalPkgId
, configurePackage, copyPackage, registerPackage
) where
import Data.List.Extra
import Development.Shake
import qualified Distribution.ModuleName as ModuleName
import qualified Distribution.ModuleName as C
import qualified Distribution.Package as C
import qualified Distribution.PackageDescription as C
import qualified Distribution.PackageDescription.Configuration as C
import qualified Distribution.PackageDescription.Parsec as C
import qualified Distribution.Simple.Compiler as C (packageKeySupported, languageToFlags, extensionsToFlags, compilerInfo)
import qualified Distribution.Simple.GHC as GHC
import qualified Distribution.Simple.Program.Db as Db
import qualified Distribution.Simple as Hooks (simpleUserHooks, autoconfUserHooks, defaultMainWithHooksNoReadArgs, compilerFlavor, CompilerFlavor(GHC))
import qualified Distribution.Simple.UserHooks as Hooks
import qualified Distribution.Simple.Compiler as C
import qualified Distribution.Simple.GHC as C
import qualified Distribution.Simple.Program.Db as C
import qualified Distribution.Simple as C
import qualified Distribution.Simple.Program.Builtin as C
import qualified Distribution.Simple.Utils as C (findHookedPackageDesc)
import qualified Distribution.Simple.Program.Types as C (programDefaultArgs, programOverrideArgs)
import qualified Distribution.Simple.Utils as C
import qualified Distribution.Simple.Program.Types as C
import qualified Distribution.Simple.Configure as C (getPersistBuildConfig)
import qualified Distribution.Simple.Build as C (initialBuildSteps)
import qualified Distribution.Types.ComponentRequestedSpec as C (defaultComponentRequestedSpec)
import qualified Distribution.Simple.Build as C
import qualified Distribution.Types.ComponentRequestedSpec as C
import qualified Distribution.InstalledPackageInfo as Installed
import qualified Distribution.Simple.PackageIndex as PackageIndex
import qualified Distribution.Simple.PackageIndex as C
import qualified Distribution.Types.LocalBuildInfo as C
import qualified Distribution.Text as C
import qualified Distribution.Types.MungedPackageId as C (mungedName)
import qualified Distribution.Types.MungedPackageId as C
import qualified Distribution.Verbosity as C
import Base
import Builder hiding (Builder)
import Builder
import Context
import Flavour (args)
import GHC.Packages (rts)
import Flavour
import GHC.Packages
import Hadrian.Expression
import Hadrian.Haskell.Cabal.PackageData
import Hadrian.Haskell.Cabal.Type ( Cabal( Cabal ) )
import Hadrian.Haskell.Cabal.Type
import Hadrian.Oracles.TextFile
import Hadrian.Target
import Settings
import Oracles.Setting
-- | Parse the Cabal package identifier from the .cabal file at the given
-- filepath.
-- | Parse the Cabal package identifier from a @.cabal@ file.
parseCabalPkgId :: FilePath -> IO String
parseCabalPkgId file = C.display . C.package . C.packageDescription <$> C.readGenericPackageDescription C.silent file
biModules :: C.PackageDescription -> (C.BuildInfo, [ModuleName.ModuleName])
biModules pd = go [ comp | comp@(bi,_) <- (map libBiModules . maybeToList $ C.library pd)
++ (map exeBiModules $ C.executables pd)
biModules :: C.PackageDescription -> (C.BuildInfo, [C.ModuleName])
biModules pd = go [ comp | comp@(bi,_) <-
(map libBiModules . maybeToList $ C.library pd) ++
(map exeBiModules $ C.executables pd)
, C.buildable bi ]
where libBiModules lib = (C.libBuildInfo lib, C.explicitLibModules lib)
exeBiModules exe = (C.buildInfo exe
, if isHaskell (C.modulePath exe) -- if "main-is: ..." is not a .hs or .lhs file, do
-- not inject "Main" into the modules. This does
-- not respect "-main-is" ghc-arguments! See GHC.hs
-- in Distribution.Simple.GHC from Cabal for the glory
-- details.
then ModuleName.main : C.exeModules exe
where
libBiModules lib = (C.libBuildInfo lib, C.explicitLibModules lib)
exeBiModules exe = (C.buildInfo exe,
-- If "main-is: ..." is not a .hs or .lhs file, do not
-- inject "Main" into the modules. This does not respect
-- "-main-is" ghc-arguments! See Cabal's
-- Distribution.Simple.GHC for the glory details.
if takeExtension (C.modulePath exe) `elem` [".hs", ".lhs"]
then C.main : C.exeModules exe
else C.exeModules exe)
go [] = error "no buildable component found"
go [] = error "No buildable component found."
go [x] = x
go _ = error "can not handle more than one buildinfo yet!"
isHaskell fp = takeExtension fp `elem` [".hs", ".lhs"]
-- | Parse the cabal file of the package from the given 'Context'.
--
-- This function reads the cabal file, gets some information about the compiler
-- to be used corresponding to the stage it gets from the 'Context', and finalizes
-- the package description it got from the cabal file with the additional information
-- it got (e.g platform, compiler version conditionals, package flags).
go _ = error "Cannot handle more than one buildinfo yet."
-- TODO: Add proper error handling for partiality due to Nothing/Left cases.
-- | Parse the Cabal file of the 'Package' from a given 'Context'. This function
-- reads the Cabal file, gets some information about the compiler to be used
-- corresponding to the 'Stage' it gets from the 'Context', and finalises the
-- package description it got from the Cabal file with additional information
-- such as platform, compiler version conditionals, and package flags.
parseCabal :: Context -> Action Cabal
parseCabal context@Context {..} = do
let (Just file) = pkgCabalFile package
let Just file = pkgCabalFile package
-- read the package description from the cabal file
-- Read the package description from the Cabal file
gpd <- liftIO $ C.readGenericPackageDescription C.verbose file
-- configure the package with the ghc compiler for this stage.
-- Configure the package with the GHC for this stage
hcPath <- builderPath (Ghc CompileHs stage)
(compiler, Just platform, _pgdb) <- liftIO $ GHC.configure C.silent (Just hcPath) Nothing Db.emptyProgramDb
(compiler, Just platform, _pgdb) <- liftIO $
C.configure C.silent (Just hcPath) Nothing C.emptyProgramDb
flagList <- interpret (target context (CabalFlags stage) [] []) =<< args <$> flavour
let flags = foldr addFlag mempty flagList
where addFlag :: String -> C.FlagAssignment -> C.FlagAssignment
where
addFlag :: String -> C.FlagAssignment -> C.FlagAssignment
addFlag ('-':name) = C.insertFlagAssignment (C.mkFlagName name) False
addFlag ('+':name) = C.insertFlagAssignment (C.mkFlagName name) True
addFlag name = C.insertFlagAssignment (C.mkFlagName name) True
let (Right (pd,_)) = C.finalizePD flags C.defaultComponentRequestedSpec (const True) platform (C.compilerInfo compiler) [] gpd
let (Right (pd,_)) = C.finalizePD flags C.defaultComponentRequestedSpec
(const True) platform (C.compilerInfo compiler) [] gpd
-- depPkgs are all those packages that are needed. These should be found in
-- the known build packages. Even if they are not build in this stage.
-- the known build packages even if they are not build in this stage.
let depPkgs = map (findPackageByName' . C.unPackageName . C.depPkgName)
. flip C.enabledBuildDepends C.defaultComponentRequestedSpec $ pd
where findPackageByName' p = case findPackageByName p of
Just p' -> p'
Nothing -> error $ "Failed to find package: " ++ show p
$ flip C.enabledBuildDepends C.defaultComponentRequestedSpec pd
where
findPackageByName' p = fromMaybe (error msg) (findPackageByName p)
where
msg = "Failed to find package " ++ quote (show p)
return $ Cabal (C.unPackageName . C.pkgName . C.package $ pd)
(C.display . C.pkgVersion . C.package $ pd)
(C.synopsis pd)
gpd
pd
depPkgs
(C.synopsis pd) gpd pd depPkgs
-- | This function runs the equivalent of @cabal configure@ using the Cabal library
-- directly, collecting all the configuration options and flags to be passed to Cabal
-- before invoking it.
--
-- It of course also 'need's package database entries for the dependencies of
-- the package the 'Context' points to.
-- TODO: Add proper error handling for partiality due to Nothing cases.
-- | This function runs the equivalent of @cabal configure@ using the Cabal
-- library directly, collecting all the configuration options and flags to be
-- passed to Cabal before invoking it. It 'need's package database entries for
-- the dependencies of the package the 'Context' points to.
configurePackage :: Context -> Action ()
configurePackage context@Context {..} = do
Just (Cabal _ _ _ gpd _pd depPkgs) <- readCabalFile context
-- Stage packages are those we have in this stage.
stagePkgs <- stagePackages stage
-- we'll need those package in our package database.
need =<< sequence [ pkgConfFile (context { package = pkg }) | pkg <- depPkgs, pkg `elem` stagePkgs ]
-- We'll need those packages in our package database.
deps <- sequence [ pkgConfFile (context { package = pkg })
| pkg <- depPkgs, pkg `elem` stagePkgs ]
need deps
-- figure out what hooks we need.
-- Figure out what hooks we need.
hooks <- case C.buildType (C.flattenPackageDescription gpd) of
C.Configure -> pure Hooks.autoconfUserHooks
C.Configure -> pure C.autoconfUserHooks
-- time has a "Custom" Setup.hs, but it's actually Configure
-- plus a "./Setup test" hook. However, Cabal is also
-- "Custom", but doesn't have a configure script.
C.Custom ->
do configureExists <- doesFileExist (replaceFileName (unsafePkgCabalFile package) "configure")
if configureExists
then pure Hooks.autoconfUserHooks
else pure Hooks.simpleUserHooks
-- not quite right, but good enough for us:
do configureExists <- doesFileExist
(replaceFileName (unsafePkgCabalFile package) "configure")
pure $ if configureExists then C.autoconfUserHooks
else C.simpleUserHooks
-- Not quite right, but good enough for us:
_ | package == rts ->
-- don't try to do post conf validation for rts.
-- this will simply not work, due to the ld-options,
-- and the Stg.h.
pure $ Hooks.simpleUserHooks { Hooks.postConf = \_ _ _ _ -> return () }
| otherwise -> pure Hooks.simpleUserHooks
-- Don't try to do post conf validation for rts. This will simply
-- not work, due to the ld-options and the Stg.h.
pure $ C.simpleUserHooks { C.postConf = \_ _ _ _ -> return () }
| otherwise -> pure C.simpleUserHooks
case pkgCabalFile package of
Nothing -> error "No a cabal package!"
Nothing -> error "Not a Cabal package!"
Just _ -> do
-- compute the flaglist
flagList <- interpret (target context (CabalFlags stage) [] []) =<< args <$> flavour
-- compute the cabal conf args
argList <- interpret (target context (GhcCabal Conf stage) [] []) =<< args <$> flavour
liftIO $ do
Hooks.defaultMainWithHooksNoReadArgs hooks gpd (argList ++ ["--flags=" ++ unwords flagList])
-- | Copies a built package (that the 'Context' points to) into a package
-- database (the one for the ghc corresponding to the stage the 'Context'
-- points to).
flavourArgs <- args <$> flavour
-- Compute the list of flags.
flagList <- interpret (target context (CabalFlags stage) [] []) flavourArgs
-- Compute the Cabal configurartion arguments.
argList <- interpret (target context (GhcCabal Conf stage) [] []) flavourArgs
liftIO $ C.defaultMainWithHooksNoReadArgs hooks gpd
(argList ++ ["--flags=" ++ unwords flagList])
-- | Copy the 'Package' of a given 'Context' into the package database
-- corresponding to the 'Stage' of the 'Context'.
copyPackage :: Context -> Action ()
copyPackage context@Context {..} = do
-- original invocation
Just (Cabal _ _ _ gpd _ _) <- readCabalFile context
ctxPath <- Context.contextPath context
pkgDbPath <- packageDbPath stage
liftIO $ C.defaultMainWithHooksNoReadArgs C.autoconfUserHooks gpd
[ "copy", "--builddir", ctxPath, "--target-package-db", pkgDbPath ]
top <- topDirectory
ctxPath <- (top -/-) <$> Context.contextPath context
pkgDbPath <- (top -/-) <$> packageDbPath stage
let userHooks = Hooks.autoconfUserHooks
copyHooks = userHooks
hooks = copyHooks
liftIO $ Hooks.defaultMainWithHooksNoReadArgs hooks gpd ["copy", "--builddir", ctxPath, "--target-package-db", pkgDbPath]
-- | Registers a built package (the one the 'Context' points to)
-- into the package database.
-- | Register the 'Package' of a given 'Context' into the package database.
registerPackage :: Context -> Action ()
registerPackage context@Context {..} = do
top <- topDirectory
ctxPath <- (top -/-) <$> Context.contextPath context
ctxPath <- Context.contextPath context
Just (Cabal _ _ _ gpd _ _) <- readCabalFile context
let userHooks = Hooks.autoconfUserHooks
regHooks = userHooks
liftIO $ C.defaultMainWithHooksNoReadArgs C.autoconfUserHooks gpd
[ "register", "--builddir", ctxPath ]
liftIO $
Hooks.defaultMainWithHooksNoReadArgs regHooks gpd ["register", "--builddir", ctxPath]
-- | Parses the 'PackageData' for a package (the one in the 'Context').
-- | Parse the 'PackageData' of the 'Package' of a given 'Context'.
parsePackageData :: Context -> Action PackageData
parsePackageData context@Context {..} = do
-- XXX: This is conceptually wrong!
-- We should use the gpd, and
-- the flagAssignment and compiler, hostPlatform, ... information
-- from the lbi. And then compute the finaliz PD (flags, satisfiable dependencies, platform, compiler info, deps, gpd.)
-- We should use the gpd, the flagAssignment and compiler, hostPlatform, ...
-- information from the lbi. And then compute the finalised PD (flags,
-- satisfiable dependencies, platform, compiler info, deps, gpd.)
--
-- let (Right (pd,_)) = C.finalizePackageDescription flags (const True) platform (compilerInfo compiler) [] gpd
--
-- However when using the new-build path's this might change.
Just (Cabal _ _ _ _gpd pd _depPkgs) <- readCabalFile context
cPath <- Context.contextPath context
......@@ -212,10 +194,11 @@ parsePackageData context@Context {..} = do
lbi <- liftIO $ C.getPersistBuildConfig cPath
-- XXX: move this into it's own rule for build/autogen/cabal_macros.h, and build/autogen/Path_*.hs
-- and "need" them here.
-- XXX: move this into its own rule for "build/autogen/cabal_macros.h", and
-- "build/autogen/Path_*.hs" and 'need' them here.
-- create the cabal_macros.h, ...
-- Note: the `cPath` is ignored. The path that's used is the `buildDir` path from the local build info (lbi).
-- Note: the `cPath` is ignored. The path that's used is the 'buildDir' path
-- from the local build info (lbi).
pdi <- liftIO $ getHookedBuildInfo (pkgPath package)
let pd' = C.updatePackageDescription pdi pd
lbi' = lbi { C.localPkgDescr = pd' }
......@@ -226,39 +209,35 @@ parsePackageData context@Context {..} = do
let extDeps = C.externalPackageDeps lbi'
deps = map (C.display . snd) extDeps
dep_direct = map (fromMaybe (error "dep_keys failed")
. PackageIndex.lookupUnitId (C.installedPkgs lbi')
. C.lookupUnitId (C.installedPkgs lbi')
. fst) extDeps
dep_ipids = map (C.display . Installed.installedUnitId) dep_direct
Just ghcProg = Db.lookupProgram C.ghcProgram (C.withPrograms lbi')
Just ghcProg = C.lookupProgram C.ghcProgram (C.withPrograms lbi')
dep_pkgs = PackageIndex.topologicalOrder (packageHacks (C.installedPkgs lbi'))
dep_pkgs = C.topologicalOrder (packageHacks (C.installedPkgs lbi'))
forDeps f = concatMap f dep_pkgs
-- copied from Distribution.Simple.PreProcess.ppHsc2Hs
packageHacks = case Hooks.compilerFlavor (C.compiler lbi') of
Hooks.GHC | C.pkgName (C.package pd') /= (C.mkPackageName "rts") -> hackRtsPackage
-- Copied from Distribution.Simple.PreProcess.ppHsc2Hs
packageHacks = case C.compilerFlavor (C.compiler lbi') of
C.GHC | C.pkgName (C.package pd') /= (C.mkPackageName "rts") -> 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 | null (PackageIndex.allPackages index) = index
-- 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 | null (C.allPackages index) = index
-- ^ do not hack the empty index
hackRtsPackage index =
case PackageIndex.lookupPackageName index (C.mkPackageName "rts") of
[(_,[rts])] ->
PackageIndex.insert rts{
hackRtsPackage index = case C.lookupPackageName index (C.mkPackageName "rts") of
[(_,[rts])] -> C.insert rts {
Installed.ldOptions = [],
Installed.libraryDirs = filter (not . ("gcc-lib" `isSuffixOf`)) (Installed.libraryDirs rts)} index
-- GHC <= 6.12 had $topdir/gcc-lib in their
-- library-dirs for the rts package, which causes
-- problems when we try to use the in-tree mingw,
-- due to accidentally picking up the incompatible
-- libraries there. So we filter out gcc-lib from
-- the RTS's library-dirs here.
_ -> error "No (or multiple) ghc rts package is registered!!"
Installed.libraryDirs = filter (not . ("gcc-lib" `isSuffixOf`))
(Installed.libraryDirs rts)} index
-- GHC <= 6.12 had $topdir/gcc-lib in their library-dirs for the rts
-- package, which causes problems when we try to use the in-tree
-- mingw, due to accidentally picking up the incompatible libraries
-- there. So we filter out gcc-lib from the RTS's library-dirs here.
_ -> error "No (or multiple) GHC rts package is registered!"
in return $ PackageData
{ dependencies = deps
......@@ -286,27 +265,24 @@ parsePackageData context@Context {..} = do
, cmmSrcs = C.cmmSources . fst . biModules $ pd'
, dataFiles = C.dataFiles pd'
, hcOpts = C.programDefaultArgs ghcProg
++ (C.hcOptions Hooks.GHC . fst . biModules $ pd')
++ C.languageToFlags (C.compiler lbi') (C.defaultLanguage . fst . biModules $ pd')
++ C.extensionsToFlags (C.compiler lbi') (C.usedExtensions . fst . biModules $ pd')
++ (C.hcOptions C.GHC . fst . biModules $ pd')
++ C.languageToFlags (C.compiler lbi') (C.defaultLanguage . fst $ biModules pd')
++ C.extensionsToFlags (C.compiler lbi') (C.usedExtensions . fst $ biModules pd')
++ C.programOverrideArgs ghcProg
, asmOpts = C.asmOptions . fst . biModules $ pd'
, ccOpts = C.ccOptions . fst . biModules $ pd'
, cmmOpts = C.cmmOptions . fst . biModules $ pd'
, cppOpts = C.cppOptions . fst . biModules $ pd'
, ldOpts = C.ldOptions . fst . biModules $ pd'
, asmOpts = C.asmOptions . fst $ biModules pd'
, ccOpts = C.ccOptions . fst $ biModules pd'
, cmmOpts = C.cmmOptions . fst $ biModules pd'
, cppOpts = C.cppOptions . fst $ biModules pd'
, ldOpts = C.ldOptions . fst $ biModules pd'
, depIncludeDirs = forDeps Installed.includeDirs
, depCcOpts = forDeps Installed.ccOptions
, depLdOpts = forDeps Installed.ldOptions
, buildGhciLib = C.withGHCiLib lbi'
}
, buildGhciLib = C.withGHCiLib lbi' }
getHookedBuildInfo :: FilePath -> IO C.HookedBuildInfo
getHookedBuildInfo baseDir = do
-- TODO: We should probably better generate this in the
-- build dir, rather then in the base dir? However
-- `configure` is run in the baseDir.
-- TODO: We should probably better generate this in the build dir, rather then
-- in the base dir? However `configure` is run in the baseDir.
maybe_infoFile <- C.findHookedPackageDesc baseDir
case maybe_infoFile of
Nothing -> return C.emptyHookedBuildInfo
......
......@@ -41,7 +41,6 @@ registerPackages rs context@Context {..} = do
Stage0 | pkg `notElem` bootLibs -> copyConf rs (context { package = pkg }) conf
_ -> buildConf rs (context { package = pkg }) conf
buildConf :: [(Resource, Int)] -> Context -> FilePath -> Action ()
buildConf _ context@Context {..} _conf = do
depPkgIds <- cabalDependencies context
......@@ -49,7 +48,7 @@ buildConf _ context@Context {..} _conf = do
-- setup-config, triggers `ghc-cabal configure`
-- everything of a package should depend on that
-- in the first place.
setupConfig <- (contextPath context) <&> (-/- "setup-config")
setupConfig <- contextPath context <&> (-/- "setup-config")
need [setupConfig]
need =<< mapM (\pkgId -> packageDbPath stage <&> (-/- pkgId <.> "conf")) depPkgIds
......
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