basis/tools/test/test.factor

   1 ! Copyright (C) 2003, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors namespaces arrays prettyprint sequences kernel
   4 vectors quotations words parser assocs combinators continuations
   5 debugger io io.styles io.files vocabs vocabs.loader source-files
   6 compiler.units summary stack-checker effects tools.vocabs ;
   7 IN: tools.test
   8
   9 SYMBOL: failures
  10
  11 : <failure> ( error what -- triple )
  12     error-continuation get 3array ;
  13
  14 : failure ( error what -- )
  15     <failure> failures get push ;
  16
  17 SYMBOL: this-test
  18
  19 : (unit-test) ( what quot -- )
  20     swap dup . flush this-test set
  21     failures get [
  22         [ this-test get failure ] recover
  23     ] [
  24         call
  25     ] if ;
  26
  27 : unit-test ( output input -- )
  28     [ 2array ] 2keep [
  29         { } swap with-datastack swap >array assert=
  30     ] 2curry (unit-test) ;
  31
  32 : short-effect ( effect -- pair )
  33     [ in>> length ] [ out>> length ] bi 2array ;
  34
  35 : must-infer-as ( effect quot -- )
  36     >r 1quotation r> [ infer short-effect ] curry unit-test ;
  37
  38 : must-infer ( word/quot -- )
  39     dup word? [ 1quotation ] when
  40     [ infer drop ] curry [ ] swap unit-test ;
  41
  42 : must-fail-with ( quot pred -- )
  43     >r [ f ] compose r>
  44     [ recover ] 2curry
  45     [ t ] swap unit-test ;
  46
  47 : must-fail ( quot -- )
  48     [ drop t ] must-fail-with ;
  49
  50 : (run-test) ( vocab -- )
  51     dup vocab-source-loaded? [
  52         vocab-tests [ run-file ] each
  53     ] [ drop ] if ;
  54
  55 : run-test ( vocab -- failures )
  56     V{ } clone [
  57         failures [
  58             [ (run-test) ] [ swap failure ] recover
  59         ] with-variable
  60     ] keep ;
  61
  62 : failure. ( triple -- )
  63     dup second .
  64     dup first print-error
  65     "Traceback" swap third write-object ;
  66
  67 : test-failures. ( assoc -- )
  68     [
  69         nl
  70         [
  71             "==== ALL TESTS PASSED" print
  72         ] [
  73             "==== FAILING TESTS:" print
  74             [
  75                 swap vocab-heading.
  76                 [ failure. nl ] each
  77             ] assoc-each
  78         ] if-empty
  79     ] [
  80         "==== NOTHING TO TEST" print
  81     ] if* ;
  82
  83 : run-tests ( prefix -- failures )
  84     child-vocabs [ f ] [
  85         [ dup run-test ] { } map>assoc
  86         [ second empty? not ] filter
  87     ] if-empty ;
  88
  89 : test ( prefix -- )
  90     run-tests test-failures. ;
  91
  92 : run-all-tests ( prefix -- failures )
  93     "" run-tests ;
  94
  95 : test-all ( -- )
  96     run-all-tests test-failures. ;