Special macro's for racket/gui

gui-class.rkt

@@ -0,0 +1,97 @@
+#lang racket
+
+(require (rename-in racket/gui [send old-send] [new old-new]))
+(require (for-syntax (rename-in roos [-> old->])))
+(require (rename-in roos [-> old->]))
+
+(provide (all-from-out roos)
+         (all-from-out racket/gui)
+         -> send new
+         )
+
+(define-syntax send
+  (syntax-rules ()
+    ((_ obj method)
+     (if (roos-object? obj)
+         (-> obj method)
+         (old-send obj method)))
+    ((_ obj method a ...)
+     (if (roos-object? obj)
+         (-> obj method a ...)
+         (old-send obj method a ...)))
+    ))
+
+
+
+(define-syntax ->
+  (syntax-rules ()
+    ((_ obj method)
+     (if (roos-object? obj)
+         (old-> obj method)
+         (old-send obj method)))
+    ((_ obj method a ...)
+     (if (roos-object? obj)
+         (old-> obj method a ...)
+         (old-send obj method a ...)))
+    ))
+
+(define-syntax new*
+  (syntax-rules (v)
+    ((_ cl (x y) ...)
+     (old-new cl (x y) ...))
+    ((_ cl x ...)
+     (old-new cl (v x) ...))
+    ))
+
+(define-syntax new
+  (syntax-rules ()
+    ((_ cl)
+     (if (roos-class? cl)
+         (roos-new cl)
+         (old-new cl)))
+    ((_ cl a ...)
+     (if (roos-class? cl)
+         (roos-new cl a ...)
+         (new* cl a ...)))
+    ))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Testing
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(module+ test
+  (require rackunit)
+
+  (define (t% x)
+    (class object%
+      (init-field (y* x))
+      (define/public (y) y*)
+      (define/public (y! x) (set! y* x))
+      (define/public (f a) (* (send this y) a))
+      (super-new)
+      ))
+
+  (def-roos (t x) this (supers)
+    (y x)
+    ((f a) (* (-> this y) a))
+    )
+  
+  (check-true
+   (let ((cl (t% 5)))
+     (let ((o (new cl)))
+       (= (send o f 2) 10))))
+
+  (check-true
+   (let ((cl (t% 6)))
+     (let ((o (new cl)))
+       (= (-> o f 3) 18))))
+
+  (check-true
+   (let ((o (new t 8)))
+     (= (-> o f 4) 32)))
+
+  (check-true
+   (= (send (new t 4) f 2) 8))
+)
+

scribblings/gui-class.scrbl

@@ -0,0 +1,21 @@
+#lang scribble/manual
+
+@(require
+   scribble/example
+   @(for-label roos/gui-class))
+
+@(define myeval
+   (make-base-eval '(require roos/class)))
+
+
+@title[#:tag "top"]{Interoperability Macros for roos and racket/gui}
+
+@author[@author+email["Hans Dijkema" "hans@dijkewijk.nl"]]
+
+@defmodule[roos/gui-class]
+
+This module provides a compatibility layer between the @seclink["roos"  #:doc '(lib "roos/scribblings/roos.scrbl") ]{@racketmodname[roos]} object system and the standard @racketmodname[racket/class] system. It exports the macros @racket[send], @racket[->], and @racket[new], which automatically dispatch to the appropriate implementation based on the type of the given object or class.
+
+This one is specifically for racket/gui. The provided macros are the same as for @seclink["roos/class" #:doc '(lib "roos/scribblings/class.scrbl")].
+
+@; End of documentation