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 generic help.html help.lint io io.directories
   5 io.encodings.utf8 io.files kernel locals mason.common namespaces
   6 parser.notes sequences sets sorting source-files.errors system
   7 tools.errors tools.test tools.time vocabs.errors
   8 vocabs.hierarchy vocabs.refresh words ;
   9 IN: mason.test
  10
  11 : do-load ( -- )
  12     "" (load)
  13     [ keys load-all-vocabs-file to-file ]
  14     [ load-all-errors-file utf8 [ load-failures. ] with-file-writer ]
  15     bi ;
  16
  17 GENERIC: word-vocabulary ( word -- vocabulary )
  18
  19 M: word word-vocabulary vocabulary>> ;
  20
  21 M: method word-vocabulary "method-generic" word-prop word-vocabulary ;
  22
  23 :: do-step ( errors summary-file details-file -- )
  24     errors
  25     [ error-type +linkage-error+ eq? ] reject
  26     [ file>> ] map members natural-sort summary-file to-file
  27     errors details-file utf8 [ errors. ] with-file-writer ;
  28
  29 : do-tests ( -- )
  30     forget-tests? on
  31     test-all test-failures get
  32     test-all-vocabs-file
  33     test-all-errors-file
  34     do-step ;
  35
  36 : do-help-lint ( -- )
  37     help-lint-all lint-failures get values
  38     help-lint-vocabs-file
  39     help-lint-errors-file
  40     do-step ;
  41
  42 : do-benchmarks ( -- )
  43     run-timing-benchmarks
  44     [ benchmarks-file to-file ] [
  45         [ keys benchmark-error-vocabs-file to-file ]
  46         [ benchmark-error-messages-file utf8 [ benchmark-errors. ] with-file-writer ] bi
  47     ] bi* ;
  48
  49 : do-compile-errors ( -- )
  50     compiler-errors get values
  51     compiler-errors-file
  52     compiler-error-messages-file
  53     do-step ;
  54
  55 : outdated-core-vocabs ( -- modified-sources modified-docs any? )
  56     "" to-refresh drop 2dup [ empty? not ] either? ;
  57
  58 : outdated-boot-image. ( modified-sources modified-docs -- )
  59     "Boot image is out of date. Changed vocabs:" print
  60     union [ print ] each
  61     flush ;
  62
  63 : check-boot-image ( -- ? )
  64     outdated-core-vocabs [ outdated-boot-image. t ] [ 2drop f ] if ;
  65
  66 : run-mason-rc ( -- )
  67     t "user-init" [
  68         ".factor-mason-rc" rc-path try-user-init
  69     ] with-variable ;
  70
  71 : check-user-init-errors ( -- ? )
  72     user-init-errors get-global assoc-empty?
  73     [ f ] [ :user-init-errors t ] if ;
  74
  75 : do-all ( -- )
  76     f parser-quiet? set-global
  77     ".." [
  78         run-mason-rc check-user-init-errors [ 1 exit ] when
  79         bootstrap-time get boot-time-file to-file
  80         check-boot-image [ 1 exit ] when
  81         [ do-load ] benchmark load-time-file to-file
  82         [ generate-help ] benchmark html-help-time-file to-file
  83         [ do-tests ] benchmark test-time-file to-file
  84         [ do-help-lint ] benchmark help-lint-time-file to-file
  85         [ do-benchmarks ] benchmark benchmark-time-file to-file
  86         do-compile-errors
  87     ] with-directory ;
  88
  89 MAIN: do-all