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 (eprintf "...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)
|
|
(eprintf "~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)))
|
|
|
|
|
|
|
|
|