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