CommandLine.icl 5.94 KB
Newer Older
1 2
implementation module Gast.CommandLine

3
import StdBool
4 5 6 7 8
from StdFunc import flip, o
import StdList
import StdString
import StdTuple

Camil Staps's avatar
Camil Staps committed
9
import Control.Monad => qualified join
10
import Data.Either
11 12
import Data.Error
from Data.Func import $
Camil Staps's avatar
Camil Staps committed
13 14
import Text.GenParse
import Text.GenPrint
15
import Data.List
Camil Staps's avatar
Camil Staps committed
16
import Data.Tuple
17 18
import System.CommandLine
import System.Options
19
import System.File
20 21 22 23 24
import Testing.Options
import Text

import Gast

25
instance getOptions a where getOptions _ = []
26
instance getPrintOptions a where getPrintOptions _ = []
27

28
instance Testable (o1, o2, a) | Testable a
29
where
30 31
	evaluate (_,_,p) g a = evaluate p g a
	testname (_,_,p) = testname p
32

33 34
instance getOptions ([Testoption], a, b) where getOptions (opts,_,_) = opts
instance getPrintOptions (a, [PrintOption], b) where getPrintOptions (_,opts,_) = opts
35 36 37 38 39 40

instance Testable ExposedProperty
where
	evaluate (EP p) g a = evaluate p g a
	testname (EP p) = testname p

41
instance getOptions ExposedProperty where getOptions (EP p) = getOptions p
42

43 44
exposeProperties :: ![PrintOption] ![Testoption] ![a] !*World -> *World | Testable, getOptions a
exposeProperties printopts globopts ps w
45
# ([_:opts], w) = getCommandLine w
Camil Staps's avatar
Camil Staps committed
46
# opts = parseOptions optionDescription opts gDefault{|*|}
47 48 49
| isError opts = error (join "\n" $ fromError opts) w
# opts = fromOk opts
# (io,w) = stdio w
Camil Staps's avatar
Camil Staps committed
50
| opts.test_options.list
51 52 53
	# io = foldl (<<<) io [testname p +++ "\n" \\ p <- ps]
	# (_,w) = fclose io w
	= w
Camil Staps's avatar
Camil Staps committed
54
# ps = case opts.test_options.runs of
55 56 57 58 59 60
	[] -> map (tuple3 [] []) ps
	rs -> [ let opts = map (fromOk o parseOpt) r.options in
		( [o \\ Left  o <- opts]
		, [o \\ Right o <- opts]
		, p
		) \\ r <- rs, p <- ps | r.TestRun.name == testname p]
Camil Staps's avatar
Camil Staps committed
61
# ps = filter (\p -> not (isMember (testname p) opts.test_options.skip)) ps
62
# (io,w) = seqSt (test opts.global_print_options opts.global_options) ps io w
63 64 65 66 67 68 69 70 71 72
# (_,w) = fclose io w
= w
where
	error :: !String !*World -> *World
	error s w
	# io = stderr
	# io = io <<< s <<< "\n"
	# (_,w) = fclose io w
	# w = setReturnCode 1 w
	= w
Camil Staps's avatar
Camil Staps committed
73

74 75 76 77 78 79 80 81 82 83 84 85 86 87 88
	// Specialized for the type of `test`
	seqSt :: !(a .st1 -> .(.st2 -> .(.st1,.st2))) ![a] !.st1 !.st2 -> .(!.st1, !.st2)
	seqSt f [x:xs] st1 st2
	# (st1,st2) = f x st1 st2
	# (st1,st2) = seqSt f xs st1 st2
	= (st1,st2)
	seqSt _ [] st1 st2 = (st1, st2)

	test :: ![PrintOption] ![Testoption] !p !*File !*World -> *(!*File, !*World) | getOptions, getPrintOptions, Testable p
	test popts opts p io w
	# events = Test (globopts ++ opts ++ getOptions p) p
	= stream (toPrintConfig (printopts ++ popts ++ getPrintOptions p)) events io w
	where
		stream :: !PrintConfig ![GastEvent] !*File !*World -> *(!*File, !*World)
		stream pc [ge:ges] io w
89
		# io = foldl (\io ev -> snd $ fflush $ io <<< ev) io $ printEvents pc [ge]
90 91 92 93 94 95 96
		# w = case ge of
			GE_TestFinished _ {resultType=CounterExpls _ _ _} _ _ -> setReturnCode 1 w
			GE_TestFinished _ {resultType=Undefined _}        _ _ -> setReturnCode 1 w
			_                                                     -> w
		= stream pc ges io w
		stream _  [] io w = (io,w)

Camil Staps's avatar
Camil Staps committed
97 98
	optionDescription :: Option Options
	optionDescription = WithHelp True $ Options
99 100 101
		[ Shorthand "-O" "--option" $ AddHelpLines
			[ "Tests N:            the maximum number of tests to run"
			, "Fails N:            the maximum number of failing test cases to collect"
Camil Staps's avatar
Camil Staps committed
102
			, "Args N:             the maximum number of arguments to generate"
103 104 105 106 107
			, "RandomSeed N:       a custom random seed"
			, "Skew N:             0 for symmetric test generation; positive for right-skewn generation; negative for left-skewn generation"
			, "MaxDepth N:         the maximum tree depth in generated test cases"
			, "Output options:"
			, "- Quiet:            only show the end result"
108
			, "- Concise N:        show a test counter for every N tests"
109 110 111 112
			, "- Verbose:          show every test case, then hide it again"
			, "- Trace:            show every test case"
			, "- OutputTestEvents: output JSON test events as in Testing.TestEvents"
			] $ Option
Camil Staps's avatar
Camil Staps committed
113 114 115
			"--option"
			// When no runs are given yet, this gives global options
			(\opt opts -> parseOpt opt >>= \opt -> case opts.test_options.runs of
116 117 118
				[] -> case opt of
					Left  o -> Ok {opts & global_options=opts.global_options ++ [o]}
					Right o -> Ok {opts & global_print_options=opts.global_print_options ++ [o]}
Camil Staps's avatar
Camil Staps committed
119
				rs -> let r = last rs in
120 121 122 123 124
					Ok {opts & test_options.runs=init rs ++ [{r & options=r.options ++ [print opt]}]}
				with
					print (Left o)  = printToString o
					print (Right o) = printToString o
			)
Camil Staps's avatar
Camil Staps committed
125
			"OPT"
126
			"Add OPT to the options of the previously added test, where OPT is one of:"
Camil Staps's avatar
Camil Staps committed
127 128 129 130 131 132 133
		, Shorthand "-r" "--run" $ Option
			"--run"
			// Remove tests previously added with the same name, to make it possible to add --run after --run-all
			(\r opts -> if (isMember r allnames)
				(Ok {opts & test_options.runs=[r` \\ r` <- opts.test_options.runs | r`.TestRun.name <> r]++ [{name=r, options=[]}]})
				(Error ["No test with the name '" +++ r +++ "' is known."]))
			"NAME"
134
			"Run test NAME (see --list for a list of names)"
Camil Staps's avatar
Camil Staps committed
135 136 137 138 139 140 141 142 143 144 145 146 147
		, Shorthand "-R" "--run-all" $ Flag
			"--run-all"
			// Only add those tests which do not exist yet in the runs list
			(\opts -> let existing = [r.TestRun.name \\ r <- opts.test_options.runs] in Ok
				{opts & test_options.runs=opts.test_options.runs
				++ [{name=r,options=[]} \\ r <- allnames | not (isMember r existing)]})
			"Run all tests (which have not been mentioned with --run yet)"
		, Biject (\r->r.test_options) (\old r -> {old & test_options=r}) testOptionDescription
		]
	where
		allnames = map testname ps

:: Options =
148 149 150
	{ test_options         :: !TestOptions
	, global_options       :: ![Testoption]
	, global_print_options :: ![PrintOption]
Camil Staps's avatar
Camil Staps committed
151 152
	}

153 154 155
derive gDefault Options, Testoption, GenType, PrintOption
derive gParse Testoption, GenType, PrintOption
derive gPrint Testoption, GenType, PrintOption
Camil Staps's avatar
Camil Staps committed
156

157
parseOpt :: !String -> MaybeError [String] (Either Testoption PrintOption)
Camil Staps's avatar
Camil Staps committed
158
parseOpt s = case parseString s of
159 160 161 162
	Just o  -> Ok (Left o)
	Nothing -> case parseString s of
		Just o  -> Ok (Right o)
		Nothing -> Error ["Could not parse '" +++ s +++ "' as test option"]