1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Rules.Selftest (selftestRules) where
import Hadrian.Haskell.Cabal
import Test.QuickCheck
import Base
import Context
import Oracles.ModuleFiles
import Packages
import Settings
import Target
import Utilities
import qualified System.FilePath.Posix as Posix ((</>))
instance Arbitrary Way where
arbitrary = wayFromUnits <$> arbitrary
instance Arbitrary WayUnit where
arbitrary = arbitraryBoundedEnum
test :: Testable a => a -> Action ()
test = liftIO . quickCheck
selftestRules :: Rules ()
selftestRules =
"selftest" ~> do
testBuilder
testChunksOfSize
testDependencies
testLookupAll
testModuleName
testPackages
testPaths
testWay
testBuilder :: Action ()
testBuilder = do
putBuild "==== trackArgument"
let make = target undefined (Make undefined) undefined undefined
test $ forAll (elements ["-j", "MAKEFLAGS=-j", "THREADS="])
$ \prefix (NonNegative n) ->
not (trackArgument make prefix) &&
not (trackArgument make ("-j" ++ show (n :: Int)))
testChunksOfSize :: Action ()
testChunksOfSize = do
putBuild "==== chunksOfSize"
test $ chunksOfSize 3 [ "a", "b", "c" , "defg" , "hi" , "jk" ]
== [ ["a", "b", "c"], ["defg"], ["hi"], ["jk"] ]
test $ \n xs ->
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"
let pkgs = ghcPackages \\ [libffi] -- @libffi@ does not have a Cabal file.
depLists <- mapM pkgDependencies pkgs
test $ and [ deps == sort deps | deps <- depLists ]
putBuild "==== Dependencies of the 'ghc-bin' binary"
ghcDeps <- pkgDependencies ghc
test $ pkgName compiler `elem` ghcDeps
stage0Deps <- contextDependencies (vanillaContext stage0InTree ghc)
stage1Deps <- contextDependencies (vanillaContext Stage1 ghc)
stage2Deps <- contextDependencies (vanillaContext Stage2 ghc)
test $ vanillaContext stage0InTree 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"
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 (`lookup` dict) items
where
dicts :: Gen [(Int, Int)]
dicts = nubBy (\x y -> fst x == fst y) <$> vector 20
extras :: Gen [Int]
extras = vector 20
testModuleName :: Action ()
testModuleName = do
putBuild "==== Encode/decode module name"
test $ encodeModule "Data/Functor" "Identity.hs" == "Data.Functor.Identity"
test $ encodeModule "" "Prelude" == "Prelude"
test $ decodeModule "Data.Functor.Identity" == ("Data/Functor", "Identity")
test $ decodeModule "Prelude" == ("", "Prelude")
test $ forAll names $ \n -> uncurry encodeModule (decodeModule n) == n
where
names = intercalate "." <$> listOf1 (listOf1 $ elements "abcABC123_'")
testPackages :: Action ()
testPackages = do
putBuild "==== Check system configuration"
putBuild "==== Packages, interpretInContext, configuration flags"
forM_ allStages $ \stage -> do
pkgs <- stagePackages stage
when (win32 `elem` pkgs) . test $ windowsHost
when (unix `elem` pkgs) . test $ not windowsHost
test $ pkgs == nubOrd pkgs
testWay :: Action ()
testWay = do
putBuild "==== Read Way, Show Way"
test $ \(x :: Way) -> read (show x) == x
testPaths :: Action ()
testPaths = do
putBuild "==== Absolute, Relative Path Concatenation"
test $ forAll paths $ \(path1, path2) ->
path1 -/- path2 == path1 Posix.</> path2
where
paths = (,) <$> path <*> path
path = frequency [(1, relativePath), (1, absolutePath)]
relativePath = intercalate "/" <$> listOf1 (elements ["a"])
absolutePath = ('/':) <$> relativePath
|
