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 generalizations io
   5 io.files.temp io.files.unique kernel lexer math math.functions
   6 math.vectors namespaces parser prettyprint quotations sequences
   7 sequences.generalizations source-files source-files.errors
   8 source-files.errors.debugger splitting stack-checker summary
   9 system tools.errors tools.time unicode vocabs vocabs.files
  10 vocabs.hierarchy vocabs.hierarchy.private vocabs.loader
  11 vocabs.metadata vocabs.parser vocabs.refresh words ;
  12 IN: tools.test
  13
  14 TUPLE: test-failure < source-file-error continuation ;
  15
  16 SYMBOL: +test-failure+
  17
  18 M: test-failure error-type drop +test-failure+ ;
  19
  20 SYMBOL: test-failures
  21
  22 test-failures [ V{ } clone ] initialize
  23
  24 T{ error-type-holder
  25    { type +test-failure+ }
  26    { word ":test-failures" }
  27    { plural "unit test failures" }
  28    { icon "vocab:ui/tools/error-list/icons/unit-test-error.png" }
  29    { quot [ test-failures get ] }
  30 } define-error-type
  31
  32 SYMBOL: silent-tests?
  33 f silent-tests? set-global
  34
  35 SYMBOL: verbose-tests?
  36 t verbose-tests? set-global
  37
  38 SYMBOL: restartable-tests?
  39 t restartable-tests? set-global
  40
  41 : <test-failure> ( error experiment path line# -- test-failure )
  42     test-failure new
  43         swap >>line#
  44         swap >>path
  45         swap >>asset
  46         swap >>error
  47         error-continuation get >>continuation ;
  48
  49 SYMBOL: long-unit-tests-threshold
  50 long-unit-tests-threshold [ 10,000,000,000 ] initialize
  51
  52 SYMBOL: long-unit-tests-enabled?
  53 long-unit-tests-enabled? [ t ] initialize
  54
  55 <PRIVATE
  56
  57 : notify-test-failed ( error experiment path line# -- )
  58     "--> test failed!" print
  59     <test-failure> test-failures get push
  60     notify-error-observers ;
  61
  62 SYMBOL: current-test-file
  63
  64 : notify-test-file-failed ( error -- )
  65     [ f current-test-file get ] keep error-line notify-test-failed ;
  66
  67 :: (unit-test) ( output input -- error/f failed? tested? )
  68     [ { } input with-datastack output assert-sequence= f f ] [ t ] recover t ;
  69
  70 : (long-unit-test) ( output input -- error/f failed? tested? )
  71     long-unit-tests-enabled? get [ (unit-test) ] [ 2drop f f f ] if ;
  72
  73 : (unit-test-comparator) ( output input comparator -- error/f failed? tested? )
  74     swapd '[
  75         { } _ with-datastack _ >quotation
  76         [ 3dup @ [ 3drop t ] [ drop assert ] if ] compose
  77         with-datastack first dup not
  78     ] [ t ] recover t ; inline
  79
  80 : (unit-test~) ( output input -- error/f failed? tested? )
  81     [ ~ ] (unit-test-comparator) ;
  82
  83 : (unit-test-v~) ( output input -- error/f failed? tested? )
  84     [ v~ ] (unit-test-comparator) ;
  85
  86 : short-effect ( effect -- pair )
  87     [ in>> length ] [ out>> length ] bi 2array ;
  88
  89 :: (must-infer-as) ( effect quot -- error/f failed? tested? )
  90     [ quot infer short-effect effect assert= f f ] [ t ] recover t ;
  91
  92 :: (must-infer) ( quot -- error/f failed? tested? )
  93     [ quot infer drop f f ] [ t ] recover t ;
  94
  95 SINGLETON: did-not-fail
  96
  97 M: did-not-fail summary drop "Did not fail" ;
  98
  99 :: (must-fail-with) ( quot pred -- error/f failed? tested? )
 100     [ { } quot with-datastack drop did-not-fail t ]
 101     [ dup pred call( error -- ? ) [ drop f f ] [ t ] if ] recover t ;
 102
 103 :: (must-fail) ( quot -- error/f failed? tested? )
 104     [ { } quot with-datastack drop did-not-fail t ] [ drop f f ] recover t ;
 105
 106 : experiment-title ( word -- string )
 107     "(" ?head drop ")" ?tail drop
 108     H{ { CHAR: - CHAR: \s } } substitute >title ;
 109
 110 MACRO: <experiment> ( word -- quot )
 111     [ stack-effect in>> length dup ]
 112     [ name>> experiment-title ] bi
 113     '[ _ ndup _ narray _ prefix ] ;
 114
 115 : experiment. ( seq -- )
 116     [ first write ": " write ]
 117     [ rest verbose-tests? get [ . ] [ short. ] if flush ] bi ;
 118
 119 :: experiment ( word: ( -- error/f failed? tested? ) line# -- )
 120     word <experiment> :> e
 121     silent-tests? get [ e experiment. ] unless
 122     word execute [
 123         [
 124             current-test-file get [
 125                 e current-test-file get line# notify-test-failed
 126             ] [ rethrow ] if
 127         ] [ drop ] if
 128     ] [ 2drop "Warning: test skipped!" print ] if ; inline
 129
 130 : parse-test ( accum word -- accum )
 131     literalize suffix!
 132     lexer get line>> suffix!
 133     \ experiment suffix! ; inline
 134
 135 <<
 136
 137 SYNTAX: TEST:
 138     scan-token
 139     [ create-word-in ]
 140     [ "(" ")" surround search '[ _ parse-test ] ] bi
 141     define-syntax ;
 142
 143 >>
 144
 145 : fake-unit-test ( quot -- test-failures )
 146     [
 147         "fake" current-test-file set
 148         V{ } clone test-failures set
 149         call
 150         test-failures get
 151     ] with-scope notify-error-observers ; inline
 152
 153 PRIVATE>
 154
 155 : run-test-file ( path -- )
 156     dup current-test-file [
 157         test-failures get current-test-file get +test-failure+ delete-file-errors
 158         '[ _ run-file ] [
 159             restartable-tests? get
 160             [ dup compute-restarts empty? not ] [ f ] if
 161             [ rethrow ] [ notify-test-file-failed ] if
 162         ] recover
 163     ] with-variable ;
 164
 165 SYMBOL: forget-tests?
 166
 167 <PRIVATE
 168
 169 : forget-tests ( files -- )
 170     forget-tests? get
 171     [ [ [ forget-source ] each ] with-compilation-unit ] [ drop ] if ;
 172
 173 : possible-long-unit-tests ( vocab nanos -- )
 174     long-unit-tests-threshold get [
 175         dupd > long-unit-tests-enabled? get not and [
 176             swap
 177             "Warning: possible long unit test for " write
 178             vocab-name write " - " write
 179             1,000,000,000 /f pprint " seconds" print
 180         ] [ 2drop ] if
 181     ] [ 2drop ] if* ;
 182
 183 : test-vocab ( vocab -- )
 184     lookup-vocab [
 185         dup source-loaded?>> [
 186             dup vocab-tests [
 187                 [ [ run-test-file ] each ]
 188                 [ forget-tests ]
 189                 bi
 190             ] benchmark possible-long-unit-tests
 191         ] [ drop ] if
 192     ] when* ;
 193
 194 : test-vocabs ( vocabs -- )
 195     [ don't-test? ] reject [ test-vocab ] each ;
 196
 197 PRIVATE>
 198
 199 : with-test-file ( ..a quot: ( ..a path -- ..b ) -- ..b )
 200     '[ "" "" _ cleanup-unique-file ] with-temp-directory ; inline
 201
 202 : with-test-directory ( ..a quot: ( ..a -- ..b ) -- ..b )
 203     [ cleanup-unique-directory ] with-temp-directory ; inline
 204
 205 TEST: unit-test
 206 TEST: unit-test~
 207 TEST: unit-test-v~
 208 TEST: unit-test-comparator
 209 TEST: long-unit-test
 210 TEST: must-infer-as
 211 TEST: must-infer
 212 TEST: must-fail-with
 213 TEST: must-fail
 214
 215 M: test-failure error. ( error -- )
 216     {
 217         [ error-location print nl ]
 218         [ asset>> [ experiment. nl ] when* ]
 219         [ error>> error. ]
 220         [ continuation>> call>> callstack. ]
 221     } cleave ;
 222
 223 : :test-failures ( -- ) test-failures get errors. ;
 224
 225 : test ( prefix -- ) loaded-child-vocab-names test-vocabs ;
 226
 227 : test-all ( -- ) "" test ;
 228
 229 : refresh-and-test ( prefix --  ) to-refresh [ do-refresh ] keepdd test-vocabs ;
 230
 231 : refresh-and-test-all ( -- ) "" refresh-and-test ;
 232
 233 : test-main ( -- )
 234     command-line get
 235     "--fast" swap [ member? ] [ remove ] 2bi swap
 236     [ f long-unit-tests-enabled? set-global ] when
 237     [
 238         dup vocab-roots get member? [
 239             "" vocabs-to-load [ require-all ] keep
 240         ] [
 241             [ load ] [ loaded-child-vocab-names ] bi
 242         ] if test-vocabs
 243     ] each
 244     test-failures get empty?
 245     [ [ "==== FAILING TESTS" print flush :test-failures ] unless ]
 246     [ 0 1 ? exit ] bi ;
 247
 248 MAIN: test-main