unstable: more docs, a few changes to gui libs
svn: r16887 original commit: 50bfe1b8be5f548f3fca0ff99839b20fdc046315
This commit is contained in:
Ryan Culpepper
parent
52a7d2c20c
commit
64e35b664e
|
|
@ -1,134 +1,17 @@
|
||||||
|
|
||||||
#lang scheme/base
|
#lang scheme/base
|
||||||
(require (for-syntax scheme/base unstable/syntax)
|
;; owner: ryanc
|
||||||
scheme/list
|
(require scheme/list
|
||||||
scheme/class
|
scheme/class
|
||||||
scheme/gui)
|
scheme/gui
|
||||||
(provide field/notify
|
"../private/notify.ss")
|
||||||
notify-methods
|
(provide (all-from-out "../private/notify.ss")
|
||||||
connect-to-pref
|
|
||||||
connect-to-pref/readonly
|
|
||||||
notify-box%
|
|
||||||
notify-box/pref
|
|
||||||
notify-box/pref/readonly
|
|
||||||
menu-option/notify-box
|
menu-option/notify-box
|
||||||
menu-group/notify-box
|
menu-group/notify-box
|
||||||
check-box/notify-box
|
check-box/notify-box
|
||||||
choice/notify-box)
|
choice/notify-box)
|
||||||
|
|
||||||
(define-for-syntax (mk-init name)
|
;; GUI elements tied to notify-boxes
|
||||||
(format-id name "init-~a" (syntax-e name)))
|
;; See unstable/private/notify.ss for the non-gui parts of notify-boxes.
|
||||||
(define-for-syntax (mk-get name)
|
|
||||||
(format-id name "get-~a" (syntax-e name)))
|
|
||||||
(define-for-syntax (mk-set name)
|
|
||||||
(format-id name "set-~a" (syntax-e name)))
|
|
||||||
(define-for-syntax (mk-listen name)
|
|
||||||
(format-id name "listen-~a" (syntax-e name)))
|
|
||||||
|
|
||||||
(define-syntax (field/notify stx)
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(field/notify name value)
|
|
||||||
(with-syntax ([init-name (mk-init #'name)]
|
|
||||||
[get-name (mk-get #'name)]
|
|
||||||
[set-name (mk-set #'name)]
|
|
||||||
[listen-name (mk-listen #'name)])
|
|
||||||
#'(begin (field [name (init-name)])
|
|
||||||
(define/public (init-name) value)
|
|
||||||
(define/public-final (get-name)
|
|
||||||
(send name get))
|
|
||||||
(define/public-final (set-name new-value)
|
|
||||||
(send name set new-value))
|
|
||||||
(define/public-final (listen-name listener)
|
|
||||||
(send name listen listener))))]))
|
|
||||||
|
|
||||||
(define-syntax (notify-methods stx)
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(notify-methods name)
|
|
||||||
(with-syntax ([init-name (mk-init #'name)]
|
|
||||||
[get-name (mk-get #'name)]
|
|
||||||
[set-name (mk-set #'name)]
|
|
||||||
[listen-name (mk-listen #'name)])
|
|
||||||
#'(begin (field [name (init-name)])
|
|
||||||
(define/public (init-name)
|
|
||||||
(new notify-box% (value #f)))
|
|
||||||
(define/public-final (get-name)
|
|
||||||
(send name get))
|
|
||||||
(define/public-final (set-name new-value)
|
|
||||||
(send name set new-value))
|
|
||||||
(define/public-final (listen-name listener)
|
|
||||||
(send name listen listener))))]))
|
|
||||||
|
|
||||||
(define-syntax (connect-to-pref stx)
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(connect-to-pref name pref)
|
|
||||||
(with-syntax ([init-name (mk-init #'name)])
|
|
||||||
#'(define/override (init-name) (notify-box/pref pref)))]))
|
|
||||||
|
|
||||||
(define-syntax (connect-to-pref/readonly stx)
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(connect-to-pref/readonly name pref)
|
|
||||||
(with-syntax ([init-name (mk-init #'name)])
|
|
||||||
#'(define/override (init-name) (notify-box/pref/readonly pref)))]))
|
|
||||||
|
|
||||||
#|
|
|
||||||
(define-syntax (define/listen stx)
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(define/listen name value)
|
|
||||||
(unless (identifier? #'name)
|
|
||||||
(raise-syntax-error 'define/listen "expected identifier" #'name))
|
|
||||||
(with-syntax ([get-name (mk-get #'name)]
|
|
||||||
[set-name (mk-set #'name)]
|
|
||||||
[listen-name (mk-listen #'name)])
|
|
||||||
#'(begin
|
|
||||||
(define name value)
|
|
||||||
(define listeners null)
|
|
||||||
(define/public-final (get-name) name)
|
|
||||||
(define/public-final (set-name new-value)
|
|
||||||
(set! name new-value)
|
|
||||||
(for-each (lambda (listener) (listener new-value)) listeners))
|
|
||||||
(define/public-final (listen-name listener)
|
|
||||||
(set! listeners (cons listener listeners)))))]))
|
|
||||||
|#
|
|
||||||
|
|
||||||
(define notify-box%
|
|
||||||
(class object%
|
|
||||||
(init value)
|
|
||||||
(define v value)
|
|
||||||
(define listeners null)
|
|
||||||
|
|
||||||
;; get : -> value
|
|
||||||
;; Fetch current value
|
|
||||||
(define/public (get)
|
|
||||||
v)
|
|
||||||
|
|
||||||
;; set : value -> void
|
|
||||||
;; Update value and notify listeners
|
|
||||||
(define/public (set nv)
|
|
||||||
(set! v nv)
|
|
||||||
(for-each (lambda (p) (p nv)) listeners))
|
|
||||||
|
|
||||||
;; listen : (value -> void) -> void
|
|
||||||
;; Add a listener
|
|
||||||
(define/public (listen p)
|
|
||||||
(set! listeners (cons p listeners)))
|
|
||||||
|
|
||||||
;; remove-listener : (value -> void) -> void
|
|
||||||
(define/public (remove-listener p)
|
|
||||||
(set! listeners (remq p listeners)))
|
|
||||||
|
|
||||||
;; remove-all-listeners : -> void
|
|
||||||
(define/public (remove-all-listeners)
|
|
||||||
(set! listeners null))
|
|
||||||
|
|
||||||
(super-new)))
|
|
||||||
|
|
||||||
(define (notify-box/pref pref)
|
|
||||||
(define nb (new notify-box% (value (pref))))
|
|
||||||
(send nb listen pref)
|
|
||||||
nb)
|
|
||||||
|
|
||||||
(define (notify-box/pref/readonly pref)
|
|
||||||
(new notify-box% (value (pref))))
|
|
||||||
|
|
||||||
(define (menu-option/notify-box parent label nb)
|
(define (menu-option/notify-box parent label nb)
|
||||||
(define menu-item
|
(define menu-item
|
||||||
|
|
|
||||||
|
|
@ -1,13 +1,10 @@
|
||||||
|
|
||||||
#lang scheme/base
|
#lang scheme/base
|
||||||
(require (for-syntax scheme/base)
|
;; owner: ryanc
|
||||||
|
(require (for-syntax scheme/base syntax/parse)
|
||||||
framework/framework)
|
framework/framework)
|
||||||
(provide pref:get/set)
|
(provide pref:get/set)
|
||||||
|
|
||||||
(define-syntax pref:get/set
|
(define (pref:get/set sym)
|
||||||
(syntax-rules ()
|
(case-lambda
|
||||||
[(_ get/set prop)
|
[() (preferences:get sym)]
|
||||||
(define get/set
|
[(v) (preferences:set sym v)]))
|
||||||
(case-lambda
|
|
||||||
[() (preferences:get 'prop)]
|
|
||||||
[(newval) (preferences:set 'prop newval)]))]))
|
|
||||||
|
|
|
||||||
85
collects/unstable/private/notify.ss
Normal file
85
collects/unstable/private/notify.ss
Normal file
|
|
@ -0,0 +1,85 @@
|
||||||
|
#lang scheme/base
|
||||||
|
;; owner: ryanc
|
||||||
|
(require (for-syntax scheme/base syntax/parse unstable/syntax)
|
||||||
|
scheme/list
|
||||||
|
scheme/class)
|
||||||
|
(provide define-notify
|
||||||
|
notify-box%
|
||||||
|
notify-box/pref)
|
||||||
|
|
||||||
|
;; Non-gui parts of notify-boxes
|
||||||
|
;; Worth splitting into two libraries?
|
||||||
|
;; Probably not, very few non-gui uses of classes.
|
||||||
|
|
||||||
|
(define-for-syntax (mk-init name)
|
||||||
|
(format-id name "init-~a" (syntax-e name)))
|
||||||
|
(define-for-syntax (mk-get name)
|
||||||
|
(format-id name "get-~a" (syntax-e name)))
|
||||||
|
(define-for-syntax (mk-set name)
|
||||||
|
(format-id name "set-~a" (syntax-e name)))
|
||||||
|
(define-for-syntax (mk-listen name)
|
||||||
|
(format-id name "listen-~a" (syntax-e name)))
|
||||||
|
|
||||||
|
(define-syntax (define-notify stx)
|
||||||
|
(syntax-parse stx
|
||||||
|
[(define-notify name:id
|
||||||
|
(~optional value:expr
|
||||||
|
#:defaults ([value #'(new notify-box% (value #f))]))
|
||||||
|
(~optional (~and #:init-method init-method)))
|
||||||
|
(with-syntax ([init-name (mk-init #'name)]
|
||||||
|
[get-name (mk-get #'name)]
|
||||||
|
[set-name (mk-set #'name)]
|
||||||
|
[listen-name (mk-listen #'name)])
|
||||||
|
(with-syntax ([(init-expr init-method-decl)
|
||||||
|
(if (attribute init-method)
|
||||||
|
(list #'(init-name)
|
||||||
|
#'(define/public (init-name) value))
|
||||||
|
(list #'value
|
||||||
|
#'(begin)))])
|
||||||
|
(quasisyntax/loc stx
|
||||||
|
(begin (field [name init-expr])
|
||||||
|
init-method-decl
|
||||||
|
(define/public-final (get-name)
|
||||||
|
(send name get))
|
||||||
|
(define/public-final (set-name new-value)
|
||||||
|
(send name set new-value))
|
||||||
|
(define/public-final (listen-name listener)
|
||||||
|
(send name listen listener))))))]))
|
||||||
|
|
||||||
|
(define notify-box%
|
||||||
|
(class object%
|
||||||
|
(init value)
|
||||||
|
(define v value)
|
||||||
|
(define listeners null)
|
||||||
|
|
||||||
|
;; get : -> value
|
||||||
|
;; Fetch current value
|
||||||
|
(define/public (get)
|
||||||
|
v)
|
||||||
|
|
||||||
|
;; set : value -> void
|
||||||
|
;; Update value and notify listeners
|
||||||
|
(define/public (set nv)
|
||||||
|
(set! v nv)
|
||||||
|
(for-each (lambda (p) (p nv)) listeners))
|
||||||
|
|
||||||
|
;; listen : (value -> void) -> void
|
||||||
|
;; Add a listener
|
||||||
|
(define/public (listen p)
|
||||||
|
(set! listeners (cons p listeners)))
|
||||||
|
|
||||||
|
;; remove-listener : (value -> void) -> void
|
||||||
|
(define/public (remove-listener p)
|
||||||
|
(set! listeners (remq p listeners)))
|
||||||
|
|
||||||
|
;; remove-all-listeners : -> void
|
||||||
|
(define/public (remove-all-listeners)
|
||||||
|
(set! listeners null))
|
||||||
|
|
||||||
|
(super-new)))
|
||||||
|
|
||||||
|
|
||||||
|
(define (notify-box/pref pref #:readonly? [readonly? #f])
|
||||||
|
(define nb (new notify-box% (value (pref))))
|
||||||
|
(send nb listen pref)
|
||||||
|
nb)
|
||||||
Loading…
Reference in New Issue
Block a user