CommandLine.icl 6.05 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

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

import Gast

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

29
instance Testable (o1, o2, a) | Testable a
30
where
31 32
	evaluate (_,_,p) g a = evaluate p g a
	testname (_,_,p) = testname p
Camil Staps's avatar
Camil Staps committed
33
	testmodule (_,_,p) = testmodule p
34

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

instance Testable ExposedProperty
where
	evaluate (EP p) g a = evaluate p g a
	testname (EP p) = testname p
Camil Staps's avatar
Camil Staps committed
42
	testmodule (EP p) = testmodule p
43

44
instance getOptions ExposedProperty where getOptions (EP p) = getOptions p
45

46 47
exposeProperties :: ![PrintOption] ![Testoption] ![a] !*World -> *World | Testable, getOptions a
exposeProperties printopts globopts ps w
48
# ([_:opts], w) = getCommandLine w
Camil Staps's avatar
Camil Staps committed
49
# opts = parseOptions optionDescription opts gDefault{|*|}
50 51 52
| isError opts = error (join "\n" $ fromError opts) w
# opts = fromOk opts
# (io,w) = stdio w
Camil Staps's avatar
Camil Staps committed
53
| opts.test_options.list
54 55 56
	# io = foldl (<<<) io [testname p +++ "\n" \\ p <- ps]
	# (_,w) = fclose io w
	= w
Camil Staps's avatar
Camil Staps committed
57
# ps = case opts.test_options.runs of
58 59 60 61 62 63
	[] -> 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
64
# ps = filter (\p -> not (isMember (testname p) opts.test_options.skip)) ps
65
# (io,w) = seqSt (test opts.global_print_options opts.global_options) ps io w
66 67 68 69 70 71 72 73 74 75
# (_,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
76

77 78 79 80 81 82 83 84 85 86 87 88 89 90 91
	// 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
92
		# io = foldl (\io ev -> snd $ fflush $ io <<< ev) io $ printEvents pc [ge]
93
		# w = case ge of
Camil Staps's avatar
Camil Staps committed
94 95 96
			GE_TestFinished _ _ {resultType=CounterExpls _ _ _} _ _ -> setReturnCode 1 w
			GE_TestFinished _ _ {resultType=Undefined _}        _ _ -> setReturnCode 1 w
			_                                                       -> w
97 98 99
		= stream pc ges io w
		stream _  [] io w = (io,w)

Camil Staps's avatar
Camil Staps committed
100 101
	optionDescription :: Option Options
	optionDescription = WithHelp True $ Options
102 103 104
		[ 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
105
			, "Args N:             the maximum number of arguments to generate"
106 107 108 109 110
			, "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"
111
			, "- Concise N:        show a test counter for every N tests"
112 113 114 115
			, "- 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
116 117 118
			"--option"
			// When no runs are given yet, this gives global options
			(\opt opts -> parseOpt opt >>= \opt -> case opts.test_options.runs of
119 120 121
				[] -> 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
122
				rs -> let r = last rs in
123 124 125 126 127
					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
128
			"OPT"
129
			"Add OPT to the options of the previously added test, where OPT is one of:"
Camil Staps's avatar
Camil Staps committed
130 131 132 133 134 135 136
		, 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"
137
			"Run test NAME (see --list for a list of names)"
Camil Staps's avatar
Camil Staps committed
138 139 140 141 142 143 144 145 146 147 148 149 150
		, 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 =
151 152 153
	{ test_options         :: !TestOptions
	, global_options       :: ![Testoption]
	, global_print_options :: ![PrintOption]
Camil Staps's avatar
Camil Staps committed
154 155
	}

156 157 158
derive gDefault Options, Testoption, GenType, PrintOption
derive gParse Testoption, GenType, PrintOption
derive gPrint Testoption, GenType, PrintOption
Camil Staps's avatar
Camil Staps committed
159

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