8d6e9e79a4
It looks like run-teaching-program hasn't been touched in quite a while. To begin with, the "rewrite-module" function used to add code to print out values of non-define exprs, but this is no longer necessary. In fact, the only thing that it does now is to discard "provide" statements, and even this may be unnecessary. I rewrote big chunks of this (short) file to introduce defines, eliminate unnecessary functions, and add stepper- skip-completely annotations to the requires associated with teachpacks. Also, it appears that the 'rep' argument to expand-teaching-program was entirely superfluous; I removed it from the argument list, and also from the three places in the main tree (deinprogramm, lang, and the stepper) that call this function. Let me know of any problems seen with teachpack requires....
303 lines
12 KiB
Racket
303 lines
12 KiB
Racket
#lang scheme
|
|
|
|
(require stepper/private/shared
|
|
stepper/private/model
|
|
tests/utils/sexp-diff
|
|
lang/run-teaching-program
|
|
(only-in srfi/13 string-contains)
|
|
scheme/contract
|
|
"language-level-model.rkt")
|
|
|
|
|
|
;; A SIMPLE EXAMPLE OF USING THIS FRAMEWORK:
|
|
|
|
;; note that this example uses the abbreviation from test-abbrev; don't uncomment it!
|
|
|
|
#;
|
|
(let* ([defs1 `((define (a x) (+ x 5)) (define b a))]
|
|
[defs2 (append defs1 `((define c a)))])
|
|
(apply ;; you can abstract over this application with a define-syntax
|
|
run-one-test
|
|
(tt 'top-ref4 ;; - the name of the test
|
|
m:intermediate ;; - the language level (or levels) to run in
|
|
,@defs1 (define c b) (c 3) ;; - the expressions to test (everything up to the first ::)
|
|
:: ,@defs1 (define c {b}) ;; - the steps; the '::' divides steps, repeated '->'s indicate
|
|
-> ,@defs1 (define c {a}) ;; that the 'before' of the second step is the 'after' of
|
|
:: ,@defs2 ({c} 3) ;; the first one. the curly braces indicate the hilighted sexp.
|
|
-> ,@defs2 ({a} 3)
|
|
:: ,@defs2 {(a 3)}
|
|
-> ,@defs2 {(+ 3 5)}
|
|
-> ,@defs2 {8})))
|
|
|
|
|
|
|
|
|
|
;; PARAMETERS THAT CONTROL TESTING
|
|
|
|
(provide test-directory
|
|
display-only-errors
|
|
show-all-steps
|
|
disable-stepper-error-handling)
|
|
|
|
(define test-directory (find-system-path 'temp-dir))
|
|
|
|
;; use this parameter to suppress output except in error cases:
|
|
(define display-only-errors (make-parameter #f))
|
|
|
|
;; use this parameter to show successful steps as well as unsuccessful ones:
|
|
(define show-all-steps (make-parameter #f))
|
|
|
|
;; use this parameter to prevent the stepper from capturing errors
|
|
;; (so that you can take advantage of DrRacket's error reporting)
|
|
(define disable-stepper-error-handling (make-parameter #f))
|
|
|
|
|
|
;; DATA DEFINITIONS:
|
|
|
|
;; a step is one of
|
|
;; - `(before-after ,before ,after) where before and after are sexp-with-hilite's
|
|
;; - `(error ,err-msg) where err-msg is a string
|
|
;; - `(before-error ,before ,err-msg) where before is an sexp-with-hilite and err-msg is a string
|
|
;; - `(finished-stepping)
|
|
;; or
|
|
;; - `(ignore)
|
|
(define (step? sexp)
|
|
(match sexp
|
|
[(list 'before-after before after) #t]
|
|
[(list 'error (? string? msg)) #t]
|
|
[(list 'before-error before (? string? msg)) #t]
|
|
[(list 'finished-stepping) #t]
|
|
[(list 'ignore) #t]
|
|
[else #f]))
|
|
|
|
;; a model-or-models is one of
|
|
;; - an ll-model, or
|
|
;; - (listof ll-model?)
|
|
(define model-or-models/c (or/c ll-model? (listof ll-model?)))
|
|
|
|
;; THE METHOD THAT RUNS A TEST:
|
|
|
|
(provide/contract [run-one-test (symbol? model-or-models/c string? (listof step?) (listof (list/c string? string?)) . -> . boolean?)])
|
|
;; run-one-test : symbol? model-or-models? string? steps? extra-files -> boolean?
|
|
|
|
;; the ll-model determines the behavior of the stepper w.r.t. "language-level"-y things:
|
|
;; how should values be rendered, should steps be displayed (i.e, will the input & output
|
|
;; steps look just the same), etc. If
|
|
|
|
;; the string contains a program to be evaluated. The string is an ironclad if blunt way
|
|
;; of ensuring that the program has no syntax information associated with it.
|
|
|
|
;; the steps lists the desired steps. The easiest way to understand these is probably just to
|
|
;; read the code for the comparison given in "compare-steps", below.
|
|
|
|
;; the extra-files contain a list of other files that must occur in the same directory.
|
|
|
|
;; run the named test, return #t if a failure occurred during the test.
|
|
|
|
(define (run-one-test name models exp-str expected-steps extra-files)
|
|
(unless (display-only-errors)
|
|
(printf "running test: ~v\n" name))
|
|
(let ([error-has-occurred-box (box #f)])
|
|
(test-sequence/many models exp-str expected-steps extra-files error-has-occurred-box)
|
|
(if (unbox error-has-occurred-box)
|
|
(begin (fprintf (current-error-port) "...Error has occurred during test: ~v\n" name)
|
|
#f)
|
|
#t)))
|
|
|
|
(provide/contract [string->expanded-syntax-list (-> ll-model? string? (listof syntax?))])
|
|
(define (string->expanded-syntax-list ll-model exp-str)
|
|
(define expander-thunk ((string->expander-thunk ll-model exp-str)))
|
|
(let loop ()
|
|
(define next (expander-thunk))
|
|
(cond [(eof-object? next) '()]
|
|
[else (cons next (loop))])))
|
|
|
|
|
|
|
|
|
|
|
|
;; test-sequence/many : model-or-models/c string? steps? -> (void)
|
|
;; run a given test through a bunch of language models (or just one).
|
|
(define (test-sequence/many models exp-str expected-steps extra-files error-box)
|
|
(cond [(list? models)(for-each (lambda (model) (test-sequence model exp-str expected-steps extra-files error-box))
|
|
models)]
|
|
[else (test-sequence models exp-str expected-steps extra-files error-box)]))
|
|
|
|
(define port null)
|
|
|
|
;; test-sequence : ll-model? string? steps? extra-files? -> (void)
|
|
;; given a language model and an expression and a sequence of steps,
|
|
;; check to see whether the stepper produces the desired steps
|
|
(define (test-sequence the-ll-model exp-str expected-steps extra-files error-box)
|
|
(parameterize ([current-directory test-directory])
|
|
(for ([f (in-list extra-files)])
|
|
(display-to-file (second f) (first f) #:exists 'truncate))
|
|
(define expander-thunk (string->expander-thunk the-ll-model exp-str))
|
|
(match the-ll-model
|
|
[(struct ll-model (namespace-spec render-settings enable-testing?))
|
|
(unless (display-only-errors)
|
|
(printf "testing string: ~v\n" exp-str))
|
|
(test-sequence/core render-settings expander-thunk expected-steps error-box)
|
|
(close-input-port port)
|
|
(delete-file "stepper-test")
|
|
(for ([f (in-list extra-files)])
|
|
(delete-file (first f)))])))
|
|
|
|
|
|
;; given a language level model and a string, produce a thunk that returns
|
|
;; syntax objects expanded in the given language:
|
|
;; EFFECT: creates a file called "stepper-test" in test-directory
|
|
(define (string->expander-thunk the-ll-model exp-str)
|
|
(parameterize ([current-directory test-directory])
|
|
(match the-ll-model
|
|
[(struct ll-model (namespace-spec render-settings enable-testing?))
|
|
(let ([filename "stepper-test"])
|
|
(display-to-file exp-str filename #:exists 'truncate)
|
|
(set! port (open-input-file "stepper-test"))
|
|
(let* (#;[port (open-input-file filename)]
|
|
[module-id (gensym "stepper-module-name-")])
|
|
;; thunk this so that syntax errors happen within the error handlers:
|
|
(lambda () (expand-teaching-program port read-syntax namespace-spec '() module-id enable-testing?))))])))
|
|
|
|
;; test-sequence/core : render-settings? boolean? syntax? steps?
|
|
;; this is a front end for calling the stepper's "go"; the main
|
|
;; responsibility here is to fake the behavior of DrRacket and collect the
|
|
;; resulting steps.
|
|
(define (test-sequence/core render-settings expanded-thunk expected-steps error-box)
|
|
(let* ([current-error-display-handler (error-display-handler)]
|
|
[all-steps
|
|
(append expected-steps '((finished-stepping)))]
|
|
;; the values of certain parameters aren't surviving; create
|
|
;; lexical bindings for them:
|
|
[current-show-all-steps (show-all-steps)]
|
|
[current-display-only-errors (display-only-errors)]
|
|
[receive-result
|
|
(lambda (result)
|
|
(if (null? all-steps)
|
|
(warn error-box
|
|
'test-sequence
|
|
"ran out of expected steps. Given result: ~v" result)
|
|
(begin
|
|
(if (compare-steps result (car all-steps) error-box)
|
|
(when (and current-show-all-steps (not current-display-only-errors))
|
|
(printf "test-sequence: steps match for expected result: ~v\n"
|
|
(car all-steps)))
|
|
(warn error-box
|
|
'test-sequence
|
|
"steps do not match\n given: ~v\nexpected: ~v"
|
|
(show-result result error-box)
|
|
(car all-steps)))
|
|
(set! all-steps (cdr all-steps)))))]
|
|
[iter-caller
|
|
(lambda (init iter)
|
|
(init)
|
|
(call-iter-on-each (expanded-thunk) iter))])
|
|
(let/ec escape
|
|
(parameterize ([error-escape-handler (lambda () (escape (void)))])
|
|
(go iter-caller receive-result render-settings
|
|
#:disable-error-handling? (disable-stepper-error-handling))))
|
|
(error-display-handler current-error-display-handler)))
|
|
|
|
(define-namespace-anchor n-anchor)
|
|
|
|
;; it seems to be okay to use the same namespace for all of the tests...
|
|
(define test-namespace (make-base-namespace))
|
|
(namespace-attach-module (namespace-anchor->empty-namespace n-anchor)
|
|
'mzlib/pconvert-prop
|
|
test-namespace)
|
|
(namespace-attach-module (namespace-anchor->empty-namespace n-anchor)
|
|
'racket/private/promise
|
|
test-namespace)
|
|
(parameterize ([current-namespace test-namespace])
|
|
(namespace-require 'test-engine/racket-tests)
|
|
;; make the test engine happy by adding a binding for test~object:
|
|
(namespace-set-variable-value! 'test~object #f))
|
|
|
|
;; call-iter-on-each : (-> syntax?) (syntax? (-> 'a) -> 'a) -> void/c
|
|
;; call the given iter on each syntax in turn (iter bounces control
|
|
;; back to us by calling the followup-thunk).
|
|
(define (call-iter-on-each stx-thunk iter)
|
|
(parameterize ([current-namespace test-namespace])
|
|
(let iter-loop ()
|
|
(let* ([next (stx-thunk)]
|
|
[followup-thunk (if (eof-object? next)
|
|
void
|
|
iter-loop)]
|
|
[expanded (expand next)])
|
|
;;(printf "~v\n" expanded)
|
|
(iter expanded followup-thunk)))))
|
|
|
|
|
|
(define (warn error-box who fmt . args)
|
|
(set-box! error-box #t)
|
|
(fprintf (current-error-port) "~a: ~a\n" who (apply format fmt args)))
|
|
|
|
|
|
;; (-> step-result? sexp? boolean?)
|
|
(define (compare-steps actual expected error-box)
|
|
(match expected
|
|
[`(before-after ,before ,after)
|
|
(and (before-after-result? actual)
|
|
(andmap (lambda (fn expected name)
|
|
(unless (list? (fn actual))
|
|
(warn error-box
|
|
'compare-steps "not a list: ~v"
|
|
(syntax->hilite-datum (fn actual))))
|
|
(noisy-equal? (map syntax->hilite-datum
|
|
(fn actual))
|
|
expected
|
|
name
|
|
error-box))
|
|
(list before-after-result-pre-exps
|
|
before-after-result-post-exps)
|
|
(list before after)
|
|
(list 'before 'after)))]
|
|
[`(error ,err-msg)
|
|
(and (error-result? actual)
|
|
(string-contains (error-result-err-msg actual) err-msg))]
|
|
[`(before-error ,before ,err-msg)
|
|
(and (before-error-result? actual)
|
|
(and (noisy-equal? (map syntax->hilite-datum
|
|
(before-error-result-pre-exps actual))
|
|
before
|
|
'before
|
|
error-box)
|
|
(equal? err-msg (before-error-result-err-msg actual))))]
|
|
[`(finished-stepping) (finished-stepping? actual)]
|
|
[`(ignore) (warn error-box
|
|
'compare-steps "ignoring one step") #t]
|
|
[else (begin (warn error-box
|
|
'compare-steps
|
|
"unexpected expected step type: ~v" expected)
|
|
#f)]))
|
|
|
|
|
|
|
|
;; used to display results in an error message
|
|
(define (show-result r error-box)
|
|
(if (before-after-result? r)
|
|
(list 'before-after-result
|
|
(map (lambda (fn)
|
|
(unless (list? (fn r))
|
|
(warn error-box
|
|
'show-result "not a list: ~v"
|
|
(syntax->hilite-datum (fn r))))
|
|
(map syntax->hilite-datum
|
|
(fn r)))
|
|
(list before-after-result-pre-exps
|
|
before-after-result-post-exps)))
|
|
r))
|
|
|
|
;; noisy-equal? : (any any . -> . boolean)
|
|
;; like equal?, but prints a noisy error message
|
|
(define (noisy-equal? actual expected name error-box)
|
|
(if (equal? actual expected)
|
|
#t
|
|
(begin (warn error-box 'not-equal?
|
|
"~.s:\nactual: ~e =/= \nexpected: ~e\n here's the diff: ~e" name actual expected (sexp-diff actual expected))
|
|
#f)))
|
|
|
|
|
|
|
|
|