From 6e399dd1dd89f5b0e0006df811e2116929fd2137 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 29 Jul 2017 23:17:55 -0400 Subject: [PATCH] Experimental Racket GUI driver. --- racket/syndicate/drivers/gui.rkt | 189 ++++++++++++++++++++++++ racket/syndicate/examples/actor/gui.rkt | 49 ++++++ 2 files changed, 238 insertions(+) create mode 100644 racket/syndicate/drivers/gui.rkt create mode 100644 racket/syndicate/examples/actor/gui.rkt diff --git a/racket/syndicate/drivers/gui.rkt b/racket/syndicate/drivers/gui.rkt new file mode 100644 index 0000000..26dc60b --- /dev/null +++ b/racket/syndicate/drivers/gui.rkt @@ -0,0 +1,189 @@ +#lang syndicate/actor +;; Driver for Racket's GUI. + +(require racket/class) +(require racket/gui) + +(provide (struct-out widget) + (struct-out widget-prop) + (struct-out widget-object) + (struct-out widget-event) + assert-widget) + +(module+ implementation-details + (provide (struct-out widget-query) + (struct-out frames-present) + (struct-out frame-closing))) + +(struct widget (id type) #:prefab) ;; assertion +(struct widget-prop (id key value) #:prefab) ;; assertion +(struct widget-object (id object) #:prefab) ;; assertion +(struct widget-event (id class type event) #:prefab) ;; message + +(struct widget-query (object key ch) #:prefab) ;; message +(struct frames-present () #:prefab) ;; assertion +(struct frame-closing (object) #:prefab) ;; message + +(define-syntax-rule (assert-widget id type [prop init] ...) + (begin (assert (widget id type)) + (assert (widget-prop id 'prop init)) ...)) + +(define *widget-types* (make-hasheq)) + +(define (define-widget-type! type proc) + (hash-set! *widget-types* type proc)) + +(define-syntax-rule (define-widget-type (type id) body ...) + (define-widget-type! 'type + (lambda (id _type) + body ...))) + +(define-syntax defprop + (syntax-rules () + [(_ w id prop-key #:widget setter-expr) + (begin (define/query-value -wid- #f (widget-prop id 'prop-key $wid-value) wid-value) + (define/query-value prop-key #f (widget-object (-wid-) $o) o + #:on-add (let ((prop-key (prop-key))) + (log-info "Invoking setter for ~a widget-prop ~a: ~a" id 'prop-key prop-key) + setter-expr)))] + [(_ w id prop-key default setter-expr) + (define/query-value prop-key default (widget-prop id 'prop-key $prop-value) prop-value + #:on-add (let ((prop-key (prop-key))) + (log-info "Invoking setter for ~a prop ~a: ~a" id 'prop-key prop-key) + setter-expr))])) + +(define-syntax-rule (with-widget-props w id [[defprop-items ...] ...] body ...) + (begin + (defprop w id defprop-items ...) ... + (on-start (flush!) ;; allow queries to have a go at the dataspace + (react body ...)))) + +(define-syntax-rule (maybe-send receiver selector args ...) + (and receiver + (send receiver selector args ...))) + +(define syndicate-frame% + (class* frame% () + (super-new) + (define/augment (can-close?) + (define ch (make-channel)) + (send-ground-message (widget-query this 'can-close? ch)) + (define answers (channel-get ch)) + (not (set-member? answers #f))) + (define/augment (on-close) + (send-ground-message (frame-closing this))))) + +(define-widget-type (frame id) + (define outermost-facet (current-facet-id)) + (define w #f) + (on-stop (maybe-send w show #f)) + (with-widget-props w id [[label "" (maybe-send w set-label label)] + [parent #:widget (maybe-send w reparent parent)]] + (parameterize ((current-eventspace (make-eventspace))) + (set! w (new syndicate-frame% + [label (label)] + [parent (parent)] + )) + (send w show #t)) + (on (message (inbound (frame-closing w))) + (stop-facet outermost-facet)) + (assert (frames-present)) + (assert (widget-object id w)))) + +(define-syntax-rule (during-parent [id parent-id-var parent-var] body ...) + (during (widget-prop id 'parent $parent-id) + (during (widget-object parent-id $parent) + (log-info "~a --parent--> ~a" id parent-id) + (let ((parent-id-var parent-id) + (parent-var parent)) + body ...)))) + +(define (control-event-callback id) + (lambda (_widget e) + (send-ground-message (widget-event id 'control (send e get-event-type) e)))) + +(define-syntax-rule (on-stop-delete-child w) + (on-stop (maybe-send (maybe-send w get-parent) delete-child w))) + +(define-widget-type (button id) + (during-parent [id parent-id parent] + (define w #f) + (on-stop-delete-child w) + (with-widget-props w id [[label "" (maybe-send w set-label label)] + [enabled #t (maybe-send w enable enabled)]] + (set! w (new button% + [label (label)] + [parent parent] + [enabled (enabled)] + [callback (control-event-callback id)])) + (assert (widget-object id w))))) + +(define-widget-type (message id) + (during-parent [id parent-id parent] + (define w #f) + (on-stop-delete-child w) + (with-widget-props w id [[label "" (maybe-send w set-label label)]] + (set! w (new message% + [label (label)] + [parent parent])) + (assert (widget-object id w))))) + +(define-syntax-rule (on-stop-delete-menu-item w) + (on-stop (maybe-send w delete))) + +(define (get-menu-eventspace x) + (cond + [(is-a? x menu%) (get-menu-eventspace (send x get-parent))] + [(is-a? x menu-bar%) (get-menu-eventspace (send x get-frame))] + [(is-a? x frame%) (send x get-eventspace)])) + +(define-widget-type (menu-bar id) + (during-parent [id parent-id parent] + (define w #f) + ;; (on-stop-delete w) ;; It turns out there is no way to remove a menu-bar% from a frame% ! + (with-widget-props w id [] + (parameterize ((current-eventspace (get-menu-eventspace parent))) + (set! w (new menu-bar% + [parent parent]))) + (assert (widget-object id w))))) + +(define-widget-type (menu id) + (during-parent [id parent-id parent] + (define w #f) + (on-stop-delete-menu-item w) + (with-widget-props w id [[label "" (maybe-send w set-label label)]] + (parameterize ((current-eventspace (get-menu-eventspace parent))) + (set! w (new menu% + [label (label)] + [parent parent]))) + (assert (widget-object id w))))) + +(define-widget-type (menu-item id) + (during-parent [id parent-id parent] + (define w #f) + (on-stop-delete-menu-item w) + (with-widget-props w id [[label "" (maybe-send w set-label label)]] + (parameterize ((current-eventspace (get-menu-eventspace parent))) + (set! w (new menu-item% + [label (label)] + [parent parent] + [callback (control-event-callback id)]))) + (assert (widget-object id w))))) + +;;--------------------------------------------------------------------------- + +(spawn #:name 'widget-server + (during/spawn (widget $id $type) + #:name (widget id type) + (match (hash-ref *widget-types* type #f) + [#f (error 'widget "Invalid widget type ~a (ID ~a, parent-id ~a)" type id)] + [proc (proc id type)])) + (during (frames-present) + (on (message (inbound (widget-event $id $class $type $event))) + (send! (widget-event id class type event))) + (on (message (inbound (widget-query $w $prop-key $ch))) + (react (define f (current-facet-id)) + (during (widget-object $id w) + (on-start + (channel-put ch (immediate-query (query-set (widget-prop id prop-key $v) v))) + (stop-facet f))))))) diff --git a/racket/syndicate/examples/actor/gui.rkt b/racket/syndicate/examples/actor/gui.rkt new file mode 100644 index 0000000..e16fa6b --- /dev/null +++ b/racket/syndicate/examples/actor/gui.rkt @@ -0,0 +1,49 @@ +#lang syndicate/actor +;; Small test program for the gui.rkt driver + +(require/activate syndicate/drivers/gui) + +(spawn #:name 'demo-w + (field [can-close? #f]) + + (assert-widget 'w 'frame + [label "Hello Syndicate"] + [can-close? (can-close?)]) + (on (asserted (observe (widget-prop 'w 'can-close? _))) + ;; TODO: Reconsider this. Should it be possible to lazily + ;; compute whether or not `can-close?`, when we detect that + ;; someone cares? At present, by the time we find out + ;; someone cares, it's too late to influence their + ;; decision. + (log-info "Oo err, someone cares whether the window can close") + (can-close? #t)) + + (assert-widget 'm 'message + [parent 'w] + [label (format "Window will ~aclose if close icon clicked" + (if (can-close?) "" "not "))]) + + (assert-widget 'w-menu 'menu-bar [parent 'w]) + (assert-widget 'w-file 'menu [parent 'w-menu] [label "File"]) + (assert-widget 'w-exit 'menu-item [parent 'w-file] [label "Exit"]) + (assert-widget 'w-hello 'menu-item [parent 'w-file] [label "Hello!"]) + + (stop-when (message (widget-event 'w-exit _ _ _))) + (on (message (widget-event 'w-hello _ _ _)) + (log-info "Hello!"))) + +(spawn #:name 'demo-b + (field [enabled #f]) + + (assert-widget 'b 'button + [parent 'w] + [label "Click me"] + [enabled (enabled)]) + (stop-when (message (widget-event 'b $c $t $e)) + (log-info "Event: ~v/~v/~v" c t e)) + + (assert-widget 'b2 'button + [parent 'w] + [label "Enable the other one"]) + (on (message (widget-event 'b2 _ _ _)) + (enabled #t)))