94c1ecc5574270cdaafb38d9a1e784b978e37687
[ghc.git] / src / Rules / Selftest.hs
1 {-# OPTIONS_GHC -fno-warn-orphans #-}
2 module Rules.Selftest (selftestRules) where
3
4 import Test.QuickCheck
5
6 import Base
7 import GHC
8 import Oracles.ModuleFiles
9 import Oracles.Setting
10 import Settings
11 import Target
12
13 instance Arbitrary Way where
14 arbitrary = wayFromUnits <$> arbitrary
15
16 instance Arbitrary WayUnit where
17 arbitrary = arbitraryBoundedEnum
18
19 test :: Testable a => a -> Action ()
20 test = liftIO . quickCheck
21
22 selftestRules :: Rules ()
23 selftestRules =
24 "selftest" ~> do
25 testBuilder
26 testChunksOfSize
27 testLookupAll
28 testModuleName
29 testPackages
30 testWay
31
32 testBuilder :: Action ()
33 testBuilder = do
34 putBuild $ "==== trackArgument"
35 let make = target undefined (Make undefined) undefined undefined
36 test $ forAll (elements ["-j", "MAKEFLAGS=-j", "THREADS="])
37 $ \prefix (NonNegative n) ->
38 trackArgument make prefix == False &&
39 trackArgument make ("-j" ++ show (n :: Int)) == False
40
41 testChunksOfSize :: Action ()
42 testChunksOfSize = do
43 putBuild $ "==== chunksOfSize"
44 test $ chunksOfSize 3 [ "a", "b", "c" , "defg" , "hi" , "jk" ]
45 == [ ["a", "b", "c"], ["defg"], ["hi"], ["jk"] ]
46 test $ \n xs ->
47 let res = chunksOfSize n xs
48 in concat res == xs && all (\r -> length r == 1 || length (concat r) <= n) res
49
50 testLookupAll :: Action ()
51 testLookupAll = do
52 putBuild $ "==== lookupAll"
53 test $ lookupAll ["b" , "c" ] [("a", 1), ("c", 3), ("d", 4)]
54 == [Nothing, Just (3 :: Int)]
55 test $ forAll dicts $ \dict -> forAll extras $ \extra ->
56 let items = sort $ map fst dict ++ extra
57 in lookupAll items (sort dict) == map (flip lookup dict) items
58 where
59 dicts :: Gen [(Int, Int)]
60 dicts = nubBy (\x y -> fst x == fst y) <$> vector 20
61 extras :: Gen [Int]
62 extras = vector 20
63
64 testModuleName :: Action ()
65 testModuleName = do
66 putBuild $ "==== Encode/decode module name"
67 test $ encodeModule "Data/Functor" "Identity.hs" == "Data.Functor.Identity"
68 test $ encodeModule "" "Prelude" == "Prelude"
69
70 test $ decodeModule "Data.Functor.Identity" == ("Data/Functor", "Identity")
71 test $ decodeModule "Prelude" == ("", "Prelude")
72
73 test $ forAll names $ \n -> uncurry encodeModule (decodeModule n) == n
74 where
75 names = intercalate "." <$> listOf1 (listOf1 $ elements "abcABC123_'")
76
77 testPackages :: Action ()
78 testPackages = do
79 putBuild $ "==== Check system configuration"
80 win <- windowsHost -- This depends on the @boot@ and @configure@ scripts.
81 putBuild $ "==== Packages, interpretInContext, configuration flags"
82 forM_ [Stage0 ..] $ \stage -> do
83 pkgs <- stagePackages stage
84 when (win32 `elem` pkgs) . test $ win
85 when (unix `elem` pkgs) . test $ not win
86 test $ pkgs == nubOrd pkgs
87
88 testWay :: Action ()
89 testWay = do
90 putBuild $ "==== Read Way, Show Way"
91 test $ \(x :: Way) -> read (show x) == x
92