(module preferences mzscheme
  (require (lib "string-constant.ss" "string-constants")
           (lib "unitsig.ss")
	   (lib "class.ss")
           (lib "file.ss")
	   "sig.ss"
           "../gui-utils.ss"
	   (lib "mred-sig.ss" "mred")
	   (lib "pretty.ss")
	   (lib "list.ss"))
  
  (provide preferences@)
  (define preferences@
    (unit/sig framework:preferences^
      (import mred^
              [exn : framework:exn^]
              [exit : framework:exit^]
              [panel : framework:panel^]
              [frame : framework:frame^])
      
      (rename [-read read])
      
      (define main-preferences-symbol 'plt:framework-prefs)
      
      ;; preferences : sym -o> (union marshalled pref)
      (define preferences (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 : sym -o> default
      (define defaults (make-hash-table))
      
      (define-struct un/marshall (marshall unmarshall))
      (define-struct marshalled (data))
      (define-struct pref (value))
      (define-struct default (value checker))
      
      (define guard
        (lambda (when p value thunk failure)
          (with-handlers ([not-break-exn? failure])
            (thunk))))
      
      (define (unmarshall p marshalled)
        (let/ec k
          (let* ([data (marshalled-data marshalled)]
                 [unmarshall-fn (un/marshall-unmarshall
                                 (hash-table-get marshall-unmarshall
                                                 p
                                                 (lambda () (k data))))])
            (guard "unmarshalling" p marshalled
                   (lambda () (unmarshall-fn data))
                   (lambda (exn)
                     (begin0
                       (hash-table-get
                        defaults
                        p
                        (lambda ()
                          (raise exn)))
                       (message-box (format (string-constant error-unmarshalling) p)
                                    (if (exn? exn)
                                        (format "~a" (exn-message exn))
                                        (format "~s" exn)))))))))
      
      ;; get-callbacks : sym -> (listof (-> void))
      (define (get-callbacks p)
        (hash-table-get callbacks
                        p
                        (lambda () null)))
      
      ;; pref-callback : (make-pref-callback (sym tst -> void))
      ;; this is used as a wrapped to hack around the problem
      ;; that different procedures might be eq?.
      (define-struct pref-callback (cb))

      ;; add-callback : sym (-> void) -> void
      (define (add-callback p callback)
        (let ([new-cb (make-pref-callback callback)])
          (hash-table-put! callbacks p 
                           (append 
                            (hash-table-get callbacks p (lambda () null))
                            (list new-cb)))
          (lambda ()
            (hash-table-put!
             callbacks
             p
             (let loop ([callbacks (hash-table-get callbacks p (lambda () 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)))]))]))))))
      
      (define (check-callbacks p value)
	(for-each (lambda (x)
		    (guard "calling callback" p value
			   (lambda () ((pref-callback-cb x) p value))
			   raise))
                  (get-callbacks p)))
      
      (define (get p) 
        (let ([ans (hash-table-get preferences p
                                   (lambda () 
                                     (raise (exn:make-unknown-preference
                                             (format "preferences:get: attempted to get unknown preference: ~e" p)
                                             (current-continuation-marks)))))])
          (cond
            [(marshalled? ans)
             (let* ([default-s
                     (hash-table-get
                      defaults p
                      (lambda ()
                        (raise (exn:make-unknown-preference
                                (format "preferences:get: no default pref for: ~e" p)
                                (current-continuation-marks)))))]
                    [default (default-value default-s)]
                    [checker (default-checker default-s)]
                    [unmarshalled (let ([unmarsh (unmarshall p ans)])
                                    (if (checker unmarsh)
                                        unmarsh
                                        default))]
                    [pref (begin (check-callbacks p unmarshalled)
				 unmarshalled)])
               (hash-table-put! preferences p (make-pref pref))
               pref)]
            [(pref? ans)
             (pref-value ans)]
            [else (error 'prefs.ss "robby error.1: ~a" ans)])))
      
      (define (default-set? p)
        (let/ec k
          (hash-table-get defaults p (lambda () (k #f)))
          #t))

      (define (set p value)
        (let* ([pref (hash-table-get preferences p (lambda () #f))])
          (unless (default-set? p)
            (error 'preferences:set "tried to set a preference but no default set for ~e, with ~e"
                   p value))
          (cond
            [(pref? pref)
             (check-callbacks p value)
	     (set-pref-value! pref value)]
            [(or (marshalled? pref) 
                 (not pref))
             (check-callbacks p value)
	     (hash-table-put! preferences p (make-pref value))]
            [else
             (error 'prefs.ss "robby error.0: ~a" pref)])))
      
      (define set-un/marshall
        (lambda (p marshall unmarshall)
          (unless (default-set? p)
            (error 'set-un/marshall "must call set-default for ~s before calling set-un/marshall for ~s"
                   p p))
          (hash-table-put! marshall-unmarshall p (make-un/marshall marshall unmarshall))))
      
      (define restore-defaults
        (lambda ()
          (hash-table-for-each
           defaults
           (lambda (p v) (set p v)))))
      
      ;; set-default : (sym TST (TST -> boolean) -> void
      (define (set-default p default-value checker)
        (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-get preferences p 
                          (lambda ()
                            (hash-table-put! preferences p (make-pref default-value))))
          (hash-table-put! defaults p (make-default default-value checker))))
      
      (define (save)
        (with-handlers ([(lambda (x) #t)
                         (lambda (exn)
                           (message-box
                            (string-constant preferences)
                            (format (string-constant error-saving-preferences)
                                    (exn-message exn)))
                           #f)])
          (let ([syms (list main-preferences-symbol)]
                [vals (list (hash-table-map preferences marshall-pref))]
                [res #t])
            (put-preferences
             syms vals
             (lambda (filename)
               (let* ([d (make-object dialog% (string-constant preferences))]
                      [m (make-object message% (string-constant waiting-for-pref-lock) d)])
                 (thread
                  (lambda ()
                    (sleep 2)
                    (send d show #f)))
                 (send d show #t)
                 (put-preferences 
                  syms vals
                  (lambda (filename)
                    (set! res #f)
                    (message-box
                     (string-constant preferences)
                     (format (string-constant pref-lock-not-gone) filename)))))))
            res)))
      
      (define (marshall-pref p ht-value)
        (cond
          [(marshalled? ht-value) (list p (marshalled-data ht-value))]
          [(pref? ht-value)
           (let* ([value (pref-value ht-value)]
                  [marshalled
                   (let/ec k
                     (guard "marshalling" p value
                            (lambda ()
                              ((un/marshall-marshall
                                (hash-table-get marshall-unmarshall p
                                                (lambda ()
                                                  (k value))))
                               value))
                            raise))])
             (list p marshalled))]
          [else (error 'prefs.ss "robby error.2: ~a" ht-value)]))
      
      (define (read-err input msg)
        (message-box 
         (string-constant preferences)
         (let* ([max-len 150]
                [s1 (format "~s" input)]
                [ell "..."]
                [s2 (if (<= (string-length s1) max-len)
                        s1
                        (string-append
                         (substring s1 0 (- max-len
                                            (string-length ell)))
                         ell))])
           (string-append
            (string-constant error-reading-preferences)
            "\n"
            msg
            s2))))

      (define (for-each-pref-in-file parse-pref preferences-filename)
        (let/ec k
          (let ([input (with-handlers
                           ([not-break-exn?
                             (lambda (exn)
                               (message-box
                                (string-constant error-reading-preferences)
                                (string-append
                                 (string-constant error-reading-preferences)
                                 (format "\n~a" (exn-message exn))))
                               (k #f))])
                         (call-with-input-file preferences-filename read 'text))])
            (if (eof-object? input)
                (void)
                (for-each-pref-in-sexp input parse-pref)))))
      
      ;; for-each-pref-in-sexp : sexp (symbol TST -> void) -> void
      (define (for-each-pref-in-sexp input parse-pref)
        (let/ec k
          (let loop ([input input])
            (when (pair? input)
              (let ([pre-pref (car input)])
                (if (and (pair? pre-pref)
                         (pair? (cdr pre-pref))
                         (null? (cddr pre-pref)))
                    (parse-pref (car pre-pref) (cadr pre-pref))
                    (begin (read-err input (string-constant expected-list-of-length2))
                           (k #f))))
              (loop (cdr input))))))
      
      ;; add-raw-pref-to-ht : hash-table symbol marshalled-preference -> void
      (define (add-raw-pref-to-ht ht p marshalled)
        (let* ([ht-pref (hash-table-get ht p (lambda () #f))]
               [unmarshall-struct (hash-table-get marshall-unmarshall p (lambda () #f))])
          (cond
            [unmarshall-struct
             (set p ((un/marshall-unmarshall unmarshall-struct) marshalled))]
            
            ;; in this case, assume that no marshalling/unmarshalling 
            ;; is going to take place with the pref, since an unmarshalled 
            ;; pref was already there.
            [(pref? ht-pref)
             (set p marshalled)]
            
            [(marshalled? ht-pref) 
             (set-marshalled-data! ht-pref marshalled)]
            [(and (not ht-pref) unmarshall-struct)
             (set p ((un/marshall-unmarshall unmarshall-struct) marshalled))]
            [(not ht-pref)
             (hash-table-put! ht p (make-marshalled marshalled))]
            [else (error 'prefs.ss "robby error.3: ~a" ht-pref)])))

      ;; read : -> void
      (define (-read)
        (let/ec k
          (let ([sexp (get-preference main-preferences-symbol (lambda () (k #f)))])
            (install-stashed-preferences sexp))))
      
      ;; install-stashed-preferences : sexp -> void
      ;; ensure that `prefs' is actuall a well-formed preferences
      ;; table and installs them as the current preferences.
      (define (install-stashed-preferences prefs)
        (for-each-pref-in-sexp 
         prefs
         (lambda (p marshalled)
           (add-raw-pref-to-ht preferences p marshalled))))
 
                                          
    ;;    ;           ;;;                 
     ;                  ;                 
     ;                  ;                 
  ;;;;  ;;;    ;;;;     ;     ;;;    ;;; ;
 ;   ;    ;        ;    ;    ;   ;  ;   ; 
 ;   ;    ;     ;;;;    ;    ;   ;  ;   ; 
 ;   ;    ;    ;   ;    ;    ;   ;  ;   ; 
 ;   ;    ;    ;   ;    ;    ;   ;  ;   ; 
  ;;; ; ;;;;;   ;;; ; ;;;;;;  ;;;    ;;;; 
                                        ; 
                                        ; 
                                     ;;;  
      
      
      ;; ppanel-tree = 
      ;;  (union (make-ppanel-leaf string (union #f panel) (panel -> panel))
      ;;         (make-ppanel-interior string (union #f panel) (listof panel-tree)))
      (define-struct ppanel (name panel))
      (define-struct (ppanel-leaf ppanel) (maker))
      (define-struct (ppanel-interior ppanel) (children))
      
      ;; ppanels : (listof ppanel-tree)
      (define ppanels null)
      
      (define preferences-dialog #f)
      
      (define (add-panel title make-panel)
        (when preferences-dialog
          (error 'add-panel "preferences dialog already open, cannot add new panels"))
        (let ([titles (if (string? title)
                          (list title)
                          title)])
          (add-to-existing-children
           titles 
           make-panel
           (lambda (new-subtree) (set! ppanels (cons new-subtree ppanels))))))
      
      ;; add-to-existing-children : (listof string) (panel -> panel) (ppanel -> void)
      ;; adds the child specified by the path in-titles to the tree.
      (define (add-to-existing-children in-titles make-panel banger)
        (let loop ([children ppanels]
                   [title (car in-titles)]
                   [titles (cdr in-titles)]
                   [banger banger])
          (cond
            [(null? children)
             (banger (build-new-subtree (cons title titles) make-panel))]
            [else
             (let ([child (car children)])
               (if (string=? (ppanel-name child) title)
                   (cond
                     [(null? titles) 
                      (error 'add-child "child already exists with this path: ~e" in-titles)]
                     [(ppanel-leaf? child)
                      (error 'add-child "new child's path conflicts with existing path: ~e" in-titles)]
                     [else
                      (loop
                       (ppanel-interior-children child)
                       (car titles)
                       (cdr titles)
                       (lambda (x)
                         (set-ppanel-interior-children! 
                          (cons
                           x
                           (ppanel-interior-children child)))))])
                   (loop 
                    (cdr children)
                    title
                    titles
                    (lambda (x)
                      (set-cdr! children
                                (cons x (cdr children)))))))])))
      
      ;; build-new-subtree : (cons string (listof string)) (panel -> panel) -> ppanel
      (define (build-new-subtree titles make-panel)
        (let loop ([title (car titles)]
                   [titles (cdr titles)])
          (cond
            [(null? titles) (make-ppanel-leaf title #f make-panel)]
            [else
             (make-ppanel-interior 
              title
              #f
              (list (loop (car titles) (cdr titles))))])))
           
      
      (define (hide-dialog)
	(when preferences-dialog
	  (send preferences-dialog show #f)))
      
      (define (show-dialog)
	(save)
	(if preferences-dialog
	    (send preferences-dialog show #t)
	    (set! preferences-dialog
		  (make-preferences-dialog))))

      (define (add-can-close-dialog-callback cb)
	(set! can-close-dialog-callbacks
	      (cons cb can-close-dialog-callbacks)))

      (define (add-on-close-dialog-callback cb)
	(set! on-close-dialog-callbacks
	      (cons cb on-close-dialog-callbacks)))

      (define on-close-dialog-callbacks null)

      (define can-close-dialog-callbacks null)
      
      (define (make-preferences-dialog)
        (letrec ([stashed-prefs (get-preference main-preferences-symbol (lambda () null))]
		 [frame-stashed-prefs%
		  (class frame:basic%
		    (rename [super-show show])
                    (define/override (show on?)
                      (when on?
                        (set! stashed-prefs
                              (get-preference main-preferences-symbol
                                              (lambda () null))))
		      (super-show on?))
		    (super-instantiate ()))]
                 [frame 
                  (make-object frame-stashed-prefs%
                    (string-constant preferences))]
                 [build-ppanel-tree
                  (lambda (ppanel tab-panel single-panel)
                    (send tab-panel append (ppanel-name ppanel))
                    (cond
                      [(ppanel-leaf? ppanel) 
                       ((ppanel-leaf-maker ppanel) single-panel)]
                      [(ppanel-interior? ppanel)
                       (let-values ([(tab-panel single-panel) (make-tab/single-panel single-panel #t)])
                         (for-each
                          (lambda (ppanel) (build-ppanel-tree ppanel tab-panel single-panel))
                          (ppanel-interior-children ppanel)))]))]
                 [make-tab/single-panel 
                  (lambda (parent inset?)
                    (letrec ([spacer (and inset?
                                          (instantiate vertical-panel% ()
                                            (parent parent)
                                            (border 10)))]
                             [tab-panel (instantiate tab-panel% ()
                                          (choices null)
                                          (parent (if inset? spacer parent))
                                          (callback (lambda (_1 _2) 
                                                      (tab-panel-callback
                                                       single-panel
                                                       tab-panel))))]
                             [single-panel (instantiate panel:single% ()
                                             (parent tab-panel))])
                      (values tab-panel single-panel)))]
                 [tab-panel-callback
                  (lambda (single-panel tab-panel)
                    (send single-panel active-child
                          (list-ref (send single-panel get-children)
                                    (send tab-panel get-selection))))]
                 [panel (make-object vertical-panel% (send frame get-area-container))]
                 [_ (let-values ([(tab-panel single-panel) (make-tab/single-panel panel #f)])
                      (for-each
                       (lambda (ppanel)
                         (build-ppanel-tree ppanel tab-panel single-panel))
                       ppanels)
                      (let ([single-panel-children (send single-panel get-children)])
                        (unless (null? single-panel-children)
                          (send single-panel active-child (car single-panel-children))
                          (send tab-panel set-selection 0)))
                      (send tab-panel focus))]
                 [bottom-panel (make-object horizontal-panel% panel)]
                 [ok-callback (lambda args
                                (when (andmap (lambda (f) (f))
                                              can-close-dialog-callbacks)
                                  (for-each
                                   (lambda (f) (f))
                                   on-close-dialog-callbacks)
                                  (save)
                                  (hide-dialog)))]
                 [cancel-callback (lambda (_1 _2)
                                    (hide-dialog)
                                    (install-stashed-preferences stashed-prefs))])
          (gui-utils:ok/cancel-buttons
           bottom-panel
           ok-callback
           cancel-callback)
          (make-object grow-box-spacer-pane% bottom-panel)
          (send* bottom-panel
            (stretchable-height #f)
            (set-alignment 'right 'center))
          (send frame show #t)
          frame))
      
      (define (add-to-scheme-checkbox-panel f)
        (set! scheme-panel-procs 
              (let ([old scheme-panel-procs])
                (lambda (parent) (old parent) (f parent)))))
      
      (define (add-to-editor-checkbox-panel f)
        (set! editor-panel-procs 
              (let ([old editor-panel-procs])
                (lambda (parent) (old parent) (f parent)))))
      
      (define (add-to-warnings-checkbox-panel f)
        (set! warnings-panel-procs 
              (let ([old warnings-panel-procs])
                (lambda (parent) (old parent) (f parent)))))

      (define scheme-panel-procs void)
      (define editor-panel-procs void)
      (define warnings-panel-procs void)
      
      (define (add-checkbox-panel label proc)
        (add-panel
         label
         (lambda (parent)
           (let* ([main (make-object vertical-panel% parent)])
             (send main set-alignment 'left 'center)
             (proc main)
             main))))
      
      ;; make-check : panel symbol string (boolean -> any) (any -> boolean)
      ;; adds a check box preference to `main'.
      (define (make-check main pref title bool->pref pref->bool)
        (let* ([callback
                (lambda (check-box _)
                  (set pref (bool->pref (send check-box get-value))))]
               [pref-value (get pref)]
               [initial-value (pref->bool pref-value)]
               [c (make-object check-box% title main callback)])
          (send c set-value initial-value)
          (add-callback pref
                        (lambda (p v)
                          (send c set-value (pref->bool v))))))

      (define (make-recent-items-slider parent)
        (let ([slider (instantiate slider% ()
                        (parent parent)
                        (label (string-constant number-of-open-recent-items))
                        (min-value 1)
                        (max-value 100)
                        (init-value (get 'framework:recent-max-count))
                        (callback (lambda (slider y)
                                    (set 'framework:recent-max-count
                                         (send slider get-value)))))])
          (add-callback
           'framework:recent-max-count
           (lambda (p v)
             (send slider set-value v)))))
      
      (define (add-scheme-checkbox-panel)
        (letrec ([add-scheme-checkbox-panel
                  (lambda ()
                    (set! add-scheme-checkbox-panel void)
                    (add-checkbox-panel
                     (list 
                      (string-constant editor-prefs-panel-label) 
                      (string-constant scheme-prefs-panel-label))
                     (lambda (scheme-panel)
                       (make-check scheme-panel
                                   'framework:highlight-parens
                                   (string-constant highlight-parens)
                                   values values)
                       (make-check scheme-panel
                                   'framework:fixup-parens
                                   (string-constant fixup-parens)
                                   values values)
                       (make-check scheme-panel
                                   'framework:paren-match
                                   (string-constant flash-paren-match)
                                   values values)
                       (scheme-panel-procs scheme-panel)
                       (make-highlight-color-choice scheme-panel))))])
          (add-scheme-checkbox-panel)))
      
      (define (make-highlight-color-choice panel)
        (let* ([hp (instantiate horizontal-panel% ()
                     (parent panel)
                     (stretchable-height #f))]
               [msg (make-object message% (string-constant paren-match-color) hp)]
               [scheme-higlight-canvas (make-object scheme-highlight-canvas% hp)]
               [button (make-object button% 
                         (string-constant choose-color) 
                         hp
                         (lambda (x y) (change-highlight-color panel)))])
          (void)))
      
      (define scheme-highlight-canvas%
        (class canvas%
          (inherit get-client-size get-dc)
          (define/override (on-paint)
            (do-draw (get 'framework:paren-match-color)))
          (define/public (do-draw color)
            (let ([dc (get-dc)])
              (send dc set-pen (send the-pen-list find-or-create-pen
                                     color
                                     1
                                     'solid))
              (send dc set-brush (send the-brush-list find-or-create-brush
                                       color 
                                       'solid))
              (let-values ([(w h) (get-client-size)])
                (send dc draw-rectangle 0 0 w h))))
          (super-instantiate ())
          (inherit stretchable-width min-width)
          (add-callback
           'framework:paren-match-color
           (lambda (p v)
             (do-draw v)))))
      
      (define (change-highlight-color parent)
        (let ([new-color
               (get-color-from-user (string-constant choose-paren-highlight-color)
                                    (send parent get-top-level-window)
                                    (get 'framework:paren-match-color))])
          (when new-color
            (set 'framework:paren-match-color new-color))))
      
      (define (add-editor-checkbox-panel)
        (letrec ([add-editor-checkbox-panel
                  (lambda ()
                    (set! add-editor-checkbox-panel void)
                    (add-checkbox-panel 
                     (list (string-constant editor-prefs-panel-label) 
                           (string-constant general-prefs-panel-label))
                     (lambda (editor-panel)
                       (make-recent-items-slider editor-panel)
                       (make-check editor-panel
                                   'framework:autosaving-on? 
                                   (string-constant auto-save-files)
                                   values values)
                       (make-check editor-panel  'framework:backup-files? (string-constant backup-files) values values)
                       (make-check editor-panel  'framework:delete-forward? (string-constant map-delete-to-backspace)
                                   not not)
                       (make-check editor-panel 'framework:show-status-line (string-constant show-status-line) values values)
                       (make-check editor-panel 'framework:col-offsets (string-constant count-columns-from-one) values values)
                       (make-check editor-panel 
                                   'framework:display-line-numbers
                                   (string-constant display-line-numbers)
                                   values values)
                       
                       (make-check editor-panel 
                                   'framework:auto-set-wrap?
                                   (string-constant wrap-words-in-editor-buffers)
                                   values values)
                       (make-check editor-panel 
                                   'framework:search-using-dialog?
                                   (string-constant separate-dialog-for-searching)
                                   values values)
                       (make-check editor-panel 
                                   'framework:open-here?
                                   (string-constant reuse-existing-frames)
                                   values values)
                       (make-check editor-panel 
                                   'framework:menu-bindings
                                   (string-constant enable-keybindings-in-menus)
                                   values values)
                       (unless (eq? (system-type) 'unix) 
                         (make-check editor-panel 
                                     'framework:print-output-mode 
                                     (string-constant automatically-to-ps)
                                     (lambda (b) 
                                       (if b 'postscript 'standard))
                                     (lambda (n) (eq? 'postscript n))))
                       (editor-panel-procs editor-panel))))])
          (add-editor-checkbox-panel)))

      (define (add-warnings-checkbox-panel)
        (letrec ([add-warnings-checkbox-panel
                  (lambda ()
                    (set! add-warnings-checkbox-panel void)
                    (add-checkbox-panel
                     (string-constant warnings-prefs-panel-label)
                     (lambda (warnings-panel)
                       (make-check warnings-panel 
                                   'framework:verify-change-format 
                                   (string-constant ask-before-changing-format)
                                   values values)
                       (make-check warnings-panel 
                                   'framework:verify-exit
                                   (string-constant verify-exit)
                                   values values)
                       
                       (warnings-panel-procs warnings-panel))))])
          (add-warnings-checkbox-panel)))
                  
      (define (local-add-font-panel)
        (let* ([font-families-name/const
                (list (list "Default" 'default)
                      (list "Decorative" 'decorative)
                      (list "Modern" 'modern)
                      (list "Roman" 'roman)
                      (list "Script" 'script)
                      (list "Swiss" 'swiss))]
               
               [font-families (map car font-families-name/const)]
               
               [font-size-entry "defaultFontSize"]
               [font-default-string "Default Value"]
               [font-default-size (case (system-type)
                                    [(windows) 10]
                                    [(macosx) 13]
                                    [else 12])]
               [font-section "mred"]
               [build-font-entry (lambda (x) (string-append "Screen" x "__"))]
               [font-file (find-graphical-system-path 'setup-file)]
               [build-font-preference-symbol
                (lambda (family)
                  (string->symbol (string-append "framework:" family)))]
               
               [set-default
                (lambda (build-font-entry default pred)
                  (lambda (family)
                    (let ([name (build-font-preference-symbol family)]
                          [font-entry (build-font-entry family)])
                      (set-default name
                                   default
                                   (cond
                                     [(string? default) string?]
                                     [(number? default) number?]
                                     [else (error 'internal-error.set-default "unrecognized default: ~a~n" default)]))
                      (add-callback 
                       name 
                       (lambda (p new-value)
                         (write-resource 
                          font-section
                          font-entry
                          (if (and (string? new-value)
                                   (string=? font-default-string new-value))
                              ""
                              new-value)
                          font-file))))))])
          
          (for-each (set-default build-font-entry font-default-string string?)
                    font-families)
          ((set-default (lambda (x) x)
                        font-default-size
                        number?)
           font-size-entry)
          (add-panel
           (string-constant default-fonts)
           (lambda (parent)
             (letrec ([font-size-pref-sym (build-font-preference-symbol font-size-entry)]
                      [ex-string (string-constant font-example-string)]
                      [main (make-object vertical-panel% parent)]
                      [fonts (cons font-default-string (get-face-list))]
                      [make-family-panel
                       (lambda (name)
                         (let* ([pref-sym (build-font-preference-symbol name)]
                                [family-const-pair (assoc name font-families-name/const)]
                                
                                [edit (make-object text%)]
                                [_ (send edit insert ex-string)]
                                [set-edit-font
                                 (lambda (size)
                                   (let ([delta (make-object style-delta% 'change-size size)]
                                         [face (get pref-sym)])
                                     (if (and (string=? face font-default-string)
                                              family-const-pair)
                                         (send delta set-family (cadr family-const-pair))
                                         (send delta set-delta-face (get pref-sym)))
                                     
                                     (send edit change-style delta 0 (send edit last-position))))]
                                
                                [horiz (make-object horizontal-panel% main '(border))]
                                [label (make-object message% name horiz)]
                                
                                [message (make-object message%
                                           (let ([b (box "")])
                                             (if (and (get-resource 
                                                       font-section 
                                                       (build-font-entry name)
                                                       b)
                                                      (not (string=? (unbox b) 
                                                                     "")))
                                                 (unbox b)
                                                 font-default-string)) 
                                           horiz)]
                                [button 
                                 (make-object button%
                                   (string-constant change-font-button-label)
                                   horiz
                                   (lambda (button evt)
                                     (let ([new-value
                                            (get-choices-from-user
                                             (string-constant fonts)
                                             (format (string-constant choose-a-new-font)
                                                     name)
                                             fonts)])
                                       (when new-value
                                         (set pref-sym (list-ref fonts (car new-value))) 
                                         (set-edit-font (get font-size-pref-sym))))))]
                                [canvas (make-object editor-canvas% horiz
                                          edit
                                          (list 'hide-hscroll
                                                'hide-vscroll))])
                           (set-edit-font (get font-size-pref-sym))
                           (add-callback
                            pref-sym
                            (lambda (p new-value)
                              (send horiz change-children
                                    (lambda (l)
                                      (let ([new-message (make-object message%
                                                           new-value
                                                           horiz)])
                                        (set! message new-message)
                                        (update-message-sizes font-message-get-widths 
                                                              font-message-user-min-sizes)
                                        (list label 
                                              new-message
                                              button
                                              canvas))))))
                           (send canvas set-line-count 1)
                           (vector set-edit-font
                                   (lambda () (send message get-width))
                                   (lambda (width) (send message min-width width))
                                   (lambda () (send label get-width))
                                   (lambda (width) (send label min-width width)))))]
                      [set-edit-fonts/messages (map make-family-panel font-families)]
                      [collect (lambda (n) (map (lambda (x) (vector-ref x n))
                                                set-edit-fonts/messages))]
                      [set-edit-fonts (collect 0)]
                      [font-message-get-widths (collect 1)]
                      [font-message-user-min-sizes (collect 2)]
                      [category-message-get-widths (collect 3)]
                      [category-message-user-min-sizes (collect 4)]
                      [update-message-sizes
                       (lambda (gets sets)
                         (let ([width (foldl (lambda (x l) (max l (x))) 0 gets)])
                           (for-each (lambda (set) (set width)) sets)))]
                      [size-panel (make-object horizontal-panel% main '(border))]
                      [initial-font-size
                       (let ([b (box 0)])
                         (if (get-resource font-section 
                                           font-size-entry
                                           b)
                             (unbox b)
                             font-default-size))]
                      [size-slider
                       (make-object slider%
                         (string-constant font-size-slider-label)
                         1 127
                         size-panel
                         (lambda (slider evt)
                           (set font-size-pref-sym (send slider get-value)))
                         initial-font-size)])
               (update-message-sizes font-message-get-widths font-message-user-min-sizes)
               (update-message-sizes category-message-get-widths category-message-user-min-sizes)
               (add-callback
                font-size-pref-sym
                (lambda (p value)
                  (for-each (lambda (f) (f value)) set-edit-fonts)
                  (unless (= value (send size-slider get-value))
                    (send size-slider set-value value))
                  #t))
               (for-each (lambda (f) (f initial-font-size)) set-edit-fonts)
               (make-object message% (string-constant restart-to-see-font-changes) main)
               main))))
        (set! local-add-font-panel void))
      
      (define (add-font-panel) (local-add-font-panel)))))