extra/mason/test/test.factor

   1 ! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs benchmark bootstrap.stage2 calendar
   4 command-line compiler.errors continuations debugger help.html
   5 help.lint io io.directories io.encodings.utf8 io.files io.styles
   6 kernel mason.common math memory namespaces parser.notes
   7 sequences sets sorting source-files.errors system threads
   8 tools.errors tools.test tools.time vocabs
   9 vocabs.hierarchy.private vocabs.loader vocabs.refresh ;
  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 [
  25         '[
  26             [ require ]
  27             [ swap vocab-name _ set-at ] recover
  28         ] each
  29     ] keep ;
  30
  31 : load-from-root-no-restarts ( root prefix -- failures )
  32     vocabs-to-load require-all-no-restarts ;
  33
  34 : load-no-restarts ( prefix -- failures )
  35     [ vocab-roots get dup ] dip '[
  36         _ swap 1 + head vocab-roots [
  37             _ load-from-root-no-restarts
  38         ] with-variable
  39     ] map-index concat ;
  40
  41 : do-load ( -- )
  42     "" load-no-restarts
  43     [ keys load-all-vocabs-file to-file ]
  44     [ load-all-errors-file utf8 [ load-failures. ] with-file-writer ]
  45     bi ;
  46
  47 :: do-step ( errors summary-file details-file -- )
  48     errors
  49     [ error-type +linkage-error+ eq? ] reject
  50     [ path>> ] map members natural-sort summary-file to-file
  51     errors details-file utf8 [ errors. ] with-file-writer ;
  52
  53 : do-tests ( -- )
  54     forget-tests? on
  55     cpu x86.32? [
  56         "resource:core" test-root
  57         "resource:basis" test-root
  58     ] [
  59         test-all
  60     ] if
  61     test-failures get
  62     test-all-vocabs-file
  63     test-all-errors-file
  64     do-step ;
  65
  66 : do-help-lint ( -- )
  67     help-lint-all
  68     ! Give the cleanup a chance to run before looking at the errors.
  69     gc 2 seconds sleep
  70     lint-failures get values
  71     help-lint-vocabs-file
  72     help-lint-errors-file
  73     do-step ;
  74
  75 : do-benchmarks ( -- )
  76     run-timing-benchmarks
  77     [ benchmarks-file to-file ] [
  78         [ keys benchmark-error-vocabs-file to-file ]
  79         [ benchmark-error-messages-file utf8 [ benchmark-errors. ] with-file-writer ] bi
  80     ] bi* ;
  81
  82 : do-compile-errors ( -- )
  83     compiler-errors get values
  84     compiler-errors-file
  85     compiler-error-messages-file
  86     do-step ;
  87
  88 : outdated-core-vocabs ( -- modified-sources modified-docs any? )
  89     "" to-refresh drop 2dup [ empty? not ] either? ;
  90
  91 : outdated-boot-image. ( modified-sources modified-docs -- )
  92     "Boot image is out of date. Changed vocabs:" print
  93     union [ print ] each
  94     flush ;
  95
  96 : check-boot-image ( -- ? )
  97     outdated-core-vocabs [ outdated-boot-image. t ] [ 2drop f ] if ;
  98
  99 : run-mason-rc ( -- )
 100     t "user-init" [
 101         "~/.factor-mason-rc" try-user-init
 102     ] with-variable ;
 103
 104 : check-user-init-errors ( -- ? )
 105     user-init-errors get-global assoc-empty?
 106     [ f ] [ :user-init-errors t ] if ;
 107
 108 : do-all ( -- )
 109     f parser-quiet? set-global
 110     f restartable-tests? set-global
 111     ".." [
 112         run-mason-rc check-user-init-errors [ 1 exit ] when
 113         bootstrap-time get boot-time-file to-file
 114         check-boot-image [ 1 exit ] when
 115         [ do-load ] benchmark load-time-file to-file
 116         [ generate-help ] benchmark html-help-time-file to-file
 117         [ do-tests ] benchmark test-time-file to-file
 118         [ do-help-lint ] benchmark help-lint-time-file to-file
 119         [ do-benchmarks ] benchmark benchmark-time-file to-file
 120         do-compile-errors
 121     ] with-directory ;
 122
 123 MAIN: do-all