add preference layers

gui-lib/framework/preferences.rkt

@@ -28,7 +28,10 @@ the state transitions / contracts are:
 
 (require scribble/srcdoc
          racket/contract/base racket/file)
-(require/doc racket/base scribble/manual (for-label racket/serialize))
+(require/doc racket/base
+             scribble/manual
+             scribble/example
+             (for-label racket/serialize))
 
 (define-struct (exn:unknown-preference exn) ())
 
@@ -43,22 +46,30 @@ the state transitions / contracts are:
 
 ;; preferences : hash-table[sym -o> any]
 ;;   the current values of the preferences
-(define preferences (make-hasheq))
-
 ;; marshall-unmarshall : sym -o> un/marshall
-(define marshall-unmarshall (make-hasheq))
-
 ;; callbacks : sym -o> (listof (sym TST -> boolean))
-(define callbacks (make-hasheq))
-
 ;; defaults : hash-table[sym -o> default]
-(define defaults (make-hasheq))
+(struct preferences:layer (preferences marshall-unmarshall callbacks defaults prev))
 
-;; these four functions determine the state of a preference
-(define (pref-un/marshall-set? pref) (hash-has-key? marshall-unmarshall pref))
-(define (preferences:default-set? pref) (hash-has-key? defaults pref))
-(define (pref-can-init? pref)
-  (not (hash-has-key? preferences pref)))
+(define (preferences:new-layer prev)
+  (preferences:layer (make-hasheq) (make-hasheq) (make-hasheq) (make-hasheq) prev))
+(define preferences:current-layer (make-parameter (preferences:new-layer #f)))
+
+(define (find-layer pref)
+  (let loop ([pref-state (preferences:current-layer)])
+    (and pref-state
+         (cond
+           [(hash-has-key? (preferences:layer-defaults pref-state) pref)
+            pref-state]
+           [(hash-has-key? (preferences:layer-callbacks pref-state) pref)
+            pref-state]
+           [else
+            (loop (preferences:layer-prev pref-state))]))))
+
+(define (preferences:default-set? pref)
+  (define layer (find-layer pref))
+  (and layer
+       (hash-has-key? (preferences:layer-defaults layer) pref)))
 
 ;; type un/marshall = (make-un/marshall (any -> prinable) (printable -> any))
 (define-struct un/marshall (marshall unmarshall))
@@ -80,35 +91,43 @@ the state transitions / contracts are:
 ;; return the current value of the preference `p'
 ;; exported
 (define (preferences:get p)
-  (define v (hash-ref preferences p none))
-  (cond
-    ;; if this is found, we can just return it immediately
-    [(not (eq? v none))
-     v]
-    ;; first time reading this, check the file & unmarshall value, if
-    ;; it's not there, use the default
-    [(preferences:default-set? p)
-     (let* (;; try to read the preference from the preferences file
-            [v (read-pref-from-file p)]
-            [v (if (eq? v none)
-                 ;; no value read, take the default value
-                 (default-value (hash-ref defaults p))
-                 ;; found a saved value, unmarshall it
-                 (unmarshall-pref p v))])
-       ;; set the value for future reference and return it
-       (hash-set! preferences p v)
-       v)]
-    [(not (preferences:default-set? p))
+  (define pref-state (find-layer p))
+  (when (or (not pref-state)
+            (not (hash-has-key? (preferences:layer-defaults pref-state) p)))
     (raise-unknown-preference-error
      'preferences:get
      "tried to get a preference but no default set for ~e"
-      p)]))
+     p))
+  (define preferences (preferences:layer-preferences pref-state))
+  (define v (hash-ref preferences p none))
+  (cond
+    ;; first time reading this, check the file & unmarshall value, if
+    ;; it's not there, use the default
+    [(eq? v none)
+     (define defaults (preferences:layer-defaults pref-state))
+     ;; try to read the preference from the preferences file
+     (define marshalled-v (read-pref-from-file (hash-ref defaults p) p))
+     (define default-info (hash-ref defaults p))
+     (define the-default-value (default-value default-info))
+     (define v (if (eq? marshalled-v none)
+                   ;; no value read, take the default value
+                   the-default-value
+                   ;; found a saved value, unmarshall it
+                   (unmarshall-pref pref-state p marshalled-v
+                                    (default-checker default-info)
+                                    the-default-value)))
+     ;; set the value in the preferences table for easier reference
+     ;; and so we know it has been read from the disk
+     ;; (and thus setting the marshaller after this is no good)
+     (hash-set! preferences p v)
+     v]
+    ;; oth. it is found, so we can just return it
+    [else v]))
 
 ;; read-pref-from-file : symbol -> (or/c any none)
 ;; reads the preference saved in the low-level preferences
 ;; file, first checking 'p' and then checking the aliases (in order)
-(define (read-pref-from-file p)
-  (let ([defaults (hash-ref defaults p)])
+(define (read-pref-from-file defaults p)
   (let loop ([syms (cons p (default-aliases defaults))]
              [rewriters (cons values (default-rewrite-aliases defaults))])
     (cond
@@ -118,7 +137,7 @@ the state transitions / contracts are:
          ((car rewriters)
           ((preferences:low-level-get-preference)
            (add-pref-prefix (car syms))
-             (lambda () (k (loop (cdr syms) (cdr rewriters)))))))]))))
+           (lambda () (k (loop (cdr syms) (cdr rewriters)))))))])))
 
 ;; set : symbol any -> void
 ;; updates the preference
@@ -133,37 +152,37 @@ the state transitions / contracts are:
    (λ ()
      (call-pref-save-callbacks #t))
    (λ ()
-     (for-each
-      (λ (p value)
+     (for ([p (in-list ps)]
+           [value (in-list values)])
+       (define pref-state (find-layer p))
        (cond
-          [(preferences:default-set? p)
-           (define default (hash-ref defaults p))
+         [pref-state
+          (define default (hash-ref (preferences:layer-defaults pref-state) p))
           (define checker? (default-checker default))
           (unless (checker? value)
             (error 'preferences:set
                    (string-append
                     "new value doesn't satisfy preferences:set-default predicate\n"
-                     "  pref sym: ~v\n"
+                    "  pref symbol: ~e\n"
                     "  given: ~e\n"
                     "  predicate: ~e")
                    p value checker?))
-             (check-callbacks p value)
-             (hash-set! preferences p value)]
-          [(not (preferences:default-set? p))
+          (check-callbacks pref-state p value)
+          (hash-set! (preferences:layer-preferences pref-state) p value)]
+         [else
           (raise-unknown-preference-error
            'preferences:set
            (string-append
             "cannot set preference before setting default"
-             "  pref sym: ~e\n"
+            "  pref symbol: ~e\n"
             "  given: ~e")
            p
            value)]))
-      ps values)
      ((preferences:low-level-put-preferences)
       (map add-pref-prefix ps)
-      (map (λ (p value) (marshall-pref p value))
-           ps
-           values))
+      (for/list ([p (in-list ps)]
+                 [value (in-list values)])
+        (marshall-pref p value)))
      (void))
    (λ ()
      (call-pref-save-callbacks #f))))
@@ -201,11 +220,13 @@ the state transitions / contracts are:
           (current-continuation-marks))))
 
 ;; add-callback : sym (-> void) -> void
-(define preferences:add-callback 
-  (lambda (p callback [weak? #f])
-    (let ([new-cb (make-pref-callback (if weak?
+(define (preferences:add-callback p callback [weak? #f])
+  (define pref-state (or (find-layer p) (preferences:current-layer)))
+  (define callbacks (preferences:layer-callbacks pref-state))
+  (define new-cb
+    (make-pref-callback (if weak?
                             (impersonator-ephemeron callback)
-                                          callback))])
+                            callback)))
   (hash-set! callbacks
              p
              (append
@@ -224,10 +245,11 @@ the state transitions / contracts are:
               [(eq? callback new-cb)
                (loop (cdr callbacks))]
               [else
-                   (cons (car callbacks) (loop (cdr callbacks)))]))])))))))
+               (cons (car callbacks) (loop (cdr callbacks)))]))])))))
 
-;; check-callbacks : sym val -> void
-(define (check-callbacks p value)
+;; check-callbacks : pref-state sym val -> void
+(define (check-callbacks pref-state p value)
+  (define callbacks (preferences:layer-callbacks pref-state))
   (define new-callbacks
     (let loop ([callbacks (hash-ref callbacks p '())])
       (cond
@@ -252,106 +274,137 @@ the state transitions / contracts are:
       (hash-set! callbacks p new-callbacks)))
 
 (define (preferences:set-un/marshall p marshall unmarshall)
+  (define pref-state (find-layer p))
   (cond
-    [(and (preferences:default-set? p)
-          (not (pref-un/marshall-set? p))
-          (pref-can-init? p))
+    [pref-state
+     (define marshall-unmarshall (preferences:layer-marshall-unmarshall pref-state))
+     (define pref-un/marshall-set? (hash-ref marshall-unmarshall p #f))
+     (define pref-can-init? (not (hash-has-key? (preferences:layer-preferences pref-state) p)))
+     (cond
+       [(and (not pref-un/marshall-set?) pref-can-init?)
         (hash-set! marshall-unmarshall p (make-un/marshall marshall unmarshall))]
-    [(not (preferences:default-set? p))
-     (error 'preferences:set-un/marshall
-            "must call set-default for ~s before calling set-un/marshall for ~s"
-            p p)]
-    [(pref-un/marshall-set? p)
+       [pref-un/marshall-set?
         (error 'preferences:set-un/marshall
                "already set un/marshall for ~e"
                p)]
-    [(not (pref-can-init? p))
-     (error 'preferences:set-un/marshall "the preference ~e cannot be configured any more" p)]))
-
-(define (preferences:restore-defaults)
-  (hash-for-each
-   defaults
-   (λ (p def) (preferences:set p (default-value def)))))
+       [(not pref-can-init?)
+        (error 'preferences:set-un/marshall "the preference ~e cannot be configured any more" p)])]
+    [else
+     (error 'preferences:set-un/marshall
+            "must call preferences:set-default for ~s before calling set-un/marshall for ~s"
+            p p)]))
 
 ;; set-default : (sym TST (TST -> boolean) -> void
 (define (preferences:set-default p default-value checker
                                  #:aliases [aliases '()]
-                                 #:rewrite-aliases [rewrite-aliases (map (lambda (x) values) aliases)])
-  (cond
-    [(and (not (preferences:default-set? p))
-          (pref-can-init? p))
-     (define default-okay? (checker default-value))
-     (unless default-okay?
-       (error 'set-default 
+                                 #:rewrite-aliases [rewrite-aliases (map (λ (x) values) aliases)])
+  (define pref-state (or (find-layer p) (preferences:current-layer)))
+  (define defaults (preferences:layer-defaults pref-state))
+  (when (hash-has-key? defaults p)
+    (error 'preferences:set-default
            (string-append
-               "checker doesn't match default\n"
+            "preferences default already set\n"
+            "  pref symbol: ~e\n"
+            "  default: ~e\n"
+            "  checker: ~e")
+           p default-value checker))
+  (unless (checker default-value)
+    (error 'preferences:set-default
+           (string-append
+            "checker doesn't match default\n"
+            "  pref symbol: ~e\n"
             "  default: ~e\n"
-               "  pref sym: ~e\n"
             "  checker: ~e")
            p default-value checker))
-
   (unless (= (length aliases) (length rewrite-aliases))
     (error 'preferences:set-default
-	      "expected equal length lists for the #:aliases and #:rewrite-aliases arguments, got ~e and ~e"
+           (string-append
+            "expected equal length lists for the #:aliases"
+            " and #:rewrite-aliases arguments, got ~e and ~e")
            aliases rewrite-aliases))
-     (hash-set! defaults p (make-default default-value checker aliases rewrite-aliases))]
-    [(not (pref-can-init? p))
-     (error 'preferences:set-default
-            "tried to call set-default for preference ~e but it cannot be configured any more"
-            p)]
-    [(preferences:default-set? p)
-     (error 'preferences:set-default
-            "preferences default already set for ~e" p)]
-    [(not (pref-can-init? p))
-     (error 'preferences:set-default
-            "can no longer set the default for ~e" p)]))
+  (hash-set! defaults p (make-default default-value checker aliases rewrite-aliases)))
 
 ;; marshall-pref : symbol any -> (list symbol printable)
 (define (marshall-pref p value)
+  (define pref-state (find-layer p))
   (let/ec k
-    (let* ([marshaller
+    (define marshaller
       (un/marshall-marshall
-             (hash-ref marshall-unmarshall p (λ () (k value))))])
-      (marshaller value))))
+       (hash-ref (preferences:layer-marshall-unmarshall pref-state)
+                 p
+                 (λ () (k value)))))
+    (marshaller value)))
 
-;; unmarshall-pref : symbol marshalled -> any
+;; unmarshall-pref : pref-state symbol marshalled (any -> bool) any -> any
 ;; unmarshalls a preference read from the disk
-(define (unmarshall-pref p data)
-  (let* ([un/marshall (hash-ref marshall-unmarshall p #f)]
-         [result (if un/marshall
+(define (unmarshall-pref pref-state p data the-checker the-default-value)
+  (define marshall-unmarshall (preferences:layer-marshall-unmarshall pref-state))
+  (define un/marshall (hash-ref marshall-unmarshall p #f))
+  (define result
+    (if un/marshall
         ((un/marshall-unmarshall un/marshall) data)
-                     data)]
-         [default (hash-ref defaults p)])
-    (if ((default-checker default) result)
+        data))
+  (if (the-checker result)
       result
-        (default-value default))))
+      the-default-value))
 
 ;; copy-pref-value : sym any -> any
 ;; uses the marshalling code to copy a preference. If there
 ;; is not marshaller set, then no copying happens.
 (define (copy-pref-value p value)
   (let/ec k
-    (let* ([un/marshaller (hash-ref marshall-unmarshall p (λ () (k value)))]
-           [default (hash-ref defaults p)]
-           [marsh (un/marshall-marshall un/marshaller)]
-           [unmarsh (un/marshall-unmarshall un/marshaller)]
-           [marshalled (marsh value)]
-           [copy (unmarsh marshalled)])
+    (define pref-state (find-layer p))
+    (define marshall-unmarshall (preferences:layer-marshall-unmarshall pref-state))
+    (define un/marshaller (hash-ref marshall-unmarshall p (λ () (k value))))
+    (define default (hash-ref (preferences:layer-defaults pref-state) p))
+    (define marsh (un/marshall-marshall un/marshaller))
+    (define unmarsh (un/marshall-unmarshall un/marshaller))
+    (define marshalled (marsh value))
+    (define copy (unmarsh marshalled))
     (if ((default-checker default) copy)
         copy
-          value))))
+        value)))
+
+(define (preferences:restore-defaults)
+  (let loop ([prefs-state (preferences:current-layer)])
+    (when prefs-state
+      (for ([(p def) (in-hash (preferences:layer-defaults prefs-state))])
+        (preferences:set p (default-value def)))
+      (loop (preferences:layer-prev prefs-state)))))
 
 (define-struct preferences:snapshot (x))
 (define (preferences:get-prefs-snapshot)
   (make-preferences:snapshot
-   (hash-map defaults 
-             (λ (k v) (cons k (copy-pref-value k (preferences:get k)))))))
+   (let loop ([prefs-state (preferences:current-layer)]
+              [sofar '()])
+     (cond
+       [prefs-state
+        (loop (preferences:layer-prev prefs-state)
+              (for/fold ([sofar sofar])
+                        ([(k def) (in-hash (preferences:layer-defaults prefs-state))])
+                (cons (cons k (copy-pref-value (preferences:get k)))
+                      sofar)))]
+       [else sofar]))))
 
 (define (preferences:restore-prefs-snapshot snapshot)
   (multi-set (map car (preferences:snapshot-x snapshot))
              (map cdr (preferences:snapshot-x snapshot)))
   (void))
 
+(begin-for-doc
+  (define pref-layer-eval (make-base-eval))
+  (pref-layer-eval
+   '(begin
+      (require framework/preferences)
+      (let ([the-prefs-table (make-hash)])
+        (preferences:low-level-put-preferences
+         (λ (syms vals)
+           (for ([sym (in-list syms)]
+                 [val (in-list vals)])
+             (hash-set! the-prefs-table sym val))))
+        (preferences:low-level-get-preference
+         (λ (sym [fail void])
+           (hash-ref the-prefs-table sym fail)))))))
 
 (provide/doc
  (proc-doc/names
@@ -414,6 +467,10 @@ the state transitions / contracts are:
     unmarshalling functions by calling
     @racket[preferences:set-un/marshall] before adding a callback.
 
+    The result thunk removes the callback from the same @tech{preferences layer}
+    that @racket[p] was in when @racket[preferences:add-callback] was
+    originally called.
+
     This function raises an exception matching
     @racket[exn:unknown-preference?]
     if the preference default has not been set via
@@ -505,13 +562,19 @@ the state transitions / contracts are:
   preferences:register-save-callback
   (-> (-> boolean? any) symbol?)
   (callback)
-  @{Registers @racket[callback] to run twice for each call to @racket[preferences:set]---once 
-              before the preferences file is written, with @racket[#t], and once after it is written, with
-              @racket[#f]. Registration returns a key for use with @racket[preferences:unregister-save-callback]. 
-              Caveats:
-              @itemize{@item{The callback occurs on whichever thread happened to call @racket[preferences:set].}
-                       @item{Pre- and post-write notifications are not necessarily paired; unregistration
-                             may cancel the post-write notification before it occurs.}}})
+  @{Registers @racket[callback] to run twice for each call
+ to @racket[preferences:set]---once before the preferences
+ file is written, with @racket[#t], and once after it is
+ written, with @racket[#f]. Registration returns a key for
+ use with @racket[preferences:unregister-save-callback].
+ Caveats: @itemize{
+  @item{The callback occurs on whichever
+   thread happened to call @racket[preferences:set].
+  }
+  @item{
+   Pre- and post-write notifications are not necessarily
+   paired; unregistration may cancel the post-write
+   notification before it occurs.}}})
 
  (proc-doc/names
   preferences:unregister-save-callback
@@ -539,7 +602,7 @@ the state transitions / contracts are:
 
  (parameter-doc
   preferences:low-level-put-preferences
-  (parameter/c ((listof symbol?) (listof any/c) . -> . any))
+  (parameter/c (-> (listof symbol?) (listof any/c) any))
   put-preferences
   @{This parameter's value is called to save preference the preferences file.
     Its interface should be just like mzlib's @racket[put-preferences].
@@ -586,4 +649,64 @@ the state transitions / contracts are:
     copied by passing it through the marshalling and unmarshalling process.
     Other values are not copied, but references to them are instead saved.
 
-    See also @racket[preferences:restore-prefs-snapshot].}))
+    See also @racket[preferences:restore-prefs-snapshot].})
+
+ (proc-doc/names
+  preferences:new-layer
+  (-> (or/c #f preferences:layer?) preferences:layer?)
+  (previous-preferences-layer)
+  @{Creates a @tech{preferences layer} that extends @racket[previous-preferences-layer].
+
+  @history[#:added "1.30"]})
+
+ (proc-doc/names
+  preferences:layer?
+  (-> any/c boolean?)
+  (v)
+  @{Determines if @racket[v] is a @deftech{preferences layer}.
+
+  A preferences layer gives a form of scoping to preferences. When
+  a new preference is first registered with this library (via a call to
+  @racket[preferences:set-default] or @racket[preferences:add-callback])
+  it is put into the layer in @racket[preferences:current-layer]
+  (and not into any of that layer's previous layers).
+  When @racket[preferences:get], @racket[preferences:set],
+  @racket[preferences:set-un/marshall] are called, they consult and
+  manipulate only the layer where the preference was first installed.
+  Accordingly, preference layers give a way to discard some set of
+  calls to @racket[preference:set-default] and other preference configuration
+  and to start over with a new set. Note that this affects only the configuration
+  of the preferences for the library; the values are all stored centrally
+  (see @racket[preferences:low-level-put-preferences]) and are unaffected
+  by the layers.
+
+  @examples[#:eval pref-layer-eval
+
+            (define original-layer (preferences:current-layer))
+
+            (define layer2 (preferences:new-layer original-layer))
+            (parameterize ([preferences:current-layer layer2])
+              (code:comment "initialize 'a-pref in layer2")
+              (preferences:set-default 'a-pref 5 real?)
+              (preferences:set 'a-pref 6)
+              (preferences:get 'a-pref))
+
+            (define layer3 (preferences:new-layer original-layer))
+            (parameterize ([preferences:current-layer layer3])
+              (code:comment "initialize 'a-pref again, this time in layer3")
+              (code:comment "without the new layer in place, this would be an error")
+              (preferences:set-default 'a-pref 5 real?)
+              (code:comment "the actual value of the preference remains")
+              (code:comment "from the previous call to preferences:set")
+              (preferences:get 'a-pref))]
+
+  @history[#:added "1.30"]
+  })
+
+ (parameter-doc
+  preferences:current-layer
+  (parameter/c preferences:layer?)
+  preferences-layer
+  @{Determines the current @tech{preferences layer}.
+   @history[#:added "1.30"]})
+ )

gui-lib/info.rkt

@@ -30,4 +30,4 @@
 
 (define pkg-authors '(mflatt robby))
 
-(define version "1.29")
+(define version "1.30")

gui-test/framework/tests/prefs.rkt

@@ -1,7 +1,8 @@
 #lang racket/base
 (require framework/preferences
          racket/format
-         rackunit)
+         rackunit
+         racket/contract)
 
 ;(define ((check-equal? x) y) (equal? x y))
 (define pref-sym 'plt:not-a-real-preference)
@@ -34,6 +35,12 @@
           (preferences:get pref-sym))
    'new-pref)
 
+  (check-true (preferences:default-set? pref-sym))
+  (check-false (preferences:default-set? 'unknown-preference))
+  (check-false (begin
+                 (preferences:add-callback 'pref-with-only-callback-set void)
+                 (preferences:default-set? 'pref-with-only-callback-set)))
+
   (check-equal?
    (begin (preferences:set-default marshalling-pref-sym (lambda () 'the-answer) procedure?)
           (preferences:set-un/marshall marshalling-pref-sym
@@ -50,6 +57,18 @@
                           (string->symbol (~a "plt:framework-pref:" pref-sym)))
                 'new-pref)
 
+  (let ()
+    (preferences:set-default 'unmarshalling-enumerate-test '() (listof exact-nonnegative-integer?))
+    (preferences:set-un/marshall 'unmarshalling-enumerate-test
+                                 (λ (lon) (~s lon))
+                                 (λ (s) (read (open-input-string s))))
+
+    ;; simulate a value having been saved from some prior run of the preferences library
+    (hash-set! the-prefs-table 'plt:framework-pref:unmarshalling-enumerate-test
+               (~s '(1 2 3 4 5)))
+
+    (check-equal? (preferences:get 'unmarshalling-enumerate-test) '(1 2 3 4 5)))
+
   (check-equal?
    (let ([x 1])
      (preferences:set-default default-test-sym 'default symbol?)
@@ -60,6 +79,16 @@
      x)
    2)
 
+  (check-equal?
+   (let ([x 1])
+     (define remove-it (preferences:add-callback 'callback-before-delete (λ (a b) (set! x (+ x 1)))))
+     (preferences:set-default 'callback-before-delete 'default symbol?)
+     (preferences:set 'callback-before-delete 'xyz)
+     (remove-it)
+     (preferences:set 'callback-before-delete 'pdq)
+     x)
+   2)
+
   (check-equal?
    (let ([x 1])
      (define f (λ (a b) (set! x (+ x 1))))
@@ -100,4 +129,16 @@
      (remove-it)
      (preferences:set default-test-sym 'pdq)
      x)
-   1))
+   1)
+
+  (let ()
+    (hash-set! the-prefs-table
+               'plt:framework-pref:preferences-aliases-test:1
+               "1")
+    (preferences:set-default 'preferences-aliases-test
+                             0
+                             exact-nonnegative-integer?
+                             #:aliases '(preferences-aliases-test:1)
+                             #:rewrite-aliases (list (λ (v) (read (open-input-string v)))))
+    (check-equal? (preferences:get 'preferences-aliases-test) 1)))
+