basis/tools/coverage/coverage.factor

   1 ! Copyright (C) 2011 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs classes combinators
   4 combinators.short-circuit continuations fry io kernel math
   5 namespaces prettyprint quotations sequences sequences.deep
   6 splitting strings tools.annotations tools.test
   7 tools.test.private vocabs words words.symbol ;
   8 IN: tools.coverage
   9
  10 TUPLE: coverage-state < identity-tuple executed? ;
  11
  12 C: <coverage-state> coverage-state
  13
  14 SYMBOL: covered
  15
  16 : flag-covered ( coverage -- )
  17     covered get-global [ t >>executed? ] when drop ;
  18
  19 : coverage-on ( -- ) t covered set-global ;
  20
  21 : coverage-off ( -- ) f covered set-global ;
  22
  23 GENERIC: add-coverage ( object -- )
  24
  25 GENERIC: remove-coverage ( object -- )
  26
  27 GENERIC: reset-coverage ( object -- )
  28
  29 <PRIVATE
  30
  31 : private-vocab-name ( string -- string' )
  32     ".private" ?tail drop ".private" append ;
  33
  34 : coverage-words ( string -- words )
  35     words [ { [ primitive? not ] [ symbol? not ] [ predicate? not ] } 1&& ] filter ;
  36
  37 PRIVATE>
  38
  39 : each-word ( string quot -- )
  40     over ".private" tail? [
  41         [ coverage-words ] dip each
  42     ] [
  43         [ [ private-vocab-name coverage-words ] dip each ]
  44         [ [ coverage-words ] dip each ] 2bi
  45     ] if ; inline
  46
  47 : map-words ( string quot -- sequence )
  48     over ".private" tail? [
  49         [ coverage-words ] dip map
  50     ] [
  51         [ [ private-vocab-name coverage-words ] dip map ]
  52         [ [ coverage-words ] dip map ] 2bi append
  53     ] if ; inline
  54
  55 M: string add-coverage
  56     [ add-coverage ] each-word ;
  57
  58 M: string remove-coverage
  59     [ remove-coverage ] each-word ;
  60
  61 M: word add-coverage
  62     H{ } clone [ "coverage" set-word-prop ] 2keep
  63     '[
  64         \ coverage-state new [ _ set-at ] 2keep
  65         '[ _ flag-covered ] prepend
  66     ] deep-annotate ;
  67
  68 M: word remove-coverage
  69     [ reset ] [ f "coverage" set-word-prop ] bi ;
  70
  71 M: string reset-coverage
  72     [ reset-coverage ] each-word ;
  73
  74 M: word reset-coverage
  75     [ dup coverage-state? [ f >>executed? ] when drop ] each-word ;
  76
  77 GENERIC: coverage ( object -- seq )
  78
  79 M: string coverage
  80     [ dup coverage 2array ] map-words ;
  81
  82 M: word coverage ( word -- seq )
  83     "coverage" word-prop >alist
  84     [ drop executed?>> ] assoc-reject values ;
  85
  86 GENERIC: coverage. ( object -- )
  87
  88 M: string coverage.
  89     [ coverage. ] each-word ;
  90
  91 : pair-coverage. ( word quots -- )
  92     dup empty? [
  93         2drop
  94     ] [
  95         [ name>> ":" append print ]
  96         [ [ "    " write . ] each ] bi*
  97     ] if ;
  98
  99 M: word coverage.
 100     dup coverage pair-coverage. ;
 101
 102 M: sequence coverage.
 103     [ first2 pair-coverage. ] each ;
 104
 105 <PRIVATE
 106
 107 GENERIC: count-callables ( object -- n )
 108
 109 M: string count-callables
 110     [ count-callables ] map-words sum ;
 111
 112 M: word count-callables
 113     def>> [ callable? ] deep-filter length ;
 114
 115 PRIVATE>
 116
 117 : test-coverage ( vocab -- coverage )
 118     [
 119         add-coverage
 120     ] [
 121         dup '[
 122             [
 123                 _
 124                 [ coverage-on test-vocab coverage-off ]
 125                 [ coverage ] bi
 126             ] [ _ remove-coverage ] [ ] cleanup
 127         ] call
 128     ] bi ;
 129
 130 : coverage-vocab? ( vocab -- ? )
 131     { [ ".private" tail? ] [ ".tests" tail? ] } 1|| not ;
 132
 133 : test-coverage-recursively ( prefix -- assoc )
 134     child-vocabs [ coverage-vocab? ] filter
 135     [ dup test-coverage ] { } map>assoc ;
 136
 137 : %coverage ( string -- x )
 138     [ test-coverage values concat length ]
 139     [ count-callables ] bi [ swap - ] keep /f ; inline