basis/tools/test/test.factor

   1 ! Copyright (C) 2003, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators compiler.units
   4 continuations debugger effects fry generalizations io io.files
   5 io.styles kernel lexer locals macros math.parser namespaces parser
   6 vocabs.parser prettyprint quotations sequences source-files splitting
   7 stack-checker summary unicode.case vectors vocabs vocabs.loader
   8 vocabs.files words tools.errors source-files.errors io.streams.string
   9 make compiler.errors ;
  10 IN: tools.test
  11
  12 TUPLE: test-failure < source-file-error continuation ;
  13
  14 SYMBOL: +test-failure+
  15
  16 M: test-failure error-type drop +test-failure+ ;
  17
  18 SYMBOL: test-failures
  19
  20 test-failures [ V{ } clone ] initialize
  21
  22 T{ error-type
  23    { type +test-failure+ }
  24    { word ":test-failures" }
  25    { plural "unit test failures" }
  26    { icon "vocab:ui/tools/error-list/icons/unit-test-error.tiff" }
  27    { quot [ test-failures get ] }
  28 } define-error-type
  29
  30 SYMBOL: verbose-tests?
  31 t verbose-tests? set-global
  32
  33 <PRIVATE
  34
  35 : <test-failure> ( error experiment file line# -- triple )
  36     test-failure new
  37         swap >>line#
  38         swap >>file
  39         swap >>asset
  40         swap >>error
  41         error-continuation get >>continuation ;
  42
  43 : failure ( error experiment file line# -- )
  44     "--> test failed!" print
  45     <test-failure> test-failures get push
  46     notify-error-observers ;
  47
  48 SYMBOL: file
  49
  50 : file-failure ( error -- )
  51     [ f file get ] keep error-line failure ;
  52
  53 :: (unit-test) ( output input -- error ? )
  54     [ { } input with-datastack output assert-sequence= f f ] [ t ] recover ;
  55
  56 : short-effect ( effect -- pair )
  57     [ in>> length ] [ out>> length ] bi 2array ;
  58
  59 :: (must-infer-as) ( effect quot -- error ? )
  60     [ quot infer short-effect effect assert= f f ] [ t ] recover ;
  61
  62 :: (must-infer) ( quot -- error ? )
  63     [ quot infer drop f f ] [ t ] recover ;
  64
  65 TUPLE: did-not-fail ;
  66 CONSTANT: did-not-fail T{ did-not-fail }
  67
  68 M: did-not-fail summary drop "Did not fail" ;
  69
  70 :: (must-fail-with) ( quot pred -- error ? )
  71     [ { } quot with-datastack drop did-not-fail t ]
  72     [ dup pred call( error -- ? ) [ drop f f ] [ t ] if ] recover ;
  73
  74 :: (must-fail) ( quot -- error ? )
  75     [ { } quot with-datastack drop did-not-fail t ] [ drop f f ] recover ;
  76
  77 : experiment-title ( word -- string )
  78     "(" ?head drop ")" ?tail drop { { CHAR: - CHAR: \s } } substitute >title ;
  79
  80 MACRO: <experiment> ( word -- )
  81     [ stack-effect in>> length dup ]
  82     [ name>> experiment-title ] bi
  83     '[ _ ndup _ narray _ prefix ] ;
  84
  85 : experiment. ( seq -- )
  86     [ first write ": " write ]
  87     [ rest verbose-tests? get [ . ] [ short. ] if flush ] bi ;
  88
  89 :: experiment ( word: ( -- error ? ) line# -- )
  90     word <experiment> :> e
  91     e experiment.
  92     word execute [
  93         file get [
  94             e file get line# failure
  95         ] [ rethrow ] if
  96     ] [ drop ] if ; inline
  97
  98 : parse-test ( accum word -- accum )
  99     literalize suffix!
 100     lexer get line>> suffix!
 101     \ experiment suffix! ; inline
 102
 103 <<
 104
 105 SYNTAX: TEST:
 106     scan
 107     [ create-in ]
 108     [ "(" ")" surround search '[ _ parse-test ] ] bi
 109     define-syntax ;
 110
 111 >>
 112
 113 : run-test-file ( path -- )
 114     dup file [
 115         test-failures get file get +test-failure+ delete-file-errors
 116         '[ _ run-file ] [ file-failure ] recover
 117     ] with-variable ;
 118
 119 : run-vocab-tests ( vocab -- )
 120     dup vocab source-loaded?>> [
 121         vocab-tests [ run-test-file ] each
 122     ] [ drop ] if ;
 123
 124 : traceback-button. ( failure -- )
 125     "[" write [ "Traceback" ] dip continuation>> write-object "]" print ;
 126
 127 PRIVATE>
 128
 129 TEST: unit-test
 130 TEST: must-infer-as
 131 TEST: must-infer
 132 TEST: must-fail-with
 133 TEST: must-fail
 134
 135 M: test-failure error. ( error -- )
 136     {
 137         [ error-location print nl ]
 138         [ asset>> [ experiment. nl ] when* ]
 139         [ error>> error. ]
 140         [ traceback-button. ]
 141     } cleave ;
 142
 143 : :test-failures ( -- ) test-failures get errors. ;
 144
 145 : test ( prefix -- )
 146     child-vocabs [ run-vocab-tests ] each ;
 147
 148 : test-all ( -- ) "" test ;