Attempt at adding ->im; will be reverted.
`->i` already supports method contracts (for use wihin `object-contract`, whose `->i` support is tested, but undocumented), which would make `->im` possible. Unfortunately, that support is very incomplete, missing support for using `this` in contracts, making this `->im` (or the undocumented `->i` + `object-contract` combo) basically useless. Once/if that is added, then this commit would enable `->im`. Until then, it's mostly useful for future reference (hence will be reverted). In the meantime, it's possible to use `->i` within class/object contracts with an explicit `this` argument, so nothing critical is lost, just a tiny shortcut.
This commit is contained in:
Vincent St-Amour
parent
05292b7e69
commit
7c458d10d7
|
|
@ -2071,16 +2071,28 @@ domain, where the first (implicit) argument is contracted with
|
|||
@racket[any/c]. This contract is useful for writing simpler method
|
||||
contracts when no properties of @racket[this] need to be checked.}
|
||||
|
||||
@deftogether[[
|
||||
@defform[(->im maybe-chaperone
|
||||
(mandatory-dependent-dom ...)
|
||||
(optional-dependent-dom ...)
|
||||
dependent-rest
|
||||
pre-cond
|
||||
dep-range
|
||||
post-condition)]
|
||||
@defform[(->dm (mandatory-dependent-dom ...)
|
||||
(optional-dependent-dom ...)
|
||||
dependent-rest
|
||||
pre-cond
|
||||
dep-range)]{
|
||||
Similar to @racket[->d], except that the mandatory domain of the resulting contract
|
||||
dep-range)]
|
||||
]]{
|
||||
Similar to @racket[->i] and @racket[->d], except that the mandatory domain of the resulting contract
|
||||
contains one more element than the stated domain, where the first (implicit) argument is contracted
|
||||
with @racket[any/c]. In addition, @racket[this] is appropriately bound in the body of the contract.
|
||||
This contract is useful for writing simpler method contracts when no properties
|
||||
of @racket[this] need to be checked.}
|
||||
of @racket[this] need to be checked.
|
||||
|
||||
@history[#:changed "6.4.0.15" @elem{Added @racket[->im].}]
|
||||
}
|
||||
|
||||
@defform/subs[
|
||||
#:literals (field)
|
||||
|
|
|
|||
|
|
@ -1847,7 +1847,7 @@
|
|||
'neg))
|
||||
|
||||
(test/pos-blame
|
||||
'->dm-first-order-1
|
||||
'->dm-first-order-2
|
||||
'(contract (class/c [pop (->dm () () #:pre-cond (not (send this empty?)) [_ number?])]
|
||||
[push (->dm ([arg number?]) () [_ void?] #:post-cond (not (send this empty?)))]
|
||||
[empty? (->m boolean?)])
|
||||
|
|
@ -1917,7 +1917,92 @@
|
|||
'neg)]
|
||||
[o (new stack%)])
|
||||
(send o pop)))
|
||||
|
||||
|
||||
(test/spec-passed
|
||||
'->im-first-order-1
|
||||
'(contract (class/c [pop (->im () #:pre () (not (send this empty?)) [_ number?])]
|
||||
[push (->im ([arg number?]) [_ void?] #:post () (not (send this empty?)))]
|
||||
[empty? (->m boolean?)])
|
||||
(class object% (super-new)
|
||||
(define stack null)
|
||||
(define/public (empty?) (null? stack))
|
||||
(define/public (push v) (set! stack (cons v stack)))
|
||||
(define/public (pop) (let ([res (car stack)]) (set! stack (cdr stack)) res)))
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(test/pos-blame
|
||||
'->im-first-order-2
|
||||
'(contract (class/c [pop (->im () #:pre () (not (send this empty?)) [_ number?])]
|
||||
[push (->im ([arg number?]) [_ void?] #:post () (not (send this empty?)))]
|
||||
[empty? (->m boolean?)])
|
||||
(class object% (super-new)
|
||||
(define stack null)
|
||||
(define/public (empty?) (null? stack))
|
||||
(define/public (push v) (set! stack (cons v stack)))
|
||||
(define/public (pop v) (let ([res (car stack)]) (set! stack (cdr stack)) res)))
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(test/spec-passed
|
||||
'->im-higher-order-1
|
||||
'(let* ([stack% (contract (class/c
|
||||
[pop (->im () #:pre () (not (send this empty?)) [_ number?])]
|
||||
[push (->im ([arg number?]) [_ void?]
|
||||
#:post () (not (send this empty?)))]
|
||||
[empty? (->m boolean?)])
|
||||
(class object% (super-new)
|
||||
(define stack null)
|
||||
(define/public (empty?) (null? stack))
|
||||
(define/public (push v) (set! stack (cons v stack)))
|
||||
(define/public (pop)
|
||||
(let ([res (car stack)]) (set! stack (cdr stack)) res)))
|
||||
'pos
|
||||
'neg)]
|
||||
[o (new stack%)])
|
||||
(send o push 4)
|
||||
(send o empty?)
|
||||
(send o pop)))
|
||||
|
||||
(test/pos-blame
|
||||
'->im-higher-order-2
|
||||
'(let* ([stack% (contract (class/c
|
||||
[pop (->im () #:pre () (not (send this empty?)) [_ number?])]
|
||||
[push (->im ([arg number?]) [_ void?]
|
||||
#:post () (not (send this empty?)))]
|
||||
[empty? (->m boolean?)])
|
||||
(class object% (super-new)
|
||||
(define stack null)
|
||||
(define/public (empty?) (null? stack))
|
||||
(define/public (push v) (void))
|
||||
(define/public (pop)
|
||||
(define res (car stack))
|
||||
(set! stack (cdr stack))
|
||||
res))
|
||||
'pos
|
||||
'neg)]
|
||||
[o (new stack%)])
|
||||
(send o push 4)
|
||||
(send o empty?)
|
||||
(send o pop)))
|
||||
|
||||
(test/neg-blame
|
||||
'->im-higher-order-3
|
||||
'(let* ([stack% (contract
|
||||
(class/c
|
||||
[pop (->im () #:pre () (not (send this empty?)) [_ number?])]
|
||||
[push (->im ([arg number?]) [_ void?] #:post () (not (send this empty?)))]
|
||||
[empty? (->m boolean?)])
|
||||
(class object% (super-new)
|
||||
(define stack null)
|
||||
(define/public (empty?) (null? stack))
|
||||
(define/public (push v) (set! stack (cons v stack)))
|
||||
(define/public (pop) (let ([res (car stack)]) (set! stack (cdr stack)) res)))
|
||||
'pos
|
||||
'neg)]
|
||||
[o (new stack%)])
|
||||
(send o pop)))
|
||||
|
||||
(test/spec-passed
|
||||
'case->m-first-order-1
|
||||
'(contract (class/c [m (case->m (-> number? number?) (-> number? number? number?))])
|
||||
|
|
|
|||
|
|
@ -10,11 +10,12 @@
|
|||
"../contract/combinator.rkt"
|
||||
(only-in "../contract/private/arrow-val-first.rkt" ->-internal ->*-internal)
|
||||
(only-in "../contract/private/case-arrow.rkt" case->-internal)
|
||||
(only-in "../contract/private/arr-i.rkt" ->i-internal)
|
||||
(only-in "../contract/private/arr-d.rkt" ->d-internal))
|
||||
|
||||
(provide make-class/c class/c-late-neg-proj
|
||||
blame-add-method-context blame-add-field-context blame-add-init-context
|
||||
class/c ->m ->*m ->dm case->m object/c instanceof/c
|
||||
class/c ->m ->*m ->im ->dm case->m object/c instanceof/c
|
||||
make-wrapper-object
|
||||
check-object-contract
|
||||
(for-syntax parse-class/c-specs)
|
||||
|
|
@ -44,6 +45,12 @@
|
|||
(case->-internal (syntax/loc stx (case->m . args))
|
||||
#|method?|# #t)]))
|
||||
|
||||
(define-syntax (->im stx)
|
||||
(syntax-case stx ()
|
||||
[(_ . args)
|
||||
(->i-internal (syntax/loc stx (->im . args))
|
||||
#|method?|# #t)]))
|
||||
|
||||
(define-syntax (->dm stx)
|
||||
(syntax-case stx ()
|
||||
[(_ . args)
|
||||
|
|
|
|||
|
|
@ -64,7 +64,7 @@
|
|||
method-in-interface? interface->method-names class->interface class-info
|
||||
(struct-out exn:fail:object)
|
||||
make-primitive-class
|
||||
class/c ->m ->*m ->dm case->m object/c instanceof/c
|
||||
class/c ->m ->*m ->im ->dm case->m object/c instanceof/c
|
||||
dynamic-object/c
|
||||
class-seal class-unseal
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user