From f58882b4d177e4982664ad8584202288fbafc813 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Wed, 30 Sep 2009 21:32:20 +0000 Subject: [PATCH] Added support for collecting test coverage of metafunctions svn: r16193 --- collects/redex/private/reduction-semantics.ss | 84 +++++++---- collects/redex/private/tl-test.ss | 136 ++++++++++++++---- collects/redex/redex.scrbl | 42 +++--- collects/redex/reduction-semantics.ss | 6 +- doc/release-notes/redex/HISTORY.txt | 10 ++ 5 files changed, 209 insertions(+), 69 deletions(-) diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss index 3b684751a8..b8927b9760 100644 --- a/collects/redex/private/reduction-semantics.ss +++ b/collects/redex/private/reduction-semantics.ss @@ -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) diff --git a/collects/redex/private/tl-test.ss b/collects/redex/private/tl-test.ss index 91d237de61..bda6a715f0 100644 --- a/collects/redex/private/tl-test.ss +++ b/collects/redex/private/tl-test.ss @@ -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,33 +1616,121 @@ [else #f]) #t)) + (let ([< (λ (c d) (string 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) (stringnumber + 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))]) + + (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))))) + ; ; ; diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index 1552ef4333..c277c38b9b 100644 --- a/collects/redex/redex.scrbl +++ b/collects/redex/redex.scrbl @@ -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) @@ -1131,7 +1139,7 @@ argument @scheme[retries-expr] (default @scheme[100]) bounds the number of times @scheme[generate-term] is unable to produce a satisfying term after @scheme[retries-expr] attempts, it raises an exception recognized by @scheme[exn:fail:redex:generation-failure?].} - + @defform/subs[(redex-check language @#,ttpattern property-expr kw-arg ...) ([kw-arg (code:line #:attempts attempts-expr) (code:line #:source metafunction) diff --git a/collects/redex/reduction-semantics.ss b/collects/redex/reduction-semantics.ss index 3f65be6ad0..067a2e443a 100644 --- a/collects/redex/reduction-semantics.ss +++ b/collects/redex/reduction-semantics.ss @@ -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)))]) diff --git a/doc/release-notes/redex/HISTORY.txt b/doc/release-notes/redex/HISTORY.txt index 5c3323f681..b77a1990cb 100644 --- a/doc/release-notes/redex/HISTORY.txt +++ b/doc/release-notes/redex/HISTORY.txt @@ -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