extra/mason/test/test.factor

   1 ! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs benchmark bootstrap.stage2 command-line
   4 compiler.errors continuations debugger fry generic help.html
   5 help.lint io io.directories io.encodings.utf8 io.files io.styles
   6 kernel locals mason.common namespaces parser.notes sequences
   7 sets sorting source-files.errors system tools.errors tools.test
   8 tools.time vocabs vocabs.hierarchy.private vocabs.loader
   9 vocabs.refresh words ;
  10 IN: mason.test
  11
  12 : vocab-heading. ( vocab -- )
  13     nl
  14     "==== " write
  15     [ vocab-name ] [ lookup-vocab write-object ] bi ":" print
  16     nl ;
  17
  18 : load-error. ( triple -- )
  19     [ first vocab-heading. ] [ second print-error ] bi ;
  20
  21 : load-failures. ( failures -- ) [ load-error. nl ] each ;
  22
  23 : require-all-no-restarts ( vocabs -- failures )
  24     V{ } clone blacklist [
  25         V{ } clone [
  26             '[
  27                 [ require ]
  28                 [ swap vocab-name _ set-at ] recover
  29             ] each
  30         ] keep
  31     ] with-variable ;
  32
  33 : load-from-root-no-restarts ( root prefix -- failures )
  34     vocabs-to-load require-all-no-restarts ;
  35
  36 : load-no-restarts ( prefix -- failures )
  37     [ vocab-roots get ] dip
  38     '[ _ load-from-root-no-restarts ] map concat ;
  39
  40 : do-load ( -- )
  41     "" load-no-restarts
  42     [ keys load-all-vocabs-file to-file ]
  43     [ load-all-errors-file utf8 [ load-failures. ] with-file-writer ]
  44     bi ;
  45
  46 GENERIC: word-vocabulary ( word -- vocabulary )
  47
  48 M: word word-vocabulary vocabulary>> ;
  49
  50 M: method word-vocabulary "method-generic" word-prop word-vocabulary ;
  51
  52 :: do-step ( errors summary-file details-file -- )
  53     errors
  54     [ error-type +linkage-error+ eq? ] reject
  55     [ file>> ] map members natural-sort summary-file to-file
  56     errors details-file utf8 [ errors. ] with-file-writer ;
  57
  58 : do-tests ( -- )
  59     forget-tests? on
  60     test-all test-failures get
  61     test-all-vocabs-file
  62     test-all-errors-file
  63     do-step ;
  64
  65 : do-help-lint ( -- )
  66     help-lint-all lint-failures get values
  67     help-lint-vocabs-file
  68     help-lint-errors-file
  69     do-step ;
  70
  71 : do-benchmarks ( -- )
  72     run-timing-benchmarks
  73     [ benchmarks-file to-file ] [
  74         [ keys benchmark-error-vocabs-file to-file ]
  75         [ benchmark-error-messages-file utf8 [ benchmark-errors. ] with-file-writer ] bi
  76     ] bi* ;
  77
  78 : do-compile-errors ( -- )
  79     compiler-errors get values
  80     compiler-errors-file
  81     compiler-error-messages-file
  82     do-step ;
  83
  84 : outdated-core-vocabs ( -- modified-sources modified-docs any? )
  85     "" to-refresh drop 2dup [ empty? not ] either? ;
  86
  87 : outdated-boot-image. ( modified-sources modified-docs -- )
  88     "Boot image is out of date. Changed vocabs:" print
  89     union [ print ] each
  90     flush ;
  91
  92 : check-boot-image ( -- ? )
  93     outdated-core-vocabs [ outdated-boot-image. t ] [ 2drop f ] if ;
  94
  95 : run-mason-rc ( -- )
  96     t "user-init" [
  97         ".factor-mason-rc" rc-path try-user-init
  98     ] with-variable ;
  99
 100 : check-user-init-errors ( -- ? )
 101     user-init-errors get-global assoc-empty?
 102     [ f ] [ :user-init-errors t ] if ;
 103
 104 : do-all ( -- )
 105     f parser-quiet? set-global
 106     ".." [
 107         run-mason-rc check-user-init-errors [ 1 exit ] when
 108         bootstrap-time get boot-time-file to-file
 109         check-boot-image [ 1 exit ] when
 110         [ do-load ] benchmark load-time-file to-file
 111         [ generate-help ] benchmark html-help-time-file to-file
 112         [ do-tests ] benchmark test-time-file to-file
 113         [ do-help-lint ] benchmark help-lint-time-file to-file
 114         [ do-benchmarks ] benchmark benchmark-time-file to-file
 115         do-compile-errors
 116     ] with-directory ;
 117
 118 MAIN: do-all