From 64e35b664e3b18a98b73be89413e1971038cac98 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 19 Nov 2009 08:29:57 +0000 Subject: [PATCH] unstable: more docs, a few changes to gui libs svn: r16887 original commit: 50bfe1b8be5f548f3fca0ff99839b20fdc046315 --- collects/unstable/gui/notify.ss | 131 ++-------------------------- collects/unstable/gui/prefs.ss | 15 ++-- collects/unstable/private/notify.ss | 85 ++++++++++++++++++ 3 files changed, 98 insertions(+), 133 deletions(-) create mode 100644 collects/unstable/private/notify.ss diff --git a/collects/unstable/gui/notify.ss b/collects/unstable/gui/notify.ss index 099a5b7c..927bef3c 100644 --- a/collects/unstable/gui/notify.ss +++ b/collects/unstable/gui/notify.ss @@ -1,134 +1,17 @@ - #lang scheme/base -(require (for-syntax scheme/base unstable/syntax) - scheme/list +;; owner: ryanc +(require scheme/list scheme/class - scheme/gui) -(provide field/notify - notify-methods - connect-to-pref - connect-to-pref/readonly - notify-box% - notify-box/pref - notify-box/pref/readonly + scheme/gui + "../private/notify.ss") +(provide (all-from-out "../private/notify.ss") menu-option/notify-box menu-group/notify-box check-box/notify-box choice/notify-box) -(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 (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)))) +;; GUI elements tied to notify-boxes +;; See unstable/private/notify.ss for the non-gui parts of notify-boxes. (define (menu-option/notify-box parent label nb) (define menu-item diff --git a/collects/unstable/gui/prefs.ss b/collects/unstable/gui/prefs.ss index ebc5aa07..a9b4faa7 100644 --- a/collects/unstable/gui/prefs.ss +++ b/collects/unstable/gui/prefs.ss @@ -1,13 +1,10 @@ - #lang scheme/base -(require (for-syntax scheme/base) +;; owner: ryanc +(require (for-syntax scheme/base syntax/parse) framework/framework) (provide pref:get/set) -(define-syntax pref:get/set - (syntax-rules () - [(_ get/set prop) - (define get/set - (case-lambda - [() (preferences:get 'prop)] - [(newval) (preferences:set 'prop newval)]))])) +(define (pref:get/set sym) + (case-lambda + [() (preferences:get sym)] + [(v) (preferences:set sym v)])) diff --git a/collects/unstable/private/notify.ss b/collects/unstable/private/notify.ss new file mode 100644 index 00000000..1c53ce69 --- /dev/null +++ b/collects/unstable/private/notify.ss @@ -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)