extra/tools/test/test.factor

   1 ! Copyright (C) 2003, 2007 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: namespaces arrays prettyprint sequences kernel
   4 vectors quotations words parser assocs combinators
   5 continuations debugger io io.files vocabs tools.time
   6 vocabs.loader source-files ;
   7 IN: tools.test
   8
   9 SYMBOL: failures
  10
  11 : <failure> ( error what -- triple )
  12     error-continuation get 3array ;
  13
  14 : failure ( error what -- ) <failure> failures get push ;
  15
  16 SYMBOL: this-test
  17
  18 : (unit-test) ( what quot -- )
  19     swap dup . flush this-test set
  20     [ time ] curry failures get [
  21         [
  22             this-test get <failure> failures get push
  23         ] recover
  24     ] [
  25         call
  26     ] if ;
  27
  28 : unit-test ( output input -- )
  29     [ 2array ] 2keep [
  30         { } swap with-datastack swap >array assert=
  31     ] 2curry (unit-test) ;
  32
  33 TUPLE: expected-error ;
  34
  35 : unit-test-fails ( quot -- )
  36     [ f ] append [ [ drop t ] recover ] curry
  37     [ t ] swap unit-test ;
  38
  39 : run-test ( path -- failures )
  40     "temporary" forget-vocab
  41     [
  42         V{ } clone [
  43             failures [
  44                 [ run-file ] [ swap failure ] recover
  45             ] with-variable
  46         ] keep
  47     ] keep forget-source ;
  48
  49 : failure. ( triple -- )
  50     dup second .
  51     dup first print-error
  52     "Traceback" swap third write-object ;
  53
  54 : failures. ( path failures -- )
  55     "Failing tests in " write swap <pathname> .
  56     [ nl failure. nl ] each ;
  57
  58 : run-tests ( seq -- )
  59     [ dup run-test ] { } map>assoc
  60     [ second empty? not ] subset
  61     dup empty? [ drop ] [
  62         nl
  63         "==== FAILING TESTS:" print
  64         [ nl failures. ] assoc-each
  65     ] if ;
  66
  67 : run-vocab-tests ( vocabs -- )
  68     [ vocab-tests-path ] map
  69     [ dup [ ?resource-path exists? ] when ] subset
  70     run-tests ;
  71
  72 : test ( prefix -- )
  73     child-vocabs
  74     [ vocab-source-loaded? ] subset
  75     run-vocab-tests ;
  76
  77 : test-all ( -- ) "" test ;
  78
  79 : test-changes ( -- ) "" (refresh) run-vocab-tests ;