#lang scheme/base

;; history
;; 12/1/2008
;;   reorganized program structure so that commands are matched
;; against pseudo-regular expressions
;;
;; 11/21/2008
;; start vim tool

(require scheme/base
         scheme/gui
         scheme/runtime-path
         drscheme/tool
         mrlib/switchable-button
         framework/framework
         (only-in srfi/13 string-index))

(require (prefix-in utils: "utils.ss"))

(provide tool@)

;; more robust char checking
(define (char=?* c1 c2)
  (and (char? c1)
       (char? c2)
       (char=? c1 c2)))

;; convert char's as normal, ignore everything else
(define (string* c)
        (cond
          [(char? c) (string c)]
          [else ""]))

;; global variables
(define verbose? #f)
(define-runtime-path vi.png "vi.png")
(define-runtime-path vi-disabled.png "vi-disabled.png")

(define vi-bitmap
  (make-object bitmap% vi.png 'png/mask))

(define vi-disabled-bitmap
  (make-object bitmap% vi-disabled.png 'png/mask))

(define enabled? #t)

(define (log* . vs)
  (when verbose?
    (apply printf vs)))

;; loops through a list of commands until a match is found
;; if a partial match is found #t is returned. if nothing matches
;; then #f is returned. otherwise a full match returns the expression.
;; expressions should not return #f
(define-syntax (commands stx)
  (syntax-case stx ()
    ((_ ((chars ...) expr) ...)
     #'(lambda (stuff)
         (define partial (lambda () (void)))
         (define all-exprs (list (lambda ()
                                   (let loop ([cs (list chars ...)]
                                              [all stuff])
                                     (cond
                                       [(and (null? cs)
                                             (null? all))
                                        expr]
                                       [(null? cs) #f]
                                       [(null? all) partial]
                                       [(eq? (car cs) 'any)
                                        (loop (cdr cs) (cdr all))]
                                       [(equal? (car cs) (car all))
                                        (loop (cdr cs) (cdr all))]
                                       [else #f])))
                                 ...))
         (let ([result 
                 (let result-loop ([so-far #f]
                                   [exprs all-exprs])
                   (cond
                     [(null? exprs) so-far]
                     [else (let ([x ((car exprs))])
                             (cond
                               [(eq? x partial) (result-loop partial (cdr exprs))]
                               [(not x) (result-loop so-far (cdr exprs))]
                               [else x]))]))])
           (cond
             [(eq? result partial) #f]
             ;; if nothing matched, return true so that the command is cleared
             [(not result) #t]
             [else result]))))))

;; badly named..
(define escape-commands
  (commands
    [(#\i) 'insert]
    [(#\w) 'move-word-right]
    [(#\b) 'move-word-left]
    [(#\j) 'move-down]
    [(#\k) 'move-up]
    [(#\h) 'move-left]
    [(#\l) 'move-right]
    [('right) 'move-right]
    [('left) 'move-left]
    [('up) 'move-up]
    [('down) 'move-down]
    [(#\p) 'paste]
    [(#\x) 'x-cut]
    [(#\$) 'move-to-end-of-line]
    [(#\^) 'move-to-start-of-line]
    [(#\u) 'undo]
    [(#\n) 'next-search]
    [(#\N) 'prev-search]
    [(#\a) 'insert-after]
    [(#\A) 'insert-after-end-of-line]
    [(#\o) 'insert-new-line]
    [(#\0) 'move-to-first-column]
    [(#\z #\.) 'scroll-to-center]
    [(#\Z #\Z) 'save-and-quit]
    [(#\Z #\Q) 'quit]
    [(#\d #\d) 'delete-line]
    [(#\d #\$) 'delete-till-end-of-line]
    [(#\d #\w) 'delete-word]
    [(#\= #\=) 'indent]
    [(#\J) 'concat-line]
    [(#\G) 'goto-last-line]
    [(#\g #\g) 'goto-first-line]
    [(#\v) 'visual-mode]
    [(#\%) 'jump-bracket/jump-position]
    [(#\r 'any) 'replace]
    [(#\c #\w) 'change-word]
    [(#\y #\y) 'copy-line]
    ))

(define visual-commands
  (commands
    [(#\w) 'move-word-right]
    [(#\b) 'move-word-left]
    [(#\j) 'move-down]
    [(#\k) 'move-up]
    [(#\h) 'move-left]
    [(#\x) 'x-cut]
    [(#\$) 'move-to-end-of-line]
    [(#\^) 'move-to-start-of-line]
    [(#\0) 'move-to-first-column]
    [(#\l) 'move-right]
    [(#\y) 'copy]
    [(#\=) 'tabify]
    [(#\v) 'visual]))

;; todo: move vi editor to its own file so that it can be
;; used stand-alone -- (define vi-editor% (class editor% ...))

;; use a stack of modes
;; start with esc mode on the stack
;; esc mode cannot be removed
;; stack should be a fifo - (cons mode modes)
;; pop is (cdr modes)

(define mode-class
  (class object%
         (super-new)
         (init-field master)

         (define/public (mode-name)
           "some vi mode")

         (define/public (do-escape)
           (send master remove-mode))

         (define/public (do-char char)
           (void))))

(define movement-interface (interface () handle))
(define movement-mixin
  (mixin () (movement-interface)
    (inherit-field master)

    (define (do-move-down times)
      (utils:repeat (max 1 times)
                    (lambda (i)
                      (send master move-position 'down))))

    (define (do-move-up times)
      (utils:repeat (max 1 times)
                    (lambda (i)
                      (send master move-position 'up))))

    (define (do-move-left times)
      (utils:repeat (max 1 times)
                    (lambda (i)
                      (send master move-position 'left))))

    (define (do-move-right times)
      (utils:repeat (max 1 times)
                    (lambda (i)
                      (send master move-position 'right))))

    (define (do-move-word-right times)
      (utils:repeat 1 (lambda (i)
                        (let ([last (utils:next-word
                                      master
                                      (add1
                                        (send master get-end-position)))])
                          (send master set-position last)))))

    (define (do-move-word-left times)
      (utils:repeat 1 (lambda (i)
                        (let ([last (utils:previous-word
                                      master
                                      (max 0 (sub1
                                               (send master get-start-position))))])
                          (send master set-position last)))))

    (define (do-move-goto-first-line)
      (send master set-position 0))

    (define (do-move-goto-last-line)
      (let ([last (send master last-line)])
        (send master set-position
              (utils:find-line-start master last))))

    (define (do-move-to-end-of-line)
      (send master move-position 'right #f 'line))

    ;; move to the first non-whitespace character in the line
    (define (do-move-to-start-of-line)
      (let ([last (utils:find-line-end-current master)])
        (send master move-position 'left #f 'line)
        (let loop ([start (send master get-start-position)])
          (when (and (< start last)
                     (char-whitespace? (send master get-character start))
                     #;
                     (case (send master get-character start)
                       [(#\space #\tab) #t]
                       [else #f]))
            (loop (begin
                    (send master move-position 'right #f 'simple)
                    (send master get-start-position)))))))

    ;; move to column 1
    (define (do-move-to-first-column)
      (send master move-position 'left #f 'line))

    (define/public (handle kind numbers)
      (case kind
        [(move-down)       (do-move-down numbers)]
        [(move-up)         (do-move-up numbers)]
        [(move-left)       (do-move-left numbers)]
        [(move-right)      (do-move-right numbers)]
        [(move-word-right) (do-move-word-right numbers)]
        [(move-word-left)  (do-move-word-left numbers)]
        [(goto-first-line) (do-move-goto-first-line)]
        [(goto-last-line)  (do-move-goto-last-line)]
        [(move-to-end-of-line) (do-move-to-end-of-line)]
        [(move-to-start-of-line) (do-move-to-start-of-line)]
        [(move-to-first-column) (do-move-to-first-column)]
        ))

    (super-new)
    ))

(define command-use-interface (interface () use))
;; (define command-interface (interface () accept clear-command! separate-numers-from-command))
(define command-mixin
  (mixin () ()
    (inherit-field master)
    (field (command '()))

    (define (add-command! n)
      (set! command (cons n command)))

    (define/public (clear-command!)
      (set! command '()))

    ;; is this a stupid way of doing it?
    (define (number-char? char)
      (memq char '(#\0 #\1 #\2 #\3
                   #\4 #\5 #\6 #\7
                   #\8 #\9)))

    ;; split a command into its number repeat and command
    ;; e.g: 23j splits into 23 and j
    ;; the command comes in backwards, so reverse it
    (define/public (separate-numbers-from-command command)
      (let-values ([(rest numbers)
                    (let loop ([all (reverse command)]
                               [numbers '()])
                      (cond
                        [(null? all) (values all numbers)]
                        ;; if its a digit then include it as part
                        ;; of the number. if this is the first digit
                        ;; and its 0 then ignore it.
                        [(and (number-char? (car all))
                              (not (and (null? numbers)
                                        (char=?* #\0 (car all)))))
                         (loop (cdr all) (cons (car all) numbers))]
                        [else (values all numbers)]))])
        (values rest (let ([x (string->number
                                (apply string-append
                                       (map string (reverse numbers))))])
                       (if x x 0)))))

    ;; do something with a key press
    (define/public (accept char use)
      
      (define ch (send char get-key-code))
      (when (or (and (not (char? ch))
                     (not (eq? 'release ch)))
                (and (char? ch)
                     (> (char->integer ch) 0)))
        (cond
          [(char=?* #\backspace ch)
           (when (pair? command)
             (set! command (cdr command)))]
          [else (add-command! (if (char=?* ch #\return) #\+ ch))])
        (send master update-status
              (apply string-append (format "Vi ~a " (send this mode-name))
                     (map string* (reverse command))))
        (when (use char command)
          (clear-command!))))

    (begin
      (super-new))))

(define-syntax regexp-try
  (syntax-rules (else)
    [(_ str (var re expr) ...)
     (ormap (lambda (x) (x))
             (list (lambda ()
                     (let ([var (regexp-match (pregexp re) str)])
                       ;; (printf "~a match '~a' = ~a?\n" re str var)
                       (if var expr #f)))
                   ...))]))

(define ed-mixin
  (mixin () ()

    (init-field frame)
    (field (last-search-string #f))
    (inherit-field master)

    (define (goto-line line)
      (send master set-position
            (utils:find-line-start master line)))

    ;; show a dialog box with a list of commands in it
    (define (show-help)
      (void))

    (define (ensure-file-exists filename)
      (close-output-port (open-output-file filename #:exists 'can-update)))

    ;; try all the regex's and execute the command of the first matched thing
    ;; the first element (x) is bound to the result of the regexp
    (define/public (do-ed command)
      (regexp-try (apply string-append (map string* (reverse command)))
                  [x "^:w\\s*\\+$" (send (frame) save)]
                  [x "^:q\\s*\\+$" (send (frame) close)]
                  [x "^:e ([^\\s]*)\\+" 
                     (let ([filename (cadr x)])
                       ;; we shouldn't really create the file, but
                       ;; drscheme wants it to be around
                       (ensure-file-exists filename)
                       (send (frame) open-in-new-tab filename))]
                  [x "^:bd\\+" (send (frame) close-current-tab)]
                  [x "^:ha\\+" (send master print #t)]
                  [x "^:help\\+" (show-help)]
                  [x "^:(\\d+)\\s*\\+$" (goto-line (string->number (cadr x)))]
                  [x "^:run\\+" (send (frame) execute-callback)]
                  [x "^:bn\\+" (send (frame) next-tab)]
                  [x "^:bp\\+" (send (frame) prev-tab)]
                  [x "^:q!\\+" (send (frame) close)]
                  [x "^:wq\\+" (begin
                                 (send (frame) save)
                                 (send (frame) close))]

                  [x "^/(.*)" (begin
                                (let ([ender (string-index (cadr x) #\+)])
                                  (set! last-search-string
                                    (if ender
                                      (substring (cadr x) 0 ender)
                                      (cadr x)))
                                  (let ([found (send master find-string last-search-string)])
                                    (when found
                                      (send master set-position found)
                                      (let ([here (send master get-start-position)])
                                        (send master flash-on
                                              here
                                              (+ (string-length last-search-string)
                                                 here)))))
                                  ender))]

                  ;; things to ignore
                  [x "^[^:\\d/]...." #t]

                  ;; ignore the line
                  [x "^.*\\+" #t]))
    (begin
      (super-new))))

(define insert-mode-class
  (class mode-class
         (super-new)
         (inherit-field master)
         (init-field repeat)
         (field (buffer '()))

         (define/override (mode-name)
           "insert mode")

         (define/override (do-escape)
           (send master remove-mode)
           (let ((all (reverse buffer)))
             (repeat (lambda (i)
                       (for-each (lambda (x)
                                   (send master on-default-char* x))
                                 all)))))

         (define (erase-entire-line time)
           (let* ([end (send master get-start-position)]
                  [start (utils:find-line-start-current master)])
             (send master cut #f time start end)))

         (define (erase-last-word time)
           (let* ([here (send master get-start-position)]
                  [start (utils:previous-word master (max 0 (sub1 here)))])
             (send master cut #f time start here)))

         (define (do-control char)
           (case (send char get-key-code)
             [(#\u) (erase-entire-line (send char get-time-stamp))]
             [(#\w) (erase-last-word (send char get-time-stamp))]
             ;; auto-complete needs some work
             [(#\n) (send master auto-complete)]))

         (define (do-normal char)
           (cond
             [(char=?* (send char get-key-code) #\return)
              (send master insert-return)]
             [else
               (begin
                 (set! buffer (cons char buffer))
                 (send master on-default-char* char))]))

         (define/override (do-char char)
           (if (send char get-control-down)
             (do-control char)
             (do-normal char)))
         ))

;; maybe I can use a mixin to get the movement to work for visual mode
;; the same way it works in escape mode
(define visual-mode-class
  (class (command-mixin
           (movement-mixin mode-class))

         (inherit (movement:handle handle)
                  (command:accept accept)
                  separate-numbers-from-command)

         (begin
           (super-new)
           (send master set-anchor #t))
         
         (define/override (mode-name)
           "visual mode")

         (inherit-field master)
         (field (here (send master get-start-position)))

         (define/override (do-escape)
           (send master set-anchor #f)
           (send master remove-mode))

         (define (re-anchor old new)
           (if (> old new)
             (send master set-position new old)
             (send master set-position old new)))

         (define (do-normal char command)
           (let-values ([(rest numbers)
                         (separate-numbers-from-command command)])
             (let ([thing (visual-commands rest)])
               (log* "Command is ~a\n" thing)
               (let* ([xx (movement:handle thing numbers)]
                      [current-position (send master get-start-position)])
                 (when (not (send master get-anchor))
                   (re-anchor here
                              current-position)))
               (case thing
                 [(x-cut) (begin
                          (send master remove-mode)
                          (send master cut #f (send char get-time-stamp) 'start 'end)
                          (send master set-anchor #f))]
                 [(copy) (begin
                          (send master remove-mode)
                          (send master copy #f (send char get-time-stamp) 'start 'end)
                          (send master set-anchor #f))]
                 [(tabify) 
                  (begin
                    (send master tabify-selection)
                    (send master set-anchor #f)
                    (send master remove-mode))]
                 [(visual) (begin
                          (send master set-anchor #f)
                          (send master remove-mode))]
                 [else thing]))))

         (define (do-control char)
           (void))

         (define/override (do-char char)
           (if (send char get-control-down)
             (do-control char)
             (command:accept char do-normal)))
         ))

;; helper functions for setting the current vi mode
(define (insert-mode master repeat)
  (log* "[vi] insert mode\n")
  (send master update-status "Vi insert mode ")
  (new insert-mode-class (master master) (repeat repeat)))

(define (visual-mode master)
  (log* "[vi] visual mode\n")
  (send master update-status "Vi visual mode ")
  (new visual-mode-class (master master)))

(define (escape-mode master frame)
  (log* "[vi] escape mode\n")
  (new escape-mode-class [master master] [frame frame]))

(define escape-mode-class
  (class (ed-mixin
           (command-mixin
             (movement-mixin mode-class)))

         (inherit-field master)
         (inherit (movement:handle handle)
                  (command:accept accept)
                  (command:clear-command! clear-command!)
                  separate-numbers-from-command
                  do-ed)

         (field (last-motion #f))
         (inherit-field last-search-string)
         (inherit-field frame)
         (super-new)

         (define/override (mode-name)
           "escape mode")

         (define/override (do-escape)
           (command:clear-command!)
           (send master update-status "Vi escape mode "))

         (define (do-insert repeated)
           (send master add-mode (insert-mode master repeated)))

         (define (move-line-down)
           (send master move-position 'right #f 'line))
         
         (define (at-end-of-line?)
           (define (position-xy position)
             (let ([x (box 0)]
                   [y (box 0)])
               (send master position-location position x y)
               (values (unbox x) (unbox y))))
           (define (position-x position)
             (let-values ([(x y) (position-xy position)])
               x))
           (define (position-y position)
             (let-values ([(x y) (position-xy position)])
               y))
           (define (current-line)
             (send master find-line 
                   (position-y (send master get-start-position))))
           (let ([line-end (send master line-end-position (current-line))]
                 [start (send master get-start-position)])
             (= (position-x start) (position-x line-end))))

         (define (concat-line)
           (if (at-end-of-line?)
             (send master delete (add1 (send master get-start-position)))
             (begin
               (send master move-position 'right #f 'line)
               (send master delete (add1 (send master get-start-position))))))

         (define (re-indent-all)
           (send master tabify-all))

         (define (do-control char)
           (case (send char get-key-code)
             [(#\d) (begin
                     (log* "move down\n")
                     (send master move-position 'down #f 'page))]
             [(#\u) (send master move-position 'up #f 'page)]
             [(#\t) (send (frame) execute-callback)]
             [(#\i) (re-indent-all)]
             [(#\e) (let ([start (box 0)]
                          [end (box 0)])
                      (send master get-visible-line-range start end)
                      (send master scroll-to-position
                            (utils:find-line-start master (unbox end))))] 
             [(#\r) (send master redo)]
             [(#\y) (let ([start (box 0)]
                          [end (box 0)])
                      (send master get-visible-line-range start end)
                      (send master scroll-to-position
                            (utils:find-line-start master (unbox start))))]))

         (define (rep m maybe-num)
           (define num (max m (let ([x (string->number maybe-num)])
                                (if x x 0))))
           (lambda (proc)
             (utils:repeat num proc)))

         (define (delete-line time numbers)
           ;; (printf "current position is ~a\n" (send master get-start-position))
           ;; (printf "current line is ~a\n" (current-line))
           ;; (printf "line start is ~a\n" (find-line-start))
           ;; (printf "line end is ~a\n" (find-line-end))
           (log* "Delete ~a times\n" numbers)
           (send master begin-edit-sequence)
           (let ((line (utils:current-line master)))
             (send master cut #f time (utils:find-line-start master line) (utils:find-line-end master line))
             (utils:repeat (max 0 numbers)
                     (lambda (i)
                       (when (> i 0)
                         (let ((line (+ 0 line)))
                           (send master cut #t time
                                 (utils:find-line-start master line)
                                 (utils:find-line-end master line)))))))
           (send master end-edit-sequence))

         ;; make some text blink, from the cursor to the length of the string
         (define (flash-it what)
           (let ([here (send master get-start-position)])
             (send master flash-on here (+ here (string-length what)))))

         ;; search for text backward in the document
         (define (do-backward-search what)
           (when what
             (let* ([here (send master get-start-position)]
                    [found (send master find-string
                                 what 'backward here 'eof #f)])
               (if found
                 (begin
                   (send master set-position found)
                   (flash-it what))
                 (let* ([last-position (utils:find-line-end master (send master last-line))]
                        [try-again (send master find-string
                                         what 'backward
                                         last-position 'eof #f)])
                   (when try-again
                     (begin
                       (send master set-position try-again)
                       (flash-it what))))))))

         ;; search for text looking forward in the document
         (define (do-forward-search what)
           (when what
             (let* ([here (add1 (send master get-start-position))]
                    [found (send master find-string
                                 what 'forward here)])
               (if found
                 (begin
                   (send master set-position found)
                   (flash-it what))
                 (let ([try-again (send master find-string what 'forward 0)])
                   (when try-again
                     (begin
                       (send master set-position try-again)
                       (flash-it what))))))))

         ;; execute a command in escape mode
         ;; returns - nothing
         (define (do-command command last-char)
           (let-values ([(rest numbers)
                         (separate-numbers-from-command command)])
             (log* "Command is ~a numbers are ~a\n" rest numbers)
             (let ([thing (escape-commands rest)])
               (log* "Command is ~a\n" thing)
               (movement:handle thing numbers)
               (case thing
                 [(insert) (do-insert (lambda (proc)
                                        (utils:repeat (max 0 numbers) proc)))]

                 
                 [(paste) (utils:repeat 1 (lambda (i)
                                      (case last-motion
                                        [(letter) (send master move-position 'right)]
                                        [(line)
                                         (send master move-position 'right #f 'line)
                                         (send master move-position 'right)])
                                      (send master paste
                                            (send last-char get-time-stamp))))]

                 [(x-cut) (begin
                            (set! last-motion 'letter)
                            (send master cut #f
                                  (send last-char get-time-stamp)
                                  (send master get-start-position)
                                  (+ (max numbers 1)
                                     (send master get-start-position))))]

                 [(next-search)
                  (do-forward-search last-search-string)]

                 [(prev-search)
                  (do-backward-search last-search-string)]

                 [(scroll-to-center)
                  (let ([start (box 0)]
                        [end (box 0)]
                        [here (utils:current-line master)])
                      (send master get-visible-line-range start end)
                      (send master scroll-to-position
                            (utils:find-line-start master
                                                   (- here 
                                                      (inexact->exact (round (/ (- (unbox start) (unbox end))
                                                                             2)))))))]

                 [(quit) (send (frame) close)]
                 [(save-and-quit) (send (frame) close)]

                 [(replace)
                  (send master delete (add1 (send master get-start-position)))
                  (send master on-default-char* last-char)]

                 ;; [(redo) (send master redo)]
                 [(undo) (send master undo)]

                 [(insert-after) (begin
                                   (when (not (at-end-of-line?))
                                     (send master move-position 'right))
                                   (do-insert (lambda (proc)
                                                (utils:repeat 0 proc))))]
                 [(insert-after-end-of-line) (begin
                                               (move-line-down)
                                               (do-insert (lambda (proc)
                                                            (utils:repeat 0 proc))))]
                 [(insert-new-line)
                  (let ()
                    (define (line)
                      (send master insert-return))
                    (move-line-down)
                    (line)
                    (do-insert (lambda (proc)
                                 (utils:repeat (max 0 numbers)
                                         (lambda (i) (line) (proc i))))))]

                 [(visual-mode) (send master add-mode (visual-mode master))]

                 [(delete-line)
                  (set! last-motion 'line)
                  (delete-line (send last-char get-time-stamp) numbers)]
                 [(delete-till-end-of-line)
                  (send master cut #f (send last-char get-time-stamp)
                        (send master get-start-position)
                        (sub1 (utils:find-line-end master (utils:current-line master))))]

                 [(delete-word)
                  (send master cut #f (send last-char get-time-stamp)
                        (send master get-start-position)
                        (begin
                          (send master move-position 'right #f 'word)
                          (send master get-start-position)))]

                 [(indent) (send master tabify)]

                 [(concat-line) (concat-line)]

                 [(copy-line) 
                  (let ([line (utils:current-line master)]
                        [time (send last-char get-time-stamp)])
                    (set! last-motion 'line)
                    (send master copy #f time (utils:find-line-start master line) (utils:find-line-end master line))
                    (utils:repeat (max 0 numbers)
                            (lambda (i)
                              (when (> i 0)
                                (let ((line (+ i line)))
                                  (send master copy #t time
                                        (utils:find-line-start master line)
                                        (utils:find-line-end master line)))))))]


                 [(change-word)
                  (begin
                    (send master add-mode (insert-mode master 
                                                       (lambda (proc)
                                                         (utils:repeat (max 0 numbers) proc))))
                    (send master move-position 'right #t 'word)
                    (send master cut #f (send last-char get-time-stamp)
                          'start 'end))]



                 [(jump-bracket/jump-position) 
                   (if (= 0 numbers)
                     (let ([here (send master get-start-position)])
                       (define (ch x)
                         (send master get-character x))
                       (cond
                         [(or (char=?* #\( (ch here))
                              (char=?* #\[ (ch here)))
                          (send master forward-sexp here)]
                         [(or (char=?* #\) (ch (sub1 here)))
                              (char=?* #\] (ch (sub1 here))))
                          (send master backward-sexp here)]))
                     (let ([last (send master last-line)]
                           [percent numbers])
                       (log* "Jump to ~a out of ~a\n" percent last)
                       (send master set-position
                             (utils:find-line-start master
                                                    (inexact->exact
                                                      (round (/ (* last percent)
                                                                100.0)))))))]

                 #;
                 [else thing])
               thing
               )))

         (define (do-normal last-char command)
           (if (and (pair? command)
                    (or (char=?* (car (reverse command)) #\:)
                        (char=?* (car (reverse command)) #\/)))
             (do-ed command)
             (do-command command last-char)))

         (define/override (do-char char)
           (if (send char get-control-down)
             (do-control char)
             (command:accept char do-normal)))

         #;
         (define/override (do-char char)
           (if (send char get-control-down)
             (do-control char)
             (do-normal char)))
         ))

(define (unit-frame %)
  (class %
    (inherit register-toolbar-button
             get-button-panel
             update-status-line
             open-status-line
             close-status-line)

    (super-new)

    (define vi-panel
      (new horizontal-pane%
           (parent (get-button-panel))))

    (define vi-button
      (new switchable-button%
           [label "Vi Mode"]
           [parent vi-panel]
           [bitmap vi-bitmap]
           [alternate-bitmap vi-disabled-bitmap]
           [callback (lambda (i)
                       (set! enabled? (not enabled?))
                       (send i set-label-visible enabled?)
                       (if enabled?
                         (begin
                           (open-status-line 'vi-mode)
                           (update-status-line 'vi-mode "Vi mode online"))
                         (close-status-line 'vi-mode)))]))
           
    (begin
      ;; (set! x-unit-frame #t)
      (register-toolbar-button vi-button)
      (send (get-button-panel) change-children
            (lambda (_)
              (cons vi-panel
                    (remq vi-panel _))))
      (open-status-line 'vi-mode)
      (update-status-line 'vi-mode "Vi mode online")

      ;; possibly evil..
      (preferences:set 'framework:menu-bindings #f))
    ))

;; a hack to make sure the unit frame is available
;; (define x-unit-frame #f)

(define (definition-text %)
  (class %
         (begin
           (super-new)
           (log* "[vi] Creating text mode\n"))

         (inherit get-top-level-window get-tab)
         ;; a stack of modes
         (field [modes (list)])

         (define (get-unit-frame)
           (send (get-tab) get-frame)
           #;
           (get-top-level-window))

         (define/public (update-status str)
           (when (get-tab)
             ;; (printf "Unit frame is ~a\n" (send (get-tab) get-frame))
             (send (get-unit-frame) update-status-line 'vi-mode str)))

         (begin
           (add-mode (escape-mode this get-unit-frame)))

         (define/public (add-mode mode)
           (set! modes (cons mode modes))
           #;(update-status (send mode mode-name))
           )

         (define/public (remove-mode)
           (set! modes (cdr modes))
           #;(update-status (send (car modes) mode-name))
           )

         (define/override (on-char evt)
           (if enabled?
             (begin
               #;
               (log* "Control ~a char ~a\n"
                     (send evt get-control-down)
                     (send evt get-key-code))
               (case (send evt get-key-code)
                 ((escape) (send (car modes) do-escape))
                 (else (send (car modes) do-char evt))))
             (super on-char evt)))

         (define/override (on-default-char evt)
           (if enabled?
             (send (car modes) do-char evt)
             (super on-default-char evt)))

         (define/public (on-default-char* evt)
           (super on-default-char evt))

         ))

(define tool@
  (unit (import drscheme:tool^)
        (export drscheme:tool-exports^)

    (define (phase1)
      (drscheme:get/extend:extend-unit-frame unit-frame)
      (drscheme:get/extend:extend-definitions-text definition-text))

    (define (phase2)
      (void))))