;;; (define-module gauche.readline.keymap
;;;   (export ...))
;;; (select-module gauche.readline.keymap)

(define-module readline.keymap
  (use readline.history)
  (use readline.term-util)
  (export-all))
(select-module readline.keymap)

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

(define-macro (define-keys keymap . body)
  `(begin ,@(map
             (lambda (k)
               `(hash-table-put! ,keymap ,(car k) ,(cadr k)))
             body)))

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

;;; The default keymap: equal? is necessary because some 'keys' will
;;; be represented as pairs: (alt . #\r) (ext-function . 14)
(define *readline-keymap* (make-hash-table 'equal?))

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

;;; Cause the terminal to emit a tone.
(define (beep)
  (display "\x07")
  (flush))

;;; All of this module and child modules pass unique ids, explanatory
;;; messages, and the standard state/spec/exit to this function.  The
;;; default behavior is to ignore all this information and to beep
;;; rudely at the user.
(define (error-key error-id error-message state spec exit)
  (beep))

(define (char->control c)
  (ucs->char (+ (- (char->ucs (char-upcase c))
                   (char->ucs #\A))
                1)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The keymap

(define (delete-backward-char state spec exit)
  (let1 c (hash-table-get state 'cursor)
    (if (zero? c)
        ((hash-table-get spec 'error-key) 'delete-backward
         "attempted to delete beyond the beginning of the string"
         state spec exit)
        (let ((c-1 (- c 1))
              (s (hash-table-get state 'string)))
          (hash-table-put! state 'cursor c-1)
          (hash-table-put! state 'string
            (string-append (substring s 0 c-1)
                           (string-copy s (min c (string-length s)))))))))

(define (delete-char state spec exit)
  (let1 c (hash-table-get state 'cursor)
    (if (= c (string-length (hash-table-get state 'string)))
        ((hash-table-get spec 'error-key) 'delete
         "attempted to delete beyond the end of the string"
         'state spec exit)
        (begin
          (hash-table-put! state 'cursor (+ 1 c))
          (delete-backward-char state spec exit)))))

(define (delete-line state spec exit)
  (if (zero? (string-length (hash-table-get state 'string)))
      ((hash-table-get spec 'error-key) 'delete-line
       "attempted to delete the null string"
       state spec exit)
      (begin
        (hash-table-put! state 'cursor 0)
        (hash-table-put! state 'string (string)))))

(define (backward-char state spec exit)
  (let1 c (hash-table-get state 'cursor)
    (if (zero? c)
        ((hash-table-get spec 'error-key) 'backward-char
         "attempted to move beyond the beginning of the string"
         state spec exit)
        (hash-table-put! state 'cursor (- c 1)))))

(define (forward-char state spec exit)
  (let1 c (hash-table-get state 'cursor)
    (if (= c (string-length (hash-table-get state 'string)))
        ((hash-table-get spec 'error-key) 'forward-char
         "attempted to move beyond the end of the string"
         state spec exit)
        (hash-table-put! state 'cursor (+ 1 c)))))

(define (backward-word state spec exit)
  (let1 m (rxmatch #/\S*\s*$/
                   (substring (hash-table-get state 'string)
                              0
                              (hash-table-get state 'cursor)))
    (if m
        (hash-table-put! state 'cursor (rxmatch-start m))
        ((hash-table-get spec 'error-key) 'backward-word
         "attempted to move beyond the beginning of the string"
         state spec exit))))

(define (forward-word state spec exit)
  (let1 m (rxmatch #/^\s*\S+\s*|\s+$|\S+$/
                   (string-copy (hash-table-get state 'string)
                                (hash-table-get state 'cursor)))
    (if m
        (hash-table-put! state 'cursor
          (+ (hash-table-get state 'cursor)
             (rxmatch-end m)))
        ((hash-table-get spec 'error-key) 'forward-word
         "attempted to move beyond the end of the string"
         state spec exit))))

(define (beginning-of-line state spec exit)
  (hash-table-put! state 'cursor 0))

(define (end-of-line state spec exit)
  (hash-table-put! state 'cursor
    (string-length (hash-table-get state 'string))))

(define (delete-rest-of-line state spec exit)
  (hash-table-put! state 'string
    (substring (hash-table-get state 'string)
               0 (hash-table-get state 'cursor))))

(define (beginning-of-subline state spec exit)
  (hash-table-put! state 'cursor
    (if (eq? (hash-table-get spec 'spec-type) 'fixed)
        0
        (let1 cols (+ 1 (terminal-columns)
                      (- (car (hash-table-get spec 'orig))))
          (* (quotient (hash-table-get state 'cursor) cols)
             cols)))))

(define (end-of-subline state spec exit)
  (hash-table-put! state 'cursor
    (if (eq? (hash-table-get spec 'spec-type) 'fixed)
        (string-length (hash-table-get state 'string))
        (let1 cols (+ 1 (terminal-columns)
                      (- (car (hash-table-get spec 'orig))))
          (min (+ -1 cols
                  (* (quotient (hash-table-get state 'cursor) cols)
                     cols))
               (string-length (hash-table-get state 'string)))))))

(define (delete-word state spec exit)
  (let1 c (hash-table-get state 'cursor)
    (handle-char '(alt . #\f) state spec exit)
    (let1 new-c (hash-table-get state 'cursor)
      (unless (= c new-c)
        (let1 s (hash-table-get state 'string)
          (hash-table-put! state 'string
            (string-append
             (substring s 0 c)
             (string-copy s new-c))))
        (hash-table-put! state 'cursor c)))))

(define (delete-backward-word state spec exit)
  (let1 c (hash-table-get state 'cursor)
    (handle-char '(alt . #\b) state spec exit)
    (let1 new-c (hash-table-get state 'cursor)
      (unless (= c new-c)
        (let1 s (hash-table-get state 'string)
          (hash-table-put! state 'string
            (string-append
             (substring s 0 new-c)
             (string-copy s c))))))))

(define (key-newline state spec exit)
  (history-store state)
  (exit state))

(define (previous-line state spec exit)
  (if (history-previous state)
      ((hash-table-get spec 'error-key) 'previous-line
       "there is no history to walk through"
       state spec exit)))

(define (next-line state spec exit)
  (if (history-next state)
      ((hash-table-get spec 'error-key) 'next-line
       "there is no history to walk through"
       state spec exit)))

(define (tab-insert state spec exit)
  (let ((t-w (hash-table-get spec 'tab-width))
        (s (hash-table-get state 'string))
        (c (hash-table-get state 'cursor)))
    (hash-table-put! state 'string
      (string-append
       (substring s 0 c)
       (make-string t-w #\space)
       (string-copy s c)))
    (hash-table-put! state 'cursor (+ c t-w))))

(define (rot13-filter c state spec exit)
  (if (and (char? c) (char-alphabetic? c))
      (let1 a (char->integer (if (char-upper-case? c) #\A #\a))
        (integer->char (+ a (modulo (+ 13
                                   (char->integer c)
                                   (- a))
                                26))))
      c))

(define (toggle-rot13-filter state spec exit)
  (if (and (hash-table-exists? state 'char-filter)
           (eq? (hash-table-get state 'char-filter) rot13-filter))
      (hash-table-delete! state 'char-filter)
      (hash-table-put! state 'char-filter rot13-filter)))

(define (toggle-reverse-input state spec exit)
  (hash-table-put! state 'reverse?
    (not (hash-table-get state 'reverse?))))

(define-keys *readline-keymap*
  (#\delete delete-backward-char)
  ((char->control #\d) delete-char)
  ((char->control #\u) delete-line)
  ((char->control #\b) backward-char)
  ((char->control #\f) forward-char)
  ('(alt . #\b) backward-word)
  ('(alt . #\f) forward-word)
  ((char->control #\a) beginning-of-line)
  ((char->control #\e) end-of-line)
  ((char->control #\k) delete-rest-of-line)
  ('(alt . #\a) beginning-of-subline)
  ('(alt . #\e) end-of-subline)
  ('(alt . #\d) delete-word)
  ('(alt . #\delete) delete-backward-word)
  ((char->control #\p) previous-line)
  ((char->control #\n) next-line)
  (#\newline key-newline)
  (#\tab tab-insert)
  ('(alt . #\r) toggle-rot13-filter)
  ((char->control #\r) toggle-reverse-input))

(provide "readline/keymap")