racket.rkt

#lang racket/unit

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

(require string-constants
         racket/class
         racket/string
         mred/mred-sig
         syntax-color/module-lexer
         "collapsed-snipclass-helpers.rkt"
         "sig.rkt"
         "srcloc-panel.rkt"
         "../gui-utils.rkt"
         "../preferences.rkt"
         racket/match
         racket/contract/option)

(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:racket^
                [-text-mode<%> text-mode<%>]
                [-text<%> text<%>]
                [-text% text%]))

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

(define-local-member-name 
  stick-to-next-sexp?
  get-private-racket-container-keymap)

(define (racket-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-new)
    (inherit set-snipclass)
    (set-snipclass 2lib-snip-class)))

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

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

;; old snips (from old versions of drracket) 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-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)])
               (when fwd
                 (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))
      (text ,constant-green ,(string-constant scheme-mode-color-text))
      (constant ,constant-green ,(string-constant scheme-mode-color-constant))
      (hash-colon-keyword ,(make-object color% "brown")
                          ,(string-constant scheme-mode-color-hash-colon-keyword))
      (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% 157 157 250)]
         [constant-green (make-object color% 140 212 140)]
         [new-entries
          `((symbol ,sym/kwd)
            (keyword ,sym/kwd)
            (comment ,(make-object color% 249 148 40))
            (string ,constant-green)
            (text ,(make-object color% 51 174 51))
            (constant ,constant-green)
            (hash-colon-keyword ,(make-object color% 151 69 43))
            (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)
  (define sym (if (eq? _sym 'white-space)
                  'parenthesis
                  _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

    compute-racket-amount-to-indent
    compute-amount-to-indent))

(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<%> editor:keymap<%>)
         (-text<%>)
    (inherit begin-edit-sequence
             delete
             end-edit-sequence
             local-edit-sequence?
             find-string
             extend-position
             get-character
             get-extend-end-position
             get-extend-start-position
             get-keymap
             get-text
             get-start-position
             get-style-list
             get-end-position
             flash-on
             insert
             is-stopped?
             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 private-racket-container-keymap (new keymap:aug-keymap%))
    (define/public (get-private-racket-container-keymap) private-racket-container-keymap)
    
    (define/override (get-keymaps)
      (editor:add-after-user-keymap private-racket-container-keymap 
                                    (super get-keymaps)))
    
    (define/override (get-word-at current-pos)
      (let ([no-word ""])
        (cond
          [(is-stopped?)
           no-word]
          [else
           (let ([type (classify-position (max 0 (- current-pos 1)))])
             (cond
               [(memq type '(symbol keyword)) 
                (get-text (look-for-non-symbol/non-kwd (max 0 (- current-pos 1)))
                          current-pos)]
               [else no-word]))])))
    
    (define/private (look-for-non-symbol/non-kwd start)
      (let loop ([i start])
        (cond
          [(< i 0) 
           0]
          [(memq (classify-position i) '(symbol keyword))
           (loop (- i 1))]
          [else
           (+ i 1)])))
    
    (define/public (get-limit pos) 0)
    
    (define/public (balance-parens key-event [smart-skip #f])
      (insert-close-paren (get-start-position) 
                          (send key-event get-key-code)
                          (preferences:get 'framework:paren-match)
                          (preferences:get 'framework:fixup-parens)
                          (or smart-skip
                              (and (preferences:get 'framework:automatic-parens)
                                   (not (in-string/comment? this))
                                   'adjacent))))
    
    (define/public (tabify-on-return?) #t)
    (define/public (tabify [pos (get-start-position)])
      (define amt (compute-amount-to-indent pos))
      (define (do-indent amt)
        (define para (position-paragraph pos))
        (define end (paragraph-start-position para))
        (define-values (gwidth curr-offset tab-char?) (find-offset end))
        (unless (and (not tab-char?) (= amt (- curr-offset end)))
          (delete end curr-offset)
          (insert (make-string amt #\space) end)))
      (when amt (do-indent amt)))
    
      (define/private (find-offset start-pos)
        (define tab-char? #f)
        (define end-pos
          (let loop ([p start-pos])
            (let ([c (get-character p)])
              (cond
                [(char=? c #\tab)
                 (set! tab-char? #t)
                 (loop (add1 p))]
                [(char=? c #\newline)
                 p]
                [(char-whitespace? c)
                 (loop (add1 p))]
                [else
                 p]))))
        (define sizing-dc (get-dc))
        (define gwidth
          (cond
            [sizing-dc
             (define start-x (box 0))
             (define end-x (box 0))
             (position-location start-pos start-x #f #t #t)
             (position-location end-pos end-x #f #t #t)
             (define-values (w _1 _2 _3)
               (send sizing-dc get-text-extent "x"
                     (send (send (get-style-list)
                                 find-named-style "Standard")
                           get-font)))
             (inexact->exact (floor (/ (- (unbox end-x) (unbox start-x)) w)))]
            [else
             ;; if there is no display available, approximate the graphical
             ;; width on the assumption that we are using a fixed-width font
             (- end-pos start-pos)]))
        (values gwidth end-pos tab-char?))

    (define/pubment (compute-amount-to-indent pos)
      (inner (compute-racket-amount-to-indent pos) compute-amount-to-indent pos))
    (define/public-final (compute-racket-amount-to-indent pos [_get-head-sexp-type (λ (x) #f)])
      (cond
        [(is-stopped?) #f]
        [else
         (define get-head-sexp-type
           (let ([tabify-prefs (preferences:get 'framework:tabify)])
             (λ (text)
               (or (_get-head-sexp-type text)
                   (get-head-sexp-type-from-prefs text tabify-prefs)))))
         (define last-pos (last-position))
         (define para (position-paragraph pos))
         (define is-tabbable?
           (and (> para 0)
                (not (memq (classify-position (- (paragraph-start-position para) 1))
                           '(comment string error)))))
         (define end (if is-tabbable? (paragraph-start-position para) 0))
         (define 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
         (define contains
           (if is-tabbable?
               (backward-containing-sexp end limit)
               #f))
         (define contain-para (and contains
                                   (position-paragraph contains)))
         
         ;; last is the start of the S-exp just before "pos"
         (define last
           (if contains
               (let ([p (get-backward-sexp end)])
                 (if (and p (p . >= . limit))
                     p
                     (backward-match end limit)))
               #f))
         (define last-para (and last (position-paragraph last)))
         
         ;; last2 is the start of the S-exp just before the one before "pos"
         (define last2
           (if last
               (let ([p (get-backward-sexp last)])
                 (if (and p (p . >= . limit))
                     p
                     (backward-match last limit)))
               #f))
         
         (define (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)))])))))
         
         (define (get-proc)
           (define id-end (get-forward-sexp contains))
           (and (and id-end (> id-end contains))
                (let ([text (get-text contains id-end)])
                  (cond
                    [(member (classify-position contains) '(keyword symbol))
                     (get-head-sexp-type text)]
                    [else
                     'other]))))
         (define (procedure-indent)
           (case (get-proc)
             [(begin define) 1]
             [(lambda) 3]
             [else 0]))
         (define (define-or-lambda-style?)
           (define proc-name (get-proc))
           (or (equal? proc-name 'define)
               (equal? proc-name 'lambda)))
         (define (for/fold-style?)
           (define proc-name (get-proc))
           (equal? proc-name 'for/fold))
         
         (define (indent-first-arg start)
           (define-values (gwidth curr-offset tab-char?) (find-offset start))
           gwidth)
         
         (when (and is-tabbable?
                    (not (char=? (get-character (sub1 end))
                                 #\newline)))
           (insert #\newline (paragraph-start-position para)))
         
         (define amt-to-indent
           (cond
             [(not is-tabbable?)
              (if (= para 0)
                  0
                  #f)]
             [(let-values ([(gwidth real-start tab-char?) (find-offset end)])
                (and (<= (+ 3 real-start) (last-position))
                     (string=? ";;;"
                               (get-text real-start
                                         (+ 2 real-start)))))
              #f]
             [(not contains)
              ;; Something went wrong matching. Should we get here?
              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
              (define enclosing (find-up-sexp pos))
              (if enclosing
                  (+ (visual-offset enclosing) 1)
                  0)]
             [(= contains last)
              ;; this is the first expression in the define
              (+ (visual-offset contains)
                 (procedure-indent))]
             [(and (for/fold-style?)
                   last2
                   (= contains last2))
              (- last (paragraph-start-position last-para))]
             [(or (define-or-lambda-style?)
                  (for/fold-style?))
              ;; In case of "define", etc., ignore the position of last
              ;;  and just indent under the "define"
              (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 earlier and the second is an ellipsis.
              ;;      in that case, we just ignore the ellipsis or
              ;;    - the sexp we are indenting is a bunch of hypens;
              ;;      in that case, we match the opening paren
              (define id-end (get-forward-sexp contains))
              (define name-length
                (if id-end
                    (- id-end contains)
                    0))
              (cond
                [(or (first-sexp-is-keyword? contains)
                     (sexp-is-all-hyphens? contains))
                 (visual-offset contains)]
                [(second-sexp-is-ellipsis? contains)
                 (visual-offset contains)]
                [(sexp-is-all-hyphens? pos)
                 (visual-offset contains)]
                [(not (find-up-sexp pos))
                 (visual-offset contains)]
                [else
                 (+ (visual-offset contains)
                    name-length
                    (indent-first-arg (+ contains
                                         name-length)))])]
             [else
              ;; No particular special case, so indent to match first
              ;; S-expr that starts 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)
                      (visual-offset last))))]))
         amt-to-indent]))

    ;; returns #t if `pos` is in a symbol (or keyword) that consists entirely
    ;; of hyphens and has at least three hyphens; returns #f otherwise
    (define/private (sexp-is-all-hyphens? pos)
      (define fst-end (get-forward-sexp pos))
      (and fst-end
           (let ([fst-start (get-backward-sexp fst-end)])
             (and fst-start
                  (memq (classify-position fst-start) '(symbol keyword))
                  (>= (- fst-end fst-start) 3)
                  (let loop ([i fst-start])
                    (cond
                      [(< i fst-end)
                       (and (equal? #\- (get-character i)) (loop (+ i 1)))]
                      [else #t]))))))
    
    ;; 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/private (first-sexp-is-keyword? contains)
      (let ([fst-end (get-forward-sexp contains)])
        (and fst-end
             (let ([fst-start (get-backward-sexp fst-end)])
               (and fst-start
                    (equal? (classify-position fst-start) 'hash-colon-keyword))))))
    
    (define/public (tabify-selection [start-pos (get-start-position)]
                                     [end-pos (get-end-position)])
      (unless (is-stopped?) 
        (define first-para (position-paragraph start-pos))
        (define end-para (position-paragraph end-pos))
        (define tabifying-multiple-paras? (not (= first-para end-para)))
        (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)
                 (define start (paragraph-start-position para))
                 (define end (paragraph-end-position para))
                 (define skip-this-line?
                   (and tabifying-multiple-paras?
                        (for/and ([i (in-range start (+ end 1))])
                          (char-whitespace? (get-character i)))))
                 (unless skip-this-line?
                   (tabify start))
                 (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/public (tabify-all) (tabify-selection 0 (last-position)))
    (define/public (insert-return)
      (begin-edit-sequence #t #f)
      (define end-of-whitespace (get-start-position))
      (define start-cutoff
        (paragraph-start-position (position-paragraph end-of-whitespace)))
      (define start-of-whitespace
        (let loop ([pos end-of-whitespace])
          (if (and (> pos start-cutoff)
                   (char-whitespace? (get-character (sub1 pos))))
              (loop (sub1 pos))
              pos)))
      (delete start-of-whitespace end-of-whitespace)
      (insert #\newline)
      (when (and (tabify-on-return?)
                 (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))
    
    (define/public (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/public (comment-out-selection [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/public (box-comment-out-selection [_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/public (uncomment-selection [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)))


    ;; stick-to-next-sexp?: natural -> boolean
    (define stick-to-patterns
      '("'" "," ",@" "`" "#'" "#," "#`" "#,@"
        "#&" "#;" "#hash" "#hasheq" "#ci" "#cs"))
    (define stick-to-patterns-union
      (regexp (string-append 
               "^("
               (string-join (map regexp-quote stick-to-patterns) "|")
               ")")))
    (define stick-to-patterns-union-anchored
      (regexp (string-append 
               "^("
               (string-join (map regexp-quote stick-to-patterns) "|")
               ")$")))
    (define stick-to-max-pattern-length 
      (apply max (map string-length stick-to-patterns)))
    (define/public (stick-to-next-sexp? start-pos)
      ;; Optimization: speculatively check whether the string will
      ;; match the patterns; at time of writing, forward-match can be
      ;; really expensive.
      (define snippet 
        (get-text start-pos 
                  (min (last-position) 
                       (+ start-pos stick-to-max-pattern-length))))
      (and (regexp-match stick-to-patterns-union snippet)
           (let ([end-pos (forward-match start-pos (last-position))])
             (and end-pos
                  (regexp-match stick-to-patterns-union-anchored
                                (get-text start-pos end-pos))
                  #t))))
      
    (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/public (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/public (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/public (backward-sexp start-pos)
      (let ([end-pos (get-backward-sexp start-pos)])
        (if end-pos
            (set-position end-pos)
            (bell))
        #t))
    (define/public (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 (racket-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/public (up-sexp start-pos)
      (let ([exp-pos (find-up-sexp start-pos)])
        (if exp-pos
            (set-position exp-pos)
            (bell))
        #t))
    (define/public (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/public (down-sexp start-pos)
      (let ([pos (find-down-sexp start-pos)])
        (if pos
            (set-position pos)
            (bell))
        #t))
    (define/public (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 #\[)
                         (char=? first-char #\{))]
             [closer (and paren? 
                          (get-forward-sexp pos))])
        (if (and paren? closer)
            (begin (begin-edit-sequence #t #f)
                   (delete pos (add1 pos))
                   (delete (-  closer 2) (- closer 1))
                   (end-edit-sequence))
            (bell))
        #t))
    
    (define/private (select-text f forward?)
      (define start-pos (get-start-position))
      (define end-pos (get-end-position))
      (define new-pos
        (if forward?
            (if (= (get-extend-start-position) start-pos)
                (f end-pos)
                (f start-pos))
            (if (= (get-extend-end-position) end-pos)
                (f start-pos)
                (f end-pos))))
      (if new-pos 
          (extend-position new-pos)
          (bell))
          #t)

    (define/public (select-forward-sexp) (select-text (λ (x) (get-forward-sexp x)) #t))
    (define/public (select-backward-sexp) (select-text (λ (x) (get-backward-sexp x)) #f))
    (define/public (select-up-sexp) (select-text (λ (x) (find-up-sexp x)) #f))
    (define/public (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 #t #f)
      (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 #t #f)
      (define begin-outer (find-up-sexp begin-inner))
      (cond
        [begin-outer
          (define 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 #t #f)
      (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 (racket-paren:get-paren-pairs))]
            [close-parens (map cdr (racket-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)
    (define/public (get-tab-size) tab-size)
    (define/public (set-tab-size s) (set! tab-size s))
    
    (define/override (get-start-of-line pos)
      (define para (position-paragraph pos))
      (define para-start (paragraph-start-position para))
      (define para-end (paragraph-end-position para))
      (define first-non-whitespace 
        (let loop ([i para-start])
          (cond
            [(= i para-end) #f]
            [(char-whitespace? (get-character i))
             (loop (+ i 1))]
            [else i])))
      (define new-pos 
        (cond 
          [(not first-non-whitespace) para-start]
          [(= pos para-start) first-non-whitespace]
          [(<= pos first-non-whitespace) para-start]
          [else first-non-whitespace]))
      new-pos)

    (super-new)))

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

(define module-lexer/waived (waive-option module-lexer))

(define text-mode-mixin
  (mixin (color:text-mode<%> mode:surrogate-text<%>) (-text-mode<%>)
    
    (define saved-wordbreak-map #f)
    
    (define/override (on-disable-surrogate text)
      (keymap:remove-chained-keymap text keymap)
      (send text set-wordbreak-map saved-wordbreak-map)
      (super on-disable-surrogate text))
    
    (define/override (on-enable-surrogate text)
      (send text begin-edit-sequence)
      (super on-enable-surrogate text)
      (send (send text get-private-racket-container-keymap) chain-to-keymap keymap #f)
      
      (set! saved-wordbreak-map (send text get-wordbreak-map))
      
      (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))
    (define tabify-pref-callback (lambda (k v) (set! tabify-pref v)))
    (preferences:add-callback
     'framework:tabify
     tabify-pref-callback
     #t)
    
    (define/override (put-file text sup directory default-name)
      ;; don't call the surrogate's super, since it sets the default extension
      (cond
        [(equal? (finder:default-extension) "")
         (parameterize ([finder:default-extension "rkt"])
           (sup directory default-name))]
        [else (sup directory default-name)]))

    (define/override (set-get-token get-token-)
      (super set-get-token (wrap-get-token get-token- (λ () tabify-pref))))

    (super-new (get-token (wrap-get-token module-lexer/waived (λ () tabify-pref)))
               (token-sym->style short-sym->style-name)
               (matches '((|(| |)|)
                          (|[| |]|)
                          (|{| |}|))))))

(define (wrap-get-token get-token- get-tabify-pref)
  (define wrapped-get-token
    (cond
      [(procedure-arity-includes? get-token- 3)
       (λ (in offset mode)
         (define-values (lexeme type paren start end backup-delta new-mode)
           (get-token- in offset mode))
         (cond
           [(and (eq? type 'symbol)
                 (string? lexeme)
                 (get-head-sexp-type-from-prefs lexeme (get-tabify-pref)))
            (values lexeme 'keyword paren start end backup-delta new-mode)]
           [else
            (values lexeme type paren start end backup-delta new-mode)]))]
      [else
       (λ (in)
         (define-values (lexeme type paren start end) (get-token- in))
         (cond
           [(and (eq? type 'symbol)
                 (string? lexeme)
                 (get-head-sexp-type-from-prefs lexeme (get-tabify-pref)))
            (values lexeme 'keyword paren start end)]
           [else
            (values lexeme type paren start end)]))]))
  (procedure-rename wrapped-get-token
                    (string->symbol
                     (format "~a wrapped" (object-name get-token-)))))

;; get-head-sexp-type-from-prefs : string (list ht regexp regexp regexp)
;;                              -> (or/c #f 'lambda 'define 'begin 'for/fold)
(define (get-head-sexp-type-from-prefs text pref)
  (define ht (car pref))
  (define beg-reg (list-ref pref 1))
  (define def-reg (list-ref pref 2))
  (define lam-reg (list-ref pref 3))
  (define for/fold-reg (list-ref pref 4))
  (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]
       [(and for/fold-reg (regexp-match? for/fold-reg text)) 'for/fold]
       [else #f]))))


;; in-position? : text (list symbol) -> boolean
;; determines if the cursor is currently sitting in a particular
;; position. To make detection of whether the cursor is in
;; a string or comment more robust, check also the position
;; right before the cursor to make sure it matches. This handles
;; the situation ... |"blah blah"  where | indicates cursor; in
;; this case, the cursor is _not_ in the string (although
;; classify-position characterizes it so).
(define (in-position? text sym-list)
  (define selection-start (send text get-start-position))
  (define class-right (send text classify-position selection-start))
  (define class-left (and (> selection-start 0)
                          (send text classify-position (- selection-start 1))))
  ; By default, the position class is the class of the token at the r.h.s of the cursor.
  (define the-class class-right)
  ; Now for some special cases:
  ;
  ; Check if the cursor is right after a line comment, that is, on the newline character on the same
  ; line as the comment (which position is classified as 'white-space instead of 'comment).
  ; If so, a newly inserted character will still be in the line comment.
  (when (eq? 'comment class-left) ; right after a comment
    (define-values (token-start token-end) ; l.h.s. token
      (send text get-token-range (- selection-start 1)))
    ; Notice: This uses a racket-specific check, which is not ideal. Instead the tokenizer should
    ; be able to report the comment kind but that would likely be either messy or bwd incompatible.
    (when (eqv? #\; (send text get-character token-start)) ; line comment
      (set! the-class class-left)))
  ; Check if the cursor is right before a string or a comment; if so a newly inserted character
  ; will *not* be inside the string or comment, so we reclassify the position as 'white-space.
  (when (memq class-right '(comment string))
    (define-values (token-start token-end) ; r.h.s. token
      (send text get-token-range selection-start))
    (when (= token-start selection-start)
      (set! the-class 'white-space)))
  (and (member the-class sym-list) #t))

;; determines if the cursor is currently sitting in a string
;; literal or a comment. 
(define (in-string/comment? text)
  (in-position? text '(comment string)))

;; produces the 1 character string immediately following
;; the cursor, if there is one and if there is not a current
;; selection, in which case produces #f
(define (immediately-following-cursor text)
  (define selection-start (send text get-start-position))
  (and (= selection-start (send text get-end-position))   ; nothing selected
       (< selection-start (send text last-position))
       (send text get-text selection-start (+ selection-start 1))))


(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 #:alt-as-meta-keymap [alt-as-meta-keymap #f])
  (define (add-function name f)
    (send keymap add-function name f)
    (when alt-as-meta-keymap
      (send alt-as-meta-keymap add-function name f)))
  (define (add-edit-function name f)
    (send keymap add-function name (λ (edit event) (f edit)))
    (when alt-as-meta-keymap
      (send alt-as-meta-keymap add-function name (λ (edit event) (f edit)))))
  (define (add-pos-function name f)
    (define callback (λ (edit event)
                       (f edit (send edit get-start-position))))
    (send keymap add-function name callback)
    (when alt-as-meta-keymap
      (send alt-as-meta-keymap add-function name callback)))
  (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)))
  
  (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-function "paren-double-select"
        (λ (text event)
          (keymap:region-click
           text event 
           (λ (click-pos eol?)
             (define (word-based)
               (define start-box (box click-pos))
               (define end-box (box click-pos))
               (send text find-wordbreak start-box end-box 'selection)
               (values (unbox start-box) (unbox end-box)))
             (define token (send text classify-position click-pos))
             (define-values (start end)
               (cond
                 [(memq token '(string comment text)) (word-based)]
                 [(and (equal? token 'other)
                       (let-values ([(start end) (send text get-token-range click-pos)])
                         (and start
                              end
                              (let ([str (send text get-text start end)])
                                (or (regexp-match? #rx"^#lang" str)
                                    (regexp-match? #rx"^#!" str))))))
                  (word-based)]
                 [(and (equal? token 'parenthesis)
                       (ormap (λ (pr) (equal? (cdr pr) (string (send text get-character click-pos))))
                              (racket-paren:get-paren-pairs)))
                  (define start (send text get-backward-sexp (+ click-pos 1)))
                  (if start 
                      (values start (+ click-pos 1))
                      (word-based))]
                 [else
                  (let ([end (send text get-forward-sexp click-pos)])
                    (if end 
                        (let ([beginning (send text get-backward-sexp end)])
                          (if beginning
                              (values beginning end)
                              (word-based)))
                        (word-based)))]))
             (send text set-position start end)))))

  (let ([add/map-non-clever
         (λ (name keystroke char [closer #f])
           (add-edit-function 
            name
            (λ (e)
              (send e begin-edit-sequence)
              (define start (send e get-start-position))
              (define stop (send e get-end-position))
              (send e insert char start stop)
              (when (and closer (preferences:get 'framework:automatic-parens))
                (send e insert closer (+ start 1) (+ start 1)))
              (send e end-edit-sequence)))
           (send keymap map-function keystroke name))])
    (add/map-non-clever "non-clever-open-square-bracket" "~g:c:[" #\[ #\])
    (add/map-non-clever "non-clever-close-square-bracket" "~g:c:]" #\])
    (add/map-non-clever "non-clever-close-curley-bracket" "~g:c:}" #\})
    (add/map-non-clever "non-clever-close-round-paren" "~g:c:)" #\)))
  
  (add-function "balance-parens"
                (λ (edit event)
                  (send edit balance-parens event)))
  (add-function "balance-parens-forward"
                (λ (edit event)
                  (send edit balance-parens event 'forward)))

  (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 "leftbuttondouble" "paren-double-select")
  

  ;(define (insert-brace-pair text open-brace close-brace [space-between? #f])
  ;  (insert/check/balance text open-brace close-brace #f space-between?))
    #|
    (define selection-start (send text get-start-position))
    (define hash-before?  ; tweak to detect and correctly close block comments #| ... |#
      (and (< 0 selection-start)
           (string=? "#" (send text get-text (- selection-start 1) selection-start))))
    (send text begin-edit-sequence)
    (send text set-position (send text get-end-position))
    (when space-between? (send text insert " "))
    (send text insert close-brace)
    (when (and (char? open-brace) (char=? #\| open-brace) hash-before?) 
      (send text insert #\#))
    (send text set-position selection-start)
    (send text insert open-brace)
    (when space-between?
      (send text set-position (+ (send text get-start-position) 1)))
    (send text end-edit-sequence))|#

  ;; Inserts the open parens character and, if the resulting token
  ;; type satisfies checkp, then go ahead and insert the close parens
  ;; and set the cursor between them.
  ;; When space-between?, adds a space between the braces and places
  ;; the cursor after the space.
  ;; checkp: (or/c #f symbol (symbol -> boolean))
  ;;  When checkp is #f, always inserts both open and close braces
  ;;  When checkp is a symbol, only inserts the closing brace if 
  ;;    the tokenizer identifies open-brace as that type of token
  ;;    having inserted it
  ;;  When checkp is a predicate, only inserts the closing brace if
  ;;    the token type of the inserted open-brace satisfies it
  (define (insert-brace-pair text open-brace close-brace [checkp #f] [space-between? #f])
    (define selection-start (send text get-start-position))
    (define selection-end (send text get-end-position))
    (define open-len (if (string? open-brace) (string-length open-brace) 1))
    (send text begin-edit-sequence #t #f)
    (send text insert open-brace selection-start)
    (define tok-type (send text classify-position selection-start))
    (when (or (not checkp)
              (and (symbol? checkp) (eq? checkp tok-type))
              (and (procedure? checkp) (checkp tok-type)))
      (define hash-before?  ; tweak to detect and correctly close block comments #| ... |#
        ; Notice: This is racket-specific and despite the name of the file we should instead rely
        ; on the lexer alone so as to be language-agnostic.
        ; Currently though the lexer does not provide enough information about the comment type.
        (and (< 0 selection-start)
             (string=? "#" (send text get-text (- selection-start 1) selection-start))))
      (send text set-position (+ selection-end open-len))
      (when space-between? (send text insert " "))
      (send text insert close-brace)
      (when (and (char? open-brace) (char=? #\| open-brace) hash-before?) 
        (send text insert #\#))
      (send text set-position (+ selection-start open-len (if space-between? 1 0))))
    (send text end-edit-sequence))
  

  ;; only insert a pair if automatic-parens preference is on, depending
  ;; on other analyses of the state of the text (e.g. auto-parens shouldn't
  ;; affect typing literal characters inside a string constant, etc.)
  (define (maybe-insert-brace-pair text open-brace close-brace)
    (define open-parens 
      (for/list ([x (racket-paren:get-paren-pairs)]) (string-ref (car x) 0)))
    (cond
      [(not (preferences:get 'framework:automatic-parens))
       (define startpos (send text get-start-position))
       (if (and (send text get-overwrite-mode) 
                (= startpos (send text get-end-position)))
           (send text insert open-brace startpos (add1 startpos))
           (send text insert open-brace))]
    
      [else  ; automatic-parens is enabled
       (define c (immediately-following-cursor text))
       (define cur-token 
         (send text classify-position (send text get-start-position)))
       (cond
         ; insert paren pair if it results valid parenthesis token...
         [(member open-brace open-parens) 
          (insert-brace-pair text open-brace close-brace 'parenthesis)]
         
         ; ASSUME: from here on, open-brace is either "  or  |
         [else
          ;(printf "tok ~a~n" cur-token)
          (match cur-token
            [(or 'error #f) (insert-brace-pair text open-brace close-brace 'error)]
            ['constant (insert-brace-pair text open-brace close-brace 
                                          (λ (t) (not (equal? t 'constant))))]
            [(or 'symbol 'comment)
             (cond
               [(and c (char=? #\| open-brace) (string=? c "|"))   ;; smart skip
                (send text set-position (+ 1 (send text get-end-position)))
                (define d (immediately-following-cursor text))
                (when (and d (string=? d "#"))   ; a block comment?
                  (send text set-position (+ 1 (send text get-end-position))))]
               [(in-position? text '(comment)) (send text insert open-brace)]
               [else (insert-brace-pair text open-brace close-brace)])]
            ['string
             (cond
               [(not (char=? #\" open-brace))
                (insert-brace-pair text open-brace close-brace
                                   (λ (t) (not (or (equal? 'comment t) (equal? 'string t)))))]
               [else 
                (define start-position (send text get-start-position))
                (define end-position (send text get-end-position))
                (cond
                  ; smart skip a " if it is the immediately following character (c)
                  [(and c (string=? c "\"")) 
                   (send text set-position (+ 1 end-position))]
                  
                  ; there is no current selection - split the string in two
                  [(= start-position end-position)
                   (insert-brace-pair text #\" #\" #f #t)]
                  
                  ; there is a selection - split the selected text off as a
                  ; separate string from the surrounding in an intelligent way
                  ; and retain selection of the split-out string
                  [else (define selection-length (- end-position start-position))
                        (insert-brace-pair text "\" \"" "\" \"")
                        (define cur-position (send text get-start-position))
                        (send text set-position 
                              (- cur-position 1)
                              (+ cur-position selection-length 1))])])]
            [_  (insert-brace-pair text open-brace close-brace
                                   (λ (t) (not (equal? 'comment t))))])])]))
         

      
  
  (add-edit-function "insert-()-pair" (λ (text) (insert-brace-pair text #\( #\))))
  (add-edit-function "insert-[]-pair" (λ (text) (insert-brace-pair text #\[ #\])))
  (add-edit-function "insert-{}-pair" (λ (text) (insert-brace-pair text #\{ #\})))
  (add-edit-function "insert-\"\"-pair" (λ (text) (insert-brace-pair text #\" #\")))
  (add-edit-function "insert-||-pair" (λ (text) (insert-brace-pair text #\| #\|)))
  
  (add-edit-function "maybe-insert-()-pair" (λ (text) (maybe-insert-brace-pair text #\( #\))))
  (add-edit-function "maybe-insert-[]-pair" (λ (text) (maybe-insert-brace-pair text #\[ #\])))
  (add-edit-function "maybe-insert-{}-pair" (λ (text) (maybe-insert-brace-pair text #\{ #\})))
  (add-edit-function "maybe-insert-\"\"-pair" (λ (text) (maybe-insert-brace-pair text #\" #\")))
  (add-edit-function "maybe-insert-||-pair" (λ (text) (maybe-insert-brace-pair text #\| #\|)))
  
  (add-edit-function "maybe-insert-[]-pair-maybe-fixup-[]"
                     (λ (text)
                       (cond
                         [(or (not (preferences:get 'framework:fixup-open-parens))
                              (send text is-stopped?))
                          (maybe-insert-brace-pair text #\[ #\])]
                         [else 
                          (insert-paren text)])))
  
  ;; Deletes empty brace pairs (including " and |) depending on context, in a manner intended
  ;; to be usually the inverse of auto-parens.
  ;; Dependent on Racket's parens being single characters.
  (define (maybe-delete-empty-brace-pair text)
    (cond
      [(not (preferences:get 'framework:automatic-parens)) (send text delete)]
      [else
       (define selection-start (send text get-start-position))
       (define prev-position (- selection-start 1))
       (define next-position (+ selection-start 1))
       (define before-and-after
         (and (= selection-start (send text get-end-position))   ; nothing selected
              (< 0 selection-start)
              (< selection-start (send text last-position))
              (send text get-text prev-position next-position)))
       (define (paren-pair? two-str)
         (and two-str
              (equal? (send text get-matching-paren-string (substring two-str 0 1) 'close)
                      (substring two-str 1))))
       (define cur-token (send text classify-position selection-start))
       (define adj-tokens
         (and (< 0 selection-start)
              (equal? cur-token (send text classify-position prev-position))
              cur-token))
       (match* (before-and-after adj-tokens)
         [((? paren-pair?) 'parenthesis)
          (send text delete prev-position next-position)]
         [("\"\"" 'error)
          (send text delete prev-position next-position)]
         [("\"\"" 'string)
          (if (and (< 0 prev-position)
                   (string=? "\\" (send text get-text (- selection-start 2) prev-position)))
              (send text delete)
              (send text delete prev-position next-position))]
         [("||" (or 'comment 'symbol 'error))
          (cond
            [(and (< 0 prev-position)
                  (< next-position (send text last-position))
                  (string=? "#||#" (send text get-text (- selection-start 2) (+ selection-start 2))))
             (send text delete prev-position (+ selection-start 2))]
            [(equal? adj-tokens 'comment) (send text delete)]
            [else (send text delete prev-position next-position)])]
         [(_ _) (send text delete)])]))

  (add-edit-function "maybe-delete-empty-brace-pair" maybe-delete-empty-brace-pair)

  (define (insert-lambda-template edit)
    (send edit begin-edit-sequence)
    (let ([selection-start (send edit get-start-position)])
      (send edit set-position (send edit get-end-position))
      (send edit insert ")")
      (send edit set-position selection-start)
      (send edit insert ") ")
      (send edit set-position selection-start)
      (send edit insert "(λ ("))
    (send edit end-edit-sequence))
  
  (add-edit-function "insert-lambda-template" insert-lambda-template)
  
  (define (map-meta key func) (keymap:send-map-function-meta keymap key func #:alt-as-meta-keymap alt-as-meta-keymap))
  (define (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

  (map-meta ")" "balance-parens-forward")
  (map-meta "]" "balance-parens-forward")
  (map-meta "}" "balance-parens-forward")
  
  (map-meta "(" "insert-()-pair")
  (map-meta "[" "insert-[]-pair")
  (map-meta "{" "insert-{}-pair")
  (map-meta "\"" "insert-\"\"-pair")
  (map-meta "|" "insert-||-pair")

  (map "(" "maybe-insert-()-pair")
  (map "[" "maybe-insert-[]-pair-maybe-fixup-[]")
  (map "{" "maybe-insert-{}-pair")
  (map "\"" "maybe-insert-\"\"-pair")
  (map "|" "maybe-insert-||-pair")

  (map "~c:backspace" "maybe-delete-empty-brace-pair")

  (map-meta "s:l" "insert-lambda-template")

  (map "c:c;c:b" "remove-parens-forward")
  (map "c:c;c:l" "introduce-let-ans")
  (map "c:c;c:o" "move-sexp-out")
  (map "c:c;c:e" "kill-enclosing-parens")
  (map "c:c;c:[" "toggle-round-square-parens"))

(define keymap (make-object keymap:aug-keymap%))
(define alt-as-meta-keymap (make-object keymap:aug-keymap%))
(setup-keymap keymap #:alt-as-meta-keymap alt-as-meta-keymap)
(define (get-keymap) keymap)

(define (adjust-alt-as-meta on?)
  (send keymap remove-chained-keymap alt-as-meta-keymap)
  (when on?
    (send keymap chain-to-keymap alt-as-meta-keymap #f)))
(preferences:add-callback 'framework:alt-as-meta
                          (λ (p v) (adjust-alt-as-meta v)))
(adjust-alt-as-meta (preferences:get 'framework:alt-as-meta))

;; choose-paren : racket-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)]
         [for/fold-like-forms (preferences:get 'framework:square-bracket:for/fold)])
    (send text begin-edit-sequence #f #f)
    (if (and (send text get-overwrite-mode) (= start-pos end-pos))
        (send text insert "[" start-pos (add1 start-pos) #f)
        (send text insert "[" start-pos 'same #f))
    (when (equal? (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
                (define before-whitespace-pos2 
                  (send text skip-whitespace backward-match 'backward #t))
                (define 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.
                (define b-w-p-char (send text get-character (- before-whitespace-pos 1)))
                (cond
                  [(equal? b-w-p-char #\()
                   (define second-before-whitespace-pos (send text skip-whitespace 
                                                              (- before-whitespace-pos 1)
                                                              'backward
                                                              #t))
                   (define 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
                      (define second-before-whitespace-pos2 (send text skip-whitespace 
                                                                  second-backwards-match
                                                                  'backward
                                                                  #t))
                      (define second-backwards-match2 (send text backward-match
                                                            second-before-whitespace-pos2
                                                            0))
                      (cond
                        [(and second-backwards-match2
                              (ormap (λ (x)
                                       (text-between-equal? x
                                                            text
                                                            second-backwards-match2
                                                            second-before-whitespace-pos2))
                                     for/fold-like-forms))
                         ;; found a for/fold-like form, so we keep the [
                         (void)]
                        [(and second-backwards-match2
                              (member (send text classify-position second-backwards-match)
                                      ;;; otherwise, this isn't a `let loop',
                                      ;;; it is a regular let
                                      '(symbol keyword))
                              (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)
    (cond
      [(and (preferences:get 'framework:automatic-parens)
            (not (in-string/comment? text)))
       (send text insert real-char start-pos start-pos)
       (when (equal? (send text classify-position start-pos) 'parenthesis)
         (send text insert (case real-char
                           [(#\() #\)]
                           [(#\[) #\]]
                           [(#\{) #\}])
             (+ end-pos 1) (+ end-pos 1))
         (send text set-position (+ start-pos 1)))]
      [else
       (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
                 (if (send text stick-to-next-sexp? backward-match)
                     n
                     (+ 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)
  
  (mk-list-box 'framework:square-bracket:letrec "Letrec" values (get-new-simple-keyword "Letrec"))
  (mk-list-box 'framework:square-bracket:local 
               "Local" 
               values
               (get-new-simple-keyword "Local"))
  (mk-list-box 'framework:square-bracket:for/fold 
               "For/fold" 
               values
               (get-new-simple-keyword "For/fold"))
  (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)
      (define all-keywords (hash-map hash-table list))
      (define (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)
               (pick-out 'for/fold all-keywords null))))
  (define-values (begin-keywords define-keywords lambda-keywords for/fold-keywords)
    (get-keywords (car (preferences:get 'framework:tabify))))
  (define ((add-button-callback keyword-type keyword-symbol list-box) button command)
    (define 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)
    (define selections (send list-box get-selections))
    (define symbols 
      (map (λ (x) (read (open-input-string (send list-box get-string x)))) selections))
    (for-each (λ (x) (send list-box delete x)) (reverse selections))
    (define pref (preferences:get 'framework:tabify))
    (define 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)
    (define vert (make-object vertical-panel% main-panel))
    (make-object message% (format (string-constant x-like-keywords) string) vert)
    (define box (make-object list-box% #f keywords vert void '(multiple)))
    (define button-panel (make-object horizontal-panel% vert))
    (define text (new text-field% 
                      (label (string-constant indenting-prefs-extra-regexp))
                      (callback (λ (tf evt) 
                                  (define 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)))
    (define add-button (make-object button% (string-constant add-keyword)
                         button-panel (add-button-callback string symbol box)))
    (define 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-values (for/fold-list-box for/fold-regexp-text)
    (make-column "For/fold"
                 'for/fold
                 for/fold-keywords
                 (λ (x) (update-pref 4 x))))
  (define (update-list-boxes hash-table)
    (define-values (begin-keywords define-keywords lambda-keywords for/fold-keywords) 
      (get-keywords hash-table))
    (define (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)
    (reset for/fold-list-box for/fold-keywords)
    #t)
  (define update-gui
    (λ (pref)
      (update-list-boxes (car pref))
      (send begin-regexp-text set-value (or (object-name (list-ref pref 1)) ""))
      (send define-regexp-text set-value (or (object-name (list-ref pref 2)) ""))
      (send lambda-regexp-text set-value (or (object-name (list-ref pref 3)) ""))
      (send for/fold-regexp-text set-value (or (object-name (list-ref pref 4)) ""))))
  (preferences:add-callback 'framework:tabify (λ (p v) (update-gui v)))
  (update-gui (preferences:get 'framework:tabify))
  main-panel)