(define-module readline.term-util
  (use gauche.termios)
  (export-all))
(select-module readline.term-util)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Macros

;;; Intended uses:
;;;   (with-immediate-input thunk)
;;;   (with-immediate-input s-exp1 s-exp2 ...)
(define-macro (with-immediate-input . body)
  `(%with-immediate-input
    ,(if (and (= (length body) 1) (symbol? (car body)))
         (car body)
         `(lambda () ,@body))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Global variables

;;; if #t, 'read-ext-char' assumes that an #\escape is just an #\escape
;;; if a subsequent character is not immediately available; otherwise
;;; 'read-ext-char' will sleep for *escape-delay* milliseconds before
;;; seeing if a subsequent character has arrived.
(define *latency-apathy* #t)
(define *escape-delay* 150)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Miscellany

;;; (char->control #\a) => #\x01
;;; (char->control #\B) => #\x02
;;; Only valid for [A-Za-z], even though (char->control #\space)
;;; would be sensible: (char->control #\space) => #\null => #\x00
(define (char->control c)
  (ucs->char (+ (- (char->ucs (char-upcase c))
                   (char->ucs #\A))
                1)))

;;; Needed by 'read-ext-char' if *latency-apathy* is #f
(define (sys-sleep-ms ms)
  (sys-select #f #f #f (* 1000 ms)))

;;; (add-digit 50 2) => 502
(define (add-digit n c)
  (+ (* n 10) (digit->integer c)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Terminal Functions

;;; Evaluate thunk with the ICANON and ECHO flags of
;;; (current-input-port) disabled.  There's no reason to use this
;;; except through the 'with-immediate-input' macro; given a thunk T,
;;; (with-immediate-input T) and (%with-immediate-input T) compile
;;; identically.
(define (%with-immediate-input thunk)
  (let* ((port (current-input-port))
         (attr (sys-tcgetattr port))
         (lflag (slot-ref attr 'lflag)))
    (dynamic-wind
        (lambda ()
          (slot-set! attr 'lflag (logand lflag
                                         (lognot ICANON)
                                         (lognot ECHO)))
          (sys-tcsetattr port TCSAFLUSH attr))
        thunk
        (lambda ()
          (slot-set! attr 'lflag lflag)
          (sys-tcsetattr port TCSANOW attr)))))

;;; Read and ignore characters from (current-input-port) until
;;; a certain character is read.
(define (skip-until c)
  (unless (char=? (read-char) c)
    (skip-until c)))

;;; Return the current cursor position as (x . y), both 1-counted
;;; (that is, the topmost-leftmost cursor position is (1 . 1));
;;; depending on terminal settings, this may count from the upperleft
;;; corner of the current scrolling region or from the upperleft
;;; corner of the screen.  'get-cursor' expects to be called from
;;; within 'with-immediate-input'.
(define (get-cursor)
  (display "\x1b[6n")    ; answer is ESC[y;xR
  (flush)
  (skip-until #\escape)
  (read-char)                  ; #\[
  (let next-ydigit ((c (read-char))
                    (y 0))
    (if (char-numeric? c)
        (next-ydigit (read-char) (add-digit y c))
        ;; #\;
        (let next-xdigit ((c (read-char))
                          (x 0))
          (if (char-numeric? c)
              (next-xdigit (read-char) (add-digit x c))
              ;; #\R
              (cons x y))))))

;;; 'read-ext-char' returns one of
;;;    * #\char
;;;    * (alt . #\char)
;;;    * char-symbol (such as 'left-arrow' or 'pause')
;;;    * (ext-function . number)
;;;    * (unknown-keycode . (#\escape #\[ ...))
;;; 'read-ext-char' expects to be called from within
;;; 'with-immediate-input'.  'read-ext-char' has different methods of
;;; distinguishing #\escape from just-#\escape and such as the first
;;; character of 'up-arrow'; see "Global variables".
(define (read-ext-char)
  (let next-state ((state 'normal?))
    (let1 c (read-char)
      (case state
        ((normal?)
         (if (and (eqv? c #\escape)
                  (or *latency-apathy*
                      (sys-sleep-ms *escape-delay*))
                  (char-ready? (current-input-port)))
             (next-state 'ALT-key?)
             c))
        ((ALT-key?)
         (if (eqv? c #\[)
             (next-state 'arrow-key?)
             (cons 'alt c)))
        ((arrow-key?)
         (if (char-numeric? c)
             (read-ext-char:ext-function? (digit->integer c))
             (case c
               ((#\[) (next-state 'f1-f5?))
               ((#\A) 'up-arrow)
               ((#\B) 'down-arrow)
               ((#\C) 'right-arrow)
               ((#\D) 'left-arrow)
               ((#\P) 'pause)      ; or break?
               (else `(unknown-keycode . (#\escape #\[ ,c))))))
        ((f1-f5?)
         (case c
           ((#\A) 'function-1)
           ((#\B) 'function-2)
           ((#\C) 'function-3)
           ((#\D) 'function-4)
           ((#\E) 'function-5)
           (else `(unknown-keycode . (#\escape #\[ #\[ ,c)))))))))
(define (read-ext-char:ext-function? n)
  (let1 c (read-char)
    (cond
     ((char-numeric? c)
      (read-ext-char:ext-function? (add-digit n c)))
     ((eqv? c #\~)
      (cons 'ext-function n))
     (else
      `(unknown-keycode . (#\escape #\[
                           ,@(string->list (number->string n))
                           ,c))))))

;;; Cursor-movement commands; note that these do not automatically
;;; flush.  'to-cursor' takes a pair (x . y) as from get-cursor and
;;; moves the cursor to that coordinate.  'to-column' recieves a
;;; number and moves the cursor to that column (counting by 1 from
;;; the leftmost column) on the current line.
(define (to-cursor xy)
  (display #`"\x1b[,(cdr xy);,(car xy)H"))
(define (to-column x)
  (display #`"\x1b[,|x|G"))

;;; Erase the portion of the current line that is after the cursor.
;;; Not that this function, like 'to-cursor' and 'to-column', does
;;; not invoke 'flush'.  It has no effect until its output is actually
;;; written.
(define (erase-rest-of-line)
  (display "\x1b[K"))

;;; Return the number of columns in the terminal via the hackish
;;; method of moving the cursor to the 2000th column (stopping at
;;; the rightmost column, on terminals with a number of columns less
;;; than or equal to 2000) and then invoking 'get-cursor'.
;;; 'terminal-columns' expects to be called from within
;;; 'with-immediate-input', since 'get-cursor' won't work otherwise.
;;; 'terminal-columns' flushes (current-output-port).
(define (terminal-columns)
  (display "\x1b[2000C")
  (flush)
  (car (get-cursor)))

(provide "readline/term-util")