syndicate-2017/racket/syndicate/drivers/gui.rkt

190 lines
7.0 KiB
Racket

#lang syndicate
;; 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)))))))