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

tools.test: Add long-unit-test and refactor a bit.

char-rename
Doug Coleman 2017-06-04 12:30:51 -05:00
parent 06fd324379
commit be1175b3c5
1 changed files with 30 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -45,39 +45,44 @@ t restartable-tests? set-global
<PRIVATE <PRIVATE
: failure ( error experiment path line# -- ) : notify-test-failed ( error experiment path line# -- )
"--> test failed!" print "--> test failed!" print
<test-failure> test-failures get push <test-failure> test-failures get push
notify-error-observers ; notify-error-observers ;
SYMBOL: current-test-file SYMBOL: current-test-file
: file-failure ( error -- ) : notify-test-file-failed ( error -- )
[ f current-test-file get ] keep error-line failure ; [ f current-test-file get ] keep error-line notify-test-failed ;
:: (unit-test) ( output input -- error ? ) :: (unit-test) ( output input -- error/f failed? tested? )
[ { } input with-datastack output assert-sequence= f f ] [ t ] recover ; [ { } input with-datastack output assert-sequence= f f ] [ t ] recover t ;
SYMBOL: long-unit-tests-enabled?
long-unit-tests-enabled? [ t ] initialize
: (long-unit-test) ( output input -- error/f failed? tested? )
long-unit-tests-enabled? get [ (unit-test) ] [ 2drop f f f ] if ;
: short-effect ( effect -- pair ) : short-effect ( effect -- pair )
[ in>> length ] [ out>> length ] bi 2array ; [ in>> length ] [ out>> length ] bi 2array ;
:: (must-infer-as) ( effect quot -- error ? ) :: (must-infer-as) ( effect quot -- error/f failed? tested? )
[ quot infer short-effect effect assert= f f ] [ t ] recover ; [ quot infer short-effect effect assert= f f ] [ t ] recover t ;
:: (must-infer) ( quot -- error ? ) :: (must-infer) ( quot -- error/f failed? tested? )
[ quot infer drop f f ] [ t ] recover ; [ quot infer drop f f ] [ t ] recover t ;
TUPLE: did-not-fail ; SINGLETON: did-not-fail
CONSTANT: did-not-fail-literal T{ did-not-fail }
M: did-not-fail summary drop "Did not fail" ; M: did-not-fail summary drop "Did not fail" ;
:: (must-fail-with) ( quot pred -- error ? ) :: (must-fail-with) ( quot pred -- error/f failed? tested? )
[ { } quot with-datastack drop did-not-fail-literal t ] [ { } quot with-datastack drop did-not-fail t ]
[ dup pred call( error -- ? ) [ drop f f ] [ t ] if ] recover ; [ dup pred call( error -- ? ) [ drop f f ] [ t ] if ] recover t ;
:: (must-fail) ( quot -- error ? ) :: (must-fail) ( quot -- error/f failed? tested? )
[ { } quot with-datastack drop did-not-fail-literal t ] [ drop f f ] recover ; [ { } quot with-datastack drop did-not-fail t ] [ drop f f ] recover t ;
: experiment-title ( word -- string ) : experiment-title ( word -- string )
"(" ?head drop ")" ?tail drop "(" ?head drop ")" ?tail drop
@ -92,14 +97,16 @@ MACRO: <experiment> ( word -- quot )
[ first write ": " write ] [ first write ": " write ]
[ rest verbose-tests? get [ . ] [ short. ] if flush ] bi ; [ rest verbose-tests? get [ . ] [ short. ] if flush ] bi ;
:: experiment ( word: ( -- error ? ) line# -- ) :: experiment ( word: ( -- error/f failed? tested? ) line# -- )
word <experiment> :> e word <experiment> :> e
e experiment. e experiment.
word execute [ word execute [
current-test-file get [ [
e current-test-file get line# failure current-test-file get [
] [ rethrow ] if e current-test-file get line# notify-test-failed
] [ drop ] if ; inline ] [ rethrow ] if
] [ drop ] if
] [ 2drop "Warning: test skipped!" print ] if ; inline
: parse-test ( accum word -- accum ) : parse-test ( accum word -- accum )
literalize suffix! literalize suffix!
@ -132,7 +139,7 @@ PRIVATE>
'[ _ run-file ] [ '[ _ run-file ] [
restartable-tests? get restartable-tests? get
[ dup compute-restarts empty? not ] [ f ] if [ dup compute-restarts empty? not ] [ f ] if
[ rethrow ] [ file-failure ] if [ rethrow ] [ notify-test-file-failed ] if
] recover ] recover
] with-variable ; ] with-variable ;
@ -165,6 +172,7 @@ PRIVATE>
[ cleanup-unique-directory ] with-temp-directory ; inline [ cleanup-unique-directory ] with-temp-directory ; inline
TEST: unit-test TEST: unit-test
TEST: long-unit-test
TEST: must-infer-as TEST: must-infer-as
TEST: must-infer TEST: must-infer
TEST: must-fail-with TEST: must-fail-with