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 vocabs.hierarchy
10 TUPLE: coverage-state < identity-tuple executed? ;
12 C: <coverage-state> coverage-state
16 : flag-covered ( coverage -- )
17 covered get-global [ t >>executed? ] when drop ;
19 : coverage-on ( -- ) t covered set-global ;
21 : coverage-off ( -- ) f covered set-global ;
23 GENERIC: add-coverage ( object -- )
25 GENERIC: remove-coverage ( object -- )
27 GENERIC: reset-coverage ( object -- )
31 : private-vocab-name ( string -- string' )
32 ".private" ?tail drop ".private" append ;
34 : coverage-words ( string -- words )
35 vocab-words [ { [ primitive? not ] [ symbol? not ] [ predicate? not ] } 1&& ] filter ;
39 : each-word ( string quot -- )
40 over ".private" tail? [
41 [ coverage-words ] dip each
43 [ [ private-vocab-name coverage-words ] dip each ]
44 [ [ coverage-words ] dip each ] 2bi
47 : map-words ( string quot -- sequence )
48 over ".private" tail? [
49 [ coverage-words ] dip map
51 [ [ private-vocab-name coverage-words ] dip map ]
52 [ [ coverage-words ] dip map ] 2bi append
55 M: string add-coverage
56 [ add-coverage ] each-word ;
58 M: string remove-coverage
59 [ remove-coverage ] each-word ;
62 H{ } clone [ "coverage" set-word-prop ] 2keep
64 \ coverage-state new [ _ set-at ] 2keep
65 '[ _ flag-covered ] prepend
68 M: word remove-coverage
69 [ reset ] [ f "coverage" set-word-prop ] bi ;
71 M: string reset-coverage
72 [ reset-coverage ] each-word ;
74 M: word reset-coverage
75 [ dup coverage-state? [ f >>executed? ] when drop ] each-word ;
77 GENERIC: coverage ( object -- seq )
80 [ dup coverage 2array ] map-words ;
82 M: word coverage ( word -- seq )
83 "coverage" word-prop >alist
84 [ drop executed?>> ] assoc-reject values ;
86 GENERIC: coverage. ( object -- )
89 [ coverage. ] each-word ;
91 : pair-coverage. ( word quots -- )
95 [ name>> ":" append print ]
96 [ [ " " write . ] each ] bi*
100 dup coverage pair-coverage. ;
102 M: sequence coverage.
103 [ first2 pair-coverage. ] each ;
107 GENERIC: count-callables ( object -- n )
109 M: string count-callables
110 [ count-callables ] map-words sum ;
112 M: word count-callables
113 def>> [ callable? ] deep-filter length ;
117 : test-coverage ( vocab -- coverage )
124 [ coverage-on test-vocab coverage-off ]
126 ] [ _ remove-coverage ] [ ] cleanup
130 : coverage-vocab? ( vocab -- ? )
131 { [ ".private" tail? ] [ ".tests" tail? ] } 1|| not ;
133 : test-coverage-recursively ( prefix -- assoc )
134 disk-vocabs-for-prefix [ coverage-vocab? ] filter
135 [ dup test-coverage ] { } map>assoc ;
137 : %coverage ( string -- x )
138 [ test-coverage values concat length ]
139 [ count-callables ] bi [ swap - ] keep /f ; inline