diff --git a/collects/honu/private/tools/test.ss b/collects/honu/private/tools/test.ss new file mode 100644 index 0000000000..0a491cfb06 --- /dev/null +++ b/collects/honu/private/tools/test.ss @@ -0,0 +1,112 @@ +(module test mzscheme + + (require (lib "list.ss")) + + #| + Test case and test suite macros: + + Expressions: + (test-case NAME EXPR PREDICATE) + (test-suite NAME CASE ...) + + Definitions: + (define-test-case NAME EXPR PREDICATE) + (define-test-suite NAME CASES ...) + |# + + (define (report? obj) (or (void? obj) (list? obj))) + + (define (exn-sexp exn) + `(error ,(exn-message exn))) + + (define-for-syntax (syntax-rest stx) + (syntax-case stx () [(_ . REST) #'REST])) + + (define-for-syntax (translate-predicate stx) + (syntax-case stx (equal: error: pred:) + [(equal: VALUE) + #`(lambda (name expr thunk) + (lambda () + (with-handlers ([(lambda (exn) #t) + (lambda (exn) `(,name : ,expr raised ,(exn-sexp exn)))]) + (let* ([result (thunk)]) + (with-handlers ([(lambda (exn) #t) + (lambda (exn) + `(,name : expected value VALUE raised ,(exn-sexp exn)))]) + (let* ([expected VALUE]) + (if (equal? result expected) + (void) + `(,name : ,expr = ,result != ,expected))))))))] + [error: + #`(lambda (name expr thunk) + (lambda () + (with-handlers ([(lambda (exn) #t) (lambda (exn) (void))]) + (let* ([result (thunk)]) + `(,name : ,expr = ,result but expected error)))))] + [(error: PRED) + #`(lambda (name expr thunk) + (lambda () + (with-handlers + ([(lambda (exn) #t) + (lambda (exn) + (with-handlers + ([(lambda (exn) #t) + (lambda (exn) + `(,name : predicate PRED raised ,(exn-sexp exn)))]) + (if (PRED exn) + (void) + `(,name : ,expr raised ,(exn-sexp exn) which failed PRED))))]) + (let* ([result (thunk)]) + `(,name : ,expr = ,result but expected error)))))] + [(pred: PRED) + #`(lambda (name expr thunk) + (lambda () + (with-handlers ([(lambda (exn) #t) + (lambda (exn) `(,name : ,expr raised ,(exn-sexp exn)))]) + (let* ([result (thunk)]) + (with-handlers ([(lambda (exn) #t) + (lambda (exn) + `(,name : predicate PRED raised ,(exn-sexp exn)))]) + (if (PRED result) + (void) + `(,name : ,expr = ,result failed PRED)))))))] + )) + + (define-for-syntax (translate-test-case stx) + (syntax-case stx () + [(NAME EXPR PREDICATE) + #`(#,(translate-predicate #'PREDICATE) 'NAME 'EXPR (lambda () EXPR))])) + + (define-for-syntax (translate-test-suite stx) + (syntax-case stx () + [(NAME CASE ...) + #`(let* ([cases (list CASE ...)]) + (lambda () + (let* ([reports (map (lambda (case) (case)) cases)] + [errors (filter (lambda (report) (not (void? report))) reports)]) + (cond [(null? errors) (void)] + [(= (length errors) 1) (cons 'NAME (first errors))] + [else (cons 'NAME (cons ': errors))]))))])) + + (define-for-syntax (translate-define-test-case stx) + (syntax-case stx () + [(NAME . _) #`(define NAME #,(translate-test-case stx))])) + + (define-for-syntax (translate-define-test-suite stx) + (syntax-case stx () + [(NAME . _) #`(define NAME #,(translate-test-suite stx))])) + + (define-syntax (test-case stx) + (translate-test-case (syntax-rest stx))) + + (define-syntax (test-suite stx) + (translate-test-suite (syntax-rest stx))) + + (define-syntax (define-test-case stx) + (translate-define-test-case (syntax-rest stx))) + + (define-syntax (define-test-suite stx) + (translate-define-test-suite (syntax-rest stx))) + + (provide report? test-case test-suite define-test-case define-test-suite) + ) diff --git a/collects/honu/test-cases.ss b/collects/honu/test-cases.ss index 32e43efec3..9c175d5669 100644 --- a/collects/honu/test-cases.ss +++ b/collects/honu/test-cases.ss @@ -1,6 +1,11 @@ (module test-cases mzscheme (require (lib "contract.ss") + (prefix srfi13: (lib "13.ss" "srfi")) + "private/tools/test.ss" + "private/typechecker/typecheck-expression.ss" + "tenv.ss" + "ast.ss" "utils.ss" "top.ss") @@ -21,7 +26,27 @@ ; "examples/nonexistent.honu" )) - (define/c (run-tests) (-> (listof any/c)) - (map test-file examples)) + (define-test-suite honu-tests + (test-case + examples-simple + (map test-file examples) + [pred: (lambda (all-results) + (andmap (lambda (file-results) + (andmap (lambda (result) (eq? result #t)) + file-results)) + all-results))]) + (test-suite typechecker + (test-suite expression + (test-case sequence-not-void + (typecheck-expression + (wrap-lenv) #f + (make-honu:seq + #'() + (list (make-honu:lit #'() (make-honu:type-prim #'() 'int) 5)) + (make-honu:lit #'() (make-honu:type-prim #'() 'int) 4))) + [error: (lambda (exn) (srfi13:string-contains (exn-message exn) "void"))])))) + + (define/c (run-tests) (-> report?) + (honu-tests)) ) \ No newline at end of file