;; originally by Dan Grossman
;; 6/30/95

(module scheme mzscheme
  (require "collapsed-snipclass-helpers.ss"
           (lib "string-constant.ss" "string-constants")
           (lib "unitsig.ss")
	   (lib "class.ss")
	   "sig.ss"
	   (lib "mred-sig.ss" "mred")
           (lib "mred.ss" "mred")
	   (lib "list.ss")
	   (lib "thread.ss")
           (lib "etc.ss")
           (lib "surrogate.ss")
           (lib "scheme-lexer.ss" "syntax-color"))
  
  (provide scheme@)

  (define (scheme-paren:get-paren-pairs)
    '(("(" . ")")
      ("[" . "]")
      ("{" . "}")))
  
  
  (define scheme@
    (unit/sig framework:scheme^
      (import mred^
              [preferences : framework:preferences^]
              [icon : framework:icon^]
              [keymap : framework:keymap^]
              [text : framework:text^]
              [editor : framework:editor^]
              [frame : framework:frame^]
              [comment-box : framework:comment-box^]
              [mode : framework:mode^]
              [color : framework:color^]
              [color-prefs : framework:color-prefs^])
      
      (rename [-text-mode<%> text-mode<%>]
              [-text<%> text<%>]
              [-text% text%])
      
      (define text-balanced? 
        (opt-lambda (text [start 0] [in-end #f])
          (let* ([end (or in-end (send text last-position))]
                 [port (open-input-text-editor text start end)])
            (with-handlers ([exn:fail:read:eof? (λ (x) #f)]
                            [exn:fail:read? (λ (x) #t)])
              (let loop ()
                (let ([s (read port)])
                  (or (eof-object? s)
                      (loop))))))))
      
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;;                                                                  ;;
      ;;                           Sexp Snip                              ;;
      ;;                                                                  ;;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

      (define (set-box/f! b v) (when (box? b) (set-box! b v)))

      (define sexp-snip<%>
        (interface ()
          get-saved-snips))

      (define sexp-snip%
        (class* snip% (sexp-snip<%> readable-snip<%>)
          (init-field left-bracket right-bracket saved-snips)
          (define/public (get-saved-snips) saved-snips)
          (field [sizing-text (format "~a   ~a" left-bracket right-bracket)])

          (define/public (read-special file line col pos)
            (let ([text (make-object text:basic%)])
              (for-each
               (λ (s) (send text insert (send s copy)
                                 (send text last-position)
                                 (send text last-position)))
               saved-snips)
	      (datum->syntax-object
	       #f
	       (read (open-input-text-editor text))
	       (list file line col pos 1))))
          
          (define/override get-text
            (opt-lambda (offset num [flattened? #f])
              (if flattened?
                  (apply string-append
                         (map (λ (snip)
                                (send snip get-text 0 (send snip get-count) flattened?))
                              saved-snips))
                  (super get-text offset num flattened?))))
              
          (define/override (copy)
            (instantiate sexp-snip% ()
              (left-bracket left-bracket)
              (right-bracket right-bracket)
              (saved-snips saved-snips)))
          
          (define/override (write stream-out)
            (send stream-out put (bytes (char->integer left-bracket)))
            (send stream-out put (bytes (char->integer right-bracket)))
            (send stream-out put (length saved-snips))
            (let loop ([snips saved-snips])
              (cond
                [(null? snips) (void)]
                [else
                 (let* ([snip (car snips)]
                        [snipclass (send snip get-snipclass)])
                   (send stream-out put (string->bytes/utf-8 (send snipclass get-classname)))
                   (send snip write stream-out))
                 (loop (cdr snips))])))
          
          (define/override (draw dc x y left top right bottom dx dy draw-caret)
            (send dc draw-text sizing-text x y)
            (let-values ([(lpw lph lpa lpd) (send dc get-text-extent (string left-bracket))]
                         [(rpw rph rpa rpd) (send dc get-text-extent (string right-bracket))]
                         [(sw sh sa sd) (send dc get-text-extent sizing-text)])
              (let* ([dtw (- sw lpw rpw)]
                     [dot-start (+ x lpw)]
                     [dt1x (+ dot-start (* dtw 1/5))]
                     [dt2x (+ dot-start (* dtw 1/2))]
                     [dt3x (+ dot-start (* dtw 4/5))]
                     [dty (+ y (/ sh 2))])
                (send dc draw-rectangle dt1x dty 2 2)
                (send dc draw-rectangle dt2x dty 2 2)
                (send dc draw-rectangle dt3x dty 2 2))))

          (inherit get-style)
          (define/override (get-extent dc x y wb hb descentb spaceb lspaceb rspaceb)
            (let-values ([(w h d a) (send dc get-text-extent sizing-text (send (get-style) get-font))])
              (set-box/f! wb w)
              (set-box/f! hb h)
              (set-box/f! descentb d)
              (set-box/f! spaceb a)
              (set-box/f! lspaceb 0)
              (set-box/f! rspaceb 0)))
          (super-instantiate ())
          (inherit set-snipclass)
          (set-snipclass lib-snip-class)))

      (define sexp-snipclass% (make-sexp-snipclass% sexp-snip%))
      
      ;; old snips (from old versions of drscheme) use this snipclass
      (define lib-snip-class (make-object sexp-snipclass%))
      (send lib-snip-class set-classname (format "~s" '(lib "collapsed-snipclass.ss" "framework")))
      (send lib-snip-class set-version 0)
      (send (get-the-snip-class-list) add lib-snip-class)

      ;; new snips use this snipclass
      (define old-snip-class (make-object sexp-snipclass%))
      (send old-snip-class set-classname "drscheme:sexp-snip")
      (send old-snip-class set-version 0)
      (send (get-the-snip-class-list) add old-snip-class)

      (keymap:add-to-right-button-menu
       (let ([old (keymap:add-to-right-button-menu)])
         (λ (menu text event)
           (old menu text event)
           (split/collapse-text menu text event)
	   (void))))
      
      ;; split/collapse-text : (instanceof menu%) (instanceof editor<%>) (instanceof mouse-event%) -> void
      (define (split/collapse-text menu text event)
        (when (and (is-a? text -text<%>)
                   (not (send text is-frozen?))
                   (not (send text is-stopped?)))
          (let* ([on-it-box (box #f)]
                 [click-pos 
                  (call-with-values
                   (λ ()
                     (send text dc-location-to-editor-location
                           (send event get-x)
                           (send event get-y)))
                   (λ (x y)
                     (send text find-position x y #f on-it-box)))]
                 [snip (send text find-snip click-pos 'after)]
                 [char (send text get-character click-pos)]
                 [left? (memq char '(#\( #\{ #\[))]
                 [right? (memq char '(#\) #\} #\]))])
            (cond
              [(and snip (is-a? snip sexp-snip<%>))
               (make-expand-item text snip menu)]
              [(not (unbox on-it-box))
               ;; clicking in nowhere land, just ignore
               (void)]
              [(or left? right?)
               ;; clicking on left or right paren
               (let* ([pos (if left?
                               click-pos
                               (+ click-pos 1))]
                      [other-pos (if left?
                                     (send text get-forward-sexp pos)
                                     (send text get-backward-sexp pos))])
                 (when other-pos
                   (let ([left-pos (min pos other-pos)]
                         [right-pos (max pos other-pos)])
                     (make-collapse-item text left-pos right-pos menu))))]
              [else 
               ;; clicking on some other text -> collapse containing sexp
               (let ([up-sexp (send text find-up-sexp click-pos)])
                 (when up-sexp 
                   (let ([fwd (send text get-forward-sexp up-sexp)])
                     (make-collapse-item text up-sexp fwd menu))))]))))
      
      ;; make-expand-item : (instanceof text%) (instanceof sexp-snip<%>) (instanceof menu%) -> void
      (define (make-expand-item text snip menu)
        (instantiate separator-menu-item% ()
          (parent menu))
        (instantiate menu-item% ()
          (parent menu)
          (label (string-constant expand-sexp))
          (callback (λ (item evt) (expand-from text snip)))))
      
      ;; expand-from : (instanceof text%) (instanceof sexp-snip<%>) -> void
      (define (expand-from text snip)
        (let ([snips (send snip get-saved-snips)])
          (send text begin-edit-sequence)
          (let ([pos (send text get-snip-position snip)])
            (send text delete pos (+ pos 1))
            (let loop ([snips (reverse snips)])
              (cond
                [(null? snips) (void)]
                [else (send text insert (send (car snips) copy) pos pos)
                      (loop (cdr snips))])))
          (send text end-edit-sequence)))

      ;; make-collapse-item : (instanceof text%) number number (instanceof menu%) -> void
      ;; adds a collapse menu item to the menu
      (define (make-collapse-item text left-pos right-pos menu)
        (instantiate separator-menu-item% ()
          (parent menu))
        (instantiate menu-item% ()
          (parent menu)
          (label (string-constant collapse-sexp))
          (callback (λ (item evt)
                      (collapse-from text left-pos right-pos)))))
      
      (define (collapse-from text left-pos right-pos)
        (let ([left-bracket (send text get-character left-pos)]
              [right-bracket (send text get-character (- right-pos 1))])
          (send text begin-edit-sequence)
          (send text split-snip left-pos)
          (send text split-snip right-pos)
          (let ([snips (let loop ([snip (send text find-snip left-pos 'after)])
                         (cond
                           [(not snip) null]
                           [((send text get-snip-position snip) . >= . right-pos)
                            null]
                           [else (cons (send snip copy) (loop (send snip next)))]))])
            (send text delete left-pos right-pos)
            (send text insert (instantiate sexp-snip% () 
                                (left-bracket left-bracket)
                                (right-bracket right-bracket)
                                (saved-snips snips))
                  left-pos left-pos)
            (send text end-edit-sequence))))
      

                                                                             
              ;;                                                             
               ;                                   ;                    ;    
               ;                                   ;                    ;    
  ;;;    ;;;   ; ;;    ;;;  ;;; ;    ;;;          ;;;;;   ;;;  ;;; ;;; ;;;;; 
 ;   ;  ;   ;  ;;  ;  ;   ;  ; ; ;  ;   ;    ;     ;     ;   ;   ; ;    ;    
  ;;;   ;      ;   ;  ;;;;;  ; ; ;  ;;;;;          ;     ;;;;;    ;     ;    
     ;  ;      ;   ;  ;      ; ; ;  ;              ;     ;       ; ;    ;    
 ;   ;  ;   ;  ;   ;  ;   ;  ; ; ;  ;   ;          ;   ; ;   ;  ;   ;   ;   ;
  ;;;    ;;;  ;;; ;;;  ;;;  ;; ; ;;  ;;;     ;      ;;;   ;;;  ;;   ;;   ;;; 
                                                                             
 
      (define color-prefs-table
        (let ([constant-green (make-object color% 41 128 38)]
              [symbol-blue (make-object color% 38 38 128)])
        `((symbol ,symbol-blue ,(string-constant scheme-mode-color-symbol))
          (keyword ,symbol-blue ,(string-constant scheme-mode-color-keyword))
          (comment ,(make-object color% 194 116 31) ,(string-constant scheme-mode-color-comment))
          (string ,constant-green ,(string-constant scheme-mode-color-string))
          (constant ,constant-green ,(string-constant scheme-mode-color-constant))
          (parenthesis ,(make-object color% "brown") ,(string-constant scheme-mode-color-parenthesis))
          (error ,(make-object color% "red") ,(string-constant scheme-mode-color-error))
          (other ,(make-object color% "black") ,(string-constant scheme-mode-color-other)))))
      (define (get-color-prefs-table) color-prefs-table)
      
      (define (short-sym->pref-name sym) (string->symbol (short-sym->style-name sym)))
      (define sn-hash (make-hash-table))
      (define (short-sym->style-name sym)
	(hash-table-get sn-hash sym
			(λ ()
			  (let ([s (format "framework:syntax-coloring:scheme:~a" sym)])
			    (hash-table-put! sn-hash sym s)
			    s))))
      
      (define (add-coloring-preferences-panel)
        (color-prefs:add-to-preferences-panel
         "Scheme"
         (λ (parent)
           (for-each
            (λ (line)
              (let ([sym (car line)])
                (color-prefs:build-color-selection-panel 
                 parent
                 (short-sym->pref-name sym)
                 (short-sym->style-name sym)
                 (format "~a" sym))))
            color-prefs-table))))
      
      (define-struct string/pos (string pos))
      
      (define -text<%>
        (interface (text:basic<%> mode:host-text<%> color:text<%>)
          get-limit
          balance-parens
          tabify-on-return?
          tabify
          tabify-selection
          tabify-all
          insert-return
          box-comment-out-selection
          comment-out-selection
          uncomment-selection
          get-forward-sexp
          remove-sexp
          forward-sexp
          flash-forward-sexp
          get-backward-sexp
          flash-backward-sexp
          backward-sexp
          find-up-sexp
          up-sexp
          find-down-sexp
          down-sexp
          remove-parens-forward
          
          select-forward-sexp
          select-backward-sexp
          select-up-sexp
          select-down-sexp
          transpose-sexp
          mark-matching-parenthesis
          get-tab-size
          set-tab-size))
      
      (define init-wordbreak-map
        (λ (map)
          (let ([v (send map get-map #\-)])
            (send map set-map 
                  #\-
                  '(line)))))
      (define wordbreak-map (make-object editor-wordbreak-map%))
      (define (get-wordbreak-map) wordbreak-map)
      (init-wordbreak-map wordbreak-map)
      
      (define matching-parenthesis-style 
        (let ([matching-parenthesis-delta (make-object style-delta% 'change-bold)]
              [style-list (editor:get-standard-style-list)])
          (send matching-parenthesis-delta set-delta-foreground "forest green")
          (send style-list new-named-style "Matching Parenthesis Style"
                (send style-list find-or-create-style
                      (send style-list find-named-style "Standard")
                      matching-parenthesis-delta))
          (send style-list find-named-style "Matching Parenthesis Style")))

      (define text-mixin
        (mixin (text:basic<%> mode:host-text<%> color:text<%>) (-text<%>)
          (inherit begin-edit-sequence
                   delete
                   end-edit-sequence
                   local-edit-sequence?
                   find-string
                   get-character
                   get-keymap
                   get-text
                   get-start-position
                   get-style-list
                   get-end-position
                   flash-on
                   insert
                   kill
                   last-position
                   paragraph-start-position
                   paragraph-end-position
                   position-paragraph
                   set-keymap
                   set-load-overwrites-styles
                   set-position
                   set-wordbreak-map
                   set-tabs
                   set-style-list
                   set-styles-fixed
                   change-style
                   get-snip-position
                   backward-match
                   backward-containing-sexp
                   forward-match
                   skip-whitespace
                   insert-close-paren
		   classify-position)
          
          (inherit get-styles-fixed)
          (inherit has-focus? find-snip split-snip)
          
          (public get-limit balance-parens tabify-on-return? tabify tabify-selection
                  tabify-all insert-return calc-last-para 
                  box-comment-out-selection comment-out-selection uncomment-selection
                  get-forward-sexp remove-sexp forward-sexp flash-forward-sexp get-backward-sexp
                  flash-backward-sexp backward-sexp find-up-sexp up-sexp find-down-sexp down-sexp
                  remove-parens-forward)
          (define (get-limit pos) 0)
          
          (define (balance-parens key-event)
            (insert-close-paren (get-start-position) 
                                (send key-event get-key-code)
                                (preferences:get 'framework:paren-match)
                                (preferences:get 'framework:fixup-parens)))
          
          (define (tabify-on-return?) #t)
          (define tabify    
            (opt-lambda ([pos (get-start-position)])
              (let* ([last-pos (last-position)]
                     [para (position-paragraph pos)]
		     [is-tabbable? (and (> para 0)
					(not (memq (classify-position (sub1 (paragraph-start-position para)))
						   '(comment string error))))]
                     [okay (and is-tabbable? (> para 0))]
                     [end (if okay (paragraph-start-position para) 0)]
                     [limit (get-limit pos)]
		     ;; "contains" is the start of the initial sub-S-exp
		     ;;  in the S-exp that contains "pos". If pos is outside
		     ;;  all S-exps, this will be the start of the initial
		     ;;  S-exp
                     [contains 
                      (if okay
                          (backward-containing-sexp end limit)
                          #f)]
                     [contain-para (and contains
                                        (position-paragraph contains))]
		     ;; "last" is the start of the S-exp just before "pos"
                     [last 
                      (if contains
                          (backward-match end limit)
                          #f)]
                     [last-para (and last
                                     (position-paragraph last))])
                (letrec	
                    ([find-offset
                      (λ (pos)
                        (let loop ([p pos][o 0])
                          (let ([c (get-character p)])
                            (cond
                              [(char=? c #\tab)
                               (loop (add1 p) (+ o (- 8 (modulo o 8))))]
                              [(char=? c #\newline)
                               (cons o p)]
                              [(char-whitespace? c)
                               (loop (add1 p) (add1 o))]
                              [else
                               (cons o p)]))))]
                     [visual-offset
                      (λ (pos)
                        (let loop ([p (sub1 pos)])
                          (if (= p -1)
                              0
                              (let ([c (get-character p)])
                                (cond
                                  [(char=? c #\null) 0]
                                  [(char=? c #\tab)
                                   (let ([o (loop (sub1 p))])
                                     (+ o (- 8 (modulo o 8))))]
                                  [(char=? c #\newline) 0]
                                  [else (add1 (loop (sub1 p)))])))))]
                     [do-indent
                      (λ (amt)
                        (let* ([pos-start end]
                               [curr-offset (find-offset pos-start)])
                          (unless (= amt (car curr-offset))
                            (delete pos-start (cdr curr-offset))
                            (insert
                             (make-string amt #\space)
                             pos-start))))]
                     [get-proc
                      (λ ()
			(let ([id-end (forward-match contains (last-position))])
			  (if (and id-end (> id-end contains))
			      (let* ([text (get-text contains id-end)])
                                (or (get-keyword-type text)
                                    'other)))))]
                     [procedure-indent
                      (λ ()
                        (case (get-proc)
                          [(define) 1]
                          [(begin) 1]
                          [(lambda) 3]
                          [else 0]))]
                     [special-check
                      (λ ()
                        (let* ([proc-name (get-proc)])
                          (or (eq? proc-name 'define)
                              (eq? proc-name 'lambda))))]
                     [indent-first-arg
                      (λ (start)
                        (car (find-offset start)))])
                  (when (and okay
                             (not (char=? (get-character (sub1 end))
                                          #\newline)))
                    (insert #\newline (paragraph-start-position para)))
                  (cond
		    [(not is-tabbable?) (void)]
                    [(let ([real-start (cdr (find-offset end))]) 
                       (and (<= (+ 3 real-start) (last-position))
                            (string=? ";;;"
                                      (get-text real-start
                                                (+ 2 real-start)))))
                     (void)]
                    [(= para 0) (do-indent 0)]
                    [(not contains)
		     ;; Something went wrong matching. Should we get here?
                     (do-indent 0)]
                    [(not last) 
		     ;; We can't find a match backward from pos,
		     ;;  but we seem to be inside an S-exp, so 
		     ;;  go "up" an S-exp, and move forward past
		     ;;  the associated paren
                     (let ([enclosing (find-up-sexp pos)])
                       (do-indent (if enclosing
                                      (+ (visual-offset enclosing) 1)
                                      0)))]
                    [(= contains last)
		     ;; There's only one S-expr in the S-expr
		     ;;  containing "pos"
                     (do-indent (+ (visual-offset contains)
                                   (procedure-indent)))]
                    [(special-check)
		     ;; In case of "define", etc., ignore the position of last 
		     ;;  and just indent under the "define"
                     (do-indent (add1 (visual-offset contains)))]
                    [(= contain-para last-para)
		     ;; So far, the S-exp containing "pos" was all on
		     ;;  one line (possibly not counting the opening paren),
		     ;;  so indent to follow the first S-exp's end
                     (let ([name-length (let ([id-end (forward-match contains (last-position))])
					  (if id-end
					      (- id-end contains)
					      0))])
                       (do-indent (+ (visual-offset contains)
                                     name-length
                                     (indent-first-arg (+ contains 
                                                          name-length)))))]
                    [else
		     ;; No particular special case, so indent to match first 
		     ;; S-expr that start on the previous line
		     (let loop ([last last][last-para last-para])
		       (let* ([next-to-last (backward-match last limit)]
			      [next-to-last-para (and next-to-last
						      (position-paragraph next-to-last))])
			 (if (equal? last-para next-to-last-para)
			     (loop next-to-last next-to-last-para)
			     (do-indent (visual-offset last)))))])))))
          
          (define tabify-selection
            (opt-lambda ([start-pos (get-start-position)]
                         [end-pos (get-end-position)])
              (let ([first-para (position-paragraph start-pos)]
                    [end-para (position-paragraph end-pos)])
                (with-handlers ([exn:break?
                                 (λ (x) #t)])
                  (dynamic-wind
                   (λ () 
                     (when (< first-para end-para)
                       (begin-busy-cursor))
                     (begin-edit-sequence))
                   (λ ()
                     (let loop ([para first-para])
                       (when (<= para end-para)
                         (tabify (paragraph-start-position para))
			 (parameterize-break #t (void))
                         (loop (add1 para))))
                     (when (and (>= (position-paragraph start-pos) end-para)
                                (<= (skip-whitespace (get-start-position) 'backward #f)
                                    (paragraph-start-position first-para)))
                       (set-position 
                        (let loop ([new-pos (get-start-position)])
                          (if (let ([next (get-character new-pos)])
                                (and (char-whitespace? next)
                                     (not (char=? next #\newline))))
                              (loop (add1 new-pos))
                              new-pos)))))
                   (λ ()
                     (end-edit-sequence)
                     (when (< first-para end-para)
                       (end-busy-cursor))))))))
          
          (define (tabify-all) (tabify-selection 0 (last-position)))
          (define (insert-return)
            (if (tabify-on-return?)
                (begin 
                  (begin-edit-sequence)
                  (insert #\newline)
                  (tabify (get-start-position))
                  (set-position 
                   (let loop ([new-pos (get-start-position)])
                     (if (let ([next (get-character new-pos)])
                           (and (char-whitespace? next)
                                (not (char=? next #\newline))))
                         (loop (add1 new-pos))
                         new-pos)))
                  (end-edit-sequence))
                (insert #\newline)))
          
          (define (calc-last-para last-pos)
            (let ([last-para (position-paragraph last-pos #t)])
              (if (and (> last-pos 0)
                       (> last-para 0))
                  (begin (split-snip last-pos)
                         (let ([snip (find-snip last-pos 'before)])
                           (if (member 'hard-newline (send snip get-flags))
                               (- last-para 1)
                               last-para)))
                  last-para)))
          
          (define comment-out-selection 
            (opt-lambda ([start-pos (get-start-position)] 
                         [end-pos (get-end-position)]) 
              (begin-edit-sequence) 
              (let ([first-pos-is-first-para-pos? 
                     (= (paragraph-start-position (position-paragraph start-pos)) 
                        start-pos)]) 
                (let* ([first-para (position-paragraph start-pos)] 
                       [last-para (calc-last-para end-pos)]) 
                  (let para-loop ([curr-para first-para]) 
                    (if (<= curr-para last-para) 
                        (let ([first-on-para (paragraph-start-position curr-para)]) 
                          (insert #\; first-on-para) 
                          (para-loop (add1 curr-para)))))) 
                (when first-pos-is-first-para-pos? 
                  (set-position 
                   (paragraph-start-position (position-paragraph (get-start-position))) 
                   (get-end-position)))) 
              (end-edit-sequence) 
              #t)) 
          
          (define box-comment-out-selection
            (opt-lambda ([_start-pos 'start]
                         [_end-pos 'end])
	      (let ([start-pos (if (eq? _start-pos 'start)
				   (get-start-position)
				   _start-pos)]
		    [end-pos (if (eq? _end-pos 'end)
				 (get-end-position)
				 _end-pos)])
		(begin-edit-sequence)
		(split-snip start-pos)
		(split-snip end-pos)
		(let* ([cb (instantiate comment-box:snip% ())]
		       [text (send cb get-editor)])
		  (let loop ([snip (find-snip start-pos 'after-or-none)])
		    (cond
		      [(not snip) (void)]
		      [((get-snip-position snip) . >= . end-pos) (void)]
		      [else
		       (send text insert (send snip copy)
			     (send text last-position)
			     (send text last-position))
		       (loop (send snip next))]))
		  (delete start-pos end-pos)
		  (insert cb start-pos)
		  (set-position start-pos start-pos))
		(end-edit-sequence)
		#t)))
          
          ;; uncomment-box/selection : -> void
          ;; uncomments a comment box, if the focus is inside one.
          ;; otherwise, calls uncomment selection to uncomment
          ;; something else.
          (inherit get-focus-snip)
          (define/public (uncomment-box/selection)
            (begin-edit-sequence)
            (let ([focus-snip (get-focus-snip)])
              (cond
                [(not focus-snip) (uncomment-selection)]
                [(is-a? focus-snip comment-box:snip%) 
                 (extract-contents 
                  (get-snip-position focus-snip)
                  focus-snip)]
                [else (uncomment-selection)]))
            (end-edit-sequence)
            #t)
          
          (define uncomment-selection
            (opt-lambda ([start-pos (get-start-position)]
                         [end-pos (get-end-position)])
              (let ([snip-before (find-snip start-pos 'before-or-none)]
                    [snip-after (find-snip start-pos 'after-or-none)])
                
                (begin-edit-sequence)
                (cond
                  [(and (= start-pos end-pos)
                        snip-before
                        (is-a? snip-before comment-box:snip%))
                   (extract-contents start-pos snip-before)]
                  [(and (= start-pos end-pos)
                        snip-after
                        (is-a? snip-after comment-box:snip%))
                   (extract-contents start-pos snip-after)]
                  [(and (= (+ start-pos 1) end-pos)
                        snip-after
                        (is-a? snip-after comment-box:snip%))
                   (extract-contents start-pos snip-after)]
                  [else
                   (let* ([last-pos (last-position)]
                          [first-para (position-paragraph start-pos)]
                          [last-para (calc-last-para end-pos)])
                     (let para-loop ([curr-para first-para])
                       (when (<= curr-para last-para)
                         (let ([first-on-para
                                (skip-whitespace  (paragraph-start-position curr-para)
                                                  'forward
                                                  #f)])
                           (split-snip first-on-para)
                           (when (and (< first-on-para last-pos)
                                      (char=? #\; (get-character first-on-para))
                                      (is-a? (find-snip first-on-para 'after-or-none) string-snip%))
                             (delete first-on-para (+ first-on-para 1)))
                           (para-loop (add1 curr-para))))))])
                (end-edit-sequence))
              #t))
          
          ;; extract-contents : number (is-a?/c comment-box:snip%) -> void
          ;; copies the contents of the comment-box-snip out of the snip
          ;; and into this editor as `pos'. Deletes the comment box snip
          (define/private (extract-contents pos snip)
            (let ([editor (send snip get-editor)])
              (let loop ([snip (send editor find-snip (send editor last-position) 'before-or-none)])
                (cond
                  [snip
                   (insert (send snip copy) pos)
                   (loop (send snip previous))]
                  [else (void)]))
              (let ([snip-pos (get-snip-position snip)])
                (delete snip-pos (+ snip-pos 1)))
              (set-position pos pos)))
          
          [define get-forward-sexp
            (λ (start-pos)
              (forward-match start-pos (last-position)))]
          [define remove-sexp
            (λ (start-pos)
              (let ([end-pos (get-forward-sexp start-pos)])
                (if end-pos 
                    (kill 0 start-pos end-pos)
                    (bell)))
              #t)]
          [define forward-sexp
            (λ (start-pos)
              (let ([end-pos (get-forward-sexp start-pos)])
                (if end-pos 
                    (set-position end-pos)
                    (bell))
                #t))]
          [define flash-forward-sexp
            (λ (start-pos)
              (let ([end-pos (get-forward-sexp start-pos)])
                (if end-pos 
                    (flash-on end-pos (add1 end-pos))
                    (bell)) 
                #t))]	    
          [define get-backward-sexp
            (λ (start-pos)
              (let* ([limit (get-limit start-pos)]
                     [end-pos
                      (backward-match start-pos limit)]
                     [min-pos
                      (backward-containing-sexp start-pos limit)]
                     [ans
                      (if (and end-pos 
                               (or (not min-pos)
                                   (>= end-pos min-pos)))
                          end-pos
                          #f)])
                ans))]
          [define flash-backward-sexp
            (λ (start-pos)
              (let ([end-pos (get-backward-sexp start-pos)])
                (if end-pos
                    (flash-on end-pos (add1 end-pos))
                    (bell))
                #t))]
          [define backward-sexp
            (λ (start-pos)
              (let ([end-pos (get-backward-sexp start-pos)])
                (if end-pos
                    (set-position end-pos)
                    (bell))
                #t))]
          [define find-up-sexp
            (λ (start-pos)
              (let* ([limit-pos (get-limit start-pos)]
		     [exp-pos
                      (backward-containing-sexp start-pos limit-pos)])
                
                (if (and exp-pos (> exp-pos limit-pos))
		    (let* ([in-start-pos (skip-whitespace exp-pos 'backward #t)]
			   [paren-pos
			    (λ (paren-pair)
			      (find-string
			       (car paren-pair)
			       'backward
			       in-start-pos
			       limit-pos))])
		      (let ([poss (let loop ([parens (scheme-paren:get-paren-pairs)])
				    (cond
				     [(null? parens) null]
				     [else 
				      (let ([pos (paren-pos (car parens))])
					(if pos
					    (cons pos (loop (cdr parens)))
					    (loop (cdr parens))))]))])
			(if (null? poss) ;; all finds failed
			    #f
			    (- (apply max poss) 1)))) ;; subtract one to move outside the paren
                    #f)))]
          [define up-sexp
            (λ (start-pos)
              (let ([exp-pos (find-up-sexp start-pos)])
                (if exp-pos
                    (set-position exp-pos)
                    (bell))
                #t))]
          [define find-down-sexp
            (λ (start-pos)
              (let ([last (last-position)])
                (let loop ([pos start-pos])
                  (let ([next-pos (forward-match pos last)])
                    (if (and next-pos (> next-pos pos))
                        (let ([back-pos
                               (backward-containing-sexp (sub1 next-pos) pos)])
                          (if (and back-pos
                                   (> back-pos pos))
                              back-pos
                              (loop next-pos)))
                        #f)))))]
          [define down-sexp
            (λ (start-pos)
              (let ([pos (find-down-sexp start-pos)])
                (if pos
                    (set-position pos)
                    (bell))
                #t))]
          [define remove-parens-forward
            (λ (start-pos)
              (let* ([pos (skip-whitespace start-pos 'forward #f)]
                     [first-char (get-character pos)]
                     [paren? (or (char=? first-char #\( )
                                 (char=? first-char #\[ ))]
                     [closer (if paren? 
                                 (forward-match pos (last-position)))])
                (if (and paren? closer)
                    (begin (begin-edit-sequence)
                           (delete pos (add1 pos))
                           (delete (-  closer 2) (- closer 1))
                           (end-edit-sequence))
                    (bell))
                #t))]
          
          (define/private (select-text f forward?)
            (let* ([start-pos (get-start-position)]
                   [end-pos (get-end-position)])
              (let-values ([(new-start new-end)
                            (if forward?
                                (values start-pos (f end-pos))
                                (values (f start-pos) end-pos))])
                (if (and new-start new-end) 
                    (set-position new-start new-end)
                    (bell))
                #t)))
          (public select-forward-sexp select-backward-sexp select-up-sexp select-down-sexp
                  transpose-sexp mark-matching-parenthesis)
          
          [define select-forward-sexp (λ () (select-text (λ (x) (get-forward-sexp x)) #t))]
          [define select-backward-sexp (λ () (select-text (λ (x) (get-backward-sexp x)) #f))]
          [define select-up-sexp (λ () (select-text (λ (x) (find-up-sexp x)) #f))]
          [define select-down-sexp (λ () (select-text (λ (x) (find-down-sexp x)) #t))]
          
	  (inherit get-fixed-style)
          (define (mark-matching-parenthesis pos)
            (let ([open-parens (map car (scheme-paren:get-paren-pairs))]
                  [close-parens (map cdr (scheme-paren:get-paren-pairs))])
              (when (member (string (get-character pos)) open-parens)
                (let ([end (get-forward-sexp pos)])
                  (when (and end
                             (member (string (get-character (- end 1))) close-parens))
                    (let ([start-style (send (find-snip pos 'after) get-style)]
                          [end-style (send (find-snip end 'before) get-style)])
                      (cond
                        [(and (eq? matching-parenthesis-style start-style)
                              (eq? matching-parenthesis-style end-style))
                         (let ([fixed-style (get-fixed-style)])
                           (change-style fixed-style pos (+ pos 1))
                           (change-style fixed-style (- end 1) end))]
                        [else
                         (change-style matching-parenthesis-style pos (+ pos 1))
                         (change-style matching-parenthesis-style (- end 1) end)])))))))
          
          [define transpose-sexp
            (λ (pos)
              (let ([start-1 (get-backward-sexp pos)])
                (if (not start-1)
                    (bell)
                    (let ([end-1 (get-forward-sexp start-1)])
                      (if (not end-1)
                          (bell)
                          (let ([end-2 (get-forward-sexp end-1)])
                            (if (not end-2)
                                (bell)
                                (let ([start-2 (get-backward-sexp end-2)])
                                  (if (or (not start-2)
                                          (< start-2 end-1))
                                      (bell)
                                      (let ([text-1 
                                             (get-text start-1 end-1)]
                                            [text-2 
                                             (get-text start-2 end-2)])
                                        (begin-edit-sequence)
                                        (insert text-1 start-2 end-2)
                                        (insert text-2 start-1 end-1)
                                        (set-position end-2)
                                        (end-edit-sequence)))))))))))]
          [define tab-size 8]
          (public get-tab-size set-tab-size)
          [define get-tab-size (λ () tab-size)]
          [define set-tab-size (λ (s) (set! tab-size s))]
                    
          (super-instantiate ())))

      (define -text-mode<%>
        (interface ()
          ))
      
      (define text-mode-mixin
        (mixin (color:text-mode<%> mode:surrogate-text<%>) (-text-mode<%>)

          (define/override (on-disable-surrogate text)
            (keymap:remove-chained-keymap text keymap)
            (super on-disable-surrogate text))
          
          (define/override (on-enable-surrogate text)
	    (send text begin-edit-sequence)
	    (super on-enable-surrogate text)
	    (send (send text get-keymap) chain-to-keymap keymap #t)
            
            ;; I don't know about these editor flag settings.
            ;; maybe they belong in drscheme?
            (send text set-load-overwrites-styles #f)
            (send text set-wordbreak-map wordbreak-map)
	    (let ([bw (box 0)]
		  [bu (box #f)]
		  [tab-size (send text get-tab-size)])
	      (unless (and (null? (send text get-tabs #f bw bu))
			   (= tab-size (unbox bw))
			   (not (unbox bu)))
                	(send text set-tabs null (send text get-tab-size) #f)))
            (send text set-styles-fixed #t)
	    (send text end-edit-sequence))
          
          (super-new (get-token scheme-lexer-wrapper)
                     (token-sym->style short-sym->style-name)
                     (matches '((|(| |)|)
                                (|[| |]|)
                                (|{| |}|))))))
      
      (define (scheme-lexer-wrapper in)
        (let-values (((lexeme type paren start end) (scheme-lexer in)))
          (cond
            ((and (eq? type 'symbol)
                  (get-keyword-type lexeme))
             (values lexeme 'keyword paren start end))
            (else
             (values lexeme type paren start end)))))
      
      ;; get-keyword-type : string -> (union #f 'lambda 'define 'begin)
      (define (get-keyword-type text)
        (let* ([pref (preferences:get 'framework:tabify)]
               [ht (car pref)]
               [beg-reg (cadr pref)]
               [def-reg (caddr pref)]
               [lam-reg (cadddr pref)])
          (hash-table-get 
           ht
           (string->symbol text)
           (λ () 
             (cond
               [(and beg-reg (regexp-match beg-reg text)) 'begin]
               [(and def-reg (regexp-match def-reg text)) 'define]
               [(and lam-reg (regexp-match lam-reg text)) 'lambda]
               [else #f])))))
      
      (define set-mode-mixin
        (mixin (-text<%> mode:host-text<%>) ()
	  (super-new)
	  (inherit set-surrogate)
	  (set-surrogate (new text-mode%))))

      (define -text% (set-mode-mixin
		      (text-mixin
		       (mode:host-text-mixin
			color:text%))))

      (define text-mode% (text-mode-mixin color:text-mode%))
    
                                                                                           
              ;;                                 ;;                                        
               ;                                  ;                                        
               ;                                  ;                                        
  ;;;    ;;;   ; ;;    ;;;  ;;; ;    ;;;          ;  ;;   ;;;  ;;; ;;;;;; ;   ;;;;  ; ;;;  
 ;   ;  ;   ;  ;;  ;  ;   ;  ; ; ;  ;   ;         ; ;    ;   ;  ;   ;  ; ; ;      ;  ;   ; 
  ;;;   ;      ;   ;  ;;;;;  ; ; ;  ;;;;;         ;;     ;;;;;  ;   ;  ; ; ;   ;;;;  ;   ; 
     ;  ;      ;   ;  ;      ; ; ;  ;             ; ;    ;       ; ;   ; ; ;  ;   ;  ;   ; 
 ;   ;  ;   ;  ;   ;  ;   ;  ; ; ;  ;   ;         ;  ;   ;   ;   ;;;   ; ; ;  ;   ;  ;   ; 
  ;;;    ;;;  ;;; ;;;  ;;;  ;; ; ;;  ;;;         ;;   ;;  ;;;     ;   ;; ; ;;  ;;; ; ;;;;  
                                                                  ;                  ;     
                                                                  ;                  ;     
                                                                ;;                  ;;;    
      (define setup-keymap
        (λ (keymap)
          
          (let ([add-pos-function
                 (λ (name call-method)
                   (send keymap add-function name
                         (λ (edit event)
                           (call-method
                            edit
                            (send edit get-start-position)))))])
            (add-pos-function "remove-sexp" (λ (e p) (send e remove-sexp p)))
            (add-pos-function "forward-sexp" (λ (e p) (send e forward-sexp p)))
            (add-pos-function "backward-sexp" (λ (e p) (send e backward-sexp p)))
            (add-pos-function "up-sexp" (λ (e p) (send e up-sexp p)))
            (add-pos-function "down-sexp" (λ (e p) (send e down-sexp p)))
            (add-pos-function "flash-backward-sexp" (λ (e p) (send e flash-backward-sexp p)))
            (add-pos-function "flash-forward-sexp" (λ (e p) (send e flash-forward-sexp p)))
            (add-pos-function "remove-parens-forward" (λ (e p) (send e remove-parens-forward p)))
            (add-pos-function "transpose-sexp" (λ (e p) (send e transpose-sexp p)))
            (add-pos-function "mark-matching-parenthesis"
                              (λ (e p) (send e mark-matching-parenthesis p))))
          
          (let ([add-edit-function
                 (λ (name call-method)
                   (send keymap add-function name
                         (λ (edit event)
                           (call-method edit))))])
            (add-edit-function "select-forward-sexp" 
                               (λ (x) (send x select-forward-sexp)))
            (add-edit-function "select-backward-sexp"  
                               (λ (x) (send x select-backward-sexp)))
            (add-edit-function "select-down-sexp"  
                               (λ (x) (send x select-down-sexp)))
            (add-edit-function "select-up-sexp"  
                               (λ (x) (send x select-up-sexp)))
            (add-edit-function "tabify-at-caret"  
                               (λ (x) (send x tabify-selection)))
            (add-edit-function "do-return"  
                               (λ (x) 
                                 (send x insert-return)))
            (add-edit-function "comment-out"  
                               (λ (x) (send x comment-out-selection)))
            (add-edit-function "box-comment-out"  
                               (λ (x) (send x box-comment-out-selection)))
            (add-edit-function "uncomment"  
                               (λ (x) (send x uncomment-selection))))
          
          (send keymap add-function "balance-parens"
                (λ (edit event)
                  (send edit balance-parens event)))
          
          (send keymap map-function "TAB" "tabify-at-caret")
          
          (send keymap map-function "return" "do-return")
          (send keymap map-function "s:return" "do-return")
          (send keymap map-function "s:c:return" "do-return")
          (send keymap map-function "a:return" "do-return")
          (send keymap map-function "s:a:return" "do-return")
          (send keymap map-function "c:a:return" "do-return")
          (send keymap map-function "c:s:a:return" "do-return")
          (send keymap map-function "c:return" "do-return")
          (send keymap map-function "d:return" "do-return")
          
          (send keymap map-function ")" "balance-parens")
          (send keymap map-function "]" "balance-parens")
          (send keymap map-function "}" "balance-parens")
          
          (let ([map-meta
                 (λ (key func)
                   (keymap:send-map-function-meta keymap key func))]
                [map
                 (λ (key func)
                   (send keymap map-function key func))])
            
            (map-meta "up" "up-sexp")
            (map-meta "c:u" "up-sexp")
            (map "a:up" "up-sexp")
            (map-meta "s:up" "select-up-sexp")
            (map "a:s:up" "select-up-sexp")
            (map-meta "s:c:u" "select-up-sexp")
            
            (map-meta "down" "down-sexp")
            (map "a:down" "down-sexp")
            (map-meta "s:down" "select-down-sexp")
            (map "a:s:down" "select-down-sexp")
            (map-meta "s:c:down" "select-down-sexp")
            
            (map-meta "right" "forward-sexp")
            (map "a:right" "forward-sexp")
            (map-meta "s:right" "select-forward-sexp")
            (map "a:s:right" "select-forward-sexp")
            
            (map-meta "left" "backward-sexp")
            (map "a:left" "backward-sexp")
            (map-meta "s:left" "select-backward-sexp")
            (map "a:s:left" "select-backward-sexp")
            
            (map-meta "return" "do-return")
            (map-meta "s:return" "do-return")
            (map-meta "s:c:return" "do-return")
            (map-meta "a:return" "do-return")
            (map-meta "s:a:return" "do-return")
            (map-meta "c:a:return" "do-return")
            (map-meta "c:s:a:return" "do-return")
            (map-meta "c:return" "do-return")
            
            (map-meta "c:semicolon" "comment-out")
            (map-meta "c:=" "uncomment")
            (map-meta "c:k" "remove-sexp")
            
            (map-meta "c:f" "forward-sexp")
            (map-meta "s:c:f" "select-forward-sexp")
            
            (map-meta "c:b" "backward-sexp")
            (map-meta "s:c:b" "select-backward-sexp")
            
            (map-meta "c:p" "flash-backward-sexp")
            (map-meta "s:c:n" "flash-forward-sexp")
            
            (map-meta "c:space" "select-forward-sexp")
            (map-meta "c:t" "transpose-sexp")
            
            ;(map-meta "c:m" "mark-matching-parenthesis")
            ; this keybinding doesn't interact with the paren colorer
            )
          (send keymap map-function "c:c;c:b" "remove-parens-forward")))
      
      (define keymap (make-object keymap:aug-keymap%))
      (setup-keymap keymap)
      (define (get-keymap) keymap)
      
                                                                             
                        ;;;                                            ;;;   
                       ;                                                 ;   
                       ;                                                 ;   
; ;;;   ; ;;;   ;;;   ;;;;;   ;;;         ; ;;;   ;;;;  ; ;;;    ;;;     ;   
 ;   ;   ;     ;   ;   ;     ;   ;         ;   ;      ;  ;;  ;  ;   ;    ;   
 ;   ;   ;     ;;;;;   ;      ;;;          ;   ;   ;;;;  ;   ;  ;;;;;    ;   
 ;   ;   ;     ;       ;         ;         ;   ;  ;   ;  ;   ;  ;        ;   
 ;   ;   ;     ;   ;   ;     ;   ;         ;   ;  ;   ;  ;   ;  ;   ;    ;   
 ;;;;   ;;;;    ;;;   ;;;;    ;;;          ;;;;    ;;; ;;;;  ;;  ;;;   ;;;;;;
 ;                                         ;                                 
 ;                                         ;                                 
;;;                                       ;;;                                

      
      (define (add-preferences-panel)
        (preferences:add-panel
         (list (string-constant editor-prefs-panel-label) 
               (string-constant indenting-prefs-panel-label))
         (λ (p)
           (define get-keywords
             (λ (hash-table)
               (letrec ([all-keywords (hash-table-map hash-table list)]
                        [pick-out (λ (wanted in out)
                                    (cond
                                      [(null? in) (quicksort out string<=?)]
                                      [else (if (eq? wanted (cadr (car in))) 
                                                (pick-out wanted (cdr in) (cons (symbol->string (car (car in))) out))
                                                (pick-out wanted (cdr in) out))]))])
                 (values  (pick-out 'begin all-keywords null)
                          (pick-out 'define all-keywords null)
                          (pick-out 'lambda all-keywords null)))))
           (define-values (begin-keywords define-keywords lambda-keywords)
             (get-keywords (car (preferences:get 'framework:tabify))))
           (define add-button-callback
             (λ (keyword-type keyword-symbol list-box)
               (λ (button command)
                 (let ([new-one
                        (keymap:call/text-keymap-initializer
                         (λ ()
                           (get-text-from-user
                            (format (string-constant enter-new-keyword) keyword-type)
                            (format (string-constant x-keyword) keyword-type))))])
                   (when new-one
                     (let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f)))
                                     (read (open-input-string new-one)))])
                       (cond
                         [(and (symbol? parsed)
                               (hash-table-get (car (preferences:get 'framework:tabify))
                                               parsed
                                               (λ () #f)))
                          (message-box (string-constant error)
                                       (format (string-constant already-used-keyword) parsed))]
                         [(symbol? parsed)
                          (let ([ht (car (preferences:get 'framework:tabify))])
                            (hash-table-put! ht parsed keyword-symbol)
                            (update-list-boxes ht))]
                         [else (message-box 
                                (string-constant error)
                                (format (string-constant expected-a-symbol) new-one))])))))))
           (define delete-callback
             (λ (list-box)
               (λ (button command)
                 (let* ([selections (send list-box get-selections)]
                        [symbols (map (λ (x) (string->symbol (send list-box get-string x))) selections)])
                   (for-each (λ (x) (send list-box delete x)) (reverse selections))
                   (let ([ht (car (preferences:get 'framework:tabify))])
                     (for-each (λ (x) (hash-table-remove! ht x)) symbols))))))
           (define main-panel (make-object horizontal-panel% p))
           (define make-column
             (λ (string symbol keywords bang-regexp)
               (let* ([vert (make-object vertical-panel% main-panel)]
                      [_ (make-object message% (format (string-constant x-like-keywords) string) vert)]
                      [box (make-object list-box% #f keywords vert void '(multiple))]
                      [button-panel (make-object horizontal-panel% vert)]
                      [text (new text-field% 
                                 (label (string-constant indenting-prefs-extra-regexp))
                                 (callback (λ (tf evt) 
                                             (let ([str (send tf get-value)])
                                               (cond
                                                 [(equal? str "") 
                                                  (bang-regexp #f)]
                                                 [else
                                                  (with-handlers ([exn:fail?
                                                                   (λ (x)
                                                                     (color-yellow (send tf get-editor)))])
                                                    (bang-regexp (regexp str))
                                                    (clear-color (send tf get-editor)))]))))
                                 (parent vert))]
                      [add-button (make-object button% (string-constant add-keyword)
                                    button-panel (add-button-callback string symbol box))]
                      [delete-button (make-object button% (string-constant remove-keyword)
                                       button-panel (delete-callback box))])
                 (send* button-panel 
                   (set-alignment 'center 'center)
                   (stretchable-height #f))
                 (send add-button min-width (send delete-button get-width))
                 (values box text))))
           (define (color-yellow text)
             (let ([sd (make-object style-delta%)])
               (send sd set-delta-background "yellow")
               (send text change-style sd 0 (send text last-position))))
           (define (clear-color text)
             (let ([sd (make-object style-delta%)])
               (send sd set-delta-background "white")
               (send text change-style sd 0 (send text last-position))))
           (define-values (begin-list-box begin-regexp-text) 
             (make-column "Begin"
                          'begin
                          begin-keywords
                          (λ (x) (set-car! (cdr (preferences:get 'framework:tabify)) x))))
           (define-values (define-list-box define-regexp-text) 
             (make-column "Define" 
                          'define 
                          define-keywords
                          (λ (x) (set-car! (cddr (preferences:get 'framework:tabify)) x))))
           (define-values (lambda-list-box lambda-regexp-text)
             (make-column "Lambda"
                          'lambda
                          lambda-keywords
                          (λ (x) (set-car! (cdddr (preferences:get 'framework:tabify)) x))))
           (define update-list-boxes
             (λ (hash-table)
               (let-values ([(begin-keywords define-keywords lambda-keywords) (get-keywords hash-table)]
                            [(reset) (λ (list-box keywords)
                                       (send list-box clear)
                                       (for-each (λ (x) (send list-box append x)) keywords))])
                 (reset begin-list-box begin-keywords)
                 (reset define-list-box define-keywords)
                 (reset lambda-list-box lambda-keywords)
                 #t)))
           (define update-gui
             (λ (pref)
               (update-list-boxes (car pref))
               (send begin-regexp-text set-value (or (object-name (cadr pref)) ""))
               (send define-regexp-text set-value (or (object-name (caddr pref)) ""))
               (send lambda-regexp-text set-value (or (object-name (cadddr pref)) ""))))
           (preferences:add-callback 'framework:tabify (λ (p v) (update-gui v)))
           main-panel))))))
