[Git][ghc/ghc][wip/hadrian-sys-cabal] WIP: Cleanup
Matthew Pickering
gitlab at gitlab.haskell.org
Sun May 19 07:59:22 UTC 2019
Matthew Pickering pushed to branch wip/hadrian-sys-cabal at Glasgow Haskell Compiler / GHC
Commits:
79555e97 by Matthew Pickering at 2019-05-19T07:59:04Z
WIP: Cleanup
- - - - -
13 changed files:
- hadrian/hadrian.cabal
- hadrian/src/Base.hs
- hadrian/src/Builder.hs
- hadrian/src/Hadrian/Builder.hs
- hadrian/src/Hadrian/Builder/Ar.hs
- hadrian/src/Hadrian/Package.hs
- hadrian/src/Packages.hs
- hadrian/src/Rules.hs
- hadrian/src/Rules/Download.hs
- hadrian/src/Rules/Library.hs
- hadrian/src/Rules/Register.hs
- − hadrian/src/Settings/Builders/GhcCabal.hs
- hadrian/src/Settings/Builders/SysCabal.hs
Changes:
=====================================
hadrian/hadrian.cabal
=====================================
@@ -130,7 +130,7 @@ executable hadrian
, mtl == 2.2.*
, parsec >= 3.1 && < 3.2
, QuickCheck >= 2.6 && < 2.13
- , shake >= 0.17.6
+ , shake >= 0.18.1
, transformers >= 0.4 && < 0.6
, unordered-containers >= 0.2.1 && < 0.3
build-tools: alex >= 3.1
=====================================
hadrian/src/Base.hs
=====================================
@@ -161,15 +161,15 @@ pkgCabalFile p = do
-- | Path to location of package source files
realPkgPath :: Package -> Action FilePath
realPkgPath p = do
- case pkgPath p of
- Left f -> return f
- Right v -> downloadedPath <&> (-/- (pkgName p ++ "-" ++ v))
+ case pkgLocation p of
+ Internal f -> return f
+ External v -> downloadedPath <&> (-/- (pkgName p ++ "-" ++ v))
-- | Relative path to where to put result files
resPkgPath :: Package -> FilePath
resPkgPath p =
- case pkgPath p of
- Left f -> f
- Right {} -> "gen" </> pkgName p
+ case pkgLocation p of
+ Internal f -> f
+ External {} -> "gen" </> pkgName p
=====================================
hadrian/src/Builder.hs
=====================================
@@ -114,7 +114,6 @@ data Builder = Alex
| Autoreconf FilePath
| DeriveConstants
| Cabal ConfigurationInfo Stage
- | SysCabal FilePath
| SysCabalGet
| Cc CcMode Stage
| Configure FilePath
@@ -305,7 +304,6 @@ systemBuilderPath builder = case builder of
Cc _ _ -> fromKey "cc"
-- We can't ask configure for the path to configure!
Configure _ -> return "configure"
- SysCabal _ -> fromKey "system-cabal"
SysCabalGet {} -> fromKey "system-cabal"
Ghc _ Stage0 -> fromKey "system-ghc"
GhcPkg _ Stage0 -> fromKey "system-ghc-pkg"
=====================================
hadrian/src/Hadrian/Builder.hs
=====================================
@@ -60,7 +60,6 @@ class ShakeValue b => Builder b where
path <- builderPath builder
let msg = if null args then "" else " (" ++ intercalate ", " args ++ ")"
putBuild $ "| Run " ++ show builder ++ msg
- liftIO $ getLine
quietly $ cmd (buildOptions buildInfo) [path] args
-- | Make sure a builder and its runtime dependencies are up-to-date.
=====================================
hadrian/src/Hadrian/Builder/Ar.hs
=====================================
@@ -24,7 +24,6 @@ import Development.Shake.Classes
import GHC.Generics
import Hadrian.Expression
import Hadrian.Utilities
-import Debug.Trace
-- | We support packing and unpacking archives with @ar at .
data ArMode = Pack | Unpack deriving (Eq, Generic, Show)
@@ -50,13 +49,7 @@ arFlagsCount = 2
-- should use 'runArWithoutTempFile' instead.
runAr :: FilePath -> [String] -> Action ()
runAr arPath argList = withTempFile $ \tmp -> do
- traceShowM fileArgs
- doesFileExist (head fileArgs) >>= traceShowM
- doesFileExist (head fileArgs) >>= traceShowM
- liftIO $ getLine
- liftIO $ writeFile tmp $ unwords fileArgs
- liftIO $ getLine
- doesFileExist (head fileArgs) >>= traceShowM
+ writeFile' tmp $ unwords fileArgs
cmd [arPath] flagArgs ('@' : tmp)
where
flagArgs = take arFlagsCount argList
=====================================
hadrian/src/Hadrian/Package.hs
=====================================
@@ -13,11 +13,11 @@
-----------------------------------------------------------------------------
module Hadrian.Package (
-- * Data types
- Package (..), PackageName, PackageType,
+ Package (..), PackageName, PackageType, PackageLocation(..),
-- * Construction and properties
library, program, external, dummyPackage
- , isLibrary, isProgram, isExternalLibrary,
+ , isLibrary, isProgram
) where
@@ -28,7 +28,11 @@ import GHC.Generics
-- See https://github.com/snowleopard/hadrian/issues/12.
data PackageType = Library | Program deriving (Eq, Generic, Ord, Show)
-data InternalExternal = Internal | External deriving (Eq, Generic, Ord, Show)
+data PackageLocation =
+ Internal FilePath -- ^ Path to the file contents relative to
+ -- root directory.
+ | External String -- ^ Version string to fetch package from Hackage.
+ deriving (Eq, Generic, Ord, Show)
type PackageName = String
@@ -42,19 +46,19 @@ data Package = Package {
-- | The path to the package source code relative to the root of the build
-- system. For example, @libraries/Cabal/Cabal@ and @ghc@ are paths to the
-- @Cabal@ and @ghc-bin@ packages in GHC.
- pkgPath :: Either FilePath String
+ pkgLocation :: PackageLocation
} deriving (Eq, Generic, Ord, Show)
-- | Construct a library package.
library :: PackageName -> FilePath -> Package
-library p fp = Package Library p (Left fp)
+library p fp = Package Library p (Internal fp)
external :: PackageName -> String -> Package
-external p v = Package Library p (Right v)
+external p v = Package Library p (External v)
-- | Construct a program package.
program :: PackageName -> FilePath -> Package
-program p fp = Package Program p (Left fp)
+program p fp = Package Program p (Internal fp)
-- TODO: Remove this hack.
-- | A dummy package that we never try to build but use when we need a 'Package'
@@ -72,18 +76,13 @@ isProgram :: Package -> Bool
isProgram (Package Program _ _) = True
isProgram _ = False
-isExternalLibrary :: Package -> Bool
-isExternalLibrary (Package _ _ (Right{})) = True
-isExternalLibrary _ = False
-
-
instance Binary PackageType
instance Hashable PackageType
instance NFData PackageType
-instance Binary InternalExternal
-instance Hashable InternalExternal
-instance NFData InternalExternal
+instance Binary PackageLocation
+instance Hashable PackageLocation
+instance NFData PackageLocation
instance Binary Package
instance Hashable Package
=====================================
hadrian/src/Packages.hs
=====================================
@@ -120,7 +120,7 @@ util name = program name ("utils" -/- name)
-- | Amend a package path if it doesn't conform to a typical pattern.
setPath :: Package -> FilePath -> Package
-setPath pkg path = pkg { pkgPath = Left path }
+setPath pkg path = pkg { pkgLocation = Internal path }
-- | Given a 'Context', compute the name of the program that is built in it
-- assuming that the corresponding package's type is 'Program'. For example, GHC
=====================================
hadrian/src/Rules.hs
=====================================
@@ -29,9 +29,6 @@ import Target
import UserSettings
import Utilities
-import Debug.Trace
-
-
-- | @tool-args@ is used by tooling in order to get the arguments necessary
-- to set up a GHC API session which can compile modules from GHC. When
-- run, the target prints out the arguments that would be passed to @ghc@
@@ -83,12 +80,9 @@ topLevelTargets = action $ do
[ stageHeader "libraries" libNames
, stageHeader "programs" pgmNames ]
let buildStages = [ s | s <- [Stage0 ..], s < finalStage ]
- putNormal "abc"
targets <- concatForM buildStages $ \stage -> do
packages <- stagePackages stage
- traceShowM packages
mapM (path stage) packages
- putNormal (show (targets, buildStages))
-- Why we need wrappers: https://gitlab.haskell.org/ghc/ghc/issues/16534.
root <- buildRoot
=====================================
hadrian/src/Rules/Download.hs
=====================================
@@ -1,46 +1,38 @@
module Rules.Download (downloadRules) where
import Hadrian.BuildPath
-import Hadrian.Haskell.Cabal
-import Hadrian.Haskell.Cabal.Type
import qualified Text.Parsec as Parsec
import Base
import Context
import Expression hiding (way, package)
-import Oracles.ModuleFiles
import Packages
-import Rules.Gmp
-import Rules.Libffi (libffiDependencies)
import Target
import Utilities
-import Debug.Trace
--- * Library 'Rules'
+-- * Rules for downloading a package from an external source
downloadRules :: Rules ()
downloadRules = do
root <- buildRootRules
root -/- downloadedDir -/- "//*.cabal" %> downloadLibrary
+-- | Parses root -/- downloadedDir -/- pkgname-version -/-
parsePackage :: FilePath -> Parsec.Parsec String () String
parsePackage root = do
- Parsec.string root
- Parsec.char '/'
- Parsec.string downloadedDir
- Parsec.char '/'
+ void $ Parsec.string root
+ void $ Parsec.char '/'
+ void $ Parsec.string downloadedDir
+ void $ Parsec.char '/'
Parsec.manyTill Parsec.anyChar (Parsec.try $ Parsec.string "/")
-
-
+-- | Download a library using `cabal get`
downloadLibrary :: FilePath -> Action ()
downloadLibrary fp = do
- traceShowM fp
root <- buildRoot
p <- parsePath (parsePackage root) "package name" fp
- traceShowM p
dPath <- downloadedPath
let ctx = Context Stage0 ghc vanilla
- build $ target ctx (SysCabalGet) [p] []
+ build $ target ctx SysCabalGet [p] []
copyDirectory ("/tmp" </> p) dPath
removeDirectory ("/tmp" </> p)
=====================================
hadrian/src/Rules/Library.hs
=====================================
@@ -15,7 +15,6 @@ import Rules.Libffi (libffiDependencies)
import Target
import Utilities
import Settings
-import Debug.Trace
-- * Library 'Rules'
libraryRules :: Rules ()
@@ -56,12 +55,7 @@ buildStaticLib root archivePath = do
archivePath
let context = libAContext l
objs <- libraryObjects context
- --removeFile archivePath
- traceShowM objs
- doesFileExist (head objs) >>= traceShowM
- doesFileExist (head objs) >>= traceShowM
- doesFileExist (head objs) >>= traceShowM
- liftIO $ getLine
+ removeFile archivePath
build $ target context (Ar Pack stage) objs [archivePath]
synopsis <- pkgSynopsis (package context)
putSuccess $ renderLibrary
@@ -174,21 +168,21 @@ data LibGhci = LibGhci String [Integer] Way deriving (Eq, Show)
-- | Get the 'Context' corresponding to the build path for a given static library.
libAContext :: BuildPath LibA -> Context
-libAContext (BuildPath _ stage pkgpath (LibA pkgname _ way)) =
+libAContext (BuildPath _ stage pkgpath (LibA _ _ way)) =
Context stage pkg way
where
pkg = unsafeFindPackageByPath pkgpath
-- | Get the 'Context' corresponding to the build path for a given GHCi library.
libGhciContext :: BuildPath LibGhci -> Context
-libGhciContext (BuildPath _ stage pkgpath (LibGhci pkgname _ way)) =
+libGhciContext (BuildPath _ stage pkgpath (LibGhci _ _ way)) =
Context stage pkg way
where
pkg = unsafeFindPackageByPath pkgpath
-- | Get the 'Context' corresponding to the build path for a given dynamic library.
libDynContext :: BuildPath LibDyn -> Context
-libDynContext (BuildPath _ stage pkgpath (LibDyn pkgname _ way _)) =
+libDynContext (BuildPath _ stage pkgpath (LibDyn _ _ way _)) =
Context stage pkg way
where
pkg = unsafeFindPackageByPath pkgpath
=====================================
hadrian/src/Rules/Register.hs
=====================================
@@ -88,13 +88,7 @@ registerPackageRules rs stage = do
let ctx = Context stage pkg vanilla
case stage of
Stage0 | isBoot -> copyConf rs ctx conf
--- _ | isExternalLibrary pkg -> buildExternal rs ctx pkg conf
- _ | isLibrary pkg -> buildConf rs ctx conf
-
--- Install a package using the system cabal
-buildExternal :: [(Resource, Int)] -> Context -> Package -> FilePath -> Action ()
-buildExternal rs context Package{..} conf =
- buildWithResources rs $ target context SysCabalGet [] []
+ _ -> buildConf rs ctx conf
buildConf :: [(Resource, Int)] -> Context -> FilePath -> Action ()
buildConf _ context at Context {..} conf = do
=====================================
hadrian/src/Settings/Builders/GhcCabal.hs deleted
=====================================
@@ -1,162 +0,0 @@
-module Settings.Builders.GhcCabal (
- ghcCabalBuilderArgs
- ) where
-
-import Data.Maybe (fromJust)
-
-import Builder ( ArMode ( Pack ) )
-import Context
-import Flavour
-import GHC.Packages
-import Hadrian.Builder (getBuilderPath, needBuilder )
-import Hadrian.Haskell.Cabal
-import Settings.Builders.Common
-
-ghcCabalBuilderArgs :: Args
-ghcCabalBuilderArgs = mconcat
- [ builder (GhcCabal Conf) ? do
- verbosity <- expr getVerbosity
- top <- expr topDirectory
- path <- getContextPath
- stage <- getStage
- mconcat [ arg "configure"
- -- don't strip libraries when cross compiling.
- -- XXX we need to set --with-strip= (stripCmdPath :: Action FilePath), and if it's ':' disable
- -- stripping as well. As it is now, I believe we might have issues with stripping on
- -- windows, as I can't see a consumer of `stripCmdPath`.
- -- TODO: See https://github.com/snowleopard/hadrian/issues/549.
- , flag CrossCompiling ? pure [ "--disable-executable-stripping"
- , "--disable-library-stripping" ]
- , arg "--cabal-file"
- , arg =<< fromJust . pkgCabalFile <$> getPackage
- , arg "--distdir"
- , arg $ top -/- path
- , arg "--ipid"
- , arg "$pkg-$version"
- , arg "--prefix"
- , arg "${pkgroot}/.."
- , withStaged $ Ghc CompileHs
- , withStaged (GhcPkg Update)
- , withBuilderArgs (GhcPkg Update stage)
- , bootPackageDatabaseArgs
- , libraryArgs
- , configureArgs
- , bootPackageConstraints
- , withStaged $ Cc CompileC
- , notStage0 ? with (Ld stage)
- , withStaged (Ar Pack)
- , with Alex
- , with Happy
- , verbosity < Chatty ?
- pure [ "-v0", "--configure-option=--quiet"
- , "--configure-option=--disable-option-checking"
- ]
- ]
- ]
-
--- TODO: Isn't vanilla always built? If yes, some conditions are redundant.
--- TODO: Need compiler_stage1_CONFIGURE_OPTS += --disable-library-for-ghci?
--- TODO: should `elem` be `wayUnit`?
--- This approach still doesn't work. Previously libraries were build only in the
--- Default flavours and not using context.
-libraryArgs :: Args
-libraryArgs = do
- flavourWays <- getLibraryWays
- contextWay <- getWay
- withGhci <- expr ghcWithInterpreter
- dynPrograms <- dynamicGhcPrograms <$> expr flavour
- let ways = flavourWays ++ [contextWay]
- pure [ if vanilla `elem` ways
- then "--enable-library-vanilla"
- else "--disable-library-vanilla"
- , if vanilla `elem` ways && withGhci && not dynPrograms
- then "--enable-library-for-ghci"
- else "--disable-library-for-ghci"
- , if or [Profiling `wayUnit` way | way <- ways]
- then "--enable-library-profiling"
- else "--disable-library-profiling"
- , if or [Dynamic `wayUnit` way | way <- ways]
- then "--enable-shared"
- else "--disable-shared" ]
-
--- TODO: LD_OPTS?
-configureArgs :: Args
-configureArgs = do
- top <- expr topDirectory
- root <- getBuildRoot
- pkg <- getPackage
- let conf key expr = do
- values <- unwords <$> expr
- not (null values) ?
- arg ("--configure-option=" ++ key ++ "=" ++ values)
- cFlags = mconcat [ remove ["-Werror"] cArgs
- , getStagedSettingList ConfCcArgs
- , arg $ "-I" ++ top -/- root -/- generatedDir
- -- See https://github.com/snowleopard/hadrian/issues/523
- , arg $ "-I" ++ top -/- pkgPath pkg
- , arg $ "-I" ++ top -/- "includes" ]
- ldFlags = ldArgs <> (getStagedSettingList ConfGccLinkerArgs)
- cppFlags = cppArgs <> (getStagedSettingList ConfCppArgs)
- cldFlags <- unwords <$> (cFlags <> ldFlags)
- mconcat
- [ conf "CFLAGS" cFlags
- , conf "LDFLAGS" ldFlags
- , conf "CPPFLAGS" cppFlags
- , not (null cldFlags) ? arg ("--gcc-options=" ++ cldFlags)
- , conf "--with-iconv-includes" $ arg =<< getSetting IconvIncludeDir
- , conf "--with-iconv-libraries" $ arg =<< getSetting IconvLibDir
- , conf "--with-gmp-includes" $ arg =<< getSetting GmpIncludeDir
- , conf "--with-gmp-libraries" $ arg =<< getSetting GmpLibDir
- , conf "--with-curses-libraries" $ arg =<< getSetting CursesLibDir
- , flag CrossCompiling ? (conf "--host" $ arg =<< getSetting TargetPlatformFull)
- , conf "--with-cc" $ arg =<< getBuilderPath . (Cc CompileC) =<< getStage
- , notStage0 ? (arg =<< ("--ghc-option=-ghcversion-file=" ++) <$> expr ((-/-) <$> topDirectory <*> ghcVersionH))]
-
-bootPackageConstraints :: Args
-bootPackageConstraints = stage0 ? do
- bootPkgs <- expr $ stagePackages Stage0
- let pkgs = filter (\p -> p /= compiler && isLibrary p) bootPkgs
- ctx <- getContext
- constraints <- expr $ fmap catMaybes $ forM (sort pkgs) $ \pkg -> do
- version <- pkgVersion (ctx { Context.package = pkg})
- return $ fmap ((pkgName pkg ++ " == ") ++) version
- pure $ concat [ ["--constraint", c] | c <- constraints ]
-
-cppArgs :: Args
-cppArgs = do
- root <- getBuildRoot
- arg $ "-I" ++ root -/- generatedDir
-
-withBuilderKey :: Builder -> String
-withBuilderKey b = case b of
- Ar _ _ -> "--with-ar="
- Ld _ -> "--with-ld="
- Cc _ _ -> "--with-gcc="
- Ghc _ _ -> "--with-ghc="
- Alex -> "--with-alex="
- Happy -> "--with-happy="
- GhcPkg _ _ -> "--with-ghc-pkg="
- _ -> error $ "withBuilderKey: not supported builder " ++ show b
-
--- Adds arguments to builders if needed.
-withBuilderArgs :: Builder -> Args
-withBuilderArgs b = case b of
- GhcPkg _ stage -> do
- top <- expr topDirectory
- pkgDb <- expr $ packageDbPath stage
- notStage0 ? arg ("--ghc-pkg-option=--global-package-db=" ++ top -/- pkgDb)
- _ -> return [] -- no arguments
-
-
--- Expression 'with Alex' appends "--with-alex=/path/to/alex" and needs Alex.
-with :: Builder -> Args
-with b = do
- path <- getBuilderPath b
- if (null path) then mempty else do
- top <- expr topDirectory
- expr $ needBuilder b
- arg $ withBuilderKey b ++ unifyPath (top </> path)
-
-withStaged :: (Stage -> Builder) -> Args
-withStaged sb = with . sb =<< getStage
-
=====================================
hadrian/src/Settings/Builders/SysCabal.hs
=====================================
@@ -1,28 +1,11 @@
module Settings.Builders.SysCabal (sysCabalBuilderArgs) where
import Settings.Builders.Common
-import Packages
sysCabalBuilderArgs :: Args
sysCabalBuilderArgs = mconcat
- [ builder (SysCabal "groups")? do
- verbosity <- expr getVerbosity
- stage <- getStage
- --top <- expr topDirectory
- pkgDb <- expr $ packageDbPath stage
- ghcPath <- expr $ builderPath (Ghc CompileHs stage)
- mconcat [ arg "install"
- , arg =<< ((++ "/") <$> getInput)
- , arg "--with-compiler"
- , arg ghcPath
- , arg "--package-db"
- , arg pkgDb
- , arg "--ipid"
- , arg "$pkg-$version"
-
- , verbosity < Chatty ? arg "-v0" ]
- , builder SysCabalGet ? do
- p <- expr $ downloadedPath
+ [ builder SysCabalGet ? do
+-- p <- expr $ downloadedPath
mconcat [ arg "get"
, arg =<< getInput
, arg "--destdir"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/79555e97b5de3a81ff21f3e2ad7bff86802074f6
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/79555e97b5de3a81ff21f3e2ad7bff86802074f6
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20190519/3d0c6c79/attachment-0001.html>
More information about the ghc-commits
mailing list