Unverified Commit 798a716b authored by Andrey Mokhov's avatar Andrey Mokhov Committed by GitHub
Browse files

Simplify Package data type (#663)

I noticed that all packages we build have Cabal files now, which means we no longer need to distinguish between C and Haskell packages. This leads to a lot of simplifications and removal of unsafe functions.
parent a820566c
......@@ -44,7 +44,6 @@ executable hadrian
, Hadrian.Oracles.TextFile.Rules
, Hadrian.Oracles.TextFile.Type
, Hadrian.Package
, Hadrian.Package.Type
, Hadrian.Target
, Hadrian.Utilities
, Oracles.Flag
......
......@@ -4,10 +4,9 @@ module Context (
-- * Expressions
getStage, getPackage, getWay, getStagedSettingList, getBuildPath,
withHsPackage,
-- * Paths
contextDir, buildPath, buildDir, pkgId, pkgInplaceConfig, pkgSetupConfigFile,
contextDir, buildPath, buildDir, pkgInplaceConfig, pkgSetupConfigFile,
pkgHaddockFile, pkgLibraryFile, pkgGhciLibraryFile, pkgConfFile, objectPath,
contextPath, getContextPath, libDir, libPath
) where
......@@ -44,21 +43,6 @@ getWay = way <$> getContext
getStagedSettingList :: (Stage -> SettingList) -> Args Context b
getStagedSettingList f = getSettingList . f =<< getStage
-- | Construct an expression that depends on the Cabal file of the current
-- package and is empty in a non-Haskell context.
withHsPackage :: (Monoid a, Semigroup a) => (Context -> Expr Context b a) -> Expr Context b a
withHsPackage expr = do
pkg <- getPackage
ctx <- getContext
case pkgCabalFile pkg of
Just _ -> expr ctx
Nothing -> mempty
pkgId :: Context -> Action FilePath
pkgId ctx@Context {..} = case pkgCabalFile package of
Just _ -> pkgIdentifier ctx
Nothing -> return (pkgName package) -- Non-Haskell packages, e.g. rts
libDir :: Context -> FilePath
libDir Context {..} = stageString stage -/- "lib"
......@@ -69,7 +53,7 @@ libPath context = buildRoot <&> (-/- libDir context)
pkgFile :: Context -> String -> String -> Action FilePath
pkgFile context@Context {..} prefix suffix = do
path <- buildPath context
pid <- pkgId context
pid <- pkgIdentifier context
return $ path -/- prefix ++ pid ++ suffix
-- | Path to inplace package configuration file of a given 'Context'.
......@@ -108,8 +92,8 @@ pkgGhciLibraryFile context = pkgFile context "HS" ".o"
-- | Path to the configuration file of a given 'Context'.
pkgConfFile :: Context -> Action FilePath
pkgConfFile ctx@Context {..} = do
root <- buildRoot
pid <- pkgId ctx
root <- buildRoot
pid <- pkgIdentifier ctx
return $ root -/- relativePackageDbPath stage -/- pid <.> "conf"
-- | Given a 'Context' and a 'FilePath' to a source file, compute the 'FilePath'
......
module Context.Type where
import Hadrian.Package.Type
import Development.Shake.Classes
import GHC.Generics
import Hadrian.Package
import Stage
import Way.Type
import GHC.Generics
import Development.Shake.Classes
-- | Build context for a currently built 'Target'. We generate potentially
-- different build rules for each 'Context'.
data Context = Context
......
......@@ -30,12 +30,10 @@ import Hadrian.Expression hiding (Expr, Predicate, Args)
import Hadrian.Haskell.Cabal.PackageData
import Hadrian.Oracles.TextFile
-- TODO: Get rid of partiality.
-- | Get values from a configured cabal stage.
getPackageData :: (PackageData -> a) -> Expr a
getPackageData key = do
ctx <- getContext
Just packageData <- expr (readPackageData ctx)
packageData <- expr . readPackageData =<< getContext
return $ key packageData
-- | Is the build currently in the provided stage?
......
......@@ -13,23 +13,22 @@ module Hadrian.Haskell.Cabal (
pkgVersion, pkgIdentifier, pkgDependencies, pkgSynopsis
) where
import Data.Maybe
import Development.Shake
import Context.Type
import Hadrian.Haskell.Cabal.CabalData
import Hadrian.Package
import Hadrian.Oracles.TextFile
import Hadrian.Package
-- | Read a Cabal file and return the package version. The Cabal file is tracked.
pkgVersion :: Context -> Action (Maybe String)
pkgVersion = fmap (fmap version) . readCabalData
pkgVersion :: Context -> Action String
pkgVersion = fmap version . readCabalData
-- | Read a Cabal file and return the package identifier, e.g. @base-4.10.0.0@.
-- The Cabal file is tracked.
pkgIdentifier :: Context -> Action String
pkgIdentifier ctx = do
cabal <- fromMaybe (error "Cabal file could not be read") <$> readCabalData ctx
pkgIdentifier context = do
cabal <- readCabalData context
return $ if null (version cabal)
then name cabal
else name cabal ++ "-" ++ version cabal
......@@ -38,9 +37,9 @@ pkgIdentifier ctx = do
-- The current version does not take care of Cabal conditionals and therefore
-- returns a crude overapproximation of actual dependencies. The Cabal file is
-- tracked.
pkgDependencies :: Context -> Action (Maybe [PackageName])
pkgDependencies = fmap (fmap (map pkgName . packageDependencies)) . readCabalData
pkgDependencies :: Context -> Action [PackageName]
pkgDependencies = fmap (map pkgName . packageDependencies) . readCabalData
-- | Read a Cabal file and return the package synopsis. The Cabal file is tracked.
pkgSynopsis :: Context -> Action (Maybe String)
pkgSynopsis = fmap (fmap synopsis) . readCabalData
pkgSynopsis :: Context -> Action String
pkgSynopsis = fmap synopsis . readCabalData
......@@ -3,7 +3,7 @@ module Hadrian.Haskell.Cabal.CabalData where
import Development.Shake.Classes
import Distribution.PackageDescription
import GHC.Generics
import Hadrian.Package.Type
import Hadrian.Package
-- | Haskell package metadata extracted from a Cabal file, without performing
-- the resolution of package configuration flags and associated conditionals.
......
......@@ -2,7 +2,7 @@ module Hadrian.Haskell.Cabal.PackageData where
import Development.Shake.Classes
import GHC.Generics
import Hadrian.Package.Type
import Hadrian.Package
-- | Most of these fields used to be provided in @package-data.mk@ files.
data PackageData = PackageData
......
......@@ -83,7 +83,7 @@ biModules pd = go [ comp | comp@(bi,_,_) <-
-- such as platform, compiler version conditionals, and package flags.
parseCabalFile :: Context -> Action CabalData
parseCabalFile context@Context {..} = do
let file = unsafePkgCabalFile package
let file = pkgCabalFile package
-- Read the package description from the Cabal file
gpd <- liftIO $ C.readGenericPackageDescription C.verbose file
......@@ -124,7 +124,7 @@ configurePackage :: Context -> Action ()
configurePackage context@Context {..} = do
putLoud $ "| Configure package " ++ quote (pkgName package)
CabalData _ _ _ gpd _pd depPkgs <- unsafeReadCabalData context
CabalData _ _ _ gpd _pd depPkgs <- readCabalData context
-- Stage packages are those we have in this stage.
stagePkgs <- stagePackages stage
......@@ -141,7 +141,7 @@ configurePackage context@Context {..} = do
-- "Custom", but doesn't have a configure script.
C.Custom -> do
configureExists <- doesFileExist $
replaceFileName (unsafePkgCabalFile package) "configure"
replaceFileName (pkgCabalFile package) "configure"
pure $ if configureExists then C.autoconfUserHooks else C.simpleUserHooks
-- Not quite right, but good enough for us:
_ | package == rts ->
......@@ -165,7 +165,7 @@ configurePackage context@Context {..} = do
copyPackage :: Context -> Action ()
copyPackage context@Context {..} = do
putLoud $ "| Copy package " ++ quote (pkgName package)
CabalData _ _ _ gpd _ _ <- unsafeReadCabalData context
CabalData _ _ _ gpd _ _ <- readCabalData context
ctxPath <- Context.contextPath context
pkgDbPath <- packageDbPath stage
verbosity <- getVerbosity
......@@ -178,7 +178,7 @@ registerPackage :: Context -> Action ()
registerPackage context@Context {..} = do
putLoud $ "| Register package " ++ quote (pkgName package)
ctxPath <- Context.contextPath context
CabalData _ _ _ gpd _ _ <- unsafeReadCabalData context
CabalData _ _ _ gpd _ _ <- readCabalData context
verbosity <- getVerbosity
let v = if verbosity >= Loud then "-v3" else "-v0"
liftIO $ C.defaultMainWithHooksNoReadArgs C.autoconfUserHooks gpd
......@@ -195,7 +195,7 @@ parsePackageData context@Context {..} = do
-- let (Right (pd,_)) = C.finalizePackageDescription flags (const True) platform (compilerInfo compiler) [] gpd
--
-- However when using the new-build path's this might change.
CabalData _ _ _ _gpd pd _depPkgs <- unsafeReadCabalData context
CabalData _ _ _ _gpd pd _depPkgs <- readCabalData context
cPath <- Context.contextPath context
need [cPath -/- "setup-config"]
......
......@@ -14,12 +14,11 @@
module Hadrian.Oracles.TextFile (
readTextFile, lookupValue, lookupValueOrEmpty, lookupValueOrError,
lookupValues, lookupValuesOrEmpty, lookupValuesOrError, lookupDependencies,
readCabalData, unsafeReadCabalData, readPackageData
readCabalData, readPackageData
) where
import Data.Maybe
import Development.Shake
import GHC.Stack
import Context.Type
import Hadrian.Haskell.Cabal.CabalData
......@@ -75,17 +74,11 @@ lookupDependencies depFile file = do
Just (source : files) -> return (source, files)
-- | Read and parse a @.cabal@ file, caching and tracking the result.
readCabalData :: Context -> Action (Maybe CabalData)
readCabalData :: Context -> Action CabalData
readCabalData = askOracle . CabalFile
-- | Like 'readCabalData' but raises an error on a non-Cabal context.
unsafeReadCabalData :: HasCallStack => Context -> Action CabalData
unsafeReadCabalData context = fromMaybe (error msg) <$> readCabalData context
where
msg = "[unsafeReadCabalData] Non-Cabal context: " ++ show context
-- | Read and parse a @.cabal@ file recording the obtained 'PackageData',
-- caching and tracking the result. Note that unlike 'readCabalData' this
-- function resolves all Cabal configuration flags and associated conditionals.
readPackageData :: Context -> Action (Maybe PackageData)
readPackageData :: Context -> Action PackageData
readPackageData = askOracle . PackageDataFile
......@@ -46,22 +46,18 @@ textFileOracle = do
return $ Map.fromList [ (key, values) | (key:values) <- contents ]
void $ addOracle $ \(KeyValues (file, key)) -> Map.lookup key <$> kvs file
cabal <- newCache $ \(ctx@Context {..}) ->
case pkgCabalFile package of
Just file -> do
need [file]
putLoud $ "| CabalFile oracle: reading " ++ quote file
++ " (Stage: " ++ stageString stage ++ ")..."
Just <$> parseCabalFile ctx
Nothing -> return Nothing
cabal <- newCache $ \(ctx@Context {..}) -> do
let file = pkgCabalFile package
need [file]
putLoud $ "| CabalFile oracle: reading " ++ quote file
++ " (Stage: " ++ stageString stage ++ ")..."
parseCabalFile ctx
void $ addOracle $ \(CabalFile ctx) -> cabal ctx
confCabal <- newCache $ \(ctx@Context {..}) ->
case pkgCabalFile package of
Just file -> do
need [file]
putLoud $ "| PackageDataFile oracle: reading " ++ quote file
++ " (Stage: " ++ stageString stage ++ ")..."
Just <$> parsePackageData ctx
Nothing -> return Nothing
confCabal <- newCache $ \(ctx@Context {..}) -> do
let file = pkgCabalFile package
need [file]
putLoud $ "| PackageDataFile oracle: reading " ++ quote file
++ " (Stage: " ++ stageString stage ++ ")..."
parsePackageData ctx
void $ addOracle $ \(PackageDataFile ctx) -> confCabal ctx
......@@ -26,11 +26,11 @@ type instance RuleResult TextFile = String
newtype CabalFile = CabalFile Context
deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
type instance RuleResult CabalFile = Maybe CabalData
type instance RuleResult CabalFile = CabalData
newtype PackageDataFile = PackageDataFile Context
deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
type instance RuleResult PackageDataFile = Maybe PackageData
type instance RuleResult PackageDataFile = PackageData
newtype KeyValue = KeyValue (FilePath, String)
deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
......
......@@ -13,79 +13,72 @@
-----------------------------------------------------------------------------
module Hadrian.Package (
-- * Data types
Package (..), PackageName, PackageLanguage, PackageType,
Package (..), PackageName, PackageType,
-- * Construction and properties
cLibrary, cProgram, hsLibrary, hsProgram, dummyPackage,
isLibrary, isProgram, isCPackage, isHsPackage,
library, program, dummyPackage, isLibrary, isProgram,
-- * Package directory structure
pkgCabalFile, unsafePkgCabalFile
pkgCabalFile
) where
import Data.Maybe
import Development.Shake.Classes
import Development.Shake.FilePath
import GHC.Stack
import GHC.Generics
import Hadrian.Package.Type
import Hadrian.Utilities
-- | Construct a C library package.
cLibrary :: PackageName -> FilePath -> Package
cLibrary = Package C Library
-- TODO: Make PackageType more precise.
-- See https://github.com/snowleopard/hadrian/issues/12.
data PackageType = Library | Program deriving (Eq, Generic, Ord, Show)
-- | Construct a C program package.
cProgram :: PackageName -> FilePath -> Package
cProgram = Package C Program
type PackageName = String
-- | Construct a Haskell library package.
hsLibrary :: PackageName -> FilePath -> Package
hsLibrary = Package Haskell Library
-- TODO: Consider turning Package into a GADT indexed with language and type.
data Package = Package {
-- | The package type. 'Library' and 'Program' packages are supported.
pkgType :: PackageType,
-- | The package name. We assume that all packages have different names,
-- hence two packages with the same name are considered equal.
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
} deriving (Eq, Generic, Ord, Show)
-- | Construct a Haskell program package.
hsProgram :: PackageName -> FilePath -> Package
hsProgram = Package Haskell Program
-- | Construct a library package.
library :: PackageName -> FilePath -> Package
library = Package Library
-- | A dummy package, which we never try to build
-- but just use as a better @undefined@ in code
-- where we need a 'Package' to set up a Context
-- but will not really operate over one.
-- | Construct a program package.
program :: PackageName -> FilePath -> Package
program = Package Program
-- TODO: Remove this hack.
-- | A dummy package that we never try to build but use when we need a 'Package'
-- to construct a 'Context' but do not need to access the package field.
dummyPackage :: Package
dummyPackage = hsLibrary "dummy" "dummy/path/"
dummyPackage = library "dummy" "dummy/path/"
-- | Is this a library package?
isLibrary :: Package -> Bool
isLibrary (Package _ Library _ _) = True
isLibrary (Package Library _ _) = True
isLibrary _ = False
-- | Is this a program package?
isProgram :: Package -> Bool
isProgram (Package _ Program _ _) = True
isProgram (Package Program _ _) = True
isProgram _ = False
-- | Is this a C package?
isCPackage :: Package -> Bool
isCPackage (Package C _ _ _) = True
isCPackage _ = False
-- | Is this a Haskell package?
isHsPackage :: Package -> Bool
isHsPackage (Package Haskell _ _ _) = True
-- we consider the RTS as a haskell package because we
-- use information from its Cabal file to build it,
-- and we e.g want 'pkgCabalFile' to point us to
-- 'rts/rts.cabal' when passed the rts package as argument.
isHsPackage (Package _ _ "rts" _) = True
isHsPackage _ = False
-- | The path to the Cabal file of a Haskell package, e.g. @ghc/ghc-bin.cabal@.
pkgCabalFile :: Package -> FilePath
pkgCabalFile p = pkgPath p -/- pkgName p <.> "cabal"
-- | The path to the Cabal file of a Haskell package, e.g. @ghc/ghc-bin.cabal@,
-- or @Nothing@ if the argument is not a Haskell package.
pkgCabalFile :: Package -> Maybe FilePath
pkgCabalFile p | isHsPackage p = Just $ pkgPath p -/- pkgName p <.> "cabal"
| otherwise = Nothing
instance Binary PackageType
instance Hashable PackageType
instance NFData PackageType
-- | Like 'pkgCabalFile' but raises an error on a non-Cabal package.
unsafePkgCabalFile :: HasCallStack => Package -> FilePath
unsafePkgCabalFile p = fromMaybe (error msg) (pkgCabalFile p)
where
msg = "[unsafePkgCabalFile] Non-Cabal package: " ++ show p
instance Binary Package
instance Hashable Package
instance NFData Package
\ No newline at end of file
module Hadrian.Package.Type where
import GHC.Generics
import Development.Shake.Classes
data PackageLanguage = C | Haskell deriving (Generic, Show)
-- TODO: Make PackageType more precise.
-- See https://github.com/snowleopard/hadrian/issues/12.
data PackageType = Library | Program deriving (Generic, Show)
type PackageName = String
-- TODO: Consider turning Package into a GADT indexed with language and type.
data Package = Package {
-- | The package language. 'C' and 'Haskell' packages are supported.
pkgLanguage :: PackageLanguage,
-- | The package type. 'Library' and 'Program' packages are supported.
pkgType :: PackageType,
-- | The package name. We assume that all packages have different names,
-- hence two packages with the same name are considered equal.
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
} deriving (Generic, Show)
instance Eq Package where
p == q = pkgName p == pkgName q
instance Ord Package where
compare p q = compare (pkgName p) (pkgName q)
instance Binary PackageLanguage
instance Hashable PackageLanguage
instance NFData PackageLanguage
instance Binary PackageType
instance Hashable PackageType
instance NFData PackageType
instance Binary Package
instance Hashable Package
instance NFData Package
......@@ -408,22 +408,21 @@ renderActionNoOutput what input = do
i = unifyPath input
-- | Render the successful build of a program.
renderProgram :: String -> String -> Maybe String -> String
renderProgram :: String -> String -> String -> String
renderProgram name bin synopsis = renderBox $
[ "Successfully built program " ++ name
, "Executable: " ++ bin ] ++
[ "Program synopsis: " ++ prettySynopsis synopsis | isJust synopsis ]
[ "Program synopsis: " ++ endWithADot synopsis | not (null synopsis) ]
-- | Render the successful build of a library.
renderLibrary :: String -> String -> Maybe String -> String
renderLibrary :: String -> String -> String -> String
renderLibrary name lib synopsis = renderBox $
[ "Successfully built library " ++ name
, "Library: " ++ lib ] ++
[ "Library synopsis: " ++ prettySynopsis synopsis | isJust synopsis ]
[ "Library synopsis: " ++ endWithADot synopsis | not (null synopsis) ]
prettySynopsis :: Maybe String -> String
prettySynopsis Nothing = ""
prettySynopsis (Just s) = dropWhileEnd isPunctuation s ++ "."
endWithADot :: String -> String
endWithADot s = dropWhileEnd isPunctuation s ++ "."
-- | Render the given set of lines in an ASCII box. The minimum width and
-- whether to use Unicode symbols are hardcoded in the function's body.
......
......@@ -44,83 +44,79 @@ isGhcPackage :: Package -> Bool
isGhcPackage = (`elem` ghcPackages)
-- | Package definitions, see 'Package'.
array = hsLib "array"
base = hsLib "base"
binary = hsLib "binary"
bytestring = hsLib "bytestring"
cabal = hsLib "Cabal" `setPath` "libraries/Cabal/Cabal"
checkApiAnnotations = hsUtil "check-api-annotations"
checkPpr = hsUtil "check-ppr"
compareSizes = hsUtil "compareSizes" `setPath` "utils/compare_sizes"
compiler = hsTop "ghc" `setPath` "compiler"
containers = hsLib "containers"
deepseq = hsLib "deepseq"
deriveConstants = hsUtil "deriveConstants"
directory = hsLib "directory"
filepath = hsLib "filepath"
genapply = hsUtil "genapply"
genprimopcode = hsUtil "genprimopcode"
ghc = hsPrg "ghc-bin" `setPath` "ghc"
ghcBoot = hsLib "ghc-boot"
ghcBootTh = hsLib "ghc-boot-th"
ghcCompact = hsLib "ghc-compact"
ghcHeap = hsLib "ghc-heap"
ghci = hsLib "ghci"
ghcPkg = hsUtil "ghc-pkg"
ghcPrim = hsLib "ghc-prim"
ghcTags = hsUtil "ghctags"
ghcSplit = hsUtil "ghc-split"
haddock = hsUtil "haddock"
haskeline = hsLib "haskeline"
hsc2hs = hsUtil "hsc2hs"
hp2ps = hsUtil "hp2ps"
hpc = hsLib "hpc"
hpcBin = hsUtil "hpc-bin" `setPath` "utils/hpc"
integerGmp = hsLib "integer-gmp"
integerSimple = hsLib "integer-simple"
iserv = hsUtil "iserv"
libffi = cTop "libffi"
libiserv = hsLib "libiserv"
mtl = hsLib "mtl"
parsec = hsLib "parsec"
parallel = hsLib "parallel"
pretty = hsLib "pretty"
primitive = hsLib "primitive"
process = hsLib "process"
rts = cTop "rts"
runGhc = hsUtil "runghc"
stm = hsLib "stm"
templateHaskell = hsLib "template-haskell"
terminfo = hsLib "terminfo"
text = hsLib "text"
time = hsLib "time"
timeout = hsUtil "timeout" `setPath` "testsuite/timeout"
touchy = hsUtil "touchy"
transformers = hsLib "transformers"
unlit = hsUtil "unlit"
unix = hsLib "unix"
win32 = hsLib "Win32"
xhtml = hsLib "xhtml"
-- | Construct a Haskell library package, e.g. @array@.
hsLib :: PackageName -> Package
hsLib name = hsLibrary name ("libraries" -/- name)
-- | Construct a top-level Haskell library package, e.g. @compiler@.
hsTop :: PackageName -> Package
hsTop name = hsLibrary name name
-- | Construct a top-level C library package, e.g. @rts@.
cTop :: PackageName -> Package
cTop name = cLibrary name name
-- | Construct a top-level Haskell program package, e.g. @ghc@.
hsPrg :: PackageName -> Package
hsPrg name = hsProgram name name
-- | Construct a Haskell utility package, e.g. @haddock@.
hsUtil :: PackageName -> Package
hsUtil name = hsProgram name ("utils" -/- name)
array = lib "array"
base = lib "base"
binary = lib "binary"
bytestring = lib "bytestring"
cabal = lib "Cabal" `setPath` "libraries/Cabal/Cabal"
checkApiAnnotations = util "check-api-annotations"
checkPpr = util "check-ppr"
compareSizes = util "compareSizes" `setPath` "utils/compare_sizes"
compiler = top "ghc" `setPath` "compiler"
containers = lib "containers"
deepseq = lib "deepseq"
deriveConstants = util "deriveConstants"
directory = lib "directory"
filepath = lib "filepath"
genapply = util "genapply"
genprimopcode = util "genprimopcode"
ghc = prg "ghc-bin" `setPath` "ghc"
ghcBoot = lib "ghc-boot"
ghcBootTh = lib "ghc-boot-th"
ghcCompact = lib "ghc-compact"
ghcHeap = lib "ghc-heap"
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"
iserv = util "iserv"