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

Fix package dependencies (#657)

This fixes #654.

There are only two important changes.

1) The first one fixes missing dependencies:

```diff
-pkgDependencies = fmap (fmap PD.dependencies) . readPackageDataFile
+pkgDependencies = fmap (fmap (map pkgName . packageDependencies)) . readCabalFile
```

Here `PD.dependencies` returned versioned package names, e.g. `ghc-8.7`, which then failed to match with non-versioned package names such as `ghc` in `contextDependencies`. Switching from `PD.dependencies` to `packageDependencies` fixes this.

2) I clearly remember that we didn't have this bug before, so I added some tests for our package dependency infrastructure to prevent such regressions in future:

```haskell
testDependencies :: Action ()
testDependencies = do
    putBuild "==== pkgDependencies"
    depLists <- mapM (pkgDependencies . vanillaContext Stage1) ghcPackages
    test $ and [ deps == sort deps | Just deps <- depLists ]
    putBuild "==== Dependencies of the 'ghc-bin' binary"
    ghcDeps <- pkgDependencies (vanillaContext Stage1 ghc)
    test $ isJust ghcDeps
    test $ pkgName compiler `elem` fromJust ghcDeps
    stage0Deps <- contextDependencies (vanillaContext Stage0 ghc)
    stage1Deps <- contextDependencies (vanillaContext Stage1 ghc)
    stage2Deps <- contextDependencies (vanillaContext Stage2 ghc)
    test $ vanillaContext Stage0 compiler `notElem` stage1Deps
    test $ vanillaContext Stage1 compiler `elem`    stage1Deps
    test $ vanillaContext Stage2 compiler `notElem` stage1Deps
    test $ stage1Deps /= stage0Deps
    test $ stage1Deps == stage2Deps
```

Everything else are cosmetic changes, fixing minor issues in comments, and adding TODOs. To figure out the failure in #654 I had to read some code I didn't write and my hands were automatically fixing some style inconsistencies with the rest of the Hadrian code base. (I'd like to emphasise that I make no judgement about which style is better, it's merely an attempt to make the code base look more homogeneous, which I think is useful.)
parent 2fac0531
......@@ -30,12 +30,13 @@ import Hadrian.Expression hiding (Expr, Predicate, Args)
import Hadrian.Haskell.Cabal.PackageData (PackageData)
import Hadrian.Oracles.TextFile (readPackageDataFile)
-- TODO: Get rid of partiality.
-- | Get values from a configured cabal stage.
getPackageData :: (PackageData -> a) -> Expr a
getPackageData key = do
ctx <- getContext
Just cabal <- expr (readPackageDataFile ctx)
return $ key cabal
ctx <- getContext
Just cabal <- expr (readPackageDataFile ctx)
return $ key cabal
-- | Is the build currently in the provided stage?
stage :: Stage -> Predicate
......
......@@ -17,31 +17,30 @@ import Data.Maybe
import Development.Shake
import Context.Type
import Hadrian.Haskell.Cabal.Type as C
import Hadrian.Haskell.Cabal.PackageData as PD
import Hadrian.Haskell.Cabal.Type
import Hadrian.Package
import Hadrian.Oracles.TextFile
-- | Read a Cabal file and return the package version. The Cabal file is tracked.
pkgVersion :: Context -> Action (Maybe String)
pkgVersion = fmap (fmap C.version) . readCabalFile
pkgVersion = fmap (fmap version) . readCabalFile
-- | 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") <$> readCabalFile ctx
return $ if null (C.version cabal)
then C.name cabal
else C.name cabal ++ "-" ++ C.version cabal
return $ if null (version cabal)
then name cabal
else name cabal ++ "-" ++ version cabal
-- | Read a Cabal file and return the sorted list of the package dependencies.
-- 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 PD.dependencies) . readPackageDataFile
pkgDependencies = fmap (fmap (map pkgName . packageDependencies)) . readCabalFile
-- | Read a Cabal file and return the package synopsis. The Cabal file is tracked.
pkgSynopsis :: Context -> Action (Maybe String)
pkgSynopsis = fmap (fmap C.synopsis) . readCabalFile
pkgSynopsis = fmap (fmap synopsis) . readCabalFile
......@@ -135,17 +135,17 @@ textFileOracle = do
return $ Map.fromList [ (key, values) | (key:values) <- contents ]
void $ addOracle $ \(KeyValues (file, key)) -> Map.lookup key <$> kvs file
cabal <- newCache $ \(ctx@Context {..}) -> do
cabal <- newCache $ \(ctx@Context {..}) ->
case pkgCabalFile package of
Just file -> do
need [file]
putLoud $ "| CabalFile oracle: reading " ++ quote file ++ " (Stage: " ++ stageString stage ++ ")..."
Just <$> parseCabal ctx
Nothing -> return Nothing
Just file -> do
need [file]
putLoud $ "| CabalFile oracle: reading " ++ quote file
++ " (Stage: " ++ stageString stage ++ ")..."
Just <$> parseCabal ctx
Nothing -> return Nothing
void $ addOracle $ \(CabalFile ctx) -> cabal ctx
confCabal <- newCache $ \(ctx@Context {..}) -> do
confCabal <- newCache $ \(ctx@Context {..}) ->
case pkgCabalFile package of
Just file -> do
need [file]
......@@ -153,5 +153,4 @@ textFileOracle = do
++ " (Stage: " ++ stageString stage ++ ")..."
Just <$> parsePackageData ctx
Nothing -> return Nothing
void $ addOracle $ \(PackageDataFile ctx) -> confCabal ctx
......@@ -23,68 +23,64 @@ import qualified Text.Parsec as Parsec
libraryRules :: Rules ()
libraryRules = do
root <- buildRootRules
root -/- "//libHS*-*.dylib" %> buildDynamicLibUnix root "dylib"
root -/- "//libHS*-*.so" %> buildDynamicLibUnix root "so"
root -/- "//*.a" %> buildStaticLib root
priority 2 $ root -/- "//HS*-*.o" %> buildGhciLibO root
root <- buildRootRules
root -/- "//libHS*-*.dylib" %> buildDynamicLibUnix root "dylib"
root -/- "//libHS*-*.so" %> buildDynamicLibUnix root "so"
root -/- "//*.a" %> buildStaticLib root
priority 2 $ root -/- "//HS*-*.o" %> buildGhciLibO root
-- * 'Action's for building libraries
-- | Build a static library ('LibA') under the given build root, whose
-- path is the second argument.
-- | Build a static library ('LibA') under the given build root, whose path is
-- the second argument.
buildStaticLib :: FilePath -> FilePath -> Action ()
buildStaticLib root archivePath = do
l@(BuildPath _ stage _ (LibA pkgname _ way))
<- parsePath (parseBuildLibA root)
"<.a library (build) path parser>"
archivePath
let context = libAContext l
objs <- libraryObjects context
removeFile archivePath
build $ target context (Ar Pack stage) objs [archivePath]
synopsis <- pkgSynopsis context
putSuccess $ renderLibrary
(quote pkgname ++ " (" ++ show stage ++ ", way " ++ show way ++ ").")
archivePath synopsis
-- | Build a dynamic library ('LibDyn') under the given build root,
-- with the given suffix (@.so@ or @.dylib@, @.dll@ in the future),
-- where the complete path of the archive to build is given as the
-- third argument.
l@(BuildPath _ stage _ (LibA pkgname _ way))
<- parsePath (parseBuildLibA root)
"<.a library (build) path parser>"
archivePath
let context = libAContext l
objs <- libraryObjects context
removeFile archivePath
build $ target context (Ar Pack stage) objs [archivePath]
synopsis <- pkgSynopsis context
putSuccess $ renderLibrary
(quote pkgname ++ " (" ++ show stage ++ ", way " ++ show way ++ ").")
archivePath synopsis
-- | Build a dynamic library ('LibDyn') under the given build root, with the
-- given suffix (@.so@ or @.dylib@, @.dll@ in the future), where the complete
-- path of the archive to build is given as the third argument.
buildDynamicLibUnix :: FilePath -> String -> FilePath -> Action ()
buildDynamicLibUnix root suffix dynlibpath = do
dynlib <- parsePath (parseBuildLibDyn root suffix) "<dyn lib parser>" dynlibpath
let context = libDynContext dynlib
deps <- contextDependencies context
need =<< mapM pkgLibraryFile deps
objs <- libraryObjects context
build $ target context (Ghc LinkHs $ Context.stage context) objs [dynlibpath]
-- | Build a "ghci library" ('LibGhci') under the given build root,
-- with the complete path of the file to build is given as the second
-- argument.
dynlib <- parsePath (parseBuildLibDyn root suffix) "<dyn lib parser>" dynlibpath
let context = libDynContext dynlib
deps <- contextDependencies context
need =<< mapM pkgLibraryFile deps
objs <- libraryObjects context
build $ target context (Ghc LinkHs $ Context.stage context) objs [dynlibpath]
-- | Build a "GHCi library" ('LibGhci') under the given build root, with the
-- complete path of the file to build is given as the second argument.
buildGhciLibO :: FilePath -> FilePath -> Action ()
buildGhciLibO root ghcilibPath = do
l@(BuildPath _ stage _ (LibGhci _ _ _))
<- parsePath (parseBuildLibGhci root)
"<.o ghci lib (build) path parser>"
ghcilibPath
let context = libGhciContext l
objs <- allObjects context
need objs
build $ target context (Ld stage) objs [ghcilibPath]
l@(BuildPath _ stage _ (LibGhci _ _ _))
<- parsePath (parseBuildLibGhci root)
"<.o ghci lib (build) path parser>"
ghcilibPath
let context = libGhciContext l
objs <- allObjects context
need objs
build $ target context (Ld stage) objs [ghcilibPath]
-- * Helpers
-- | Return all Haskell and non-Haskell object files for the
-- given 'Context'.
-- | Return all Haskell and non-Haskell object files for the given 'Context'.
allObjects :: Context -> Action [FilePath]
allObjects context = (++) <$> nonHsObjects context <*> hsObjects context
-- | Return all the non-Haskell object files for the given library
-- context (object files built from C, C-- and sometimes other things).
-- | Return all the non-Haskell object files for the given library context
-- (object files built from C, C-- and sometimes other things).
nonHsObjects :: Context -> Action [FilePath]
nonHsObjects context = do
cObjs <- cObjects context
......@@ -93,8 +89,7 @@ nonHsObjects context = do
eObjs <- extraObjects context
return $ cObjs ++ cmmObjs ++ eObjs
-- | Return all the C object files needed to build the given library
-- context.
-- | Return all the C object files needed to build the given library context.
cObjects :: Context -> Action [FilePath]
cObjects context = do
srcs <- interpretInContext context (getPackageData PD.cSrcs)
......@@ -104,8 +99,8 @@ cObjects context = do
else filter ((`notElem` ["Evac_thr", "Scav_thr"]) . takeBaseName) objs
-- | Return extra object files needed to build the given library context. The
-- resulting list is non empty only when the package from the 'Context' is
-- /integer-gmp/.
-- resulting list is currently non-empty only when the package from the
-- 'Context' is @integer-gmp@.
extraObjects :: Context -> Action [FilePath]
extraObjects context
| package context == integerGmp = do
......@@ -114,8 +109,8 @@ extraObjects context
map unifyPath <$> getDirectoryFiles "" [gmpPath -/- gmpObjectsDir -/- "*.o"]
| otherwise = return []
-- | Return all the object files to be put into the library
-- we're building for the given 'Context'.
-- | Return all the object files to be put into the library we're building for
-- the given 'Context'.
libraryObjects :: Context -> Action [FilePath]
libraryObjects context@Context{..} = do
hsObjs <- hsObjects context
......@@ -136,188 +131,177 @@ libraryObjects context@Context{..} = do
-- * Library paths types and parsers
-- | > libHS<pkg name>-<pkg version>[_<way suffix>].a
data LibA = LibA String [Integer] Way
deriving (Eq, Show)
data LibA = LibA String [Integer] Way deriving (Eq, Show)
-- | > <so or dylib>
data DynLibExt = So | Dylib
deriving (Eq, Show)
data DynLibExt = So | Dylib deriving (Eq, Show)
-- | > libHS<pkg name>-<pkg version>-ghc<ghc version>[_<way suffix>].<so or dylib>
data LibDyn = LibDyn String [Integer] Way DynLibExt
deriving (Eq, Show)
data LibDyn = LibDyn String [Integer] Way DynLibExt deriving (Eq, Show)
-- | > HS<pkg name>-<pkg version>[_<way suffix>].o
data LibGhci = LibGhci String [Integer] Way
deriving (Eq, Show)
data LibGhci = LibGhci String [Integer] Way deriving (Eq, Show)
-- | A path of the form
--
-- > <build root>/stage<N>/<path/to/pkg/from/ghc/root>/build/<something>
-- > <build root>/stage<N>/<path/to/pkg/from/ghc/root>/build/<something>
--
-- where @something@ describes a library to be build for the given package.
-- where @something@ describes a library to be build for the given package.
--
-- @a@, which represents that @something@, is instantiated as 'LibA', 'LibDyn'
-- and 'LibGhci' successively in this module, depending on the type of library
-- we're giving the build rules for.
data BuildPath a
= BuildPath FilePath -- ^ > <build root>/
Stage -- ^ > stage<N>/
FilePath -- ^ > <path/to/pkg/from/ghc/root>/build/
a -- ^ > whatever comes after 'build/'
deriving (Eq, Show)
-- @a@, which represents that @something@, is instantiated as 'LibA', 'LibDyn'
-- and 'LibGhci' successively in this module, depending on the type of library
-- we're giving the build rules for.
data BuildPath a = BuildPath FilePath -- ^ > <build root>/
Stage -- ^ > stage<N>/
FilePath -- ^ > <path/to/pkg/from/ghc/root>/build/
a -- ^ > whatever comes after 'build/'
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))
= Context stage pkg way
where pkg = Package (if pkgname == "rts" then C else Haskell) Library pkgname pkgpath
libAContext (BuildPath _ stage pkgpath (LibA pkgname _ way)) =
Context stage pkg way
where
pkg = Package (if pkgname == "rts" then C else Haskell) Library pkgname pkgpath
-- | Get the 'Context' corresponding to the build path for a given ghci library.
-- | Get the 'Context' corresponding to the build path for a given GHCi library.
libGhciContext :: BuildPath LibGhci -> Context
libGhciContext (BuildPath _ stage pkgpath (LibGhci pkgname _ way))
= Context stage pkg way
where pkg = Package (if pkgname == "rts" then C else Haskell) Library pkgname pkgpath
libGhciContext (BuildPath _ stage pkgpath (LibGhci pkgname _ way)) =
Context stage pkg way
where
pkg = Package (if pkgname == "rts" then C else Haskell) Library pkgname 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 _))
= Context stage pkg way
where pkg = Package (if pkgname == "rts" then C else Haskell) Library pkgname pkgpath
libDynContext (BuildPath _ stage pkgpath (LibDyn pkgname _ way _)) =
Context stage pkg way
where
pkg = Package (if pkgname == "rts" then C else Haskell) Library pkgname pkgpath
-- | Parse a build path for a library to be built under the given build root,
-- where the filename will be parsed with the given parser argument.
-- where the filename will be parsed with the given parser argument.
parseBuildPath
:: FilePath -- ^ build root
-> Parsec.Parsec String () a -- ^ what to parse after @build/@
-> Parsec.Parsec String () (BuildPath a)
:: FilePath -- ^ build root
-> Parsec.Parsec String () a -- ^ what to parse after @build/@
-> Parsec.Parsec String () (BuildPath a)
parseBuildPath root afterBuild = do
_ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
stage <- parseStage
_ <- Parsec.char '/'
pkgpath <- Parsec.manyTill Parsec.anyChar (Parsec.try $ Parsec.string "/build/")
a <- afterBuild
return (BuildPath root stage pkgpath a)
_ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
stage <- parseStage
_ <- Parsec.char '/'
pkgpath <- Parsec.manyTill Parsec.anyChar (Parsec.try $ Parsec.string "/build/")
a <- afterBuild
return (BuildPath root stage pkgpath a)
-- | Parse a path to a static library to be built, making sure the path starts
-- with the given build root.
-- with the given build root.
parseBuildLibA :: FilePath -> Parsec.Parsec String () (BuildPath LibA)
parseBuildLibA root = parseBuildPath root parseLibAFilename
Parsec.<?> "build path for a static library"
Parsec.<?> "build path for a static library"
-- | Parse a path to a ghci library to be built, making sure the path starts
-- with the given build root.
-- with the given build root.
parseBuildLibGhci :: FilePath -> Parsec.Parsec String () (BuildPath LibGhci)
parseBuildLibGhci root = parseBuildPath root parseLibGhciFilename
Parsec.<?> "build path for a ghci library"
Parsec.<?> "build path for a ghci library"
-- | Parse a path to a dynamic library to be built, making sure the path starts
-- with the given build root.
-- with the given build root.
parseBuildLibDyn :: FilePath -> String -> Parsec.Parsec String () (BuildPath LibDyn)
parseBuildLibDyn root ext = parseBuildPath root (parseLibDynFilename ext)
Parsec.<?> ("build path for a dynamic library with extension " ++ ext)
Parsec.<?> ("build path for a dynamic library with extension " ++ ext)
-- | Parse the filename of a static library to be built into a 'LibA' value.
parseLibAFilename :: Parsec.Parsec String () LibA
parseLibAFilename = do
_ <- Parsec.string "libHS"
(pkgname, pkgver) <- parsePkgId
way <- parseWaySuffix vanilla
_ <- Parsec.string ".a"
return (LibA pkgname pkgver way)
_ <- Parsec.string "libHS"
(pkgname, pkgver) <- parsePkgId
way <- parseWaySuffix vanilla
_ <- Parsec.string ".a"
return (LibA pkgname pkgver way)
-- | Parse the filename of a ghci library to be built into a 'LibGhci' value.
parseLibGhciFilename :: Parsec.Parsec String () LibGhci
parseLibGhciFilename = do
_ <- Parsec.string "HS"
(pkgname, pkgver) <- parsePkgId
way <- parseWaySuffix vanilla
_ <- Parsec.string ".o"
return (LibGhci pkgname pkgver way)
_ <- Parsec.string "HS"
(pkgname, pkgver) <- parsePkgId
way <- parseWaySuffix vanilla
_ <- Parsec.string ".o"
return (LibGhci pkgname pkgver way)
-- | Parse the filename of a dynamic library to be built into a 'LibDyn' value.
parseLibDynFilename :: String -> Parsec.Parsec String () LibDyn
parseLibDynFilename ext = do
_ <- Parsec.string "libHS"
(pkgname, pkgver) <- parsePkgId
_ <- optional $ Parsec.string "-ghc" *> parsePkgVersion
way <- addWayUnit Dynamic <$> parseWaySuffix dynamic
_ <- Parsec.string ("." ++ ext)
return (LibDyn pkgname pkgver way $ if ext == "so" then So else Dylib)
_ <- Parsec.string "libHS"
(pkgname, pkgver) <- parsePkgId
_ <- optional $ Parsec.string "-ghc" *> parsePkgVersion
way <- addWayUnit Dynamic <$> parseWaySuffix dynamic
_ <- Parsec.string ("." ++ ext)
return (LibDyn pkgname pkgver way $ if ext == "so" then So else Dylib)
-- To be kept in sync with Stage.hs's stageString function
-- | Parse @"stageX"@ into a 'Stage'.
parseStage :: Parsec.Parsec String () Stage
parseStage = (Parsec.string "stage" *> Parsec.choice
[ Parsec.string (show n) $> toEnum n
| n <- map fromEnum [minBound .. maxBound :: Stage]
]) Parsec.<?> "stage string"
-- To be kept in sync with the show instances in
-- Way.Type, until we perhaps use some bidirectional
-- parsing/pretty printing approach or library.
-- | Parse a way suffix, returning the argument when no suffix is found
-- (the argument will be vanilla in most cases, but dynamic when we parse
-- the way suffix out of a shared library file name.
[ Parsec.string (show n) $> toEnum n
| n <- map fromEnum [minBound .. maxBound :: Stage]
]) Parsec.<?> "stage string"
-- To be kept in sync with the show instances in 'Way.Type', until we perhaps
-- use some bidirectional parsing/pretty printing approach or library.
-- | Parse a way suffix, returning the argument when no suffix is found (the
-- argument will be vanilla in most cases, but dynamic when we parse the way
-- suffix out of a shared library file name).
parseWaySuffix :: Way -> Parsec.Parsec String () Way
parseWaySuffix w = Parsec.choice
[ Parsec.string "_" *> (wayFromUnits <$> Parsec.sepBy1 parseWayUnit (Parsec.string "_"))
, pure w
] Parsec.<?> "way suffix (e.g _thr_p, or none for vanilla)"
where parseWayUnit = Parsec.choice
[ Parsec.string "thr" *> pure Threaded
, Parsec.char 'd' *>
(Parsec.choice
[ Parsec.string "ebug" *> pure Debug
, Parsec.string "yn" *> pure Dynamic
]
)
, Parsec.char 'p' *> pure Profiling
, Parsec.char 'l' *> pure Logging
] Parsec.<?> "way unit (thr, debug, dyn, p, l)"
-- | Parse a @"pkgname-pkgversion"@ string into
-- the package name and the integers that make up the
-- package version.
[ Parsec.string "_" *> (wayFromUnits <$> Parsec.sepBy1 parseWayUnit (Parsec.string "_"))
, pure w
] Parsec.<?> "way suffix (e.g _thr_p, or none for vanilla)"
where
parseWayUnit = Parsec.choice
[ Parsec.string "thr" *> pure Threaded
, Parsec.char 'd' *>
(Parsec.choice [ Parsec.string "ebug" *> pure Debug
, Parsec.string "yn" *> pure Dynamic ])
, Parsec.char 'p' *> pure Profiling
, Parsec.char 'l' *> pure Logging
] Parsec.<?> "way unit (thr, debug, dyn, p, l)"
-- | Parse a @"pkgname-pkgversion"@ string into the package name and the
-- integers that make up the package version.
parsePkgId :: Parsec.Parsec String () (String, [Integer])
parsePkgId = parsePkgId' "" Parsec.<?> "package identifier (<name>-<version>)"
where parsePkgId' currName = do
s <- Parsec.many1 Parsec.alphaNum
_ <- Parsec.char '-'
let newName = if null currName then s else currName ++ "-" ++ s
Parsec.choice [ (newName,) <$> parsePkgVersion
, parsePkgId' newName
]
where
parsePkgId' currName = do
s <- Parsec.many1 Parsec.alphaNum
_ <- Parsec.char '-'
let newName = if null currName then s else currName ++ "-" ++ s
Parsec.choice [ (newName,) <$> parsePkgVersion
, parsePkgId' newName ]
-- | Parse "."-separated integers that describe a package's version.
parsePkgVersion :: Parsec.Parsec String () [Integer]
parsePkgVersion = fmap reverse (parsePkgVersion' []) Parsec.<?> "package version"
where parsePkgVersion' xs = do
n <- parseNatural
Parsec.choice
where
parsePkgVersion' xs = do
n <- parseNatural
Parsec.choice
[ Parsec.try (Parsec.lookAhead (Parsec.char '.' *> (Parsec.letter <|> Parsec.char '_')))
$> (n:xs)
, Parsec.char '.' *> parsePkgVersion' (n:xs)
, pure $ (n:xs)
]
, pure $ (n:xs) ]
-- | Parse a natural number.
parseNatural :: Parsec.Parsec String () Integer
parseNatural = (read <$> Parsec.many1 Parsec.digit)
Parsec.<?> "natural number"
parseNatural = (read <$> Parsec.many1 Parsec.digit) Parsec.<?> "natural number"
-- | Runs the given parser against the given path,
-- erroring out when the parser fails (because it shouldn't
-- if the code from this module is correct).
-- | Runs the given parser against the given path, erroring out when the parser
-- fails (because it shouldn't if the code from this module is correct).
parsePath
:: Parsec.Parsec String () a -- ^ parser to run
-> String -- ^ string describing the input source
-> FilePath -- ^ path to parse
-> Action a
:: Parsec.Parsec String () a -- ^ parser to run
-> String -- ^ string describing the input source
-> FilePath -- ^ path to parse
-> Action a
parsePath p inp path = case Parsec.parse p inp path of
Left err -> fail $ "Rules.Library.parsePath: path="
++ path ++ ", error:\n" ++ show err
Right a -> pure a
Left err -> fail $ "Rules.Library.parsePath: path="
++ path ++ ", error:\n" ++ show err
Right a -> pure a
......@@ -4,11 +4,14 @@ module Rules.Selftest (selftestRules) where
import Test.QuickCheck
import Base
import Context
import GHC
import Hadrian.Haskell.Cabal
import Oracles.ModuleFiles
import Oracles.Setting
import Settings
import Target
import Utilities
instance Arbitrary Way where
arbitrary = wayFromUnits <$> arbitrary
......@@ -24,6 +27,7 @@ selftestRules =
"selftest" ~> do
testBuilder
testChunksOfSize
testDependencies
testLookupAll
testModuleName
testPackages
......@@ -47,6 +51,24 @@ testChunksOfSize = do
let res = chunksOfSize n xs
in concat res == xs && all (\r -> length r == 1 || length (concat r) <= n) res
testDependencies :: Action ()
testDependencies = do
putBuild "==== pkgDependencies"
depLists <- mapM (pkgDependencies . vanillaContext Stage1) ghcPackages
test $ and [ deps == sort deps | Just deps <- depLists ]
putBuild "==== Dependencies of the 'ghc-bin' binary"
ghcDeps <- pkgDependencies (vanillaContext Stage1 ghc)
test $ isJust ghcDeps
test $ pkgName compiler `elem` fromJust ghcDeps
stage0Deps <- contextDependencies (vanillaContext Stage0 ghc)
stage1Deps <- contextDependencies (vanillaContext Stage1 ghc)
stage2Deps <- contextDependencies (vanillaContext Stage2 ghc)
test $ vanillaContext Stage0 compiler `notElem` stage1Deps
test $ vanillaContext Stage1 compiler `elem` stage1Deps
test $ vanillaContext Stage2 compiler `notElem` stage1Deps
test $ stage1Deps /= stage0Deps
test $ stage1Deps == stage2Deps
testLookupAll :: Action ()
testLookupAll = do
putBuild "==== lookupAll"
......@@ -89,4 +111,3 @@ testWay :: Action ()
testWay = do
putBuild "==== Read Way, Show Way"
test $ \(x :: Way) -> read (show x) == x
......@@ -46,14 +46,13 @@ contextDependencies ctx@Context {..} = do
let newPkgs = nubOrd $ sort (deps ++ pkgs)
if pkgs == newPkgs then return pkgs else go newPkgs
step pkg = pkgDependencies (ctx { Context.package = pkg }) >>= \case
Nothing -> return [] -- Non-Cabal packages have no dependencies.
Just deps -> do
active <- sort <$> stagePackages depStage
return $ intersectOrd (compare . pkgName) active deps
Nothing -> return [] -- Non-Cabal packages have no dependencies.
Just deps -> do
active <- sort <$> stagePackages depStage
return $ intersectOrd (compare . pkgName) active deps
cabalDependencies :: Context -> Action [String]
cabalDependencies ctx = interpretInContext ctx $
getPackageData PD.depIpIds
cabalDependencies ctx = interpretInContext ctx $ getPackageData PD.depIpIds
-- | Lookup dependencies of a 'Package' in the vanilla Stage1 context.
stage1Dependencies :: Package -> Action [Package]
......
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