#lang scheme/base

(require scheme/base
	 scheme/gui
	 drscheme/tool
	 framework/framework)

(provide (rename-out [tool tool@]))

;; 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 (do-escape)
	   (void))

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

(define insert-mode-class
  (class mode-class
	 (super-new)
	 (inherit-field master)
	 (init-field repeat)
	 (field (buffer '()))
	 (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 visual-mode-class
  (class mode-class
	 (begin
	   (super-new)
	   (send master set-anchor #t))

	 (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 (current-line)
	   (send master find-line 
		 (let ([x (box 0)]
		       [y (box 0)])
		   (send master position-location
			 (send master get-start-position)
			 x y)
		   (unbox y))))

	 (define (find-line-start line)
	   (send master line-start-position line))

	 (define (find-line-end line)
	   (add1
	     (send master line-end-position line)))

	 (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 (current-line)))
	     (send master copy #f time (find-line-start line) (find-line-end line))
	     (repeat (lambda (i)
		       (when (> i 0)
			 (let ((line (+ i line)))
			   (send master copy #t time
				 (find-line-start line)
				 (find-line-end 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)
  (printf "[vi] copy mode\n")
  (new copy-mode-class (master master) (repeat repeat)))

(define escape-mode-class
  (class mode-class
	 (super-new)
	 (inherit-field master)
	 (field (numbers '()))

	 (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-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/override (do-char char)
	   #;
	   (printf "Control ~a char ~a\n" (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 #f #\D) (send master move-position 'down #f 'page)]
	     [(list #f #\U) (send master move-position 'up #f 'page)]
	     [(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 #\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
			      (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)]))
	 ))

#|
[(#\/) (do-find)]
[(#\k) (move-up)]
[(#\j) (move-down)]
[(#\w) (move-word-right)]
[(#\b) (move-word-left)]
[(#\a) (begin
(insert-mode!)
(move-right))]
[(#\A) (begin
(insert-mode!)
(move-line-down))]
[(#\o) (begin
(insert-mode!)
(move-line-down)
(insert #\newline))]
[(#\O) (begin
(insert-mode!)
(move-line-up)
(move-line-up)
(insert #\newline))]
[(#\i) (insert-mode!)]
[(#\I) (begin
(insert-mode!)
(move-line-up))])
|#

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

(define (visual-mode master)
  (printf "[vi] visual mode\n")
  (new visual-mode-class (master master)))

(define (escape-mode master)
  (printf "[vi] escape mode\n")
  (new escape-mode-class (master master)))

(define (definition-text %)
  (printf "[vi] Creating text mode\n")
  (class %
	 (super-instantiate ())
	 (field [modes (list (escape-mode this))])
	 
	 (define/public (add-mode mode)
	   (set! modes (cons mode modes)))

	 (define/public (remove-mode)
	   (set! modes (cdr modes)))

	 (define (move-right)
	   (send this move-position 'right))

	 (define (move-left)
	   (send this move-position 'left))

	 (define (move-up)
	   (send this move-position 'up))

	 (define (move-down)
	   (send this move-position 'down))


	 (define (move-line-up)
	   (send this move-position 'left #f 'line))

	 (define (move-word-right)
	   (send this move-position 'right #f 'word))

	 (define (move-word-left)
	   (send this move-position 'left #f 'word))

	 #;
	 (define (insert-mode!)
	   (set! mode 'insert))

	 (define (do-find)
	   (void))

	 #;
	 (define (do-esc-mode evt)
	   (case (send evt get-key-code)
	     [(#\l) (move-right)]
	     [(#\v) (begin
		      (send this set-anchor
			    (not (send this get-anchor))))]
	     [(#\h) (move-left)]
	     [(#\/) (do-find)]
	     [(#\k) (move-up)]
	     [(#\j) (move-down)]
	     [(#\w) (move-word-right)]
	     [(#\b) (move-word-left)]
	     [(#\a) (begin
		      (insert-mode!)
		      (move-right))]
	     [(#\A) (begin
		      (insert-mode!)
		      (move-line-down))]
	     [(#\o) (begin
		      (insert-mode!)
		      (move-line-down)
		      (insert #\newline))]
	     [(#\O) (begin
		      (insert-mode!)
		      (move-line-up)
		      (move-line-up)
		      (insert #\newline))]
	     [(#\i) (insert-mode!)]
	     [(#\I) (begin
		      (insert-mode!)
		      (move-line-up))]))

	 (define (do-insert-mode evt)
	   ;; (printf "[vi] Key code is ~a\n" (send evt get-key-code))
	   (super on-default-char evt)
	   #;
	   (case (send evt get-key-code)
	     ((escape) (set! mode 'esc))
	     (else (super on-default-char evt))))

	 (define/override (on-char evt)
	   (case (send evt get-key-code)
	     ((escape) (send (car modes) do-escape))
	     (else (super on-char evt))))

	 (define/override (on-default-char evt)
	   (send (car modes) do-char evt))

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

	 #;
	 (define/override (insert obj)
	   (super insert obj))

	 #;
	 (define/override (get-character index)
	   (super get-character index))

	 ))

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

    (define (phase1)

      #;
      (define (definition-canvas %)
	%)

      ;; (drscheme:get/extend:extend-definitions-canvas definition-canvas)
      (drscheme:get/extend:extend-definitions-text definition-text))

    (define (phase2)
      (void))))