diff --git a/gui-class.rkt b/gui-class.rkt new file mode 100644 index 0000000..2dcfc35 --- /dev/null +++ b/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)) +) + diff --git a/scribblings/gui-class.scrbl b/scribblings/gui-class.scrbl new file mode 100644 index 0000000..9332e59 --- /dev/null +++ b/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