;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; readline.scm - a module for 'GNU Readline'-like input

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Legalese

;;; I'm (mentally) used to systems that are licensed under the GNU GPL,
;;; and I *like* the GPL, and I, consequently, would've really liked to
;;; release this under the GNU General Public License.  ...but Gauche is
;;; under a BSD-like license.  Instead of working up a rationale I'll
;;; just quote the Gauche Reference Manual:

;;;   Although the traversal of the tree can be written in a few lines
;;;   of Scheme, I provide this module in the spirits of
;;;   OnceAndOnlyOnce.   Also it's easier if we have a common interface.

;;; All of the code in this library was written from scratch by Julian
;;; Fondren <cleverjulian@hotmail.com>, except for %with-immediate-input
;;; which is almost totally from Shiro Kawai.  None of this library is
;;; derived from the GNU Readline Library -- any similarities that may
;;; exist between the code of this library and the code of that library
;;; are by parts unintentional, accidental, and unavoidable.

;;; This library is released into the public domain.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-module readline
  (use readline.history)
  (use readline.keymap)
  (use readline.term-util)
  (export readline *readline-keymap* read-ext-char
          with-immediate-input))
(select-module readline)

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

;;; ((key arg1 arg2 arg3 ...) s-exp1 s-exp2 ...)
;;; (key value)
(define-macro (make-hash-table: . body)
  (let1 k (gensym)
    `(let1 ,k (make-hash-table)
       ,@(map (lambda (k-v)
                (if (pair? (car k-v))
                    `(hash-table-put! ,k ',(caar k-v)
                                      (lambda ,(cdar k-v)
                                        ,@(cdr k-v)))
                    `(hash-table-put! ,k ',(car k-v) ,(cadr k-v))))
              body)
       ,k)))

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

;;; Return #t if a character's integer-value is not less than '32';
;;; such characters tend to be terminal-control characters and do not
;;; display nicely.  #\newline #\tab #\return are among the characters
;;; for which this function is #f
(define (printable? c)
  (and (char? c) (>= (char->ucs c) 32)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The library proper

(define (handle-char c state spec exit)
  (let1 keymap (hash-table-get spec 'keymap)
    (if (hash-table-exists? keymap c)
        (let1 k (hash-table-get keymap c)
          (if (procedure? k)
              (k state spec exit)
              ((hash-table-get spec 'add-char) k state spec exit)))
        ((hash-table-get spec 'add-char) c state spec exit))))

(define (redraw-horizontal state spec exit)
  (let* ((s (hash-table-get state 'string))
         (s-l (string-length s))
         (orig (hash-table-get spec 'orig))
         (o-l (+ ((hash-table-get spec 'get-columns))
                 1 (- (car orig))))
         (cursor (hash-table-get state 'cursor))
         (t1 (max 0 (+ -1 (* o-l (quotient cursor o-l)))))
         (t2 (+ (car orig) (modulo cursor o-l))))
    (to-cursor orig)
    (display (substring s t1 (min s-l (+ t1 o-l))))
    (erase-rest-of-line)
    (to-column (if (>= cursor o-l) (+ 1 t2) t2))
    (flush)))
    
(define (add-char c state spec exit)
  (%add-char
   (if (hash-table-exists? state 'char-filter)
       ((hash-table-get state 'char-filter) c state spec exit)
       c) state spec exit))
(define (%add-char c state spec exit)
  (if (printable? c)
      (let ((s (hash-table-get state 'string))
            (cursor (hash-table-get state 'cursor)))
        (hash-table-put! state 'string
                         (string-append
                          (substring s 0 cursor)
                          (string c)
                          (string-copy s cursor)))
        (if (not (hash-table-get state 'reverse?))
            (hash-table-put! state 'cursor (+ cursor 1))))
      ((hash-table-get spec 'error-key)
       'add-char (cons "undefined unprintable key entered" c)
       state spec exit)))

(define (make-horizontal-spec)
  (make-hash-table:
    (spec-type 'horizontal)
    (get-columns terminal-columns)
    (tab-width 8)
    (error-key error-key)
    (add-char add-char)
    (get-char read-ext-char)
    (keymap *readline-keymap*)
    (handle-char handle-char)
    (redraw redraw-horizontal)))
(define (make-vertical-spec)
  (make-hash-table:
    (spec-type 'vertical)
    (get-columns terminal-columns)
    (get-rows terminal-rows)
    (tab-width 8)
    (error-key error-key)
    (add-char add-char)
    (get-char read-ext-char)
    (keymap *readline-keymap*)
    (handle-char handle-char)
    (redraw redraw-vertical)))
(define (make-fixed-spec n)
  (make-hash-table:
    (spec-type 'fixed)
    (length n)
    (tab-width 8)
    (error-key error-key)
    (add-char add-char-fixed)
    (get-char read-ext-char)
    (keymap *readline-keymap*)
    (handle-char handle-char)
    (redraw redraw-fixed)))

;;; readline &keyword type length
;;;   type may be one of 'horizontal 'vertical 'fixed
;;;   if type is 'fixed , length must also be provided
;;;   default type is 'horizontal
;;; ex. (readline 'fixed 20)
(define (readline state . opts)
  (call/cc
   (lambda (exit)
     (%readline
      (if state
          (begin
            (hash-table-put! state 'string "")
            (hash-table-put! state 'cursor 0)
            state)
          (make-hash-table:
            (cursor 0) (string "") (reverse? #f)
            (last-history '()) (history '())))
      (let1 type (get-keyword :type opts 'horizontal)
        (case type
          ((horizontal) (make-horizontal-spec))
          ((vertical) (make-vertical-spec))
          ((fixed)
           (make-fixed-spec (get-keyword :length opts)))
          (else
           (error "readline" "invalid spec type" type))))
      exit))))
       
(define (%readline state spec exit)
  (hash-table-put! spec 'orig (get-cursor))
  ((hash-table-get spec 'redraw) state spec exit)
  (%%readline state spec exit))
(define (%%readline state spec exit)
  (dynamic-wind
      (lambda () #f)
      (lambda ()
        ((hash-table-get spec 'handle-char)
         ((hash-table-get spec 'get-char)) state spec exit))
      (lambda ()
        ((hash-table-get spec 'redraw) state spec exit)))
    (%%readline state spec exit))

(provide "readline")