blob: eb920c13f560611515857f006ee1fc512b71d6b8 (
plain)
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
|
{- Tests the system and generates Build.SysConfig.hs. -}
module Build.TestConfig where
import System.IO
import System.Cmd
import System.Exit
type ConfigKey = String
data ConfigValue =
BoolConfig Bool |
StringConfig String |
MaybeStringConfig (Maybe String) |
MaybeBoolConfig (Maybe Bool)
data Config = Config ConfigKey ConfigValue
type Test = IO Config
type TestName = String
data TestCase = TestCase TestName Test
instance Show ConfigValue where
show (BoolConfig b) = show b
show (StringConfig s) = show s
show (MaybeStringConfig s) = show s
show (MaybeBoolConfig s) = show s
instance Show Config where
show (Config key value) = unlines
[ key ++ " :: " ++ valuetype value
, key ++ " = " ++ show value
]
where
valuetype (BoolConfig _) = "Bool"
valuetype (StringConfig _) = "String"
valuetype (MaybeStringConfig _) = "Maybe String"
valuetype (MaybeBoolConfig _) = "Maybe Bool"
writeSysConfig :: [Config] -> IO ()
writeSysConfig config = writeFile "Build/SysConfig.hs" body
where
body = unlines $ header ++ map show config ++ footer
header = [
"{- Automatically generated. -}"
, "module Build.SysConfig where"
, ""
]
footer = []
runTests :: [TestCase] -> IO [Config]
runTests [] = return []
runTests (TestCase tname t : ts) = do
testStart tname
c <- t
testEnd c
rest <- runTests ts
return $ c:rest
{- Tests that a command is available, aborting if not. -}
requireCmd :: ConfigKey -> String -> Test
requireCmd k cmdline = do
ret <- testCmd k cmdline
handle ret
where
handle r@(Config _ (BoolConfig True)) = return r
handle r = do
testEnd r
error $ "** the " ++ c ++ " command is required"
c = head $ words cmdline
{- Checks if a command is available by running a command line. -}
testCmd :: ConfigKey -> String -> Test
testCmd k cmdline = do
ret <- system $ quiet cmdline
return $ Config k (BoolConfig $ ret == ExitSuccess)
{- Ensures that one of a set of commands is available by running each in
- turn. The Config is set to the first one found. -}
selectCmd :: ConfigKey -> [(String, String)] -> Test
selectCmd k = searchCmd
(return . Config k . StringConfig)
(\cmds -> do
testEnd $ Config k $ BoolConfig False
error $ "* need one of these commands, but none are available: " ++ show cmds
)
maybeSelectCmd :: ConfigKey -> [(String, String)] -> Test
maybeSelectCmd k = searchCmd
(return . Config k . MaybeStringConfig . Just)
(\_ -> return $ Config k $ MaybeStringConfig Nothing)
searchCmd :: (String -> Test) -> ([String] -> Test) -> [(String, String)] -> Test
searchCmd success failure cmdsparams = search cmdsparams
where
search [] = failure $ fst $ unzip cmdsparams
search ((c, params):cs) = do
ret <- system $ quiet $ c ++ " " ++ params
if ret == ExitSuccess
then success c
else search cs
quiet :: String -> String
quiet s = s ++ " >/dev/null 2>&1"
testStart :: TestName -> IO ()
testStart s = do
putStr $ " checking " ++ s ++ "..."
hFlush stdout
testEnd :: Config -> IO ()
testEnd (Config _ (BoolConfig True)) = status "yes"
testEnd (Config _ (BoolConfig False)) = status "no"
testEnd (Config _ (StringConfig s)) = status s
testEnd (Config _ (MaybeStringConfig (Just s))) = status s
testEnd (Config _ (MaybeStringConfig Nothing)) = status "not available"
testEnd (Config _ (MaybeBoolConfig (Just True))) = status "yes"
testEnd (Config _ (MaybeBoolConfig (Just False))) = status "no"
testEnd (Config _ (MaybeBoolConfig Nothing)) = status "unknown"
status :: String -> IO ()
status s = putStrLn $ ' ':s
|
