tool.ss
#lang scheme/base

(require scheme/base
         scheme/gui
         scheme/runtime-path
         drscheme/tool
         mrlib/switchable-button
         framework/framework)

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

(provide tool@)

;; 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)))

;; 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 replace-mode-class
  (class mode-class
         (super-new)
         (inherit-field master)
         (init-field repeat)

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

         (define/override (do-char char)
           (when (eq? 'press (send char get-key-release-code))
             (send master remove-mode)
             (send master delete (add1 (send master get-start-position)))
             (send master on-default-char* char)
             (repeat (lambda (i)
                       (void)))))
         ))

(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/override (do-char char)
           (set! buffer (cons char buffer))
           (send master on-default-char* char))))

(define change-mode-class
  (class mode-class
         (super-new)
         (inherit-field master)
         (init-field repeat)

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

         (define/override (do-char char)
           (case (send char get-key-code)
             [(#\w) (begin
                      (send master remove-mode)
                      (send master add-mode (insert-mode master repeat))
                      (send master move-position 'right #t 'word)
                      (send master cut #f (send char get-time-stamp)
                            'start 'end))]))
         ))

(define ed-mode-class
  (class mode-class
         (super-new)
         (inherit-field master)
         (init-field frame)

         (define/override (mode-name)
           ":")
         
         (define text "")

         (define (perform-action str)
           (log* "Perform action '~a'\n" str)
           (match str
             ["w" (send (frame) save)]
             ["q" (send (frame) close)]
             [else (void)]))

         (define (update-line)
           ;; (printf "Text is ~a\n" text)
           (send (frame) update-status-line 'vi-mode
                 (format ":~a" text)))

         (define/override (do-char event)
           (let ([char (send event get-key-code)])
             (cond
               [(not (char? char)) (void)]
               [(char=? #\return char)
                (send master remove-mode)
                (perform-action text)]
               [(char=? #\backspace char)
                (begin
                  (set! text (substring text 0 (max 0 (sub1 (string-length text)))))
                  (update-line))]
               [else
                 (begin
                   (set! text (string-append text (string char)))
                   (update-line))])
             ))
         ))

(define delete-mode-class
  (class mode-class
         (super-new)
         (inherit-field master)
         (init-field repeat)
         
         (define/override (mode-name)
           "delete mode")

         (define (delete-line time)
           ;; (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))
           (let ((line (utils:current-line master)))
             (send master cut #f time (utils:find-line-start master line) (utils:find-line-end master line))
             (repeat (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))))))))

         (define/override (do-char char)
           (case (send char get-key-code)
             [(#\d) (begin
                      (send master remove-mode)
                      (delete-line (send char get-time-stamp)))]))
         ))

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

         (inherit-field master)

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

         (define/override (do-char char)
           (case (send char get-key-code)
             [(#\x) (begin
                      (send master remove-mode)
                      (send master cut #f (send char get-time-stamp) 'start 'end)
                      (send master set-anchor #f))]
             [(#\y) (begin
                      (send master remove-mode)
                      (send master copy #f (send char get-time-stamp) 'start 'end)
                      (send master set-anchor #f))]
             [(#\l) (send master move-position 'right)]
             [(#\h) (send master move-position 'left)]
             [(#\k) (send master move-position 'up)]
             [(#\j) (send master move-position 'down)]
             [(#\v) (begin
                      (send master set-anchor #f)
                      (send master remove-mode))]))
         ))

(define copy-mode-class
  (class mode-class
         (super-new)
         (inherit-field master)
         (init-field repeat)

         (define/override (do-escape)
           (send master remove-mode))
         
         (define/override (mode-name)
           "copy mode")

         (define (copy-line time)
           ;; (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))
           (let ((line (utils:current-line master)))
             (send master copy #f time (utils:find-line-start master line) (utils:find-line-end master line))
             (repeat (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))))))))

         (define/override (do-char char)
           (case (send char get-key-code)
             [(#\y) (begin
                      (send master remove-mode)
                      (copy-line (send char get-time-stamp)))]))
         ))

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

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

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

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

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

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

(define (visual-mode master)
  (log* "[vi] visual mode\n")
  (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 mode-class
         (inherit-field master)
         (field (numbers '()))
         (init-field frame)
         (super-new)

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

         (define/override (do-escape)
           (set! numbers '()))

         (define (compute-repeat lower)
           (let loop ((n 0)
                      (nums numbers))
             (if (null? nums)
               (max lower n)
               (loop (+ (car nums) (* n 10))
                     (cdr nums)))))

         (define (clear-repeat!)
           (set! numbers '()))

         (define (repeat maximum proc)
           (for ([i (in-range 0 (compute-repeat maximum))])
                (proc i))
           (clear-repeat!))

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

         (define (do-change repeated)
           (send master add-mode (change-mode master repeated)))
         
         (define (do-delete repeated)
           (send master add-mode (delete-mode master repeated)))

         (define (do-ed)
           (send master add-mode (ed-mode master frame)))

         (define (do-replace)
           (send master add-mode (replace-mode master (lambda (proc)
                                                        (repeat 0 proc)))))

         (define (do-copy)
           (send master add-mode (copy-mode master (lambda (proc)
                                                     (repeat 0 proc)))))

         (define (move-line-down)
           (send master move-position 'right #f 'line))

         (define (add! n)
           (set! numbers (cons n numbers)))

         (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/override (do-char char)
           (log* "Control ~a char ~a match ~a\n" (send char get-control-down)
                   (send char get-key-code)
                   (list (send char get-control-down) (send char get-key-code))
                   )
           (match (list (send char get-control-down) (send char get-key-code))
                  [(list #f #\i) (begin
                                   (do-insert (lambda (proc)
                                                (repeat 0 proc))))]
                  [(list #f #\1) (add! 1)]
                  [(list #f #\2) (add! 2)]
                  [(list #f #\3) (add! 3)]
                  [(list #f #\4) (add! 4)]
                  [(list #f #\5) (add! 5)]
                  [(list #f #\6) (add! 6)]
                  [(list #f #\7) (add! 7)]
                  [(list #f #\8) (add! 8)]
                  [(list #f #\9) (add! 9)]
                  [(list #f #\$) (send master move-position 'right #f 'line)]
                  [(list #f #\^) (send master move-position 'left #f 'line)]
                  [(list #t #\r) (send master redo)]
                  [(list #f #\u) (send master undo)]
                  [(list #f #\r) (do-replace)]
                  [(list #t #\d) 
                   (begin
                     (log* "move down\n")
                     (send master move-position 'down #f 'page))]
                  [(list #t #\u) (send master move-position 'up #f 'page)]
                  [(list #f #\J) (concat-line)]
                  [(list #f #\:) (do-ed)]
                  [(list #f #\y) (do-copy)]
                  [(list #f #\x) (begin
                                   (send master cut #f
                                         (send char get-time-stamp)
                                         (send master get-start-position)
                                         (+ (compute-repeat 1)
                                            (send master get-start-position)))
                                   (clear-repeat!))]
                  [(list #f #\c) (do-change (lambda (proc)
                                              (repeat 0 proc)))]
                  [(list #f #\d) (do-delete (lambda (proc)
                                              (repeat 0 proc)))]
                  [(list #f #\w) (repeat 1 (lambda (i)
                                             (send master move-position 'right #f 'word)))]
                  [(list #f #\b) (repeat 1 (lambda (i)
                                             (send master move-position 'left #f 'word)))]
                  [(list #f #\p) (repeat 1 (lambda (i)
                                             (send master paste (send char get-time-stamp))))]
                  [(list #f #\l) (repeat 1 (lambda (i)
                                             (send master move-position 'right)))]
                  [(list #f #\h) (repeat 1 (lambda (i)
                                             (send master move-position 'left)))]
                  [(list #f #\k) (repeat 1 (lambda (i)
                                             (send master move-position 'up)))]
                  [(list #f #\j) (repeat 1 (lambda (i)
                                             (send master move-position 'down)))]
                  [(list #f #\v) (send master add-mode (visual-mode master))]
                  [(list #f #\a) (begin
                                   (when (not (at-end-of-line?))
                                     (send master move-position 'right))
                                   (do-insert (lambda (proc)
                                                (repeat 0 proc))))]
                  [(list #f #\A) (begin
                                   (move-line-down)
                                   (do-insert (lambda (proc)
                                                (repeat 0 proc))))]
                  [(list #f #\o)
                   (begin
                     (define (line)
                       (send master insert #\newline))
                     (move-line-down)
                     (line)
                     (do-insert (lambda (proc)
                                  (repeat 0 (lambda (i) (line) (proc i))))))]
                  [else (void)]))
         ))

(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 %)
  (log* "[vi] Creating text mode\n")
  (class %
         (super-instantiate ())
         (inherit get-top-level-window)
         (field [modes (list)])

         (define (get-unit-frame)
           (get-top-level-window))

         (define (update-status str)
           (when x-unit-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))))