frame.rkt

#lang racket/unit

(require string-constants
         racket/class
         racket/contract/base
         racket/path
         "search.rkt"
         "sig.rkt"
         "../preferences.rkt"
         "../gui-utils.rkt"
         "gen-standard-menus.rkt"
         "interfaces.rkt"
         "srcloc-panel.rkt"
         framework/private/focus-table
         mrlib/close-icon
         mred/mred-sig)

(import mred^
        [prefix group: framework:group^]
        [prefix preferences: framework:preferences^]
        [prefix icon: framework:icon^]
        [prefix handler: framework:handler^]
        [prefix application: framework:application^]
        [prefix panel: framework:panel^]
        [prefix finder: framework:finder^]
        [prefix keymap: framework:keymap^]
        [prefix text: framework:text^]
        [prefix pasteboard: framework:pasteboard^]
        [prefix editor: framework:editor^]
        [prefix canvas: framework:canvas^]
        [prefix menu: framework:menu^]
        [prefix racket: framework:racket^]
        [prefix exit: framework:exit^]
        [prefix comment-box: framework:comment-box^]
        [prefix color-prefs: framework:color-prefs^])

(export (rename framework:frame^ 
                [-editor<%> editor<%>]
                [-pasteboard% pasteboard%]
                [-text% text%]))

(init-depend mred^ framework:text^ framework:canvas^)

(define (reorder-menus frame)
  (define items (send (send frame get-menu-bar) get-items))
  (define (find-menu name)
    (ormap (λ (i) (and (string=? (send i get-plain-label) name) i))
           items))
  (let* ([file-menu (find-menu (string-constant file-menu))]
         [edit-menu (find-menu (string-constant edit-menu))]
         [windows-menu (or (find-menu (string-constant windows-menu))
                           (find-menu (string-constant tabs-menu)))]
         [help-menu (find-menu (string-constant help-menu))]
         [other-items
          (remq* (list file-menu edit-menu windows-menu help-menu) items)]
         [re-ordered (filter values `(,file-menu ,edit-menu
                                                 ,@other-items
                                                 ,windows-menu ,help-menu))])
    (for-each (λ (item) (send item delete)) items)
    (for-each (λ (item) (send item restore)) re-ordered)))

(define (remove-empty-menus frame)
  (define menus (send (send frame get-menu-bar) get-items))
  (for-each (λ (menu) (send menu delete)) menus)
  (for-each (λ (menu)
              (when (pair? (send menu get-items)) (send menu restore)))
            menus))

(define add-snip-menu-items
  (lambda (edit-menu c% [func void])
    (let* ([get-edit-target-object
            (λ ()
              (let ([menu-bar
                     (let loop ([p (send edit-menu get-parent)])
                       (cond
                         [(is-a? p menu-bar%)
                          p]
                         [(is-a? p menu%)
                          (loop (send p get-parent))]
                         [else #f]))])
                (and menu-bar
                     (let ([frame (send menu-bar get-frame)])
                       (send frame get-edit-target-object)))))]
           [edit-menu:do 
            (λ (const)
              (λ (menu evt)
                (let ([edit (get-edit-target-object)])
                  (when (and edit
                             (is-a? edit editor<%>))
                    (send edit do-edit-operation const)))
                #t))]
           [on-demand
            (λ (menu-item)
              (let ([edit (get-edit-target-object)])
                (send menu-item enable (and edit (is-a? edit editor<%>)))))]
           [insert-comment-box
            (λ ()
              (let ([text (get-edit-target-object)])
                (when text
                  (let ([snip (make-object comment-box:snip%)])
                    (send text insert snip)
                    (send text set-caret-owner snip 'global)))))])
      
      (let ([item
             (new c%
                  [label (string-constant insert-comment-box-menu-item-label)]
                  [parent edit-menu]
                  [callback (λ (x y) (insert-comment-box))]
                  [demand-callback on-demand])])
        (func item))
      (define plain-insert-callback (edit-menu:do 'insert-image))
      (define lowercase-imgs "*.png;*.jpg;*.jpeg;*.gif;*.xpm;*.bmp")
      (define imgs (string-append
                    lowercase-imgs ";"
                    (string-upcase lowercase-imgs)))
      (let ([item 
             (new c% 
                  [label (string-constant insert-image-item)]
                  [parent edit-menu]
                  [callback (λ (menu evt)
                              (parameterize ([finder:default-filters 
                                              `(["Image" ,imgs]
                                                ["Any" "*.*"])])
                                (plain-insert-callback menu evt)))]
                  [demand-callback on-demand])])
        (func item))
      (void))))

(define frame-width 600)
(define frame-height 650)
(let ([window-trimming-upper-bound-width 20]
      [window-trimming-upper-bound-height 50])
  (let-values ([(w h) (get-display-size)])
    (set! frame-width (min frame-width (- w window-trimming-upper-bound-width)))
    (set! frame-height (min frame-height (- h window-trimming-upper-bound-height)))))

(define basic<%> frame:basic<%>)

(define focus-table<%> (interface (top-level-window<%>)))
(define focus-table-mixin
  (mixin (top-level-window<%>) (focus-table<%>)
    (inherit get-eventspace)
    
    (define/override (show on?)
      (define old (remove this (frame:lookup-focus-table (get-eventspace))))
      (define new (if on? (cons this old) old))
      (frame:set-focus-table (get-eventspace) new)
      (super show on?))
    
    (define/augment (on-close)
      (frame:set-focus-table (get-eventspace) (remove this (frame:lookup-focus-table (get-eventspace))))
      (inner (void) on-close))
    
    (super-new)
    
    (frame:set-focus-table (get-eventspace) (frame:lookup-focus-table (get-eventspace)))))

(define basic-mixin
  (mixin ((class->interface frame%)) (basic<%>)
    
    (define/override (show on?)
      (if on?
          (send (group:get-the-frame-group) insert-frame this)
          (send (group:get-the-frame-group) remove-frame this))
      (super show on?))
    
    (define/override (can-exit?)
      (and (exit:user-oks-exit)
           (begin
             (exit:set-exiting #t)
             (let ([res (exit:can-exit?)])
               (unless res
                 (exit:set-exiting #f))
               res))))
    (define/override (on-exit) 
      (exit:on-exit)
      (queue-callback
       (λ ()
         (exit)
         (exit:set-exiting #f))))
    
    (define/public (make-visible filename) (void))
    (define/public get-filename
      (case-lambda
        [() (get-filename #f)]
        [(b) #f]))
    
    (define/public (editing-this-file? filename) #f)
    
    (define/override (on-superwindow-show shown?)
      (send (group:get-the-frame-group) frame-shown/hidden this)
      (super on-superwindow-show shown?))
    
    (define after-init? #f)
    
    (define/override on-drop-file
      (λ (filename)
        (handler:edit-file filename)))
    
    ;; added call to set label here to hopefully work around a problem in mac mred
    (inherit set-label change-children)
    (define/override after-new-child
      (λ (child)
        (when after-init?
          (change-children (λ (l) (remq child l)))
          (error 'frame:basic-mixin
                 (string-append
                  "do not add children directly to a frame:basic (unless using make-root-area-container); "
                  "use the get-area-container method instead")))))
    
    (define/public get-area-container% (λ () vertical-panel%))
    (define/public get-menu-bar% (λ () menu-bar%))
    (define/public make-root-area-container
      (λ (% parent)
        (make-object % parent)))
    
    (inherit on-close can-close?)
    (define/public (close)
      (when (can-close?)
        (on-close)
        (show #f)))
    
    (inherit accept-drop-files)
    
    (super-new)
    
    (accept-drop-files #t)
    
    (inherit set-icon)
    (let ([icon (current-icon)])
      (when icon
        (if (pair? icon)
            (let ([small (car icon)]
                  [large (cdr icon)])
              (set-icon small (send small get-loaded-mask) 'small)
              (set-icon large (send large get-loaded-mask) 'large))
            (set-icon icon (send icon get-loaded-mask) 'both))))
    
    (group:create-windows-menu (make-object (get-menu-bar%) this))
    
    (reorder-menus this)
    
    [define panel (make-root-area-container (get-area-container%) this)]
    (define/public (get-area-container) panel)
    (set! after-init? #t)))

(define current-icon (make-parameter #f))

(define size-pref<%>
  (interface (basic<%>)
    adjust-size-when-monitor-setup-changes?))

(define-local-member-name monitor-setup-changed)

(define size-pref-mixin
  (mixin (basic<%>) (size-pref<%>)
    (init-field size-preferences-key
                [position-preferences-key #f])
    (inherit is-maximized?)
    (define/override (on-size w h)
      
      ;; if the monitor state is currently fluxuating, then
      ;; don't save preferences values, since the OS is doing
      ;; some adjustments for us.
      (when (or (equal? (compute-current-monitor-information)
                        latest-monitor-information)
                (not (adjust-size-when-monitor-setup-changes?)))
        (define old-table (preferences:get size-preferences-key)) 
        (define new-val
          (cond
            [(is-maximized?)
             (define old (or (hash-ref old-table latest-monitor-information #f)
                             (hash-ref old-table #f)))
             (cons #t (cdr old))]
            [else
             (list #f w h)]))
        (preferences:set size-preferences-key 
                         (hash-set*
                          old-table
                          latest-monitor-information new-val
                          #f new-val)))
      (super on-size w h))
      
    (define on-move-timer-arg-x #f)
    (define on-move-timer-arg-y #f)
    (define on-move-timer-arg-max? #f)
    (define on-move-callback-running? #f)
    (define/override (on-move x y)
      (when position-preferences-key
        (unless on-move-callback-running?
          (set! on-move-callback-running? #t)
          (queue-callback
           (λ () 
             (set! on-move-callback-running? #f)
             (unless on-move-timer-arg-max?
               
               ;; if the monitor state is currently fluxuating, then
               ;; don't save preferences values, since the OS is doing
               ;; some adjustments for us.
               (when (or (equal? (compute-current-monitor-information)
                                 latest-monitor-information)
                         (not (adjust-size-when-monitor-setup-changes?)))
                 (define-values (monitor delta-x delta-y) (find-closest on-move-timer-arg-x on-move-timer-arg-y))
                 (define old-table (preferences:get position-preferences-key))
                 (define val (list monitor delta-x delta-y))
                 (preferences:set position-preferences-key
                                  (hash-set*
                                   old-table
                                   latest-monitor-information val
                                   #f val)))))
           #f))
        (set! on-move-timer-arg-x x)
        (set! on-move-timer-arg-y y)
        (set! on-move-timer-arg-max? (is-maximized?)))
      (super on-move x y))
    
    (define/augment (display-changed)
      (restart-montior-information-timer)
      (inner (void) display-changed))
    
    ;; if all of the offsets have some negative direction, then
    ;; just keep the thing relative to the original montior; otherwise
    ;; make it relative to whatever origin it is closest to.
    (define/private (find-closest x y)
      (define closest 0)
      (define-values (delta-x delta-y dist) (find-distance x y 0))
      
      (for ([m (in-range 1 (get-display-count))])
        (define-values (new-delta-x new-delta-y new-dist) 
          (find-distance x y m))
        (when (and new-delta-x
                   new-delta-y
                   (new-delta-x . >= . 0)
                   (new-delta-y . >= . 0))
          (when (< new-dist dist)
            (set! closest m)
            (set!-values (delta-x delta-y dist) (values new-delta-x new-delta-y new-dist)))))
      
      (values closest delta-x delta-y))
    
    (define/private (find-distance x y mon)
      (define-values (delta-x delta-y)
        (let-values ([(l t) (get-display-left-top-inset #:monitor mon)])
          (values (+ x l) (+ y t))))
      (values delta-x
              delta-y
              (sqrt (+ (* delta-x delta-x)
                       (* delta-y delta-y)))))
    
    (inherit maximize)
    (define/private (get-sizes/maximzed)
      (define size-table (preferences:get size-preferences-key))
      (define-values (maximized? w h) (apply values (or (hash-ref size-table latest-monitor-information #f)
                                                        (hash-ref size-table #f))))
      (define-values (x y origin-still-visible?)
        (cond
          [position-preferences-key
           (define pos-table (preferences:get position-preferences-key))
           (define-values (monitor delta-x delta-y) (apply values (or (hash-ref pos-table latest-monitor-information #f)
                                                                      (hash-ref pos-table #f))))
           (define-values (l t) (get-display-left-top-inset #:monitor monitor))
           (define-values (mw mh) (get-display-size #:monitor monitor))
           (if (and l t mw mh)
               (values (- delta-x l) 
                       (- delta-y t)
                       (and (<= 0 delta-x mw)
                            (<= 0 delta-y mh)))
               (values #f #f #f))]
          [else
           (values #f #f #f)]))
      (define (already-one-there? x y w h)
        (for/or ([fr (in-list (get-top-level-windows))])
          (and (equal? x (send fr get-x))
               (equal? y (send fr get-y))
               (equal? w (send fr get-width))
               (equal? h (send fr get-height))
               (equal? maximized? (send fr is-maximized?)))))
      (cond
        [(or (and (already-one-there? x y w h)
                  (not maximized?))
             (not origin-still-visible?))
         ;; these are the situations where we look for a different position of the window
         (let loop ([n 50]
                    [x 0]
                    [y 0])
           (cond
             [(zero? n)
              (values #f #f #f #f maximized?)]
             [(already-one-there? x y w h)
              (define-values (dw dh) (get-display-size #:monitor 0))
              (define sw (- dw w))
              (define sh (- dh h))
              (if (or (<= sw 0)
                      (<= sh 0))
                (values #f #f #f #f maximized?)
                (loop (- n 1) 
                      (modulo (+ x 20) (- dw w))
                      (modulo (+ y 20) (- dh h))))]
             [else
              (values w h x y maximized?)]))]
        [else
         (values w h x y maximized?)]))
    
    (define/public (adjust-size-when-monitor-setup-changes?) #f)
    
    (inherit begin-container-sequence
             end-container-sequence
             move
             resize)
    (define/public (monitor-setup-changed) 
      (when (adjust-size-when-monitor-setup-changes?)
        (define-values (w h x y maximized?) (get-sizes/maximzed))
        (when (and w h x y)
          (begin-container-sequence)
          (move x y)
          (resize w h)
          (when maximized?
            (maximize #t))
          (end-container-sequence))))
    
    (let-values ([(w h x y maximized?) (get-sizes/maximzed)])
      (cond
        [(and w h x y)
         (super-new [width w] [height h] [x x] [y y])]
        [else
         (super-new)])
      (when maximized?
        (maximize #t)))))

(define (setup-size-pref size-preferences-key w h 
                         #:maximized? [maximized? #f]
                         #:position-preferences [position-preferences-key #f])
  (preferences:set-default size-preferences-key 
                           (hash #f (list maximized? w h))
                           (hash/c (or/c (listof (list/c any/c any/c any/c any/c))
                                         #f)
                                   (list/c boolean?
                                           exact-nonnegative-integer?
                                           exact-nonnegative-integer?)
                                   #:immutable #t
                                   #:flat? #t))
  (when position-preferences-key
    (preferences:set-default position-preferences-key 
                             (hash #f (list 0 0 0))
                             (hash/c (or/c (listof (list/c any/c any/c any/c any/c))
                                           #f)
                                     (list/c exact-nonnegative-integer?
                                             exact-integer?
                                             exact-integer?)
                                     #:immutable #t
                                     #:flat? #t))))

(define (compute-current-monitor-information)
  (filter
   values
   (for/list ([m (in-range (get-display-count))])
     (define-values (left top) (get-display-left-top-inset #:monitor m))
     (define-values (width height) (get-display-size #:monitor m))
     (and left top width height
          (list left top width height)))))

(define latest-monitor-information (compute-current-monitor-information))
(define pending-monitor-information #f)
(define montior-information-timer
  (new timer%
       [notify-callback
        (λ ()
          (define new-monitor-information (compute-current-monitor-information))
          (cond
            [pending-monitor-information
             (cond
               [(equal? pending-monitor-information new-monitor-information)
                (set! pending-monitor-information #f)
                (set! latest-monitor-information new-monitor-information)
                (queue-callback
                 (λ ()
                   (when (editor:get-change-font-size-when-monitors-change?)
                     (editor:set-current-preferred-font-size
                      (editor:get-current-preferred-font-size)))
                   (for ([frame (in-list (get-top-level-windows))])
                     (when (is-a? frame size-pref<%>)
                       (send frame monitor-setup-changed)))
                   #f))]
               [else
                (set! pending-monitor-information new-monitor-information)
                (restart-montior-information-timer)])]
            [else
             (unless (equal? latest-monitor-information new-monitor-information)
               (set! pending-monitor-information new-monitor-information)
               (restart-montior-information-timer))]))]))
(define (restart-montior-information-timer)
  (send montior-information-timer stop)
  (send montior-information-timer start 250 #t))


(define register-group<%> (interface ()))
(define register-group-mixin
  (mixin (basic<%>) (register-group<%>)
    
    (define/augment (can-close?)
      (and (inner #t can-close?)
           (group:can-close-check)))
    (define/augment (on-close)
      (send (group:get-the-frame-group)
            remove-frame
            this)
      (inner (void) on-close)
      (group:on-close-action))
    
    (define/override (on-activate on?)
      (super on-activate on?)
      (when on?
        (send (group:get-the-frame-group) set-active-frame this)))
    
    (super-new)
    (send (group:get-the-frame-group) insert-frame this)))

(define locked-message (string-constant read-only))

(define lock-canvas%
  (class canvas%
    (field [locked? #f])
    (inherit refresh)
    (define/public (set-locked l)
      (unless (eq? locked? l)
        (set! locked? l)
        (setup-sizes)
        (refresh)))
    (inherit get-client-size get-dc)
    (define/override (on-paint)
      (define dc (get-dc))
      (define (draw str bg-color bg-style line-color line-style)
        (send dc set-font small-control-font)
        (define-values (w h) (get-client-size))
        (define-values (tw th _1 _2) (send dc get-text-extent str #f 'grapheme))
        (send dc set-pen (send the-pen-list find-or-create-pen line-color 1 line-style))
        (send dc set-brush (send the-brush-list find-or-create-brush bg-color bg-style))
        (send dc draw-rectangle 0 0 w h)
        (send dc draw-text str
              (- (/ w 2) (/ tw 2))
              (- (/ h 2) (/ th 2))
              'grapheme))
      (when locked?
        (draw locked-message "yellow" 'solid "black" 'solid)))
    
    (inherit get-parent min-width min-height stretchable-width stretchable-height)
    (define/private (setup-sizes)
      (let ([dc (get-dc)])
        (if locked?
            (let-values ([(w h _1 _2) (send dc get-text-extent locked-message)])
              (min-width (inexact->exact (floor (+ w 4))))
              (min-height (inexact->exact (floor (+ h 2)))))
            (begin
              (min-width 0)
              (min-height 0)))))
    
    (super-new [style '(transparent no-focus)])
    
    (send (get-dc) set-font small-control-font)
    (setup-sizes)
    (stretchable-width #f)
    (stretchable-height #t)))

(define status-line<%>
  (interface (basic<%>)
    open-status-line
    close-status-line
    update-status-line))

;; status-line : (make-status-line symbol number)
(define-struct status-line (id count))

;; status-line-msg : (make-status-line-msg (is-a?/c message%) (union symbol #f))
(define-struct status-line-msg (message [id #:mutable]))

(define status-line-mixin
  (mixin (basic<%>) (status-line<%>)
    (field [status-line-container-panel #f]
           
           ;; status-lines : (listof status-line)
           [status-lines null]
           
           ;; status-line-msgs : (listof status-line-msg)
           [status-line-msgs null])
    (define/override (make-root-area-container % parent)
      (let* ([s-root (super make-root-area-container vertical-pane% parent)]
             [r-root (make-object % s-root)])
        (set! status-line-container-panel
              (instantiate vertical-panel% ()
                (parent s-root)
                (stretchable-height #f)))
        r-root))
    (define/public (open-status-line id)
      (do-main-thread
       (λ ()
         (when status-line-container-panel
           (set! status-lines
                 (let loop ([status-lines status-lines])
                   (cond
                     [(null? status-lines)
                      (list (make-status-line id 1))]
                     [else (let ([status-line (car status-lines)])
                             (if (eq? id (status-line-id status-line))
                                 (cons (make-status-line id (+ (status-line-count status-line) 1))
                                       (cdr status-lines))
                                 (cons status-line (loop (cdr status-lines)))))])))))))
    
    (define/public (close-status-line id)
      (do-main-thread
       (λ ()
         (when status-line-container-panel
           
           ;; decrement counter in for status line, or remove it if
           ;; counter goes to zero.
           (set! status-lines
                 (let loop ([status-lines status-lines])
                   (cond
                     [(null? status-lines) (error 'close-status-line "status line not open ~e" id)]
                     [else (let* ([status-line (car status-lines)]
                                  [this-line? (eq? (status-line-id status-line) id)])
                             (cond
                               [(and this-line? (= 1 (status-line-count status-line)))
                                (cdr status-lines)]
                               [this-line?
                                (cons (make-status-line id (- (status-line-count status-line) 1))
                                      (cdr status-lines))]
                               [else (cons status-line (loop (cdr status-lines)))]))])))
           
           ;; make sure that there are only as many messages as different status lines, in total
           (let ([status-line-msg (find-status-line-msg id)])
             (when status-line-msg
               (send (status-line-msg-message status-line-msg) set-label "")
               (set-status-line-msg-id! status-line-msg #f)))
           (let* ([msgs-that-can-be-removed (filter (λ (x) (not (status-line-msg-id x))) status-line-msgs)]
                  [max-to-include (length status-lines)]
                  [msgs-to-remove
                   (let loop ([n max-to-include]
                              [l msgs-that-can-be-removed])
                     (cond
                       [(null? l) l]
                       [(zero? n) l]
                       [else (loop (- n 1) (cdr l))]))])
             (send status-line-container-panel
                   change-children
                   (λ (old-children)
                     (foldl (λ (status-line-msg l)
                              (remq (status-line-msg-message status-line-msg) l))
                            old-children
                            msgs-to-remove)))
             (set! status-line-msgs
                   (let loop ([l msgs-to-remove]
                              [status-line-msgs status-line-msgs])
                     (cond
                       [(null? l) status-line-msgs]
                       [else (loop (cdr l)
                                   (remq (car l) status-line-msgs))]))))))))
    
    ;; update-status-line : symbol (union #f string)
    (define/public (update-status-line id msg-txt)
      (do-main-thread
       (λ ()
         (unless (open-status-line? id)
           (error 'update-status-line "unknown id ~e, other arg ~e" id msg-txt))
         (if msg-txt
             (cond
               [(find-status-line-msg id)
                =>
                (λ (existing-status-line-msg)
                  (let ([msg (status-line-msg-message existing-status-line-msg)])
                    (unless (equal? (send msg get-label) msg-txt)
                      (send msg set-label msg-txt))))]
               [(find-available-status-line-msg)
                =>
                (λ (available-status-line-msg)
                  (send (status-line-msg-message available-status-line-msg) set-label msg-txt)
                  (set-status-line-msg-id! available-status-line-msg id))]
               [else
                (set! status-line-msgs
                      (cons (make-new-status-line-msg id msg-txt)
                            status-line-msgs))])
             (let ([status-line-msg (find-status-line-msg id)])
               (when status-line-msg
                 (send (status-line-msg-message status-line-msg) set-label "")
                 (set-status-line-msg-id! status-line-msg #f)))))))
    
    ;; open-status-line? : symbol -> boolean
    (define/private (open-status-line? id)
      (let loop ([status-lines status-lines])
        (cond
          [(null? status-lines) #f]
          [else
           (let ([status-line (car status-lines)])
             (or (eq? (status-line-id status-line) id)
                 (loop (cdr status-lines))))])))
    
    ;; find-available-status-line-msg : -> (union #f status-line-msg)
    (define/private (find-available-status-line-msg)
      (let loop ([status-line-msgs status-line-msgs])
        (cond
          [(null? status-line-msgs) #f]
          [else (let ([status-line-msg (car status-line-msgs)])
                  (if (status-line-msg-id status-line-msg)
                      (loop (cdr status-line-msgs))
                      status-line-msg))])))
    
    ;; find-status-line-msg : symbol -> (union #f status-line-msg)
    (define/private (find-status-line-msg id)
      (let loop ([status-line-msgs status-line-msgs])
        (cond
          [(null? status-line-msgs) #f]
          [else (let ([status-line-msg (car status-line-msgs)])
                  (if (eq? id (status-line-msg-id status-line-msg))
                      status-line-msg
                      (loop (cdr status-line-msgs))))])))
    
    ;; make-new-status-line-msg : symbol string -> status-line-msg
    (define/private (make-new-status-line-msg id msg-txt)
      (define msg
        (new message% 
             [parent status-line-container-panel]
             [stretchable-width #t]
             [label ""]))
      (send msg set-label msg-txt)
      (make-status-line-msg msg id))
    
    (inherit get-eventspace)
    (define/private (do-main-thread t)
      (let ([c-eventspace (current-eventspace)])
        (if (and (eq? c-eventspace (get-eventspace))
                 (eq? (current-thread) (eventspace-handler-thread c-eventspace)))
            (t)
            (parameterize ([current-eventspace c-eventspace])
              ;; need high priority callbacks to ensure ordering wrt other callbacks
              (queue-callback t #t)))))
    
    (super-new)))

(define info<%> frame:info<%>)

(define magic-space 25)

(define-local-member-name get-memory-use-canvas)
(define memory-use-timer-cell (make-thread-cell #f))
(define (update-memory-use-canvases)
  (define found-any? #f)
  (for ([window (in-list (get-top-level-windows))])
    (when (is-a? window frame:info<%>)
      (set! found-any? #t)
      (send (send window get-memory-use-canvas) update-memory-use-if-bigish-change)))
  (unless found-any?
    (send (thread-cell-ref memory-use-timer-cell) stop)
    (thread-cell-set! memory-use-timer-cell #f)))
(define (maybe-create-memory-use-timer)
  (unless (thread-cell-ref memory-use-timer-cell)
    (when (eq? (current-thread) (eventspace-handler-thread (current-eventspace)))
      (thread-cell-set! memory-use-timer-cell
                        (new timer%
                             [notify-callback update-memory-use-canvases]
                             [interval 1000])))))

(define info-mixin
  (mixin (basic<%>) (info<%>)
    [define rest-panel 'uninitialized-root]
    [define super-root 'uninitialized-super-root]
    (define/override (make-root-area-container % parent)
      (let* ([s-root (super make-root-area-container
                            vertical-pane%
                            parent)]
             [r-root (make-object % s-root)])
        (set! super-root s-root)
        (set! rest-panel r-root)
        r-root))
    
    (define info-canvas #f)
    (define/public (get-info-canvas) info-canvas)
    (define/public (set-info-canvas c) (set! info-canvas c))
    (define/public (get-info-editor)
      (and info-canvas
           (send info-canvas get-editor)))
    
    (define/public (determine-width string canvas edit)
      (send edit set-autowrap-bitmap #f)
      (send canvas call-as-primary-owner
            (λ ()
              (let ([lb (box 0)]
                    [rb (box 0)])
                (send edit erase)
                (send edit insert string)
                (send edit position-location 
                      (send edit last-position)
                      rb)
                (send edit position-location 0 lb)
                (send canvas min-width 
                      (+ (get-client-width/view-delta edit canvas)
                         (- (inexact->exact (floor (unbox rb)))
                            (inexact->exact (floor (unbox lb))))))))))
    
    (define outer-info-panel 'top-info-panel-uninitialized)
    
    ;; this flag is specific to this frame
    ;; the true state of the info panel is
    ;; the combination of this flag and the 
    ;; 'framework:show-status-line preference
    ;; as shown in update-info-visibility
    (define info-hidden? #f)
    (define/public (hide-info)
      (set! info-hidden? #t)
      (update-info-visibility (preferences:get 'framework:show-status-line)))
    (define/public (show-info)
      (set! info-hidden? #f)
      (update-info-visibility (preferences:get 'framework:show-status-line)))
    (define/public (is-info-hidden?) info-hidden?)
    (define/private (update-info-visibility pref-value)
      (cond
        [(or info-hidden? (not pref-value))
         (send super-root change-children
               (λ (l)
                 (if (memq outer-info-panel l)
                     (begin (unregister-collecting-blit gc-canvas)
                            (unregister-pref-save-callback)
                            (list rest-panel))
                     l)))]
        [else
         (send super-root change-children
               (λ (l)
                 (if (memq outer-info-panel l)
                     l
                     (begin
                       (register-gc-blit)
                       (register-pref-save-callback)
                       (list rest-panel outer-info-panel)))))]))
    
    [define close-panel-callback
      (preferences:add-callback
       'framework:show-status-line
       (λ (p v)
         (update-info-visibility v)))]
    (define memory-cleanup void) ;; only for checkouts and nightly build users; used with memory-text
    
    (define/augment (on-close)
      (unregister-collecting-blit gc-canvas)
      (unregister-pref-save-callback)
      (close-panel-callback)
      (memory-cleanup)
      (inner (void) on-close))
    
    (define icon-currently-locked? 'uninit)
    (define/public (lock-status-changed)
      (let ([info-edit (get-info-editor)])
        (cond
          [(not (object? lock-canvas))
           (void)]
          [(is-a? info-edit editor:file<%>)
           (unless (send lock-canvas is-shown?)
             (send lock-canvas show #t))
           (let ([locked-now? (not (send info-edit get-read-write?))])
             (unless (eq? locked-now? icon-currently-locked?)
               (set! icon-currently-locked? locked-now?)
               (when (object? lock-canvas)
                 (send lock-canvas set-locked locked-now?))))]
          [else
           (when (send lock-canvas is-shown?)
             (send lock-canvas show #f))])))
    
    (define/public (update-info) (lock-status-changed))
    
    (super-new)
    (set! outer-info-panel (make-object horizontal-panel% super-root))
    (send outer-info-panel stretchable-height #f)
    
    (define info-panel (new-horizontal-panel% [parent outer-info-panel]))
    (new grow-box-spacer-pane% [parent outer-info-panel])
    
    (define/public (get-info-panel) info-panel)
    (define/public (get-memory-use-canvas) this-frames-memory-canvas)
    
    (define pref-save-canvas #f)
    (set! pref-save-canvas (new pref-save-canvas% [parent (get-info-panel)]))
    
    [define lock-canvas (make-object lock-canvas% (get-info-panel))]
    (define this-frames-memory-canvas #f)
    ; set up the memory use display in the status line
    (let* ([panel (new-horizontal-panel%
                       [parent (get-info-panel)]
                       [stretchable-width #f]
                       [stretchable-height #f])])
      (set! this-frames-memory-canvas
            (new memory-position-canvas%
                 [parent panel]
                 [button-up
                  (λ (evt)
                    (cond
                      [(or (send evt get-alt-down)
                           (send evt get-control-down))
                       (dynamic-require 'framework/private/follow-log #f)]
                      [else
                       (collect-garbage)
                       (update-memory-text)]))]))
      (set! memory-canvases (cons this-frames-memory-canvas memory-canvases))
      (maybe-create-memory-use-timer)
      (set! memory-cleanup
            (λ ()
              (set! memory-canvases (remq this-frames-memory-canvas memory-canvases))))
      (send panel stretchable-width #f))
    
    (define gc-canvas (new gc-off-canvas% [parent (get-info-panel)] [style '(border no-focus)]))
    (define/private (register-gc-blit)
      (let ([onb (icon:get-gc-on-bitmap)]
            [offb (icon:get-gc-off-bitmap)])
        (when (and (send onb ok?)
                   (send offb ok?))
          (register-collecting-blit gc-canvas 
                                    0 0
                                    (send onb get-width)
                                    (send onb get-height)
                                    onb offb))))
    
    (define pref-save-callback-registration #f)
    (inherit get-eventspace)
    (define/private (register-pref-save-callback)
      (when pref-save-canvas
        (set! pref-save-callback-registration
              (preferences:register-save-callback
               (λ (start?)
                 (cond
                   [(eq? (current-thread) (eventspace-handler-thread (get-eventspace)))
                    (send pref-save-canvas set-on? start?)]
                   [else
                    (queue-callback
                     (λ ()
                       (send pref-save-canvas set-on? start?)))]))))))
    (define/private (unregister-pref-save-callback)
      (when pref-save-callback-registration
        (preferences:unregister-save-callback pref-save-callback-registration)))
    (register-pref-save-callback)
    
    (unless (preferences:get 'framework:show-status-line)
      (send super-root change-children
            (λ (l)
              (list rest-panel))))
    (register-gc-blit)
    
    (let* ([gcb (icon:get-gc-on-bitmap)]
           [gc-width (if (send gcb ok?)
                         (send gcb get-width)
                         10)]
           [gc-height (if (send gcb ok?)
                          (send gcb get-height)
                          10)])
      (send* gc-canvas
        (min-client-width (max (send gc-canvas min-width) gc-width))
        (min-client-height (max (send gc-canvas min-height) gc-height))
        (stretchable-width #f)
        (stretchable-height #f)))
    (send* (get-info-panel) 
      (set-alignment 'right 'center)
      (stretchable-height #f)
      (spacing 3)
      (border 3))))

(define (ensure-enough-width editor-canvas text)
  (send editor-canvas call-as-primary-owner
        (λ ()
          (let ([delta (get-client-width/view-delta text editor-canvas)]
                [lb (box 0)]
                [rb (box 0)])
            (send text position-location 
                  (send text last-position)
                  rb)
            (send text position-location 0 lb)
            (let ([nw
                   (+ delta (- (inexact->exact (floor (unbox rb)))
                               (inexact->exact (floor (unbox lb)))))])
              (when (< (send editor-canvas min-client-width) nw)
                (send editor-canvas min-client-width nw)))))))

(define (get-client-width/view-delta position-edit position-canvas)
  (let ([admin (send position-edit get-admin)]
        [wb (box 0)])
    (send admin get-view #f #f wb #f)
    (let-values ([(cw ch) (send position-canvas get-client-size)])
      (inexact->exact (floor (- cw (unbox wb)))))))

(define position-canvas%
  (class canvas%
    (inherit min-client-height min-client-width get-dc get-client-size refresh)
    (init init-width)
    (init-field [button-up #f])
    (init-field [char-typed void])
    (define str "")
    (define/public (set-str _str)
      (set! str _str)
      (update-client-width str)
      (refresh))
    (define/private (update-client-width str)
      (define dc (get-dc))
      (define-values (cw _4) (get-client-size))
      (define-values (tw _1 _2 _3) (send dc get-text-extent str normal-control-font 'grapheme))
      (when (< cw tw)
        (min-client-width (inexact->exact (ceiling tw)))))
    (define/override (on-paint)
      (define dc (get-dc))
      (send dc set-font normal-control-font)
      (send dc set-text-foreground (get-label-foreground-color))
      (define-values (cw ch) (get-client-size))
      (define-values (tw th _1 _2) (send dc get-text-extent str))
      (send dc draw-text str 0 (/ (- ch th) 2) 'grapheme))
    (define/override (on-event evt)
      (when button-up
        (when (send evt button-up?)
          (let-values ([(cw ch) (get-client-size)])
            (when (and (<= (send evt get-x) cw)
                       (<= (send evt get-y) ch))
              (if (procedure-arity-includes? button-up 1)
                  (button-up evt)
                  (button-up)))))))
    (define/override (on-char evt)
      (char-typed evt))
    (super-new (style '(transparent no-focus)))
    (let ([dc (get-dc)])
      (let-values ([(_1 th _2 _3) (send dc get-text-extent str)])
        (min-client-height (inexact->exact (floor th)))))
    (update-client-width init-width)))

(define memory-canvases '())
(define (update-memory-text)
  (for ([memory-canvas (in-list memory-canvases)])
    (send memory-canvas update-memory-use)))
(define memory-position-canvas%
  (class position-canvas%
    (inherit set-str)
    (define/public (update-memory-use)
      (set! last-memory-use (current-memory-use))
      (set-str (format-number last-memory-use)))
    (define/public (update-memory-use-if-bigish-change)
      (define change-amount (abs (- (current-memory-use) last-memory-use)))
      (when (change-amount . > . (* 1024 1024)) ;; more than one meg
        (update-memory-use)))

    (define/private (format-number n)
      (let* ([mbytes (/ n 1024 1024)]
             [before-decimal (floor mbytes)]
             [after-decimal (modulo (floor (* mbytes 100)) 100)])
        (string-append
         (number->string before-decimal)
         "."
         (cond
           [(<= after-decimal 9) (format "0~a" after-decimal)]
           [else (number->string after-decimal)])
         " MB")))

    (super-new [init-width "99.99 MB"])
    (define last-memory-use 0)
    (update-memory-use)))

(define text-info<%> frame:text-info<%>)
(define text-info-mixin
  (mixin (info<%>) (text-info<%>)
    (inherit get-info-editor)
    (define remove-first
      (preferences:add-callback
       'framework:col-offsets
       (λ (p v)
         (editor-position-changed-offset/numbers
          v
          (preferences:get 'framework:display-line-numbers)
          (preferences:get 'framework:display-character-offsets?))
         #t)))
    (define remove-second
      (preferences:add-callback
       'framework:display-line-numbers
       (λ (p v)
         (editor-position-changed-offset/numbers
          (preferences:get 'framework:col-offsets)
          v
          (preferences:get 'framework:display-character-offsets?))
         #t)))
    (define remove-third
      (preferences:add-callback
       'framework:display-character-offsets?
       (λ (p v)
         (editor-position-changed-offset/numbers
          (preferences:get 'framework:col-offsets)
          (preferences:get 'framework:display-line-numbers)
          v)
         #t)))
    (define/augment (on-close)
      (remove-first)
      (remove-second)
      (remove-third)
      (inner (void) on-close))
    [define last-start #f]
    [define last-end #f]
    [define last-params #f]
    (define/private (editor-position-changed-offset/numbers offset?
                                                            line-numbers?
                                                            character-offsets?)
      (when (object? position-canvas)
        (define edit (get-info-editor))
        (define (make-one pos)
          (define (line-numbers)
            (define para (send edit position-paragraph pos))
            (define col (find-col edit para pos))
            (define para-start (send edit paragraph-start-position para))
            (format "~a:~a"
                    (add1 para)
                    (if offset?
                        (add1 col)
                        col)))
          (cond
            [(and line-numbers? character-offsets?)
             (format "~a@~a" pos (line-numbers))]
            [line-numbers?
             (line-numbers)]
            [else (format "~a" pos)]))
        (cond
          [edit
           (unless (send position-canvas is-shown?)
             (send position-canvas show #t))
           (define start (send edit get-start-position))
           (define end (send edit get-end-position))
           (define this-params (list offset? line-numbers? character-offsets?))
           (unless (and last-start
                        (equal? last-params this-params)
                        (= last-start start)
                        (= last-end end))
             (set! last-params this-params)
             (set! last-start start)
             (set! last-end end)
             (change-position-edit-contents
              (if (= start end)
                  (make-one start)
                  (string-append
                   (make-one start)
                   (if (and line-numbers? character-offsets?) " - " "-")
                   (make-one end)))))]
          [else
           (when (send position-canvas is-shown?)
             (send position-canvas show #f))])))
    
    ;; find-col : text number number -> number
    ;; given a line number and a position, finds the
    ;; column number for that position
    (define/private (find-col text line pos)
      (let ([line-start (send text paragraph-start-position line)])
        (if (= line-start pos)
            0
            (let loop ([col 0]
                       [snip (send text find-snip line-start 'after-or-none)])
              (cond
                [(and snip (is-a? snip tab-snip%))
                 ;; assume cursor isn't in the middle of the tab snip
                 ;; and that there is no tab array
                 (let ([twb (box 0)])
                   (send text get-tabs #f twb #f)
                   (let ([tw (floor (inexact->exact (unbox twb)))])
                     (loop (+ col (- tw (modulo col tw)))
                           (send snip next))))]
                [snip 
                 (let ([snip-position (send text get-snip-position snip)]
                       [snip-length (send snip get-count)])
                   (if (<= snip-position pos (+ snip-position snip-length))
                       (+ col (- pos snip-position))
                       (loop (+ col snip-length)
                             (send snip next))))]
                [else
                 col])))))
    
    
    [define anchor-last-state? #f]
    [define overwrite-last-state? #f]

    (define/private (update-ascii-art-enlarge-msg)
      (define ascii-art-enlarge-mode?
        (let ([e (get-info-editor)])
          (and (is-a? e text:ascii-art-enlarge-boxes<%>)
               (send e get-ascii-art-enlarge))))
      (unless (eq? (and (member ascii-art-enlarge-mode-msg (send uncommon-parent get-children)) #t)
                   ascii-art-enlarge-mode?)
        (if ascii-art-enlarge-mode?
            (add-uncommon-child ascii-art-enlarge-mode-msg)
            (remove-uncommon-child ascii-art-enlarge-mode-msg))))

    ;; this callback is kind of a hack. we know that when the set-ascii-art-enlarge
    ;; method of text:ascii-art-enlarge<%> is called that it changes the preferences
    ;; value so we will get called back here; it would be better if we could just
    ;; have the callback happen directly by overriding that method, but that causes
    ;; backwards incompatibility problems.
    (define callback (λ (p v)
                       (queue-callback
                        (λ () (update-ascii-art-enlarge-msg))
                        #f)))
    (preferences:add-callback 'framework:ascii-art-enlarge callback #t)

    
    (field (macro-recording? #f))
    (define/private (update-macro-recording-icon)
      (unless (eq? (send macro-recording-message is-shown?)
                   macro-recording?)
        (if macro-recording?
            (add-uncommon-child macro-recording-message)
            (remove-uncommon-child macro-recording-message))))
    (define/public (set-macro-recording on?)
      (set! macro-recording? on?)
      (update-macro-recording-icon))
    
    (define/public (anchor-status-changed)
      (let ([info-edit (get-info-editor)]
            [failed
             (λ ()
               (unless (eq? anchor-last-state? #f)
                 (set! anchor-last-state? #f)
                 (remove-uncommon-child anchor-message)))])
        (cond
          [info-edit
           (let ([anchor-now? (send info-edit get-anchor)])
             (unless (eq? anchor-now? anchor-last-state?)
               (cond
                 [(object? anchor-message)
                  (if anchor-now?
                      (add-uncommon-child anchor-message)
                      (remove-uncommon-child anchor-message))
                  (set! anchor-last-state? anchor-now?)]
                 [else (failed)])))]
          [else
           (failed)])))
    (define/public (editor-position-changed)
      (editor-position-changed-offset/numbers
       (preferences:get 'framework:col-offsets)
       (preferences:get 'framework:display-line-numbers)
       (preferences:get 'framework:display-character-offsets?)))
    (define/public (overwrite-status-changed)
      (let ([info-edit (get-info-editor)]
            [failed
             (λ ()
               (set! overwrite-last-state? #f)
               (remove-uncommon-child overwrite-message))])
        (cond
          [info-edit
           (let ([overwrite-now? (send info-edit get-overwrite-mode)])
             (unless (eq? overwrite-now? overwrite-last-state?)
               (cond
                 [(object? overwrite-message)
                  (if overwrite-now?
                      (add-uncommon-child overwrite-message)
                      (remove-uncommon-child overwrite-message))
                  (set! overwrite-last-state? overwrite-now?)]
                 [else
                  (failed)])))]
          [else
           (failed)])))
    

    (define/public (add-line-number-menu-items menu)
      (void))
    
    (define/public (use-file-text-mode-changed)
      (when (object? file-text-mode-msg)
        (define ed (get-info-editor))
        (send file-text-mode-msg-parent change-children
              (λ (l)
                (if (and (is-a? ed text:info<%>)
                         (eq? (system-type) 'windows)
                         (send ed use-file-text-mode))
                  (list file-text-mode-msg)
                  '())))))
    
    (define/override (update-info)
      (super update-info)
      (update-macro-recording-icon)
      (update-ascii-art-enlarge-msg)
      (overwrite-status-changed)
      (anchor-status-changed)
      (editor-position-changed)
      (use-file-text-mode-changed))
    (super-new)
    
    (inherit get-info-panel)
    
    (define position-parent (new click-pref-panel% 
                                 [border 2]
                                 [parent (get-info-panel)]
                                 [stretchable-width #f]
                                 [stretchable-height #f]
                                 [extra-menu-items (λ (menu) (add-line-number-menu-items menu))]))
    (define position-canvas (new position-canvas% 
                                 [parent position-parent] 
                                 [init-width "1:1"]))
    (define/private (change-position-edit-contents str)
      (send position-canvas set-str str))
    
    (send (get-info-panel) change-children
          (λ (l)
            (cons position-parent (remq position-parent l))))

    (define file-text-mode-msg-parent (new-horizontal-panel%
                                           [stretchable-width #f]
                                           [stretchable-height #f]
                                           [parent (get-info-panel)]))
    (define file-text-mode-msg (new file-text-mode-msg% [parent file-text-mode-msg-parent]))
    (send file-text-mode-msg-parent change-children (λ (l) '()))
    (send (get-info-panel) change-children
          (λ (l)
            (cons file-text-mode-msg-parent (remq file-text-mode-msg-parent l))))
    
    (define uncommon-parent (new-horizontal-panel%
                                 [parent (get-info-panel)]
                                 [stretchable-width #f]))
    
    (send (get-info-panel) change-children
          (λ (l) (cons uncommon-parent (remq uncommon-parent l))))
    
    (define ascii-art-enlarge-mode-msg (new message%
                                            [parent uncommon-parent]
                                            [label "╠╬╣"]
                                            [auto-resize #t]))
    (define anchor-message
      (new message%
           [font small-control-font]
           [label (string-constant auto-extend-selection)]
           [parent uncommon-parent]))
    (define overwrite-message 
      (new message%
           [font small-control-font]
           [label (string-constant overwrite)]
           [parent uncommon-parent]))
    (define macro-recording-message
      (new message%
           [label "c-x;("]
           [font small-control-font]
           [parent uncommon-parent]))
    (define/private (remove-uncommon-child c)
      (send uncommon-parent change-children
            (λ (l) (remq c l))))
    (define/private (add-uncommon-child c)
      (define (child->num c)
        (cond
          [(eq? c ascii-art-enlarge-mode-msg) -1]
          [(eq? c anchor-message) 0]
          [(eq? c overwrite-message) 1]
          [(eq? c macro-recording-message) 2]))
      (send uncommon-parent change-children
            (λ (l) (sort (cons c (remq c l))
                         <
                         #:key child->num))))

    (inherit determine-width)
    (send uncommon-parent change-children (λ (l) '()))
    (editor-position-changed)
    (use-file-text-mode-changed)))

(define crlf-string "CRLF")
(define file-text-mode-msg%
  (class canvas%
    (inherit min-width min-height get-dc refresh)
    (define/override (on-paint)
      (define dc (get-dc))
      (send dc set-pen "black" 1 'transparent)
      (send dc set-brush "orange" 'solid)
      (define-values (w h d a) (send dc get-text-extent crlf-string))
      (send dc draw-rectangle 0 0 (+ w 4) h)
      (send dc draw-text crlf-string 2 0))
    (super-new)
    (inherit stretchable-width)
    (stretchable-width #f)
    (send (get-dc) set-font small-control-font)
    (let ()
      (define-values (w h d a) (send (get-dc) get-text-extent crlf-string))
      (min-width (inexact->exact (ceiling (+ w 4))))
      (min-height (inexact->exact (ceiling h))))))         

(define click-pref-panel%
  (class horizontal-panel%
    (init-field extra-menu-items)
    (inherit popup-menu)
    (define/override (on-subwindow-event receiver evt)
      (cond
        [(send evt button-down?)
         (define menu (new popup-menu%))
         (define line-numbers? (preferences:get 'framework:display-line-numbers))
         (define character-offsets? (preferences:get 'framework:display-character-offsets?))
         (new checkable-menu-item%
              [parent menu]
              [label (string-constant show-line-and-column-numbers)]
              [callback (λ (x y) (preferences:set 'framework:display-line-numbers (not line-numbers?)))]
              [checked line-numbers?])
         (new checkable-menu-item%
              [parent menu]
              [label (string-constant show-character-offsets)]
              [callback (λ (x y) (preferences:set 'framework:display-character-offsets? (not character-offsets?)))]
              [checked character-offsets?])
         (extra-menu-items menu)
         (popup-menu menu 
                     (+ 1 (send evt get-x))
                     (+ 1 (send evt get-y)))
         #t]
        [else
         (super on-subwindow-event receiver evt)]))
    (super-new)))

(define pasteboard-info<%> (interface (info<%>)))
(define pasteboard-info-mixin
  (mixin (basic<%>) (pasteboard-info<%>)
    (super-new)))

(define standard-menus<%> frame:standard-menus<%>)
(generate-standard-menus-code)

(define -editor<%> (interface (standard-menus<%>)
                     get-entire-label
                     get-label-prefix
                     set-label-prefix

                     get-canvas%
                     get-canvas<%>
                     get-editor%
                     get-editor<%>
                     
                     make-editor
                     revert
                     save
                     save-as
                     get-canvas
                     get-editor

                     find-editor))

(define editor-mixin
  (mixin (standard-menus<%>) (-editor<%>)
    (init (filename #f))
    (init-field (editor% #f))
    
    (inherit get-area-container get-client-size 
             show get-edit-target-window get-edit-target-object)
    
    (define/override get-filename
      (case-lambda
        [() (get-filename #f)]
        [(b)
         (let ([e (get-editor)])
           (and e (send e get-filename b)))]))
    
    (define/override (editing-this-file? filename)
      (let ([path-equal?
             (λ (x y)
               (with-handlers ((exn:fail? (λ (x) #f)))
                 (equal? (normal-case-path (normalize-path x))
                         (normal-case-path (normalize-path y)))))])
        (let ([this-fn (get-filename)])
          (and this-fn
               (path-equal? filename (get-filename))))))
    
    (define/augment (on-close)
      (send (get-editor) on-close)
      (inner (void) on-close))
    
    (define/augment (can-close?)
      (and (send (get-editor) can-close?)
           (inner #t can-close?)))
    
    [define label ""]
    [define label-prefix (application:current-app-name)]
    (define/private (do-label)
      (super set-label (gui-utils:trim-string (get-entire-label) 200))
      (send (group:get-the-frame-group) frame-label-changed this))
    
    (define/public (get-entire-label)
      (cond
        [(string=? "" label)
         label-prefix]
        [(string=? "" label-prefix)
         label]
        [else 
         (string-append label " - " label-prefix)]))
    (define/public (get-label-prefix) label-prefix)
    (define/public (set-label-prefix s)
      (when (and (string? s)
                 (not (string=? s label-prefix)))
        (set! label-prefix s)
        (do-label)))
    [define/override get-label (λ () label)]
    [define/override set-label
      (λ (t)
        (when (and (string? t)
                   (not (string=? t label)))
          (set! label t)
          (do-label)))]
    
    (define/public (get-canvas%) editor-canvas%)
    (define/public (get-canvas<%>) (class->interface editor-canvas%))
    (define/public (make-canvas)
      (let ([% (get-canvas%)]
            [<%> (get-canvas<%>)])
        (unless (implementation? % <%>)
          (error 'frame:editor%
                 "result of get-canvas% method must match ~e interface; got: ~e"
                 <%> %))
        (instantiate % () (parent (get-area-container)))))
    (define/public (get-editor%)
      (or editor%
          (error 'editor-frame% "abstract method: no editor% class specified")))
    (define/public (get-editor<%>)
      editor:basic<%>)
    (define/public (make-editor)
      (let ([% (get-editor%)]
            [<%> (get-editor<%>)])
        (unless (implementation? % <%>)
          (error 'frame:editor%
                 "result of get-editor% method must match ~e interface; got: ~e"
                 <%> %))
        (make-object %)))
    
    (define/public save
      (lambda ([format 'same])
        (let* ([ed (get-editor)]
               [filename (send ed get-filename)])
          (if filename
              (send ed save-file/gui-error filename format)
              (save-as format)))))
    
    (define/public save-as
      (lambda ([format 'same])
        (let* ([editor (get-editor)]
               [name (send editor get-filename)])
          (let-values ([(base name)
                        (if name 
                            (let-values ([(base name dir?) (split-path name)])
                              (values base name))
                            (values #f #f))])
            (let ([file (send editor put-file base name)])
              (if file
                  (send editor save-file/gui-error file format)
                  #f))))))
    
    (define/private (basename str)
      (let-values ([(base name dir?) (split-path str)])
        base))
    
    (inherit get-checkable-menu-item% get-menu-item%)
    
    (define/override (file-menu:open-callback item evt)
      (let* ([e (get-editor)]
             [fn (and e (send e get-filename))]
             [dir (and fn
                       (let-values ([(base name dir) (split-path fn)])
                         base))])
        (handler:open-file dir)))
    
    (define/override (file-menu:revert-on-demand item)
      (send item enable (not (send (get-editor) is-locked?))))
    
    (define/override file-menu:revert-callback 
      (λ (item control)
        (let* ([edit (get-editor)]
               [b (box #f)]
               [filename (send edit get-filename b)])
          (if (or (not filename)
                  (unbox b))
              (bell)
              (when (or (not (send (get-editor) is-modified?))
                        (gui-utils:get-choice
                         (string-constant are-you-sure-revert)
                         (string-constant yes)
                         (string-constant no)
                         (string-constant are-you-sure-revert-title)
                         #f
                         this
                         #:dialog-mixin focus-table-mixin))
                (revert))))
        #t))
    
    (define/public (revert)
      (send (get-editor) revert/gui-error))
    
    (define/override file-menu:create-revert? (λ () #t))
    (define/override file-menu:save-callback
      (λ (item control)
        (save)
        #t))
    
    (define/override file-menu:create-save? (λ () #t))
    (define/override file-menu:save-as-callback (λ (item control) (save-as) #t))
    (define/override file-menu:create-save-as? (λ () #t))
    (define/override file-menu:print-callback (λ (item control)
                                                (send (get-editor) print
                                                      #t
                                                      #t
                                                      (preferences:get 'framework:print-output-mode))
                                                #t))
    (define/override file-menu:create-print? (λ () #t))
    
    (inherit get-top-level-window)
    (define/override (file-menu:between-save-as-and-print file-menu)
      (when (and (can-get-page-setup-from-user?) (file-menu:create-print?))
        (new menu-item% 
             [parent file-menu]
             [label (string-constant page-setup-menu-item)]
             [help-string (string-constant page-setup-info)]
             [callback
              (lambda (item event)
                (let ([s (get-page-setup-from-user #f (get-top-level-window))])
                  (when s
                    (send (current-ps-setup) copy-from s))))])))
    
    (define/override (edit-menu:between-select-all-and-find edit-menu)
      (define c% (get-checkable-menu-item%))
      (define (on-demand menu-item)
        (define edit (get-edit-target-object))
        (cond
          [(and edit (is-a? edit editor<%>))
           (send menu-item enable #t)
           (send menu-item check (send edit auto-wrap))]
          [else 
           (send menu-item check #f)
           (send menu-item enable #f)]))
      (define (callback item event)
        (define edit (get-edit-target-object))
        (when (and edit
                   (is-a? edit editor<%>))
          (define new-pref (not (send edit auto-wrap)))
          (preferences:set 'framework:auto-set-wrap? new-pref)
          (send edit auto-wrap new-pref)))
      (new c%
           [label (string-constant wrap-text-item)]
           [parent edit-menu]
           [callback callback]
           [demand-callback on-demand])
      (make-object separator-menu-item% edit-menu))
    
    (define/override help-menu:about-callback 
      (λ (menu evt) 
        (message-box (application:current-app-name)
                     (format (string-constant welcome-to-something)
                             (application:current-app-name))
                     #f
                     '(ok))))
    (define/override help-menu:about-string (λ () (application:current-app-name)))
    (define/override help-menu:create-about? (λ () #t))
    
    (super-new (label (get-entire-label)))
    
    (define canvas #f)
    (define editor #f)
    (define/public (get-canvas)
      (unless canvas
        (set! canvas (make-canvas))
        (send canvas set-editor (get-editor)))
      canvas)
    (define/public (get-editor)
      (unless editor
        (set! editor (make-editor))
        (send (get-canvas) set-editor editor))
      editor)
    (define/public (find-editor predicate)
      (if (and editor
               (predicate editor))
          editor
          #f))
    (cond
      [(and filename (file-exists? filename))
       (let ([ed (get-editor)])
         (send ed begin-edit-sequence)
         (send ed load-file/gui-error filename 'guess)
         (send ed end-edit-sequence))]
      [filename
       (send (get-editor) set-filename filename)]
      [else (void)])
    
    (let ([ed-fn (send (get-editor) get-filename)])
      (set! label (or (and ed-fn 
                           (path->string (file-name-from-path ed-fn)))
                      (send (get-editor) get-filename/untitled-name))))
    (do-label)
    (let ([canvas (get-canvas)])
      (when (is-a? canvas editor-canvas%)
        ;; when get-canvas is overridden,
        ;; it might not yet be implemented
        (send canvas focus)))))

(define text<%> (interface (-editor<%>)))
(define text-mixin
  (mixin (-editor<%>) (text<%>)
    (define/override (get-editor<%>) (class->interface text%))
    (init (filename #f) (editor% text:keymap%))
    
    (inherit get-editor)
    (define/override (edit-menu:between-find-and-preferences edit-menu)
      (when (add-find-longest-line-menu-item?)
        (new menu-item%
             [parent edit-menu] 
             [label (string-constant find-longest-line)]
             [callback 
              (λ (x y)
                (define ed (get-editor))
                (define (line-len p)
                  (define ans 
                    (- (send ed paragraph-end-position p #f)
                       (send ed paragraph-start-position p #f)))
                  ans)
                (when ed
                  (let loop ([p (- (send ed last-paragraph) 1)]
                             [longest-size (line-len (send ed last-paragraph))]
                             [longest (send ed last-paragraph)])
                    (cond
                      [(= p -1)
                       (send ed set-position 
                             (send ed paragraph-start-position longest #f)
                             (send ed paragraph-end-position longest #f))]
                      [else
                       (define this-size (line-len p))
                       (cond
                         [(<= longest-size this-size)
                          (loop (- p 1) this-size p)]
                         [else
                          (loop (- p 1) longest-size longest)])]))))]))
      (super edit-menu:between-find-and-preferences edit-menu))
      
    (define/public (add-find-longest-line-menu-item?) #t)
    
    (super-new (filename filename) (editor% editor%))))

(define pasteboard<%> (interface (-editor<%>)))
(define pasteboard-mixin
  (mixin (-editor<%>) (pasteboard<%>)
    (define/override get-editor<%> (λ () (class->interface pasteboard%)))
    (init (filename #f) (editor% pasteboard:keymap%))
    (super-new (filename filename) (editor% editor%))))

(define delegate<%>
  (interface (status-line<%> text<%>)
    delegated-text-shown?
    hide-delegated-text
    show-delegated-text
    delegate-moved
    set-delegated-text
    get-delegated-text))

(define delegatee-editor-canvas%
  (class (canvas:color-mixin canvas:basic%)
    (init-field delegate-frame)
    (inherit get-editor get-dc)
    
    (define/override (on-event evt)
      (super on-event evt)
      (when delegate-frame
        (let ([text (get-editor)])
          (when (and (is-a? text text%)
                     (send delegate-frame delegated-text-shown?))
            (cond
              [(send evt button-down?)
               (let-values ([(editor-x editor-y)
                             (send text dc-location-to-editor-location 
                                   (send evt get-x)
                                   (send evt get-y))])
                 (send delegate-frame click-in-overview 
                       (send text find-position editor-x editor-y)))])))))
    (super-new)))

(define (at-most-200 s)
  (cond
    [(<= (string-length s) 200)
     s]
    [else (substring s 0 200)]))

(define delegatee-text<%>
  (interface ()
    set-start/end-para))

(define delegatee-text%
  (class* text:basic% (delegatee-text<%>)
    (define start-para #f)
    (define end-para #f)
    (define view-x-b (box 0))
    (define view-width-b (box 0))
    (inherit get-admin
             paragraph-start-position paragraph-end-position 
             position-location invalidate-bitmap-cache scroll-to-position
             get-visible-position-range position-paragraph
             last-position)
    
    (define/override (on-new-string-snip)
      (instantiate text:1-pixel-string-snip% ()))
    
    (define/override (on-new-tab-snip)
      (instantiate text:1-pixel-tab-snip% ()))
    
    ;; set-start/end-para : (union (#f #f -> void) (number number -> void))
    (define/public (set-start/end-para _start-para _end-para)
      (unless (and (equal? _start-para start-para)
                   (equal? _end-para end-para))
        (let ([old-start-para start-para]
              [old-end-para end-para])
          (cond
            [else
             (set! start-para _start-para)
             (set! end-para _end-para)])
          
          (when (and start-para end-para)
            
            (let-values ([(v-start v-end) (let ([bs (box 0)]
                                                [bf (box 0)])
                                            (get-visible-position-range bs bf)
                                            (values (unbox bs)
                                                    (unbox bf)))])
              (let ([v-start-para (position-paragraph v-start)]
                    [v-end-para (position-paragraph v-end)])
                (cond
                  [(v-start-para . >= . start-para)
                   (scroll-to-position (paragraph-start-position start-para))]
                  [(v-end-para . <= . end-para)
                   (scroll-to-position (paragraph-end-position end-para))]
                  [else (void)]))))
          (define the-l #f)
          (define the-t #f)
          (define the-r #f)
          (define the-b #f)
          (when (and old-start-para old-end-para)
            (let-values ([(x y w h) (get-rectangle old-start-para old-end-para)])
              (when x
                (set! the-l x)
                (set! the-t y)
                (set! the-r (+ x w))
                (set! the-b (+ y h)))))
          (when (and start-para end-para)
            (let-values ([(x y w h) (get-rectangle start-para end-para)])
              (cond
                [(and x the-l)
                 (set! the-l (min x the-l))
                 (set! the-t (min y the-t))
                 (set! the-r (max the-r (+ x w)))
                 (set! the-b (max the-b (+ y h)))]
                [x
                 (set! the-l x)
                 (set! the-t y)
                 (set! the-r (+ x w))
                 (set! the-b (+ y h))])))
          (when the-l
            (invalidate-bitmap-cache the-l the-t (- the-r the-l) (- the-b the-t))))))
    
    (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
      (when (and before?
                 start-para
                 end-para)
        (let ([old-pen (send dc get-pen)]
              [old-brush (send dc get-brush)])
          (send dc set-pen
                (send the-pen-list find-or-create-pen 
                      (preferences:get 'framework:delegatee-overview-color)
                      1
                      'solid))
          (send dc set-brush
                (send the-brush-list find-or-create-brush 
                      (preferences:get 'framework:delegatee-overview-color)
                      'solid))
          (let-values ([(x y w h) (get-rectangle start-para end-para)])
            (when x
              (send dc draw-rectangle 
                    (+ dx x)
                    (+ dy y)
                    w
                    h)))
          (send dc set-pen old-pen)
          (send dc set-brush old-brush)))
      (super on-paint before? dc left top right bottom dx dy draw-caret))
    
    
    ;; get-rectangle : number number -> 
    ;;                (values (union #f number) (union #f number) (union #f number) (union #f number))
    ;; computes the rectangle corresponding the input paragraphs
    (define/private (get-rectangle start-para end-para)
      (let ([start (get-line-y start-para #t)]
            [end (get-line-y end-para #f)]
            [admin (get-admin)])
        (cond
          [(not admin)
           (values #f #f #f #f)]
          [(= 0 (last-position))
           (values #f #f #f #f)]
          [else
           (send admin get-view view-x-b #f view-width-b #f)
           (send admin get-view view-x-b #f view-width-b #f)
           (values (unbox view-x-b)
                   start
                   (unbox view-width-b)
                   (- end start))])))
    
    (define/private (get-line-y para top?)
      (let ([pos (paragraph-start-position para)]
            [b (box 0)])
        (position-location pos #f b top? #f #t)
        (unbox b)))
    (super-new)
    
    (inherit set-cursor)
    (set-cursor (make-object cursor% 'arrow))
    
    (inherit set-line-spacing)
    (set-line-spacing 0)))

(define delegate-mixin
  (mixin (status-line<%> text<%>) (delegate<%>)
    
    (define delegated-text #f)
    (define/public-final (get-delegated-text) delegated-text)
    (define/public-final (set-delegated-text t) 
      (unless (or (not t) (is-a? t text:delegate<%>))
        (error 'set-delegated-text 
               "expected either #f or a text:delegate<%> object, got ~e" 
               t))
      (unless (eq? delegated-text t)
        (set! delegated-text t)
        (when shown?
          (unless (send (get-delegated-text) get-delegate)
            (send (get-delegated-text) set-delegate 
                  (new delegatee-text%)))
          (send delegate-ec set-editor (send (get-delegated-text) get-delegate)))))
    
    [define rest-panel 'uninitialized-root]
    [define super-root 'uninitialized-super-root]
    [define/override make-root-area-container
      (λ (% parent)
        (let* ([s-root (super make-root-area-container
                              horizontal-pane%
                              parent)]
               [r-root (make-object % s-root)])
          (set! super-root s-root)
          (set! rest-panel r-root)
          r-root))]
    
    (define/override (get-editor<%>)
      text:delegate<%>)
    
    (define/override (get-editor%)
      (text:delegate-mixin (super get-editor%)))
    
    (field (shown? (preferences:get 'framework:show-delegate?)))
    (define/public (delegated-text-shown?) 
      shown?)
    
    (inherit close-status-line open-status-line)
    (define/public (hide-delegated-text)
      (set! shown? #f)
      (when delegated-text 
        (send delegated-text set-delegate #f))
      (send delegate-ec set-editor #f)
      (send super-root change-children
            (λ (l) (list rest-panel))))
    (define/public (show-delegated-text)
      (set! shown? #t)
      (when delegated-text
        (unless (send delegated-text get-delegate)
          (send delegated-text set-delegate 
                (new delegatee-text%)))
        (send delegate-ec set-editor (send (get-delegated-text) get-delegate)))
      (send super-root change-children
            (λ (l) (list rest-panel delegate-ec))))
    
    (define/public (click-in-overview pos)
      (when shown?
        (let* ([d-canvas (send delegated-text get-canvas)]
               [bx (box 0)]
               [by (box 0)])
          (let-values ([(cw ch) (send d-canvas get-client-size)])
            (send delegated-text position-location pos bx by)
            (send d-canvas focus)
            (send d-canvas scroll-to 
                  (- (unbox bx) (/ cw 2))
                  (- (unbox by) (/ ch 2))
                  cw
                  ch
                  #t)
            (send delegated-text set-position pos)))))
    
    (define/public (delegate-moved)
      (define delegatee (send delegate-ec get-editor))
      (when delegatee
        (let ([startb (box 0)]
              [endb (box 0)])
          (send delegated-text get-visible-position-range startb endb #f)
          (send delegatee set-start/end-para
                (send delegated-text position-paragraph (unbox startb)) 
                (send delegated-text position-paragraph (unbox endb))))))
    
    (define/public (get-delegatee) (send delegate-ec get-editor))
        
    (super-new)
    
    (define delegate-ec (new delegatee-editor-canvas%
                             [parent super-root]
                             [delegate-frame this]
                             [min-width 150]
                             [stretchable-width #f]))
    (inherit get-editor)
    (if (preferences:get 'framework:show-delegate?)
        (show-delegated-text)
        (hide-delegated-text))))

(define searchable<%> (interface (basic<%>)
                        search
                        search-replace
                        replace-all
                        
                        get-text-to-search
                        set-text-to-search
                        
                        search-hidden?
                        hide-search
                        unhide-search

                        get-case-sensitive-search?
                        search-hits-changed
                        ))

(define old-search-highlight void)
(define (clear-search-highlight)
  (old-search-highlight)
  (set! old-search-highlight void))

(define find/replace-text%
  (class (text:foreground-color-mixin  text:keymap%)
    (init-field pref-sym)
    (inherit get-canvas get-text last-position insert find-first-snip
             get-admin invalidate-bitmap-cache
             begin-edit-sequence end-edit-sequence get-top-level-window)
    (define/augment (after-insert x y)
      (update-prefs)
      (inner (void) after-insert x y))
    (define/augment (after-delete x y)
      (update-prefs)
      (inner (void) after-delete x y))
    (define timer #f)
    (define/private (update-prefs)
      (unless timer
        (set! timer (new timer%
                         [notify-callback
                          (λ ()
                            (preferences:set pref-sym
                                             (let loop ([snip (find-first-snip)])
                                               (cond
                                                 [(not snip) '()]
                                                 [(is-a? snip string-snip%)
                                                  (cons (send snip get-text 0 (send snip get-count))
                                                        (loop (send snip next)))]
                                                 [else (cons snip (loop (send snip next)))]))))])))
      (send timer stop)
      (send timer start 150 #t))
    (define/override (get-keymaps)
      (editor:add-after-user-keymap search/replace-keymap (super get-keymaps)))
    (super-new)
    (inherit set-styles-fixed)
    (set-styles-fixed #t)
    (begin-edit-sequence)
    (for-each
     (λ (x) (insert x (last-position) (last-position)))
     (preferences:get pref-sym))
    (end-edit-sequence)
    
    (define pref-callback 
      (λ (p v)
        (let ([c (get-canvas)])
          (when (and c (send c get-line-count))
            (send c set-editor (send c get-editor))))))
    
    (preferences:add-callback 'framework:standard-style-list:font-size pref-callback #t)))

(define find-text%
  (class find/replace-text%
    (inherit get-canvas get-text last-position insert find-first-snip
             get-admin invalidate-bitmap-cache run-after-edit-sequence
             begin-edit-sequence end-edit-sequence get-top-level-window)
    
    (define/private (get-case-sensitive-search?)
      (let ([frame (get-top-level-window)])
        (and frame
             (send frame get-case-sensitive-search?))))

    (define/override (on-focus on?)  
      (let ([frame (get-top-level-window)])
        (when frame
          (let ([text-to-search (send frame get-text-to-search)])
            (when text-to-search
              (when on?
                (send text-to-search set-search-anchor (send text-to-search get-start-position)))))))
      (super on-focus on?))
    
    (define/augment (after-insert x y)
      (update-searching-str/trigger-jump)
      (inner (void) after-insert x y))
    (define/augment (after-delete x y)
      (update-searching-str/trigger-jump)
      (inner (void) after-delete x y))
    (define/private (update-searching-str/trigger-jump)
      (let ([tlw (get-top-level-window)])
        (when tlw
          (send tlw search-string-changed)))
      
      ;; trigger-jump
      (when (preferences:get 'framework:anchored-search)
        (let ([frame (get-top-level-window)])
          (when frame
            (let ([text-to-search (send frame get-text-to-search)])
              (when text-to-search
                (let ([anchor-pos (send text-to-search get-anchor-pos)])
                  (when anchor-pos
                    (cond
                      [(equal? "" (get-text))
                       (send text-to-search set-position anchor-pos anchor-pos)]
                      [else
                       (search 'forward #t #t #f anchor-pos)])))))))))

    
    (define/private (get-searching-text)
      (let ([frame (get-top-level-window)])
        (and frame
             (send frame get-text-to-search))))
    (define/public (search [searching-direction 'forward] 
                           [beep? #t]
                           [wrap? #t]
                           [move-anchor? #t]
                           [search-start-position #f])
      (let* ([string (get-text)]
             [top-searching-edit (get-searching-text)])
        (when top-searching-edit
          (let ([searching-edit
                 (let loop ([txt top-searching-edit])
                   (define focus-snip (send txt get-focus-snip))
                   (cond
                     [(and focus-snip (is-a? focus-snip editor-snip%))
                      (loop (send focus-snip get-editor))]
                     [else txt]))]
                
                [not-found
                 (λ (found-edit skip-beep?)
                   (when (and beep?
                              (not skip-beep?))
                     (bell))
                   #f)]
                [found
                 (λ (text first-pos)
                   (define (thunk)
                     (define last-pos ((if (eq? searching-direction 'forward) + -)
                                       first-pos (string-length string)))
                     (define start-pos (min first-pos last-pos))
                     (define end-pos (max first-pos last-pos))
                     
                     (send text begin-edit-sequence #t #f)
                     (send text set-caret-owner #f 'display)
                     (send text set-position start-pos end-pos #f #f 'local)
                     
                     
                     ;; scroll to the middle if the search result isn't already visible
                     (let ([search-result-line (send text position-line (send text get-start-position))]
                           [bt (box 0)]
                           [bb (box 0)])
                       (send text get-visible-line-range bt bb #f)
                       (unless (< (unbox bt) search-result-line (unbox bb))
                         (let* ([half (sub1 (quotient (- (unbox bb) (unbox bt)) 2))]
                                [last-pos (send text position-line (send text last-position))]
                                [top-pos (send text line-start-position 
                                               (max (min (- search-result-line half) last-pos) 0))]
                                [bottom-pos (send text line-start-position 
                                                  (max 0
                                                       (min (+ search-result-line half)
                                                            last-pos)))])
                           (send text scroll-to-position 
                                 top-pos
                                 #f
                                 bottom-pos))))
                     
                     (when move-anchor?
                       (when (is-a? text text:searching<%>)
                         (send text set-search-anchor
                               (if (eq? searching-direction 'forward)
                                   end-pos
                                   start-pos))))
                     
                     (send text end-edit-sequence))
                   
                   (define owner (or (send text get-active-canvas)
                                     (send text get-canvas)))
                   (if owner
                       (send owner call-as-primary-owner thunk)
                       (thunk))
                   #t)])
            
            (if (string=? string "")
                (not-found top-searching-edit #t)
                (let-values ([(found-edit first-pos)
                              (find-string-embedded
                               (if search-start-position 
                                   top-searching-edit
                                   searching-edit)
                               string
                               searching-direction
                               (or search-start-position
                                   (if (eq? 'forward searching-direction)
                                       (send searching-edit get-end-position)
                                       (send searching-edit get-start-position)))
                               'eof #t
                               (get-case-sensitive-search?)
                               #t)])
                  (cond
                    [(not first-pos)
                     (if wrap?
                         (begin
                           (let-values ([(found-edit pos)
                                         (find-string-embedded
                                          top-searching-edit
                                          string 
                                          searching-direction
                                          (if (eq? 'forward searching-direction)
                                              0
                                              (send searching-edit last-position))
                                          'eof #t
                                          (get-case-sensitive-search?)
                                          #f)])
                             (if (not pos)
                                 (not-found found-edit #f)
                                 (found found-edit pos))))
                         (not-found found-edit #f))]
                    [else
                     (found found-edit first-pos)])))))))

    (define/override (on-paint before dc left top right bottom dx dy draw-caret?)
      (super on-paint before dc left top right bottom dx dy draw-caret?)
      (when before
        (let ([canvas (get-canvas)])
          (when (and canvas
                     (send canvas is-red?))
            (let-values ([(view-x view-y view-width view-height)
                          (let ([b1 (box 0)]
                                [b2 (box 0)]
                                [b3 (box 0)]
                                [b4 (box 0)])
                            (send (get-admin) get-view b1 b2 b3 b4)
                            (values (unbox b1)
                                    (unbox b2)
                                    (unbox b3)
                                    (unbox b4)))])
              (let ([pen (send dc get-pen)]
                    [brush (send dc get-brush)])
                (send dc set-pen "black" 1 'transparent)
                (send dc set-brush
                      (color-prefs:lookup-in-color-scheme
                       'framework:failed-search-background-color)
                      'solid)
                (send dc draw-rectangle (+ dx view-x) (+ view-y dy) view-width view-height)
                (send dc set-pen pen)
                (send dc set-brush brush)))))))
    
    (super-new [pref-sym 'framework:search-string])))

(define replace-text%
  (class find/replace-text%
    (inherit set-styles-fixed)
    (super-new [pref-sym 'framework:replace-string])
    (define/override (get-keymaps)
      (editor:add-after-user-keymap search/replace-keymap (super get-keymaps)))
    (set-styles-fixed #t)))

(define search/replace-keymap (new keymap%))
(send search/replace-keymap map-function "tab" "switch-between-search-and-replace")
(send search/replace-keymap add-function "switch-between-search-and-replace"
      (λ (text evt)
        (let ([find-txt (send (send text get-top-level-window) get-find-edit)]
              [replace-txt (send (send text get-top-level-window) get-replace-edit)])
          (cond
            [(eq? find-txt text)
             (send replace-txt set-position 0 (send replace-txt last-position))
             (send (send replace-txt get-canvas) focus)]
            [(eq? replace-txt text)
             (send find-txt set-position 0 (send find-txt last-position))
             (send (send find-txt get-canvas) focus)]))))

(send search/replace-keymap map-function "return" "next")
(send search/replace-keymap add-function "next"
      (λ (text evt)
        (send (send text get-top-level-window) search 'forward)))

(send search/replace-keymap map-function "s:return" "prev")
(send search/replace-keymap add-function "prev"
      (λ (text evt)
        (send (send text get-top-level-window) search 'backward)))

(send search/replace-keymap map-function "c:return" "insert-return")
(send search/replace-keymap map-function "a:return" "insert-return")
(send search/replace-keymap add-function "insert-return"
      (λ (text evt)
        (send text insert "\n")))

(send search/replace-keymap map-function "esc" "hide-search")
(send search/replace-keymap add-function "hide-search"
      (λ (text evt)
        (let ([tlw (send text get-top-level-window)])
          (when tlw
            (send tlw hide-search)))))

(send search/replace-keymap map-function "c:g" "hide-search-and-snap-back")
(send search/replace-keymap add-function "hide-search-and-snap-back"
      (λ (text evt)
        (let ([tlw (send text get-top-level-window)])
          (when tlw
            (when (preferences:get 'framework:anchored-search)
              (let ([text-to-search (send tlw get-text-to-search)])
                (when text-to-search
                  (let ([anchor-pos (send text-to-search get-anchor-pos)])
                    (when anchor-pos 
                      (send text-to-search set-position anchor-pos))))))
            (send tlw hide-search)))))

(send search/replace-keymap map-function "f3" "unhide-search-and-toggle-focus")
(send search/replace-keymap add-function "unhide-search-and-toggle-focus"
      (λ (text evt)
        (let ([tlw (send text get-top-level-window)])
          (when tlw
            (send tlw unhide-search-and-toggle-focus)))))

(define searchable-canvas% 
  (class (canvas:color-mixin canvas:basic%)
    (inherit refresh get-dc get-client-size)
    (define red? #f)
    (define/public (is-red?) red?)
    (define/public (set-red r?)
      (unless (equal? red? r?)
        (set! red? r?)
        (refresh)))
    (define/override (on-paint)
      (when red?
        (let ([dc (get-dc)])
          (let-values ([(cw ch) (get-client-size)])
            (let ([pen (send dc get-pen)]
                  [brush (send dc get-brush)])
              (send dc set-pen "black" 1 'transparent)
              (send dc set-brush
                    (color-prefs:lookup-in-color-scheme
                     'framework:failed-search-background-color)
                    'solid)
              (send dc draw-rectangle 0 0 cw ch)
              (send dc set-pen pen)
              (send dc set-brush brush)))))
      (super on-paint))
    (super-new)))

(define-local-member-name 
  update-matches 
  get-find-edit
  get-replace-edit
  search-string-changed)

(define searchable-mixin
  (mixin (standard-menus<%>) (searchable<%>)
    (inherit edit-menu:get-show/hide-replace-item)
    
    (define super-root 'unitiaialized-super-root)
    
    (define case-sensitive-search? (preferences:get 'framework:case-sensitive-search?))
    (define/public (get-case-sensitive-search?) case-sensitive-search?)
    (define replace-visible? (preferences:get 'framework:replace-visible?))
  
    (define/override (edit-menu:find-callback menu evt) (unhide-search-and-toggle-focus) #t)
    (define/override (edit-menu:create-find?) #t)

    (define/override (edit-menu:find-from-selection-callback menu evt) 
      (unhide-search-and-toggle-focus #:new-search-string-from-selection? #t)
      #t)
    (define/override (edit-menu:find-from-selection-on-demand item)
      (define t (get-text-to-search))
      (send item enable (and t (not (= (send t get-start-position)
                                       (send t get-end-position))))))
    (define/override (edit-menu:create-find-from-selection?) #t)
    
    (define/override (edit-menu:find-next-callback menu evt) (search 'forward) #t)
    (define/override (edit-menu:create-find-next?) #t)
    
    (define/override (edit-menu:find-previous-callback menu evt) (search 'backward) #t)
    (define/override (edit-menu:create-find-previous?) #t)
    
    (define/override (edit-menu:create-show/hide-replace?) #t)
    (define/override (edit-menu:show/hide-replace-callback a b) 
      (cond
        [hidden?
         (unhide-search #f)
         (set-replace-visible? #t)
         (send replace-edit set-position 0 (send replace-edit last-position))
         (send (send replace-edit get-canvas) focus)]
        [else
         (set-replace-visible? (not replace-visible?))
         (when replace-visible?
           (send replace-edit set-position 0 (send replace-edit last-position))
           (send (send replace-edit get-canvas) focus))])
      #t)
    (define/override (edit-menu:show/hide-replace-string)
      (if replace-visible?
          (string-constant hide-replace-menu-item)
          (string-constant show-replace-menu-item)))
    (define/override (edit-menu:show/hide-replace-on-demand item) 
      (send item set-label
            (if (and (not hidden?) replace-visible?)
                (string-constant hide-replace-menu-item)
                (string-constant show-replace-menu-item))))
    
    (define/override (edit-menu:replace-callback a b) (search-replace) #t)
    (define/override (edit-menu:create-replace?) #t)
    (define/override (edit-menu:replace-on-demand item) 
      (send item enable (and (not hidden?) replace-visible?)))

    (define/override (edit-menu:find-case-sensitive-callback menu evt) 
      (set! case-sensitive-search? (not case-sensitive-search?))
      (preferences:set 'framework:case-sensitive-search? case-sensitive-search?)
      (when find-edit
        (unless hidden?
          (search-string-changed))))
    (define/override (edit-menu:find-case-sensitive-on-demand item) (send item check case-sensitive-search?))
    (define/override (edit-menu:create-find-case-sensitive?) #t)

    (define/override (edit-menu:replace-all-callback menu evt) (replace-all) #t)
    (define/override (edit-menu:replace-all-on-demand item)
      (send item enable (and find-edit
                             (not (string=? (send find-edit get-text) ""))
                             (not hidden?)
                             replace-visible?)))
    (define/override (edit-menu:create-replace-all?) #t)

    (define/override make-root-area-container
      (λ (% parent)
        (let* ([s-root (super make-root-area-container
                              vertical-pane%
                              parent)]
               [root (make-object % s-root)])
          (set! super-root s-root)
          root)))

    (define/override (on-activate on?)
      (super on-activate on?)
      (when on?
        (try-to-update-canvas-in-case-font-size-changed)))

    (define text-to-search #f)
    (define/public-final (get-text-to-search) text-to-search)

    (define/public-final (set-text-to-search new)
      (unless (or (not new) (is-a? new text:searching<%>))
        (raise-argument-error 'set-text-to-search
                              (format "~s" '(or/c (is-a?/c text:searching<%>) #f))
                              new))
      (unless (eq? new text-to-search)
        (let ([old text-to-search])
          (set! text-to-search new)
          (unless hidden?
            (when find-edit
              (when old
                (send old set-searching-state #f #f #f #f)
                (send old set-search-anchor #f))
              (when new
                (send new set-search-anchor (send new get-start-position))
                (search-parameters-changed)))))))
    
    ;; called by the text-to-search when it finishes the search
    (define/public-final (search-hits-changed)
      (when find-edit
        (when text-to-search
          (let-values ([(before-caret-new-hits new-hits) (send text-to-search get-search-hit-count)])
            (update-matches before-caret-new-hits new-hits)
            (let ([is-red? (and (zero? new-hits) 
                                (not (zero? (send find-edit last-position))))])
              (send find-canvas set-red is-red?))))))

    (define/public-final (search-string-changed) (search-parameters-changed))
    (define/private (search-parameters-changed)
      (let ([str (send find-edit get-text)])
        (when text-to-search
          (send text-to-search set-searching-state
                (if (equal? str "") #f str)
                case-sensitive-search?
                replace-visible?
                #t))))
    
    (define/public (search-hidden?) hidden?)
    
    (define/public (hide-search)
      (set! hidden? #t)
      (when search-gui-built?
        (when text-to-search
          (send text-to-search set-searching-state #f #f #f #f))
        (send super-root change-children
              (λ (l)
                (remove search/replace-panel l)))
        (clear-search-highlight)
        (when text-to-search
          (send text-to-search set-search-anchor #f)
          (let ([canvas (send text-to-search get-canvas)])
            (when canvas
              (send canvas focus))))))
    
    (define/public (unhide-search focus? #:new-search-string-from-selection? [new-search-string-from-selection? #f])
      (when hidden?
        (set! hidden? #f)
        (build-search-gui-in-frame)
        (unless (memq search/replace-panel (send super-root get-children))
          (send super-root add-child search/replace-panel))
        (search-parameters-changed)
        (send find-edit begin-edit-sequence #t #f)
        (when new-search-string-from-selection?
          (update-search-string-from-selection))
        (when focus?
          (send find-edit set-position 0 (send find-edit last-position))
          (send (send find-edit get-canvas) focus))
        (try-to-update-canvas-in-case-font-size-changed)
        (send find-edit end-edit-sequence)))

    (define/private (try-to-update-canvas-in-case-font-size-changed)
      (when find-edit
        (define c (send find-edit get-canvas))
        (when (and c (send c get-line-count))
          (send c set-editor (send c get-editor)))))

    (define/public (unhide-search-and-toggle-focus #:new-search-string-from-selection? [new-search-string-from-selection? #f])
      (if hidden?
        (unhide-search #t #:new-search-string-from-selection? new-search-string-from-selection?)
        (let ([canvas (and text-to-search (send text-to-search get-canvas))])
          (cond
            [(or (not text-to-search) (and canvas (send canvas has-focus?)))
             (send find-edit begin-edit-sequence #t #f)
             (when new-search-string-from-selection?
               (update-search-string-from-selection))
             (send find-edit set-position 0 (send find-edit last-position))
             (send find-canvas focus)
             (send find-edit end-edit-sequence)]
            [canvas
             (send canvas focus)]))))
    
    (define/private (update-search-string-from-selection)
      (when (and text-to-search
                 (not (= (send text-to-search get-start-position)
                         (send text-to-search get-end-position))))
        (send find-edit delete 0 (send find-edit last-position))
        (send text-to-search move/copy-to-edit 
              find-edit 
              (send text-to-search get-start-position)
              (send text-to-search get-end-position)
              0
              #:try-to-move? #f)))
    
    (define/public (search searching-direction)
      (unhide-search #f)
      (send find-edit search searching-direction #t))
    
    (define/public (search-replace)
      (define text-to-search (get-text-to-search))
      (when text-to-search
        (define replacee-start-or-pair (send text-to-search get-replace-search-hit))
        (when replacee-start-or-pair
          (define-values (text-to-replace-in replacee-start)
            (cond
              [(pair? replacee-start-or-pair)
               (values (car replacee-start-or-pair) (cdr replacee-start-or-pair))]
              [else (values text-to-search replacee-start-or-pair)]))
          (define replacee-end (+ replacee-start (send find-edit last-position)))
          (send text-to-replace-in begin-edit-sequence)
          (send text-to-search begin-edit-sequence)
          (send text-to-replace-in set-position replacee-end replacee-end)
          (send text-to-replace-in delete replacee-start replacee-end)
          (copy-over replace-edit
                     0 (send replace-edit last-position)
                     text-to-replace-in
                     replacee-start)
          (search 'forward)
          (send text-to-search finish-pending-search-work)
          (send text-to-search end-edit-sequence)
          (send text-to-replace-in end-edit-sequence))))
      
    (define/private (copy-over src-txt src-start src-end dest-txt dest-pos)
      (send src-txt split-snip src-start)
      (send src-txt split-snip src-end)
      (let loop ([snip (send src-txt find-snip src-end 'before)])
        (cond
          [(or (not snip) (< (send src-txt get-snip-position snip) src-start))
           (void)]
          [else
           (let ([prev (send snip previous)])
             (send dest-txt insert (send snip copy) dest-pos dest-pos)
             (loop prev))])))
    
    (define/public (replace-all)
      (unhide-search #f)
      (let ([txt (get-text-to-search)])
        (when txt
          (let ([search-str (send find-edit get-text)]
                [ht (make-hasheq)])
            (send txt begin-edit-sequence)
            (hash-set! ht txt #t)
            (let loop ([txt (pop-all-the-way-out txt)]
                       [pos 0])
              (let-values ([(found-txt found-pos) (find-string-embedded txt
                                                                        search-str
                                                                        'forward
                                                                        pos
                                                                        'eof
                                                                        #f
                                                                        case-sensitive-search?
                                                                        #t)])
                (when found-pos
                  (unless (hash-ref ht found-txt #f)
                    (hash-set! ht found-txt #t)
                    (send found-txt begin-edit-sequence))
                  (let ([start (- found-pos (send find-edit last-position))])
                    (define revision-before (send found-txt get-revision-number))
                    (send found-txt delete start found-pos)
                    (define revision-after (send found-txt get-revision-number))
                    (unless (= revision-before revision-after)
                      (copy-over replace-edit 0 (send replace-edit last-position) found-txt start))
                    (loop found-txt (if (= revision-before revision-after)
                                        found-pos
                                        (+ start (send replace-edit last-position))))))))
            (hash-for-each ht (λ (txt _) (send txt end-edit-sequence)))))))
                             
    (define/private (pop-all-the-way-out txt)
      (let ([admin (send txt get-admin)])
        (if (is-a? admin editor-snip-editor-admin<%>)
            (let* ([snip (send admin get-snip)]
                   [edit-above (send (send snip get-admin) get-editor)])
              (pop-all-the-way-out edit-above))
            txt)))
    
    (define/private (find-embedded-focus-editor editor)
      (let loop ([editor editor])
        (let ([s (send editor get-focus-snip)])
          (cond
            [(and s (is-a? s editor-snip%))
             (let ([next-ed (send s get-editor)])
               (if next-ed 
                   (loop next-ed)
                   editor))]
            [else editor]))))
    
    (define search-gui-built? #f)
    (define search/replace-panel #f)
    (define find-canvas #f)
    (define replace-canvas #f)
    (define hidden? #t)
    (field [update-matches void])
    (define find-edit #f)
    (define replace-edit #f)
    
    (define/public (get-find-edit) find-edit)
    (define/public (get-replace-edit) replace-edit)
    
    (inherit begin-container-sequence end-container-sequence)
    
    (define/public (get-replace-visible?) replace-visible?)
    (define/public (set-replace-visible? r?) 
      (unless (equal? replace-visible? r?)
        (set! replace-visible? r?)
        (preferences:set 'framework:replace-visible? r?)
        (show/hide-replace)
        (send (edit-menu:get-show/hide-replace-item) set-label
              (if replace-visible?
                  (string-constant hide-replace-menu-item)
                  (string-constant show-replace-menu-item)))
        (search-parameters-changed)))
    
    (define show/hide-replace void)
    
    (define/private (build-search-gui-in-frame)
      (unless search-gui-built?
        (set! search-gui-built? #t)
        (begin-container-sequence)
        (set! find-edit (new find-text%))
        (set! replace-edit (new replace-text%))
        (set! search/replace-panel (new-horizontal-panel% 
                                        [parent super-root]
                                        [stretchable-height #f]))
        (define search-panel
          (new-horizontal-panel% 
               [parent search/replace-panel]
               [stretchable-height #f]))
        (define replace-panel
          (new-horizontal-panel%
               [parent search/replace-panel]
               [stretchable-height #f]))
        (set! find-canvas (new searchable-canvas%
                               [style '(hide-hscroll hide-vscroll)]
                               [vertical-inset 2]
                               [parent search-panel]
                               [editor find-edit]
                               [line-count 1]
                               [stretchable-height #f]
                               [stretchable-width #t]))
        (set! replace-canvas (new searchable-canvas%
                                  [style '(hide-hscroll hide-vscroll)]
                                  [vertical-inset 2]
                                  [parent replace-panel]
                                  [editor replace-edit]
                                  [line-count 1]
                                  [stretchable-height #f]
                                  [stretchable-width #t]))
        
        (define search-button (new button% 
                                   [label (string-constant search-next)]
                                   [vert-margin 0]
                                   [parent search-panel]
                                   [callback (λ (x y) (search 'forward))]
                                   [font small-control-font]))
        (define search-prev-button (new button% 
                                        [label (string-constant search-previous)]
                                        [vert-margin 0]
                                        [parent search-panel]
                                        [callback (λ (x y) (search 'backward))]
                                        [font small-control-font]))
        
        (define hits-panel (new-vertical-panel%
                                [parent search-panel]
                                [alignment '(left center)]
                                [stretchable-height #f]
                                [stretchable-width #f]))
        
        (define num-msg (new message% 
                             [label "0"] 
                             [vert-margin 0]
                             [auto-resize #t]
                             [font tiny-control-font]
                             [parent hits-panel]))
        (define matches-msg (new message% 
                                 [label (string-constant search-matches)]
                                 [vert-margin 0]
                                 [font tiny-control-font]
                                 [parent hits-panel]))
        
        (define _6 (set! update-matches
                         (λ (before-caret-m m) 
                           (cond
                             [(zero? m)
                              (send num-msg set-label "0")]
                             [else
                              (let ([number (number->str/comma m)]
                                    [bc-number (number->str/comma before-caret-m)])
                                (send num-msg set-label (format "~a/~a" bc-number number)))])
                           (send matches-msg set-label (if (= m 1) 
                                                           (string-constant search-match)
                                                           (string-constant search-matches))))))
        
        (define replace-button
          (new button% 
               [label (string-constant search-replace)]
               [vert-margin 0]
               [parent replace-panel]
               [font small-control-font]
               [callback (λ (x y) (search-replace))]))
        (define skip-button
          (new button% 
               [label (string-constant search-skip)]
               [vert-margin 0]
               [parent replace-panel]
               [font small-control-font]
               [callback (λ (x y) (search 'forward))]))
        
        (define show-replace-button
          (new button%
               [label (string-constant search-show-replace)]
               [font small-control-font]
               [callback (λ (a b) (set-replace-visible? #t))]
               [parent replace-panel]))
        (define hide-replace-button
          (new button%
               [label (string-constant search-hide-replace)]
               [font small-control-font]
               [callback (λ (a b) (set-replace-visible? #f))]
               [parent replace-panel]))
        
        (set! show/hide-replace
              (λ ()
                (send replace-panel begin-container-sequence)
                (cond
                  [replace-visible?
                   (send replace-panel change-children (λ (l) all-replace-children))
                   (send replace-panel stretchable-width #t)]
                  [else
                   (send replace-panel change-children (λ (l) (list show-replace-button)))
                   (send replace-panel stretchable-width #f)])
                (send replace-panel end-container-sequence)))
        
        (define all-replace-children
          (list replace-canvas
                replace-button
                skip-button
                hide-replace-button))
        
        (define hide-button
          (new close-icon%
               [callback (λ () (hide-search))]
               [vertical-pad 0]
               [parent search/replace-panel]))
        
        (show/hide-replace)
        (end-container-sequence)))
    
    (super-new)))

(define (number->str/comma m)
  (list->string
   (reverse
    (let loop ([chars (reverse (string->list (format "~a" m)))])
      (cond
        [(<= (length chars) 3)
         chars]
        [else (list* (list-ref chars 0)
                     (list-ref chars 1)
                     (list-ref chars 2)
                     #\,
                     (loop (cdddr chars)))])))))

(define searchable-text<%> (interface (searchable<%> text<%>)))

(define searchable-text-mixin
  (mixin (text<%> searchable<%>) (searchable-text<%>)
    (inherit get-editor)
    (define/override (get-editor<%>) text:searching<%>)
    (define/override (get-editor%) (text:searching-mixin (super get-editor%)))
    (super-new)))

(define gc-off-canvas%
  (class canvas%
    (inherit get-dc)
    (define/override (on-paint)
      (send (get-dc) draw-bitmap (icon:get-gc-off-bitmap) 0 0))
    (super-new)))

(define pref-save-canvas%
  (class canvas%
    (define on? #f)
    
    (define mouse-over? #f)
    (define mouse-down? #f)
    
    (define/private (update-mouse-over? mo?)
      (unless (eq? mouse-over? mo?)
        (set! mouse-over? mo?)
        (refresh)))
    (define/private (update-mouse-down? md?)
      (unless (eq? mouse-down? md?)
        (set! mouse-down? md?)
        (refresh)))
    
    (define indicator "P")
    
    (inherit refresh)
    (define/override (on-event evt)
      (cond
        [(send evt entering?)
         (update-mouse-over? #t)]
        [(send evt leaving?)
         (update-mouse-over? #f)])
      (cond
        [(send evt button-down?)
         (update-mouse-down? #t)]
        [(send evt button-up?)
         (update-mouse-down? #f)
         (let-values ([(cw ch) (get-client-size)])
           (when (and (<= 0 (send evt get-x) cw)
                      (<= 0 (send evt get-y) ch))
             (show-prefs-stats)))]))
    
    (define/private (show-prefs-stats)
      (define f (new frame% 
                     [label (format "~a - Preferences Stats" (string-constant drscheme))]
                     [width 600]
                     [height 400]))
      (define t (new text%))
      (define ec (new editor-canvas% [parent f] [editor t]))
      (send f reflow-container)
      (send t begin-edit-sequence)
      (define tp (open-output-text-editor t))
      (define prefs-file (find-system-path 'pref-file))
      (fprintf tp "prefs file:\n  ~a\n\n" (path->string prefs-file))
      (fprintf tp "setting a preference:\n  ")
      (preferences:set 'drracket:prefs-debug #f)
      (parameterize ([current-output-port tp])
        (time (preferences:set 'drracket:prefs-debug #t)))
      (define file-contents (call-with-input-file prefs-file read))
      (fprintf tp "\n~s preference keys\n\n" (length file-contents))
      
      (fprintf tp "preferences taking the most space:\n")
      (define sizes (map 
                     (λ (x) 
                       (list 
                        (car x)
                        (bytes-length (string->bytes/utf-8 (format "~s" x)))))
                     file-contents))
      (for ([frame (in-list (sort sizes > #:key cadr))]
            [x (in-range 0 10)])
        (define key (list-ref frame 0))
        (define size (list-ref frame 1))
        (fprintf tp "  ~s (~s bytes)\n" key size))
      (send t auto-wrap #t)
      (send t set-position 0 0)
      (send t lock #t)
      (send t end-edit-sequence)
      (send f show #t))
    
    (define/override (on-paint)
      (define-values (cw ch) (get-client-size))
      (define dc (get-dc))
      (define (draw-p)
        (send dc set-font small-control-font)
        (send dc draw-text indicator
              (- (/ cw 2) (/ indicator-width 2))
              (- (/ ch 2) (/ indicator-height 2))))
      (cond
        [on?
         (send dc set-text-foreground (get-label-foreground-color))
         (draw-p)]
        [mouse-over?
         (send dc set-brush (if mouse-down? "blue" "skyblue") 'solid)
         (send dc set-pen "black" 1 'transparent)
         (send dc draw-rectangle 0 0 cw ch)
         (send dc set-text-foreground (send the-color-database find-color "white"))
         (draw-p)]))
    
    (define/public (set-on? new-on?)
      (set! on? new-on?)
      (send (get-dc) erase)
      (on-paint)
      (flush))
    
    (inherit get-dc flush get-client-size min-width min-height)
    (super-new [stretchable-width #f]
               [stretchable-height #f]
               [style '(transparent no-focus)])
    
    (send (get-dc) set-smoothing 'smoothed)
    (define-values (indicator-width indicator-height)
      (let-values ([(tw th _1 _2) (send (get-dc) get-text-extent indicator small-control-font)])
        (values tw th)))
    (min-width (+ (inexact->exact (ceiling indicator-width)) 4))
    (min-height (+ (inexact->exact (ceiling indicator-height)) 4))))

(define basic% (focus-table-mixin (register-group-mixin (basic-mixin frame%))))
(define size-pref% (size-pref-mixin basic%))
(define info% (info-mixin basic%))
(define text-info% (text-info-mixin info%))
(define pasteboard-info% (pasteboard-info-mixin text-info%))
(define status-line% (status-line-mixin text-info%))
(define standard-menus% (standard-menus-mixin status-line%))
(define editor% (editor-mixin standard-menus%))

(define -text% (text-mixin editor%))
(define searchable% (searchable-text-mixin (searchable-mixin -text%)))
(define delegate% (delegate-mixin searchable%))

(define -pasteboard% (pasteboard-mixin editor%))