4669b6bfed
(the names of the textbooks are no longer explicit in the hierarchy of the languages so just specify "Beginning Student", for example)
120 lines
4.1 KiB
Racket
120 lines
4.1 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-drracket-and-run-tests
|
|
(λ ()
|
|
(let* ([drr-frame (wait-for-drracket-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 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)
|
|
(eprintf "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))
|
|
(eprintf "FAILED line ~a\n got: ~s\nexpected: ~s\n"
|
|
(test-line t)
|
|
got
|
|
(test-uncovered t)))))))))
|