#lang scheme/unit

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

(require string-constants
         scheme/class
         mred/mred-sig
         syntax-color/module-lexer
         "collapsed-snipclass-helpers.ss"
         "sig.ss"
         "../gui-utils.ss"
         "../preferences.ss"
         scheme/match)

(import mred^
        [prefix preferences: framework:preferences^]
        [prefix icon: framework:icon^]
        [prefix keymap: framework:keymap^]
        [prefix text: framework:text^]
        [prefix editor: framework:editor^]
        [prefix frame: framework:frame^]
        [prefix comment-box: framework:comment-box^]
        [prefix mode: framework:mode^]
        [prefix color: framework:color^]
        [prefix color-prefs: framework:color-prefs^]
        [prefix finder: framework:finder^])

(export (rename framework:scheme^
                [-text-mode<%> text-mode<%>]
                [-text<%> text<%>]
                [-text% text%]))

(init-depend mred^ framework:keymap^ framework:color^ framework:mode^
             framework:text^ framework:editor^)

(define (scheme-paren:get-paren-pairs)
  '(("(" . ")")
    ("[" . "]")
    ("{" . "}")))

(define text-balanced? 
  (lambda (text [start 0] [in-end #f])
    (let* ([end (or in-end (send text last-position))]
           [port (open-input-text-editor text start end)])
      (with-handlers ([exn:fail:read:eof? (λ (x) #f)]
                      [exn:fail:read? (λ (x) #t)])
        (let ([first (read port)])
          (cond
            [(eof-object? first) #f]
            [else
             (let loop ()
               (let ([s (read port)])
                 (cond
                   [(eof-object? s) #t]
                   [else (loop)])))]))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                                                                  ;;
;;                           Sexp Snip                              ;;
;;                                                                  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

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

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

(define sexp-snipclass% (make-sexp-snipclass% sexp-snip%))

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

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

(keymap:add-to-right-button-menu
 (let ([old (keymap:add-to-right-button-menu)])
   (λ (menu text event)
     (old menu text event)
     (split/collapse-text menu text event)
     (void))))

;; split/collapse-text : (instanceof menu%) (instanceof editor<%>) (instanceof mouse-event%) -> void
(define (split/collapse-text menu text event)
  (when (and (is-a? text -text<%>)
             (not (send text is-frozen?))
             (not (send text is-stopped?)))
    (let* ([on-it-box (box #f)]
           [click-pos 
            (call-with-values
             (λ ()
               (send text dc-location-to-editor-location
                     (send event get-x)
                     (send event get-y)))
             (λ (x y)
               (send text find-position x y #f on-it-box)))]
           [snip (send text find-snip click-pos 'after)]
           [char (send text get-character click-pos)]
           [left? (memq char '(#\( #\{ #\[))]
           [right? (memq char '(#\) #\} #\]))])
      (cond
        [(and snip (is-a? snip sexp-snip<%>))
         (make-expand-item text snip menu)]
        [(not (unbox on-it-box))
         ;; clicking in nowhere land, just ignore
         (void)]
        [(or left? right?)
         ;; clicking on left or right paren
         (let* ([pos (if left?
                         click-pos
                         (+ click-pos 1))]
                [other-pos (if left?
                               (send text get-forward-sexp pos)
                               (send text get-backward-sexp pos))])
           (when other-pos
             (let ([left-pos (min pos other-pos)]
                   [right-pos (max pos other-pos)])
               (make-collapse-item text left-pos right-pos menu))))]
        [else 
         ;; clicking on some other text -> collapse containing sexp
         (let ([up-sexp (send text find-up-sexp click-pos)])
           (when up-sexp 
             (let ([fwd (send text get-forward-sexp up-sexp)])
               (make-collapse-item text up-sexp fwd menu))))]))))

;; make-expand-item : (instanceof text%) (instanceof sexp-snip<%>) (instanceof menu%) -> void
(define (make-expand-item text snip menu)
  (instantiate separator-menu-item% ()
    (parent menu))
  (instantiate menu-item% ()
    (parent menu)
    (label (string-constant expand-sexp))
    (callback (λ (item evt) (expand-from text snip)))))

;; expand-from : (instanceof text%) (instanceof sexp-snip<%>) -> void
(define (expand-from text snip)
  (let ([snips (send snip get-saved-snips)])
    (send text begin-edit-sequence)
    (let ([pos (send text get-snip-position snip)])
      (send text delete pos (+ pos 1))
      (let loop ([snips (reverse snips)])
        (cond
          [(null? snips) (void)]
          [else (send text insert (send (car snips) copy) pos pos)
                (loop (cdr snips))])))
    (send text end-edit-sequence)))

;; make-collapse-item : (instanceof text%) number number (instanceof menu%) -> void
;; adds a collapse menu item to the menu
(define (make-collapse-item text left-pos right-pos menu)
  (instantiate separator-menu-item% ()
    (parent menu))
  (instantiate menu-item% ()
    (parent menu)
    (label (string-constant collapse-sexp))
    (callback (λ (item evt)
                (collapse-from text left-pos right-pos)))))

(define (collapse-from text left-pos right-pos)
  (let ([left-bracket (send text get-character left-pos)]
        [right-bracket (send text get-character (- right-pos 1))])
    (send text begin-edit-sequence)
    (send text split-snip left-pos)
    (send text split-snip right-pos)
    (let ([snips (let loop ([snip (send text find-snip left-pos 'after)])
                   (cond
                     [(not snip) null]
                     [((send text get-snip-position snip) . >= . right-pos)
                      null]
                     [else (cons (send snip copy) (loop (send snip next)))]))])
      (send text delete left-pos right-pos)
      (send text insert (instantiate sexp-snip% () 
                          (left-bracket left-bracket)
                          (right-bracket right-bracket)
                          (saved-snips snips))
            left-pos left-pos)
      (send text end-edit-sequence))))


;                                            
;                                            
;                                            
;               ;  ;;;;                      
;              ;;  ;;;;                      
;    ;;;;    ;;;;; ;;;; ;;;    ;;;   ;;; ;;; 
;   ;;;;;;  ;;;;;; ;;;;;;;;;  ;;;;;  ;;;;;;; 
;  ;;;;;;;;  ;;;;  ;;;; ;;;; ;;;; ;; ;;;; ;; 
;  ;;;; ;;;  ;;;;  ;;;; ;;;; ;;;;;;; ;;;;    
;  ;;;;;;;;  ;;;;; ;;;; ;;;; ;;;;;   ;;;;    
;   ;;;;;;   ;;;;; ;;;; ;;;;  ;;;;;; ;;;;    
;    ;;;;     ;;;; ;;;; ;;;;   ;;;;  ;;;;    
;                                            
;                                            
;                                            


(define color-prefs-table
  (let ([constant-green (make-object color% 41 128 38)]
        [symbol-blue (make-object color% 38 38 128)])
    `((symbol ,symbol-blue ,(string-constant scheme-mode-color-symbol))
      (keyword ,symbol-blue ,(string-constant scheme-mode-color-keyword))
      (comment ,(make-object color% 194 116 31) ,(string-constant scheme-mode-color-comment))
      (string ,constant-green ,(string-constant scheme-mode-color-string))
      (constant ,constant-green ,(string-constant scheme-mode-color-constant))
      (parenthesis ,(make-object color% "brown") ,(string-constant scheme-mode-color-parenthesis))
      (error ,(make-object color% "red") ,(string-constant scheme-mode-color-error))
      (other ,(make-object color% "black") ,(string-constant scheme-mode-color-other)))))

(define white-on-black-color-prefs-table
  (let* ([sym/kwd (make-object color% 102 102 255)]
         [new-entries
          `((symbol ,sym/kwd)
            (keyword ,sym/kwd)
            (comment ,(make-object color% 249 148 40))
            (string ,(make-object color% 51 174 51))
            (constant ,(make-object color% 60 194 57))
            (parenthesis ,(make-object color% 151 69 43))
            (other ,(make-object color% "white")))])
    (map 
     (λ (line)
       (let ([new (assoc (car line) new-entries)])
         (if new
             (list* (car line)
                    (cadr new)
                    (cddr line))
             line)))
     color-prefs-table)))

(define (get-color-prefs-table) color-prefs-table)
(define (get-white-on-black-color-prefs-table) white-on-black-color-prefs-table)

(define (short-sym->pref-name sym) (string->symbol (short-sym->style-name sym)))
(define (xlate-sym-style sym) (case sym
                                [(sexp-comment) 'comment]
                                [else sym]))
(define sn-hash (make-hasheq))
(define (short-sym->style-name sym)
  (hash-ref sn-hash sym
            (λ ()
              (let ([s (format "framework:syntax-color:scheme:~a"
                               (xlate-sym-style sym))])
                (hash-set! sn-hash sym s)
                s))))

(define (add-coloring-preferences-panel)
  (color-prefs:add-to-preferences-panel
   "Racket"
   (λ (parent)
     (for-each
      (λ (line)
        (let ([sym (car line)])
          (color-prefs:build-color-selection-panel 
           parent
           (short-sym->pref-name sym)
           (short-sym->style-name sym)
           (caddr line))))
      color-prefs-table))))

(define-struct string/pos (string pos))

(define -text<%>
  (interface (text:basic<%> mode:host-text<%> color:text<%>)
    get-limit
    balance-parens
    tabify-on-return?
    tabify
    tabify-selection
    tabify-all
    insert-return
    box-comment-out-selection
    comment-out-selection
    uncomment-selection
    get-forward-sexp
    remove-sexp
    forward-sexp
    flash-forward-sexp
    get-backward-sexp
    flash-backward-sexp
    backward-sexp
    find-up-sexp
    up-sexp
    find-down-sexp
    down-sexp
    remove-parens-forward
    
    select-forward-sexp
    select-backward-sexp
    select-up-sexp
    select-down-sexp
    transpose-sexp
    mark-matching-parenthesis
    get-tab-size
    set-tab-size
    
    introduce-let-ans
    move-sexp-out
    kill-enclosing-parens
    toggle-round-square-parens))

(define init-wordbreak-map
  (λ (map)
    (send map set-map  #\< '(line selection))  ; interfaces e.g.the canvas<%> interface
    (send map set-map  #\> '(line selection))  ; interfaces, casts e.g. string->path
    (send map set-map  #\% '(line selection))  ; intefraces, classes
    (send map set-map  #\? '(line selection))  ; predicates
    (send map set-map  #\' '(line selection))  ; literal symbols
    (send map set-map  #\! '(line selection))  ; assignments e.g. set
    (send map set-map  #\- '(line selection))  ; hyphens
    (send map set-map  #\: '(line selection)))); valid identifiers with colons

(define wordbreak-map (make-object editor-wordbreak-map%))
(define (get-wordbreak-map) wordbreak-map)
(init-wordbreak-map wordbreak-map)

(define matching-parenthesis-style 
  (let ([matching-parenthesis-delta (make-object style-delta% 'change-bold)]
        [style-list (editor:get-standard-style-list)])
    (send matching-parenthesis-delta set-delta-foreground "forest green")
    (send style-list new-named-style "Matching Parenthesis Style"
          (send style-list find-or-create-style
                (send style-list find-named-style "Standard")
                matching-parenthesis-delta))
    (send style-list find-named-style "Matching Parenthesis Style")))

(define text-mixin
  (mixin (text:basic<%> mode:host-text<%> color:text<%> text:autocomplete<%>) (-text<%>)
    (inherit begin-edit-sequence
             delete
             end-edit-sequence
             local-edit-sequence?
             find-string
             get-character
             get-keymap
             get-text
             get-start-position
             get-style-list
             get-end-position
             flash-on
             insert
             kill
             last-position
             paragraph-start-position
             paragraph-end-position
             position-paragraph
             set-keymap
             set-load-overwrites-styles
             set-position
             set-wordbreak-map
             set-tabs
             set-style-list
             set-styles-fixed
             change-style
             get-snip-position
             backward-match
             backward-containing-sexp
             forward-match
             skip-whitespace
             insert-close-paren
             classify-position)
    
    (inherit get-styles-fixed)
    (inherit has-focus? find-snip split-snip
             position-location get-dc)
    
    (define/override (get-word-at current-pos)
      (let ([no-word ""])
        (cond
          [(or (is-stopped?) (is-frozen?))
           no-word]
          [else
           (let ([type (classify-position (max 0 (- current-pos 1)))])
             (cond
               [(eq? 'symbol type) 
                (get-text (look-for-non-symbol (max 0 (- current-pos 1)))
                          current-pos)]
               [else no-word]))])))
    
    (define/private (look-for-non-symbol start)
      (let loop ([i start])
        (cond
          [(< i 0) 
           0]
          [(eq? (classify-position i) 'symbol)
           (loop (- i 1))]
          [else
           (+ i 1)])))
    
    (public tabify-on-return? tabify
            tabify-all insert-return calc-last-para 
            box-comment-out-selection comment-out-selection uncomment-selection
            flash-forward-sexp 
            flash-backward-sexp backward-sexp find-up-sexp up-sexp find-down-sexp down-sexp
            remove-parens-forward)
    
    (define/public (get-limit pos) 0)
    
    (define/public (balance-parens key-event)
      (insert-close-paren (get-start-position) 
                          (send key-event get-key-code)
                          (preferences:get 'framework:paren-match)
                          (preferences:get 'framework:fixup-parens)))
    
    (define (tabify-on-return?) #t)
    (define tabify    
      (lambda ([pos (get-start-position)])
        (let* ([tabify-prefs (preferences:get 'framework:tabify)]
               [last-pos (last-position)]
               [para (position-paragraph pos)]
               [is-tabbable? (and (> para 0)
                                  (not (memq (classify-position (sub1 (paragraph-start-position para)))
                                             '(comment string error))))]
               [end (if is-tabbable? (paragraph-start-position para) 0)]
               [limit (get-limit pos)]
               ;; "contains" is the start of the initial sub-S-exp
               ;;  in the S-exp that contains "pos". If pos is outside
               ;;  all S-exps, this will be the start of the initial
               ;;  S-exp
               [contains 
                (if is-tabbable?
                    (backward-containing-sexp end limit)
                    #f)]
               [contain-para (and contains
                                  (position-paragraph contains))]
               ;; "last" is the start of the S-exp just before "pos"
               [last 
                (if contains
                    (let ([p (get-backward-sexp end)])
                      (if (and p (p . >= . limit))
                          p
                          (backward-match end limit)))
                    #f)]
               [last-para (and last
                               (position-paragraph last))])
          (letrec	
              ([find-offset
                (λ (start-pos)
                  (let ([end-pos
                         (let loop ([p start-pos])
                           (let ([c (get-character p)])
                             (cond
                               [(char=? c #\tab)
                                (loop (add1 p))]
                               [(char=? c #\newline)
                                p]
                               [(char-whitespace? c)
                                (loop (add1 p))]
                               [else
                                p])))]
                        [start-x (box 0)]
                        [end-x (box 0)])
                    (position-location start-pos start-x #f #t #t)
                    (position-location end-pos end-x #f #t #t)
                    (let-values ([(w _1 _2 _3) (send (get-dc) get-text-extent "x" 
                                                     (send (send (get-style-list)
                                                                 find-named-style "Standard")
                                                           get-font))])
                      (cons (inexact->exact (floor (/ (- (unbox end-x) (unbox start-x)) w)))
                            end-pos))))]
               
               [visual-offset
                (λ (pos)
                  (let loop ([p (sub1 pos)])
                    (if (= p -1)
                        0
                        (let ([c (get-character p)])
                          (cond
                            [(char=? c #\null) 0]
                            [(char=? c #\tab)
                             (let ([o (loop (sub1 p))])
                               (+ o (- 8 (modulo o 8))))]
                            [(char=? c #\newline) 0]
                            [else (add1 (loop (sub1 p)))])))))]
               [do-indent
                (λ (amt)
                  (let* ([pos-start end]
                         [curr-offset (find-offset pos-start)])
                    (unless (= amt (- (cdr curr-offset) pos-start))
                      (delete pos-start (cdr curr-offset))
                      (insert (make-string amt #\space)
                              pos-start))))]
               [get-proc
                (λ ()
                  (let ([id-end (get-forward-sexp contains)])
                    (and (and id-end (> id-end contains))
                         (let* ([text (get-text contains id-end)])
                           (or (get-keyword-type text tabify-prefs)
                               'other)))))]
               [procedure-indent
                (λ ()
                  (case (get-proc)
                    [(begin define) 1]
                    [(lambda) 3]
                    [else 0]))]
               [special-check
                (λ ()
                  (let* ([proc-name (get-proc)])
                    (or (eq? proc-name 'define)
                        (eq? proc-name 'lambda))))]
               [indent-first-arg (λ (start) (car (find-offset start)))])
            (when (and is-tabbable?
                       (not (char=? (get-character (sub1 end))
                                    #\newline)))
              (insert #\newline (paragraph-start-position para)))
            (cond
              [(not is-tabbable?) 
               (when (= para 0)
                 (do-indent 0))]
              [(let ([real-start (cdr (find-offset end))]) 
                 (and (<= (+ 3 real-start) (last-position))
                      (string=? ";;;"
                                (get-text real-start
                                          (+ 2 real-start)))))
               (void)]
              [(not contains)
               ;; Something went wrong matching. Should we get here?
               (do-indent 0)]
              [(not last) 
               ;; We can't find a match backward from pos,
               ;;  but we seem to be inside an S-exp, so 
               ;;  go "up" an S-exp, and move forward past
               ;;  the associated paren
               (let ([enclosing (find-up-sexp pos)])
                 (do-indent (if enclosing
                                (+ (visual-offset enclosing) 1)
                                0)))]
              [(= contains last)
               ;; There's only one S-expr in the S-expr
               ;;  containing "pos"
               (do-indent (+ (visual-offset contains)
                             (procedure-indent)))]
              [(special-check)
               ;; In case of "define", etc., ignore the position of last 
               ;;  and just indent under the "define"
               (do-indent (add1 (visual-offset contains)))]
              [(= contain-para last-para)
               ;; So far, the S-exp containing "pos" was all on
               ;;  one line (possibly not counting the opening paren),
               ;;  so indent to follow the first S-exp's end
               ;;  unless there are just two sexps and the second is an ellipsis.
               ;;  in that case, we just ignore the ellipsis
               (let ([name-length (let ([id-end (get-forward-sexp contains)])
                                    (if id-end
                                        (- id-end contains)
                                        0))])
                 (cond
                   [(second-sexp-is-ellipsis? contains)
                    (do-indent (visual-offset contains))]
                   [(not (find-up-sexp pos))
                    (do-indent (visual-offset contains))]
                   [else
                    (do-indent (+ (visual-offset contains)
                                  name-length
                                  (indent-first-arg (+ contains 
                                                       name-length))))]))]
              [else
               ;; No particular special case, so indent to match first 
               ;; S-expr that start on the previous line
               (let loop ([last last][last-para last-para])
                 (let* ([next-to-last (backward-match last limit)]
                        [next-to-last-para (and next-to-last
                                                (position-paragraph next-to-last))])
                   (if (equal? last-para next-to-last-para)
                       (loop next-to-last next-to-last-para)
                       (do-indent (visual-offset last)))))])))))
    
    ;; returns #t if `contains' is at a position on a line with an sexp, an ellipsis and nothing else.
    ;; otherwise, returns #f
    (define/private (second-sexp-is-ellipsis? contains)
      (let ([fst-end (get-forward-sexp contains)])
        (and fst-end
             (let ([snd-end (get-forward-sexp fst-end)])
               (and snd-end
                    (let ([snd-start (get-backward-sexp snd-end)])
                      (and snd-start
                           (equal? (get-text snd-start snd-end)
                                   "...")
                           (let ([thrd-start (get-forward-sexp snd-end)])
                             (and (or (not thrd-start)
                                      (not (= (position-paragraph thrd-start)
                                              (position-paragraph snd-start)))))))))))))
    
    (define/public tabify-selection
      (lambda ([start-pos (get-start-position)]
               [end-pos (get-end-position)])
        (let ([first-para (position-paragraph start-pos)]
              [end-para (position-paragraph end-pos)])
          (with-handlers ([exn:break?
                           (λ (x) #t)])
            (dynamic-wind
             (λ () 
               (when (< first-para end-para)
                 (begin-busy-cursor))
               (begin-edit-sequence))
             (λ ()
               (let loop ([para first-para])
                 (when (<= para end-para)
                   (tabify (paragraph-start-position para))
                   (parameterize-break #t (void))
                   (loop (add1 para))))
               (when (and (>= (position-paragraph start-pos) end-para)
                          (<= (skip-whitespace (get-start-position) 'backward #f)
                              (paragraph-start-position first-para)))
                 (set-position 
                  (let loop ([new-pos (get-start-position)])
                    (if (let ([next (get-character new-pos)])
                          (and (char-whitespace? next)
                               (not (char=? next #\newline))))
                        (loop (add1 new-pos))
                        new-pos)))))
             (λ ()
               (end-edit-sequence)
               (when (< first-para end-para)
                 (end-busy-cursor))))))))
    
    (define (tabify-all) (tabify-selection 0 (last-position)))
    (define (insert-return)
      (if (tabify-on-return?)
          (begin 
            (begin-edit-sequence)
            (insert #\newline)
            (tabify (get-start-position))
            (set-position 
             (let loop ([new-pos (get-start-position)])
               (if (let ([next (get-character new-pos)])
                     (and (char-whitespace? next)
                          (not (char=? next #\newline))))
                   (loop (add1 new-pos))
                   new-pos)))
            (end-edit-sequence))
          (insert #\newline)))
    
    (define (calc-last-para last-pos)
      (let ([last-para (position-paragraph last-pos #t)])
        (if (and (> last-pos 0)
                 (> last-para 0))
            (begin (split-snip last-pos)
                   (let ([snip (find-snip last-pos 'before)])
                     (if (member 'hard-newline (send snip get-flags))
                         (- last-para 1)
                         last-para)))
            last-para)))
    
    (define comment-out-selection 
      (lambda ([start-pos (get-start-position)] 
               [end-pos (get-end-position)]) 
        (begin-edit-sequence) 
        (let ([first-pos-is-first-para-pos? 
               (= (paragraph-start-position (position-paragraph start-pos)) 
                  start-pos)]) 
          (let* ([first-para (position-paragraph start-pos)] 
                 [last-para (calc-last-para end-pos)]) 
            (let para-loop ([curr-para first-para]) 
              (when (<= curr-para last-para) 
                (let ([first-on-para (paragraph-start-position curr-para)]) 
                  (insert #\; first-on-para) 
                  (para-loop (add1 curr-para)))))) 
          (when first-pos-is-first-para-pos? 
            (set-position 
             (paragraph-start-position (position-paragraph (get-start-position))) 
             (get-end-position)))) 
        (end-edit-sequence) 
        #t)) 
    
    (define box-comment-out-selection
      (lambda ([_start-pos 'start]
               [_end-pos 'end])
        (let ([start-pos (if (eq? _start-pos 'start)
                             (get-start-position)
                             _start-pos)]
              [end-pos (if (eq? _end-pos 'end)
                           (get-end-position)
                           _end-pos)])
          (begin-edit-sequence)
          (split-snip start-pos)
          (split-snip end-pos)
          (let* ([cb (instantiate comment-box:snip% ())]
                 [text (send cb get-editor)])
            (let loop ([snip (find-snip start-pos 'after-or-none)])
              (cond
                [(not snip) (void)]
                [((get-snip-position snip) . >= . end-pos) (void)]
                [else
                 (send text insert (send snip copy)
                       (send text last-position)
                       (send text last-position))
                 (loop (send snip next))]))
            (delete start-pos end-pos)
            (insert cb start-pos)
            (set-position start-pos start-pos))
          (end-edit-sequence)
          #t)))
    
    ;; uncomment-box/selection : -> void
    ;; uncomments a comment box, if the focus is inside one.
    ;; otherwise, calls uncomment selection to uncomment
    ;; something else.
    (inherit get-focus-snip)
    (define/public (uncomment-box/selection)
      (begin-edit-sequence)
      (let ([focus-snip (get-focus-snip)])
        (cond
          [(not focus-snip) (uncomment-selection)]
          [(is-a? focus-snip comment-box:snip%) 
           (extract-contents 
            (get-snip-position focus-snip)
            focus-snip)]
          [else (uncomment-selection)]))
      (end-edit-sequence)
      #t)
    
    (define uncomment-selection
      (lambda ([start-pos (get-start-position)]
               [end-pos (get-end-position)])
        (let ([snip-before (find-snip start-pos 'before-or-none)]
              [snip-after (find-snip start-pos 'after-or-none)])
          
          (begin-edit-sequence)
          (cond
            [(and (= start-pos end-pos)
                  snip-before
                  (is-a? snip-before comment-box:snip%))
             (extract-contents start-pos snip-before)]
            [(and (= start-pos end-pos)
                  snip-after
                  (is-a? snip-after comment-box:snip%))
             (extract-contents start-pos snip-after)]
            [(and (= (+ start-pos 1) end-pos)
                  snip-after
                  (is-a? snip-after comment-box:snip%))
             (extract-contents start-pos snip-after)]
            [else
             (let* ([last-pos (last-position)]
                    [first-para (position-paragraph start-pos)]
                    [last-para (calc-last-para end-pos)])
               (let para-loop ([curr-para first-para])
                 (when (<= curr-para last-para)
                   (let ([first-on-para
                          (skip-whitespace  (paragraph-start-position curr-para)
                                            'forward
                                            #f)])
                     (split-snip first-on-para)
                     (when (and (< first-on-para last-pos)
                                (char=? #\; (get-character first-on-para))
                                (is-a? (find-snip first-on-para 'after-or-none) string-snip%))
                       (delete first-on-para (+ first-on-para 1)))
                     (para-loop (add1 curr-para))))))])
          (end-edit-sequence))
        #t))
    
    ;; extract-contents : number (is-a?/c comment-box:snip%) -> void
    ;; copies the contents of the comment-box-snip out of the snip
    ;; and into this editor as `pos'. Deletes the comment box snip
    (define/private (extract-contents pos snip)
      (let ([editor (send snip get-editor)])
        (let loop ([snip (send editor find-snip (send editor last-position) 'before-or-none)])
          (cond
            [snip
             (insert (send snip copy) pos)
             (loop (send snip previous))]
            [else (void)]))
        (let ([snip-pos (get-snip-position snip)])
          (delete snip-pos (+ snip-pos 1)))
        (set-position pos pos)))
    
    (define/private (stick-to-next-sexp? start-pos)
      (let ([end-pos (forward-match start-pos (last-position))])
        (and end-pos
             (member (get-text start-pos end-pos)
                     '("'" "," ",@" "`"
                           "#'" "#," "#`" "#,@"
                           "#&" "#;"
                           "#hash" "#hasheq"
                           "#ci" "#cs")))))
    
    (define/public (get-forward-sexp start-pos) 
      ;; loop to work properly with quote, etc.
      (let loop ([one-forward (forward-match start-pos (last-position))])
        (cond
          [(and one-forward (not (= 0 one-forward)))
           (let ([bw (backward-match one-forward 0)])
             (cond
               [(and bw 
                     (stick-to-next-sexp? bw))
                (let ([two-forward (forward-match one-forward (last-position))])
                  (if two-forward
                      (loop two-forward)
                      one-forward))]
               [else
                one-forward]))]
          [else one-forward])))
    
    (define/public (remove-sexp start-pos)
      (let ([end-pos (get-forward-sexp start-pos)])
        (if end-pos 
            (kill 0 start-pos end-pos)
            (bell)))
      #t)
    (define/public (forward-sexp start-pos)
      (let ([end-pos (get-forward-sexp start-pos)])
        (if end-pos 
            (set-position end-pos)
            (bell))
        #t))
    [define flash-forward-sexp
      (λ (start-pos)
        (let ([end-pos (get-forward-sexp start-pos)])
          (if end-pos 
              (flash-on end-pos (add1 end-pos))
              (bell)) 
          #t))]
    (define/public (get-backward-sexp start-pos)
      (let* ([limit (get-limit start-pos)]
             [end-pos (backward-match start-pos limit)]
             [min-pos (backward-containing-sexp start-pos limit)])
        (if (and end-pos 
                 (or (not min-pos)
                     (end-pos . >= . min-pos)))
            ;; Can go backward, but check for preceding quote, unquote, etc.
            (let loop ([end-pos end-pos])
              (let ([next-end-pos (backward-match end-pos limit)])
                (if (and next-end-pos
                         (or (not min-pos)
                             (end-pos . >= . min-pos))
                         (stick-to-next-sexp? next-end-pos))
                    (loop next-end-pos)
                    end-pos)))
            ;; can't go backward at all:
            #f)))
    [define flash-backward-sexp
      (λ (start-pos)
        (let ([end-pos (get-backward-sexp start-pos)])
          (if end-pos
              (flash-on end-pos (add1 end-pos))
              (bell))
          #t))]
    [define backward-sexp
      (λ (start-pos)
        (let ([end-pos (get-backward-sexp start-pos)])
          (if end-pos
              (set-position end-pos)
              (bell))
          #t))]
    [define find-up-sexp
      (λ (start-pos)
        (let* ([limit-pos (get-limit start-pos)]
               [exp-pos
                (backward-containing-sexp start-pos limit-pos)])
          
          (if (and exp-pos (> exp-pos limit-pos))
              (let* ([in-start-pos (skip-whitespace exp-pos 'backward #t)]
                     [paren-pos
                      (λ (paren-pair)
                        (find-string
                         (car paren-pair)
                         'backward
                         in-start-pos
                         limit-pos))])
                (let ([poss (let loop ([parens (scheme-paren:get-paren-pairs)])
                              (cond
                                [(null? parens) null]
                                [else 
                                 (let ([pos (paren-pos (car parens))])
                                   (if pos
                                       (cons pos (loop (cdr parens)))
                                       (loop (cdr parens))))]))])
                  (if (null? poss) ;; all finds failed
                      #f
                      (- (apply max poss) 1)))) ;; subtract one to move outside the paren
              #f)))]
    [define up-sexp
      (λ (start-pos)
        (let ([exp-pos (find-up-sexp start-pos)])
          (if exp-pos
              (set-position exp-pos)
              (bell))
          #t))]
    [define find-down-sexp
      (λ (start-pos)
        (let loop ([pos start-pos])
          (let ([next-pos (get-forward-sexp pos)])
            (if (and next-pos (> next-pos pos))
                (let ([back-pos
                       (backward-containing-sexp (sub1 next-pos) pos)])
                  (if (and back-pos
                           (> back-pos pos))
                      back-pos
                      (loop next-pos)))
                #f))))]
    [define down-sexp
      (λ (start-pos)
        (let ([pos (find-down-sexp start-pos)])
          (if pos
              (set-position pos)
              (bell))
          #t))]
    [define remove-parens-forward
      (λ (start-pos)
        (let* ([pos (skip-whitespace start-pos 'forward #f)]
               [first-char (get-character pos)]
               [paren? (or (char=? first-char #\( )
                           (char=? first-char #\[ ))]
               [closer (and paren? 
                            (get-forward-sexp pos))])
          (if (and paren? closer)
              (begin (begin-edit-sequence)
                     (delete pos (add1 pos))
                     (delete (-  closer 2) (- closer 1))
                     (end-edit-sequence))
              (bell))
          #t))]
    
    (define/private (select-text f forward?)
      (let* ([start-pos (get-start-position)]
             [end-pos (get-end-position)])
        (let-values ([(new-start new-end)
                      (if forward?
                          (values start-pos (f end-pos))
                          (values (f start-pos) end-pos))])
          (if (and new-start new-end) 
              (set-position new-start new-end)
              (bell))
          #t)))
    (public select-forward-sexp select-backward-sexp select-up-sexp select-down-sexp)
    [define select-forward-sexp (λ () (select-text (λ (x) (get-forward-sexp x)) #t))]
    [define select-backward-sexp (λ () (select-text (λ (x) (get-backward-sexp x)) #f))]
    [define select-up-sexp (λ () (select-text (λ (x) (find-up-sexp x)) #f))]
    [define select-down-sexp (λ () (select-text (λ (x) (find-down-sexp x)) #t))]
    
    (define/public (introduce-let-ans pos)
      (dynamic-wind
       (λ () (begin-edit-sequence))
       (λ ()
         (let ([before-text "(let ([ans "]
               [after-text "])\n"]
               [after-text2 "(printf \"~s\\n\" ans)\nans)"]
               [end-l (get-forward-sexp pos)])
           (cond
             [end-l
              (insert after-text2 end-l end-l)
              (insert after-text end-l end-l)
              (insert before-text pos pos)
              (let ([blank-line-pos (+ end-l (string-length after-text) (string-length before-text))])
                (set-position blank-line-pos blank-line-pos))
              (tabify-selection 
               pos
               (+ end-l 
                  (string-length before-text)
                  (string-length after-text)
                  (string-length after-text2)))]
             [else
              (bell)])))
       (λ ()
         (end-edit-sequence))))
    
    (define/public (move-sexp-out begin-inner)
      (begin-edit-sequence)
      (let ([end-inner (get-forward-sexp begin-inner)]
            [begin-outer (find-up-sexp begin-inner)])
        (cond
          [(and end-inner begin-outer)
           (let ([end-outer (get-forward-sexp begin-outer)])
             (cond
               [end-outer
                (delete end-inner end-outer)
                (delete begin-outer begin-inner)
                (tabify-selection begin-outer (+ begin-outer (- end-inner begin-inner)))]
               [else (bell)]))]
          [else (bell)]))
      (end-edit-sequence))
    
    (define/public (kill-enclosing-parens begin-inner)
      (begin-edit-sequence)
      (let ([begin-outer (find-up-sexp begin-inner)])
        (cond
          [begin-outer
            (let ([end-outer (get-forward-sexp begin-outer)])
              (cond
                [(and end-outer (> (- end-outer begin-outer) 2))
                 (delete (- end-outer 1) end-outer)
                 (delete begin-outer (+ begin-outer 1))
                 (tabify-selection begin-outer (- end-outer 2))]
                [else (bell)]))]
          [else (bell)]))
      (end-edit-sequence))
    
    ;; change the parens following the cursor from () to [] or vice versa
    (define/public (toggle-round-square-parens start-pos)
      (begin-edit-sequence)
      (let* ([sexp-begin (skip-whitespace start-pos 'forward #f)]
             [sexp-end (get-forward-sexp sexp-begin)])
        (cond [(and sexp-end
                    (< (+ 1 sexp-begin) sexp-end))
               ;; positions known to exist: start-pos <= x < sexp-end
               (match* ((get-character sexp-begin) (get-character (- sexp-end 1)))
                       [(#\( #\)) (replace-char-at-posn sexp-begin "[")
                                  (replace-char-at-posn (- sexp-end 1) "]")]
                       [(#\[ #\]) (replace-char-at-posn sexp-begin "(")
                                  (replace-char-at-posn (- sexp-end 1) ")")]
                       [(_ _) (bell)])]
              [else (bell)]))
      (end-edit-sequence))
    
    ;; replace-char-at-posn: natural-number string -> 
    ;;   replace the char at the given posn with the given string.
    ;;
    ;; this abstraction exists because the duplicated code in toggle-round-square-parens was 
    ;; just a little too much for comfort
    (define (replace-char-at-posn posn str)
      ;; insertions are performed before deletions in order to preserve the location of the cursor
      (insert str (+ posn 1) (+ posn 1))
      (delete posn (+ posn 1)))
    
    (inherit get-fixed-style)
    (define/public (mark-matching-parenthesis pos)
      (let ([open-parens (map car (scheme-paren:get-paren-pairs))]
            [close-parens (map cdr (scheme-paren:get-paren-pairs))])
        (when (member (string (get-character pos)) open-parens)
          (let ([end (get-forward-sexp pos)])
            (when (and end
                       (member (string (get-character (- end 1))) close-parens))
              (let ([start-style (send (find-snip pos 'after) get-style)]
                    [end-style (send (find-snip end 'before) get-style)])
                (cond
                  [(and (eq? matching-parenthesis-style start-style)
                        (eq? matching-parenthesis-style end-style))
                   (let ([fixed-style (get-fixed-style)])
                     (change-style fixed-style pos (+ pos 1))
                     (change-style fixed-style (- end 1) end))]
                  [else
                   (change-style matching-parenthesis-style pos (+ pos 1))
                   (change-style matching-parenthesis-style (- end 1) end)])))))))
    
    ;; get-snips/rev: start end -> (listof snip)
    ;; Returns a list of the snips in reverse order between
    ;; start and end.
    (define/private (get-snips/rev start end)
      (split-snip start)
      (split-snip end)
      (let loop ([snips/rev '()]
                 [a-snip (find-snip start 'after-or-none)])
        (cond
          [(or (not a-snip)
               (>= (get-snip-position a-snip)
                   end))
           snips/rev]
          [else
           (loop (cons (send a-snip copy) snips/rev)
                 (send a-snip next))])))
    
    (define/public (transpose-sexp pos)
      (let ([start-1 (get-backward-sexp pos)])
        (if (not start-1)
            (bell)
            (let ([end-1 (get-forward-sexp start-1)])
              (if (not end-1)
                  (bell)
                  (let ([end-2 (get-forward-sexp end-1)])
                    (if (not end-2)
                        (bell)
                        (let ([start-2 (get-backward-sexp end-2)])
                          (if (or (not start-2)
                                  (< start-2 end-1))
                              (bell)
                              (let ([snips-1/rev (get-snips/rev start-1 end-1)]
                                    [snips-2/rev (get-snips/rev start-2 end-2)])
                                (begin-edit-sequence)
                                (delete start-2 end-2)
                                (for-each (λ (s) (insert s start-2)) snips-1/rev)
                                (delete start-1 end-1)
                                (for-each (λ (s) (insert s start-1)) snips-2/rev)
                                (set-position end-2)
                                (end-edit-sequence)))))))))))
    [define tab-size 8]
    (public get-tab-size set-tab-size)
    [define get-tab-size (λ () tab-size)]
    [define set-tab-size (λ (s) (set! tab-size s))]
    
    (inherit is-frozen? is-stopped?)
    (define/public (rewrite-square-paren)
      (cond
        [(or (not (preferences:get 'framework:fixup-open-parens))
             (is-frozen?)
             (is-stopped?))
         (insert #\[
                 (get-start-position)
                 (get-end-position))]
        [else 
         (insert-paren this)]))
    
    (super-new)))

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

(define text-mode-mixin
  (mixin (color:text-mode<%> mode:surrogate-text<%>) (-text-mode<%>)
    
    (define/override (on-disable-surrogate text)
      (keymap:remove-chained-keymap text keymap)
      (super on-disable-surrogate text))
    
    (define/override (on-enable-surrogate text)
      (send text begin-edit-sequence)
      (super on-enable-surrogate text)
      (let ([km (send text get-keymap)])
        (when km
          (send km chain-to-keymap keymap #f)))
      
      ;; I don't know about these editor flag settings.
      ;; maybe they belong in drscheme?
      (send text set-load-overwrites-styles #f)
      (send text set-wordbreak-map wordbreak-map)
      (let ([bw (box 0)]
            [bu (box #f)]
            [tab-size (send text get-tab-size)])
        (unless (and (null? (send text get-tabs #f bw bu))
                     (= tab-size (unbox bw))
                     (not (unbox bu)))
          (send text set-tabs null (send text get-tab-size) #f)))
      (send text set-styles-fixed #t)
      (send text end-edit-sequence))
    
    (define tabify-pref (preferences:get 'framework:tabify))
    (preferences:add-callback
     'framework:tabify
     (lambda (k v) (set! tabify-pref v)))
    (define/private (scheme-lexer-wrapper in offset mode)
      (let-values (((lexeme type paren start end backup-delta mode) (module-lexer in offset mode)))
        (cond
          ((and (eq? type 'symbol)
                (get-keyword-type lexeme tabify-pref))
           (values lexeme 'keyword paren start end backup-delta mode))
          (else
           (values lexeme type paren start end backup-delta mode)))))
    
    (define/override (put-file text sup directory default-name)
      (parameterize ([finder:default-extension "rkt"]
                     [finder:default-filters '(["Racket Sources" "*.rkt;*.ss;*.scm"]
                                               ["Any" "*.*"])])
        ;; don't call the surrogate's super, since it sets the default extension
        (sup directory default-name)))
    
    (super-new (get-token (lambda (in offset mode) (scheme-lexer-wrapper in offset mode)))
               (token-sym->style short-sym->style-name)
               (matches '((|(| |)|)
                          (|[| |]|)
                          (|{| |}|))))))

;; get-keyword-type : string (list ht regexp regexp regexp)
;;                 -> (union #f 'lambda 'define 'begin)
(define (get-keyword-type text pref)
  (let* ([ht (car pref)]
         [beg-reg (cadr pref)]
         [def-reg (caddr pref)]
         [lam-reg (cadddr pref)])
    (hash-ref
     ht
     (with-handlers ((exn:fail:read? (λ (x) #f)))
       (read (open-input-string text)))
     (λ () 
       (cond
         [(and beg-reg (regexp-match beg-reg text)) 'begin]
         [(and def-reg (regexp-match def-reg text)) 'define]
         [(and lam-reg (regexp-match lam-reg text)) 'lambda]
         [else #f])))))

(define set-mode-mixin
  (mixin (-text<%> mode:host-text<%>) ()
    (super-new)
    (inherit set-surrogate)
    (set-surrogate (new text-mode%))))

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

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

(define (setup-keymap keymap)
  (let ([add-pos-function
         (λ (name call-method)
           (send keymap add-function name
                 (λ (edit event)
                   (call-method
                    edit
                    (send edit get-start-position)))))])
    (add-pos-function "remove-sexp" (λ (e p) (send e remove-sexp p)))
    (add-pos-function "forward-sexp" (λ (e p) (send e forward-sexp p)))
    (add-pos-function "backward-sexp" (λ (e p) (send e backward-sexp p)))
    (add-pos-function "up-sexp" (λ (e p) (send e up-sexp p)))
    (add-pos-function "down-sexp" (λ (e p) (send e down-sexp p)))
    (add-pos-function "flash-backward-sexp" (λ (e p) (send e flash-backward-sexp p)))
    (add-pos-function "flash-forward-sexp" (λ (e p) (send e flash-forward-sexp p)))
    (add-pos-function "remove-parens-forward" (λ (e p) (send e remove-parens-forward p)))
    (add-pos-function "transpose-sexp" (λ (e p) (send e transpose-sexp p)))
    (add-pos-function "mark-matching-parenthesis"
                      (λ (e p) (send e mark-matching-parenthesis p)))
    (add-pos-function "introduce-let-ans"
                      (λ (e p) (send e introduce-let-ans p)))
    (add-pos-function "move-sexp-out"
                      (λ (e p) (send e move-sexp-out p)))
    (add-pos-function "kill-enclosing-parens"
                      (lambda (e p) (send e kill-enclosing-parens p)))
    (add-pos-function "toggle-round-square-parens"
                      (lambda (e p) (send e toggle-round-square-parens p)))
    
    (let ([add-edit-function
           (λ (name call-method)
             (send keymap add-function name
                   (λ (edit event)
                     (call-method edit))))])
      (add-edit-function "select-forward-sexp" 
                         (λ (x) (send x select-forward-sexp)))
      (add-edit-function "select-backward-sexp"  
                         (λ (x) (send x select-backward-sexp)))
      (add-edit-function "select-down-sexp"  
                         (λ (x) (send x select-down-sexp)))
      (add-edit-function "select-up-sexp"  
                         (λ (x) (send x select-up-sexp)))
      (add-edit-function "tabify-at-caret"  
                         (λ (x) (send x tabify-selection)))
      (add-edit-function "do-return"  
                         (λ (x) 
                           (send x insert-return)))
      (add-edit-function "comment-out"  
                         (λ (x) (send x comment-out-selection)))
      (add-edit-function "box-comment-out"  
                         (λ (x) (send x box-comment-out-selection)))
      (add-edit-function "uncomment"  
                         (λ (x) (send x uncomment-selection)))
      (add-edit-function "rewrite-square-paren"  
                         (λ (x) (send x rewrite-square-paren)))
      
      (let ([add/map-non-clever
             (λ (name keystroke char)
               (add-edit-function 
                name
                (λ (e) (send e insert char (send e get-start-position) (send e get-end-position))))
               (send keymap map-function keystroke name))])
        (add/map-non-clever "non-clever-open-square-bracket" "c:[" #\[)
        (add/map-non-clever "non-clever-close-square-bracket" "c:]" #\])
        (add/map-non-clever "non-clever-close-curley-bracket" "c:}" #\})
        (add/map-non-clever "non-clever-close-round-paren" "c:)" #\))))
    
    (send keymap add-function "balance-parens"
          (λ (edit event)
            (send edit balance-parens event)))
    
    (send keymap map-function "TAB" "tabify-at-caret")
    
    (send keymap map-function "return" "do-return")
    (send keymap map-function "s:return" "do-return")
    (send keymap map-function "s:c:return" "do-return")
    (send keymap map-function "a:return" "do-return")
    (send keymap map-function "s:a:return" "do-return")
    (send keymap map-function "c:a:return" "do-return")
    (send keymap map-function "c:s:a:return" "do-return")
    (send keymap map-function "c:return" "do-return")
    (send keymap map-function "d:return" "do-return")
    
    (send keymap map-function ")" "balance-parens")
    (send keymap map-function "]" "balance-parens")
    (send keymap map-function "}" "balance-parens")
    
    (send keymap map-function "[" "rewrite-square-paren")
    
    (let ([map-meta
           (λ (key func)
             (keymap:send-map-function-meta keymap key func))]
          [map
           (λ (key func)
             (send keymap map-function key func))])
      
      (map-meta "up" "up-sexp")
      (map-meta "c:u" "up-sexp")
      (map "a:up" "up-sexp")
      (map-meta "s:up" "select-up-sexp")
      (map "a:s:up" "select-up-sexp")
      (map-meta "s:c:u" "select-up-sexp")
      
      (map-meta "down" "down-sexp")
      (map "a:down" "down-sexp")
      (map-meta "s:down" "select-down-sexp")
      (map "a:s:down" "select-down-sexp")
      (map-meta "s:c:down" "select-down-sexp")
      
      (map-meta "right" "forward-sexp")
      (map "a:right" "forward-sexp")
      (map "m:right" "forward-sexp")
      (map-meta "s:right" "select-forward-sexp")
      (map "a:s:right" "select-forward-sexp")
      (map "m:s:right" "select-forward-sexp")
      
      (map-meta "left" "backward-sexp")
      (map "a:left" "backward-sexp")
      (map "m:left" "backward-sexp")
      (map-meta "s:left" "select-backward-sexp")
      (map "a:s:left" "select-backward-sexp")
      (map "m:s:left" "select-backward-sexp")
      
      (map-meta "return" "do-return")
      (map-meta "s:return" "do-return")
      (map-meta "s:c:return" "do-return")
      (map-meta "a:return" "do-return")
      (map-meta "s:a:return" "do-return")
      (map-meta "c:a:return" "do-return")
      (map-meta "c:s:a:return" "do-return")
      (map-meta "c:return" "do-return")
      
      (map-meta "c:semicolon" "comment-out")
      (map-meta "c:=" "uncomment")
      (map-meta "c:k" "remove-sexp")
      
      (map-meta "c:f" "forward-sexp")
      (map-meta "s:c:f" "select-forward-sexp")
      
      (map-meta "c:b" "backward-sexp")
      (map-meta "s:c:b" "select-backward-sexp")
      
      (map-meta "c:p" "flash-backward-sexp")
      (map-meta "s:c:n" "flash-forward-sexp")
      
      (map-meta "c:space" "select-forward-sexp")
      (map-meta "c:t" "transpose-sexp")
      
      ;(map-meta "c:m" "mark-matching-parenthesis")
      ; this keybinding doesn't interact with the paren colorer
      )
    (send keymap map-function "c:c;c:b" "remove-parens-forward")
    (send keymap map-function "c:c;c:l" "introduce-let-ans")
    (send keymap map-function "c:c;c:o" "move-sexp-out")
    (send keymap map-function "c:c;c:e" "kill-enclosing-parens")
    (send keymap map-function "c:c;c:[" "toggle-round-square-parens")))

(define keymap (make-object keymap:aug-keymap%))
(setup-keymap keymap)
(define (get-keymap) keymap)

;; choose-paren : scheme-text number -> character
;; returns the character to replace a #\[ with, based
;; on the context where it is typed in.
(define (insert-paren text)
  (let* ([pos (send text get-start-position)]
         [real-char #\[]
         [change-to (λ (i c) 
                      ;(printf "change-to, case ~a\n" i)
                      (set! real-char c))]
         [start-pos (send text get-start-position)]
         [end-pos (send text get-end-position)]
         [letrec-like-forms (preferences:get 'framework:square-bracket:letrec)])
    (send text begin-edit-sequence #f #f)
    (send text insert "[" start-pos 'same #f)
    (when (eq? (send text classify-position pos) 'parenthesis)
      (let* ([before-whitespace-pos (send text skip-whitespace pos 'backward #t)]
             [keyword/distance (find-keyword-and-distance before-whitespace-pos text)])
        (cond
          [(and keyword/distance
                (member keyword/distance
                        (preferences:get 'framework:square-bracket:cond/offset)))
           ;; just leave the square backet in, in this case
           (void)]
          [(and keyword/distance
                (member (car keyword/distance)
                        (preferences:get 'framework:square-bracket:local)))
           (unless (= (cadr keyword/distance) 0)
             (change-to 7 #\())]
          [else
           (let* ([backward-match (send text backward-match before-whitespace-pos 0)]
                  [b-m-char (and (number? backward-match) (send text get-character backward-match))])
             (cond
               [backward-match
                ;; there is an expression before this, at this layer
                (let* ([before-whitespace-pos2 (send text skip-whitespace backward-match 'backward #t)]
                       [backward-match2 (send text backward-match before-whitespace-pos2 0)])
                  
                  (cond
                    [(member b-m-char '(#\( #\[ #\{))
                     ;; found a "sibling" parenthesized sequence. use the parens it uses.
                     (change-to 1 b-m-char)]
                    [else
                     ;; otherwise, we switch to (
                     (change-to 2 #\()]))]
               [(not (zero? before-whitespace-pos))
                ;; this is the first thing in the sequence
                ;; pop out one layer and look for a keyword.
                (let ([b-w-p-char (send text get-character (- before-whitespace-pos 1))])
                  (cond
                    [(equal? b-w-p-char #\()
                     (let* ([second-before-whitespace-pos (send text skip-whitespace 
                                                                (- before-whitespace-pos 1)
                                                                'backward
                                                                #t)]
                            [second-backwards-match (send text backward-match
                                                          second-before-whitespace-pos
                                                          0)])
                       (cond
                         [(not second-backwards-match)
                          (change-to 3 #\()]
                         [(and (beginning-of-sequence? text second-backwards-match)
                               (ormap (λ (x) (text-between-equal? x
                                                                  text
                                                                  second-backwards-match
                                                                  second-before-whitespace-pos))
                                      letrec-like-forms))
                          ;; we found a let<mumble> keyword, so we get a square bracket
                          (void)]
                         [else
                          ;; go back one more sexp in the same row, looking for `let loop' pattern
                          (let* ([second-before-whitespace-pos2 (send text skip-whitespace 
                                                                      second-backwards-match
                                                                      'backward
                                                                      #t)]
                                 [second-backwards-match2 (send text backward-match
                                                                second-before-whitespace-pos2
                                                                0)])
                            (cond
                              [(and second-backwards-match2
                                    (eq? (send text classify-position second-backwards-match)
                                         ;;; otherwise, this isn't a `let loop', it is a regular let!
                                         'symbol)
                                    (member "let" letrec-like-forms)
                                    (text-between-equal? "let"
                                                         text
                                                         second-backwards-match2
                                                         second-before-whitespace-pos2))
                               ;; found the `(let loop (' so we keep the [
                               (void)]
                              [else
                               ;; otherwise, round.
                               (change-to 4 #\()]))]))]
                    [else 
                     (change-to 5 #\()]))]
               [else 
                (change-to 6 #\()]))])))
    (send text delete pos (+ pos 1) #f)
    (send text end-edit-sequence)
    (send text insert real-char start-pos end-pos)))

;; find-keyword-and-distance : -> (union #f (cons string number))
(define (find-keyword-and-distance before-whitespace-pos text)
  ;; searches backwards for the keyword in the sequence at this level.
  ;; if found, it counts how many sexps back it was 
  (let loop ([pos before-whitespace-pos]
             [n 0])
    (let ([backward-match (send text backward-match pos 0)])
      (cond
        [backward-match
         (let ([before-whitespace-pos (send text skip-whitespace backward-match 'backward #t)])
           (loop before-whitespace-pos
                 (+ n 1)))]
        [else
         (let* ([afterwards (send text get-forward-sexp pos)]
                [keyword
                 (and afterwards
                      (send text get-text pos afterwards))])
           (and keyword
                (list keyword (- n 1))))]))))

;; beginning-of-sequence? : text number -> boolean 
;; determines if this position is at the beginning of a sequence
;; that begins with a parenthesis.
(define (beginning-of-sequence? text start)
  (let ([before-space (send text skip-whitespace start 'backward #t)])
    (cond
      [(zero? before-space) #t]
      [else
       (equal? (send text get-character (- before-space 1)) 
               #\()])))

(define (text-between-equal? str text start end)
  (and (= (string-length str) (- end start))
       (let loop ([i (string-length str)])
         (cond
           [(= i 0) #t]
           [else
            (and (char=? (string-ref str (- i 1))
                         (send text get-character (+ i start -1)))
                 (loop (- i 1)))]))))


;;;                                            ;;;   
;                                                 ;   
;                                                 ;   
; ;;;   ; ;;;   ;;;   ;;;;;   ;;;         ; ;;;   ;;;;  ; ;;;    ;;;     ;   
;   ;   ;     ;   ;   ;     ;   ;         ;   ;      ;  ;;  ;  ;   ;    ;   
;   ;   ;     ;;;;;   ;      ;;;          ;   ;   ;;;;  ;   ;  ;;;;;    ;   
;   ;   ;     ;       ;         ;         ;   ;  ;   ;  ;   ;  ;        ;   
;   ;   ;     ;   ;   ;     ;   ;         ;   ;  ;   ;  ;   ;  ;   ;    ;   
;;;;   ;;;;    ;;;   ;;;;    ;;;          ;;;;    ;;; ;;;;  ;;  ;;;   ;;;;;;
;                                         ;                                 
;                                         ;                                 
;;;                                       ;;;                                


(define (add-preferences-panel)
  (preferences:add-panel
   (list (string-constant editor-prefs-panel-label) 
         (string-constant indenting-prefs-panel-label))
   make-indenting-prefs-panel)
  (preferences:add-panel
   (list (string-constant editor-prefs-panel-label) 
         (string-constant square-bracket-prefs-panel-label))
   make-square-bracket-prefs-panel))

(define (make-square-bracket-prefs-panel p)
  (define main-panel (make-object vertical-panel% p))
  (define boxes-panel (new horizontal-panel% [parent main-panel]))
  
  (define (mk-list-box sym keyword-type pref->string get-new-one)
    (letrec ([vp (new vertical-panel% [parent boxes-panel])]
             [_ (new message% 
                     [label (format (string-constant x-like-keywords) keyword-type)]
                     [parent vp])]
             [lb
              (new list-box% 
                   [label #f]
                   [parent vp]
                   [choices (map pref->string (preferences:get sym))]
                   [callback
                    (λ (lb evt)
                      (send remove-button enable (pair? (send lb get-selections))))])]
             [bp (new horizontal-panel% [parent vp] [stretchable-height #f])]
             [add
              (new button%
                   [label (string-constant add-keyword)]
                   [parent bp]
                   [callback 
                    (λ (x y)
                      (let ([new-one (get-new-one)])
                        (when new-one
                          (preferences:set sym (append (preferences:get sym) 
                                                       (list new-one))))))])]
             [remove-button
              (new button%
                   [label (string-constant remove-keyword)]
                   [parent bp]
                   [callback 
                    (λ (x y)
                      (let ([n (send lb get-selections)])
                        (when (pair? n)
                          (preferences:set 
                           sym 
                           (let loop ([i 0]
                                      [prefs (preferences:get sym)])
                             (cond
                               [(= i (car n)) (cdr prefs)]
                               [else (cons (car prefs)
                                           (loop (+ i 1)
                                                 (cdr prefs)))])))
                          (cond
                            [(= 0 (send lb get-number))
                             (send remove-button enable #f)]
                            [else
                             (send lb set-selection 
                                   (if (= (car n) (send lb get-number))
                                       (- (send lb get-number) 1)
                                       (car n)))]))))])])
      (unless (pair? (send lb get-selections))
        (send remove-button enable #f))
      (preferences:add-callback sym
                                (λ (p v)
                                  (send lb clear)
                                  (for-each (λ (x) (send lb append (pref->string x))) v)))))
  
  (define (get-new-simple-keyword label)
    (λ ()
      (let ([new-one
             (keymap:call/text-keymap-initializer
              (λ ()
                (get-text-from-user
                 (format (string-constant enter-new-keyword) label)
                 (format (string-constant x-keyword) label))))])
        (and new-one
             (let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f)))
                             (read (open-input-string new-one)))])
               
               (and (symbol? parsed)
                    (symbol->string parsed)))))))
  
  (define (get-new-cond-keyword)
    (define f (new dialog% [label (format (string-constant enter-new-keyword) "Cond")]))
    (define tb (keymap:call/text-keymap-initializer
                (λ ()
                  (new text-field% 
                       [parent f]
                       [label #f]))))
    (define number-panel (new horizontal-panel% [parent f] [stretchable-height #f]))
    (define number-label (new message% [parent number-panel] [label (string-constant skip-subexpressions)]))
    (define number
      (keymap:call/text-keymap-initializer
       (λ ()
         (new text-field% 
              [parent number-panel]
              [init-value "1"]
              [min-width 50]
              [label #f]))))
    
    (define answers #f)
    (define bp (new horizontal-panel% 
                    [parent f] 
                    [stretchable-height #f]
                    [alignment '(right center)]))
    (define (confirm-callback b e)
      (let ([n (string->number (send number get-value))]
            [sym (with-handlers ([exn:fail:read? (λ (x) #f)])
                   (read (open-input-string (send tb get-value))))])
        (when (and (number? n)
                   (symbol? sym))
          (set! answers (list (symbol->string sym) n)))
        (send f show #f)))
    
    (define (cancel-callback b e)
      (send f show #f))
    
    (define-values (ok-button cancel-button)
      (gui-utils:ok/cancel-buttons bp confirm-callback cancel-callback (string-constant ok) (string-constant cancel)))
    (send tb focus)
    (send f show #t)
    answers)
  
  (define stupid-internal-definition-syntax1
    (mk-list-box 'framework:square-bracket:letrec "Letrec" values (get-new-simple-keyword "Letrec")))
  (define stupid-internal-definition-syntax3
    (mk-list-box 'framework:square-bracket:local 
                 "Local" 
                 values
                 (get-new-simple-keyword "Local")))
  (define stupid-internal-definition-syntax2
    (mk-list-box 'framework:square-bracket:cond/offset 
                 "Cond" 
                 (λ (l) (format "~a (~a)" (car l) (cadr l)))
                 get-new-cond-keyword))
  
  (define check-box (new check-box% 
                         [parent main-panel]
                         [label (string-constant fixup-open-brackets)]
                         [value (preferences:get 'framework:fixup-open-parens)]
                         [callback 
                          (λ (x y)
                            (preferences:set 'framework:fixup-open-parens (send check-box get-value)))]))
  (preferences:add-callback
   'framework:fixup-open-parens
   (λ (p v)
     (send check-box set-value v)))
  
  main-panel)

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