basis/tools/test/test.factor

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