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 ;
9 TUPLE: coverage-state < identity-tuple executed? ;
11 C: <coverage-state> coverage-state
15 : flag-covered ( coverage -- )
16 covered get-global [ t >>executed? ] when drop ;
18 : coverage-on ( -- ) t covered set-global ;
20 : coverage-off ( -- ) f covered set-global ;
22 GENERIC: add-coverage ( object -- )
24 GENERIC: remove-coverage ( object -- )
26 GENERIC: reset-coverage ( object -- )
30 : private-vocab-name ( string -- string' )
31 ".private" ?tail drop ".private" append ;
33 : coverage-words ( string -- words )
44 : each-word ( string quot -- )
45 over ".private" tail? [
46 [ coverage-words ] dip each
48 [ [ private-vocab-name coverage-words ] dip each ]
49 [ [ coverage-words ] dip each ] 2bi
52 : map-words ( string quot -- sequence )
53 over ".private" tail? [
54 [ coverage-words ] dip map
56 [ [ private-vocab-name coverage-words ] dip map ]
57 [ [ coverage-words ] dip map ] 2bi append
60 M: string add-coverage
61 [ add-coverage ] each-word ;
63 M: string remove-coverage
64 [ remove-coverage ] each-word ;
67 H{ } clone [ "coverage" set-word-prop ] 2keep
69 \ coverage-state new [ _ set-at ] 2keep
70 '[ _ flag-covered ] prepend
73 M: word remove-coverage
74 [ reset ] [ f "coverage" set-word-prop ] bi ;
76 M: string reset-coverage
77 [ reset-coverage ] each-word ;
79 M: word reset-coverage
80 [ dup coverage-state? [ f >>executed? ] when drop ] each-word ;
82 GENERIC: coverage ( object -- seq )
85 [ dup coverage 2array ] map-words ;
87 M: word coverage ( word -- seq )
89 [ drop executed?>> ] assoc-reject values ;
91 GENERIC: coverage. ( object -- )
94 [ coverage. ] each-word ;
96 : pair-coverage. ( word seq -- )
98 [ name>> ":" append print ]
99 [ [ " " write . ] each ] bi*
103 dup coverage pair-coverage. ;
105 M: sequence coverage.
106 [ first2 pair-coverage. ] each ;
110 GENERIC: count-callables ( object -- n )
112 M: string count-callables
113 [ count-callables ] map-words sum ;
115 M: word count-callables
116 def>> 0 [ callable? [ 1 + ] when ] deep-reduce ;
120 : test-coverage ( vocab -- coverage )
127 [ coverage-on test-vocab coverage-off ]
129 ] [ _ remove-coverage ] [ ] cleanup
133 : coverage-vocab? ( vocab -- ? )
134 { [ ".private" tail? ] [ ".tests" tail? ] } 1|| not ;
136 : test-coverage-recursively ( prefix -- assoc )
137 loaded-child-vocab-names [ coverage-vocab? ] filter
138 [ dup test-coverage ] { } map>assoc ;
140 : %coverage ( string -- x )
141 [ test-coverage values concat length ]
142 [ count-callables ] bi [ swap - ] keep /f ; inline