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

Make parse type and type annotation tests run at the right phase.

Browse Source
This commit is contained in:
Eric Dobson 2013-11-21 08:54:25 -08:00
parent 4518ad855f
commit c97ce693f3
2 changed files with 57 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

76
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/parse-type-tests.rkt
View File

@ -1,48 +1,27 @@
#lang racket/base
(require "test-utils.rkt" (for-syntax racket/base)
(require "test-utils.rkt"
"evaluator.rkt"
(for-syntax
racket/base
racket/dict
(env tvar-env type-alias-env)
(utils tc-utils)
(env type-alias-env type-env-structs tvar-env type-name-env init-envs)
(rep type-rep)
(rename-in (types subtype union utils abbrev numeric-tower)
[Un t:Un] [-> t:->] [->* t:->*])
(base-env base-types base-types-extra colon)
(submod typed-racket/base-env/base-types initialize)
(for-template (base-env base-types base-types-extra base-env colon))
(private parse-type)
rackunit
racket/dict)
(rep type-rep)
(submod typed-racket/base-env/base-types initialize)
(rename-in (types union abbrev numeric-tower)
[Un t:Un] [-> t:->] [->* t:->*]))
(only-in typed-racket/typed-racket do-standard-inits)
(base-env base-types base-types-extra colon)
rackunit)
(provide tests)
(gen-test-main)
;; HORRIBLE HACK!
;; We are solving the following problem:
;; when we require "base-env.rkt" for template, it constructs the type-alias-env
;; in phase 0 (relative to this module), but populates it with phase -1 identifiers
;; The identifiers are also bound in this module at phase -1, but the comparison for
;; the table is phase 0, so they don't compare correctly
;; The solution is to add the identifiers to the table at phase 0.
;; We do this by going through the table, constructing new identifiers based on the symbol
;; of the old identifier.
;; This relies on the identifiers being bound at phase 0 in this module (which they are,
;; because we have a phase 0 require of "base-env.rkt").
(initialize-type-names)
(for ([pr (type-alias-env-map cons)])
(let ([nm (car pr)]
[ty (cdr pr)])
(register-resolved-type-alias (datum->syntax #'here (syntax->datum nm)) ty)))
(define-syntax (run-one stx)
(syntax-case stx ()
[(_ ty) (syntax/loc stx
(parameterize ([current-tvars initial-tvar-env]
[current-orig-stx #'ty]
[orig-module-stx #'ty]
[expanded-module-stx #'ty]
[delay-errors? #f])
(parse-type (syntax ty))))]))
(begin-for-syntax
(do-standard-inits))
(define-syntax (pt-test stx)
(syntax-case stx (FAIL)
@ -50,19 +29,26 @@
(syntax/loc stx (pt-test FAIL ty-stx initial-tvar-env))]
[(_ FAIL ty-stx tvar-env)
(quasisyntax/loc stx
(test-exn #,(format "~a" (syntax->datum #'ty-stx))
exn:fail:syntax?
(test-case #,(format "~a" (syntax->datum #'ty-stx))
(unless
(phase1-phase0-eval
(with-handlers ([exn:fail:syntax? (lambda (exn) #'#t)])
(parameterize ([current-tvars tvar-env]
[delay-errors? #f])
(lambda () (parse-type (quote-syntax ty-stx))))))]
(parse-type (quote-syntax ty-stx)))
#'#f))
(fail-check "No syntax error when parsing type."))))]
[(_ ts tv) (syntax/loc stx (pt-test ts tv initial-tvar-env))]
[(_ ty-stx ty-val tvar-env)
(quasisyntax/loc
stx
(test-case #,(format "~a" (syntax->datum #'ty-stx))
(unless
(phase1-phase0-eval
(parameterize ([current-tvars tvar-env]
[delay-errors? #f])
(check type-equal? (parse-type (quote-syntax ty-stx)) ty-val))))]))
#`#,(type-equal? (parse-type (quote-syntax ty-stx)) ty-val)))
(fail-check "Unequal types"))))]))
(define-syntax pt-tests
(syntax-rules ()
@ -70,9 +56,9 @@
(test-suite nm
(pt-test elems ...) ...)]))
(define N -Number)
(define B -Boolean)
(define Sym -Symbol)
(define-for-syntax N -Number)
(define-for-syntax B -Boolean)
(define-for-syntax Sym -Symbol)
(define tests
(pt-tests

39
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/type-annotation-test.rkt
View File

@ -1,30 +1,31 @@
#lang scheme/base
#lang racket/base
(require "test-utils.rkt"
(for-syntax scheme/base)
typed-racket/private/type-annotation
typed-racket/private/parse-type
(types abbrev numeric-tower utils)
(env type-env-structs init-envs)
(utils tc-utils)
"evaluator.rkt"
(for-syntax
racket/base
racket/list
(rep type-rep filter-rep object-rep)
(submod typed-racket/base-env/base-types initialize)
(private type-annotation)
(types abbrev numeric-tower tc-result))
(only-in typed-racket/typed-racket do-standard-inits)
(base-env prims base-types base-types-extra colon)
rackunit)
(initialize-type-names)
(provide tests)
(gen-test-main)
(begin-for-syntax
(do-standard-inits))
(define-syntax-rule (tat ann-stx ty)
(check-tc-result-equal? (format "~a" (quote ann-stx))
(type-ascription (let ([ons (current-namespace)]
[ns (make-base-namespace)])
(parameterize ([current-namespace ns])
(namespace-require 'typed-racket/base-env/prims)
(namespace-require 'typed-racket/base-env/base-types)
(namespace-require 'typed-racket/base-env/base-types-extra)
(expand 'ann-stx))))
ty))
(test-case (format "~a" (quote ann-stx))
(unless
(phase1-phase0-eval
(define stx (local-expand (quote-syntax ann-stx) 'expression empty))
(define ascrip (type-ascription stx))
#`#,(equal? ascrip ty))
(fail-check "Unequal types"))))
(define tests
(test-suite