diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt index 87b4cf7f..b4d1a0f6 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt @@ -45,8 +45,6 @@ (raise-syntax-error 'class "should only be used internally")) (begin-for-syntax - (module+ test (require rackunit)) - ;; forms that are not allowed by Typed Racket yet (define unsupported-forms (list (quote-syntax augride) @@ -91,6 +89,11 @@ (quote-syntax super-make-object) (quote-syntax inspect))))) +;; export some syntax-time definitions for testing purposes +(module+ internal + (provide (for-syntax init-decl class-clause class-clause-or-other + extract-names clause init-clause get-optional-inits))) + (begin-for-syntax ;; A Clause is a (clause Syntax Id Listof Option) ;; @@ -293,46 +296,7 @@ (add-kind #'init-field) (add-kind #'field) (add-kind #'public) - (add-kind #'pubment)) - - (module+ test - ;; equal? check but considers id & stx pair equality - (define (equal?/id x y) - (cond [(and (identifier? x) (identifier? y)) - (free-identifier=? x y)] - [(and (syntax? x) (syntax? y)) - (and (free-identifier=? (stx-car x) (stx-car y)) - (free-identifier=? (stx-car (stx-cdr x)) - (stx-car (stx-cdr y))))] - (equal?/recur x y equal?/id))) - - ;; utility macro for checking if a syntax matches a - ;; given syntax class - (define-syntax-rule (syntax-parses? stx syntax-class) - (syntax-parse stx - [(~var _ syntax-class) #t] - [_ #f])) - - ;; for rackunit with equal?/id - (define-binary-check (check-equal?/id equal?/id actual expected)) - - (check-true (syntax-parses? #'x init-decl)) - (check-true (syntax-parses? #'([x y]) init-decl)) - (check-true (syntax-parses? #'(x 0) init-decl)) - (check-true (syntax-parses? #'([x y] 0) init-decl)) - (check-true (syntax-parses? #'(init x y z) class-clause)) - (check-true (syntax-parses? #'(public f g h) class-clause)) - (check-true (syntax-parses? #'(public f) class-clause-or-other)) - (check-equal?/id - (extract-names (list (clause #'(init x y z) - #'init - (list #'(x x) #'(y y) #'(z z))) - (clause #'(public f g h) - #'public - (list #'(f f) #'(g g) #'(h h))))) - (make-immutable-free-id-table - (hash #'public (list #'(f f) #'(g g) #'(h h)) - #'init (list #'(x x) #'(y y) #'(z z))))))) + (add-kind #'pubment))) (define-syntax (class stx) (syntax-parse stx @@ -475,13 +439,6 @@ #:when optional?) (stx-car id-pair))))) - (module+ test - (check-equal?/id - (get-optional-inits - (list (init-clause #'(init [x 0]) #'init #'([x x]) (list #t)) - (init-clause #'(init [(a b)]) #'init #'([a b]) (list #f)))) - (list #'x))) - ;; check-unsupported-features : Dict -> Void ;; Check if features that are not supported were used and ;; raise an error if they are present diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt index 411b746c..56f5ca62 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt @@ -32,4 +32,5 @@ "keyword-expansion-test.rkt" "special-env-typecheck-tests.rkt" "contract-tests.rkt" - "interactive-tests.rkt") + "interactive-tests.rkt" + "class-util-tests.rkt") diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-util-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-util-tests.rkt new file mode 100644 index 00000000..86ec27b3 --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-util-tests.rkt @@ -0,0 +1,71 @@ +#lang racket/base + +;; Tests for utilities and helpers for the internals of +;; class type-checking, parsing, etc. + +(require (except-in "test-utils.rkt" private) + racket/class + rackunit + syntax/id-table + syntax/parse + syntax/stx + ;; phase-shift down for use in tests below + (for-template (submod typed-racket/base-env/class-prims internal))) + +(provide tests) +(gen-test-main) + +;; equal? check but considers id & stx pair equality for the +;; specific test cases that appear here (it's not a general check) +(define (equal?/id x y) + (cond [(and (identifier? x) (identifier? y)) + (free-identifier=? x y)] + [(and (syntax? x) (syntax? y)) + (and (identifier? (stx-car x)) + (identifier? (stx-car y)) + (free-identifier=? (stx-car x) (stx-car y)) + (free-identifier=? (stx-car (stx-cdr x)) + (stx-car (stx-cdr y))))] + [else (equal?/recur x y equal?/id)])) + +;; utility macro for checking if a syntax matches a +;; given syntax class +(define-syntax-rule (syntax-parses? stx syntax-class) + (syntax-parse stx + [(~var _ syntax-class) #t] + [_ #f])) + +;; for rackunit with equal?/id +(define-binary-check (check-equal?/id equal?/id actual expected)) + +(define tests + (test-suite "Class utility tests" + (check-true (syntax-parses? #'x init-decl)) + (check-true (syntax-parses? #'([x y]) init-decl)) + (check-true (syntax-parses? #'(x 0) init-decl)) + (check-true (syntax-parses? #'([x y] 0) init-decl)) + (check-true (syntax-parses? #'(init x y z) class-clause)) + (check-true (syntax-parses? #'(public f g h) class-clause)) + (check-true (syntax-parses? #'(public f) class-clause-or-other)) + + (check-equal?/id + (extract-names (list (clause #'(init x y z) + #'init + (list #'(x x) #'(y y) #'(z z)) + (list #f #f #f)) + (clause #'(public f g h) + #'public + (list #'(f f) #'(g g) #'(h h)) + (list #f #f #f)))) + (make-immutable-free-id-table + (hash #'public (list #'(f f) #'(g g) #'(h h)) + #'init (list #'(x x) #'(y y) #'(z z)))) + + (check-equal?/id + (get-optional-inits + (list (init-clause #'(init [x 0]) #'init #'([x x]) + (list #f) (list #t)) + (init-clause #'(init [(a b)]) #'init #'([a b]) + (list #f) (list #f)))) + (list #'x))))) +