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