tools.test: use source-files.errors
Slava Pestov
parent
7adb76aaf4
commit
e5c28dfa95
|
|
@ -1,95 +1,146 @@
|
||||||
! Copyright (C) 2003, 2008 Slava Pestov.
|
! Copyright (C) 2003, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors namespaces arrays prettyprint sequences kernel
|
USING: accessors arrays assocs combinators compiler.units
|
||||||
vectors quotations words parser assocs combinators continuations
|
continuations debugger effects fry generalizations io io.files
|
||||||
debugger io io.styles io.files vocabs vocabs.loader source-files
|
io.styles kernel lexer locals macros math.parser namespaces
|
||||||
compiler.units summary stack-checker effects tools.vocabs fry ;
|
parser prettyprint quotations sequences source-files splitting
|
||||||
|
stack-checker summary unicode.case vectors vocabs vocabs.loader words
|
||||||
|
tools.vocabs tools.errors source-files.errors io.streams.string make ;
|
||||||
IN: tools.test
|
IN: tools.test
|
||||||
|
|
||||||
SYMBOL: failures
|
TUPLE: test-failure < source-file-error experiment continuation ;
|
||||||
|
|
||||||
: <failure> ( error what -- triple )
|
SYMBOL: passed-tests
|
||||||
error-continuation get 3array ;
|
SYMBOL: failed-tests
|
||||||
|
|
||||||
: failure ( error what -- )
|
<PRIVATE
|
||||||
|
|
||||||
|
: <test-failure> ( error experiment file line# -- triple )
|
||||||
|
test-failure new
|
||||||
|
swap >>line#
|
||||||
|
swap >>file
|
||||||
|
swap >>experiment
|
||||||
|
swap >>error
|
||||||
|
error-continuation get >>continuation ;
|
||||||
|
|
||||||
|
: failure ( error experiment file line# -- )
|
||||||
"--> test failed!" print
|
"--> test failed!" print
|
||||||
<failure> failures get push ;
|
<test-failure> failed-tests get push ;
|
||||||
|
|
||||||
SYMBOL: this-test
|
: success ( experiment -- ) passed-tests get push ;
|
||||||
|
|
||||||
: (unit-test) ( what quot -- )
|
: file-failure ( error file -- )
|
||||||
swap dup . flush this-test set
|
[ f ] [ f ] bi* failure ;
|
||||||
failures get [
|
|
||||||
[ this-test get failure ] recover
|
|
||||||
] [
|
|
||||||
call
|
|
||||||
] if ; inline
|
|
||||||
|
|
||||||
: unit-test ( output input -- )
|
:: (unit-test) ( output input -- error ? )
|
||||||
[ 2array ] 2keep '[
|
[ { } input with-datastack output assert-sequence= f f ] [ t ] recover ; inline
|
||||||
_ { } _ with-datastack swap >array assert=
|
|
||||||
] (unit-test) ;
|
|
||||||
|
|
||||||
: 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 -- )
|
:: (must-infer-as) ( effect quot -- error ? )
|
||||||
[ 1quotation ] dip '[ _ infer short-effect ] unit-test ;
|
[ quot infer short-effect effect assert= f f ] [ t ] recover ; inline
|
||||||
|
|
||||||
: must-infer ( word/quot -- )
|
:: (must-infer) ( word/quot -- error ? )
|
||||||
dup word? [ 1quotation ] when
|
word/quot dup word? [ '[ _ execute ] ] when :> quot
|
||||||
'[ _ infer drop ] [ ] swap unit-test ;
|
[ quot infer drop f f ] [ t ] recover ; inline
|
||||||
|
|
||||||
: must-fail-with ( quot pred -- )
|
SINGLETON: did-not-fail
|
||||||
[ '[ @ f ] ] dip '[ _ _ recover ] [ t ] swap unit-test ;
|
|
||||||
|
|
||||||
: must-fail ( quot -- )
|
M: did-not-fail summary drop "Did not fail" ;
|
||||||
[ drop t ] must-fail-with ;
|
|
||||||
|
|
||||||
: (run-test) ( vocab -- )
|
:: (must-fail-with) ( quot pred -- error ? )
|
||||||
|
[ quot call did-not-fail t ]
|
||||||
|
[ dup pred call [ drop f f ] [ t ] if ] recover ; inline
|
||||||
|
|
||||||
|
:: (must-fail) ( quot -- error ? )
|
||||||
|
[ quot call did-not-fail t ] [ drop f f ] recover ; inline
|
||||||
|
|
||||||
|
: experiment-title ( word -- string )
|
||||||
|
"(" ?head drop ")" ?tail drop { { CHAR: - CHAR: \s } } substitute >title ;
|
||||||
|
|
||||||
|
MACRO: <experiment> ( word -- )
|
||||||
|
[ stack-effect in>> length dup ]
|
||||||
|
[ name>> experiment-title ] bi
|
||||||
|
'[ _ ndup _ narray _ prefix ] ;
|
||||||
|
|
||||||
|
: experiment. ( seq -- )
|
||||||
|
[ first write ": " write ] [ rest . ] bi ;
|
||||||
|
|
||||||
|
:: experiment ( word: ( -- error ? ) file line# -- )
|
||||||
|
word <experiment> :> e
|
||||||
|
e experiment.
|
||||||
|
word execute [ e file line# failure ] [ drop e success ] if ; inline
|
||||||
|
|
||||||
|
: parse-test ( accum word -- accum )
|
||||||
|
literalize parsed
|
||||||
|
file get dup [ path>> ] when parsed
|
||||||
|
lexer get line>> parsed
|
||||||
|
\ experiment parsed ; inline
|
||||||
|
|
||||||
|
<<
|
||||||
|
|
||||||
|
SYNTAX: TEST:
|
||||||
|
scan
|
||||||
|
[ create-in ]
|
||||||
|
[ "(" ")" surround search '[ _ parse-test ] ] bi
|
||||||
|
define-syntax ;
|
||||||
|
|
||||||
|
>>
|
||||||
|
|
||||||
|
: run-test-file ( path -- )
|
||||||
|
[ run-file ] [ swap file-failure ] recover ;
|
||||||
|
|
||||||
|
: collect-results ( quot -- failed passed )
|
||||||
|
[
|
||||||
|
V{ } clone failed-tests set
|
||||||
|
V{ } clone passed-tests set
|
||||||
|
call
|
||||||
|
failed-tests get
|
||||||
|
passed-tests get
|
||||||
|
] with-scope ; inline
|
||||||
|
|
||||||
|
: run-vocab-tests ( vocab -- )
|
||||||
dup vocab source-loaded?>> [
|
dup vocab source-loaded?>> [
|
||||||
vocab-tests [ run-file ] each
|
vocab-tests [ run-test-file ] each
|
||||||
] [ drop ] if ;
|
] [ drop ] if ;
|
||||||
|
|
||||||
: run-test ( vocab -- failures )
|
: traceback-button. ( failure -- )
|
||||||
V{ } clone [
|
"[" write [ "Traceback" ] dip continuation>> write-object "]" print ;
|
||||||
failures [
|
|
||||||
[ (run-test) ] [ swap failure ] recover
|
|
||||||
] with-variable
|
|
||||||
] keep ;
|
|
||||||
|
|
||||||
: failure. ( triple -- )
|
PRIVATE>
|
||||||
dup second .
|
|
||||||
dup first print-error
|
|
||||||
"Traceback" swap third write-object ;
|
|
||||||
|
|
||||||
: test-failures. ( assoc -- )
|
TEST: unit-test
|
||||||
|
TEST: must-infer-as
|
||||||
|
TEST: must-infer
|
||||||
|
TEST: must-fail-with
|
||||||
|
TEST: must-fail
|
||||||
|
|
||||||
|
M: test-failure summary
|
||||||
|
[ experiment>> experiment. ] with-string-writer ;
|
||||||
|
|
||||||
|
M: test-failure error. ( error -- )
|
||||||
|
[ call-next-method ]
|
||||||
|
[ traceback-button. ]
|
||||||
|
bi ;
|
||||||
|
|
||||||
|
: results. ( failed passed -- )
|
||||||
[
|
[
|
||||||
nl
|
|
||||||
[
|
[
|
||||||
"==== ALL TESTS PASSED" print
|
[ length # " tests failed, " % ]
|
||||||
] [
|
[ length # " tests passed." % ]
|
||||||
"==== FAILING TESTS:" print
|
bi*
|
||||||
[
|
] "" make print nl
|
||||||
swap vocab-heading.
|
] [ drop errors. ] 2bi ;
|
||||||
[ failure. nl ] each
|
|
||||||
] assoc-each
|
|
||||||
] if-empty
|
|
||||||
] [
|
|
||||||
"==== NOTHING TO TEST" print
|
|
||||||
] if* ;
|
|
||||||
|
|
||||||
: run-tests ( prefix -- failures )
|
: run-tests ( prefix -- failed passed )
|
||||||
child-vocabs [ f ] [
|
[ child-vocabs [ run-vocab-tests ] each ] collect-results ;
|
||||||
[ dup run-test ] { } map>assoc
|
|
||||||
[ second empty? not ] filter
|
|
||||||
] if-empty ;
|
|
||||||
|
|
||||||
: test ( prefix -- )
|
: test ( prefix -- )
|
||||||
run-tests test-failures. ;
|
run-tests results. ;
|
||||||
|
|
||||||
: run-all-tests ( -- failures )
|
: run-all-tests ( -- failed passed )
|
||||||
"" run-tests ;
|
"" run-tests ;
|
||||||
|
|
||||||
: test-all ( -- )
|
: test-all ( -- )
|
||||||
run-all-tests test-failures. ;
|
run-all-tests results. ;
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue