Fix package dependencies (#657)
authorAndrey Mokhov <andrey.mokhov@gmail.com>
Fri, 24 Aug 2018 10:25:39 +0000 (11:25 +0100)
committerGitHub <noreply@github.com>
Fri, 24 Aug 2018 10:25:39 +0000 (11:25 +0100)
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.)

src/Expression.hs
src/Hadrian/Haskell/Cabal.hs
src/Hadrian/Oracles/TextFile.hs
src/Rules/Library.hs
src/Rules/Selftest.hs
src/Utilities.hs

index 3a26f43..d17ee67 100644 (file)
@@ -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
index faba64f..a330f44 100644 (file)
@@ -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
index 2f58fab..bcacb46 100644 (file)
@@ -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
index 0f74d9d..d4228dd 100644 (file)
@@ -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
index d1ffaac..0bf2824 100644 (file)
@@ -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
-
index 2c73d94..1be1e54 100644 (file)
@@ -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]