Commit 7c65e098 authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Simplify Package data type

parent 39a2b895
......@@ -109,7 +109,6 @@ executable hadrian
, ScopedTypeVariables
, TupleSections
other-extensions: MultiParamTypeClasses
, OverloadedStrings
, TypeFamilies
build-depends: base >= 4.8 && < 5
, ansi-terminal == 0.6.*
......
......@@ -24,7 +24,7 @@ data Context = Context
{ stage :: Stage -- ^ Currently build Stage
, package :: Package -- ^ Currently build Package
, way :: Way -- ^ Currently build Way (usually 'vanilla')
} deriving (Show, Eq, Generic)
} deriving (Eq, Generic, Show)
instance Binary Context
instance Hashable Context
......@@ -96,7 +96,7 @@ pkgSetupConfigFile context = do
pkgHaddockFile :: Context -> Action FilePath
pkgHaddockFile context@Context {..} = do
path <- buildPath context
let name = pkgNameString package
let name = pkgName package
return $ path -/- "doc/html" -/- name -/- name <.> "haddock"
-- | Path to the library file of a given 'Context', e.g.:
......
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
module GHC (
-- * GHC packages
......@@ -30,9 +29,9 @@ import Oracles.Setting
-- | These are all GHC packages we know about. Build rules will be generated for
-- all of them. However, not all of these packages will be built. For example,
-- package 'win32' is built only on Windows.
-- "Packages" defines default conditions for building each package, which can
-- be overridden in @hadrian/src/UserSettings.hs@.
-- package 'win32' is built only on Windows. "Settings.Default" defines default
-- conditions for building each package, which can be overridden in
-- @hadrian/src/UserSettings.hs@.
defaultKnownPackages :: [Package]
defaultKnownPackages =
[ array, base, binary, bytestring, cabal, checkApiAnnotations, compareSizes
......@@ -45,59 +44,80 @@ defaultKnownPackages =
, xhtml ]
-- | Package definitions, see 'Package'.
array = library "array"
base = library "base"
binary = library "binary"
bytestring = library "bytestring"
cabal = library "Cabal" `setPath` "libraries/Cabal/Cabal"
checkApiAnnotations = utility "check-api-annotations"
compareSizes = utility "compareSizes" `setPath` "utils/compare_sizes"
compiler = topLevel "ghc" `setPath` "compiler"
containers = library "containers"
deepseq = library "deepseq"
deriveConstants = utility "deriveConstants"
directory = library "directory"
dllSplit = utility "dll-split"
filepath = library "filepath"
genapply = utility "genapply"
genprimopcode = utility "genprimopcode"
ghc = topLevel "ghc-bin" `setPath` "ghc" `setType` Program
ghcBoot = library "ghc-boot"
ghcBootTh = library "ghc-boot-th"
ghcCabal = utility "ghc-cabal"
ghcCompact = library "ghc-compact"
ghci = library "ghci"
ghcPkg = utility "ghc-pkg"
ghcPrim = library "ghc-prim"
ghcTags = utility "ghctags"
ghcSplit = utility "ghc-split"
haddock = utility "haddock"
haskeline = library "haskeline"
hsc2hs = utility "hsc2hs"
hp2ps = utility "hp2ps"
hpc = library "hpc"
hpcBin = utility "hpc-bin" `setPath` "utils/hpc"
integerGmp = library "integer-gmp"
integerSimple = library "integer-simple"
iservBin = topLevel "iserv-bin" `setPath` "iserv" `setType` Program
libffi = topLevel "libffi"
mkUserGuidePart = utility "mkUserGuidePart"
parallel = library "parallel"
pretty = library "pretty"
primitive = library "primitive"
process = library "process"
rts = topLevel "rts"
runGhc = utility "runghc"
stm = library "stm"
templateHaskell = library "template-haskell"
terminfo = library "terminfo"
time = library "time"
touchy = utility "touchy"
transformers = library "transformers"
unlit = utility "unlit"
unix = library "unix"
win32 = library "Win32"
xhtml = library "xhtml"
array = lib "array"
base = lib "base"
binary = lib "binary"
bytestring = lib "bytestring"
cabal = lib "Cabal" `setPath` "libraries/Cabal/Cabal"
checkApiAnnotations = util "check-api-annotations"
compareSizes = util "compareSizes" `setPath` "utils/compare_sizes"
compiler = top "ghc" `setPath` "compiler"
containers = lib "containers"
deepseq = lib "deepseq"
deriveConstants = util "deriveConstants"
directory = lib "directory"
dllSplit = util "dll-split"
filepath = lib "filepath"
genapply = util "genapply"
genprimopcode = util "genprimopcode"
ghc = prg "ghc-bin" `setPath` "ghc"
ghcBoot = lib "ghc-boot"
ghcBootTh = lib "ghc-boot-th"
ghcCabal = util "ghc-cabal"
ghcCompact = lib "ghc-compact"
ghci = lib "ghci"
ghcPkg = util "ghc-pkg"
ghcPrim = lib "ghc-prim"
ghcTags = util "ghctags"
ghcSplit = util "ghc-split"
haddock = util "haddock"
haskeline = lib "haskeline"
hsc2hs = util "hsc2hs"
hp2ps = util "hp2ps"
hpc = lib "hpc"
hpcBin = util "hpc-bin" `setPath` "utils/hpc"
integerGmp = lib "integer-gmp"
integerSimple = lib "integer-simple"
iservBin = prg "iserv-bin" `setPath` "iserv"
libffi = top "libffi"
mkUserGuidePart = util "mkUserGuidePart"
parallel = lib "parallel"
pretty = lib "pretty"
primitive = lib "primitive"
process = lib "process"
rts = top "rts"
runGhc = util "runghc"
stm = lib "stm"
templateHaskell = lib "template-haskell"
terminfo = lib "terminfo"
time = lib "time"
touchy = util "touchy"
transformers = lib "transformers"
unlit = util "unlit"
unix = lib "unix"
win32 = lib "Win32"
xhtml = lib "xhtml"
-- | Construct a library package, e.g. @array@.
lib :: String -> Package
lib name = library name ("libraries" -/- name)
-- | Construct a top-level library package, e.g. @compiler@.
top :: String -> Package
top name = library name name
-- | Construct a top-level program package, e.g. @ghc@.
prg :: String -> Package
prg name = program name name
-- | Construct a utility package, e.g. @haddock@.
util :: String -> Package
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 | isLibrary pkg = library (pkgName pkg) path
| otherwise = program (pkgName pkg) path
-- | Some builders are built by this very build system, in which case
-- 'builderProvenance' returns the corresponding build 'Context' (which includes
......@@ -168,7 +188,7 @@ programName Context {..}
| package == hpcBin = "hpc"
| package == runGhc = "runhaskell"
| package == iservBin = "ghc-iserv"
| otherwise = pkgNameString package
| otherwise = pkgName package
-- | Some contexts are special: their packages do not have @.cabal@ metadata or
-- we cannot run @ghc-cabal@ on them, e.g. because the latter hasn't been built
......@@ -188,7 +208,7 @@ autogenPath context@Context {..}
| package == ghc = autogen "build/ghc"
| package == hpcBin = autogen "build/hpc"
| package == iservBin = autogen "build/iserv"
| otherwise = autogen $ "build" -/- pkgNameString package
| otherwise = autogen $ "build" -/- pkgName package
where
autogen dir = buildPath context <&> (-/- dir -/- "autogen")
......
-----------------------------------------------------------------------------
-- |
-- Module : Hadrian.Haskell.Package
-- Copyright : (c) Andrey Mokhov 2014-2017
-- License : MIT (see the file LICENSE)
-- Maintainer : andrey.mokhov@gmail.com
-- Stability : experimental
--
-- Haskell packages and operations on them.
-----------------------------------------------------------------------------
module Hadrian.Haskell.Package (
Package, PackageName (..), PackageType (..),
-- * Queries
pkgName, pkgPath, pkgType, pkgNameString, pkgCabalFile,
-- * Helpers for constructing and using 'Package's
setPath, topLevel, library, utility, setType, isLibrary, isProgram
-- * Data type
Package,
-- * Construction and properties
library, program, pkgName, pkgPath, isLibrary, isProgram,
-- * Package directory structure
pkgCabalFile
) where
import Data.String
import Development.Shake.Classes
import Development.Shake.FilePath
import GHC.Generics
import Hadrian.Utilities
-- | The name of a Haskell package.
newtype PackageName = PackageName { fromPackageName :: String }
deriving (Binary, Eq, Generic, Hashable, IsString, NFData, Ord, Typeable)
-- TODO: Make PackageType more precise, #12.
-- | We regard packages as either being libraries or programs. This is a bit of
-- a convenient lie as Haskell packages can be both, but it works for now.
data PackageType = Library | Program deriving Generic
-- | A Haskell package.
data Package = Package {
-- | The name of a Haskell package. Examples: @Cabal@, @ghc-bin@.
pkgName :: PackageName,
-- | 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 :: FilePath,
-- | A library (e.g. @Cabal@) or a program (e.g. @ghc-bin@).
pkgType :: PackageType
} deriving Generic
-- TODO: Get rid of non-derived Show instances.
data PackageType = Library | Program deriving (Generic, Show)
-- | A Haskell package. The current implementation treats a package as either
-- a library or a program, which is a gross oversimplification as Haskell
-- packages can be both. This works for now, but in future we plan to support
-- general Haskell packages. Also note that we assume that all packages have
-- different names, hence two packages with the same name are considered equal.
data Package = Package PackageType String FilePath deriving Generic
-- | The name of a Haskell package. Examples: @Cabal@, @ghc-bin@.
pkgName :: Package -> String
pkgName (Package _ name _) = name
-- | 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 :: Package -> FilePath
pkgPath (Package _ _ path) = path
instance Show Package where
show = pkgNameString
show (Package Library n p) = "library " ++ show n ++ " " ++ show p
show (Package Program n p) = "program " ++ show n ++ " " ++ show p
instance Eq Package where
p == q = pkgName p == pkgName q
......@@ -51,40 +62,24 @@ instance Binary PackageType
instance Hashable PackageType
instance NFData PackageType
-- | Prettyprint 'Package' name.
pkgNameString :: Package -> String
pkgNameString = fromPackageName . pkgName
-- | Construct a library package.
library :: String -> FilePath -> Package
library = Package Library
-- | Relative path to cabal file, e.g.: "libraries/Cabal/Cabal/Cabal.cabal"
pkgCabalFile :: Package -> FilePath
pkgCabalFile pkg = pkgPath pkg -/- pkgNameString pkg <.> "cabal"
-- | Smart constructor for a top-level package, e.g. 'compiler'.
topLevel :: PackageName -> Package
topLevel name = Package name (fromPackageName name) Library
-- | Smart constructor for a library package, e.g. 'array'.
library :: PackageName -> Package
library name = Package name ("libraries" -/- fromPackageName name) Library
-- | Construct a program package.
program :: String -> FilePath -> Package
program = Package Program
-- | Smart constructor for a utility package, e.g. 'haddock'.
utility :: PackageName -> Package
utility name = Package name ("utils" -/- fromPackageName name) Program
-- | Amend package path. Useful when a package name doesn't match its path.
setPath :: Package -> FilePath -> Package
setPath pkg path = pkg { pkgPath = path }
-- | Amend package type.
setType :: Package -> PackageType -> Package
setType pkg ty = pkg { pkgType = ty }
-- | The path to a package cabal file, e.g.: @ghc/ghc-bin.cabal@.
pkgCabalFile :: Package -> FilePath
pkgCabalFile pkg = pkgPath pkg -/- pkgName pkg <.> "cabal"
-- | Check whether a package is a library.
isLibrary :: Package -> Bool
isLibrary (Package _ _ Library) = True
isLibrary (Package Library _ _) = True
isLibrary _ = False
-- | Check whether a package is a program.
isProgram :: Package -> Bool
isProgram (Package _ _ Program) = True
isProgram (Package Program _ _) = True
isProgram _ = False
......@@ -62,7 +62,7 @@ generatePackageData context@Context {..} file = do
genPath <- buildRoot <&> (-/- generatedDir)
let pkgKey = if isLibrary package then "COMPONENT_ID = " else "PROGNAME = "
writeFileChanged file . unlines $
[ pkgKey ++ pkgNameString package ] ++
[ pkgKey ++ pkgName package ] ++
[ "S_SRCS = " ++ unwords asmSrcs ] ++
[ "C_SRCS = " ++ unwords cSrcs ] ++
[ "CMM_SRCS = " ++ unwords cmmSrcs ] ++
......
......@@ -18,8 +18,7 @@ haddockDependencies context = do
path <- buildPath context
depNames <- pkgDataList $ DepNames path
sequence [ pkgHaddockFile $ vanillaContext Stage1 depPkg
| Just depPkg <- map (findKnownPackage . PackageName) depNames
, depPkg /= rts ]
| Just depPkg <- map findKnownPackage depNames, depPkg /= rts ]
-- Note: this build rule creates plenty of files, not just the .haddock one.
-- All of them go into the 'doc' subdirectory. Pedantically tracking all built
......
......@@ -275,7 +275,7 @@ generateConfigHs = do
let cIntegerLibraryType
| intLib == integerGmp = "IntegerGMP"
| intLib == integerSimple = "IntegerSimple"
| otherwise = error $ "Unknown integer library: " ++ pkgNameString intLib
| otherwise = error $ "Unknown integer library: " ++ pkgName intLib
cSupportsSplitObjs <- expr $ yesNo <$> supportsSplitObjects
cGhcWithInterpreter <- expr $ yesNo <$> ghcWithInterpreter
cGhcWithNativeCodeGen <- expr $ yesNo <$> ghcWithNativeCodeGen
......@@ -323,7 +323,7 @@ generateConfigHs = do
, "cStage :: String"
, "cStage = show (STAGE :: Int)"
, "cIntegerLibrary :: String"
, "cIntegerLibrary = " ++ show (pkgNameString intLib)
, "cIntegerLibrary = " ++ show (pkgName intLib)
, "cIntegerLibraryType :: IntegerLibrary"
, "cIntegerLibraryType = " ++ cIntegerLibraryType
, "cSupportsSplitObjs :: String"
......
......@@ -281,9 +281,8 @@ installLibsTo libs dir = do
".a" -> do
let out = dir -/- takeFileName lib
installData [out] dir
let context = vanillaContext Stage0 $ topLevel (PackageName "")
-- TODO: Get rid of meaningless context for certain builder like ranlib
build $ target context Ranlib [out] [out]
build $ target (stageContext Stage0) Ranlib [out] [out]
_ -> installData [lib] dir
-- ref: includes/ghc.mk
......
......@@ -37,7 +37,7 @@ libraryObjects context@Context{..} = do
buildDynamicLib :: Context -> Rules ()
buildDynamicLib context@Context{..} = do
let libPrefix = "//" ++ contextDir context -/- "libHS" ++ pkgNameString package
let libPrefix = "//" ++ contextDir context -/- "libHS" ++ pkgName package
-- OS X
libPrefix ++ "*.dylib" %> buildDynamicLibUnix
-- Linux
......@@ -52,7 +52,7 @@ buildDynamicLib context@Context{..} = do
buildPackageLibrary :: Context -> Rules ()
buildPackageLibrary context@Context {..} = do
let libPrefix = "//" ++ contextDir context -/- "libHS" ++ pkgNameString package
let libPrefix = "//" ++ contextDir context -/- "libHS" ++ pkgName package
libPrefix ++ "*" ++ (waySuffix way <.> "a") %%> \a -> do
objs <- libraryObjects context
asuf <- libsuf way
......@@ -63,12 +63,12 @@ buildPackageLibrary context@Context {..} = do
synopsis <- interpretInContext context $ getPkgData Synopsis
unless isLib0 . putSuccess $ renderLibrary
(quote (pkgNameString package) ++ " (" ++ show stage ++ ", way "
(quote (pkgName package) ++ " (" ++ show stage ++ ", way "
++ show way ++ ").") a (dropWhileEnd isPunctuation synopsis)
buildPackageGhciLibrary :: Context -> Rules ()
buildPackageGhciLibrary context@Context {..} = priority 2 $ do
let libPrefix = "//" ++ contextDir context -/- "HS" ++ pkgNameString package
let libPrefix = "//" ++ contextDir context -/- "HS" ++ pkgName package
libPrefix ++ "*" ++ (waySuffix way <.> "o") %> \obj -> do
objs <- allObjects context
need objs
......
......@@ -83,7 +83,7 @@ buildWrapper context@Context {..} wrapper wrapperPath wrapped = do
writeFileChanged wrapperPath contents
makeExecutable wrapperPath
putSuccess $ "| Successfully created wrapper for " ++
quote (pkgNameString package) ++ " (" ++ show stage ++ ")."
quote (pkgName package) ++ " (" ++ show stage ++ ")."
-- TODO: Get rid of the Paths_hsc2hs.o hack.
buildBinary :: [(Resource, Int)] -> Context -> FilePath -> Action ()
......@@ -106,6 +106,6 @@ buildBinary rs context@Context {..} bin = do
buildWithResources rs $ target context (Ghc LinkHs stage) binDeps [bin]
synopsis <- interpretInContext context $ getPkgData Synopsis
putSuccess $ renderProgram
(quote (pkgNameString package) ++ " (" ++ show stage ++ ").")
(quote (pkgName package) ++ " (" ++ show stage ++ ").")
bin
(dropWhileEnd isPunctuation synopsis)
......@@ -15,14 +15,14 @@ registerPackage rs context@Context {..} = do
-- Packages @ghc-boot@ and @ghc-boot-th@ both match the @ghc-boot*@
-- pattern, therefore we need to use priorities to match the right rule.
-- TODO: Get rid of this hack.
"//" ++ stage0PackageDbDir -/- pkgNameString package ++ "*.conf" %%>
"//" ++ stage0PackageDbDir -/- pkgName package ++ "*.conf" %%>
buildConf rs context
when (package == ghc) $ "//" ++ stage0PackageDbDir -/- packageDbStamp %>
buildStamp rs context
when (stage == Stage1) $ do
inplacePackageDbPath -/- pkgNameString package ++ "*.conf" %%>
inplacePackageDbPath -/- pkgName package ++ "*.conf" %%>
buildConf rs context
when (package == ghc) $ inplacePackageDbPath -/- packageDbStamp %>
......
......@@ -46,7 +46,7 @@ flavour = do
return $ fromMaybe unknownFlavour $ find ((== flavourName) . name) flavours
integerLibraryName :: Action String
integerLibraryName = pkgNameString <$> (integerLibrary =<< flavour)
integerLibraryName = pkgName <$> (integerLibrary =<< flavour)
programContext :: Stage -> Package -> Action Context
programContext stage pkg = do
......@@ -62,7 +62,7 @@ knownPackages = sort $ defaultKnownPackages ++ userKnownPackages
-- TODO: Speed up? Switch to Set?
-- Note: this is slow but we keep it simple as there are just ~50 packages
findKnownPackage :: PackageName -> Maybe Package
findKnownPackage :: String -> Maybe Package
findKnownPackage name = find (\pkg -> pkgName pkg == name) knownPackages
-- | Determine the location of a 'Builder'.
......
......@@ -31,7 +31,7 @@ haddockBuilderArgs = builder Haddock ? do
, arg $ "--dump-interface=" ++ output
, arg "--html"
, arg "--hoogle"
, arg $ "--title=" ++ pkgNameString pkg ++ "-" ++ version ++ ": " ++ synopsis
, arg $ "--title=" ++ pkgName pkg ++ "-" ++ version ++ ": " ++ synopsis
, arg $ "--prologue=" ++ path -/- "haddock-prologue.txt"
, arg $ "--optghc=-D__HADDOCK_VERSION__=" ++ show (versionToInt hVersion)
, map ("--hide=" ++) <$> getPkgDataList HiddenModules
......
......@@ -12,7 +12,7 @@ ghcCabalPackageArgs = stage0 ? package ghcCabal ? builder Ghc ? do
cabalDeps <- expr $ pkgDependencies cabal
(_, cabalVersion) <- expr $ cabalNameVersion (pkgCabalFile cabal)
mconcat
[ pure [ "-package " ++ pkgNameString pkg | pkg <- cabalDeps ]
[ pure [ "-package " ++ pkgName pkg | pkg <- cabalDeps ]
, arg "--make"
, arg "-j"
, arg ("-DCABAL_VERSION=" ++ replace "." "," cabalVersion)
......
......@@ -189,10 +189,10 @@ packageDependenciesGenerator :: FilePath -> Action String
packageDependenciesGenerator _ = do
pkgDeps <- forM (sort knownPackages) $ \pkg -> do
exists <- doesFileExist (pkgCabalFile pkg)
if not exists then return (pkgNameString pkg)
if not exists then return (pkgName pkg)
else do
deps <- nubOrd . sort <$> cabalDependencies (pkgCabalFile pkg)
return . unwords $ pkgNameString pkg : (deps \\ [pkgNameString pkg])
return . unwords $ pkgName pkg : (deps \\ [pkgName pkg])
return (unlines pkgDeps)
-- | Given a 'Context' this 'Action' looks up its package dependencies in
......@@ -206,9 +206,9 @@ contextDependencies Context {..} = do
let pkgContext = \pkg -> Context (min stage Stage1) pkg way
-- 'packageDependencies' is generated by 'packageDependenciesGenerator'.
path <- buildRoot <&> (-/- packageDependencies)
deps <- lookupValuesOrError path (pkgNameString package)
deps <- lookupValuesOrError path (pkgName package)
pkgs <- sort <$> interpretInContext (pkgContext package) getPackages
return . map pkgContext $ intersectOrd (compare . pkgNameString) pkgs deps
return . map pkgContext $ intersectOrd (compare . pkgName) pkgs deps
-- | Lookup dependencies of a 'Package' in the vanilla Stage1 context.
pkgDependencies :: Package -> Action [Package]
......@@ -254,7 +254,7 @@ putInfo t = putProgressInfo =<< renderAction
where
contextInfo = concat $ [ " (" ]
++ [ "stage = " ++ show (stage $ context t) ]
++ [ ", package = " ++ pkgNameString (package $ context t) ]
++ [ ", package = " ++ pkgName (package $ context t) ]
++ [ ", way = " ++ show (way $ context t) | (way $ context t) /= vanilla ]
++ [ ")" ]
digest [] = "none"
......
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