racket/snip: fix style-list%' notify-on-change' and contracts

The method uses the new `impersonator-ephemeron' function to
retain a callback as long any value that it impersonates
is reachable.

original commit: dbdfd4236f1f759a2c6706901dad25bd46998509

collects/scribblings/gui/style-list-class.scrbl

@@ -126,19 +126,27 @@ The @racket[like-style] style must be in this style list, otherwise
 @defmethod[(notify-on-change [f ((or/c (is-a?/c style<%>) #f) . -> . any)])
            any/c]{
 
-Attaches a callback to the style list, retaining the callback only weakly (in
- the sense of @racket[make-weak-box]). The callback is invoked
- whenever a style is modified.
+Attaches a callback @racket[f] to the style list. The callback
+ @racket[f] is invoked whenever a style is modified.
 
 Often, a change in one style will trigger a change in several other
  derived styles; to allow clients to handle all the changes in a
- batch, @racket[#f] is passed in as the changing style after a set of
+ batch, @racket[#f] is passed to @racket[f] as the changing style after a set of
  styles has been processed.
 
 The return value from @method[style-list% notify-on-change] is an
  opaque key to be used with @method[style-list% forget-notification].
 
-}
+The callback @racket[f] replaces any callback for which it is
+ @racket[equal?], which helps avoid redundant notifications in case of
+ redundant registrations. The callback @racket[f] is retained only
+ weakly (in the sense of @racket[make-weak-box]), but it is retained
+ as long as any value that @racket[f] impersonates is reachable; for
+ example, if @racket[f] represents a function with a contract applied,
+ then @racket[f] is retained for notification as long as the original
+ (pre-contract) function is reachable. The callback @racket[f] is also
+ retained as long as the opaque key produced by @method[style-list%
+ notify-on-change] is reachable.}
 
 
 @defmethod[(number)

collects/tests/gracket/editor.rktl

@@ -608,6 +608,46 @@
   (send t set-clickback 1 3 void)
   (send t delete 0 5)
   (send t undo))
+
+;; ----------------------------------------
+;; notification callbacks, weak links, and chaperones:
+
+(let ()
+  (define id 0)
+  (define count 0)
+  (define count2 0)
+
+  (define sl (new style-list%))
+
+  (define N 100)
+
+  (define cbs
+    (for/list ([i (in-range N)])
+      (define cb (lambda (x) (set! id i) (set! count (add1 count))))
+      ;; procedure retained:
+      (void (send sl notify-on-change (chaperone-procedure cb (lambda (v) v))))
+      ;; procedure not retained:
+      (void (send sl notify-on-change (lambda (x) (set! id i) (set! count2 (add1 count2)))))
+      cb))
+
+  (define (try name)
+    (send sl new-named-style name (send sl find-named-style "Basic")))
+
+  (try "X")
+  (set! count 0)
+  (set! count2 0)
+
+  (collect-garbage)
+  (try "Y") ;; expect 2 callbacks per notifier
+
+  (define v #f)
+  (set! v cbs) ;; forces retention of `cbs'
+  (unless (= (length v) N) (error "test is broken"))
+
+  (unless (= count (* 2 N))
+    (error 'notifications "too weak? ~e" count))
+  (unless (<= 0 count2 (/ N 2))
+    (error 'notifications "not weak enough? ~e" count2)))
   
 ;; ----------------------------------------