;;;; edit-line.scm - pure scheme line editor
;;
;; Copyright (c) 2011-2017 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; vt100 terminal utilities

(define (terminal-escape out ch arg)
  (write-char (integer->char 27) out)
  (write-char #\[ out)
  (if arg (display arg out))
  (write-char ch out)
  (flush-output-port out))

;; we use zero-based columns
(define (terminal-goto-col out n)  (terminal-escape out #\G (+ n 1)))
(define (terminal-up out n)        (terminal-escape out #\A n))
(define (terminal-down out n)      (terminal-escape out #\B n))
(define (terminal-clear-below out) (terminal-escape out #\J #f))
(define (terminal-clear-right out) (terminal-escape out #\K #f))

(define (read-numeric-sequence in)
  (let lp ((c (peek-char in)) (acc '()))
    (case c
      ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
       (read-char in)  ;; skip peeked char
       (lp (peek-char in) (cons c acc)))
      (else
       (string->number (apply string (reverse acc)))))))

(define (terminal-current-position in out)
  (with-stty '(not icanon isig echo)
    (lambda ()
      (terminal-escape out #\n 6)
      (read-char in)
      (and (eqv? #\[ (read-char in))
           (let ((y (read-numeric-sequence in)))
             (and y
                  (eqv? #\; (read-char in))
                  (let ((x (read-numeric-sequence in)))
                    (and x
                         (eqv? #\R (read-char in))
                         (list (- y 1) (- x 1))))))))))

(define (at-first-column? in out)
  (let ((pos (terminal-current-position in out)))
    (and pos (zero? (cadr pos)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; history

(define maximum-history-size 512)

(define-record-type History
  (%make-history remaining past future filter)
  history?
  (remaining history-remaining history-remaining-set!)
  (past history-past history-past-set!)
  (future history-future history-future-set!)
  (filter history-filter history-filter-set!))

(define (make-history . o)
  (%make-history (if (pair? o) (car o) maximum-history-size)
                 '()
                 '()
                 (and (pair? o) (pair? (cdr o)) (cadr o))))

(define (history-current h)
  (let ((p (history-past h)))
    (and (pair? p) (car p))))

(define (history->list h)
  (let ((past (history-past h)) (future (history-future h)))
    (if (pair? past) (cons (car past) (append future (cdr past))) future)))

(define (list->history ls . o)
  (%make-history (max maximum-history-size (length ls)) ls '()
                 (and (pair? o) (car o))))

(define (history-flatten! h)
  (history-past-set! h (history->list h))
  (history-future-set! h '()))

(define (drop-last ls) (reverse (cdr (reverse ls))))

(define (history-past-push! h x)
  (if (positive? (history-remaining h))
      (history-remaining-set! h (- (history-remaining h) 1))
      (if (pair? (history-past h))
          (history-past-set! h (drop-last (history-past h)))
          (history-future-set! h (drop-last (history-future h)))))
  (history-past-set! h (cons x (history-past h))))

(define (history-insert! h x)
  (history-flatten! h)
  (if (not (and (history-filter h) ((history-filter h) x)))
      (history-past-push! h x)))

(define (history-reset! h)
  (cond
   ((pair? (history-future h))
    (history-past-set! h (append (drop-last (history-future h))
                                 (history-past h)))
    (history-future-set! h '()))))

(define (history-commit! h x)
  (history-reset! h)
  (if (not (and (pair? (history-past h)) (equal? x (car (history-past h)))))
      (history-insert! h x)))

(define (history-prev! h)
  (let ((past (history-past h)))
    (and (pair? past)
         (pair? (cdr past))
         (begin
           (history-future-set! h (cons (car past) (history-future h)))
           (history-past-set! h (cdr past))
           (cadr past)))))

(define (history-next! h)
  (let ((future (history-future h)))
    (and (pair? future)
         (begin
           (history-past-set! h (cons (car future) (history-past h)))
           (history-future-set! h (cdr future))
           (car future)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; char and string utils

(define (char-word-constituent? ch)
  (or (char-alphabetic? ch) (char-numeric? ch)
      (memv ch '(#\_ #\- #\+ #\:))))

(define (char-non-word-constituent? ch) (not (char-word-constituent? ch)))

(define (string-copy! dst dstart src start end)
  (if (>= start dstart)
      (do ((i start (+ i 1)) (j dstart (+ j 1)))
          ((= i end))
        (string-set! dst j (string-ref src i)))
      (do ((i (- end 1) (- i 1)) (j (+ dstart (- end start 1)) (- j 1)))
          ((< i start))
        (string-set! dst j (string-ref src i)))))

(define (string-index ch x)
  (let ((len (string-length x)))
    (let lp ((i 0))
      (cond ((>= i len) #f)
            ((eqv? ch (string-ref x i)))
            (else (lp (+ i 1)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; buffers

(define-record-type Buffer
  (%make-buffer refresh? cleared? min pos row max-row col gap start width
                string history complete? single-line?)
  buffer?
  (refresh? buffer-refresh? buffer-refresh?-set!)
  (cleared? buffer-cleared? buffer-cleared?-set!)
  (min buffer-min buffer-min-set!)
  (pos buffer-pos buffer-pos-set!)
  (row buffer-row buffer-row-set!)
  (max-row buffer-max-row buffer-max-row-set!)
  (col buffer-col buffer-col-set!)
  (gap buffer-gap buffer-gap-set!)
  (start buffer-start buffer-start-set!)
  (width buffer-width buffer-width-set!)
  (string buffer-string buffer-string-set!)
  (kill-ring buffer-kill-ring buffer-kill-ring-set!)
  (history buffer-history buffer-history-set!)
  (complete? buffer-complete? buffer-complete?-set!)
  (single-line? buffer-single-line? buffer-single-line?-set!))

(define default-buffer-size 256)
(define default-buffer-width 80)

(define (make-buffer)
  (%make-buffer #f #f 0 0 0 0 0 default-buffer-size 0 default-buffer-width
                (make-string default-buffer-size) '() #f #f))

(define (buffer->string buf)
  (let ((str (buffer-string buf)))
    (string-append (substring str (buffer-min buf) (buffer-pos buf))
                   (substring str (buffer-gap buf) (string-length str)))))

(define (buffer-right-length buf)
  (- (string-length (buffer-string buf)) (buffer-gap buf)))
(define (buffer-length buf)
  (+ (buffer-pos buf) (buffer-right-length buf)))
(define (buffer-free-space buf)
  (- (buffer-gap buf) (buffer-pos buf)))

(define (buffer-clamp buf n)
  (max (buffer-min buf) (min n (buffer-length buf))))

(define (buffer-resize buf n)
  (cond ((<= (buffer-free-space buf) n)
         (let* ((right-len (buffer-right-length buf))
                (new-len (* 2 (max n (buffer-length buf))))
                (new-gap (- new-len right-len))
                (new (make-string new-len))
                (old (buffer-string buf)))
           (string-copy! new 0 old 0 (buffer-pos buf))
           (string-copy! new new-gap old (buffer-gap buf) (string-length old))
           (buffer-string-set! buf new)
           (buffer-gap-set! buf new-gap)))))

;; Adapted from fmt-unicode. TODO: convert to char-sets.
(define low-non-spacing-chars '#u8(
#xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
#x78    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0 #xfe #xff #xff #xff #xff #xff #x1f    0    0    0    0    0    0    0
   0    0 #x3f    0    0    0    0    0    0 #xf8 #xff #x01    0    0 #x01    0
   0    0    0    0    0    0    0    0    0    0 #xc0 #xff #xff #x3f    0    0
   0    0 #x02    0    0    0 #xff #xff #xff #x07    0    0    0    0    0    0
   0    0    0    0 #xc0 #xff #x01    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
#x06    0    0    0    0    0    0 #x10 #xfe #x21 #x1e    0 #x0c    0    0    0
#x02    0    0    0    0    0    0 #x10 #x1e #x20    0    0 #x0c    0    0    0
#x06    0    0    0    0    0    0 #x10 #xfe #x3f    0    0    0    0 #x03    0
#x06    0    0    0    0    0    0 #x30 #xfe #x21    0    0 #x0c    0    0    0
#x02    0    0    0    0    0    0 #x90 #x0e #x20 #x40    0    0    0    0    0
#x04    0    0    0    0    0    0    0    0 #x20    0    0    0    0    0    0
   0    0    0    0    0    0    0 #xc0 #xc1 #xff #x7f    0    0    0    0    0
   0    0    0    0    0    0    0 #x10 #x40 #x30    0    0    0    0    0    0
   0    0    0    0    0    0    0    0 #x0e #x20    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0 #x04 #x7c    0    0    0    0    0
   0    0    0    0    0    0 #xf2 #x07 #x80 #x7f    0    0    0    0    0    0
   0    0    0    0    0    0 #xf2 #x1f    0 #x3f    0    0    0    0    0    0
   0    0    0 #x03    0    0 #xa0 #x02    0    0    0    0    0    0 #xfe #x7f
#xdf    0 #xff #xff #xff #xff #xff #x1f #x40    0    0    0    0    0    0    0
   0    0    0    0    0 #xe0 #xfd #x02    0    0    0 #x03    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0 #x1c    0    0    0 #x1c    0    0    0 #x0c    0    0    0 #x0c    0
   0    0    0    0    0    0 #x80 #x3f #x40 #xfe #x0f #x20    0    0    0    0
   0 #x38    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0 #x02    0    0    0    0    0    0    0    0    0    0
   0    0    0    0 #x87 #x01 #x04 #x0e    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0 #xff #x1f #xe2 #x07))

(define (unicode-char-width c)
  (let ((ci (char->integer c)))
    (cond
      ;; hand-checked ranges from EastAsianWidth.txt
      ((<= #x1100 ci #x115F) 2) ; Hangul
      ((<= #x2E80 ci #x4DB5) 2) ; CJK
      ((<= #x4E00 ci #xA4C6) 2)
      ((<= #xAC00 ci #xD7A3) 2) ; Hangul
      ((<= #xF900 ci #xFAD9) 2) ; CJK compat
      ((<= #xFE10 ci #xFE6B) 2)
      ((<= #xFF01 ci #xFF60) 2)
      ((<= #xFFE0 ci #xFFE6) 2)
      ((<= #x20000 ci #x30000) 2)
      ;; non-spacing mark (Mn) ranges from UnicodeData.txt
      ((<= #x0300 ci #x20fd)  ; #x3029
       ;; inlined bit-vector-ref for portability
       (let* ((i (- ci #x0300))
              (byte (quotient i 8))
              (off (remainder i 8)))
         (if (zero? (bitwise-and (bytevector-u8-ref low-non-spacing-chars byte)
                                 (arithmetic-shift 1 off)))
             1
             0)))
      ((<= #x302A ci #x302F) 0)
      ((<= #x3099 ci #x309A) 0)
      ((= #xFB1E ci) 0)
      ((<= #xFE00 ci #xFE23) 0)
      ((<= #x1D167 ci #x1D169) 0)
      ((<= #x1D17B ci #x1D182) 0)
      ((<= #x1D185 ci #x1D18B) 0)
      ((<= #x1D1AA ci #x1D1AD) 0)
      ((<= #xE0100 ci #xE01EF) 0)
      (else 1))))

(define (unicode-string-width str . o)
  (let ((start (if (pair? o) (car o) 0))
        (end (if (and (pair? o) (pair? (cdr o)))
                 (cadr o)
                 (string-length str))))
    (let lp1 ((i start) (width 0))
      (if (>= i end)
          width
          (let ((c (string-ref str i)))
            (cond
              ;; ANSI escapes
              ((and (= 27 (char->integer c)) ; esc
                    (< (+ i 1) end)
                    (eqv? #\[ (string-ref str (+ i 1))))
               (let lp2 ((i (+ i 2)))
                 (cond ((>= i end) width)
                       ((memv (string-ref str i) '(#\m #\newline))
                        (lp1 (+ i 1) width))
                       (else (lp2 (+ i 1))))))
              ;; unicode characters
              ((>= (char->integer c) #x80)
               (lp1 (+ i 1) (+ width (unicode-char-width c))))
              ;; normal ASCII
              (else (lp1 (+ i 1) (+ width 1)))))))))

(define (buffer-update-position! buf)
  (let ((pos (buffer-pos buf))
        (gap (buffer-gap buf))
        (str (buffer-string buf))
        (end (string-length (buffer-string buf)))
        (width (buffer-width buf)))
    (cond
     ((buffer-single-line? buf)
      ;; The "start" is the last left-most column of the buffer when
      ;; we overflow and need to scroll horizontally.  This defaults
      ;; to 0 and increments as we move past the last column.  We
      ;; update it when we find that (via movement or insertion) the
      ;; point would no longer be visible from "start" to the end of
      ;; the line, by shifting the start to the rightmost column that
      ;; would show the point.  Thus, after scrolling off the
      ;; beginning of the buffer, successive movements left will first
      ;; go to the 0th column, then scroll to the start one character
      ;; at a time.  A beginning-of-line command will restore the
      ;; "start" to 0 immediately.
      ;; We assume no embedded newlines in this case.
      (let ((start (buffer-start buf))
            (min-width (unicode-string-width str 0 (buffer-min buf))))
        (cond
         ((> start pos)
          ;; We've moved back before the current start - reset to pos.
          (buffer-start-set! buf pos))
         ((> (+ 1 min-width (unicode-string-width str start pos))
             (buffer-width buf))
          ;; The edited text is wider than the screen - scroll the
          ;; start so that pos fits on the end.
          ;; TODO: This isn't correct for wide characters, need to
          ;; loop checking individual widths.
          (buffer-start-set!
           buf
           (max 0 (- (+ 1 min-width (unicode-string-width str 0 pos))
                     (buffer-width buf))))))
        ;; Compute the current column as the width of the prompt plus
        ;; the width of the visible buffer from start to pos.
        (let* ((vis-width (unicode-string-width str (buffer-start buf) pos))
               (col (+ min-width vis-width)))
          (buffer-col-set! buf col))))
     (else
      ;; Otherwise, in a multi-line editor we need to scan for
      ;; newlines to determine the current (relative) row and column.
      ;; TODO: Handle ANSI escapes.
      (let lp ((i 0) (row 0) (col 0)) ;; update row/col
        (cond ((= i pos)
               (buffer-row-set! buf row)
               (buffer-col-set! buf col)
               (lp gap row col))      ;; skip from pos->gap
              ((>= i end)
               (buffer-max-row-set!
                buf (if (and (zero? col) (> row 0)) (- row 1) row)))
              ((eqv? #\newline (string-ref str i))
               (lp (+ i 1) (+ row 1) 0))
              (else
               (let ((off (unicode-char-width (string-ref str i))))
                 (if (>= (+ col off) width)
                     (lp (+ i 1) (+ row 1) 0)
                     (lp (+ i 1) row (+ col off)))))))))))

(define (buffer-clear buf out)
  (cond
   ((not (buffer-cleared? buf))
    ;; goto start of input
    (terminal-goto-col out 0)
    (if (positive? (buffer-row buf))
        (terminal-up out (buffer-row buf)))
    ;; clear below
    (terminal-clear-below out)
    (buffer-cleared?-set! buf #t))))

(define (buffer-draw buf out)
  (let* ((gap (buffer-gap buf))
         (str (buffer-string buf))
         (end (string-length str))
         (old-row (buffer-row buf))
         (old-col (buffer-col buf)))
    ;; update position and clear the current input
    (buffer-clear buf out)
    (buffer-update-position! buf)
    (let ((left (if (buffer-single-line? buf)
                    (buffer-start buf)
                    (buffer-min buf)))
          (right
           (if (buffer-single-line? buf)
               (min end (+ (buffer-gap buf)
                           (- (buffer-width buf) (buffer-col buf))))
               end)))
      (display (substring str 0 (buffer-min buf)) out)
      (display (substring str left (buffer-pos buf)) out)
      (display (substring str (buffer-gap buf) right) out))
    (cond
     ((not (buffer-single-line? buf))
      ;; move to next line if point at eol
      (if (and (zero? (buffer-col buf)) (positive? (buffer-row buf)))
          (write-char #\space out))
      ;; move to correct row then col
      (if (< (buffer-row buf) (buffer-max-row buf))
          (terminal-up out (- (buffer-max-row buf) (buffer-row buf))))))
    (terminal-goto-col out (buffer-col buf))
    (flush-output-port out)
    (buffer-cleared?-set! buf #f)))

(define (buffer-refresh buf out)
  (cond ((buffer-refresh? buf)
         (buffer-draw buf out)
         (buffer-refresh?-set! buf #f))))

(define (buffer-goto! buf out n)
  (let ((pos (buffer-pos buf))
        (gap (buffer-gap buf))
        (str (buffer-string buf))
        (n (buffer-clamp buf n)))
    (cond ((not (= n pos))
           (buffer-update-position! buf) ;; necesary?
           (if (< n pos)
               (string-copy! str (- gap (- pos n)) str n pos)
               (string-copy! str pos str gap (+ gap (- n pos))))
           (buffer-pos-set! buf n)
           (buffer-gap-set! buf (+ gap (- n pos)))
           (cond
            ((not (buffer-refresh? buf))
             (let ((old-row (buffer-row buf))
                   (old-start (buffer-start buf)))
               (buffer-update-position! buf)
               (cond
                ((not (= old-start (buffer-start buf)))
                 (buffer-refresh?-set! buf #t))
                (else
                 (let ((row-diff (- old-row (buffer-row buf))))
                   (cond ((> row-diff 0) (terminal-up out row-diff))
                         ((< row-diff 0) (terminal-down out (- row-diff)))))
                 (terminal-goto-col out (buffer-col buf)))))))))))

(define (buffer-insert! buf out x)
  (let ((len (if (char? x) 1 (string-length x)))
        (pos (buffer-pos buf)))
    (buffer-resize buf len)
    (if (char? x)
        (string-set! (buffer-string buf) pos x)
        (string-copy! (buffer-string buf) pos x 0 len))
    (buffer-pos-set! buf (+ (buffer-pos buf) len))
    (cond
     ((buffer-refresh? buf))
     ((and (= (buffer-gap buf) (string-length (buffer-string buf)))
           (< (+ (buffer-col buf) len) (buffer-width buf))
           (if (char? x)
               (not (eqv? x #\newline))
               (not (string-index #\newline x))))
      ;; fast path - append to end of buffer w/o wrapping to next line
      (display x out)
      (flush-output-port out)
      (buffer-col-set! buf (+ (buffer-col buf) len))
      (buffer-cleared?-set! buf #f))
     (else
      (buffer-refresh?-set! buf #t)))))

(define (buffer-delete! buf out start end)
  (let ((pos (buffer-pos buf))
        (gap (buffer-gap buf))
        (str (buffer-string buf))
        (start (buffer-clamp buf start))
        (end (buffer-clamp buf end)))
    (if (not (buffer-refresh? buf))
        (if (and (= start pos) (>= end (buffer-length buf)))
            (terminal-clear-below out)
            (buffer-refresh?-set! buf #t)))
    (cond ((< end pos)
           (string-copy! str start str end pos)
           (buffer-pos-set! buf (+ start (- pos end))))
          ((> start gap)
           (string-copy! str start str gap (+ gap (- end start)))
           (buffer-gap-set! buf (+ gap (- end start))))
          (else
           (buffer-pos-set! buf (min pos start))
           (buffer-gap-set! buf (max gap (+ pos (- gap pos) (- end pos))))))))

(define (buffer-skip buf pred)
  (let* ((str (buffer-string buf)) (end (string-length str)))
    (let lp ((i (buffer-gap buf)))
      (if (or (>= i end) (not (pred (string-ref str i))))
          (+ (- i (buffer-gap buf)) (buffer-pos buf))
          (lp (+ i 1))))))

(define (buffer-skip-reverse buf pred)
  (let ((str (buffer-string buf)))
    (let lp ((i (- (buffer-pos buf) 1)))
      (if (or (< i 0) (not (pred (string-ref str i)))) i (lp (- i 1))))))

(define (buffer-previous-word buf)
  (let ((i (buffer-skip-reverse buf char-word-constituent?)))
    (substring (buffer-string buf) (+ i 1) (buffer-pos buf))))

(define (buffer-format-list buf out words)
  (let ((width (buffer-width buf)))
    (define (write-rows num-cols widths)
      (let lp ((ls words) (i 0))
        (cond
         ((pair? ls)
          (let ((diff (- (vector-ref widths i) (string-length (car ls)))))
            (display (car ls) out)
            (if (= (+ i 1) num-cols)
                (newline out)
                (display (make-string (+ 1 diff) #\space) out))
            (lp (cdr ls) (modulo (+ i 1) num-cols))))
         ((< i num-cols)
          (newline out)))))
    (let try-cols ((num-cols (length words)))
      (cond
       ((<= num-cols 1)
        (newline out)
        (for-each (lambda (x) (display x out) (newline out)) words))
       (else
        (let ((widths (make-vector num-cols 0)))
          (let lp ((ls words) (i 0) (avail (- num-cols 1)))
            (cond
             ((null? ls)
              (write-rows num-cols widths))
             (else
              (let ((diff (- (string-length (car ls)) (vector-ref widths i))))
                (if (positive? diff)
                    (let ((avail (+ avail diff)))
                      (cond
                       ((> avail width)
                        (try-cols (- num-cols 1)))
                       (else
                        (vector-set! widths i (string-length (car ls)))
                        (lp (cdr ls) (modulo (+ i 1) num-cols) avail))))
                    (lp (cdr ls) (modulo (+ i 1) num-cols) avail))))))))))))

(define (buffer-make-completer generate)
  (lambda (ch buf out return)
    (let* ((word (buffer-previous-word buf))
           (ls (generate buf word)))
      (cond
       ((null? ls)
        (command/beep ch buf out return))
       ((= 1 (length ls))
        (buffer-insert! buf out (substring (car ls) (string-length word))))
       (else
        (newline out)
        (buffer-format-list buf out ls)
        (buffer-draw buf out))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; keymaps

(define keymap? pair?)

(define (make-keymap . o)
  (cons (make-vector 256 #f) (and (pair? o) (car o))))

(define (make-sparse-keymap . o)
  (cons '() (and (pair? o) (car o))))

(define (make-printable-keymap)
  (let* ((keymap (make-keymap command/self-insert))
         (v (car keymap)))
    (do ((i #x20 (+ i 1))) ((= i #x7F) keymap)
      (vector-set! v i command/self-insert))))

(define (make-standard-escape-bracket-keymap)
  (let* ((keymap (make-keymap))
         (v (car keymap)))
    (vector-set! v 65 command/backward-history)
    (vector-set! v 66 command/forward-history)
    (vector-set! v 67 command/forward-char)
    (vector-set! v 68 command/backward-char)
    keymap))

(define (make-standard-escape-keymap)
  (let* ((keymap (make-keymap))
         (v (car keymap)))
    (vector-set! v   8 command/backward-delete-word)
    (vector-set! v  91 (make-standard-escape-bracket-keymap))
    (vector-set! v  98 command/backward-word)
    (vector-set! v 100 command/forward-delete-word)
    (vector-set! v 102 command/forward-word)
    (vector-set! v 127 command/backward-delete-word)
    keymap))

(define (make-standard-keymap . o)
  (let* ((keymap (make-printable-keymap))
         (v (car keymap))
         (catch-control-c? (and (pair? o) (car o))))
    (vector-set! v   0 command/enter)   ;; for telnet
    (vector-set! v   1 command/beginning-of-line)
    (vector-set! v   2 command/backward-char)
    (vector-set! v   3 (if catch-control-c? command/cancel command/quit))
    (vector-set! v   4 command/forward-delete-char)
    (vector-set! v   5 command/end-of-line)
    (vector-set! v   6 command/forward-char)
    (vector-set! v   8 command/backward-delete-char)
    (vector-set! v  10 command/enter)
    (vector-set! v  11 command/forward-delete-line)
    (vector-set! v  12 command/refresh)
    (vector-set! v  13 command/skip)
    (vector-set! v  14 command/forward-history)
    (vector-set! v  16 command/backward-history)
    (vector-set! v  21 command/backward-delete-line)
    (vector-set! v  27 (make-standard-escape-keymap))
    (vector-set! v 127 command/backward-delete-char)
    keymap))

(define (keymap-lookup keymap n)
  (let ((table (car keymap)))
    (or (if (vector? table)
            (and (< -1 n (vector-length table)) (vector-ref table n))
            (cond ((assv n table) => cdr) (else #f)))
        (if (keymap? (cdr keymap))
            (keymap-lookup (cdr keymap) n)
            (cdr keymap)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; commands

(define (command/self-insert ch buf out return)
  (buffer-insert! buf out ch))

(define (command/enter ch buf out return)
  (protect (exn
            ((and (exception? exn)
                  (eq? 'read-incomplete (exception-kind exn)))
             (command/self-insert ch buf out return))
            (else
             (buffer-clear buf out)
             (print-exception exn out)
             (buffer-draw buf out)))
    (cond
     (((buffer-complete? buf) buf)
      (command/end-of-line ch buf out return)
      (display "\r\n" out)
      (flush-output-port out)
      (return))
     (else
      (command/self-insert ch buf out return)))))

(define (command/cancel ch buf out return)
  (command/end-of-line ch buf out return)
  (display "^C" out)
  (newline out)
  (buffer-delete! buf out 0 (buffer-length buf))
  (buffer-draw buf out))

(define (command/quit ch buf out return)
  (command/end-of-line ch buf out return)
  (display "^C" out)
  (newline out)
  (stty out '(icanon isig echo))
  (return '^C))

(define (command/beep ch buf out return)
  (write-char (integer->char 7) out))

(define (command/skip ch buf out return)
  #f)

(define (command/refresh ch buf out return)
  (buffer-draw buf out))

(define (command/beginning-of-line ch buf out return)
  (buffer-goto! buf out 0))

(define (command/end-of-line ch buf out return)
  (buffer-goto! buf out (buffer-length buf)))

(define (command/forward-char ch buf out return)
  (buffer-goto! buf out (+ (buffer-pos buf) 1)))

(define (command/backward-char ch buf out return)
  (buffer-goto! buf out (- (buffer-pos buf) 1)))

(define (command/forward-delete-char ch buf out return)
  (cond
   ((zero? (- (buffer-length buf) (buffer-min buf)))
    (newline out)
    (return 'eof))
   (else
    (buffer-delete! buf out (buffer-pos buf) (+ (buffer-pos buf) 1)))))

(define (command/backward-delete-char ch buf out return)
  (buffer-delete! buf out (- (buffer-pos buf) 1) (buffer-pos buf)))

(define (command/forward-delete-line ch buf out return)
  (buffer-delete! buf out (buffer-pos buf) (buffer-length buf)))

(define (command/backward-delete-line ch buf out return)
  (buffer-delete! buf out 0 (buffer-pos buf)))

(define (command/backward-history ch buf out return)
  (let ((history (buffer-history buf)))
    (cond
     ((and (history? history) (pair? (history-past history)))
      (if (null? (history-future history))
          (history-insert! history (buffer->string buf)))
      (cond
       ((pair? (cdr (history-past history)))
        (buffer-delete! buf out 0 (buffer-length buf))
        (buffer-insert! buf out (history-prev! history))))))))

(define (command/forward-history ch buf out return)
  (let ((history (buffer-history buf)))
    (cond
     ((and (history? history) (pair? (history-future history)))
      (buffer-delete! buf out 0 (buffer-length buf))
      (let ((res (buffer-insert! buf out (history-next! history))))
        (if (null? (history-future history))
            (history-past-set! history (cdr (history-past history))))
        res)))))

(define (command/forward-word ch buf out return)
  (buffer-goto! buf out (buffer-skip buf char-non-word-constituent?))
  (buffer-goto! buf out (buffer-skip buf char-word-constituent?)))

(define (command/backward-word ch buf out return)
  (buffer-goto! buf out (buffer-skip-reverse buf char-non-word-constituent?))
  (buffer-goto! buf out (+ (buffer-skip-reverse buf char-word-constituent?) 1)))

(define (command/forward-delete-word ch buf out return)
  (let ((start (buffer-pos buf)))
    (buffer-goto! buf out (buffer-skip buf char-non-word-constituent?))
    (buffer-delete! buf out start (buffer-skip buf char-word-constituent?))))

(define (command/backward-delete-word ch buf out return)
  (let ((end (buffer-pos buf)))
    (buffer-goto! buf out (buffer-skip-reverse buf char-non-word-constituent?))
    (let ((start (buffer-skip-reverse buf char-word-constituent?)))
      (buffer-delete! buf out (+ start 1) end))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; line-editing

(define standard-keymap (make-standard-keymap))
(define standard-cancel-keymap (make-standard-keymap #t))

(define (get-key ls key . o)
  (let ((x (memq key ls)))
    (if (and x (pair? (cdr x))) (cadr x) (and (pair? o) (car o)))))

(define (with-leading-ports ls proc)
  (if (and (pair? ls) (input-port? (car ls)))
      (if (and (pair? (cdr ls)) (output-port? (cadr ls)))
          (proc (car ls) (cadr ls) (cddr ls))
          (proc (car ls) (current-output-port) (cdr ls)))
      (proc (current-input-port) (current-output-port) ls)))

(define (make-line-editor . args)
  (let* ((prompter (get-key args 'prompt: "> "))
         (history (get-key args 'history:))
         (complete? (get-key args 'complete?: (lambda (buf) #t)))
         (completion (get-key args 'completion: #f))
         (terminal-width (get-key args 'terminal-width:))
         (single-line? (get-key args 'single-line?: #f))
         (fresh-line (get-key args 'fresh-line: #f))
         (no-stty? (get-key args 'no-stty?: #f))
         (hidden? (get-key args 'hidden?: #f))
         (keymap0 (get-key args 'keymap:
                           (if (get-key args 'catch-control-c?: #f)
                               standard-cancel-keymap
                               standard-keymap)))
         (keymap (if completion
                     (cons (list (cons 9 completion)) keymap0)
                     keymap0))
         (buf (or (get-key args 'buffer: #f) (make-buffer))))
    (lambda (in out)
      (let* ((width (or terminal-width (get-terminal-width out) 80))
             (prompt (if (procedure? prompter) (prompter) prompter))
             (done? #f)
             (tmp-out (if hidden? (open-output-string) out))
             (return (lambda o (set! done? (if (pair? o) (car o) #t)))))
        ;; Maybe start at a fresh line.
        (cond
         ((and fresh-line (not (at-first-column? in out)))
          (if (string? fresh-line) (display fresh-line out))
          (newline out)))
        ;; Clear buffer and reset prompt.
        (buffer-refresh?-set! buf #t)
        (buffer-min-set! buf 0)
        (buffer-delete! buf out 0 (buffer-length buf))
        (buffer-width-set! buf width)
        (buffer-insert! buf out prompt)
        (buffer-min-set! buf (string-length prompt))
        (buffer-history-set! buf history)
        (buffer-complete?-set! buf complete?)
        (buffer-single-line?-set! buf single-line?)
        (if single-line? (buffer-start-set! buf (buffer-min buf)))
        (buffer-refresh buf out)
        (flush-output-port out)
        ((if no-stty? (lambda (out f) (f)) with-raw-io)
         out
         (lambda ()
           (let lp ((kmap keymap))
             (let ((ch (read-char in)))
               (if (eof-object? ch)
                   (let ((res (buffer->string buf)))
                     (if (equal? res "") ch res))
                   (let ((x (keymap-lookup kmap (char->integer ch))))
                     (cond
                      ((keymap? x)
                       (lp x))
                      ((procedure? x)
                       (protect (exn (else
                                      (buffer-clear buf out)
                                      (print-exception exn out)
                                      (buffer-draw buf out)))
                         (x ch buf tmp-out return))
                       (flush-output-port tmp-out)
                       (buffer-refresh buf tmp-out)
                       (if done?
                           (and (not (eq? done? 'eof)) (buffer->string buf))
                           (lp keymap)))
                      (else
                       ;;(command/beep ch buf out return)
                       (lp keymap)))))))))))))

(define (edit-line . args)
  (with-leading-ports
   args
   (lambda (in out rest) ((apply make-line-editor rest) in out))))

(define (edit-line-repl . args)
  (with-leading-ports
   args
   (lambda (in out rest)
     (let ((eval (get-key rest 'eval: (lambda (x) x)))
           (print (get-key rest 'write: write))
           (history (or (get-key rest 'history:) (make-history))))
       (let ((edit-line
              (apply make-line-editor 'no-stty?: #t 'history: history rest)))
         ((if (get-key args 'no-stty?:) (lambda (out f) (f)) with-raw-io)
          out
          (lambda ()
            (let lp ()
              (let ((line (edit-line in out)))
                (if (pair? (history-future history))
                    (history-past-set! history (cdr (history-past history))))
                (history-commit! history line)
                (print (eval line) out)
                (newline out)
                (lp))))))))))
