(module utils mzscheme
(require (lib "string.ss") (lib "plt-match.ss"))
(define-syntax (sourced-match stx)
(syntax-case stx ()
[(_ val clause ...)
(datum->syntax-object
stx
(syntax-e (local-expand (syntax/loc stx (match val clause ...))
'expression '()))
stx
stx)]))
(define-syntax (define-predicate-matcher stx)
(syntax-case stx ()
[(_ pred)
(identifier? #'pred)
(let* ([name (symbol->string (syntax-e #'pred))]
[id (lambda (sfx)
(let ([sym (string->symbol (string-append name sfx))])
(datum->syntax-object stx sym stx stx)))])
(with-syntax ([pred: (id ":")] [pred? (id "?")])
#'(define-match-expander pred:
(syntax-rules (pred:) [(pred: pat) (? pred? pat)]))))]))
(define-predicate-matcher number)
(define-predicate-matcher integer)
(define-predicate-matcher symbol)
(define-predicate-matcher string)
(define-predicate-matcher boolean)
(provide (rename sourced-match match)
number: integer: symbol: string: boolean:)
(provide *if)
(define-syntax *if
(syntax-rules () [(*if cond then else) (if cond then else)]))
(provide *list? *cons)
(define (*list? x)
(or (null? x) (pair? x)))
(define (*cons x l)
(if (*list? l) (cons x l) (raise-type-error 'cons "list" 1 x l)))
(define good-char "(?:[ \t\r\na-zA-Z0-9_{}!?*/<=>:+-]|[.][.][.])")
(define good-string "[^\"\\']*(?:''[^\"\\']*)*")
(define expr-re
(regexp (string-append "^"
good-char"*"
"(?:'"good-string"'"good-char"*)*"
"$")))
(define string-re
(regexp (string-append "'("good-string")'")))
(provide string->sexpr)
(define (string->sexpr str)
(unless (string? str)
(raise-type-error 'string->sexpr "string" 0 str))
(unless (regexp-match expr-re str)
(error 'string->sexpr "syntax error (bad contents)"))
(let ([sexprs (read-from-string-all
(regexp-replace*
"''" (regexp-replace* string-re str "\"\\1\"") "'"))])
(if (= 1 (length sexprs))
(car sexprs)
(error 'string->sexpr "bad syntax (multiple expressions)"))))
(define (transform-fail:syntax thunk from to)
(with-handlers ([exn:fail:syntax?
(lambda (e)
(raise (make-exn:fail:syntax
(string->immutable-string
(regexp-replace (format "^~a:" from)
(exn-message e)
(format "~a:" to)))
(exn-continuation-marks e)
(exn:fail:syntax-exprs e))))])
(thunk)))
(provide make-transformer)
(define (make-transformer literals from+to-list)
(define transformer
(transform-fail:syntax
(lambda () (eval `(syntax-rules ,literals ,@from+to-list)))
'syntax
'transform))
(lambda (expr)
(syntax-object->datum (transformer (datum->syntax-object #f expr)))))
(provide test test-mode test-postprocess)
(define test-mode (make-parameter 'report))
(define test-inspector (make-parameter (current-inspector)))
(define test-postprocess (make-parameter values))
(define (install-test-inspector)
(test-inspector (current-inspector))
(current-inspector (make-inspector))
(print-struct #t))
(define-syntax (test stx)
(unless (memq (syntax-local-context) '(top-level module module-begin))
(raise-syntax-error
#f "can be used only as a top-level expression"
stx))
(syntax-case* stx (=> <= =error> <error=)
(lambda (x y) (eq? (syntax-e x) (syntax-e y)))
[(test expr)
(syntax/loc stx (test-1 expr 'expr))]
[(test expr1 => expr2)
(syntax/loc stx (test-2 expr1 'expr1 expr2 'expr2))]
[(test expr2 <= expr1)
(syntax/loc stx (test-2 expr1 'expr1 expr2 'expr2))]
[(test expr =error> msg-re)
(syntax/loc stx
(test-e (lambda () ((test-postprocess) expr)) 'expr msg-re))]
[(test msg-re <error= expr)
(syntax/loc stx
(test-e (lambda () ((test-postprocess) expr)) 'expr msg-re))]))
(define-struct (exn:test exn) ())
(define (test-error fmt . args)
(parameterize ([current-inspector (test-inspector)]
[print-struct #t])
(let ([msg (string-append "Test failure: " (apply format fmt args))])
(case (test-mode)
[(report) (fprintf (current-error-port) "~a\n" msg)]
[(verbose error)
(raise (make-exn:test (string->immutable-string msg)
(current-continuation-marks)))]
[else (error 'test "bad test-mode: ~e" (test-mode))]))))
(define (test-ok label)
(parameterize ([current-inspector (test-inspector)]
[print-struct #t])
(when (eq? 'verbose (test-mode))
(fprintf (current-error-port) "Test passed: ~e\n" label))
(void)))
(define (test-1 val expr)
(if ((test-postprocess) val)
(test-ok expr)
(test-error "~e failed" expr)))
(define (test-2 val1 expr1 val2 expr2)
(parameterize ([current-inspector (test-inspector)])
(let ([val1 ((test-postprocess) val1)]
[val2 ((test-postprocess) val2)])
(if (equal? val1 val2)
(test-ok expr1)
(test-error "~e failed: got ~e, but expected ~e" expr1 val1 val2)))))
(define (test-e thunk expr msg-re)
(let ([r (with-handlers ([exn:fail? (lambda (e) e)]) (thunk))])
(cond
[(not (exn? r)) (test-error "~e did not signal an error" expr)]
[(not (regexp-match-positions (simple-glob->regexp msg-re)
(exn-message r)))
(test-error "mismatched error message in ~e (expecting \"~a\"): ~a"
expr msg-re (exn-message r))]
[else (test-ok expr)])))
(define glob-item-re
(regexp (string-append "(?:"
"[\\]." "|"
"[*?]" ")")))
(define (simple-glob->regexp glob)
(let loop ([i 0] [ps (regexp-match-positions* glob-item-re glob)] [r '()])
(if (null? ps)
(regexp (apply string-append
(reverse! (cons (regexp-quote (substring glob i)) r))))
(loop (cdar ps) (cdr ps)
(cons (if (= 1 (- (cdar ps) (caar ps)))
(if (equal? #\* (string-ref glob (caar ps))) ".*" ".")
(substring glob (caar ps) (cdar ps)))
(if (= i (caar ps))
r (cons (regexp-quote (substring glob i (caar ps)))
r)))))))
(install-test-inspector)
(provide any? list-of sexp-of box-of union-of intersection-of false? true?)
(define (any? x) #t)
(define (list-of pred?)
(define (list-of-proc l) (and (*list? l) (andmap pred? l)))
list-of-proc)
(define (sexp-of pred?) (define (sexp-of-proc s)
(let loop ([s s]) (or (pred? s) (and (*list? s) (andmap loop s)))))
sexp-of-proc)
(define (box-of pred?)
(define (box-of-proc x) (and (box? x) (pred? (unbox x))))
box-of-proc)
(define (union-of . preds)
(define (union-of-proc x) (ormap (lambda (p?) (p? x)) preds))
union-of-proc)
(define (intersection-of . preds)
(define (intersection-of-proc x) (andmap (lambda (p?) (p? x)) preds))
intersection-of-proc)
(define (false? x) (not x))
(define (true? x) (not (not x)))
)