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
126
127
128
129
130
|
{- Tests the system and generates SysConfig. -}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Build.TestConfig where
import Utility.Path
import Utility.Monad
import Utility.SafeCommand
import Utility.Directory
import System.IO
import System.FilePath
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" body
where
body = unlines $ header ++ map show config ++ footer
header = [
"{- Automatically generated. -}"
, ""
]
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
{- Checks if a command is available by running a command line. -}
testCmd :: ConfigKey -> String -> Test
testCmd k cmdline = do
ok <- boolSystem "sh" [ Param "-c", Param $ quiet cmdline ]
return $ Config k (BoolConfig ok)
{- 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
ok <- boolSystem "sh" [ Param "-c", Param $ quiet $ c ++ " " ++ params ]
if ok
then success c
else search cs
{- Finds a command, either in PATH or perhaps in a sbin directory not in
- PATH. If it's in PATH the config is set to just the command name,
- but if it's found outside PATH, the config is set to the full path to
- the command. -}
findCmdPath :: ConfigKey -> String -> Test
findCmdPath k command = do
ifM (inPath command)
( return $ Config k $ MaybeStringConfig $ Just command
, do
r <- getM find ["/usr/sbin", "/sbin", "/usr/local/sbin"]
return $ Config k $ MaybeStringConfig r
)
where
find d =
let f = d </> command
in ifM (doesFileExist f) ( return (Just f), return Nothing )
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
|
