From 35de0b22d059e9526209636bf0aa53ede8aa5a24 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Mon, 30 Aug 2010 09:11:15 -0500
Subject: [PATCH] added a test coverage test suite

---
 .../tests/drracket/teaching-lang-coverage.rkt | 125 ++++++++++++++++++
 1 file changed, 125 insertions(+)
 create mode 100644 collects/tests/drracket/teaching-lang-coverage.rkt

diff --git a/collects/tests/drracket/teaching-lang-coverage.rkt b/collects/tests/drracket/teaching-lang-coverage.rkt
new file mode 100644
index 0000000000..43b34fa639
--- /dev/null
+++ b/collects/tests/drracket/teaching-lang-coverage.rkt
@@ -0,0 +1,125 @@
+#lang racket/base
+(require racket/gui/base
+         racket/class
+         mrlib/text-string-style-desc
+         "drracket-test-util.rkt"
+         (for-syntax racket/base))
+
+;; Test suite for the coverage annotations in the teaching languages.
+;; Each test case specifies a teaching language (via a regexp), a string
+;; to put in the definitions window and a list of strings that correspond to
+;; maximal uncovered regions from the original program. Running this file
+;; will fire up a drracket, put the program in the definitions, run the 
+;; program, ensure that the output is only whitespace and numbers, and then 
+;; make sure the coverage is as expected.
+
+;; NB: the results of executing each of these tests (ie the stuff that shows up in the 
+;; interactions window when you run the program) should be whitespace and numbers only
+;; (well, plus the prompt)
+
+
+(struct test (lang-regexp program uncovered line))
+
+(define-syntax (t stx)
+  (syntax-case stx ()
+    [(t a b c)
+     (with-syntax ([line (syntax-line #'t)])
+       #'(test a b c line))]))
+
+(define tests
+  (list (t #rx"Beginning Student$"
+           "(define (f x) x)"
+           '("x"))
+        (t #rx"Beginning Student$"
+           "(define (f x) x) (f 1)"
+           '())
+        (t #rx"Beginning Student$"
+           "(define-struct s (a b))"
+           '())
+        (t #rx"Beginning Student$"
+           #<<--
+(define (f x)
+  (... (cond
+         [(null? x) ???]
+         [else      (first x)
+                    (f (rest x))])))
+--
+           '())
+        
+        (t #rx"Intermediate Student$"
+           "(define-struct s (a b))"
+           '())
+        (t #rx"Intermediate Student$"
+           #<<--
+(define-struct foo (x))
+
+(: make-foo (Number -> foo))
+(: foo-x (foo -> Number))
+
+(define x (make-foo 5))
+(foo-x x)
+--
+           '())))
+
+;; get-annotate-output : drscheme-frame -> (listof str/ann)
+(define (get-annotated-output drs)
+  (let ([chan (make-channel)])
+    (queue-callback
+     (λ ()
+       (channel-put chan (get-string/style-desc (send drs get-definitions-text)))))
+    (channel-get chan)))
+
+;; returns #t if an element of the result of get-string/style-desc
+;; corresponds to an uncovered region of the editor
+(define (is-uncovered? ele)
+  (let ([style (list-ref ele 1)])
+    (and (list? style)
+         (let loop ([style style])
+           (cond
+             [(null? style) #f]
+             [else
+              (let ([fst (car style)]
+                    [snd (cadr style)])
+                (cond
+                  [(eq? fst 'background)
+                   (equal? snd '(0 0 0))]
+                  [else
+                   (loop (cddr style))]))])))))
+
+;; find-uncovered-text : list[get-string/style-desc result] -> (listof string)
+;; returns strings containing the uncovered text in the editor (in the order they appear in the file)
+(define (find-uncovered-text string/style-desc)
+  (map car (filter is-uncovered? string/style-desc)))
+
+(fire-up-drscheme-and-run-tests
+ (λ ()
+   (let* ([drr-frame (wait-for-drscheme-frame)]
+          [definitions-text (send drr-frame get-definitions-text)]
+          [interactions-text (send drr-frame get-interactions-text)])
+       
+     (let ([last-lang #f])
+       (for ([t (in-list tests)])
+         (let ([this-lang (test-lang-regexp t)])
+           (unless (equal? this-lang last-lang)
+             (set-language-level! (list #rx"How to Design Programs" this-lang))))
+         (clear-definitions drr-frame)
+         (send definitions-text insert (test-program t))
+         (do-execute drr-frame)
+         
+         (let ([result (fetch-output
+                        drr-frame
+                        (send interactions-text paragraph-start-position 2)
+                        (send interactions-text last-position))])
+           (unless (regexp-match #rx"^[ \n\t0-9>]*$" result)
+             (fprintf (current-error-port)
+                      "FAILED line ~a, got ~s for the output, but expected only digits and whitespace"
+                      (test-line t)
+                      result)))
+
+         (let ([got (find-uncovered-text (get-annotated-output drr-frame))])
+           (unless (equal? got (test-uncovered t))
+             (fprintf (current-error-port)
+                      "FAILED line ~a\n     got: ~s\nexpected: ~s\n"
+                      (test-line t)
+                      got 
+                      (test-uncovered t)))))))))