Added support for collecting test coverage of metafunctions

svn: r16193

collects/redex/private/reduction-semantics.ss

@@ -727,8 +727,14 @@
                                                   body-code)])
                                   (cond
                                     [really-matched
-                                     (when (relation-coverage)
+                                     (for-each
-                                       (cover-case case-id name (relation-coverage)))
+                                      (λ (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)
+(define (cover-case id cov)
-  (hash-update! (coverage-unwrap cov) id 
+  (hash-update! (coverage-counts cov) id 
-                (λ (c) (cons (car c) (add1 (cdr c))))
+                (λ (c) (cons (car c) (add1 (cdr c))))))
-                (λ () (raise-user-error 
-                       'relation-coverage
-                       "coverage structure not initilized for this relation"))))
 
 (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)
+(define-syntax (fresh-coverage stx)
-  (let ([h (make-hasheq)])
+  (syntax-case stx ()
-    (for-each 
+    [(name subj-stx)
-     (λ (rwp) 
+     (with-syntax ([subj
-       (hash-set! h (rewrite-proc-id rwp) (cons (or (rewrite-proc-name rwp) "unnamed") 0)))
+                    (cond [(and (identifier? (syntax subj-stx))
-     (reduction-relation-make-procs relation))
+                                (let ([tf (syntax-local-value (syntax subj-stx) (λ () #f))])
-    (make-coverage h)))
+                                  (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)

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<? (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)))
+             (--> any any id))]
-                  (side-condition (odd? (term number)))
-                  side-condition)
-             (--> 1 4)
-             (==> 2 t
-                  shortcut)
-             with
-             [(--> (q a) b)
-              (==> a b)])]
          [c (make-coverage R)]
-         [< (λ (c d) (string<? (car c) (car d)))])
+         [c* (make-coverage R)])
-    (parameterize ([relation-coverage c])
+    (parameterize ([relation-coverage (list c c*)])
       (apply-reduction-relation R 4)
-      (test (sort (covered-cases c) <)
+      (test (covered-cases c) '(("id" . 1)))
-            '(("shortcut" . 0) ("side-condition" . 0) ("unnamed" . 0)))
+      (test (covered-cases c*) '(("id" . 1)))))
-      
-      (apply-reduction-relation R 3)
-      (test (sort (covered-cases c) <)
-            '(("shortcut" . 0) ("side-condition" . 1) ("unnamed" . 0)))
-      
-      (apply-reduction-relation* R 1)
-      (test (sort (covered-cases c) <)
-            '(("shortcut" . 1) ("side-condition" . 2) ("unnamed" . 1)))))
-  
   
+  (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))])
+    
+    (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)))))
+
 ;                                                                       
 ;                                                                       
 ;                                                                       

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?]{
+@defform/subs[(make-coverage subject)
-Constructs a structure to contain the per-case test coverage of
+              ([subject (code:line metafunction)
-the relation @scheme[r]. Use with @scheme[relation-coverage]
+                        (code:line relation-expr)])]{
-and @scheme[covered-cases].
+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?)]{
+@defparam[relation-coverage tracked (listof coverage?)]{
-When @scheme[c] is a @scheme[coverage] structure, rather than 
+Redex populates the coverage records in @scheme[tracked] (default @scheme[null]),
-@scheme[#f] (the default), procedures such as
+counting the times that tests exercise each case of the associated metafunction
-@scheme[apply-reduction-relation], @scheme[traces], etc. count 
+and relations.}
-the number applications of each case of the
-@scheme[reduction-relation], storing the results in @scheme[c].
-}
 
 @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)])
+       (let ([equals-coverage (make-coverage equals)]
-         (parameterize ([relation-coverage coverage])
+             [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)

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?))]
+ [relation-coverage (parameter/c (listof coverage?))]
- [make-coverage (-> reduction-relation? coverage?)]
  [covered-cases (-> coverage? (listof (cons/c string? natural-number/c)))])

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