From d9e433d5122879d946efff3dc3d79104f1316149 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 25 Aug 2010 09:35:19 -0500 Subject: [PATCH] Rackety --- collects/redex/examples/r6rs/test.rkt | 419 +++++++++++++------------- 1 file changed, 209 insertions(+), 210 deletions(-) diff --git a/collects/redex/examples/r6rs/test.rkt b/collects/redex/examples/r6rs/test.rkt index e5363104f8..d4019281a3 100644 --- a/collects/redex/examples/r6rs/test.rkt +++ b/collects/redex/examples/r6rs/test.rkt @@ -1,213 +1,212 @@ -(module test mzscheme - (require redex/reduction-semantics - (lib "etc.ss") - (lib "contract.ss")) - - (define-struct test-suite (name reductions to-mz equal? tests)) - (define-struct test (name input expecteds run-mz? around file line)) - - (define (show-dup-error from dup) - (string->immutable-string - (format "FOUND DUPLICATE!\n----\n~s\nwent to this twice:\n~s\n----\n" - from - dup))) - - (define (uniq from lot) - (let loop ((thelist lot)) - (unless (null? thelist) - (when (member (car thelist) (cdr thelist)) - (raise (make-exn:fail:duplicate - (show-dup-error from (car thelist)) - (current-continuation-marks)))) - (loop (cdr thelist))))) - (define-struct (exn:fail:duplicate exn:fail) ()) +#lang racket/base - (define evaluate - (opt-lambda (reductions t progress? [intermediate-state-test void]) - (let ([cache (make-hash-table 'equal)] - [count 0] - [results (make-hash-table 'equal)]) - - (let loop ([t t] - [depth 0]) - (unless (hash-table-get cache t (λ () #f)) - (hash-table-put! cache t #t) - (set! count (+ count 1)) - (intermediate-state-test t) - (when progress? - (cond - [(eq? progress? 'dots) - (when (= 0 (modulo count 100)) - (printf ":") - (flush-output))] - [else - (when (= 0 (modulo count 5000)) - (printf "~s states ... " count) - (flush-output))])) - (let ([nexts (apply-reduction-relation reductions t)]) - (cond - [(null? nexts) - (hash-table-put! results t #t)] - [else - (uniq t nexts) - (for-each (λ (t) (loop t (+ depth 1))) - nexts)])))) - - (when progress? - (unless (eq? progress? 'dots) - (printf "~s state~a total\n" count (if (= 1 count) "" "s")))) - (hash-table-map results (λ (x y) x))))) - - (define (set-same? s1 s2 same?) - (define (in-s1? s2-ele) (ormap (lambda (s1-ele) (same? s1-ele s2-ele)) s1)) - (define (in-s2? s1-ele) (ormap (lambda (s2-ele) (same? s1-ele s2-ele)) s2)) - (and (andmap in-s1? s2) - (andmap in-s2? s1) - #t)) - - (define-syntax (-test stx) - (syntax-case stx () - [(_ name term expected) - (with-syntax ([line (syntax-line stx)] - [source (syntax-source stx)]) - (syntax (build-test name term (list expected) #t #f line source)))] - [(_ name term expected mz?) - (with-syntax ([line (syntax-line stx)] - [source (syntax-source stx)]) - (syntax (build-test name term (list expected) mz? #f line source)))] - [(_ name term expected mz? around) - (with-syntax ([line (syntax-line stx)] - [source (syntax-source stx)]) - (syntax (build-test name term (list expected) mz? around line source)))])) - - (define-syntax (test/anss stx) - (syntax-case stx () - [(_ name term expecteds) - (with-syntax ([line (syntax-line stx)] - [source (syntax-source stx)]) - (syntax (build-test name term expecteds #t #f line source)))])) - - (define (build-test name term expecteds mz? around line source) - (make-test name term expecteds mz? (or around (λ (t) (t))) - (cond - [(path? source) - (let-values ([(base name dir?) (split-path source)]) - (path->string name))] - [else ""]) - line)) - - (define (run-test-suite test-suite) - (printf "running test suite: ~a\n" (test-suite-name test-suite)) - (let ([count 0]) - (for-each (λ (test) - (set! count (+ count 1)) - (run-test test-suite test)) - (test-suite-tests test-suite)) - (printf "ran ~a tests\n" count))) - - (define-struct multiple-values (lst) (make-inspector)) - - (define (run-test test-suite test) - (let* ([name (test-name test)] - [input (test-input test)] - [expecteds (test-expecteds test)] - [file (test-file test)] - [line (test-line test)] - [got - ((test-around test) - (λ () - (evaluate (test-suite-reductions test-suite) - input - #f)))]) - (unless (set-same? got expecteds (test-suite-equal? test-suite)) - (fprintf (current-error-port) "line ~a of ~a ~a\n test: ~s\n got: ~s\nexpected: ~s\n\n" - line - file - name - input - (separate-lines got) - (separate-lines expecteds))) - (when (test-run-mz? test) - (let* ([mv-wrap - (λ vals - (if (= 1 (length vals)) - (car vals) - (make-multiple-values vals)))] - [mz-got - (with-handlers ([exn? values]) - (call-with-values - (λ () (eval ((test-suite-to-mz test-suite) input))) - mv-wrap))] - [expected (car expecteds)] - [mz-expected (with-handlers ([exn? values]) - (call-with-values - (λ () (eval ((test-suite-to-mz test-suite) expected))) - mv-wrap))]) - (unless (same-mz? mz-got mz-expected) - (parameterize ([print-struct #t]) - (fprintf (current-error-port) "line ~s of ~a ~a\nMZ test: ~s\n got: ~s\nexpected: ~s\n\n" - line - file - name - input - (if (exn? mz-got) (exn-message mz-got) mz-got) - (if (exn? mz-expected) (exn-message mz-expected) mz-expected)))))))) - - (define (separate-lines sexps) - (cond - [(null? sexps) ""] - [(null? (cdr sexps)) (car sexps)] - [else (apply string-append (map (λ (x) (format "\n~s" x)) sexps))])) +(require redex/reduction-semantics + racket/contract + (for-syntax racket/base)) + +(define-struct test-suite (name reductions to-mz equal? tests)) +(define-struct test (name input expecteds run-mz? around file line)) + +(define (show-dup-error from dup) + (string->immutable-string + (format "FOUND DUPLICATE!\n----\n~s\nwent to this twice:\n~s\n----\n" + from + dup))) + +(define (uniq from lot) + (let loop ((thelist lot)) + (unless (null? thelist) + (when (member (car thelist) (cdr thelist)) + (raise (make-exn:fail:duplicate + (show-dup-error from (car thelist)) + (current-continuation-marks)))) + (loop (cdr thelist))))) +(define-struct (exn:fail:duplicate exn:fail) ()) + +(define (evaluate reductions t progress? [intermediate-state-test void]) + (let ([cache (make-hash)] + [count 0] + [results (make-hash)]) - (define (same-mz? mz-got mz-expected) - (or (same-mz-single-value? mz-got mz-expected) - - (and (multiple-values? mz-got) - (multiple-values? mz-expected) - (andmap same-mz-single-value? - (multiple-values-lst mz-got) - (multiple-values-lst mz-expected))) - - (and (exn? mz-got) - (exn? mz-expected) - (equal? (exn-message mz-got) - (exn-message mz-expected))) - - (and (exn? mz-got) - (regexp? mz-expected) - (regexp-match mz-expected (exn-message mz-got))))) - - (define (same-mz-single-value? mz-got mz-expected) - (or (equal? mz-got mz-expected) - (and (procedure? mz-got) - (procedure? mz-expected) - (equal? (procedure-arity mz-got) - (procedure-arity mz-expected))))) - - - (define (-test-suite n a b e? . c) (make-test-suite n a b e? c)) - - (provide (rename -test test)) - (provide/contract [rename -test-suite - test-suite - (->* (string? - reduction-relation? - (-> any/c any) - (-> any/c any/c boolean?)) - (listof test?) - (test-suite?))] - [run-test-suite (-> test-suite? any)]) - - (provide test-suite-tests - test? - test-name - test-input - test-expecteds - test-file - test-line - test/anss - - evaluate - exn:fail:duplicate? - set-same?)) + (let loop ([t t] + [depth 0]) + (unless (hash-ref cache t (λ () #f)) + (hash-set! cache t #t) + (set! count (+ count 1)) + (intermediate-state-test t) + (when progress? + (cond + [(eq? progress? 'dots) + (when (= 0 (modulo count 100)) + (printf ":") + (flush-output))] + [else + (when (= 0 (modulo count 5000)) + (printf "~s states ... " count) + (flush-output))])) + (let ([nexts (apply-reduction-relation reductions t)]) + (cond + [(null? nexts) + (hash-set! results t #t)] + [else + (uniq t nexts) + (for-each (λ (t) (loop t (+ depth 1))) + nexts)])))) + + (when progress? + (unless (eq? progress? 'dots) + (printf "~s state~a total\n" count (if (= 1 count) "" "s")))) + (hash-map results (λ (x y) x)))) +(define (set-same? s1 s2 same?) + (define (in-s1? s2-ele) (ormap (lambda (s1-ele) (same? s1-ele s2-ele)) s1)) + (define (in-s2? s1-ele) (ormap (lambda (s2-ele) (same? s1-ele s2-ele)) s2)) + (and (andmap in-s1? s2) + (andmap in-s2? s1) + #t)) + +(define-syntax (-test stx) + (syntax-case stx () + [(_ name term expected) + (with-syntax ([line (syntax-line stx)] + [source (syntax-source stx)]) + (syntax (build-test name term (list expected) #t #f line source)))] + [(_ name term expected mz?) + (with-syntax ([line (syntax-line stx)] + [source (syntax-source stx)]) + (syntax (build-test name term (list expected) mz? #f line source)))] + [(_ name term expected mz? around) + (with-syntax ([line (syntax-line stx)] + [source (syntax-source stx)]) + (syntax (build-test name term (list expected) mz? around line source)))])) + +(define-syntax (test/anss stx) + (syntax-case stx () + [(_ name term expecteds) + (with-syntax ([line (syntax-line stx)] + [source (syntax-source stx)]) + (syntax (build-test name term expecteds #t #f line source)))])) + +(define (build-test name term expecteds mz? around line source) + (make-test name term expecteds mz? (or around (λ (t) (t))) + (cond + [(path? source) + (let-values ([(base name dir?) (split-path source)]) + (path->string name))] + [else ""]) + line)) + +(define (run-test-suite test-suite) + (printf "running test suite: ~a\n" (test-suite-name test-suite)) + (let ([count 0]) + (for-each (λ (test) + (set! count (+ count 1)) + (run-test test-suite test)) + (test-suite-tests test-suite)) + (printf "ran ~a tests\n" count))) + +(define-struct multiple-values (lst) #:transparent) + +(define (run-test test-suite test) + (let* ([name (test-name test)] + [input (test-input test)] + [expecteds (test-expecteds test)] + [file (test-file test)] + [line (test-line test)] + [got + ((test-around test) + (λ () + (evaluate (test-suite-reductions test-suite) + input + #f)))]) + (unless (set-same? got expecteds (test-suite-equal? test-suite)) + (fprintf (current-error-port) "line ~a of ~a ~a\n test: ~s\n got: ~s\nexpected: ~s\n\n" + line + file + name + input + (separate-lines got) + (separate-lines expecteds))) + (when (test-run-mz? test) + (let* ([mv-wrap + (λ vals + (if (= 1 (length vals)) + (car vals) + (make-multiple-values vals)))] + [mz-got + (with-handlers ([exn? values]) + (call-with-values + (λ () (eval ((test-suite-to-mz test-suite) input))) + mv-wrap))] + [expected (car expecteds)] + [mz-expected (with-handlers ([exn? values]) + (call-with-values + (λ () (eval ((test-suite-to-mz test-suite) expected))) + mv-wrap))]) + (unless (same-mz? mz-got mz-expected) + (parameterize ([print-struct #t]) + (fprintf (current-error-port) "line ~s of ~a ~a\nMZ test: ~s\n got: ~s\nexpected: ~s\n\n" + line + file + name + input + (if (exn? mz-got) (exn-message mz-got) mz-got) + (if (exn? mz-expected) (exn-message mz-expected) mz-expected)))))))) + +(define (separate-lines sexps) + (cond + [(null? sexps) ""] + [(null? (cdr sexps)) (car sexps)] + [else (apply string-append (map (λ (x) (format "\n~s" x)) sexps))])) + +(define (same-mz? mz-got mz-expected) + (or (same-mz-single-value? mz-got mz-expected) + + (and (multiple-values? mz-got) + (multiple-values? mz-expected) + (andmap same-mz-single-value? + (multiple-values-lst mz-got) + (multiple-values-lst mz-expected))) + + (and (exn? mz-got) + (exn? mz-expected) + (equal? (exn-message mz-got) + (exn-message mz-expected))) + + (and (exn? mz-got) + (regexp? mz-expected) + (regexp-match mz-expected (exn-message mz-got))))) + +(define (same-mz-single-value? mz-got mz-expected) + (or (equal? mz-got mz-expected) + (and (procedure? mz-got) + (procedure? mz-expected) + (equal? (procedure-arity mz-got) + (procedure-arity mz-expected))))) + + +(define (-test-suite n a b e? . c) (make-test-suite n a b e? c)) + +(provide (rename-out [-test test])) +(provide/contract [rename -test-suite + test-suite + (->* (string? + reduction-relation? + (-> any/c any) + (-> any/c any/c boolean?)) + (listof test?) + test-suite?)] + [run-test-suite (-> test-suite? any)]) + +(provide test-suite-tests + test? + test-name + test-input + test-expecteds + test-file + test-line + test/anss + + evaluate + exn:fail:duplicate? + set-same?)