diff --git a/typed-racket-lib/typed-racket/private/type-contract.rkt b/typed-racket-lib/typed-racket/private/type-contract.rkt index 2e966b6b..eb22825e 100644 --- a/typed-racket-lib/typed-racket/private/type-contract.rkt +++ b/typed-racket-lib/typed-racket/private/type-contract.rkt @@ -467,7 +467,8 @@ [type (in-list public-types)] #:unless (memq name pubment-names)) (values name type))) - (class/sc (append + (class/sc (from-untyped? typed-side) + (append (map (λ (n sc) (member-spec 'override n sc)) override-names (map t->sc/meth override-types)) (map (λ (n sc) (member-spec 'pubment n sc)) @@ -477,8 +478,7 @@ (map (λ (n sc) (member-spec 'init n sc)) init-names (map t->sc/neg init-types)) (map (λ (n sc) (member-spec 'field n sc)) - field-names (map t->sc/both field-types))) - #f)] + field-names (map t->sc/both field-types))))] [(Struct: nm par (list (fld: flds acc-ids mut?) ...) proc poly? pred?) (cond [(dict-ref recursive-values nm #f)] diff --git a/typed-racket-lib/typed-racket/static-contracts/combinators/object.rkt b/typed-racket-lib/typed-racket/static-contracts/combinators/object.rkt index 60dab6bd..fdef9f02 100644 --- a/typed-racket-lib/typed-racket/static-contracts/combinators/object.rkt +++ b/typed-racket-lib/typed-racket/static-contracts/combinators/object.rkt @@ -14,7 +14,7 @@ (contract-out [struct member-spec ([modifier symbol?] [id symbol?] [sc static-contract?])] [object/sc ((listof object-member-spec?) . -> . static-contract?)] - [class/sc ((listof member-spec?) boolean? . -> . static-contract?)] + [class/sc (boolean? (listof member-spec?) . -> . static-contract?)] [instanceof/sc (static-contract? . -> . static-contract?)])) @@ -100,8 +100,8 @@ (define (object/sc specs) (object-combinator (member-seq specs))) -(define (class/sc specs opaque) - (class-combinator (member-seq specs) opaque)) +(define (class/sc opaque? specs) + (class-combinator (member-seq specs) opaque?)) (define (instanceof/sc class) (instanceof-combinator (list class))) @@ -151,7 +151,7 @@ vals)) #`(let ([override-temp override-ctc] ... [pubment-temp pubment-ctc] ...) - (class/c #,@(if opaque (list '#:opaque) empty) + (class/c #,@(if opaque '(#:opaque #:ignore-local-member-names) null) #,@(map (member-spec->form f) vals-rest) [override-name override-temp] ... (override [override-name override-temp] ...) diff --git a/typed-racket-test/unit-tests/contract-tests.rkt b/typed-racket-test/unit-tests/contract-tests.rkt index e50d8405..0f0c3218 100644 --- a/typed-racket-test/unit-tests/contract-tests.rkt +++ b/typed-racket-test/unit-tests/contract-tests.rkt @@ -12,6 +12,7 @@ (submod typed-racket/private/type-contract test-exports) (only-in racket/contract contract) racket/match + (except-in racket/class private) rackunit) (provide tests) (gen-test-main) @@ -64,6 +65,7 @@ (namespace-require 'typed-racket/utils/any-wrap) (namespace-require 'typed-racket/utils/evt-contract) (namespace-require '(submod typed-racket/private/type-contract predicates)) + (namespace-require 'typed/racket/class) (current-namespace))) ;; (t-int type (-> any any) any) @@ -98,14 +100,17 @@ (define pos (if (syntax-e #'typed-side) 'typed 'untyped)) (define neg (if (syntax-e #'typed-side) 'untyped 'typed)) #`(test-case (format "~a for ~a in ~a" 'type-expr 'val-expr 'fun-expr) - (let ([type-val type-expr] [fun-val fun-expr] [val val-expr]) - (with-check-info (['type type-val] ['test-value val]) + (let ([type-val type-expr]) + (with-check-info (['type type-val] ['test-value (quote val-expr)]) (define ctc-result (type->contract type-val #:typed-side typed-side (λ (#:reason [reason #f]) (fail-check (or reason "Type could not be converted to contract"))))) (match-define (list extra-stxs ctc-stx) ctc-result) + (define namespace (ctc-namespace)) + (define val (eval (quote val-expr) namespace)) + (define fun-val (eval (quote fun-expr) namespace)) (define ctced-val (eval #`(let () #,@(map (λ (stx) (syntax-shift-phase-level stx 1)) @@ -114,7 +119,7 @@ #,val #,(quote (quote #,pos)) #,(quote (quote #,neg)))) - (ctc-namespace))) + namespace)) (check (λ () (fun-val ctced-val))))))])) (define tests @@ -205,20 +210,20 @@ (t-sc (Un (-lst Univ) -Number) (or/sc number/sc (listof/sc any-wrap/sc))) ;; classes - (t-sc (-class) (class/sc null #f)) + (t-sc (-class) (class/sc #f null)) (t-sc (-class #:init ([x -Number #f] [y -Number #f])) - (class/sc (list (member-spec 'init 'x number/sc) - (member-spec 'init 'y number/sc)) - #f)) + (class/sc #f + (list (member-spec 'init 'x number/sc) + (member-spec 'init 'y number/sc)))) (t-sc (-class #:init ([x -Number #f] [y -Number #t])) - (class/sc (list (member-spec 'init 'x number/sc) - (member-spec 'init 'y number/sc)) - #f)) + (class/sc #f + (list (member-spec 'init 'x number/sc) + (member-spec 'init 'y number/sc)))) (t-sc (-class #:init ([x -Number #f]) #:init-field ([y -Integer #f])) - (class/sc (list (member-spec 'init 'x number/sc) + (class/sc #f + (list (member-spec 'init 'x number/sc) (member-spec 'init 'y integer/sc) - (member-spec 'field 'y integer/sc)) - #f)) + (member-spec 'field 'y integer/sc)))) (t (-class #:method ([m (-poly (x) (-> x x))]))) (t (-class #:method ([m (-polydots (x) (->... (list) (x x) -Void))]))) (t (-class #:method ([m (-polyrow (x) (list null null null null) @@ -266,4 +271,24 @@ (make-channel) #:untyped #:msg #rx"cannot put on a channel") + ;; typed/untyped interaction with class/object contracts + (t-int/fail (-object #:field ([f -String])) + (λ (o) (get-field g o)) + (new (class object% (super-new) + (field [f "f"] [g "g"]))) + #:typed + #:msg #rx"does not have the requested field") + (t-int/fail (-object #:method ([m (-> -String)])) + (λ (o) (send o n)) + (new (class object% (super-new) + (define/public (m) "m") + (define/public (n) "n"))) + #:typed + #:msg #rx"no such method") + (t-int (-class #:method ([m (-> -String)])) + (λ (s%) (class s% (super-new) + (define/public (n) "ok"))) + (class object% (super-new) + (define/public (m) "m")) + #:untyped) )) diff --git a/typed-racket-test/unit-tests/static-contract-optimizer-tests.rkt b/typed-racket-test/unit-tests/static-contract-optimizer-tests.rkt index ac9167b8..2cda6913 100644 --- a/typed-racket-test/unit-tests/static-contract-optimizer-tests.rkt +++ b/typed-racket-test/unit-tests/static-contract-optimizer-tests.rkt @@ -280,9 +280,14 @@ #:neg (object/sc (list (member-spec 'field 'x list?/sc)))) (check-optimize - (class/sc (list (member-spec 'field 'x (listof/sc any/sc))) #f) - #:pos (class/sc (list (member-spec 'field 'x list?/sc)) #f) - #:neg (class/sc (list (member-spec 'field 'x list?/sc)) #f)) + (class/sc #t (list (member-spec 'field 'x (listof/sc any/sc)))) + #:pos (class/sc #t (list (member-spec 'field 'x list?/sc))) + #:neg (class/sc #t (list (member-spec 'field 'x list?/sc)))) + + (check-optimize + (class/sc #f (list (member-spec 'field 'x (listof/sc any/sc)))) + #:pos (class/sc #f (list (member-spec 'field 'x list?/sc))) + #:neg (class/sc #f (list (member-spec 'field 'x list?/sc)))) (check-optimize (recursive-sc (list foo-id bar-id)