Verified Commit 3e8420d5 authored by Camil Staps's avatar Camil Staps 🚀

Split print options and test options

parent b75001b9
......@@ -5,20 +5,17 @@ definition module Gast.CommandLine
* {{`Testing.Options`}}.
*/
from Gast.Testable import class Testable, :: Testoption
from Gast.Testable import class Testable, :: Testoption, :: PrintOption
/**
* This class extends TestableWithOptions with a member to get Testoptions.
*/
class getOptions a :: a -> [Testoption]
class getPrintOptions a :: a -> [PrintOption]
/**
* The default implemenetation of TestableWithOptions is to have no options.
*/
instance getOptions a
instance getPrintOptions a
instance Testable ([o], a) | Testable a
instance getOptions ([Testoption], a)
instance Testable (o1, o2, a) | Testable a
instance getOptions ([Testoption], a, b)
instance getPrintOptions (a, [PrintOption], b)
/**
* Wrap a TestableWithOptions in an existential type to easily build
......@@ -32,7 +29,8 @@ instance getOptions ExposedProperty
/**
* Expose a set of Gast properties as a CLI application.
*
* @param The print options
* @param The default options for all tests.
* @param The tests to expose.
*/
exposeProperties :: ![Testoption] ![a] !*World -> *World | Testable, getOptions a
exposeProperties :: ![PrintOption] ![Testoption] ![a] !*World -> *World | Testable, getOptions a
......@@ -6,6 +6,7 @@ import StdString
import StdTuple
import Control.Monad => qualified join
import Data.Either
import Data.Error
from Data.Func import $
import Text.GenParse
......@@ -20,13 +21,15 @@ import Text
import Gast
instance getOptions a where getOptions _ = []
instance getPrintOptions a where getPrintOptions _ = []
instance Testable ([o], a) | Testable a
instance Testable (o1, o2, a) | Testable a
where
evaluate (_,p) g a = evaluate p g a
testname (_,p) = testname p
evaluate (_,_,p) g a = evaluate p g a
testname (_,_,p) = testname p
instance getOptions ([Testoption], a) where getOptions (opts,_) = opts
instance getOptions ([Testoption], a, b) where getOptions (opts,_,_) = opts
instance getPrintOptions (a, [PrintOption], b) where getPrintOptions (_,opts,_) = opts
instance Testable ExposedProperty
where
......@@ -35,8 +38,8 @@ where
instance getOptions ExposedProperty where getOptions (EP p) = getOptions p
exposeProperties :: ![Testoption] ![a] !*World -> *World | Testable, getOptions a
exposeProperties globopts ps w
exposeProperties :: ![PrintOption] ![Testoption] ![a] !*World -> *World | Testable, getOptions a
exposeProperties printopts globopts ps w
# ([_:opts], w) = getCommandLine w
# opts = parseOptions optionDescription opts gDefault{|*|}
| isError opts = error (join "\n" $ fromError opts) w
......@@ -47,15 +50,20 @@ exposeProperties globopts ps w
# (_,w) = fclose io w
= w
# ps = case opts.test_options.runs of
[] -> map (tuple []) ps
rs -> [(map (fromOk o parseOpt) r.options, p) \\ r <- rs, p <- ps | r.TestRun.name == testname p]
[] -> 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]
# ps = filter (\p -> not (isMember (testname p) opts.test_options.skip)) ps
# io = foldl (<<<) io $ concatMap (test opts.global_options) ps
# io = foldl (<<<) io $ concatMap (test opts.global_print_options opts.global_options) ps
# (_,w) = fclose io w
= w
where
test :: ![Testoption] !a -> [String] | Testable, getOptions a
test useropts p = Test (globopts ++ useropts ++ getOptions p) p
test :: ![PrintOption] ![Testoption] !a -> [String] | Testable, getOptions a
test userprintopts useropts p = printEvents (toPrintConfig (printopts ++ userprintopts))
$ Test (globopts ++ useropts ++ getOptions p) p
error :: !String !*World -> *World
error s w
......@@ -84,9 +92,15 @@ where
"--option"
// When no runs are given yet, this gives global options
(\opt opts -> parseOpt opt >>= \opt -> case opts.test_options.runs of
[] -> Ok {opts & global_options=opts.global_options ++ [opt]}
[] -> 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]}
rs -> let r = last rs in
Ok {opts & test_options.runs=init rs ++ [{r & options=r.options ++ [printToString opt]}]})
Ok {opts & test_options.runs=init rs ++ [{r & options=r.options ++ [print opt]}]}
with
print (Left o) = printToString o
print (Right o) = printToString o
)
"OPT"
"Add OPT to the options of the previously added test, where OPT is one of:"
, Shorthand "-r" "--run" $ Option
......@@ -110,15 +124,18 @@ where
allnames = map testname ps
:: Options =
{ test_options :: !TestOptions
, global_options :: ![Testoption]
{ test_options :: !TestOptions
, global_options :: ![Testoption]
, global_print_options :: ![PrintOption]
}
derive gDefault Options, Testoption, GenType
derive gParse Testoption, GenType
derive gPrint Testoption, GenType
derive gDefault Options, Testoption, GenType, PrintOption
derive gParse Testoption, GenType, PrintOption
derive gPrint Testoption, GenType, PrintOption
parseOpt :: !String -> MaybeError [String] Testoption
parseOpt :: !String -> MaybeError [String] (Either Testoption PrintOption)
parseOpt s = case parseString s of
Nothing -> Error ["Could not parse '" +++ s +++ "' as test option"]
Just o -> Ok o
Just o -> Ok (Left o)
Nothing -> case parseString s of
Just o -> Ok (Right o)
Nothing -> Error ["Could not parse '" +++ s +++ "' as test option"]
......@@ -72,19 +72,14 @@ generateAll :: !GenState -> [a] | ggen{|*|} a //& genType{|*|} a
//--- testing --//
:: Testoption
= Tests Int
| Fails Int
| Args Int
| RandomSeed Int
| RandomList [Int]
| Skew Int
| MaxDepth Int
| Verbose
| Trace
| Concise Int //* The Int tells how often a test count should be displayed
| Quiet
| OutputTestEvents //* output test results as event specified in clean-platform {{Testing.TestEvents}}
| ArgTypes [GenType]
= Tests Int
| Fails Int
| Args Int
| RandomSeed Int
| RandomList [Int]
| Skew Int
| MaxDepth Int
| ArgTypes [GenType]
/**
* The combined results of all tests for a single property.
......@@ -123,8 +118,25 @@ generateAll :: !GenState -> [a] | ggen{|*|} a //& genType{|*|} a
| GE_CounterExample CounterExampleRes
| GE_Tick Int Admin
Test :: ![Testoption] !p -> [String] | Testable p
TestList :: [Testoption] ![p] -> [String] | Testable p
:: PrintOption
= Verbose
| Trace
| Concise Int //* The Int tells how often a test count should be displayed
| Quiet
| OutputTestEvents //* output test results as event specified in clean-platform {{Testing.TestEvents}}
:: PrintConfig =
{ everyOutput :: Int Admin -> String
, counterExampleOutput :: CounterExampleRes -> String
, beforeStartOutput :: String -> String
, resultOutput :: String TestsResult [CounterExampleRes] [(!String, !Int)] -> String
}
printEvents :: PrintConfig [GastEvent] -> [String]
toPrintConfig :: ([PrintOption] -> PrintConfig)
Test :: ![Testoption] !p -> [GastEvent] | Testable p
TestList :: ![Testoption] ![p] -> [GastEvent] | Testable p
verbose :: !RandomStream !p -> [String] | Testable p
verbosen :: !Int !RandomStream !p -> [String] | Testable p
......
......@@ -102,13 +102,6 @@ derive bimap [], (,), (,,), (,,,), (,,,,), (,,,,,)
, genState :: GenState
}
:: PrintConfig =
{ everyOutput :: Int Admin -> String
, counterExampleOutput :: CounterExampleRes -> String
, beforeStartOutput :: String -> String
, resultOutput :: String TestsResult [CounterExampleRes] [(!String, !Int)] -> String
}
printEvents :: PrintConfig [GastEvent] -> [String]
printEvents pc [ge:ges] = case s of
"" -> printEvents pc ges
......@@ -295,47 +288,41 @@ where
showName :: Bool String -> String
showName quoteName l = if quoteName ("\"" <+ l <+ "\" ") l
Test :: ![Testoption] !p -> [String] | Testable p
Test options p = printEvents printConfig (testConfig config.randoms {config & randoms = []} p)
toPrintConfig :: ([PrintOption] -> PrintConfig)
toPrintConfig = foldl handleOption verbosePrintConfig
where
(config, printConfig) = foldl handleOption (verboseConfig,verbosePrintConfig) options
handleOption (c,pc) (Tests i) = ({c & maxTests = i, maxArgs = 2*i}, pc)
handleOption (c,pc) (Fails i) = ({c & fails = i}, pc)
handleOption (c,pc) (Args i) = ({c & maxArgs = i}, pc)
handleOption (c,pc) (RandomSeed i) = ({c & randoms = genRandInt i}, pc)
handleOption (c,pc) (RandomList r) = ({c & randoms = r}, pc)
handleOption (c,pc) Verbose = (c, {pc & everyOutput = verboseEvery})
handleOption (c,pc) Trace = (c, {pc & everyOutput = traceEvery})
handleOption (c,pc) (Concise n) = (c, {pc & everyOutput = countEvery n})
handleOption (c,pc) Quiet = (c, {pc & everyOutput = noEveryOutput})
handleOption (c,pc) OutputTestEvents = (c,
handleOption pc Verbose = {pc & everyOutput = verboseEvery}
handleOption pc Trace = {pc & everyOutput = traceEvery}
handleOption pc (Concise n) = {pc & everyOutput = countEvery n}
handleOption pc Quiet = {pc & everyOutput = noEveryOutput}
handleOption pc OutputTestEvents =
{ pc
& everyOutput = noEveryOutput
, counterExampleOutput = noCounterExampleOutput
, resultOutput = jsonEventEnd
, beforeStartOutput = jsonEventStart
})
handleOption (c,pc) (MaxDepth i) = ({c & genState = {c.genState & maxDepth = i}},pc)
handleOption (c,pc) (Skew s)
| s > 0 = ({c & genState = {c.genState & skewl = 1, skewr = s}}, pc)
| s < 0 = ({c & genState = {c.genState & skewl = ~s, skewr = 1}}, pc)
| otherwise = ({c & genState = {c.genState & skewl = 1, skewr = 1}}, pc)
handleOption _ o = abort ("Test: unknown option \"" +++ show1 o +++ "\"\n")
}
derive genShow Testoption, GenType
/*
generic consName a :: a -> String
consName{|Int|} i = toString i
consName{|Bool|} b = toString b
consName{|Char|} c = toString c
consName{|Real|} r = toString r
consName{|OBJECT|} f (OBJECT o) = f o
consName{|CONS of gcd|} f c = gcd.gcd_name
derive consName Testoption
*/
TestList :: [Testoption] ![p] -> [String] | Testable p
Test :: ![Testoption] !p -> [GastEvent] | Testable p
Test options p = testConfig config.randoms {config & randoms = []} p
where
config = foldl handleOption verboseConfig options
handleOption c (Tests i) = {c & maxTests = i, maxArgs = 2*i}
handleOption c (Fails i) = {c & fails = i}
handleOption c (Args i) = {c & maxArgs = i}
handleOption c (RandomSeed i) = {c & randoms = genRandInt i}
handleOption c (RandomList r) = {c & randoms = r}
handleOption c (MaxDepth i) = {c & genState = {c.genState & maxDepth = i}}
handleOption c (Skew s)
| s > 0 = {c & genState = {c.genState & skewl = 1, skewr = s}}
| s < 0 = {c & genState = {c.genState & skewl = ~s, skewr = 1}}
| otherwise = {c & genState = {c.genState & skewl = 1, skewr = 1}}
handleOption _ o = abort ("Test: unknown option \"" +++ show1 o +++ "\"\n")
TestList :: ![Testoption] ![p] -> [GastEvent] | Testable p
TestList options ps = flatten (map (Test options) ps)
test :: !p -> [String] | Testable p
......
Markdown is supported
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