racket/class: add send+ for functional style OO

collects/racket/private/class-internal.rkt

@@ -37,7 +37,7 @@
            object% object? externalizable<%> printable<%> writable<%> equal<%>
            object=?
            new make-object instantiate
-           send send/apply send/keyword-apply send* dynamic-send
+           send send/apply send/keyword-apply send* send+ dynamic-send
            class-field-accessor class-field-mutator with-method
            get-field set-field! field-bound? field-names
            private* public*  pubment*
@@ -4195,6 +4195,7 @@ An example
      (unless (symbol? method-name) (raise-argument-error 'dynamic-send "symbol?" method-name))
      (keyword-apply (find-method/who 'dynamic-send obj method-name) kws kw-vals obj args))))
 
+;; imperative chained send
 (define-syntax (send* stx)
   (syntax-case stx ()
     [(form obj clause ...)
@@ -4211,6 +4212,18 @@ An example
                    #f "bad method call" stx clause-stx)]))
            (syntax->list (syntax (clause ...)))))))]))
 
+;; functional chained send
+(define-syntax (send+ stx)
+  (define-syntax-class send-clause
+    #:description "method clause"
+    (pattern [name:id . args]))
+  (syntax-parse stx
+    [(_ obj:expr clause-0:send-clause clause:send-clause ...)
+     (quasisyntax/loc stx
+       (let ([o (send obj clause-0.name . clause-0.args)])
+         (send+ o clause ...)))]
+    [(_ obj:expr) (syntax/loc stx obj)]))
+
 ;; find-method/who : symbol[top-level-form/proc-name]
 ;;                   any[object] 
 ;;                   symbol[method-name] 
@@ -5112,7 +5125,7 @@ An example
          object% object? object=? externalizable<%> printable<%> writable<%> equal<%>
          new make-object instantiate
          get-field set-field! field-bound? field-names
-         send send/apply send/keyword-apply send* dynamic-send
+         send send/apply send/keyword-apply send* send+ dynamic-send
          class-field-accessor class-field-mutator with-method
          private* public*  pubment*
          override* overment*

collects/scribblings/reference/class.scrbl

@@ -1156,6 +1156,33 @@ is the same as
   (send o end-edit-sequence))
 ]}
 
+@defform/subs[(send+ obj-expr msg ...)
+              ([msg (method-id arg ...)
+                    (method-id arg ... . arg-list-expr)])]{
+
+Calls methods (in order) starting with the object produced by
+@racket[obj-expr]. Each method call will be invoked on the result of
+the last method call, which is expected to be an object. Each
+@racket[msg] corresponds to a use of @racket[send].
+
+This is the functional analogue of @racket[send*].
+
+@defexamples[#:eval class-eval
+(define point%
+  (class object%
+    (super-new)
+    (init-field [x 0] [y 0])
+    (define/public (move-x dx)
+      (new this% [x (+ x dx)]))
+    (define/public (move-y dy)
+      (new this% [y (+ y dy)]))))
+
+(send+ (new point%)
+       (move-x 5)
+       (move-y 7)
+       (move-x 12))
+]}
+
 @defform[(with-method ((id (obj-expr method-id)) ...)
            body ...+)]{
 

collects/tests/racket/object.rktl

@@ -1189,6 +1189,7 @@
                          (super-make-object))])
 	      (test 100 'priv (send (make-object c% 100) priv))
 	      (test 100 'priv (send* (make-object c% 100) (priv)))
+              (test 100 'priv (send+ (make-object c% 100) (priv)))
 	      (test 100 'priv (with-method ([p ((make-object c% 100) priv)]) (p)))
 	      (test 100 'gen-priv-cls (send-generic (make-object c% 100) (generic c% priv)))
               (test 100 'gen-priv-intf (send-generic (make-object c% 100) (generic i<%> priv)))
@@ -1197,6 +1198,7 @@
   (test #t object? (make-object c% 10))
   (err/rt-test (send (make-object c% 10) priv) exn:fail:object?)
   (err/rt-test (send* (make-object c% 10) (priv)) exn:fail:object?)
+  (err/rt-test (send+ (make-object c% 10) (priv)) exn:fail:object?)
   (err/rt-test (with-method ([p ((make-object c% 100) priv)]) (p)) exn:fail:object?)
   (err/rt-test (generic c% priv) exn:fail:object?)
   (err/rt-test (make-generic c% 'priv) exn:fail:object?))
@@ -1211,6 +1213,19 @@
 	      (super-new)))])
   (test 16 'send-using-local (send (new c%) pub 3)))
 
+;; ------------------------------------------------------------
+;; `send+' tests
+
+(let ([c% (class object%
+            (define/public (m . args) this)
+            (super-new))])
+  (syntax-test #'(send+ (new c%) (m 5) (m 10)))
+  (syntax-test #'(send+ (new c%) (m . (1 2 3))))
+  (syntax-test #'(send+ (new c%) (m 5) (m . (1 2 3))))
+
+  (test #t object? (send+ (new c%) (m 5) (m 15)))
+  (test #t object? (send+ (new c%) (m 5) (m . (1 2 3 4)))))
+
 ;; ------------------------------------------------------------
 ;; `new' tests