gauche 0.9.5-1build1 / usr / share / gauche-0.9 / 0.9.5 / lib / text / line-edit.scm

;;;
;;; text.line-edit - line editing
;;;
;;;   Copyright (c) 2015-2016  Shiro Kawai  <shiro@acm.org>
;;;
;;;   Redistribution and use in source and binary forms, with or without
;;;   modification, are permitted provided that the following conditions
;;;   are met:
;;;
;;;   1. Redistributions of source code must retain the above copyright
;;;      notice, this list of conditions and the following disclaimer.
;;;
;;;   2. Redistributions in binary form must reproduce the above copyright
;;;      notice, this list of conditions and the following disclaimer in the
;;;      documentation and/or other materials provided with the distribution.
;;;
;;;   3. Neither the name of the authors nor the names of its contributors
;;;      may be used to endorse or promote products derived from this
;;;      software without specific prior written permission.
;;;
;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;

(define-module text.line-edit
  (use gauche.generator)
  (use data.ring-buffer)
  (use data.queue)
  (use util.match)
  (use text.console)
  (use text.gap-buffer)
  (export <line-edit-context> read-line/edit)
  )
(select-module text.line-edit)

(define *kill-ring-size* 60)
(define *history-size* 200)

;; <line-edit-context>
;; Initializable slots:
;;   console - <console> object to use.  if omitted, make-default-console
;;             is called (see text.console)
;;   prompt  - a string or a thunk that returns a string.
;;   keymap  - a hashtable to keycode -> command.  not much useful now,
;;             for we haven't exported commands.
;;   input-continues - if this is #f, commit-or-newline always
;;             commit the line---that read-line/edit strictly works as
;;             line editor.  Otherwise, this should be a procedure that
;;             takes the current buffer content as a string, and should
;;             return #f if the input is complete, or #t otherwise.
;;             If the procedure returns #t, commit-or-newline inserts a
;;             newline to the buffer and enters multiline edit mode.

(define-class <line-edit-context> ()
  ((console :init-keyword :console :init-form (make-default-console))
   (prompt  :init-keyword :prompt :init-value "")
   (keymap  :init-keyword :keymap :init-form (default-keymap))
   (input-continues :init-keyword :input-continues :init-form #f)

   ;; Following slots are private.
   (initpos-y)
   (initpos-x)
   (screen-height)
   (screen-width)

   ;; Selection
   ;; selection is between marker-pos and the current cursor pos.
   ;; maker-pos == #f means no selection.
   (marker-pos :init-value #f)

   ;; Kill and yank
   ;; Kill ring survives across sessions.  Last-yank-* is reset after
   ;; every command except yank and yank-pop.
   (kill-ring :init-form (make-ring-buffer
                          (make-vector *kill-ring-size*)
                          :overflow-handler 'overwrite))
   (last-yank :init-value -1) ; index into the kill-ring buffer.  -1 means
                              ; last op wasn't yank.
   (last-yank-pos :init-value 0) ; index into buffer where last yank is put.
   (last-yank-size :init-value 0)

   ;; Undo
   ;; See the comment at the bottom.  In the normal state, redo-queue is
   ;; empty and undo-stack has the stack of edit commands to undo the changes.
   ;; Redo-queue is non-empty when we're in the middle of undo sequence.
   (undo-stack :init-form (make-queue))
   (redo-queue :init-form (make-queue))

   ;; History
   ;; Global history is kept in the ring buffer, index 0 being the most recent.
   ;; History-pos is the index to the last recalled history; -1 indicates
   ;; we're editing the fresh line instead of the one recalled from history.
   ;; The history-transient is a hashtable indexed by history-pos and holds
   ;; the line and undo-stack; see below.
   (history :init-form (make-ring-buffer
                        (make-vector *history-size*)
                        :overflow-handler 'overwrite))
   (history-pos :init-value -1)
   (history-transient :init-value #f)
   ))

;; Entry point API
;; NB: For the consistency with read-line, the returned string won't include
;; the final newline.
(define (read-line/edit ctx)
  (reset-undo-info! ctx)
  (reset-last-yank! ctx)
  ($ call-with-console (~ ctx'console)
     (^[con]
       (define buffer (make-gap-buffer))
       (define (eofread)
         (if (> (gap-buffer-content-length buffer) 0)
           (commit-history ctx buffer)
           (eof-object)))
       (ensure-bottom-room (~ ctx'console)) ; workaround for windows IME glitch
       (show-prompt ctx)
       (init-screen-params ctx)
       ;; Main loop.  Get a key and invoke associated command.
       ;; The command may return one of the following values.
       ;;   visible - the command changed something visible so we need to 
       ;;            redisplay, but we don't need to save the change in
       ;;            the actual buffer.
       ;;            The selection is cleared.
       ;;   unchanged - no change visually and internally; we break
       ;;            undo sequence and reset last yank, but not clear
       ;;            selection.
       ;;            This occurs, for example, backward-char at the
       ;;            beginning of the input.
       ;;   nop    - totally ignore the key input.
       ;;   moved  - the command only moved cursor pos.  requires redisplay,
       ;;            but we keep selection.
       ;;   #<eof> - end of input - either input port is closed, or
       ;;            the user typed EOT char when the buffer is empty.
       ;;   commit - record the current buffer to the history, and
       ;;            returns it.
       ;;   undone - the command undid the change.  we record the fact,
       ;;            for the consecutive undo behaves differently than
       ;;            other commands.
       ;;   <edit-command> - the commad changed the buffer contents,
       ;;        and the return value is an edit command to undo the
       ;;        change.
       ;;   (yanked <edit-command>) - this is only returned by yank and yank-pop
       ;;        command.
       ;;
       ;; If the key is a character and it is not registered in the table,
       ;; we treat as if it is associated to the self-insert-command.
       ;; Given the large character set, it is a reasonable compromise.
       (let loop ([redisp #f])
         ;; NB: If next char is ready, don't bother to redisplay and
         ;; just carry over redisp flag.
         (let* ([redisp (if (and redisp (not (chready? con)))
                          (begin (redisplay ctx buffer) #f)
                          redisp)]
                [ch (getch con)]
                [h (hash-table-get (~ ctx'keymap) ch ch)])
           (cond
            [(eof-object? h) (eofread)]
            [(char? h)
             (reset-last-yank! ctx)
             (break-undo-sequence! ctx)
             (clear-mark! ctx buffer)
             (push-undo! ctx (self-insert-command ctx buffer h))
             (loop #t)]
            [(procedure? h)
             (match (h ctx buffer ch)
               [(? eof-object?)
                (if (> (gap-buffer-content-length buffer) 0)
                  (commit-history ctx buffer)
                  (eof-object))]
               ['nop       (loop redisp)]
               ['visible   (reset-last-yank! ctx)
                           (clear-mark! ctx buffer)
                           (break-undo-sequence! ctx)
                           (loop #t)]
               ['unchanged (reset-last-yank! ctx)
                           (break-undo-sequence! ctx)
                           (loop redisp)]
               ['moved     (reset-last-yank! ctx)
                           (break-undo-sequence! ctx)
                           (loop #t)]
               ['commit
                ;; We move the cursor to the last of input and redisplay,
                ;; so that the output of the client program won't overwrite
                ;; the existing input.
                (gap-buffer-move! buffer 0 'end)
                (redisplay ctx buffer)
                (putstr (~ ctx'console) "\r\n")
                (commit-history ctx buffer)]
               ['undone (reset-last-yank! ctx)
                        (clear-mark! ctx buffer)
                        (loop #t)] ; don't break undo sequence
               [('yanked edit-command)
                (break-undo-sequence! ctx)
                (clear-mark! ctx buffer)
                (push-undo! ctx edit-command)
                (loop #t)]
               [(? list? edit-command)
                (reset-last-yank! ctx)
                (break-undo-sequence! ctx)
                (clear-mark! ctx buffer)
                (push-undo! ctx edit-command)
                (loop #t)]
               [x (error "[internal] invalid return value from a command:" x)])]
            [else
             (error "[internal] do not know how to handle key:" h)]))))))

;; Check some parameters of screen.
(define (init-screen-params ctx)
  (receive (y x) (query-cursor-position (~ ctx'console))
    (set! (~ ctx'initpos-y) y)
    (set! (~ ctx'initpos-x) x))
  (receive (h w) (query-screen-size (~ ctx'console))
    (set! (~ ctx'screen-height) h)
    (set! (~ ctx'screen-width) w)))

;; Show prompt.  Returns the current column.
(define (show-prompt ctx)
  (let* ([p (~ ctx'prompt)]
         [s (if (applicable? p) (with-output-to-string p) (x->string p))])
    (putstr (~ ctx'console) s)))

;; Show secondary prompt
;; TODO: make this customizable
(define (show-secondary-prompt ctx)
  (when (> (~ ctx'initpos-x) 0)
    (putstr (~ ctx'console) (make-string (~ ctx'initpos-x) #\.))))

;; TODO: Mind char-width.
;; Calculate cursor location of the buffer position, considering
;; tab expansion & newlines.
;; Returns y and x.  assuming we know cursor is inside screen.
(define (current-buffer-cursor-position ctx buffer)
  (let ([g (gap-buffer->generator buffer)]
        [width (~ ctx'screen-width)]
        [start-y (~ ctx'initpos-y)]
        [start-x (~ ctx'initpos-x)]
        [buffer-pos (gap-buffer-pos buffer)])
    (let loop ([n 0] ; character count
               [y start-y]
               [x start-x])
      (cond [(= n buffer-pos) (values y x)]
            [(= x width) (loop n (+ y 1) 0)]
            [else
             (case (g)
               [(#\tab) (loop (+ n 1) y (* (quotient (+ x 8) 8) 8))]
               [(#\newline) (loop (+ n 1) (+ y 1) (~ ctx'initpos-x))]
               [else (loop (+ n 1) y (+ x 1))])]))))  

;; TODO: Mind char-width.
(define (redisplay ctx buffer)
  ;; generator that handles tab expansion
  ;; generate (<char> . <pos>) where <pos> is the input position, or
  ;; #f if <char> is expanded.
  (define (gen/tab g start-column)
    (gbuffer-filter (^[ch col&pos]
                      (match-let1 (col . pos) col&pos
                        (if (eqv? ch #\tab)
                          (let1 nextcol (* (quotient (+ col 8) 8) 8)
                            (values (cons (cons #\space pos)
                                          (make-list (- nextcol col 1)
                                                     (cons #\space #f)))
                                    (cons nextcol (+ pos 1))))
                          (values (list (cons ch pos))
                                  (cons (+ col 1) (+ pos 1))))))
                    (cons start-column 0) g))

  (let ([con (~ ctx'console)]
        [y   (~ ctx'initpos-y)]
        [x   (~ ctx'initpos-x)]
        [w   (~ ctx'screen-width)]
        [h   (~ ctx'screen-height)]
        [sel (selected-range ctx buffer)]
        [oparen (buffer-find-matching-paren-on-cursor buffer)])
    (define g (gen/tab (gap-buffer->generator buffer) x))
    ;; NB: If multiline chunk exceeds screen height, we skip the region
    ;; where y becomes negative.
    (move-cursor-to con (max y 0) x)
    (clear-to-eos con)
    (reset-character-attribute con)
    (let loop ([y y] [x x] [attr '(#f #f)])
      (glet1 ch&pos (g)
        (match-let1 (ch . pos) ch&pos
          (define newattr (current-char-attr pos sel oparen))
          (switch-char-attr-when-needed con attr newattr)
          (cond
           [(= x w)
            (if (= y (- h 1))
              (begin (dec! (~ ctx'initpos-y))
                     (cursor-down/scroll-up con))
              (inc! y))
            (when (>= y 0)
              (move-cursor-to con y 0)
              (putch con ch)
              (move-cursor-to con y 1))
            (loop y 1 newattr)]
           [(eqv? ch #\newline) ; works as if CR+LF
            (if (= y (- h 1))
              (begin (dec! (~ ctx'initpos-y))
                     (cursor-down/scroll-up con))
              (inc! y))
            (when (>= y 0)
              (move-cursor-to con y 0)
              (show-secondary-prompt ctx))
            (loop y (~ ctx'initpos-x) newattr)]
           [else (when (>= y 0) (putch con ch))
                 (loop y (+ x 1) newattr)])))))
  (receive (cy cx) (current-buffer-cursor-position ctx buffer)
    (move-cursor-to (~ ctx'console) cy cx)))

(define (current-char-attr pos sel oparen)
  (cond-list
   [#t @ '(#f #f)]
   [(and sel (<= (car sel) pos) (< pos (cdr sel))) @ '(bright underscore)]
   [(eqv? pos oparen) 'reverse]))

(define (switch-char-attr-when-needed con oldattr newattr)
  (unless (equal? oldattr newattr)
    (if (equal? newattr '(#f #f))
      (reset-character-attribute con)
      (set-character-attribute con newattr))))

;;
;; Key combinations
;;

(define (ctrl k)
  (integer->char (- (logand (char->integer k) (lognot #x20)) #x40)))
(define (alt k) `(ALT ,k))

;;
;; Selection
;;

(define (set-mark! ctx buffer)
  (set! (~ ctx'marker-pos) (gap-buffer-pos buffer)))

(define (clear-mark! ctx buffer) (set! (~ ctx'marker-pos) #f))

(define (selected-range ctx buffer) ; returns (start . end), end exclusive
  (and-let1 s (~ ctx'marker-pos)
    (let1 p (gap-buffer-pos buffer)
      (if (< p s) (cons p s) (cons s p)))))

;;
;; Undo stuff
;;

(define (break-undo-sequence! ctx)
  (unless (queue-empty? (~ ctx'redo-queue))
    (apply queue-push! (~ ctx'undo-stack) (dequeue-all! (~ ctx'redo-queue)))))

(define (push-undo! ctx edit-command)
  (queue-push! (~ ctx'undo-stack) edit-command))

(define (reset-undo-info! ctx)
  (dequeue-all! (~ ctx'redo-queue))
  (dequeue-all! (~ ctx'undo-stack)))

(define (set-undo-info! ctx undo-list)
  (reset-undo-info! ctx)
  (unless (null? undo-list)
    (apply enqueue! (~ ctx'undo-stack) undo-list)))

;;
;; History
;;

;; Enter the current buffer contents as the history, and discard any
;; transient info.  Returns the current buffer content.
(define (commit-history ctx buffer)
  (rlet1 str (gap-buffer->string buffer)
    (ring-buffer-add-front! (~ ctx'history) str)
    (set! (~ ctx'history-pos) -1)
    (set! (~ ctx'history-transient) #f)))

;; (~ ctx'history-transient) is a hashtable, indexed by history position
;; (-1 being the fresh line), and its value is a pair of string and
;; undo stack.  When history is recalled and edited, and then the user
;; moves history position, we save the edited line and its undo stack
;; in this table.  When the user comes back to the history position,
;; we present the saved one instead of the actual history.
;; Note that when the user recalls history for the first time of the session,
;; we save the fresh line and its undo info in the transient table
;; as the history position -1.
;; The table is reset when the user commits the input.
(define (ensure-history-transient ctx)
  (or (~ ctx'history-transient)
      (rlet1 tab (make-hash-table 'eqv?)
        (set! (~ ctx'history-transient) tab))))

;; Save the current editing line to the transient table if necessary
(define (save-history-transient ctx buffer)
  (break-undo-sequence! ctx) ; flush redo queue
  (when (or (= (~ ctx'history-pos) -1)
            (not (queue-empty? (~ ctx'undo-stack))))
    (hash-table-put! (ensure-history-transient ctx)
                     (~ ctx'history-pos)
                     (cons (gap-buffer->string buffer)
                           (dequeue-all! (~ ctx'undo-stack))))))

;; returns (<string> . <undo-list>)
(define (get-history ctx)
  (let1 tab (ensure-history-transient ctx)
    (or (hash-table-get tab (~ ctx'history-pos) #f)
        (cons (ring-buffer-ref (~ ctx'history) (~ ctx'history-pos) "")
              '()))))

(define (history-pos ctx) (~ ctx'history-pos))
(define (history-size ctx) (ring-buffer-num-entries (~ ctx'history)))

;;
;; Kill rings
;;

(define (reset-last-yank! ctx)
  (set! (~ ctx'last-yank) -1)
  (set! (~ ctx'last-yank-pos) 0)
  (set! (~ ctx'last-yank-size) 0))

(define (get-yank-line ctx)
  (let* ([rb (~ ctx'kill-ring)]
         [n  (ring-buffer-num-entries rb)])
    (if (zero? n)
      ""  ; no yank line
      (ring-buffer-ref rb (modulo (~ ctx'last-yank) n)))))

(define (save-kill-ring ctx str)
  (ring-buffer-add-front! (~ ctx'kill-ring) str))

(define (pop-yank-line ctx)
  (if (zero? (ring-buffer-num-entries (~ ctx'kill-ring)))
    ""
    (begin (inc! (~ ctx'last-yank))
           (get-yank-line ctx))))

;;
;; Some buffer utilities
;;

(define (buffer-current-line&col buf)
  (generator-fold (^[ch p]
                    (match-let1 (row . col) p
                      (if (eqv? ch #\newline)
                        (cons (+ row 1) 0)
                        (cons row (+ col 1)))))
                  '(0 . 0)
                  (gap-buffer->generator buf 0 (gap-buffer-pos buf))))

;; returns the # of newline chars in buffer
(define (buffer-num-lines buf)
  (generator-fold (^[ch cnt] (if (eqv? ch #\newline) (+ cnt 1) cnt))
                  0 (gap-buffer->generator buf)))

;; Tries to set the buffer position in line & column.  If the line
;; isn't wide enough, set the position at the end of the line.
(define (buffer-set-line&col! buf line col)
  (define nchars (gap-buffer-content-length buf))
  (let skip-lines ([pos 0] [lin 0])
    (cond [(= nchars pos) (gap-buffer-move! buf pos)]
          [(= lin line)
           (let skip-chars ([pos pos] [chr 0])
             (if (or (= nchars pos)
                     (eqv? (gap-buffer-ref buf pos) #\newline)
                     (= chr col))
               (gap-buffer-move! buf pos)
               (skip-chars (+ pos 1) (+ chr 1))))]
          [(eqv? (gap-buffer-ref buf pos) #\newline)
           (skip-lines (+ pos 1) (+ lin 1))]
          [else (skip-lines (+ pos 1) lin)])))

;; Scan open paren from START, and when found, search matching close
;; paren.  When found, call found-fn with to indexes, the
;; location of open paren and close paren.
;; Returns (values <index-of-close-paren> <found-fn-result>).
;; We'd scan recursively, but once found-fn returns a true value,
;; we stop scanning and return those values to the top.
(define (buffer-scan-matching-parens buf start end found-fn)
  (define parens '((#\( . #\)) (#\[ . #\]) (#\{ . #\})))
  (define (scan i open-pos closer)
    (if (= i end)
      (values #f #f)
      (let1 ch (gap-buffer-ref buf i)
        (cond [(eqv? ch closer) (values i (found-fn open-pos i closer))]
              [(eqv? ch #\\) (if (= i (- end 1))
                               (values #f #f)
                               (scan (+ i 2) open-pos closer))]
              [(eqv? ch #\") (in-string (+ i 1) #\" open-pos closer)]
              [(eqv? ch #\#)
               (if (= i (- end 1))
                 (values #f #f)
                 (case (gap-buffer-ref buf (+ i 1))
                   [(#\" #\/) => (^c (in-string (+ i 2) c open-pos closer))]
                   [else (scan (+ i 1) open-pos closer)]))]
              [(assq-ref parens ch) =>
               (^[closer2]
                 (receive (close-pos result) (scan (+ i 1) i closer2)
                   (cond [result (values close-pos result)]
                         [close-pos (scan (+ close-pos 1) open-pos closer)]
                         [else (values #f #f)])))]
              [else (scan (+ i 1) open-pos closer)]))))
  (define (in-string i delim open-pos closer)
    (if (= i end)
      (values #f #f)
      (let1 ch (gap-buffer-ref buf i)
        (cond [(eqv? ch delim) (scan (+ i 1) open-pos closer)]
              [(eqv? ch #\\) (if (= i (- end 1))
                               (values #f #f)
                               (in-string (+ i 2) delim open-pos closer))]
              [else (in-string (+ i 1) delim open-pos closer)]))))
  (scan start #f #f))

;; Given closing paren position, find matching opening paren.
;; START limits the search region (search performed between START and
;; CURRENT-POS).  The character at current-pos is used as the closer.
;; Returns an index of matching opening paren, or #f.
(define (buffer-find-matching-paren buf start current-pos)
  (receive (close-pos open-pos)
      ($ buffer-scan-matching-parens buf start (+ current-pos 1)
         (^[open-pos close-pos closer]
           (and (eq? close-pos current-pos) ; found
                open-pos)))
    open-pos))

;; Similar to above, but take the current cursor pos of the buffer.
(define (buffer-find-matching-paren-on-cursor buf)
  (and (not (gap-buffer-gap-at? buf 'end))
       (memv (gap-buffer-ref buf (gap-buffer-pos buf))
             '(#\) #\] #\}))
       (buffer-find-matching-paren buf 0 (gap-buffer-pos buf))))

;;;
;;; Commands
;;;

;; A command is a procedure that takes <line-edit-context>, <gap-buffer>,
;; and <key>.
;; Return value indicates the action to be taken by the main editor
;; loop.  See the read-line/edit above for the details.

(define (self-insert-command ctx buf key)
  (gap-buffer-edit! buf `(i #f ,(x->string key))))

(define (quoted-insert ctx buf key)
  (let1 ch (getch (~ ctx'console)) ; TODO: octal digits input
    (gap-buffer-edit! buf `(i #f ,(x->string ch)))))

(define (commit-input ctx buf key)
  'commit)

(define (commit-or-newline ctx buf key)
  (or (and-let* ([pred (~ ctx'input-continues)]
                 [ (pred (gap-buffer->string buf)) ])
        (gap-buffer-edit! buf '(i #f "\n")))
      'commit))

(define (delete-char ctx buf key)
  (if (not (gap-buffer-gap-at? buf 'end))
    (gap-buffer-edit! buf '(d #f 1))
    'unchanged))

(define (eot-or-delete-char ctx buf key)
  (if (zero? (gap-buffer-content-length buf))
    (eof-object)
    (delete-char ctx buf key)))

(define (delete-backward-char ctx buf key)
  (if (not (gap-buffer-gap-at? buf 'beginning))
    (let1 p-1 (- (gap-buffer-pos buf) 1)
      (gap-buffer-edit! buf `(d ,p-1 1)))
    'unchanged))

(define (backward-char ctx buf key)
  (if (not (gap-buffer-gap-at? buf 'beginning))
    (begin (gap-buffer-move! buf -1 'current)
           'moved)
    'unchanged))

(define (forward-char ctx buf key)
  (if (not (gap-buffer-gap-at? buf 'end))
    (begin (gap-buffer-move! buf 1 'current)
           'moved)
    'unchanged))

(define (move-beginning-of-line ctx buf key)
  (if (not (gap-buffer-gap-at? buf 'beginning))
    (begin (gap-buffer-move! buf 0 'beginning)
           'moved)
    'unchanged))

(define (move-end-of-line ctx buf key)
  (if (not (gap-buffer-gap-at? buf 'end))
    (begin (gap-buffer-move! buf 0 'end)
           'moved)
    'unchanged))

(define (set-mark-command ctx buf key)
  (set-mark! ctx buf)
  'moved)

(define (kill-line ctx buf key)
  (if (not (gap-buffer-gap-at? buf 'end))
    (let* ([len (- (gap-buffer-content-length buf) (gap-buffer-pos buf))]
           [e (gap-buffer-edit! buf `(d #f ,len))])
      ;; e contiains (i <pos> <killed-string>)
      (save-kill-ring ctx (caddr e))
      e)
    'unchanged))

(define (kill-region ctx buf key)
  (match (selected-range ctx buf)
    [(start . end)
     ;; NB: the cursor is either on start or on end.  either way,
     ;; after operation the cursor's be at start.
     (rlet1 e (gap-buffer-edit! buf `(d ,start ,(- end start)))
       ;; e contiains (i <pos> <killed-string>)
       (save-kill-ring ctx (caddr e)))]
    [_ 'unchanged]))

(define (kill-ring-save ctx buf key)
  (match (selected-range ctx buf)
    [(start . end)
     (save-kill-ring ctx (gap-buffer->string buf start end))
     'visible] ; this clears selection
    [_ 'unchanged]))

(define (refresh-display ctx buf key)
  (reset-terminal (~ ctx'console))
  (move-cursor-to (~ ctx'console) 0 0) ;redundant, but mintty has problem without this
  (show-prompt ctx)
  (init-screen-params ctx)
  'visible)

;; NB: This command may modify undo queue
(define (prev-history ctx buf key)
  (if (< (history-pos ctx) (- (history-size ctx) 1))
    (begin
      (save-history-transient ctx buf)
      (inc! (~ ctx'history-pos))
      (let1 p (get-history ctx)
        (set-undo-info! ctx (cdr p))
        (gap-buffer-clear! buf)
        (gap-buffer-insert! buf (car p))
        'visible))
    'unchanged))

;; NB: This command may modify undo queue
(define (next-history ctx buf key)
  (if (> (history-pos ctx) -1)
    (begin
      (save-history-transient ctx buf)
      (dec! (~ ctx'history-pos))
      (let1 p (get-history ctx)
        (set-undo-info! ctx (cdr p))
        (gap-buffer-clear! buf)
        (gap-buffer-insert! buf (car p))
        'visible))
    'unchanged))

(define (prev-line-or-history ctx buf key)
  (match-let1 (lines . col) (buffer-current-line&col buf)
    (if (zero? lines)
      (prev-history ctx buf key)
      (begin (buffer-set-line&col! buf (- lines 1) col) 'moved))))

(define (next-line-or-history ctx buf key)
  (match-let1 (lines . col) (buffer-current-line&col buf)
    (if (= lines (buffer-num-lines buf))
      (next-history ctx buf key)
      (begin (buffer-set-line&col! buf (+ lines 1) col) 'moved))))
  
       
(define (transpose-chars ctx buf key)
  (cond [(gap-buffer-gap-at? buf 'beginning) 'unchanged]
        [(= (gap-buffer-content-length buf) 1) ; special case
         (gap-buffer-move! buf 0)
         'moved]
        [else
         (gap-buffer-move! buf
                           (if (gap-buffer-gap-at? buf 'end) -2 -1)
                           'current)
         (let ([cur  (gap-buffer-ref buf (+ (gap-buffer-pos buf) 1))]
               [prev (gap-buffer-ref buf (gap-buffer-pos buf))])
           (gap-buffer-edit! buf `(c #f 2 ,(string cur prev))))]))

(define (yank ctx buf key)
  (if (> (ring-buffer-num-entries (~ ctx'kill-ring)) 0)
    (begin
      (set! (~ ctx'last-yank) 0)
      (set! (~ ctx'last-yank-pos) (gap-buffer-gap-start buf))
      (let1 yanked-text (get-yank-line ctx)
        (set! (~ ctx'last-yank-size) (string-length yanked-text))
        `(yanked ,(gap-buffer-edit! buf `(i #f ,yanked-text)))))
    'unchanged))

(define (yank-pop ctx buf key)
  (if (and (> (ring-buffer-num-entries (~ ctx'kill-ring)) 0)
           (>= (~ ctx'last-yank) 0))
    (let* ([text (pop-yank-line ctx)]
           [pos  (~ ctx'last-yank-pos)]
           [len  (~ ctx'last-yank-size)]
           [edit (gap-buffer-edit! buf `(c ,pos ,len ,text))])
      (set! (~ ctx'last-yank-size) (string-length text))
      `(yanked ,edit))
    'unchanged))

(define (undo ctx buf key)
  (if (not (queue-empty? (~ ctx'undo-stack)))
    (let* ([undo-command (queue-pop! (~ ctx'undo-stack))]
           [redo-command (gap-buffer-edit! buf undo-command)])
      (queue-push! (~ ctx'redo-queue) undo-command)
      (enqueue! (~ ctx'redo-queue) redo-command)
      'undone)
    'unchanged))

(define (keyboard-quit ctx buf key)
  (beep (~ ctx'console))
  'visible)

(define (undefined-command ctx buf key)
  (beep (~ ctx'console))
  'visible)

(define (nop-command ctx buf key)
  'nop)

(define (default-keymap)
  (hash-table 'equal?
              `(,(ctrl #\@) . ,set-mark-command)
              `(,(ctrl #\a) . ,move-beginning-of-line)
              `(,(ctrl #\b) . ,backward-char)
              `(,(ctrl #\c) . ,undefined-command)
              `(,(ctrl #\d) . ,eot-or-delete-char)
              `(,(ctrl #\e) . ,move-end-of-line)
              `(,(ctrl #\f) . ,forward-char)
              `(,(ctrl #\g) . ,keyboard-quit)
              `(,(ctrl #\h) . ,delete-backward-char)
              `(,(ctrl #\i) . ,self-insert-command) ; tab
              `(,(ctrl #\j) . ,commit-or-newline)   ; newline
              `(,(ctrl #\k) . ,kill-line)
              `(,(ctrl #\l) . ,refresh-display)
              `(,(ctrl #\m) . ,commit-or-newline) ; return
              `(,(ctrl #\n) . ,next-line-or-history)
              `(,(ctrl #\o) . ,undefined-command); todo
              `(,(ctrl #\p) . ,prev-line-or-history)
              `(,(ctrl #\q) . ,quoted-insert)
              `(,(ctrl #\r) . ,undefined-command); todo
              `(,(ctrl #\s) . ,undefined-command); todo
              `(,(ctrl #\t) . ,transpose-chars)
              `(,(ctrl #\u) . ,undefined-command); todo
              `(,(ctrl #\v) . ,undefined-command); todo
              `(,(ctrl #\w) . ,kill-region)
              `(,(ctrl #\x) . ,undefined-command); todo
              `(,(ctrl #\y) . ,yank)
              `(,(ctrl #\z) . ,undefined-command); todo
              `(,(ctrl #\[) . ,undefined-command)
              `(,(ctrl #\\) . ,undefined-command)
              `(,(ctrl #\]) . ,undefined-command)
              `(,(ctrl #\^) . ,undefined-command)
              `(,(ctrl #\_) . ,undo)

              `(,(alt #\null) . ,nop-command) ; for windows (ime on/off)
              `(,(alt #\space) . ,undefined-command) ; should be set-mark
              `(,(alt #\!) . ,undefined-command)
              `(,(alt #\") . ,undefined-command)
              `(,(alt #\#) . ,undefined-command)
              `(,(alt #\$) . ,undefined-command)
              `(,(alt #\%) . ,undefined-command)
              `(,(alt #\&) . ,undefined-command)
              `(,(alt #\') . ,undefined-command)
              `(,(alt #\() . ,undefined-command)
              `(,(alt #\)) . ,undefined-command)
              `(,(alt #\*) . ,undefined-command)
              `(,(alt #\+) . ,undefined-command)
              `(,(alt #\,) . ,undefined-command)
              `(,(alt #\-) . ,undefined-command)
              `(,(alt #\.) . ,undefined-command)
              `(,(alt #\/) . ,undefined-command)
              `(,(alt #\0) . ,undefined-command)
              `(,(alt #\1) . ,undefined-command)
              `(,(alt #\2) . ,undefined-command)
              `(,(alt #\3) . ,undefined-command)
              `(,(alt #\4) . ,undefined-command)
              `(,(alt #\5) . ,undefined-command)
              `(,(alt #\6) . ,undefined-command)
              `(,(alt #\7) . ,undefined-command)
              `(,(alt #\8) . ,undefined-command)
              `(,(alt #\9) . ,undefined-command)
              `(,(alt #\:) . ,undefined-command)
              `(,(alt #\;) . ,undefined-command)
              `(,(alt #\<) . ,undefined-command)
              `(,(alt #\=) . ,undefined-command)
              `(,(alt #\>) . ,undefined-command)
              `(,(alt #\?) . ,undefined-command)

              
              `(,(alt #\@) . ,undefined-command)
              `(,(alt #\A) . ,undefined-command)
              `(,(alt #\B) . ,undefined-command)
              `(,(alt #\C) . ,undefined-command)
              `(,(alt #\D) . ,undefined-command)
              `(,(alt #\E) . ,undefined-command)
              `(,(alt #\F) . ,undefined-command)
              `(,(alt #\G) . ,undefined-command)
              `(,(alt #\H) . ,undefined-command)
              `(,(alt #\I) . ,undefined-command)
              `(,(alt #\J) . ,undefined-command)
              `(,(alt #\K) . ,undefined-command)
              `(,(alt #\L) . ,undefined-command)
              `(,(alt #\M) . ,undefined-command)
              `(,(alt #\N) . ,undefined-command)
              `(,(alt #\O) . ,undefined-command)
              `(,(alt #\P) . ,undefined-command)
              `(,(alt #\Q) . ,undefined-command)
              `(,(alt #\R) . ,undefined-command)
              `(,(alt #\S) . ,undefined-command)
              `(,(alt #\T) . ,undefined-command)
              `(,(alt #\U) . ,undefined-command)
              `(,(alt #\V) . ,undefined-command)
              `(,(alt #\W) . ,undefined-command)
              `(,(alt #\X) . ,undefined-command)
              `(,(alt #\Y) . ,yank-pop)
              `(,(alt #\Z) . ,undefined-command)
              `(,(alt #\[) . ,undefined-command)
              `(,(alt #\\) . ,undefined-command)
              `(,(alt #\]) . ,undefined-command)
              `(,(alt #\^) . ,undefined-command)
              `(,(alt #\_) . ,undefined-command)

              `(,(alt #\`) . ,undefined-command)
              `(,(alt #\a) . ,undefined-command)
              `(,(alt #\b) . ,undefined-command)
              `(,(alt #\c) . ,undefined-command)
              `(,(alt #\d) . ,undefined-command)
              `(,(alt #\e) . ,undefined-command)
              `(,(alt #\f) . ,undefined-command)
              `(,(alt #\g) . ,undefined-command)
              `(,(alt #\h) . ,undefined-command)
              `(,(alt #\i) . ,undefined-command)
              `(,(alt #\j) . ,undefined-command)
              `(,(alt #\k) . ,undefined-command)
              `(,(alt #\l) . ,undefined-command)
              `(,(alt #\m) . ,undefined-command)
              `(,(alt #\n) . ,next-history)
              `(,(alt #\o) . ,undefined-command)
              `(,(alt #\p) . ,prev-history)
              `(,(alt #\q) . ,undefined-command)
              `(,(alt #\r) . ,undefined-command)
              `(,(alt #\s) . ,undefined-command)
              `(,(alt #\t) . ,undefined-command)
              `(,(alt #\u) . ,undefined-command)
              `(,(alt #\v) . ,undefined-command)
              `(,(alt #\w) . ,kill-ring-save)
              `(,(alt #\x) . ,undefined-command)
              `(,(alt #\y) . ,yank-pop)
              `(,(alt #\z) . ,undefined-command)
              `(,(alt #\{) . ,undefined-command)
              `(,(alt #\|) . ,undefined-command)
              `(,(alt #\}) . ,undefined-command)
              `(,(alt #\)) . ,undefined-command)
              `(,(alt #\_) . ,undefined-command)
              `(,(alt #\x7f) . ,undefined-command)

              `(#\x7f . ,delete-backward-char)

              `(,(alt (ctrl #\space)) . ,undefined-command)
              `(,(alt (ctrl #\a)) . ,undefined-command)
              `(,(alt (ctrl #\b)) . ,undefined-command)
              `(,(alt (ctrl #\c)) . ,undefined-command)
              `(,(alt (ctrl #\d)) . ,undefined-command)
              `(,(alt (ctrl #\e)) . ,undefined-command)
              `(,(alt (ctrl #\f)) . ,undefined-command)
              `(,(alt (ctrl #\g)) . ,undefined-command)
              `(,(alt (ctrl #\h)) . ,undefined-command)
              `(,(alt (ctrl #\i)) . ,undefined-command)
              `(,(alt (ctrl #\j)) . ,undefined-command)
              `(,(alt (ctrl #\k)) . ,undefined-command)
              `(,(alt (ctrl #\l)) . ,undefined-command)
              `(,(alt (ctrl #\m)) . ,undefined-command)
              `(,(alt (ctrl #\n)) . ,undefined-command)
              `(,(alt (ctrl #\o)) . ,undefined-command)
              `(,(alt (ctrl #\p)) . ,undefined-command)
              `(,(alt (ctrl #\q)) . ,undefined-command)
              `(,(alt (ctrl #\r)) . ,undefined-command)
              `(,(alt (ctrl #\s)) . ,undefined-command)
              `(,(alt (ctrl #\t)) . ,undefined-command)
              `(,(alt (ctrl #\u)) . ,undefined-command)
              `(,(alt (ctrl #\v)) . ,undefined-command)
              `(,(alt (ctrl #\w)) . ,undefined-command)
              `(,(alt (ctrl #\x)) . ,undefined-command)
              `(,(alt (ctrl #\y)) . ,undefined-command)
              `(,(alt (ctrl #\z)) . ,undefined-command)
              `(,(alt (ctrl #\[)) . ,undefined-command)
              `(,(alt (ctrl #\\)) . ,undefined-command)
              `(,(alt (ctrl #\])) . ,undefined-command)
              `(,(alt (ctrl #\^)) . ,undefined-command)
              `(,(alt (ctrl #\_)) . ,undefined-command)

              `(KEY_UP    . ,prev-line-or-history)
              `(KEY_DOWN  . ,next-line-or-history)
              `(KEY_LEFT  . ,backward-char)
              `(KEY_RIGHT . ,forward-char)
              `(KEY_INS   . ,undefined-command)
              `(KEY_DEL   . ,delete-char)
              `(KEY_HOME  . ,undefined-command)
              `(KEY_END   . ,undefined-command)
              `(KEY_PGDN  . ,undefined-command)
              `(KEY_PGUP  . ,undefined-command)
              `(KEY_F1    . ,undefined-command)
              `(KEY_F2    . ,undefined-command)
              `(KEY_F3    . ,undefined-command)
              `(KEY_F4    . ,undefined-command)
              `(KEY_F5    . ,undefined-command)
              `(KEY_F6    . ,undefined-command)
              `(KEY_F7    . ,undefined-command)
              `(KEY_F8    . ,undefined-command)
              `(KEY_F9    . ,undefined-command)
              `(KEY_F10   . ,undefined-command)
              `(KEY_F11   . ,undefined-command)
              `(KEY_F12   . ,undefined-command)
              ))

#|

Undo semantics

 We emulate Emacs undo semantics, which allows "undoing undo".
 Here's the description of algorithm.

 - A, B, C, ... is an edit commans
 - Applying command A to buffer v is v*A.  
 - ^X is an inversion of command X.  X*^X = ^X*X = I (identity)

 1. Suppose the user did three buffer-changing operations, A, B and C.
 For every such operation, we push "undo procedure" into undo-stack.
 If we write undo procedure of A as ^A, the undo stack would look
 like this:

         buffer: v*A*B*C
     undo stack: ^A ^B ^C
     redo queue:

 2. If the user invoke undo command, we pop one undo procedure and applies
 to the buffer, then (1) append the undo op to the front of redo queue,
 and (2) push the redo op to the rear of redo queue.

         buffer: v*A*B
     undo stack: ^A ^B
     redo queue: ^C C

 3. If the user invoke undo command again immediately after that (that is,
 the user does not do any operation, including cursor movement),
 we keep doing the same op.

         buffer: v*A
     undo stack: ^A
     redo queue: ^B ^C C B

 4. If the user does anything but undo command here, we flush the redo queue
 and append the contents to undo stack.

         buffer: v*A
     undo stack: ^A ^B ^C C B
     redo queue:

 5. If the user does undo again, it actually redoes the last undo.

         buffer: v*A*B
     undo stack: ^A ^B ^C C
     redo queue: B ^B

 6. Contiguous undo follows the same pattern, until the undo stack get
    empty.

         buffer: v*A*B*C
     undo stack: 
     redo queue: ^A ^B ^C C B ^B ^C C B A
|#