1#lang racket/base 2;; owner: ryanc 3(require (for-syntax racket/base syntax/parse racket/syntax) 4 racket/class) 5(provide define-notify 6 notify-box% 7 notify-box/pref) 8 9;; Non-gui parts of notify-boxes 10;; Worth splitting into two libraries? 11;; Probably not, very few non-gui uses of classes. 12 13(define-for-syntax (mk-init name) 14 (format-id name "init-~a" (syntax-e name))) 15(define-for-syntax (mk-get name) 16 (format-id name "get-~a" (syntax-e name))) 17(define-for-syntax (mk-set name) 18 (format-id name "set-~a" (syntax-e name))) 19(define-for-syntax (mk-listen name) 20 (format-id name "listen-~a" (syntax-e name))) 21 22(define-syntax (define-notify stx) 23 (syntax-parse stx 24 [(define-notify name:id 25 (~optional value:expr 26 #:defaults ([value #'(new notify-box% (value #f))])) 27 (~optional (~and #:init-method init-method))) 28 (with-syntax ([init-name (mk-init #'name)] 29 [get-name (mk-get #'name)] 30 [set-name (mk-set #'name)] 31 [listen-name (mk-listen #'name)]) 32 (with-syntax ([(init-expr init-method-decl) 33 (if (attribute init-method) 34 (list #'(init-name) 35 #'(define/public (init-name) value)) 36 (list #'value 37 #'(begin)))]) 38 (quasisyntax/loc stx 39 (begin (field [name init-expr]) 40 init-method-decl 41 (define/public-final (get-name) 42 (send name get)) 43 (define/public-final (set-name new-value) 44 (send name set new-value)) 45 (define/public-final (listen-name listener) 46 (send name listen listener))))))])) 47 48(define notify-box% 49 (class object% 50 (init value) 51 (define v value) 52 (define listeners null) 53 54 ;; get : -> value 55 ;; Fetch current value 56 (define/public (get) 57 v) 58 59 ;; set : value -> void 60 ;; Update value and notify listeners 61 (define/public (set nv) 62 (set! v nv) 63 (for-each (lambda (p) (p nv)) listeners)) 64 65 ;; listen : (value -> void) -> void 66 ;; Add a listener 67 (define/public (listen p) 68 (set! listeners (cons p listeners))) 69 70 ;; remove-listener : (value -> void) -> void 71 (define/public (remove-listener p) 72 (set! listeners (remq p listeners))) 73 74 ;; remove-all-listeners : -> void 75 (define/public (remove-all-listeners) 76 (set! listeners null)) 77 78 (super-new))) 79 80 81(define (notify-box/pref pref #:readonly? [readonly? #f]) 82 (define nb (new notify-box% (value (pref)))) 83 (send nb listen pref) 84 nb) 85