Verified Commit 69d2a5f4 authored by Camil Staps's avatar Camil Staps 🚀

Implement --option

parent 15dd3631
......@@ -5,9 +5,13 @@ import StdList
import StdString
import StdTuple
import Control.Monad => qualified join
import Data.Error
from Data.Func import $
import Data.Generics.GenParse
import Data.Generics.GenPrint
import Data.List
import Data.Tuple
import System.CommandLine
import System.Options
import Testing.Options
......@@ -38,27 +42,26 @@ where
getOptions (EP p) = getOptions p
exposeProperties :: ![Testoption] ![a] !*World -> *World | TestableWithOptions a
exposeProperties testopts ps w
exposeProperties globopts ps w
# ([_:opts], w) = getCommandLine w
# opts = parseOptions testOptionDescription opts gDefault{|*|}
# opts = parseOptions optionDescription opts gDefault{|*|}
| isError opts = error (join "\n" $ fromError opts) w
# opts = fromOk opts
# (io,w) = stdio w
| opts.list
| opts.test_options.list
# io = foldl (<<<) io [testname p +++ "\n" \\ p <- ps]
# (_,w) = fclose io w
= w
# ps = case opts.runs of
[] -> ps
rs -> filter (\p -> isMember (testname p) runnames) ps
with runnames = [r.TestRun.name \\ r <- rs]
# ps = filter (\p -> not (isMember (testname p) opts.skip)) ps
# io = foldl (<<<) io $ concatMap test ps
# ps = case opts.test_options.runs of
[] -> map (tuple []) ps
rs -> [(map (fromOk o parseOpt) r.options, p) \\ p <- ps, r <- rs | 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
# (_,w) = fclose io w
= w
where
test :: a -> [String] | TestableWithOptions a
test p = Test (getOptions p ++ testopts) p
test :: ![Testoption] !a -> [String] | TestableWithOptions a
test useropts p = Test (getOptions p ++ useropts ++ globopts) p
error :: !String !*World -> *World
error s w
......@@ -67,3 +70,48 @@ where
# (_,w) = fclose io w
# w = setReturnCode 1 w
= w
optionDescription :: Option Options
optionDescription = WithHelp True $ Options
[ Shorthand "-O" "--option" $ Option
"--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]}
rs -> let r = last rs in
Ok {opts & test_options.runs=init rs ++ [{r & options=r.options ++ [printToString opt]}]})
"OPT"
"Add OPT to the options of the previously added test"
, 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"
"Run test NAME"
, 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 =
{ test_options :: !TestOptions
, global_options :: ![Testoption]
}
derive gDefault Options, Testoption, GenType
derive gParse Testoption, GenType
derive gPrint Testoption, GenType
parseOpt :: !String -> MaybeError [String] Testoption
parseOpt s = case parseString s of
Nothing -> Error ["Could not parse '" +++ s +++ "' as test option"]
Just o -> Ok o
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