Enable opaque class contracts in TR
This commit is contained in:
Asumu Takikawa
parent
e80f17cbad
commit
e2fd3b6653
|
|
@ -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)]
|
||||
|
|
|
|||
|
|
@ -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] ...)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user