steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

tools.test: add MUST-FAIL: and MUST-FAIL-WITH:, still need named versions of these

modern-harvey3-triple
Doug Coleman 2018-08-10 08:53:40 -05:00
parent 3f0f387cbe
commit 9df90f9c87
1 changed files with 56 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
basis/tools/test/test.factor
View File

@ -104,6 +104,12 @@ MACRO: <experiment> ( word -- quot )
[ name>> experiment-title ] bi
'[ _ ndup _ narray _ prefix ] ;
TUPLE: must-fail-test-passed error test path line# ;
CONSTRUCTOR: <must-fail-test-passed> must-fail-test-passed ( error test path line# -- obj ) ;
TUPLE: must-fail-with-test-passed error test fail path line# ;
CONSTRUCTOR: <must-fail-with-test-passed> must-fail-with-test-passed ( error test fail path line# -- obj ) ;
TUPLE: new-unit-test-failed error test expected path line# ;
TUPLE: new-experiment test expected ;
@ -113,6 +119,19 @@ TUPLE: new-experiment test expected ;
swap >>expected
swap >>test ; inline
TUPLE: must-fail-experiment test ;
: <must-fail-experiment> ( test -- must-fail-experiment )
must-fail-experiment new
swap >>test ; inline
TUPLE: must-fail-with-experiment test fail ;
: <must-fail-with-experiment> ( test fail -- must-fail-with-experiment )
must-fail-with-experiment new
swap >>fail
swap >>test ; inline
: new-unit-test-failed>experiment ( new-unit-test-failed -- new-experiment )
[ test>> ] [ expected>> ] bi <new-experiment> ;
@ -122,11 +141,20 @@ M: array experiment. ( seq -- )
[ first write ": " write ]
[ rest verbose-tests? get [ . ] [ short. ] if flush ] bi ;
M: new-experiment experiment. ( seq -- )
M: new-experiment experiment. ( experiment -- )
"UNIT-TEST: " write
[ test>> verbose-tests? get [ pprint ] [ pprint-short ] if flush bl ]
[ expected>> verbose-tests? get [ pprint ] [ pprint-short ] if nl flush ] bi ;
M: must-fail-experiment experiment. ( experiment -- )
"MUST-FAIL: " write
test>> verbose-tests? get [ pprint ] [ pprint-short ] if nl flush ;
M: must-fail-with-experiment experiment. ( experiment -- )
"MUST-FAIL-WITH: " write
[ test>> verbose-tests? get [ pprint ] [ pprint-short ] if bl ]
[ fail>> verbose-tests? get [ pprint ] [ pprint-short ] if ] bi nl flush ;
:: experiment ( word: ( -- error/f failed? tested? ) line# -- )
word <experiment> :> e
e experiment.
@ -211,6 +239,33 @@ TEST: must-infer
TEST: must-fail-with
TEST: must-fail
SYNTAX: \MUST-FAIL:
scan-object dup dup
current-test-file get
lexer get line>>
'[
_ <must-fail-experiment> experiment.
[ { } _ with-datastack drop "must fail but didn't" _ _ _ <must-fail-test-passed> throw ]
[ dup must-fail-test-passed? [ rethrow ] [ drop ] if ] recover
] append! ;
SYNTAX: \MUST-FAIL-WITH:
scan-object scan-object over 2over
current-test-file get
lexer get line>>
pick
'[
_ _ <must-fail-with-experiment> experiment.
[ { } _ with-datastack drop "must fail with but didn't" _ _ _ _ <must-fail-with-test-passed> throw ]
[
dup must-fail-with-test-passed? [
rethrow
] [
dup _ call( error -- ? ) [ drop ] [ rethrow ] if
] if
] recover
] append! ;
: notify-new-test-failed ( new-unit-test-failed -- )
{
[ error>> ]