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

Add option to ignore local names in opaque class/c

Browse Source
This commit is contained in:
Asumu Takikawa 2015-02-24 17:25:00 -05:00
parent 0fce958268
commit ab68a4dc38
3 changed files with 60 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
pkgs/racket-doc/scribblings/reference/class.scrbl
View File

@ -1737,7 +1737,8 @@ resulting trait are the same as for @racket[trait-sum], otherwise the
([maybe-opaque
(code:line)
(code:line #:opaque)]
(code:line #:opaque)
(code:line #:opaque #:ignore-local-member-names)]
[member-spec
method-spec
@ -1785,7 +1786,9 @@ A class contract can be specified to be @emph{opaque} with the @racket[#:opaque]
keyword. An opaque class contract will only accept a class that defines
exactly the external methods and fields specified by the contract. A contract error
is raised if the contracted class contains any methods or fields that are
not specified.
not specified. Methods or fields with local member names (i.e., defined with
@racket[define-local-member-name]) are ignored for this check if
@racket[#:ignore-local-member-names] is provided.
The external contracts are as follows:
@ -2008,6 +2011,9 @@ As with the external contracts, when a method or field name is specified
checked on any access and/or mutation of the field that occurs in
such subclasses.}
@history[#:changed "6.1.1.8"
@string-append{Opaque class/c now optionally ignores local
member names if an additional keyword is supplied.}]
]}
@defform[(absent absent-spec ...)]{

42
pkgs/racket-test/tests/racket/contract/class.rkt
View File

@ -131,7 +131,16 @@
(class object% (super-new) (define/public (m x) 3) (define/public (n) 4))
'pos
'neg)))
(test/spec-passed
'class/c-first-order-opaque-method-3-ignore
'(let ()
(define-local-member-name n)
(contract (class/c #:opaque #:ignore-local-member-names [m (-> any/c number? number?)])
(class object% (super-new) (define/public (m x) 3) (define/public (n) 4))
'pos
'neg)))
(test/pos-blame
'class/c-first-order-opaque-method-4
'(contract
@ -141,6 +150,16 @@
(class object% (super-new) (define/public (m x) 3) (define/public (n) 4)))
'pos
'neg))
(test/spec-passed
'class/c-first-order-opaque-method-4-ignore
'(contract
(class/c #:opaque #:ignore-local-member-names [m (-> any/c number? number?)])
(let ()
(define-local-member-name n)
(class object% (super-new) (define/public (m x) 3) (define/public (n) 4)))
'pos
'neg))
(test/pos-blame
'class/c-first-order-opaque-method-5
@ -231,13 +250,22 @@
'neg))
(test/pos-blame
'class/c-first-order-opaque-field-2
'class/c-first-order-opaque-field-3
'(contract (class/c #:opaque (field [m number?]))
(let ()
(define-local-member-name n)
(class object% (super-new) (field [m 5] [n 3])))
'pos
'neg))
(test/spec-passed
'class/c-first-order-opaque-field-3-ignore
'(contract (class/c #:opaque #:ignore-local-member-names (field [m number?]))
(let ()
(define-local-member-name n)
(class object% (super-new) (field [m 5] [n 3])))
'pos
'neg))
;; No true first-order tests here, other than just to make
;; sure they're accepted. For init-field, we can at least
@ -498,6 +526,16 @@
(super-new))
'pos
'neg))
(test/spec-passed
'class/c-first-order-opaque-super-3-ignore
'(contract (class/c #:opaque #:ignore-local-member-names)
(class (let ()
(define-local-member-name m)
(class object% (super-new) (define/public (m) 3)))
(super-new))
'pos
'neg))
(test/spec-passed
'class/c-first-order-opaque-super-4

23
racket/collects/racket/private/class-c-old.rkt
View File

@ -37,6 +37,7 @@
(syntax-parameterize ([making-a-method #'this-param] [method-contract? #t]) (->d . stx)))
(define (class/c-check-first-order ctc cls fail)
(define opaque? (class/c-opaque? ctc))
(unless (class? cls)
(fail '(expected: "a class" given: "~v") cls))
(define method-ht (class-method-ht cls))
@ -55,31 +56,29 @@
[else m/l])))
(unless (contract-first-order-passes? c meth-proc)
(fail "public method ~a doesn't match contract" m))))
(unless (class/c-opaque? ctc)
(unless opaque?
(for ([m (class/c-absents ctc)])
(when (hash-ref method-ht m #f)
(fail "class already contains public method ~a" m))))
(when (class/c-opaque? ctc)
(when opaque?
(for ([m (in-hash-keys method-ht)])
(unless (memq m (class/c-methods ctc))
(if (symbol-interned? m)
(fail "method ~a not specified in contract" m)
(fail "some local member not specified in contract")))))
(when (or (not (symbol? opaque?)) (symbol-interned? m))
(fail "method ~a not specified in contract" m)))))
(define field-ht (class-field-ht cls))
(for ([f (class/c-fields ctc)])
(unless (hash-ref field-ht f #f)
(fail "no public field ~a" f)))
(unless (class/c-opaque? ctc)
(unless opaque?
(for ([f (class/c-absent-fields ctc)])
(when (hash-ref field-ht f #f)
(fail "class already contains public field ~a" f))))
(when (class/c-opaque? ctc)
(when opaque?
(for ([f (in-hash-keys field-ht)])
(unless (memq f (class/c-fields ctc))
(if (symbol-interned? f)
(fail "field ~a not specified in contract" f)
(fail "some local member field not specified in contract")))))
(when (or (not (symbol? opaque?)) (symbol-interned? f))
(fail "field ~a not specified in contract" f)))))
#t)
(define (internal-class/c-check-first-order internal-ctc cls fail)
@ -862,7 +861,7 @@
(check-one-stronger internal-class/c-augrides internal-class/c-augride-contracts
this-internal that-internal)
(if (class/c-opaque? this) (class/c-opaque? that) #t)
(equal? (class/c-opaque? this) (class/c-opaque? that))
(all-included? (class/c-absent-fields that) (class/c-absent-fields this))
(all-included? (class/c-absents that) (class/c-absents this)))]
[else #f]))
@ -1129,6 +1128,8 @@
(define-syntax (class/c stx)
(define-splicing-syntax-class opaque-keyword
(pattern (~seq #:opaque #:ignore-local-member-names)
#:with opaque? #''ignore-local-member-names)
(pattern (~seq #:opaque) #:with opaque? #'#t)
(pattern (~seq) #:with opaque? #'#f))