suzanne.soy/typed-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Move internal unit tests out into a separate file

Browse Source 
original commit: e7e354f69ae4846b3d37cce58268a01d9ee6cca7
This commit is contained in:
Asumu Takikawa 2014-02-04 12:09:54 -05:00
parent f2260843b0
commit 6cd8927abc
3 changed files with 79 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt
View File

@ -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<Syntax> Option<Type>)
;;
@ -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<Identifier, Names> -> Void
;; Check if features that are not supported were used and
;; raise an error if they are present

3
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt
View File

@ -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")

71
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-util-tests.rkt Normal file
View File

@ -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)))))