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 :: (must-not-fail) ( quot -- error/f failed? tested? )
 107     [ { } quot with-datastack drop f f ] [ t ] recover t ;
 108
 109 : experiment-title ( word -- string )
 110     "(" ?head drop ")" ?tail drop
 111     H{ { CHAR: - CHAR: \s } } substitute >title ;
 112
 113 MACRO: <experiment> ( word -- quot )
 114     [ stack-effect in>> length dup ]
 115     [ name>> experiment-title ] bi
 116     '[ _ ndup _ narray _ prefix ] ;
 117
 118 : experiment. ( seq -- )
 119     [ first write ": " write ]
 120     [ rest verbose-tests? get [ . ] [ short. ] if flush ] bi ;
 121
 122 :: experiment ( word: ( -- error/f failed? tested? ) line# -- )
 123     word <experiment> :> e
 124     silent-tests? get [ e experiment. ] unless
 125     word execute [
 126         [
 127             current-test-file get [
 128                 e current-test-file get line# notify-test-failed
 129             ] [ rethrow ] if
 130         ] [ drop ] if
 131     ] [ 2drop "Warning: test skipped!" print ] if ; inline
 132
 133 : parse-test ( accum word -- accum )
 134     literalize suffix!
 135     lexer get line>> suffix!
 136     \ experiment suffix! ; inline
 137
 138 <<
 139
 140 SYNTAX: TEST:
 141     scan-token
 142     [ create-word-in ]
 143     [ "(" ")" surround search '[ _ parse-test ] ] bi
 144     define-syntax ;
 145
 146 >>
 147
 148 : fake-unit-test ( quot -- test-failures )
 149     [
 150         "fake" current-test-file set
 151         V{ } clone test-failures set
 152         call
 153         test-failures get
 154     ] with-scope notify-error-observers ; inline
 155
 156 PRIVATE>
 157
 158 : run-test-file ( path -- )
 159     dup current-test-file [
 160         test-failures get current-test-file get +test-failure+ delete-file-errors
 161         '[ _ run-file ] [
 162             restartable-tests? get
 163             [ dup compute-restarts empty? not ] [ f ] if
 164             [ rethrow ] [ notify-test-file-failed ] if
 165         ] recover
 166     ] with-variable ;
 167
 168 SYMBOL: forget-tests?
 169
 170 <PRIVATE
 171
 172 : forget-tests ( files -- )
 173     forget-tests? get
 174     [ [ [ forget-source ] each ] with-compilation-unit ] [ drop ] if ;
 175
 176 : possible-long-unit-tests ( vocab nanos -- )
 177     long-unit-tests-threshold get [
 178         dupd > long-unit-tests-enabled? get not and [
 179             swap
 180             "Warning: possible long unit test for " write
 181             vocab-name write " - " write
 182             1,000,000,000 /f pprint " seconds" print
 183         ] [ 2drop ] if
 184     ] [ 2drop ] if* ;
 185
 186 : test-vocab ( vocab -- )
 187     lookup-vocab [
 188         dup source-loaded?>> [
 189             dup vocab-tests [
 190                 [ [ run-test-file ] each ]
 191                 [ forget-tests ]
 192                 bi
 193             ] benchmark possible-long-unit-tests
 194         ] [ drop ] if
 195     ] when* ;
 196
 197 : test-vocabs ( vocabs -- )
 198     [ don't-test? ] reject [ test-vocab ] each ;
 199
 200 PRIVATE>
 201
 202 : with-test-file ( ..a quot: ( ..a path -- ..b ) -- ..b )
 203     '[ "" "" _ cleanup-unique-file ] with-temp-directory ; inline
 204
 205 : with-test-directory ( ..a quot: ( ..a -- ..b ) -- ..b )
 206     [ cleanup-unique-directory ] with-temp-directory ; inline
 207
 208 TEST: unit-test
 209 TEST: unit-test~
 210 TEST: unit-test-v~
 211 TEST: unit-test-comparator
 212 TEST: long-unit-test
 213 TEST: must-infer-as
 214 TEST: must-infer
 215 TEST: must-fail-with
 216 TEST: must-fail
 217 TEST: must-not-fail
 218
 219 M: test-failure error. ( error -- )
 220     {
 221         [ error-location print nl ]
 222         [ asset>> [ experiment. nl ] when* ]
 223         [ error>> error. ]
 224         [ continuation>> call>> callstack. ]
 225     } cleave ;
 226
 227 : :test-failures ( -- ) test-failures get errors. ;
 228
 229 : test ( prefix -- ) loaded-child-vocab-names test-vocabs ;
 230
 231 : test-all ( -- ) "" test ;
 232
 233 : refresh-and-test ( prefix --  ) to-refresh [ do-refresh ] keepdd test-vocabs ;
 234
 235 : refresh-and-test-all ( -- ) "" refresh-and-test ;
 236
 237 : test-main ( -- )
 238     command-line get
 239     "--fast" swap [ member? ] [ remove ] 2bi swap
 240     [ f long-unit-tests-enabled? set-global ] when
 241     [
 242         dup vocab-roots get member? [
 243             "" vocabs-to-load [ require-all ] keep
 244         ] [
 245             [ load ] [ loaded-child-vocab-names ] bi
 246         ] if test-vocabs
 247     ] each
 248     test-failures get empty?
 249     [ [ "==== FAILING TESTS" print flush :test-failures ] unless ]
 250     [ 0 1 ? exit ] bi ;
 251
 252 MAIN: test-main