whoops! forgot to add preferences.ss in

svn: r5540

collects/framework/preferences.ss

@@ -0,0 +1,466 @@
+
+#|
+
+There are three attributes for each preference:
+
+  - default set, or not
+  - marshalling function set, or not
+  - initialization still okay, or not
+
+the state transitions / contracts are:
+
+  get(true, _, _) -> (true, _, false)
+  get(false, _, _) -> error default not yet set
+
+  set is just like get.
+
+  set-default(false, _, true) -> set-default(true, _, true)
+  set-default(true, _, _) -> error default already set
+  set-default(_, _, false) -> initialization not okay anymore  /* cannot happen, I think */
+
+  set-un/marshall(true, false, true) -> (true, true, true)
+  .. otherwise error
+
+  for all syms: 
+   prefs-snapshot(_, _, _) -> (_, _, false) 
+
+|#
+
+(module preferences mzscheme
+  (require (lib "file.ss")
+	   (lib "etc.ss")
+           (lib "contract.ss"))
+  
+  (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) ...))]))
+
+  
+  (define old-preferences-symbol 'plt:framework-prefs)
+  (define old-preferences (make-hash-table))
+  (let ([old-prefs (get-preference old-preferences-symbol (λ () '()))])
+    (for-each
+     (λ (line) (hash-table-put! old-preferences (car line) (cadr line)))
+     old-prefs))
+  
+  (define (add-pref-prefix p) (string->symbol (format "plt:framework-pref:~a" p)))
+  
+  ;; preferences : hash-table[sym -o> any]
+  ;; the current values of the preferences
+  (define preferences (make-hash-table))
+  
+  ;; marshalled : hash-table[sym -o> any]
+  ;; the values of the preferences, as read in from the disk
+  ;; each symbol will only be mapped in one of the preferences
+  ;; hash-table and this hash-table, but not both.
+  (define marshalled (make-hash-table))
+  
+  ;; marshall-unmarshall : sym -o> un/marshall
+  (define marshall-unmarshall (make-hash-table))
+  
+  ;; callbacks : sym -o> (listof (sym TST -> boolean))
+  (define callbacks (make-hash-table))
+  
+  ;; defaults : hash-table[sym -o> default]
+  (define defaults (make-hash-table))
+  
+  ;; these four functions determine the state of a preference
+  (define (pref-un/marshall-set? pref) (hash-table-bound? marshall-unmarshall pref))
+  (define (pref-default-set? pref) (hash-table-bound? defaults pref))
+  (define (pref-can-init? pref) 
+    (and (not snapshot-grabbed?)
+         (not (hash-table-bound? preferences pref))))
+  
+  ;; type un/marshall = (make-un/marshall (any -> prinable) (printable -> any))
+  (define-struct un/marshall (marshall unmarshall))
+  
+  ;; type pref = (make-pref any)
+  (define-struct pref (value))
+  
+  ;; type default  = (make-default any (any -> bool))
+  (define-struct default (value checker))
+  
+  ;; 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?.
+  (define-struct pref-callback (cb))
+  
+  ;; get : symbol -> any
+  ;; return the current value of the preference `p'
+  ;; exported
+  (define (preferences:get p)
+    (cond
+      [(pref-default-set? p)
+       
+       ;; unmarshall, if required
+       (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)
+           (hash-table-put! preferences p (unmarshall-pref p (hash-table-get marshalled p))))
+         (hash-table-remove! marshalled p))
+       
+       ;; 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-put! preferences p (unmarshall-pref p (hash-table-get old-preferences p)))))
+       
+       ;; clear the pref from the old table (just in case it was taking space -- we don't need it anymore)
+       (when (hash-table-bound? old-preferences p)
+         (hash-table-remove! old-preferences p))
+       
+       ;; if it still isn't set, take the default value
+       (unless (hash-table-bound? preferences p)
+         (hash-table-put! preferences p (default-value (hash-table-get defaults p))))
+       
+       (hash-table-get preferences p)]
+      [(not (pref-default-set? p))
+       (raise-unknown-preference-error
+        'preferences:get
+        "tried to get a preference but no default set for ~e"
+        p)]))
+  
+  ;; set : symbol any -> void
+  ;; updates the preference
+  ;; exported
+  (define (preferences:set p value) (multi-set (list p) (list value)))
+  
+  ;; set : symbol any -> void
+  ;; updates the preference
+  ;; exported
+
+  (define (multi-set ps values)
+    (for-each
+     (λ (p value)
+       (cond
+         [(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
+  ;; unmarshalls a preference read from the disk
+  (define (unmarshall-pref p data)
+    (let/ec k
+      (let* ([unmarshall-fn (un/marshall-unmarshall
+                             (hash-table-get marshall-unmarshall
+                                             p
+                                             (λ () (k data))))]
+             [default (hash-table-get defaults p)]
+             [result (unmarshall-fn data)])
+        (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
+    any/c
+    ()
+    "This is a parameter (see "
+    "\\Mzhyperref{parameters}{mz:parameters} for information about parameters)"
+    "which is called when a preference is saved. Its interface should "
+    "be just like mzlib's \\scheme|put-preference|.")
+   
+   (preferences:get
+    (symbol? . -> . any/c)
+    (symbol)
+    "See also"
+    "@flink preferences:set-default %"
+    "."
+    ""
+    "\\rawscm{preferences:get} returns the value for the preference"
+    "\\var{symbol}. It raises"
+    "\\scmindex{exn:unknown-preference}\\rawscm{exn:unknown-preference}"
+    "if the preference's default has not been set.")
+   (preferences:set
+    (symbol? any/c . -> . void?)
+    (symbol value)
+    "See also"
+    "@flink preferences:set-default %"
+    "."
+    ""
+    "\\rawscm{preferences:set-preference} sets the preference"
+    "\\var{symbol} to \\var{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"
+    "\\scmindex{exn:unknown-preference}\\rawscm{exn:unknown-preference}"
+    "if the preference's default has not been set.")
+   (preferences:add-callback
+    (opt-> (symbol? (symbol? any/c . -> . any/c))
+           (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."
+    "\\rawscm{preferences:add-callback} returns a thunk, which when"
+    "invoked, removes the callback from this preference."
+    ""
+    "If \\var{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"
+    "\\iscmprocedure{preferences:set-un/marshall} before adding a callback."
+    ""
+    "This function raises"
+    "\\scmindex{exn:unknown-preference}\\rawscm{exn:unknown-preference}"
+    "if the preference has not been set.")
+   (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"
+    "@flink preferences:get %"
+    ", "
+    "@flink preferences:set"
+    "(for any given preference)."
+    ""
+    "If you use"
+    "@flink preferences:set-un/marshall %"
+    ", you must call this function before calling it."
+    ""
+    "This sets the default value of the preference \\var{symbol} to"
+    "\\var{value}. If the user has chosen a different setting,"
+    "the user's setting"
+    "will take precedence over the default value."
+    ""
+    "The last argument, \\var{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 \\var{test} returns \\rawscm{\\#t}, then the preference is"
+    "treated as valid. If \\var{test} returns \\rawscm{\\#f} then the default is"
+    "used.")
+   (preferences:set-un/marshall
+    (symbol? (any/c . -> . printable/c) (printable/c . -> . any/c) . -> . void?)
+    (symbol marshall unmarshall)
+    "\\rawscm{preference:set-un/marshall} is used to specify marshalling and"
+    "unmarshalling functions for the preference"
+    "\\var{symbol}. \\var{marshall} will be called when the users saves their"
+    "preferences to turn the preference value for \\var{symbol} into a"
+    "printable value. \\var{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 \\rawscm{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 "
+    "@flink preferences:set-default"
+    "for this preference, the default value is used."
+    ""
+    "The \\var{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."
+    ""
+    "\\rawscm{preference:set-un/marshall} must be called before calling"
+    "@flink preferences:get %"
+    ", "
+    "@flink preferences:set %"
+    ".")
+   
+   (preferences:restore-defaults
+    (-> void?)
+    ()
+    "\\rawscm{(preferences:restore-defaults)} restores the users's configuration to the"
+    "default preferences.")))