86 lines
2.9 KiB
Racket
86 lines
2.9 KiB
Racket
#lang racket
|
|
|
|
(require (for-syntax scheme/mpair))
|
|
|
|
(provide t)
|
|
|
|
;; t : 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)))])
|
|
(t '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 (t 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)))))
|