[commit: ghc] wip/nfs-locking: Add a selftest for Packages (e2871fc)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/nfs-locking
Link       : http://ghc.haskell.org/trac/ghc/changeset/e2871fc28f9f8de741326bdc9b7ad48aa1936393/ghc

>---------------------------------------------------------------

commit e2871fc28f9f8de741326bdc9b7ad48aa1936393
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date:   Sun Oct 30 17:26:46 2016 +0000

    Add a selftest for Packages


>---------------------------------------------------------------

e2871fc28f9f8de741326bdc9b7ad48aa1936393
 src/Rules/Selftest.hs | 53 ++++++++++++++++++++++++++++++---------------------
 1 file changed, 31 insertions(+), 22 deletions(-)

diff --git a/src/Rules/Selftest.hs b/src/Rules/Selftest.hs
index e7f5dbb..58de8fb 100644
--- a/src/Rules/Selftest.hs
+++ b/src/Rules/Selftest.hs
@@ -6,11 +6,11 @@ import Development.Shake
 import Test.QuickCheck
 
 import Base
-import Builder
+import Expression
 import Oracles.ModuleFiles
+import Settings
 import Settings.Builders.Ar
 import UserSettings
-import Way
 
 instance Arbitrary Way where
     arbitrary = wayFromUnits <$> arbitrary
@@ -25,11 +25,12 @@ selftestRules :: Rules ()
 selftestRules =
     "selftest" ~> do
         testBuilder
-        testWay
         testChunksOfSize
+        testLookupAll
         testMatchVersionedFilePath
         testModuleName
-        testLookupAll
+        testPackages
+        testWay
 
 testBuilder :: Action ()
 testBuilder = do
@@ -39,11 +40,6 @@ testBuilder = do
             trackedArgument (Make undefined) prefix == False &&
             trackedArgument (Make undefined) ("-j" ++ show (n :: Int)) == False
 
-testWay :: Action ()
-testWay = do
-    putBuild $ "==== Read Way, Show Way"
-    test $ \(x :: Way) -> read (show x) == x
-
 testChunksOfSize :: Action ()
 testChunksOfSize = do
     putBuild $ "==== chunksOfSize"
@@ -53,6 +49,20 @@ testChunksOfSize = do
         let res = chunksOfSize n xs
         in concat res == xs && all (\r -> length r == 1 || length (concat r) <= n) res
 
+testLookupAll :: Action ()
+testLookupAll = do
+    putBuild $ "==== lookupAll"
+    test $ lookupAll ["b"    , "c"            ] [("a", 1), ("c", 3), ("d", 4)]
+                  == [Nothing, Just (3 :: Int)]
+    test $ forAll dicts $ \dict -> forAll extras $ \extra ->
+        let items = sort $ map fst dict ++ extra
+        in lookupAll items (sort dict) == map (flip lookup dict) items
+  where
+    dicts :: Gen [(Int, Int)]
+    dicts = nubBy ((==) `on` fst) <$> vector 20
+    extras :: Gen [Int]
+    extras = vector 20
+
 testMatchVersionedFilePath :: Action ()
 testMatchVersionedFilePath = do
     putBuild $ "==== matchVersionedFilePath"
@@ -82,16 +92,15 @@ testModuleName = do
   where
     names = intercalate "." <$> listOf1 (listOf1 $ elements "abcABC123_'")
 
-testLookupAll :: Action ()
-testLookupAll = do
-    putBuild $ "==== lookupAll"
-    test $ lookupAll ["b"    , "c"            ] [("a", 1), ("c", 3), ("d", 4)]
-                  == [Nothing, Just (3 :: Int)]
-    test $ forAll dicts $ \dict -> forAll extras $ \extra ->
-        let items = sort $ map fst dict ++ extra
-        in lookupAll items (sort dict) == map (flip lookup dict) items
-  where
-    dicts :: Gen [(Int, Int)]
-    dicts = nubBy ((==) `on` fst) <$> vector 20
-    extras :: Gen [Int]
-    extras = vector 20
+testPackages :: Action ()
+testPackages = do
+    putBuild $ "==== Packages, interpretInContext"
+    forM_ [Stage0 ..] $ \stage -> do
+        pkgs <- stagePackages stage
+        test $ pkgs == nubOrd pkgs
+
+testWay :: Action ()
+testWay = do
+    putBuild $ "==== Read Way, Show Way"
+    test $ \(x :: Way) -> read (show x) == x
+