Changed the interface for collecting reduction relation coverage.

svn: r13046

collects/redex/private/reduction-semantics.ss

@@ -753,22 +753,32 @@
                                           acc)))]))
                other-matches)))))
    (rewrite-proc-name child-make-proc)
-   (subst lhs-frm-id (rewrite-proc-lhs child-make-proc) rhs-from)))
+   (subst lhs-frm-id (rewrite-proc-lhs child-make-proc) rhs-from)
+   (rewrite-proc-id child-make-proc)))
 
 (define relation-coverage (make-parameter #f))
 
-(define-struct covered-case (name apps) #:inspector (make-inspector))
+(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 (apply-case c)
-  (struct-copy covered-case c [apps (add1 (covered-case-apps c))]))
+(define (covered-cases cov)
+  (hash-map (coverage-unwrap cov) (λ (k v) v)))
 
-(define (cover-case id name relation-coverage)
-  (hash-update! relation-coverage id apply-case (make-covered-case name 0)))
+(define-struct coverage (unwrap))
 
-(define (covered-cases relation-coverage)
-  (hash-map relation-coverage (λ (k v) v)))
+(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 fresh-coverage make-hasheq)
+;(define fresh-coverage (compose make-coverage make-hasheq))
 
 (define (do-leaf-match name pat w/extras proc)
   (let ([case-id (gensym)])
@@ -788,7 +798,8 @@
                          other-matches)
                  other-matches)))))
      name
-     w/extras)))
+     w/extras
+     case-id)))
 
 (define-syntax (test-match stx)
   (syntax-case stx ()
@@ -1835,5 +1846,5 @@
 
 (provide relation-coverage
          covered-cases
-         fresh-coverage
-         (struct-out covered-case))
+         (rename-out [fresh-coverage make-coverage])
+         coverage?)

collects/redex/private/struct.ss

@@ -9,7 +9,7 @@
          build-reduction-relation
          reduction-relation?
          empty-reduction-relation
-         make-rewrite-proc rewrite-proc? rewrite-proc-name rewrite-proc-lhs
+         make-rewrite-proc rewrite-proc? rewrite-proc-name rewrite-proc-lhs rewrite-proc-id
          (struct-out rule-pict))
 
 (define-struct rule-pict (arrow lhs rhs label side-conditions fresh-vars pattern-binds))
@@ -20,14 +20,15 @@
 ;;   we want to avoid doing it multiple times, so it is cached in a reduction-relation struct
 
 
-(define-values (make-rewrite-proc rewrite-proc? rewrite-proc-name rewrite-proc-lhs)
+(define-values (make-rewrite-proc rewrite-proc? rewrite-proc-name rewrite-proc-lhs rewrite-proc-id)
   (let ()
     (define-values (type constructor predicate accessor mutator) 
-      (make-struct-type 'rewrite-proc #f 3 0 #f '() #f 0))
+      (make-struct-type 'rewrite-proc #f 4 0 #f '() #f 0))
     (values constructor 
             predicate 
             (make-struct-field-accessor accessor 1 'name)
-            (make-struct-field-accessor accessor 2 'lhs))))
+            (make-struct-field-accessor accessor 2 'lhs)
+            (make-struct-field-accessor accessor 3 'id))))
 
 ;; lang : compiled-language
 ;; make-procs = (listof (compiled-lang -> proc))

collects/redex/private/tl-test.ss

@@ -1,8 +1,7 @@
 (module tl-test mzscheme
   (require "../reduction-semantics.ss"
            (only "reduction-semantics.ss" 
-                 relation-coverage fresh-coverage covered-cases
-                 make-covered-case covered-case-name)
+                 relation-coverage make-coverage covered-cases)
            "test-util.ss"
            (only "matcher.ss" make-bindings make-bind)
            scheme/match
@@ -1226,32 +1225,30 @@
             [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)])
+  (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)])]
+         [c (make-coverage R)]
+         [< (λ (c d) (string<? (car c) (car d)))])
     (parameterize ([relation-coverage c])
       (apply-reduction-relation R 4)
-      (test (covered-cases c) null)
+      (test (sort (covered-cases c) <)
+            '(("shortcut" . 0) ("side-condition" . 0) ("unnamed" . 0)))
       
       (apply-reduction-relation R 3)
-      (test (covered-cases c)
-            (list (make-covered-case "side-condition" 1)))
+      (test (sort (covered-cases c) <)
+            '(("shortcut" . 0) ("side-condition" . 1) ("unnamed" . 0)))
       
       (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)))))
+      (test (sort (covered-cases c) <)
+            '(("shortcut" . 1) ("side-condition" . 2) ("unnamed" . 1)))))
   
   (print-tests-passed 'tl-test.ss))