Commit 5c1adf65 authored by simonmar's avatar simonmar
Browse files

[project @ 2001-08-14 14:19:50 by simonmar]

Random hackage, including:

 - use the GetOpt library rather than hand-coded option parsing
 - change the binding syntax from --$var=value to just var=value.
 - be more informative in a couple of error messages
parent 5519110d
......@@ -6,6 +6,7 @@ import CmdSyntax
import CmdLexer ( isVarChar )
import CmdParser ( parseScript )
import TopSort ( topSort )
import Maybe ( isJust, fromJust )
import Monad ( when )
import Directory ( doesFileExist, removeFile )
import System ( ExitCode(..) )
......@@ -158,7 +159,7 @@ setResult is_actual res
(if is_actual then (r_exp, Just res)
else (Just res, r_act)) `bind` \ (new_exp, new_act) ->
if isJust new_exp && isJust new_act
then resultsEV (unJust new_exp, unJust new_act)
then resultsEV (fromJust new_exp, fromJust new_act)
else
setEvalEnv (p{results = (new_exp, new_act)})
`thenE_`
......@@ -278,7 +279,7 @@ evalTopBinds globals binds
-> return (Left ("circular dependencies for top-level vars: "
++ unwords (map ('$':) circular_vars)))
Right eval_order
-> let in_order = [ (v, unJust (lookup v binds)) | v <- eval_order ]
-> let in_order = [ (v, fromJust (lookup v binds)) | v <- eval_order ]
in
loop globals in_order
where
......
......@@ -5,15 +5,15 @@ module CmdSyntax ( Var, MacroName, TestName, MacroDef(..),
TestID(..), ppTestID,
TestResult(..), ppTestResult,
testid_of_TestResult, results_of_TestResult,
panic, officialMsg, my_system,
isJust, isNothing, unJust,
isTInclude, isTTest, isTMacroDef, isTAssign,
isLeft, isRight, unLeft, unRight
isLeft, isRight, unLeft, unRight,
panic, officialMsg, my_system, die,
)
where
import IO ( stdout, hPutStrLn )
import System ( system )
import IO
import System
---------------------------------------------------------------------
-- misc
......@@ -21,7 +21,11 @@ panic str
= error ("\nruntests: the `impossible' happened:\n\t" ++ str ++ "\n")
officialMsg str
= hPutStrLn stdout ("runtests: " ++ str)
= do prog <- getProgName
hPutStrLn stderr (prog ++ ": " ++ str)
die :: String -> IO a
die s = do officialMsg s; exitWith (ExitFailure 1)
my_system s
= do putStrLn s
......@@ -29,12 +33,6 @@ my_system s
--putStrLn (show exit_code)
return exit_code
isJust (Just _) = True
isJust Nothing = False
isNothing = not . isJust
unJust (Just x) = x
isLeft (Left _) = True
isLeft (Right _) = False
isRight = not . isLeft
......
......@@ -3,12 +3,15 @@ module Main where
import CmdSyntax
import CmdSemantics ( parseOneTFile, processParsedTFile )
import GetOpt
import Directory
import System
import List
import Maybe ( isJust, fromJust )
import Monad ( when )
import Time ( ClockTime, getClockTime )
import IO ( catch )
import IO ( try )
--import IOExts(trace)
......@@ -63,20 +66,47 @@ scrub ('/':'.':'/':cs) = scrub ('/':cs)
scrub (c:cs) = c : scrub cs
usage
= "\nusage:\n" ++
"runtests --tool=<compiler-to-test>\n" ++ -- "
" --config=<path_to_config_file>\n" ++ -- "
" --rootdir=<path_to_root_of_tests_directory>\n" ++ -- "
" --save-summary=<path_of_summary_file_to_create>\n" ++ -- "
" --compare-summary=<path_of_summary_file_to_compare_against>\n" ++ -- "
" [--$var=literal-value]\n" ++ -- "
" [names of tests to run, if you don't want all]\n" ++
"\n" ++
" You may not set any of the following vars from the\n" ++
data Opt
= OptTool String
| OptConfig String
| OptRootDir String
| OptSaveSummary String
| OptCompareSummary String
option_descrs = [
Option "" ["tool"] (ReqArg OptTool "PATH")
"compiler to test",
Option "" ["config"] (ReqArg OptConfig "FILE")
"config file",
Option "" ["rootdir"] (ReqArg OptRootDir "DIR")
"root of tree containing tests (default: .)",
Option "" ["save-summary"] (ReqArg OptSaveSummary "PATH")
"file in which to save the summary",
Option "" ["compare-summary"] (ReqArg OptCompareSummary "PATH")
"old summary to compare against"
]
usage = GetOpt.usageInfo header option_descrs ++ '\n':extra_info
header = "runtests [OPTION | VAR=VALUE | TEST]..."
extra_info
= " You may not set any of the following vars from the\n" ++
" command line:\n" ++
concatMap (\w -> " $" ++ w ++ "\n") special_var_names
getToolOpt os = exactlyOne "-tool" [ t | OptTool t <- os ]
getConfigOpt os = exactlyOne "-config" [ t | OptConfig t <- os ]
getRootOpt os = upToOne "-rootdir" [ t | OptRootDir t <- os ]
getSaveSuOpt os = upToOne "-save-summary" [ t | OptSaveSummary t <- os ]
getCompareSuOpt os = upToOne "-compare-summary" [ t | OptCompareSummary t <- os]
exactlyOne s [] = die ("missing " ++ '-':s ++ " option")
exactlyOne _ [a] = return a
exactlyOne s as = die ("multiple " ++ '-':s ++ " options")
upToOne s [] = return Nothing
upToOne s [a] = return (Just a)
upToOne s as = die ("multiple " ++ '-':s ++ " options")
main
= getArgs >>= main_really
......@@ -87,85 +117,84 @@ test
++ "--rootdir=../tests/codeGen")
main_really arg_ws0
= do { start_time <- getClockTime
; let (arg_ws1, maybe_tool) = fish arg_ws0 "--tool="
; let (arg_ws2, maybe_conf) = fish arg_ws1 "--config="
; let (arg_ws3, maybe_root) = fish arg_ws2 "--rootdir="
; let (arg_ws4, maybe_save_su) = fish arg_ws3 "--save-summary="
; let (arg_ws5, maybe_cmp_su) = fish arg_ws4 "--compare-summary="
; let (arg_ws6, cmd_binds) = getBinds arg_ws5
; let invalid_binds
= do start_time <- getClockTime
case getOpt Permute option_descrs arg_ws0 of
(opts, args, []) -> got_args opts args start_time
(_, _, errs) -> die (concat errs ++ usage)
got_args opts args start_time
= do tool <- getToolOpt opts
conf <- getConfigOpt opts
maybe_root <- getRootOpt opts
maybe_save_su <- getSaveSuOpt opts
maybe_cmp_su <- getCompareSuOpt opts
let (not_binds, cmd_binds) = getBinds args
let invalid_binds
= filter (`elem` special_var_names)
(map fst cmd_binds)
; if (isNothing maybe_tool
|| isNothing maybe_conf
|| isNothing maybe_root
|| not (null invalid_binds))
then do officialMsg usage
exitWith (ExitFailure 1)
else
do { let tool = unJust maybe_tool
conf = unJust maybe_conf
root = unJust maybe_root
when (not (null invalid_binds)) $ do
die ("cannot set special variable $" ++ head invalid_binds ++
" on the command line")
let -- default root is '.'
root | isJust maybe_root = fromJust maybe_root
| otherwise = "."
(confdir, conffile) = splitPathname conf
base_genv = [("tool", tool),
("confdir", confdir),
("conffilename", conffile)]
tests_to_run
= if null arg_ws6 then Nothing{-all of them-}
else Just arg_ws4{-just these-}
; conf_ok <- doesFileExist conf
; if not conf_ok
then do officialMsg ("Config file `" ++ conf ++ "' doesn't exist.")
exitWith (ExitFailure 1)
else
do { -- Find all the .T files
; all_tfiles <- findTFiles root
; putStr "\n"
; officialMsg ("Found " ++ show (length all_tfiles)
= if null not_binds then Nothing{-all of them-}
else Just not_binds{-just these-}
conf_ok <- doesFileExist conf
when (not conf_ok) (die ("config file `" ++ conf ++ "' doesn't exist"))
-- Find all the .T files
all_tfiles <- findTFiles root
officialMsg ("Found " ++ show (length all_tfiles)
++ " test description files:")
; putStr "\n"
; putStrLn (unlines (map (" "++) all_tfiles))
putStrLn (unlines (map (" "++) all_tfiles))
-- Parse them all
; all_parsed
all_parsed
<- mapM (\tfpath -> parseOneTFile
(addTVars base_genv tfpath) tfpath)
all_tfiles
; let parse_fails = filter isLeft all_parsed
; when (not (null parse_fails)) (
let parse_fails = filter isLeft all_parsed
when (not (null parse_fails)) (
do officialMsg ("Parse errors for the following .T files:\n")
putStr (unlines (map ((" "++).unLeft) parse_fails))
)
; let parsed_ok = map unRight (filter isRight all_parsed)
let parsed_ok = map unRight (filter isRight all_parsed)
-- Run all the tests in each successfully-parsed .T file.
; resultss
resultss
<- mapM ( \ (path,topdefs) -> processParsedTFile
tests_to_run
path
(addTVars base_genv path)
topdefs)
parsed_ok
; let results = concat resultss
; putStr "\n"
; officialMsg ("=== All done. ===")
let results = concat resultss
putStr "\n"
officialMsg ("=== All done. ===")
-- ; putStr ("\n" ++ ((unlines . map show) results))
; let summary = makeSummary start_time results
; putStr ("\n" ++ snd (ppSummary summary))
; putStr "\n"
; case maybe_cmp_su of
let summary = makeSummary start_time results
putStrLn ("\n" ++ snd (ppSummary summary))
case maybe_cmp_su of
Nothing -> return ()
Just fn
-> do { officialMsg ("=== Comparing against: " ++ fn ++ " ===")
; maybe_txt <- maybe_readFile fn
; maybe_txt <- try (readFile fn)
; case maybe_txt of {
Nothing -> do
Left err -> do
officialMsg ("=== Can't read abovementioned file ===")
return ()
; Just txt ->
print err
; Right txt ->
do { case ((reads txt) :: [(Summary, String)]) of
((old_summ, ""):_)
-> do putStrLn ""
......@@ -175,15 +204,16 @@ main_really arg_ws0
("=== Parse error in: " ++ fn ++ " ===")
return ()
}}}
; case maybe_save_su of
case maybe_save_su of
Nothing -> return ()
Just fn -> do officialMsg ("=== Saving summary in: " ++ fn ++ " ===")
wr_ok <- maybe_writeFile fn (show summary)
when (not wr_ok)
(officialMsg ("=== Can't write abovementioned file ==="))
; putStrLn ""
wr_ok <- try (writeFile fn (show summary))
case wr_ok of
Right _ -> return ()
Left err -> do officialMsg ("=== Can't write abovementioned file ===")
print err
putStrLn ""
-- ; exitWith ExitSuccess
}}}
where
addTVars some_genv tfpath
= case splitPathname tfpath of
......@@ -326,18 +356,6 @@ ppSummaryDiffs old new
now_unexp
-- Helper for cmd line args
fish :: [String] -> String -> ([String], Maybe String)
fish strs prefix
= let n_prefix = length prefix
pfx_eq = (== prefix).(take n_prefix)
matched = filter pfx_eq strs
unmatched = filter (not.pfx_eq) strs
in case matched of
[m] -> (unmatched, Just (drop n_prefix m))
_ -> (strs, Nothing)
-- (eg) "foo/bar/xyzzy.ext" --> ("foo/bar", "xyzzy.ext")
splitPathname :: String -> (String, String)
splitPathname full
......@@ -349,21 +367,18 @@ splitPathname full
in if null p_r then (".", reverse f_r)
else (reverse p_r, reverse f_r)
-- Extract all the --$var=value binds from a bunch of cmd line opts.
-- Extract all the var=value binds from a bunch of cmd line opts.
getBinds :: [String] -> ([String], [(Var,String)])
getBinds cmd_line_opts
= f [] [] cmd_line_opts
where
f acc_n acc_y []
= (reverse acc_n, reverse acc_y)
f acc_n acc_y (str:strs)
| take 3 str /= "--$" || '=' `notElem` drop 3 str
= f (str:acc_n) acc_y strs
| otherwise
= let varname = takeWhile (/= '=') (drop 3 str)
value = drop (4 + length varname) str
in
f acc_n ((varname,value):acc_y) strs
getBinds args = f args [] []
where
f [] binds rest = (reverse rest, reverse binds)
f (arg:args) binds rest
| isJust maybe_bind = f args (fromJust maybe_bind:binds) rest
| otherwise = f args binds (arg:rest)
where
maybe_bind = is_bind (break (== '=') arg)
is_bind (var, '=':value) = Just (var,value)
is_bind str = Nothing
-- These vars have special meanings and may not be set from the
-- command line.
......@@ -371,19 +386,6 @@ special_var_names
= ["testfilename", "testdir", "conffilename", "confdir",
"tool", "testname"]
-- File reader/writer with exception catching.
maybe_readFile :: FilePath -> IO (Maybe String)
maybe_readFile fname
= catch (readFile fname >>= (return . Just))
(const (return Nothing))
maybe_writeFile :: FilePath -> String -> IO Bool
maybe_writeFile fname cts
= catch (writeFile fname cts >> (return True))
(const (return False))
-- (eg) "foo/bar/xyzzy.ext" --> ("foo/bar", "xyzzy", "ext")
--splitPathname3 full
-- = let (dir, base_and_ext) = splitPathname full
......
......@@ -23,7 +23,7 @@ boot:
@echo "Make boot is not needed here"
runtests: $(RUNTESTS_SRCS)
ghc-5.00.2 --make Main -o runtests -i -ibasicRxLib -package lang -cpp
ghc-5.00.2 -W -fno-warn-unused-matches --make Main -o runtests -ibasicRxLib -package lang -package util -cpp
clean:
/bin/rm -f runtests *.o *.hi basicRxLib/*.o basicRxLib/*.hi
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment