#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@)

;; 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 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 (find-until matcher start mover)
           (let loop ([here start])
             (cond
               [(<= here 0) 0]
               [(matcher (send master get-character here))
                (loop (sub1 here))]
               [else here])))

         (define (previous-word start)
           (case (send master get-character start)
             [(#\( #\[ #\) #\]) start]
             [(#\space #\tab) (find-until (lambda (c)
                                            (or (equal? #\space c)
                                                (equal? #\tab c)))
                                          start
                                          sub1)]
             [else (find-until (lambda (c)
                                 (not (member c '(#\( #\[ #\) #\]
                                                  #\newline #\space #\tab))))
                               start
                               sub1)]))

         (define (erase-word time)
           (let* ([here (send master get-start-position)]
                  [start (previous-word (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-word (send char get-time-stamp))]
             [(#\n) (send master auto-complete)]))

         (define (do-normal char)
           (cond
             [(and (char? (send char get-key-code))
                   (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)))
         ))

(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)))
                   ...))]))

;; 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 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))]
             [(#\=) 
              (begin
                (send master tabify-selection)
                (send master set-anchor #f)
                (send master remove-mode))]
             [(#\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))]))
         ))

;; 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 mode-class
         (inherit-field master)
         (field (command '()))
         (field (last-motion #f))
         (field (last-search-string #f))
         (init-field frame)
         (super-new)

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

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

         (define (repeat num proc)
           (for ([i (in-range 0 num)])
                (proc i)))

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

         (define (move-line-down)
           (send master move-position 'right #f 'line))
         
         (define (add-command! n)
           (set! command (cons n command)))

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

         (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 (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)]
             [(#\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))))]))

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

         (define (rep m maybe-num)
           (define num (max m (let ([x (string->number maybe-num)])
                                (if x x 0))))
           (lambda (proc)
             (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))
             (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))

         ;; 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))]
                                                [(char=? (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]
                      [(not result) #t]
                      [else result]))))))

         (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]
             [(#\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]
             [(#\z #\.) 'scroll-to-center]
             [(#\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 (separate-numbers-from-command command)
           (let-values ([(rest numbers)
                         (let loop ([all (reverse command)]
                                    [numbers '()])
                           (cond
                             [(null? all) (values all numbers)]
                             [(number-char? (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)))))

         (define (flash-it what)
           (let ([here (send master get-start-position)])
             (send master flash-on here (+ here (string-length what)))))

         (define (do-backward-search 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)))))))

         (define (do-forward-search 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)))))))

         (define (do-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)
               (case thing
                 [(insert) (do-insert (lambda (proc)
                                        (repeat (max 0 numbers) proc)))]
                 [(move-down) (repeat (max 1 numbers)
                                      (lambda (i)
                                        (send master move-position 'down)))]
                 [(move-up) (repeat (max 1 numbers)
                                    (lambda (i)
                                      (send master move-position 'up)))]
                 [(move-left) (repeat (max 1 numbers)
                                      (lambda (i)
                                        (send master move-position 'left)))]
                 [(move-right) (repeat (max 1 numbers)
                                       (lambda (i)
                                         (send master move-position 'right)))]

                 [(move-word-right) (repeat 1 (lambda (i)
                                                (send master move-position
                                                      'right #f 'word)))]


                 [(move-word-left) (repeat 1 (lambda (i)
                                               (send master move-position
                                                     'left #f 'word)))]
                 [(paste) (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)))))))]

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

                 [(move-to-end-of-line) (send master move-position 'right #f 'line)]
                 [(move-to-start-of-line) (send master move-position 'left #f 'line)]
                 ;; [(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)
                                                (repeat 0 proc))))]
                 [(insert-after-end-of-line) (begin
                                               (move-line-down)
                                               (do-insert (lambda (proc)
                                                            (repeat 0 proc))))]
                 [(insert-new-line)
                  (let ()
                    (define (line)
                      (send master insert-return))
                    (move-line-down)
                    (line)
                    (do-insert (lambda (proc)
                                 (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))
                    (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)
                                                         (repeat (max 0 numbers) proc))))
                    (send master move-position 'right #t 'word)
                    (send master cut #f (send last-char get-time-stamp)
                          'start 'end))]

                 [(goto-first-line) (send master set-position 0)]

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

                 [(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]))))

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

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

         ;; 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 (do-ed)
           (regexp-try (apply string-append (map string (reverse command)))
             [x "^:w\\s*\\+$" (send (frame) save)]
             [x "^:q\\s*\\+$" (send (frame) close)]
             [x "^:e ([^\\s]*)\\+" 
                (send (frame) open-in-new-tab (cadr x))]
             [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]))

         (define (do-normal char)
           (define ch (send char get-key-code))
           (when (and (char? ch)
                      (> (char->integer ch) 0))
             ;; (log* "Character is ~a ~a\n" ch (char->integer ch))
             (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 "Vi escape mode " (map string (reverse command))))
             ;; (log* "Commands are ~a = ~a\n" command (apply string-append (map string (reverse command))))
             (when (if (and (pair? command)
                            (or (char=? (car (reverse command)) #\:)
                                (char=? (car (reverse command)) #\/)))
                     (do-ed)
                     (do-command char))
               (clear-command!))))

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