Added support for collecting test coverage of metafunctions
svn: r16193
This commit is contained in:
Casey Klein
parent
b50c10efa2
commit
f58882b4d1
|
|
@ -727,8 +727,14 @@
|
|||
body-code)])
|
||||
(cond
|
||||
[really-matched
|
||||
(when (relation-coverage)
|
||||
(cover-case case-id name (relation-coverage)))
|
||||
(for-each
|
||||
(λ (c)
|
||||
(let ([r (coverage-relation c)])
|
||||
(when (and (reduction-relation? r)
|
||||
(memf (λ (r) (eq? case-id (rewrite-proc-id r)))
|
||||
(reduction-relation-make-procs r)))
|
||||
(cover-case case-id c))))
|
||||
(relation-coverage))
|
||||
(loop (cdr mtchs)
|
||||
(map/mt (λ (x) (list name (f x))) really-matched acc))]
|
||||
[else
|
||||
|
|
@ -933,27 +939,41 @@
|
|||
(rewrite-proc-lhs child-make-proc)
|
||||
(rewrite-proc-id child-make-proc)))
|
||||
|
||||
(define relation-coverage (make-parameter #f))
|
||||
(define relation-coverage (make-parameter null))
|
||||
|
||||
(define (cover-case id name cov)
|
||||
(hash-update! (coverage-unwrap cov) id
|
||||
(λ (c) (cons (car c) (add1 (cdr c))))
|
||||
(λ () (raise-user-error
|
||||
'relation-coverage
|
||||
"coverage structure not initilized for this relation"))))
|
||||
(define (cover-case id cov)
|
||||
(hash-update! (coverage-counts cov) id
|
||||
(λ (c) (cons (car c) (add1 (cdr c))))))
|
||||
|
||||
(define (covered-cases cov)
|
||||
(hash-map (coverage-unwrap cov) (λ (k v) v)))
|
||||
(hash-map (coverage-counts cov) (λ (k v) v)))
|
||||
|
||||
(define-struct coverage (unwrap))
|
||||
(define-struct coverage (relation counts))
|
||||
|
||||
(define (fresh-coverage relation)
|
||||
(let ([h (make-hasheq)])
|
||||
(for-each
|
||||
(λ (rwp)
|
||||
(hash-set! h (rewrite-proc-id rwp) (cons (or (rewrite-proc-name rwp) "unnamed") 0)))
|
||||
(reduction-relation-make-procs relation))
|
||||
(make-coverage h)))
|
||||
(define-syntax (fresh-coverage stx)
|
||||
(syntax-case stx ()
|
||||
[(name subj-stx)
|
||||
(with-syntax ([subj
|
||||
(cond [(and (identifier? (syntax subj-stx))
|
||||
(let ([tf (syntax-local-value (syntax subj-stx) (λ () #f))])
|
||||
(and (term-fn? tf) (term-fn-get-id tf))))
|
||||
=> values]
|
||||
[else (syntax (let ([r subj-stx])
|
||||
(if (reduction-relation? r)
|
||||
r
|
||||
(raise-type-error 'name "reduction-relation" r))))])])
|
||||
(syntax
|
||||
(let ([h (make-hasheq)])
|
||||
(cond [(metafunc-proc? subj)
|
||||
(for-each
|
||||
(λ (c) (hash-set! h (metafunc-case-id c) (cons (metafunc-case-src-loc c) 0)))
|
||||
(metafunc-proc-cases subj))]
|
||||
[(reduction-relation? subj)
|
||||
(for-each
|
||||
(λ (rwp)
|
||||
(hash-set! h (rewrite-proc-id rwp) (cons (or (rewrite-proc-name rwp) (rewrite-proc-lhs-src rwp)) 0)))
|
||||
(reduction-relation-make-procs subj))])
|
||||
(make-coverage subj h))))]))
|
||||
|
||||
(define-syntax (test-match stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -1005,7 +1025,7 @@
|
|||
|
||||
(define-struct metafunction (proc))
|
||||
|
||||
(define-struct metafunc-case (cp rhs lhs-pat src-loc))
|
||||
(define-struct metafunc-case (cp rhs lhs-pat src-loc id))
|
||||
|
||||
(define-syntax (in-domain? stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -1196,7 +1216,7 @@
|
|||
rg-cp-let-bindings ... ...)
|
||||
(let ([cases (map (λ (pat rhs-fn rg-lhs src)
|
||||
(make-metafunc-case
|
||||
(compile-pattern lang pat #t) rhs-fn rg-lhs src))
|
||||
(compile-pattern lang pat #t) rhs-fn rg-lhs src (gensym)))
|
||||
sc
|
||||
(list rhs-fns ...)
|
||||
`(rg-side-conditions-rewritten ...)
|
||||
|
|
@ -1398,6 +1418,16 @@
|
|||
(wrap
|
||||
(letrec ([cache (make-hash)]
|
||||
[not-in-cache (gensym)]
|
||||
[log-coverage (λ (id)
|
||||
(when id
|
||||
(for-each
|
||||
(λ (c)
|
||||
(let ([r (coverage-relation c)])
|
||||
(when (and (metafunc-proc? r)
|
||||
(findf (λ (c) (eq? id (metafunc-case-id c)))
|
||||
(metafunc-proc-cases r)))
|
||||
(cover-case id c))))
|
||||
(relation-coverage))))]
|
||||
[metafunc
|
||||
(λ (exp)
|
||||
(let ([cache-ref (hash-ref cache exp not-in-cache)])
|
||||
|
|
@ -1414,12 +1444,13 @@
|
|||
[(null? cases)
|
||||
(if relation?
|
||||
(begin
|
||||
(hash-set! cache exp #f)
|
||||
(hash-set! cache exp (cons #f #f))
|
||||
#f)
|
||||
(redex-error name "no clauses matched for ~s" `(,name . ,exp)))]
|
||||
[else
|
||||
(let ([pattern (metafunc-case-cp (car cases))]
|
||||
[rhs (metafunc-case-rhs (car cases))])
|
||||
[rhs (metafunc-case-rhs (car cases))]
|
||||
[id (metafunc-case-id (car cases))])
|
||||
(let ([mtchs (match-pattern pattern exp)])
|
||||
(cond
|
||||
[(not mtchs) (loop (cdr cases) (+ num 1))]
|
||||
|
|
@ -1431,7 +1462,8 @@
|
|||
(redex-error name "codomain test failed for ~s, call was ~s" ans `(,name ,@exp)))
|
||||
(cond
|
||||
[ans
|
||||
(hash-set! cache exp #t)
|
||||
(hash-set! cache exp (cons #t id))
|
||||
(log-coverage id)
|
||||
#t]
|
||||
[else
|
||||
(loop (cdr cases) (+ num 1))]))]
|
||||
|
|
@ -1459,10 +1491,12 @@
|
|||
"codomain test failed for ~s, call was ~s"
|
||||
ans
|
||||
`(,name ,@exp)))
|
||||
(hash-set! cache exp ans)
|
||||
(hash-set! cache exp (cons ans id))
|
||||
(log-coverage id)
|
||||
ans)]))])))]))]
|
||||
[else
|
||||
cache-ref])))]
|
||||
(log-coverage (cdr cache-ref))
|
||||
(car cache-ref)])))]
|
||||
[ot (current-trace-print-args)]
|
||||
[traced-metafunc (lambda (exp)
|
||||
(if (or (eq? (current-traced-metafunctions) 'all)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
(module tl-test mzscheme
|
||||
(module tl-test scheme
|
||||
(require "../reduction-semantics.ss"
|
||||
"test-util.ss"
|
||||
(only "matcher.ss" make-bindings make-bind)
|
||||
(only-in "matcher.ss" make-bindings make-bind)
|
||||
scheme/match
|
||||
"struct.ss")
|
||||
|
||||
|
|
@ -1616,32 +1616,120 @@
|
|||
[else #f])
|
||||
#t))
|
||||
|
||||
(let ([< (λ (c d) (string<? (car c) (car d)))])
|
||||
|
||||
(let* ([R (reduction-relation
|
||||
empty-language
|
||||
(--> number (q ,(add1 (term number)))
|
||||
(side-condition (odd? (term number)))
|
||||
side-condition)
|
||||
(--> 1 4 plain)
|
||||
(==> 2 t
|
||||
shortcut)
|
||||
with
|
||||
[(--> (q a) b)
|
||||
(==> a b)])]
|
||||
[c (make-coverage R)])
|
||||
(parameterize ([relation-coverage (list c)])
|
||||
(apply-reduction-relation R 4)
|
||||
(test (sort (covered-cases c) <)
|
||||
'(("plain" . 0) ("shortcut" . 0) ("side-condition" . 0)))
|
||||
|
||||
(apply-reduction-relation R 3)
|
||||
(test (sort (covered-cases c) <)
|
||||
'(("plain" . 0) ("shortcut" . 0) ("side-condition" . 1)))
|
||||
|
||||
(apply-reduction-relation* R 1)
|
||||
(test (sort (covered-cases c) <)
|
||||
'(("plain" . 1) ("shortcut" . 1) ("side-condition" . 2)))))
|
||||
|
||||
(let* ([S (reduction-relation
|
||||
empty-language
|
||||
(--> 1 1 uno))]
|
||||
[S+ (extend-reduction-relation
|
||||
S empty-language
|
||||
(--> 2 2 dos))])
|
||||
(let ([c (make-coverage S+)])
|
||||
(parameterize ([relation-coverage (list c)])
|
||||
(apply-reduction-relation S (term 1))
|
||||
(test (sort (covered-cases c) <)
|
||||
'(("dos" . 0) ("uno" . 1)))))
|
||||
(let ([c (make-coverage S)])
|
||||
(parameterize ([relation-coverage (list c)])
|
||||
(apply-reduction-relation S+ (term 1))
|
||||
(test (sort (covered-cases c) <)
|
||||
'(("uno" . 1))))))
|
||||
|
||||
(let* ([T (reduction-relation empty-language (--> any any))]
|
||||
[c (make-coverage T)])
|
||||
(parameterize ([relation-coverage (list c)])
|
||||
(apply-reduction-relation T (term q))
|
||||
(test (and (regexp-match #px"tl-test.ss:\\d+:\\d+" (caar (covered-cases c))) #t)
|
||||
#t))))
|
||||
|
||||
(let* ([R (reduction-relation
|
||||
empty-language
|
||||
(--> number (q ,(add1 (term number)))
|
||||
(side-condition (odd? (term number)))
|
||||
side-condition)
|
||||
(--> 1 4)
|
||||
(==> 2 t
|
||||
shortcut)
|
||||
with
|
||||
[(--> (q a) b)
|
||||
(==> a b)])]
|
||||
(--> any any id))]
|
||||
[c (make-coverage R)]
|
||||
[< (λ (c d) (string<? (car c) (car d)))])
|
||||
(parameterize ([relation-coverage c])
|
||||
[c* (make-coverage R)])
|
||||
(parameterize ([relation-coverage (list c c*)])
|
||||
(apply-reduction-relation R 4)
|
||||
(test (sort (covered-cases c) <)
|
||||
'(("shortcut" . 0) ("side-condition" . 0) ("unnamed" . 0)))
|
||||
(test (covered-cases c) '(("id" . 1)))
|
||||
(test (covered-cases c*) '(("id" . 1)))))
|
||||
|
||||
(apply-reduction-relation R 3)
|
||||
(test (sort (covered-cases c) <)
|
||||
'(("shortcut" . 0) ("side-condition" . 1) ("unnamed" . 0)))
|
||||
(let* ([< (λ (c d)
|
||||
(let ([line-no (compose
|
||||
string->number
|
||||
second
|
||||
(curry regexp-match #px".*:(\\d+):\\d+"))])
|
||||
(< (line-no (car c)) (line-no (car d)))))]
|
||||
[src-ok? (curry regexp-match? #px"tl-test.ss:\\d+:\\d+")]
|
||||
[sorted-counts (λ (cc) (map cdr (sort (covered-cases cc) <)))])
|
||||
(define-metafunction empty-language
|
||||
[(f 1) 1]
|
||||
[(f 2) 2])
|
||||
(define-metafunction/extension f empty-language
|
||||
[(g 3) 3])
|
||||
(define-relation empty-language
|
||||
[(R number)
|
||||
,(even? (term number))]
|
||||
[(R number)
|
||||
,(= 3 (term number))])
|
||||
|
||||
(apply-reduction-relation* R 1)
|
||||
(test (sort (covered-cases c) <)
|
||||
'(("shortcut" . 1) ("side-condition" . 2) ("unnamed" . 1)))))
|
||||
(let ([fc (make-coverage f)]
|
||||
[rc (make-coverage (reduction-relation empty-language (--> any any)))])
|
||||
(parameterize ([relation-coverage (list rc fc)])
|
||||
(term (f 2))
|
||||
(test (andmap (compose src-ok? car) (covered-cases fc))
|
||||
#t)
|
||||
(test (sorted-counts fc) '(0 1))
|
||||
|
||||
(term (f 1))
|
||||
(term (f 1))
|
||||
(test (sorted-counts fc) '(2 1))))
|
||||
|
||||
(let ([c (make-coverage f)])
|
||||
(parameterize ([relation-coverage (list c)])
|
||||
(term (g 1))
|
||||
(test (sorted-counts c) '(1 0))))
|
||||
(let ([c (make-coverage g)])
|
||||
(parameterize ([relation-coverage (list c)])
|
||||
(term (f 1))
|
||||
(test (sorted-counts c) '(1 0 0))))
|
||||
|
||||
(let ([c (make-coverage R)])
|
||||
(parameterize ([relation-coverage (list c)])
|
||||
(term (R 2))
|
||||
(term (R 3))
|
||||
(term (R 5))
|
||||
(test (sorted-counts c) '(1 1))))
|
||||
|
||||
(let ([c (make-coverage f)]
|
||||
[c* (make-coverage f)])
|
||||
(parameterize ([relation-coverage (list c* c)])
|
||||
(term (f 1))
|
||||
(test (sorted-counts c) '(1 0))
|
||||
(test (sorted-counts c*) '(1 0)))))
|
||||
|
||||
;
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1062,47 +1062,55 @@ counters so that next time this function is called, it
|
|||
prints the test results for the next round of tests.
|
||||
}
|
||||
|
||||
@defproc[(make-coverage [r reduction-relation?]) coverage?]{
|
||||
Constructs a structure to contain the per-case test coverage of
|
||||
the relation @scheme[r]. Use with @scheme[relation-coverage]
|
||||
and @scheme[covered-cases].
|
||||
@defform/subs[(make-coverage subject)
|
||||
([subject (code:line metafunction)
|
||||
(code:line relation-expr)])]{
|
||||
Constructs a structure (recognized by @scheme[coverage?])
|
||||
to contain per-case test coverage of the supplied metafunction
|
||||
or reduction relation. Use with @scheme[relation-coverage] and
|
||||
@scheme[covered-cases].
|
||||
}
|
||||
|
||||
@defproc[(coverage? [v any/c]) boolean?]{
|
||||
Returns @scheme[#t] for a value produced by @scheme[make-coverage]
|
||||
and @scheme[#f] for any other.}
|
||||
|
||||
@defparam[relation-coverage c (or/c false/c coverage?)]{
|
||||
When @scheme[c] is a @scheme[coverage] structure, rather than
|
||||
@scheme[#f] (the default), procedures such as
|
||||
@scheme[apply-reduction-relation], @scheme[traces], etc. count
|
||||
the number applications of each case of the
|
||||
@scheme[reduction-relation], storing the results in @scheme[c].
|
||||
}
|
||||
@defparam[relation-coverage tracked (listof coverage?)]{
|
||||
Redex populates the coverage records in @scheme[tracked] (default @scheme[null]),
|
||||
counting the times that tests exercise each case of the associated metafunction
|
||||
and relations.}
|
||||
|
||||
@defproc[(covered-cases
|
||||
[c coverage?])
|
||||
(listof (cons/c string? natural-number/c))]{
|
||||
Extracts the coverage information recorded in @scheme[c], producing
|
||||
an association list mapping names to application counts.}
|
||||
an association list mapping names (or source locations, in the case of
|
||||
metafunctions or unnamed reduction-relation cases) to application counts.}
|
||||
|
||||
@examples[
|
||||
#:eval redex-eval
|
||||
(define-language empty-lang)
|
||||
|
||||
(define-metafunction empty-lang
|
||||
[(plus number_1 number_2)
|
||||
,(+ (term number_1) (term number_2))])
|
||||
|
||||
(define equals
|
||||
(reduction-relation
|
||||
empty-lang
|
||||
(--> (+) 0 "zero")
|
||||
(--> (+ number) number)
|
||||
(--> (+ number_1 number_2 number ...)
|
||||
(+ ,(+ (term number_1) (term number_2))
|
||||
(+ (plus number_1 number_2)
|
||||
number ...)
|
||||
"add")))
|
||||
(let ([coverage (make-coverage equals)])
|
||||
(parameterize ([relation-coverage coverage])
|
||||
(let ([equals-coverage (make-coverage equals)]
|
||||
[plus-coverage (make-coverage plus)])
|
||||
(parameterize ([relation-coverage (list equals-coverage
|
||||
plus-coverage)])
|
||||
(apply-reduction-relation* equals (term (+ 1 2 3)))
|
||||
(covered-cases coverage)))]
|
||||
(values (covered-cases equals-coverage)
|
||||
(covered-cases plus-coverage))))]
|
||||
|
||||
@defform/subs[(generate-term language @#,ttpattern size-exp kw-args ...)
|
||||
([kw-args (code:line #:attempts attempts-expr)
|
||||
|
|
|
|||
|
|
@ -29,7 +29,8 @@
|
|||
define-relation
|
||||
metafunction
|
||||
in-domain?
|
||||
caching-enabled?)
|
||||
caching-enabled?
|
||||
make-coverage)
|
||||
|
||||
(provide (rename-out [test-match redex-match])
|
||||
term-match
|
||||
|
|
@ -69,6 +70,5 @@
|
|||
(-> bindings? symbol? (-> any) any))]
|
||||
[variable-not-in (any/c symbol? . -> . symbol?)]
|
||||
[variables-not-in (any/c (listof symbol?) . -> . (listof symbol?))]
|
||||
[relation-coverage (parameter/c (or/c false/c coverage?))]
|
||||
[make-coverage (-> reduction-relation? coverage?)]
|
||||
[relation-coverage (parameter/c (listof coverage?))]
|
||||
[covered-cases (-> coverage? (listof (cons/c string? natural-number/c)))])
|
||||
|
|
|
|||
|
|
@ -1,3 +1,13 @@
|
|||
v4.2.3
|
||||
|
||||
* added support for collecting metafunction coverage, using the
|
||||
'relation-coverage' parameter. This includes a backwards
|
||||
incompatible change: the parameter's value is now a list of
|
||||
coverage structures, to allow coverage collection for multiple
|
||||
metafunctions and reduction relations at once.
|
||||
|
||||
* minor bug fixes
|
||||
|
||||
v4.2.2
|
||||
|
||||
* minor bug fixes
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user