c3c8870752
It seems to make sense to convert both System.Directory and System.FilePath uses to OsPath in one go. This will generally look like replacing RawFilePath with OsPath in type signatures, and will be driven by the now absolutely massive pile of compile errors. Got a few modules building in this new regime. Sponsored-by: Jack Hill
133 lines
3.8 KiB
Haskell
133 lines
3.8 KiB
Haskell
{- 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.SystemDirectory
|
|
import Utility.OsPath
|
|
|
|
import System.IO
|
|
|
|
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 (inSearchPath 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 = toOsPath d </> toOsPath command
|
|
in ifM (doesFileExist f)
|
|
( return (Just (fromOsPath 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
|