suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Support for collecing per-case test coverage of reduction relations.

Browse Source 
svn: r13013
This commit is contained in:
Casey Klein 2009-01-05 14:26:04 +00:00
parent 851c58ea50
commit 104447edf6
2 changed files with 69 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
collects/redex/private/reduction-semantics.ss
View File

@ -754,22 +754,40 @@
(rewrite-proc-name child-make-proc)
(subst lhs-frm-id (rewrite-proc-lhs child-make-proc) rhs-from)))
(define relation-coverage (make-parameter #f))
(define-struct covered-case (name apps) #:inspector (make-inspector))
(define (apply-case c)
(struct-copy covered-case c [apps (add1 (covered-case-apps c))]))
(define (cover-case id name relation-coverage)
(hash-update! relation-coverage id apply-case (make-covered-case name 0)))
(define (covered-cases relation-coverage)
(hash-map relation-coverage (λ (k v) v)))
(define fresh-coverage make-hasheq)
(define (do-leaf-match name pat w/extras proc)
(make-rewrite-proc
(λ (lang)
(let ([cp (compile-pattern lang pat #t)])
(λ (main-exp exp f other-matches)
(let ([mtchs (match-pattern cp exp)])
(if mtchs
(map/mt (λ (mtch)
(let ([really-matched (proc main-exp (mtch-bindings mtch))])
(and really-matched
(list name (f (successful-result really-matched))))))
mtchs
other-matches)
other-matches)))))
name
w/extras))
(let ([case-id (gensym)])
(make-rewrite-proc
(λ (lang)
(let ([cp (compile-pattern lang pat #t)])
(λ (main-exp exp f other-matches)
(let ([mtchs (match-pattern cp exp)])
(if mtchs
(map/mt (λ (mtch)
(let ([really-matched (proc main-exp (mtch-bindings mtch))])
(and really-matched
(when (relation-coverage)
(cover-case case-id name (relation-coverage)))
(list name (f (successful-result really-matched))))))
mtchs
other-matches)
other-matches)))))
name
w/extras)))
(define-syntax (test-match stx)
(syntax-case stx ()
@ -1801,3 +1819,8 @@
apply-reduction-relation*
variable-not-in
variables-not-in)
(provide relation-coverage
covered-cases
fresh-coverage
(struct-out covered-case))

31
collects/redex/private/tl-test.ss
View File

@ -1,5 +1,8 @@
(module tl-test mzscheme
(require "../reduction-semantics.ss"
(only "reduction-semantics.ss"
relation-coverage fresh-coverage covered-cases
make-covered-case covered-case-name)
"test-util.ss"
(only "matcher.ss" make-bindings make-bind)
scheme/match
@ -1161,4 +1164,32 @@
[else #f])
#t))
(let ([R (reduction-relation
empty-language
(--> number (q ,(add1 (term number)))
(side-condition (odd? (term number)))
side-condition)
(--> 1 4
one)
(==> 2 t
shortcut)
with
[(--> (q a) b)
(==> a b)])]
[c (fresh-coverage)])
(parameterize ([relation-coverage c])
(apply-reduction-relation R 4)
(test (covered-cases c) null)
(apply-reduction-relation R 3)
(test (covered-cases c)
(list (make-covered-case "side-condition" 1)))
(apply-reduction-relation* R 1)
(test (sort (covered-cases c)
(λ (c d) (string<? (covered-case-name c) (covered-case-name d))))
(list (make-covered-case "one" 1)
(make-covered-case "shortcut" 1)
(make-covered-case "side-condition" 2)))))
(print-tests-passed 'tl-test.ss))