added docs for the gui-utils and the textual preferences to the framework

svn: r9503

collects/framework/preferences.ss

@@ -1,4 +1,5 @@
-
+#reader scribble/reader
+#lang scheme/gui
 #|
 
 There are three attributes for each preference:
@@ -26,443 +27,438 @@ the state transitions / contracts are:
 
 |#
 
-(module preferences mzscheme
+(require scribble/srcdoc)
-  (require mzlib/file
+(require/doc scheme/base scribble/manual)
-	   mzlib/etc
-           mzlib/contract)
-  
-  (provide exn:struct:unknown-preference)
-  
-  (define-struct (exn:unknown-preference exn) ())
-  
-  ;; these two names are for consistency
-  (define exn:make-unknown-preference make-exn:unknown-preference)
-  (define exn:struct:unknown-preference struct:exn:unknown-preference)
-  
-  (define-syntax (provide/contract/docs stx)
-    (syntax-case stx ()
-      [(_ (name contract docs ...) ...)
-       (syntax (provide/contract (name contract) ...))]))
 
-  
+(provide exn:struct:unknown-preference)
-  (define old-preferences-symbol 'plt:framework-prefs)
+
-  (define old-preferences (make-hash-table))
+(define-struct (exn:unknown-preference exn) ())
-  (let ([old-prefs (get-preference old-preferences-symbol (λ () '()))])
+
-    (for-each
+;; these two names are for consistency
-     (λ (line) (hash-table-put! old-preferences (car line) (cadr line)))
+(define exn:make-unknown-preference make-exn:unknown-preference)
-     old-prefs))
+(define exn:struct:unknown-preference struct:exn:unknown-preference)
-  
+
-  (define (add-pref-prefix p) (string->symbol (format "plt:framework-pref:~a" p)))
+(define old-preferences-symbol 'plt:framework-prefs)
-  
+(define old-preferences (make-hasheq))
-  ;; preferences : hash-table[sym -o> any]
+(let ([old-prefs (get-preference old-preferences-symbol (λ () '()))])
-  ;; the current values of the preferences
+  (for-each
-  (define preferences (make-hash-table))
+   (λ (line) (hash-set! old-preferences (car line) (cadr line)))
-  
+   old-prefs))
-  ;; marshalled : hash-table[sym -o> any]
+
-  ;; the values of the preferences, as read in from the disk
+(define (add-pref-prefix p) (string->symbol (format "plt:framework-pref:~a" p)))
-  ;; each symbol will only be mapped in one of the preferences
+
-  ;; hash-table and this hash-table, but not both.
+;; preferences : hash-table[sym -o> any]
-  (define marshalled (make-hash-table))
+;; the current values of the preferences
-  
+(define preferences (make-hasheq))
-  ;; marshall-unmarshall : sym -o> un/marshall
+
-  (define marshall-unmarshall (make-hash-table))
+;; marshalled : hash-table[sym -o> any]
-  
+;; the values of the preferences, as read in from the disk
-  ;; callbacks : sym -o> (listof (sym TST -> boolean))
+;; each symbol will only be mapped in one of the preferences
-  (define callbacks (make-hash-table))
+;; hash-table and this hash-table, but not both.
-  
+(define marshalled (make-hasheq))
-  ;; defaults : hash-table[sym -o> default]
+
-  (define defaults (make-hash-table))
+;; marshall-unmarshall : sym -o> un/marshall
-  
+(define marshall-unmarshall (make-hasheq))
-  ;; these four functions determine the state of a preference
+
-  (define (pref-un/marshall-set? pref) (hash-table-bound? marshall-unmarshall pref))
+;; callbacks : sym -o> (listof (sym TST -> boolean))
-  (define (pref-default-set? pref) (hash-table-bound? defaults pref))
+(define callbacks (make-hasheq))
-  (define (pref-can-init? pref) 
+
-    (and (not snapshot-grabbed?)
+;; defaults : hash-table[sym -o> default]
-         (not (hash-table-bound? preferences pref))))
+(define defaults (make-hasheq))
-  
+
-  ;; type un/marshall = (make-un/marshall (any -> prinable) (printable -> any))
+;; these four functions determine the state of a preference
-  (define-struct un/marshall (marshall unmarshall))
+(define (pref-un/marshall-set? pref) (hash-table-bound? marshall-unmarshall pref))
-  
+(define (pref-default-set? pref) (hash-table-bound? defaults pref))
-  ;; type pref = (make-pref any)
+(define (pref-can-init? pref) 
-  (define-struct pref (value))
+  (and (not snapshot-grabbed?)
-  
+       (not (hash-table-bound? preferences pref))))
-  ;; type default  = (make-default any (any -> bool))
+
-  (define-struct default (value checker))
+;; type un/marshall = (make-un/marshall (any -> prinable) (printable -> any))
-  
+(define-struct un/marshall (marshall unmarshall))
-  ;; pref-callback : (make-pref-callback (union (weak-box (sym tst -> void)) (sym tst -> void)))
+
-  ;; this is used as a wrapped to deal with the problem that different procedures might be eq?.
+;; type pref = (make-pref any)
-  (define-struct pref-callback (cb))
+(define-struct pref (value))
-  
+
-  ;; get : symbol -> any
+;; type default  = (make-default any (any -> bool))
-  ;; return the current value of the preference `p'
+(define-struct default (value checker))
-  ;; exported
+
-  (define (preferences:get p)
+;; pref-callback : (make-pref-callback (union (weak-box (sym tst -> void)) (sym tst -> void)))
-    (cond
+;; this is used as a wrapped to deal with the problem that different procedures might be eq?.
-      [(pref-default-set? p)
+(define-struct pref-callback (cb))
-       
+
-       ;; unmarshall, if required
+;; get : symbol -> any
-       (when (hash-table-bound? marshalled p)
+;; return the current value of the preference `p'
-         ;; if `preferences' is already bound, that means the unmarshalled value isn't useful.
+;; exported
-         (unless (hash-table-bound? preferences p)
+(define (preferences:get p)
-           (hash-table-put! preferences p (unmarshall-pref p (hash-table-get marshalled p))))
+  (cond
-         (hash-table-remove! marshalled p))
+    [(pref-default-set? p)
-       
+     
-       ;; if there is no value in the preferences table, but there is one
+     ;; unmarshall, if required
-       ;; in the old version preferences file, take that:
+     (when (hash-table-bound? marshalled p)
+       ;; if `preferences' is already bound, that means the unmarshalled value isn't useful.
        (unless (hash-table-bound? preferences p)
-         (when (hash-table-bound? old-preferences p)
+         (hash-set! preferences p (unmarshall-pref p (hash-ref marshalled p))))
-           (hash-table-put! preferences p (unmarshall-pref p (hash-table-get old-preferences p)))))
+       (hash-remove! marshalled p))
-       
+     
-       ;; clear the pref from the old table (just in case it was taking space -- we don't need it anymore)
+     ;; if there is no value in the preferences table, but there is one
+     ;; in the old version preferences file, take that:
+     (unless (hash-table-bound? preferences p)
        (when (hash-table-bound? old-preferences p)
-         (hash-table-remove! old-preferences p))
+         (hash-set! preferences p (unmarshall-pref p (hash-ref old-preferences p)))))
-       
+     
-       ;; if it still isn't set, take the default value
+     ;; clear the pref from the old table (just in case it was taking space -- we don't need it anymore)
-       (unless (hash-table-bound? preferences p)
+     (when (hash-table-bound? old-preferences p)
-         (hash-table-put! preferences p (default-value (hash-table-get defaults p))))
+       (hash-remove! old-preferences p))
-       
+     
-       (hash-table-get preferences p)]
+     ;; if it still isn't set, take the default value
-      [(not (pref-default-set? p))
+     (unless (hash-table-bound? preferences p)
-       (raise-unknown-preference-error
+       (hash-set! preferences p (default-value (hash-ref defaults p))))
-        'preferences:get
+     
-        "tried to get a preference but no default set for ~e"
+     (hash-ref preferences p)]
-        p)]))
+    [(not (pref-default-set? p))
-  
+     (raise-unknown-preference-error
-  ;; set : symbol any -> void
+      'preferences:get
-  ;; updates the preference
+      "tried to get a preference but no default set for ~e"
-  ;; exported
+      p)]))
-  (define (preferences:set p value) (multi-set (list p) (list value)))
-  
-  ;; set : symbol any -> void
-  ;; updates the preference
-  ;; exported
 
-  (define (multi-set ps values)
+;; set : symbol any -> void
-    (for-each
+;; updates the preference
-     (λ (p value)
+;; exported
-       (cond
+(define (preferences:set p value) (multi-set (list p) (list value)))
-         [(pref-default-set? p)
-          (let ([default (hash-table-get defaults p)])
-            (unless ((default-checker default) value)
-              (error 'preferences:set
-                     "tried to set preference ~e to ~e but it does not meet test from preferences:set-default"
-                     p value))
-            (check-callbacks p value)
-            (hash-table-put! preferences p value)
-            (void))]
-         [(not (pref-default-set? p))
-          (raise-unknown-preference-error
-           'preferences:set "tried to set the preference ~e to ~e, but no default is set"
-           p
-           value)]))
-     ps values)
-    ((preferences:low-level-put-preferences)
-     (map add-pref-prefix ps) 
-     (map (λ (p value) (marshall-pref p value))
-          ps
-          values))
-    
-    (void))
-  
-  (define preferences:low-level-put-preferences (make-parameter put-preferences))
-  
-  (define (raise-unknown-preference-error sym fmt . args)
-    (raise (exn:make-unknown-preference
-            (string-append (format "~a: " sym) (apply format fmt args))
-            (current-continuation-marks))))
 
-  ;; unmarshall-pref : symbol marshalled -> any
+;; set : symbol any -> void
-  ;; unmarshalls a preference read from the disk
+;; updates the preference
-  (define (unmarshall-pref p data)
+;; exported
-    (let* ([un/marshall (hash-table-get marshall-unmarshall p #f)]
-           [result (if un/marshall
-                       ((un/marshall-unmarshall un/marshall) data)
-                       data)]
-           [default (hash-table-get defaults p)])
-      (if ((default-checker default) result)
-          result
-          (default-value default))))
-  
-  ;; add-callback : sym (-> void) -> void
-  (define preferences:add-callback 
-    (opt-lambda (p callback [weak? #f])
-      (let ([new-cb (make-pref-callback (if weak?
-                                            (make-weak-box callback)
-                                            callback))])
-        (hash-table-put! callbacks
-                         p 
-                         (append 
-                          (hash-table-get callbacks p (λ () null))
-                          (list new-cb)))
-        (λ ()
-          (hash-table-put!
-           callbacks
-           p
-           (let loop ([callbacks (hash-table-get callbacks p (λ () null))])
-             (cond
-               [(null? callbacks) null]
-               [else 
-                (let ([callback (car callbacks)])
-                  (cond
-                    [(eq? callback new-cb)
-                     (loop (cdr callbacks))]
-                    [else
-                     (cons (car callbacks) (loop (cdr callbacks)))]))])))))))
-  
-  ;; check-callbacks : sym val -> void
-  (define (check-callbacks p value)
-    (let ([new-callbacks
-           (let loop ([callbacks (hash-table-get callbacks p (λ () null))])
-             (cond
-               [(null? callbacks) null]
-               [else 
-                (let* ([callback (car callbacks)]
-                       [cb (pref-callback-cb callback)])
-                  (cond
-                    [(weak-box? cb)
-                     (let ([v (weak-box-value cb)])
-                       (if v
-                           (begin 
-                             (v p value)
-                             (cons callback (loop (cdr callbacks))))
-                           (loop (cdr callbacks))))]
-                    [else
-                     (cb p value)
-                     (cons callback (loop (cdr callbacks)))]))]))])
-      (if (null? new-callbacks)
-          (hash-table-remove! callbacks p)
-          (hash-table-put! callbacks p new-callbacks))))
-  
-  (define (preferences:set-un/marshall p marshall unmarshall)
-    (cond
-      [(and (pref-default-set? p)
-            (not (pref-un/marshall-set? p))
-            (pref-can-init? p))
-       (hash-table-put! marshall-unmarshall p (make-un/marshall marshall unmarshall))]
-      [(not (pref-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)
-       (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 (hash-table-bound? ht s)
-    (let/ec k
-      (hash-table-get ht s (λ () (k #f)))
-      #t))
-  
-  (define (preferences:restore-defaults)
-    (hash-table-for-each
-     defaults
-     (λ (p def) (preferences:set p (default-value def)))))
-  
-  ;; set-default : (sym TST (TST -> boolean) -> void
-  (define (preferences:set-default p default-value checker)
-    (cond
-      [(and (not (pref-default-set? p))
-            (pref-can-init? p))
-       (let ([default-okay? (checker default-value)])
-         (unless default-okay?
-           (error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t~n"
-                  p checker default-okay? default-value))
-         (hash-table-put! defaults p (make-default default-value checker))
-         (let/ec k
-           (let ([m (get-preference (add-pref-prefix p) (λ () (k (void))))])
-             ;; if there is no preference saved, we just don't do anything.
-             ;; `get' notices this case.
-             (hash-table-put! marshalled p m))))]
-      [(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)]
-      [(pref-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)]))
-  
-  ;; marshall-pref : symbol any -> (list symbol printable)
-  (define (marshall-pref p value)
-    (let/ec k
-      (let* ([marshaller
-              (un/marshall-marshall
-               (hash-table-get marshall-unmarshall p (λ () (k value))))])
-        (marshaller value))))
-  
-  (define-struct preferences:snapshot (x))
-  (define snapshot-grabbed? #f)
-  (define (preferences:get-prefs-snapshot)
-    (set! snapshot-grabbed? #t)
-    (make-preferences:snapshot (hash-table-map defaults (λ (k v) (cons k (preferences:get k))))))
-    
-  (define (preferences:restore-prefs-snapshot snapshot)
-    (multi-set (map car (preferences:snapshot-x snapshot))
-               (map cdr (preferences:snapshot-x snapshot)))
-    (void))
-  
-  
-  (provide/contract/docs
-   (preferences:snapshot? 
-    (-> any/c boolean?)
-    (arg)
-    "Determines if its argument is a preferences snapshot."
-    ""
-    "See also "
-    "@flink preferences:get-prefs-snapshot"
-    " and "
-    "@flink preferences:restore-prefs-snapshot %"
-    ".")
-   (preferences:restore-prefs-snapshot 
-    (-> preferences:snapshot? void?)
-    (snapshot)
-    "Restores the preferences saved in \\var{snapshot}."
-    ""
-    "See also "
-    "@flink preferences:get-prefs-snapshot %"
-    ".")
-   
-   (preferences:get-prefs-snapshot 
-    (-> preferences:snapshot?)
-    ()
-    "Caches all of the current values of the preferences and returns them."
-    ""
-    "See also "
-    "@flink preferences:restore-prefs-snapshot %"
-    ".")
-   
-   (exn:make-unknown-preference 
-    (string? continuation-mark-set? . -> . exn:unknown-preference?)
-    (message continuation-marks)
-    "Creates an unknown preference exception.")
-   (exn:unknown-preference? 
-    (any/c . -> . boolean?)
-    (exn)
-    "Determines if a value is an unknown preference exn.")
 
-   (preferences:low-level-put-preferences
+(define (multi-set ps values)
-    (parameter/c (-> (listof symbol?) (listof any/c) any))
+  (for-each
-    ()
+   (λ (p value)
-    "This is a parameter (see "
+     (cond
-    "\\Mzhyperref{parameters}{mz:parameters} for information about parameters)"
+       [(pref-default-set? p)
-    "which is called when a preference is saved. Its interface should "
+        (let ([default (hash-ref defaults p)])
-    "be just like mzlib's \\scheme|put-preference|.")
+          (unless ((default-checker default) value)
-   
+            (error 'preferences:set
-   (preferences:get
+                   "tried to set preference ~e to ~e but it does not meet test from preferences:set-default"
-    (symbol? . -> . any/c)
+                   p value))
-    (symbol)
+          (check-callbacks p value)
-    "See also"
+          (hash-set! preferences p value)
-    "@flink preferences:set-default %"
+          (void))]
-    "."
+       [(not (pref-default-set? p))
-    ""
+        (raise-unknown-preference-error
-    "\\rawscm{preferences:get} returns the value for the preference"
+         'preferences:set "tried to set the preference ~e to ~e, but no default is set"
-    "\\var{symbol}. It raises"
+         p
-    "\\scmindex{exn:unknown-preference}\\rawscm{exn:unknown-preference}"
+         value)]))
-    "if the preference's default has not been set.")
+   ps values)
-   (preferences:set
+  ((preferences:low-level-put-preferences)
-    (symbol? any/c . -> . void?)
+   (map add-pref-prefix ps) 
-    (symbol value)
+   (map (λ (p value) (marshall-pref p value))
-    "See also"
+        ps
-    "@flink preferences:set-default %"
+        values))
-    "."
+  
-    ""
+  (void))
-    "\\rawscm{preferences:set-preference} sets the preference"
+
-    "\\var{symbol} to \\var{value}. This should be called when the"
+(define preferences:low-level-put-preferences (make-parameter put-preferences))
-    "users requests a change to a preference."
+
-    ""
+(define (raise-unknown-preference-error sym fmt . args)
-    "This function immediately writes the preference value to disk."
+  (raise (exn:make-unknown-preference
-    ""
+          (string-append (format "~a: " sym) (apply format fmt args))
-    "It raises"
+          (current-continuation-marks))))
-    "\\scmindex{exn:unknown-preference}\\rawscm{exn:unknown-preference}"
+
-    "if the preference's default has not been set.")
+;; unmarshall-pref : symbol marshalled -> any
-   (preferences:add-callback
+;; unmarshalls a preference read from the disk
-    (opt-> (symbol? 
+(define (unmarshall-pref p data)
-            
+  (let* ([un/marshall (hash-ref marshall-unmarshall p #f)]
-            ;; important that this arg only has a flat contract
+         [result (if un/marshall
-            ;; so that no wrapper is created, so that
+                     ((un/marshall-unmarshall un/marshall) data)
-            ;; the weak box stuff works ...
+                     data)]
-            (λ (x) (and (procedure? x) (procedure-arity-includes? x 2))))
+         [default (hash-ref defaults p)])
-           (boolean?)
+    (if ((default-checker default) result)
-           (-> void?))
+        result
-    ((p f)
+        (default-value default))))
-     ((weak? #f)))
+
-    "This function adds a callback which is called with a symbol naming a"
+;; add-callback : sym (-> void) -> void
-    "preference and it's value, when the preference changes."
+(define preferences:add-callback 
-    "\\rawscm{preferences:add-callback} returns a thunk, which when"
+  (lambda (p callback [weak? #f])
-    "invoked, removes the callback from this preference."
+    (let ([new-cb (make-pref-callback (if weak?
-    ""
+                                          (make-weak-box callback)
-    "If \\var{weak?} is true, the preferences system will only hold on to"
+                                          callback))])
-    "the callback weakly."
+      (hash-set! callbacks
-    ""
+                 p 
-    "The callbacks will be called in the order in which they were added."
+                 (append 
-    ""
+                  (hash-ref callbacks p (λ () null))
-    "If you are adding a callback for a preference that requires"
+                  (list new-cb)))
-    "marshalling and unmarshalling, you must set the marshalling and"
+      (λ ()
-    "unmarshalling functions by calling"
+        (hash-set!
-    "\\iscmprocedure{preferences:set-un/marshall} before adding a callback."
+         callbacks
-    ""
+         p
-    "This function raises"
+         (let loop ([callbacks (hash-ref callbacks p (λ () null))])
-    "\\scmindex{exn:unknown-preference}\\rawscm{exn:unknown-preference}"
+           (cond
-    "if the preference has not been set.")
+             [(null? callbacks) null]
-   (preferences:set-default
+             [else 
-    (symbol? any/c (any/c . -> . any) . -> . void?)
+              (let ([callback (car callbacks)])
-    (symbol value test)
+                (cond
-    "This function must be called every time your application starts up, before any call to"
+                  [(eq? callback new-cb)
-    "@flink preferences:get %"
+                   (loop (cdr callbacks))]
-    ", "
+                  [else
-    "@flink preferences:set"
+                   (cons (car callbacks) (loop (cdr callbacks)))]))])))))))
-    "(for any given preference)."
+
-    ""
+;; check-callbacks : sym val -> void
-    "If you use"
+(define (check-callbacks p value)
-    "@flink preferences:set-un/marshall %"
+  (let ([new-callbacks
-    ", you must call this function before calling it."
+         (let loop ([callbacks (hash-ref callbacks p (λ () null))])
-    ""
+           (cond
-    "This sets the default value of the preference \\var{symbol} to"
+             [(null? callbacks) null]
-    "\\var{value}. If the user has chosen a different setting,"
+             [else 
-    "the user's setting"
+              (let* ([callback (car callbacks)]
-    "will take precedence over the default value."
+                     [cb (pref-callback-cb callback)])
-    ""
+                (cond
-    "The last argument, \\var{test} is used as a safeguard. That function is"
+                  [(weak-box? cb)
-    "called to determine if a preference read in from a file is a valid"
+                   (let ([v (weak-box-value cb)])
-    "preference. If \\var{test} returns \\rawscm{\\#t}, then the preference is"
+                     (if v
-    "treated as valid. If \\var{test} returns \\rawscm{\\#f} then the default is"
+                         (begin 
-    "used.")
+                           (v p value)
-   (preferences:set-un/marshall
+                           (cons callback (loop (cdr callbacks))))
-    (symbol? (any/c . -> . printable/c) (printable/c . -> . any/c) . -> . void?)
+                         (loop (cdr callbacks))))]
-    (symbol marshall unmarshall)
+                  [else
-    "\\rawscm{preference:set-un/marshall} is used to specify marshalling and"
+                   (cb p value)
-    "unmarshalling functions for the preference"
+                   (cons callback (loop (cdr callbacks)))]))]))])
-    "\\var{symbol}. \\var{marshall} will be called when the users saves their"
+    (if (null? new-callbacks)
-    "preferences to turn the preference value for \\var{symbol} into a"
+        (hash-remove! callbacks p)
-    "printable value. \\var{unmarshall} will be called when the user's"
+        (hash-set! callbacks p new-callbacks))))
-    "preferences are read from the file to transform the printable value"
+
-    "into it's internal representation. If \\rawscm{preference:set-un/marshall}"
+(define (preferences:set-un/marshall p marshall unmarshall)
-    "is never called for a particular preference, the values of that"
+  (cond
-    "preference are assumed to be printable."
+    [(and (pref-default-set? p)
-    ""
+          (not (pref-un/marshall-set? p))
-    "If the unmarshalling function returns a value that does not meet the"
+          (pref-can-init? p))
-    "guard passed to "
+     (hash-set! marshall-unmarshall p (make-un/marshall marshall unmarshall))]
-    "@flink preferences:set-default"
+    [(not (pref-default-set? p))
-    "for this preference, the default value is used."
+     (error 'preferences:set-un/marshall
-    ""
+            "must call set-default for ~s before calling set-un/marshall for ~s"
-    "The \\var{marshall} function might be called with any value returned"
+            p p)]
-    "from \\scheme{read} and it must not raise an error (although it"
+    [(pref-un/marshall-set? p)
-    "can return arbitrary results if it gets bad input). This might"
+     (error 'preferences:set-un/marshall
-    "happen when the preferences file becomes corrupted, or is edited"
+            "already set un/marshall for ~e" 
-    "by hand."
+            p)]
-    ""
+    [(not (pref-can-init? p))
-    "\\rawscm{preference:set-un/marshall} must be called before calling"
+     (error 'preferences:set-un/marshall "the preference ~e cannot be configured any more" p)]))
-    "@flink preferences:get %"
+
-    ", "
+(define (hash-table-bound? ht s)
-    "@flink preferences:set %"
+  (let/ec k
-    ".")
+    (hash-ref ht s (λ () (k #f)))
-   
+    #t))
-   (preferences:restore-defaults
+
-    (-> void?)
+(define (preferences:restore-defaults)
-    ()
+  (hash-for-each
-    "\\rawscm{(preferences:restore-defaults)} restores the users's configuration to the"
+   defaults
-    "default preferences.")))
+   (λ (p def) (preferences:set p (default-value def)))))
+
+;; set-default : (sym TST (TST -> boolean) -> void
+(define (preferences:set-default p default-value checker)
+  (cond
+    [(and (not (pref-default-set? p))
+          (pref-can-init? p))
+     (let ([default-okay? (checker default-value)])
+       (unless default-okay?
+         (error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t~n"
+                p checker default-okay? default-value))
+       (hash-set! defaults p (make-default default-value checker))
+       (let/ec k
+         (let ([m (get-preference (add-pref-prefix p) (λ () (k (void))))])
+           ;; if there is no preference saved, we just don't do anything.
+           ;; `get' notices this case.
+           (hash-set! marshalled p m))))]
+    [(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)]
+    [(pref-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)]))
+
+;; marshall-pref : symbol any -> (list symbol printable)
+(define (marshall-pref p value)
+  (let/ec k
+    (let* ([marshaller
+            (un/marshall-marshall
+             (hash-ref marshall-unmarshall p (λ () (k value))))])
+      (marshaller value))))
+
+(define-struct preferences:snapshot (x))
+(define snapshot-grabbed? #f)
+(define (preferences:get-prefs-snapshot)
+  (set! snapshot-grabbed? #t)
+  (make-preferences:snapshot (hash-map defaults (λ (k v) (cons k (preferences:get k))))))
+
+(define (preferences:restore-prefs-snapshot snapshot)
+  (multi-set (map car (preferences:snapshot-x snapshot))
+             (map cdr (preferences:snapshot-x snapshot)))
+  (void))
+
+
+(provide/doc
+ (proc-doc/names
+  preferences:snapshot? 
+  (-> any/c boolean?)
+  (arg)
+  @{Determines if its argument is a preferences snapshot.
+               
+               See also 
+               @scheme[preferences:get-prefs-snapshot] and 
+               @scheme[preferences:restore-prefs-snapshot].})
+ (proc-doc/names
+  preferences:restore-prefs-snapshot 
+  (-> preferences:snapshot? void?)
+  (snapshot)
+  @{Restores the preferences saved in @scheme[snapshot].
+             
+             See also @scheme[preferences:get-prefs-snapshot].})
+ 
+ (proc-doc/names
+  preferences:get-prefs-snapshot 
+  (-> preferences:snapshot?)
+  ()
+  @{Caches all of the current values of the preferences and returns them.
+           
+           See also 
+           @scheme[preferences:restore-prefs-snapshot].})
+ 
+ 
+ (proc-doc/names
+  exn:make-unknown-preference 
+  (string? continuation-mark-set? . -> . exn:unknown-preference?)
+  (message continuation-marks)
+  @{Creates an unknown preference exception.})
+ (proc-doc/names
+  exn:unknown-preference? 
+  (any/c . -> . boolean?)
+  (exn)
+  @{Determines if a value is an unknown preference exn.})
+ 
+ (parameter-doc
+  preferences:low-level-put-preferences
+  (parameter/c (-> (listof symbol?) (listof any/c) any))
+  put-preference
+  @{This parameter's value
+         is called when to save preference the preferences. Its interface should 
+         be just like mzlib's @scheme[put-preference].})
+ 
+ (proc-doc/names
+  preferences:get
+  (symbol? . -> . any/c)
+  (symbol)
+  @{See also @scheme[preferences:set-default].
+        
+        @scheme[preferences:get] returns the value for the preference
+        @scheme[symbol]. It raises
+        @index['("exn:unknown-preference")]{@scheme[exn:unknown-preference]}
+        @scheme[exn:unknown-preference]
+        if the preference's default has not been set.})
+ (proc-doc/names
+  preferences:set
+  (symbol? any/c . -> . void?)
+  (symbol value)
+  @{See also @scheme[preferences:set-default].
+        
+        @scheme[preferences:set-preference] sets the preference
+        @scheme[symbol] to @scheme[value]. This should be called when the
+        users requests a change to a preference.
+        
+        This function immediately writes the preference value to disk.
+        
+        It raises
+        @index['("exn:unknown-preference")]{@scheme[exn:unknown-preference]}
+        if the preference's default has not been set.})
+ (proc-doc/names
+  preferences:add-callback
+  (->* (symbol? 
+        
+        ;; important that this arg only has a flat contract
+        ;; so that no wrapper is created, so that
+        ;; the weak box stuff works ...
+        (λ (x) (and (procedure? x) (procedure-arity-includes? x 2))))
+       (boolean?)
+       (-> void?))
+  ((p f)
+   ((weak? #f)))
+  @{This function adds a callback which is called with a symbol naming a
+         preference and it's value, when the preference changes.
+         @scheme[preferences:add-callback] returns a thunk, which when
+         invoked, removes the callback from this preference.
+         
+         If @scheme[weak?] is true, the preferences system will only hold on to
+         the callback weakly.
+         
+         The callbacks will be called in the order in which they were added.
+         
+         If you are adding a callback for a preference that requires
+         marshalling and unmarshalling, you must set the marshalling and
+         unmarshalling functions by calling
+         @scheme[preferences:set-un/marshall] before adding a callback.
+         
+         This function raises
+         @index['("exn:unknown-preference")]{@scheme[exn:unknown-preference]}
+         @scheme[exn:unknown-preference]
+         if the preference has not been set.})
+ (proc-doc/names
+  preferences:set-default
+  (symbol? any/c (any/c . -> . any) . -> . void?)
+  (symbol value test)
+  @{This function must be called every time your application starts up, before any call to
+         @scheme[preferences:get] or
+         @scheme[preferences:set]
+         (for any given preference).
+         
+         If you use
+         @scheme[preferences:set-un/marshall],
+         you must call this function before calling it.
+         
+         This sets the default value of the preference @scheme[symbol] to
+         @scheme[value]. If the user has chosen a different setting,
+         the user's setting
+         will take precedence over the default value.
+         
+         The last argument, @scheme[test] is used as a safeguard. That function is
+         called to determine if a preference read in from a file is a valid
+         preference. If @scheme[test] returns @scheme[#t], then the preference is
+         treated as valid. If @scheme[test] returns @scheme[#f] then the default is
+         used.})
+ (proc-doc/names
+  preferences:set-un/marshall
+  (symbol? (any/c . -> . printable/c) (printable/c . -> . any/c) . -> . void?)
+  (symbol marshall unmarshall)
+  @{@scheme[preference:set-un/marshall] is used to specify marshalling and
+           unmarshalling functions for the preference
+           @scheme[symbol]. @scheme[marshall] will be called when the users saves their
+           preferences to turn the preference value for @scheme[symbol] into a
+           printable value. @scheme[unmarshall] will be called when the user's
+           preferences are read from the file to transform the printable value
+           into it's internal representation. If @scheme[preference:set-un/marshall]
+           is never called for a particular preference, the values of that
+           preference are assumed to be printable.
+           
+           If the unmarshalling function returns a value that does not meet the
+           guard passed to 
+           @scheme[preferences:set-default]
+           for this preference, the default value is used.
+           
+           The @scheme[marshall] function might be called with any value returned
+           from @scheme[read] and it must not raise an error 
+           (although it can return arbitrary results if it gets bad input). This might
+           happen when the preferences file becomes corrupted, or is edited
+           by hand.
+           
+           @scheme[preference:set-un/marshall] must be called before calling
+           @scheme[preferences:get],
+           @scheme[preferences:set].})
+ 
+ (proc-doc/names
+  preferences:restore-defaults
+  (-> void?)
+  ()
+  @{@scheme[(preferences:restore-defaults)]
+           restores the users's configuration to the
+           default preferences.}))

collects/framework/test.ss

@@ -4,11 +4,6 @@
 (require scribble/srcdoc)
 (require/doc scheme/base scribble/manual)
 
-(define-syntax (provide/contract/docs stx)
-  (syntax-case stx ()
-    [(_ (name contract docs ...) ...)
-     (syntax (provide/contract (name contract) ...))]))
-
 (define (test:top-level-focus-window-has? pred)
   (let ([tlw (get-top-level-focus-window)])
     (and tlw

collects/scribble/srcdoc.ss

@@ -55,23 +55,45 @@
   (lambda (stx)
     (syntax-case stx ()
       [(_ id contract desc)
-       (with-syntax ([((arg ...) result)
+       (with-syntax ([(header result)
                       (syntax-case #'contract (->d -> values)
                         [(->d (req ...) () (values [name res] ...))
-                         #'((req ...) (values res ...))]
+                         #'((id req ...) (values res ...))]
                         [(->d (req ...) () [name res])
-                         #'((req ...) res)]
+                         #'((id req ...) res)]
-                        [(-> result)
+                        [(->d (req ...) () #:rest rest rest-ctc [name res])
-                         #'(() result)]
+                         #'((id req ... [rest rest-ctc] (... ...)) res)]
-                        [else
+                        [(->d (req ...) (one more ...) whatever)
                          (raise-syntax-error
                           #f
-                          "unsupported procedure contract form (no argument names)"
+                          (format "unsupported ->d contract form for ~a, optional arguments non-empty, must use proc-doc/names"
+                                  (syntax->datum #'id))
+                          stx
+                          #'contract)]
+                        [(->d whatever ...) 
+                         (raise-syntax-error
+                          #f
+                          (format "unsupported ->d contract form for ~a" (syntax->datum #'id))
+                          stx
+                          #'contract)]
+                        [(-> result)
+                         #'((id) result)]
+                        [(-> whatever ...) 
+                         (raise-syntax-error
+                          #f
+                          (format "unsupported -> contract form for ~a, must use proc-doc/names if there are arguments"
+                                  (syntax->datum #'id))
+                          stx
+                          #'contract)]
+                        [(id whatever ...)
+                         (raise-syntax-error
+                          #f
+                          (format "unsupported ~a contract form (unable to synthesize argument names)" (syntax->datum #'id))
                           stx
                           #'contract)])])
          (values
           #'[id contract]
-          #'(defproc (id arg ...) result . desc)
+          #'(defproc header result . desc)
           #'(scribble/manual)))])))
 
 (define-provide/doc-transformer proc-doc/names
@@ -79,7 +101,7 @@
     (syntax-case stx ()
       [(_ id contract names desc)
        (with-syntax ([header                      
-                      (syntax-case #'(contract names) (->d -> values)
+                      (syntax-case #'(contract names) (->d -> values case->)
                         [((-> ctcs ... result) (arg-names ...))
                          (begin
                            (unless (= (length (syntax->list #'(ctcs ...)))
@@ -102,6 +124,11 @@
                         [((case-> (-> doms ... rng) ...)
                           ((args ...) ...))
                          (begin
+                           (unless (= (length (syntax->list #'((doms ...) ...)))
+                                      (length (syntax->list #'((args ...) ...))))
+                             (raise-syntax-error #f
+                                                 "number of cases and number of arg lists do not have the same size"
+                                                 stx))
                            (for-each
                             (λ (doms args)
                               (unless (= (length (syntax->list doms))
@@ -125,7 +152,18 @@
   (lambda (stx)
     (syntax-case stx (parameter/c)
       [(_ id (parameter/c contract) arg-id desc)
-       (values
+       (begin
-        #'[id (parameter/c contract)]
+         (unless (identifier? #'arg-id)
-        #'(defparam id arg-id contract . desc)
+           (raise-syntax-error 'parameter/doc 
-        #'(scribble/manual))])))
+                               "expected an identifier"
+                               stx
+                               #'arg-id))
+         (unless (identifier? #'id)
+           (raise-syntax-error 'parameter/doc 
+                               "expected an identifier"
+                               stx
+                               #'id))
+         (values
+          #'[id (parameter/c contract)]
+          #'(defparam id arg-id contract . desc)
+          #'(scribble/manual)))])))

collects/scribblings/framework/framework.scrbl

@@ -5,9 +5,13 @@
 
 @title{@bold{Framework}: PLT GUI Application Framework}
 
-The framework provides these libraries:
 @itemize{
+@item{Mode}
+@item{``Cannot parse docs for handler:open-file''}
+@item{Check indexing in preferences:get}
+}
 
+@itemize{
 @item{@bold{Entire Framework}
 
 @itemize{
@@ -74,8 +78,7 @@ The precise set of exported names is:
 @scheme[preferences:restore-defaults].
 }}
 
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+@bold{Thanks}
-@section{Thanks}
 
 Thanks to Shriram Krishnamurthi, Cormac Flanagan, Matthias
 Felleisen, Ian Barland, Gann Bierner, Richard Cobbe, Dan
@@ -84,33 +87,33 @@ Johnathan Franklin, Mark Krentel, Corky Cartwright, Michael
 Ernst, Kennis Koldewyn, Bruce Duba, and many others for
 their feedback and help.
 
-
+@include-section["application.scrbl"]
-@include-section["framework-application.scrbl"]
+@include-section["autosave.scrbl"]
-@include-section["framework-autosave.scrbl"]
+@include-section["canvas.scrbl"]
-@include-section["framework-canvas.scrbl"]
+@include-section["color-model.scrbl"]
-@include-section["framework-color-model.scrbl"]
+@include-section["color-prefs.scrbl"]
-@include-section["framework-color-prefs.scrbl"]
+@include-section["color.scrbl"]
-@include-section["framework-color.scrbl"]
+@include-section["comment-box.scrbl"]
-@include-section["framework-comment-box.scrbl"]
+@include-section["editor.scrbl"]
-@include-section["framework-editor.scrbl"]
+@include-section["exit.scrbl"]
-@include-section["framework-exit.scrbl"]
+@include-section["finder.scrbl"]
-@include-section["framework-finder.scrbl"]
+@include-section["frame.scrbl"]
-@include-section["framework-frame.scrbl"]
+@include-section["group.scrbl"]
-@include-section["framework-group.scrbl"]
+@include-section["gui-utils.scrbl"]
-@include-section["framework-handler.scrbl"]
+@include-section["handler.scrbl"]
-@include-section["framework-icon.scrbl"]
+@include-section["icon.scrbl"]
-@include-section["framework-keymap.scrbl"]
+@include-section["keymap.scrbl"]
-@;include-section["framework-main.scrbl"]
+@include-section["menu.scrbl"]
-@include-section["framework-menu.scrbl"]
+@include-section["mode.scrbl"]
-@;include-section["framework-mode.scrbl"]
+@include-section["number-snip.scrbl"]
-@include-section["framework-number-snip.scrbl"]
+@include-section["panel.scrbl"]
-@include-section["framework-panel.scrbl"]
+@include-section["pasteboard.scrbl"]
-@include-section["framework-pasteboard.scrbl"]
+@include-section["path-utils.scrbl"]
-@include-section["framework-path-utils.scrbl"]
+@include-section["preferences.scrbl"]
-@include-section["framework-preferences.scrbl"]
+@include-section["preferences-text.scrbl"]
-@include-section["framework-scheme.scrbl"]
+@include-section["scheme.scrbl"]
-@include-section["framework-text.scrbl"]
+@include-section["text.scrbl"]
-@include-section["framework-test.scrbl"]
+@include-section["test.scrbl"]
-@include-section["framework-version.scrbl"]
+@include-section["version.scrbl"]
 
 @index-section[]

collects/scribblings/framework/gui-utils.scrbl

@@ -0,0 +1,10 @@
+#lang scribble/doc
+@(require scribble/manual scribble/extract)
+@(require (for-label framework/framework))
+@(require (for-label scheme/gui))
+@title{GUI Utilities}
+
+@(require framework/framework-docs)
+@(defmodule framework/gui-utils)
+
+@(include-extracted (lib "gui-utils.ss" "framework"))

collects/scribblings/framework/preferences-text.scrbl

@@ -0,0 +1,10 @@
+#lang scribble/doc
+@(require scribble/manual scribble/extract)
+@(require (for-label framework/framework))
+@(require (for-label scheme/gui))
+@title{Preferences, Textual}
+
+@(require framework/framework-docs)
+@(defmodule framework/preferences)
+
+@(include-extracted (lib "preferences.ss" "framework"))