diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index 5ff1260191..2784d61608 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -3,6 +3,7 @@ (require (for-syntax scheme/base) mzlib/etc scheme/contract/base + (only-in scheme/contract/private/arrow making-a-method) scheme/list scheme/stxparam "class-events.ss" @@ -55,7 +56,7 @@ method-in-interface? interface->method-names class->interface class-info (struct-out exn:fail:object) make-primitive-class - class/c #| object/c |# + class/c ->m ->*m #| object/c |# ;; "keywords": private public override augment @@ -2457,6 +2458,14 @@ ;; class/c ;;-------------------------------------------------------------------- +;; Shorthand contracts that treat the implicit object argument as if it were +;; contracted with any/c. +(define-syntax-rule (->m . stx) + (syntax-parameterize ([making-a-method #t]) (-> . stx))) + +(define-syntax-rule (->*m . stx) + (syntax-parameterize ([making-a-method #t]) (->* . stx))) + (define (class/c-check-first-order ctc cls blame) (let/ec return (define (failed str . args) @@ -4648,5 +4657,5 @@ method-in-interface? interface->method-names class->interface class-info (struct-out exn:fail:object) make-primitive-class - class/c #|object/c|#) + class/c ->m ->*m #|object/c|#) diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl index 9f6196a98a..952bca243d 100644 --- a/collects/scribblings/reference/class.scrbl +++ b/collects/scribblings/reference/class.scrbl @@ -1498,14 +1498,16 @@ class hierarchy. This separation allows for stronger contracts for class clients and weaker contracts for subclasses. Method contracts must contain an additional initial argument which corresponds -to the @scheme[this] parameter of the method. This allows for contracts which -discuss the state of the object when the method is called (or, for dependent -contracts, in other parts of the contract). +to the implicit @scheme[this] parameter of the method. This allows for +contracts which discuss the state of the object when the method is called +(or, for dependent contracts, in other parts of the contract). Two alternative +contract forms, @scheme[->m] and @scheme[->m*], are provided as a shorthand +for writing method contracts. The external contracts are as follows: @itemize[ - @item{A method contract without a tag for @scheme[method-id] describes the behavior + @item{A method contract without a tag describes the behavior of the implementation of @scheme[method-id] on method sends to an object of the contracted class. This contract will continue to be checked in subclasses until the contracted class's implementation is no longer the entry point for dynamic @@ -1550,6 +1552,18 @@ The internal contracts are as follows: @scheme[augride] is used when subclasses can override the current augmentation.} ]} +@defform[(->m dom ... range)]{ +Similar to @scheme[->], except that the domain of the resulting contract contains one more element +than the stated domain, where the first (implicit) argument is contracted with @scheme[any/c]. +This contract is useful for writing simpler method contracts when no properties of @scheme[this] +need to be checked.} + +@defform[(->*m (mandatory-dom ...) (optional-dom ...) rest range)]{ +Similar to @scheme[->*], 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 +@scheme[any/c]. This contract is useful for writing simpler method contracts when no properties +of @scheme[this] need to be checked.} + @defform/subs[ #:literals (field -> ->* ->d) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index bbcaf601a6..9c250e25ae 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -5054,6 +5054,34 @@ [e% (class d% (super-new) (define/override (m x) x))]) (send (new e%) f))) + (test/spec-passed + '->m-first-order-1 + '(contract (class/c [m (->m number? number?)]) + (class object% (super-new) (define/public (m x) x)) + 'pos + 'neg)) + + (test/pos-blame + '->m-first-order-2 + '(contract (class/c [m (->m any/c number? number?)]) + (class object% (super-new) (define/public (m x) x)) + 'pos + 'neg)) + + (test/spec-passed + '->*m-first-order-1 + '(contract (class/c [m (->*m (number?) (string?) number?)]) + (class object% (super-new) (define/public (m x [f "foo"]) x)) + 'pos + 'neg)) + + (test/pos-blame + '->*m-first-order-2 + '(contract (class/c [m (->*m (any/c number?) (string?) number?)]) + (class object% (super-new) (define/public (m x [f "foo"]) x)) + 'pos + 'neg)) + ; ; ; ;; ;; ; ;;