122 lines
4.2 KiB
Racket
122 lines
4.2 KiB
Racket
#lang racket/base
|
|
(require racket/gui/base
|
|
racket/class
|
|
mrlib/text-string-style-desc
|
|
"private/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"Advanced 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)])
|
|
(eq? style 'test-coverage-off)))
|
|
|
|
;; 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)]
|
|
[same-last-time? (and (regexp? last-lang)
|
|
(equal? (object-name last-lang)
|
|
(object-name this-lang)))])
|
|
(unless same-last-time?
|
|
(set! last-lang this-lang)
|
|
(set-language-level! (list #rx"How to Design Programs" this-lang))))
|
|
|
|
(clear-definitions drr-frame)
|
|
(insert-in-definitions drr-frame (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)))))))))
|