2011-01-20 00:02:48 +00:00
|
|
|
{- Tests the system and generates SysConfig.hs. -}
|
|
|
|
|
|
|
|
module TestConfig where
|
|
|
|
|
|
|
|
import System.IO
|
|
|
|
import System.Cmd
|
|
|
|
import System.Exit
|
|
|
|
|
|
|
|
type ConfigKey = String
|
2011-04-08 01:47:56 +00:00
|
|
|
data ConfigValue =
|
|
|
|
BoolConfig Bool |
|
|
|
|
StringConfig String |
|
|
|
|
MaybeStringConfig (Maybe String)
|
2011-01-20 00:02:48 +00:00
|
|
|
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
|
2011-04-08 01:47:56 +00:00
|
|
|
show (MaybeStringConfig s) = show s
|
2011-01-20 00:02:48 +00:00
|
|
|
|
|
|
|
instance Show Config where
|
2011-04-08 01:47:56 +00:00
|
|
|
show (Config key value) = unlines
|
2011-01-20 00:02:48 +00:00
|
|
|
[ key ++ " :: " ++ valuetype value
|
|
|
|
, key ++ " = " ++ show value
|
|
|
|
]
|
|
|
|
where
|
|
|
|
valuetype (BoolConfig _) = "Bool"
|
|
|
|
valuetype (StringConfig _) = "String"
|
2011-04-08 01:47:56 +00:00
|
|
|
valuetype (MaybeStringConfig _) = "Maybe String"
|
2011-01-20 00:02:48 +00:00
|
|
|
|
|
|
|
writeSysConfig :: [Config] -> IO ()
|
|
|
|
writeSysConfig config = writeFile "SysConfig.hs" body
|
|
|
|
where
|
|
|
|
body = unlines $ header ++ map show config ++ footer
|
|
|
|
header = [
|
|
|
|
"{- Automatically generated. -}"
|
|
|
|
, "module SysConfig where"
|
|
|
|
, ""
|
|
|
|
]
|
|
|
|
footer = []
|
|
|
|
|
|
|
|
runTests :: [TestCase] -> IO [Config]
|
|
|
|
runTests [] = return []
|
2011-07-15 07:12:05 +00:00
|
|
|
runTests (TestCase tname t : ts) = do
|
2011-01-20 00:02:48 +00:00
|
|
|
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"
|
2011-07-15 07:12:05 +00:00
|
|
|
c = head $ words cmdline
|
2011-01-20 00:02:48 +00:00
|
|
|
|
|
|
|
{- 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. -}
|
2011-04-08 04:12:00 +00:00
|
|
|
selectCmd :: ConfigKey -> [String] -> String -> Test
|
|
|
|
selectCmd k = searchCmd
|
2011-07-15 07:12:05 +00:00
|
|
|
(return . Config k . StringConfig)
|
2011-04-08 04:12:00 +00:00
|
|
|
(\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
|
2011-07-15 07:12:05 +00:00
|
|
|
(return . Config k . MaybeStringConfig . Just)
|
2011-04-08 04:12:00 +00:00
|
|
|
(\_ -> return $ Config k $ MaybeStringConfig Nothing)
|
|
|
|
|
|
|
|
searchCmd :: (String -> Test) -> ([String] -> Test) -> [String] -> String -> Test
|
|
|
|
searchCmd success failure cmds param = search cmds
|
2011-01-20 00:02:48 +00:00
|
|
|
where
|
2011-04-08 04:12:00 +00:00
|
|
|
search [] = failure cmds
|
2011-01-20 00:02:48 +00:00
|
|
|
search (c:cs) = do
|
2011-04-08 02:03:31 +00:00
|
|
|
ret <- system $ quiet c ++ " " ++ param
|
2011-07-15 07:12:05 +00:00
|
|
|
if ret == ExitSuccess
|
2011-04-08 02:03:31 +00:00
|
|
|
then success c
|
2011-04-08 00:08:11 +00:00
|
|
|
else search cs
|
|
|
|
|
2011-01-20 00:02:48 +00:00
|
|
|
quiet :: String -> String
|
|
|
|
quiet s = s ++ " >/dev/null 2>&1"
|
|
|
|
|
|
|
|
testStart :: TestName -> IO ()
|
|
|
|
testStart s = do
|
|
|
|
putStr $ " checking " ++ s ++ "..."
|
|
|
|
hFlush stdout
|
|
|
|
|
|
|
|
testEnd :: Config -> IO ()
|
2011-07-15 07:12:05 +00:00
|
|
|
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"
|
|
|
|
|
|
|
|
status :: String -> IO ()
|
|
|
|
status s = putStrLn $ ' ':s
|