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

86
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 #lang racket/base
(require "test-utils.rkt" (for-syntax racket/base) (require "test-utils.rkt"
(utils tc-utils) "evaluator.rkt"
(env type-alias-env type-env-structs tvar-env type-name-env init-envs) (for-syntax
(rep type-rep) racket/base
(rename-in (types subtype union utils abbrev numeric-tower) racket/dict
[Un t:Un] [-> t:->] [->* t:->*]) (env tvar-env type-alias-env)
(utils tc-utils)
(private parse-type)
(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) (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)) rackunit)
(private parse-type)
rackunit
racket/dict)
(provide tests) (provide tests)
(gen-test-main) (gen-test-main)
;; HORRIBLE HACK! (begin-for-syntax
;; We are solving the following problem: (do-standard-inits))
;; 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))))]))
(define-syntax (pt-test stx) (define-syntax (pt-test stx)
(syntax-case stx (FAIL) (syntax-case stx (FAIL)
@ -50,19 +29,26 @@
(syntax/loc stx (pt-test FAIL ty-stx initial-tvar-env))] (syntax/loc stx (pt-test FAIL ty-stx initial-tvar-env))]
[(_ FAIL ty-stx tvar-env) [(_ FAIL ty-stx tvar-env)
(quasisyntax/loc stx (quasisyntax/loc stx
(test-exn #,(format "~a" (syntax->datum #'ty-stx)) (test-case #,(format "~a" (syntax->datum #'ty-stx))
exn:fail:syntax? (unless
(parameterize ([current-tvars tvar-env] (phase1-phase0-eval
[delay-errors? #f]) (with-handlers ([exn:fail:syntax? (lambda (exn) #'#t)])
(lambda () (parse-type (quote-syntax ty-stx))))))] (parameterize ([current-tvars tvar-env]
[delay-errors? #f])
(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))] [(_ ts tv) (syntax/loc stx (pt-test ts tv initial-tvar-env))]
[(_ ty-stx ty-val tvar-env) [(_ ty-stx ty-val tvar-env)
(quasisyntax/loc (quasisyntax/loc
stx stx
(test-case #,(format "~a" (syntax->datum #'ty-stx)) (test-case #,(format "~a" (syntax->datum #'ty-stx))
(parameterize ([current-tvars tvar-env] (unless
[delay-errors? #f]) (phase1-phase0-eval
(check type-equal? (parse-type (quote-syntax ty-stx)) ty-val))))])) (parameterize ([current-tvars tvar-env]
[delay-errors? #f])
#`#,(type-equal? (parse-type (quote-syntax ty-stx)) ty-val)))
(fail-check "Unequal types"))))]))
(define-syntax pt-tests (define-syntax pt-tests
(syntax-rules () (syntax-rules ()
@ -70,9 +56,9 @@
(test-suite nm (test-suite nm
(pt-test elems ...) ...)])) (pt-test elems ...) ...)]))
(define N -Number) (define-for-syntax N -Number)
(define B -Boolean) (define-for-syntax B -Boolean)
(define Sym -Symbol) (define-for-syntax Sym -Symbol)
(define tests (define tests
(pt-tests (pt-tests

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