252 lines
11 KiB
Scheme
252 lines
11 KiB
Scheme
|
|
(module sample-solutions-one-window mzscheme
|
|
(require "drscheme-test-util.ss"
|
|
(lib "gui.ss" "tests" "utils")
|
|
mzlib/class
|
|
mzlib/list
|
|
mzlib/file
|
|
mred
|
|
framework
|
|
(prefix fw: framework))
|
|
|
|
(provide run-test)
|
|
|
|
(define (section->language section)
|
|
(cond
|
|
[(section . <= . 12) '("How to Design Programs" "Beginning Student")]
|
|
[(section . <= . 19) '("How to Design Programs" "Intermediate Student")]
|
|
[(section . <= . 29) '("How to Design Programs" "Intermediate Student with lambda")]
|
|
[else '("How to Design Programs" "Advanced Student")]))
|
|
|
|
(define sample-solutions-teachpack-filename
|
|
(build-path (collection-path "tests" "drscheme") "sample-solutions-testsuite-tp.scm"))
|
|
|
|
(define sample-solutions-dir
|
|
(let ([try1
|
|
(collection-path "solutions")]
|
|
[try2
|
|
(build-path (collection-path "mzlib")
|
|
'up
|
|
'up
|
|
'up
|
|
"robby"
|
|
"collects"
|
|
"solutions")])
|
|
(cond
|
|
[(directory-exists? try1) try1]
|
|
[else try2])))
|
|
|
|
(unless (directory-exists? sample-solutions-dir)
|
|
(error 'sample-solutions.ss "expected directory ~s to exist" sample-solutions-dir))
|
|
|
|
(set! sample-solutions-dir (normalize-path sample-solutions-dir))
|
|
|
|
(define toc (call-with-input-file (build-path sample-solutions-dir "toc.ss") read))
|
|
(define default-toc-entry '(#f ()))
|
|
|
|
(define labels
|
|
(let* ([all-info (call-with-input-file (build-path (collection-path "solutions")
|
|
'up 'up "proj" "book" "solutions"
|
|
"labels.scm") read)]
|
|
[ex-labels (filter (lambda (x) (and (string=? (substring (car x) 0 3) "ex:")
|
|
(> (string-length (car x)) 3)))
|
|
all-info)])
|
|
(map (lambda (x)
|
|
(cons (string-append (substring (car x) 3 (string-length (car x))) ".scm")
|
|
(cdr x)))
|
|
ex-labels)))
|
|
|
|
(define (filename->section filename)
|
|
(let* ([label (car (memf (lambda (x) (string=? (car x) filename)) labels))]
|
|
[section (car (cadr label))])
|
|
section))
|
|
|
|
(define sample-solutions
|
|
(sort
|
|
(filter (lambda (x)
|
|
(and (> (string-length x) 3)
|
|
(string=? "scm" (substring x (- (string-length x) 3) (string-length x)))
|
|
(memf (lambda (y) (string=? (car y) x)) labels)))
|
|
(directory-list sample-solutions-dir))
|
|
(lambda (fx fy)
|
|
(< (filename->section fx) (filename->section fy)))))
|
|
|
|
(define separator-sexp "should be")
|
|
|
|
(define (test-single-file filename)
|
|
(let* ([toc-entry (let ([lookup (assoc (string->symbol filename) toc)])
|
|
(if lookup
|
|
(cdr lookup)
|
|
default-toc-entry))]
|
|
[section (filename->section filename)]
|
|
[language (section->language section)]
|
|
[errors-ok? (car toc-entry)]
|
|
[teachpacks (cadr toc-entry)])
|
|
(let* ([drs-frame (wait-for-drscheme-frame)]
|
|
[definitions-text (send drs-frame get-definitions-text)]
|
|
[interactions-text (send drs-frame get-interactions-text)])
|
|
|
|
(run-one/sync
|
|
(lambda ()
|
|
;; update the program (cheat to hack around gc bug -- should really use file|open)
|
|
;; (this is also much more efficient, tho)
|
|
(send definitions-text load-file (build-path sample-solutions-dir filename))))
|
|
;; only bother changing the language dialog when necessary.
|
|
(unless (string=?
|
|
(run-one/sync
|
|
(lambda ()
|
|
(send interactions-text get-text
|
|
(send interactions-text paragraph-start-position 1)
|
|
(send interactions-text paragraph-end-position 1))))
|
|
(format "Language: ~a." (car (last-pair language))))
|
|
(set-language-level! language))
|
|
;; only bother changing the teachpacks when necessary.
|
|
(let* ([get-full-path
|
|
(lambda (teachpack)
|
|
(cond
|
|
[(absolute-path? teachpack)
|
|
(normal-case-path
|
|
(normalize-path
|
|
teachpack))]
|
|
[else
|
|
(normal-case-path
|
|
(normalize-path
|
|
(build-path
|
|
(collection-path "mzlib") 'up 'up
|
|
"teachpack" "htdp" teachpack)))]))]
|
|
[teachpack-should-be
|
|
(apply string-append
|
|
(map (lambda (tp) (format "Teachpack: ~a.~n" (get-full-path tp)))
|
|
(cons
|
|
sample-solutions-teachpack-filename
|
|
teachpacks)))]
|
|
[teachpack-is
|
|
(run-one/sync
|
|
(lambda ()
|
|
(send interactions-text get-text
|
|
(send interactions-text paragraph-start-position 2)
|
|
(send interactions-text paragraph-start-position
|
|
(+ 2 (length teachpacks) 1)))))] ;; add 1 for the always there teachpack
|
|
[teachpacks-already-set? (string=? teachpack-should-be teachpack-is)])
|
|
(unless teachpacks-already-set?
|
|
(fw:test:menu-select "Language" "Clear All Teachpacks")
|
|
(use-get/put-dialog
|
|
(lambda ()
|
|
(fw:test:menu-select "Language" "Add Teachpack..."))
|
|
sample-solutions-teachpack-filename)
|
|
(for-each (lambda (teachpack)
|
|
(use-get/put-dialog
|
|
(lambda ()
|
|
(fw:test:menu-select "Language" "Add Teachpack..."))
|
|
(get-full-path teachpack)))
|
|
teachpacks)))
|
|
(do-execute drs-frame)
|
|
|
|
;; kill the program, but only when it opens windows
|
|
(let ([open-user-windows?
|
|
(parameterize ([current-eventspace (send interactions-text get-user-eventspace)])
|
|
(not (null? (get-top-level-windows))))])
|
|
(when #t #;open-user-windows?
|
|
(printf "killing\n")
|
|
(let ([cust (send interactions-text get-user-custodian)])
|
|
(run-one/sync
|
|
(lambda ()
|
|
(custodian-shutdown-all cust))))
|
|
(let ([wait-for-kill-window
|
|
(lambda ()
|
|
(let ([f (get-top-level-focus-window)])
|
|
(and f (equal? (send f get-label)
|
|
"Evaluation Terminated"))))])
|
|
(poll-until wait-for-kill-window)
|
|
(fw:test:button-push "OK")
|
|
(wait-for-drscheme-frame #f)
|
|
(printf "killed\n"))))
|
|
|
|
(check-for-red-text filename drs-frame)
|
|
|
|
;; still check equal pairs when there is a sanctioned error.
|
|
(cond
|
|
[(and (not errors-ok?)
|
|
(has-error? drs-frame))
|
|
=>
|
|
(lambda (err-msg)
|
|
(printf "ERROR: ~a: found error, but should be no errors (section ~a):~n ~a\n teachpacks: ~a\n"
|
|
filename
|
|
section
|
|
err-msg
|
|
teachpacks))]
|
|
[else
|
|
(let* ([output (fetch-output drs-frame)]
|
|
[port (open-input-string output)])
|
|
(let loop ([last #f]
|
|
[equal-count 1])
|
|
(let ([sexp (with-handlers ([(lambda (exn) #t)
|
|
(lambda (exn) exn)])
|
|
(read port))])
|
|
(unless (eof-object? sexp)
|
|
(cond
|
|
[(and (not last) (equal? sexp separator-sexp))
|
|
(printf "ERROR: ~a: found = as first sexp~n" filename)]
|
|
[(and last (equal? separator-sexp sexp))
|
|
(let ([after (with-handlers ([(lambda (exn) #t)
|
|
(lambda (exn) exn)])
|
|
(read port))])
|
|
(unless (equal? after last)
|
|
(printf "ERROR: ~a: pair #~a mismatched.\n got ~s\nexpected ~s\nteachpacks: ~a\n"
|
|
filename equal-count
|
|
(if (exn? last) (exn-message last) last)
|
|
(if (exn? after) (exn-message after) after)
|
|
teachpacks))
|
|
(loop after (+ equal-count 1)))]
|
|
[else (loop sexp equal-count)])))))]))))
|
|
|
|
(define (check-for-red-text filename drs-frame)
|
|
(when (run-one/sync
|
|
(lambda ()
|
|
(send drs-frame get-test-coverage-info-visible?)))
|
|
(printf "ERROR: ~a: test coverage shows uncovered code\n"
|
|
filename)))
|
|
|
|
;; has-test-coverage-annotations? : text -> (union (list ...) #f)
|
|
(define (has-test-coverage-annotations? definitions-text)
|
|
(let loop ([snip (send definitions-text find-first-snip)]
|
|
[black #f]
|
|
[red #f])
|
|
(cond
|
|
[snip
|
|
(let* ([style (send snip get-style)]
|
|
[foreground (send style get-foreground)])
|
|
(cond
|
|
[(black? foreground)
|
|
(if red
|
|
(list (get-snip-info definitions-text snip) red)
|
|
(loop (send snip next) (get-snip-info definitions-text snip) red))]
|
|
[(red? foreground)
|
|
(if black
|
|
(list black (get-snip-info definitions-text snip))
|
|
(loop (send snip next) black (get-snip-info definitions-text snip)))]
|
|
[else
|
|
(loop (send snip next) black red)]))]
|
|
[else #f])))
|
|
|
|
(define (get-snip-info definitions-text snip)
|
|
(let* ([pos (send definitions-text get-snip-position snip)]
|
|
[para (send definitions-text position-paragraph pos)]
|
|
[para-start (send definitions-text paragraph-start-position para)])
|
|
(list (+ para 1)
|
|
(- pos para-start))))
|
|
|
|
(define red-color (make-object color% "firebrick"))
|
|
(define (red? c)
|
|
(and (= (send c red) (send red-color red))
|
|
(= (send c green) (send red-color green))
|
|
(= (send c blue) (send red-color blue))))
|
|
|
|
(define (black? c)
|
|
(and (zero? (send c red))
|
|
(zero? (send c green))
|
|
(zero? (send c blue))))
|
|
|
|
(define (run-test)
|
|
(for-each test-single-file sample-solutions)))
|