Add the contract shorthands for -> and ->* to use for methods where we don't

care about properties of this.

svn: r18248

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|#)
 

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
+to the implicit @scheme[this] parameter of the method.  This allows for
-discuss the state of the object when the method is called (or, for dependent
+contracts which discuss the state of the object when the method is called
-contracts, in other parts of the contract).
+(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)
 

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))
+
 ;                                                              
 ;                                                              
 ;             ;;        ;;                     ;    ;;