...
svn: r14505
This commit is contained in:
parent
8476e13064
commit
08fec4f10e
84
collects/tests/stepper/test-abbrev.ss
Normal file
84
collects/tests/stepper/test-abbrev.ss
Normal file
|
@ -0,0 +1,84 @@
|
|||
#lang scheme
|
||||
|
||||
(require (for-syntax scheme/mpair))
|
||||
|
||||
(provide tt)
|
||||
|
||||
;; tt : eli's convenient short-cut syntactic form for defining tests.
|
||||
|
||||
;; here's an example of how you might use it:
|
||||
#;(let* ([defs1 `((define (a x) (+ x 5)) (define b a))]
|
||||
[defs2 (append defs1 `((define c a)))])
|
||||
(tt 'top-ref4 m:intermediate
|
||||
,@defs1 (define c b) (c 3)
|
||||
:: ,@defs1 (define c {b})
|
||||
-> ,@defs1 (define c {a})
|
||||
:: ,@defs2 ({c} 3)
|
||||
-> ,@defs2 ({a} 3)
|
||||
:: ,@defs2 {(a 3)}
|
||||
-> ,@defs2 {(+ 3 5)}
|
||||
-> ,@defs2 {8}))
|
||||
|
||||
|
||||
|
||||
(define-syntax (tt stx)
|
||||
(define (maybe-mlist->list r)
|
||||
(if (mpair? r)
|
||||
(mlist->list r)
|
||||
r))
|
||||
(define (split l)
|
||||
(let loop ([l l] [r '()])
|
||||
(cond [(null? l) (reverse (map maybe-mlist->list r))]
|
||||
[(symbol? (car l)) (loop (cdr l) (cons (car l) r))]
|
||||
[(or (null? r) (not (mpair? (car r))))
|
||||
(loop (cdr l) (cons (mlist (car l)) r))]
|
||||
[else (mappend! (car r) (mlist (car l)))
|
||||
(loop (cdr l) r)])))
|
||||
(define (process-hilites s)
|
||||
(syntax-case s ()
|
||||
[(x) (eq? #\{ (syntax-property s 'paren-shape))
|
||||
(with-syntax ([x (process-hilites #'x)]) #'(hilite x))]
|
||||
[(x . y) (let* ([x0 #'x]
|
||||
[y0 #'y]
|
||||
[x1 (process-hilites #'x)]
|
||||
[y1 (process-hilites #'y)])
|
||||
(if (and (eq? x0 x1) (eq? y0 y1))
|
||||
s
|
||||
(with-syntax ([x x1] [y y1]) #'(x . y))))]
|
||||
[_else s]))
|
||||
(define (process stx)
|
||||
(split (map (lambda (s)
|
||||
(if (and (identifier? s)
|
||||
(memq (syntax-e s) '(:: -> error:)))
|
||||
(syntax-e s)
|
||||
(process-hilites s)))
|
||||
(syntax->list stx))))
|
||||
(define (parse l)
|
||||
(syntax-case l (::)
|
||||
[(fst :: rest ...)
|
||||
(cons #'fst
|
||||
(let loop ([rest #'(rest ...)])
|
||||
(syntax-case rest (:: -> error:)
|
||||
[(error: (err)) (list #'(error err))]
|
||||
[() (list #'(finished-stepping))]
|
||||
[(x -> y) (list #'(before-after x y) #'(finished-stepping))]
|
||||
[(x -> error: (err)) (list #'(before-error x err))]
|
||||
[(x -> y :: . rest)
|
||||
(cons #'(before-after x y) (loop #'rest))]
|
||||
[(x -> y -> . rest)
|
||||
(cons #'(before-after x y) (loop #'(y -> . rest)))])))]))
|
||||
(syntax-case stx (::)
|
||||
[(_ name ll-models . rest)
|
||||
(with-syntax ([(exprs arg ...) (parse (process #'rest))])
|
||||
(quasisyntax/loc stx
|
||||
(list name
|
||||
ll-models
|
||||
;printf "exprs = ~s\n args = ~s\n"
|
||||
(exprs->string `exprs) `(arg ...))))]))
|
||||
|
||||
|
||||
;; (-> (listof sexp) string?)
|
||||
(define (exprs->string exprs)
|
||||
(apply string-append
|
||||
(cdr (apply append (map (lambda (x) (list " " (format "~s" x)))
|
||||
exprs)))))
|
|
@ -90,7 +90,13 @@
|
|||
;; 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.
|
||||
|
||||
;; run the named test, return #t if a failure occurred during the test
|
||||
;; run the named test, return #t if a failure occurred during the test.
|
||||
|
||||
;; WARNING: evaluating code expanded using run-teaching-program causes mutation of the
|
||||
;; current namespace. Unfortunately, wrapping a parameterize around each test (i.e., in this
|
||||
;; file) causes unacceptable slowdown and severe weirdness. I tried saving and restoring
|
||||
;; the namespace through mutation, and got severe weirdness again.
|
||||
|
||||
(define (run-one-test name models exp-str expected-steps)
|
||||
(unless (display-only-errors)
|
||||
(printf "running test: ~v\n" name))
|
||||
|
|
|
@ -13,6 +13,7 @@
|
|||
|
||||
)
|
||||
|
||||
|
||||
(define list-of-tests null)
|
||||
|
||||
(define (add-test test)
|
||||
|
@ -1425,12 +1426,10 @@
|
|||
;; run whatever tests are enabled (intended for interactive use):
|
||||
(define (ggg)
|
||||
(parameterize (#;[disable-stepper-error-handling #t]
|
||||
#;[display-only-errors #f]
|
||||
#;[display-only-errors #t]
|
||||
#;[store-steps #f]
|
||||
#;[show-all-steps #t])
|
||||
#;(run-tests '(check-expect check-within check-within-bad check-error) #;'(#;check-expect #;check-expect-2 check-within check-within-bad check-error))
|
||||
#;(run-tests '(check-expect forward-ref check-within #;check-within-bad #;check-error) #;'(#;check-expect #;check-expect-2 check-within check-within-bad check-error))
|
||||
#;(run-tests '(teachpack-universe))
|
||||
(run-all-tests)))
|
||||
|
||||
|
||||
|
||||
|
|
Loading…
Reference in New Issue
Block a user