#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@)
(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)))
(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)
(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)
(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)
(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")
(preferences:set 'framework:menu-bindings #f))
))
(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))))