;;Copyright 2011 Christian Kellermann <ckeen@pestilenz.org>. All
;;rights reserved.
;;
;;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.
;; THIS SOFTWARE IS PROVIDED BY CHRISTIAN KELLERMANN ``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 CHRISTIAN KELLERMANN 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.
;; The views and conclusions contained in the software and
;; documentation are those of the authors and should not be
;; interpreted as representing official policies, either expressed or
;; implied, of Christian Kellermann.

;; This is parley a small readline alike implementation in scheme. It
;; has been based on the algorithm of linenoise another excellent
;; library written by Salvatore Sanfilippo.  It aims at simplicity so
;; you may miss certain features. Nevertheless it provides hooks for
;; users of this library to extend its capabilities.
;;
;; Basic usage:
;; (parley "Prompt> ") => string or #!eof
;;
;; To use it in csi add this to your .csirc:
;;
;;(use parley)
;;(let ((old (current-input-port)))
;;     (current-input-port (make-parley-port old)))
;;
;; TODOs: * Map string position to screen position as non printable
;;          chars take up more than one ascii char on screen
;;        * Support unicode somehow
;;        * Separate state from module instance


(module parley
        (add-key-binding!
         history-from-file
         history-max-lines
         history-to-file
         make-parley-port
         parley
         terminal-supported?)

        (import chicken scheme)
        (use data-structures extras ports posix srfi-13 srfi-18 stty)

        (define history-max-lines (make-parameter 100))
        (define history #f)
        (define exit-handler-installed? #f)
        (define user-key-bindings '())
        (define user-esc-sequences '())

        (define +unsupported-terminals+ '("dumb", "cons25"))

        (define (read-one-char port)
          (unless (char-ready? port)
            (thread-wait-for-i/o! (port->fileno port) #:input))
          (read-char port))

        (define (read-one-line port)
          (let loop ((l '())
                     (c (read-one-char port)))
            (if (equal? c #\newline)
                (list->string (reverse (cons c l)))
                (loop (cons c l) (read-one-char port)))))

        (define (terminal-supported? port term)
          (and (and (port? port) (terminal-port? port))
               (not (member term +unsupported-terminals+))))

        (define (restore-terminal-settings port attrs)
          (set-terminal-attributes! port TCSADRAIN attrs))

        (define (install-exit-handler! port attributes)
          (unless exit-handler-installed?
            (on-exit (lambda ()
                       (restore-terminal-settings
                        port attributes)))
            (set! exit-handler-installed #t)))

        (define (enable-raw-mode port)
          (let ((old-attrs (get-terminal-attributes port)))
            (install-exit-handler! port old-attrs)
            (stty port '(not echo icanon isig brkint icrnl inpck istrip ixon opost))
            (stty port '(cs8))
            (set-buffering-mode! port #:none)
            old-attrs))

        (define (get-terminal-columns port)
          (receive (rows cols) (terminal-size port)
                   (if (= 0 cols) 80 cols)))

        (define +esc-sequences+
          `(( cur-left-edge  . ,(lambda () "\x1b[0G"))
            ( erase-to-right . ,(lambda () "\x1b[0K"))
            ( move-to-col . ,(lambda (col) (sprintf "\x1b[~aC" col)))))

        (define (esc-seq name)
          (cond ((alist-ref name +esc-sequences+) =>
                 identity)
                (else (error "Unknown ESC sequence " name))))

        (define (history-init!)
          (when (not history) (set! history (make-history-cursor '()))))

        (define (history-add! line)
          (unless (equal? line "") (history 'add line))
          line)

        (define (history-to-file filename)
          (with-output-to-file filename
            (lambda ()
              (for-each print (history '->list)))))

        (define (history-from-file filename)
          (for-each history-add!
                    (with-input-from-file filename read-lines)))

        (define (make-history-cursor h)
          (let ((h h)
                (pos 0)
                (syntax-check
                 (lambda (args)
                   (if (not (= 2 (length args)))
                       (error "make-history-cursor: expected 1 argument got "
                              (sub1 (length args)) args)))))
            (lambda (#!rest args)
              (if (null? args) (list-ref pos h)
                  (case (car args)
                    ((reset)
                     (set! pos 0))
                    ((->list) h)
                    ((replace)
                     (syntax-check args)
                     (if (not (null? h))
                         (set! (car h) (cadr args))))
                    ((add)
                     (syntax-check args)
                     (set! h (cons (cadr args) h))
                     (set! pos 0)
                     (if (> (length h)
                            (history-max-lines))
                         (set-cdr! (list-tail h (history-max-lines))
                                   '())))
                    ((next)
                     (if (> pos 0)
                         (begin (set! pos (sub1 pos))
                                (list-ref h pos))
                         ""))
                    ((prev)
                     (if (null? h)
                         ""
                         (let ((l (list-ref h pos)))
                           (if (< (add1 pos) (length h))
                               (set! pos (add1 pos)))
                           l)))
                    (else (list-ref h pos)))))))

        (define (string-insert s i t)  (string-replace s t i i))

        (define +caret-notation+
          '((0 . "^@")
            (1 . "^A")
            (2 . "^B")
            (3 . "^C")
            (4 . "^D")
            (5 . "^E")
            (6 . "^F")
            (7 . "^G")
            (8 . "^H")
            (9 . "^I")
            (10 . "^J")
            (11 . "^K")
            (12 . "^L")
            (13 . "^M")
            (14 . "^N")
            (15 . "^O")
            (16 . "^P")
            (17 . "^Q")
            (18 . "^R")
            (19 . "^S")
            (20 . "^T")
            (21 . "^U")
            (22 . "^V")
            (23 . "^W")
            (24 . "^X")
            (25 . "^Y")
            (26 . "^Z")
            (27 . "^[")
            (28 . "^\\")
            (29 . "^]")
            (30 . "^^[j]")
            (31 . "^_")
            (127 . "^?")))

        (define (convert-if-control-char c)
          (cond ((alist-ref (char->integer c) +caret-notation+) => identity)
                (else (string c))))

        (define (get-complete-esc-sequence port #!optional (res #f))
          (let ((c (read-one-char port)))
            (cond ((eof-object? c) #f)
                  ((and (not res)
                        (equal? c #\x5b))
                   (get-complete-esc-sequence port c))
                  (res (list res c))
                  (else #f))))

        (define (add-key-binding! key handler #!key (esc-sequence #f))
          (if esc-sequence
              (set! user-esc-sequences
                    (alist-update! key handler user-esc-sequences equal?))
              (set! user-key-bindings
                    (alist-update! key handler user-key-bindings equal?))))

        ;; each handler gets the current prompt, in, out, line, position and
        ;; exit continuation of the cursor and has to return a list of these
        ;; arguments for the next loop iteration of prompt-loop
        (define +key-handlers+
          `((nop .
                 ,(lambda (prompt in out line pos exit)
                    (list prompt in out line pos exit)))
            (discard-and-restart .
                                 ,(lambda (prompt in out line pos exit)
                                    (list prompt in out "" 0 exit)))
            (delete-curr-char .
                              ,(lambda (prompt in out line pos exit)
                                 (if (> pos 0)
                                     (let ((nline (string-append
                                                   (string-take line (sub1 pos))
                                                   (string-drop line pos))))
                                       (list prompt in out nline (sub1 pos) exit))
                                     (list prompt in out line pos exit))))
            (swap-char .
                       ,(lambda (prompt in out line pos exit)
                          (let ((len (string-length line)))
                            (if (and (> pos 0)
                                     (< pos len))
                                (let* ((before (sub1 pos))
                                       (token-1 (string (string-ref line before)))
                                       (token (string (string-ref line pos)))
                                       (tmp (string-replace line token before pos))
                                       (nline (string-replace tmp token-1 pos (add1 pos)))
                                       (npos (if (not (= pos (sub1 len)))
                                                 (add1 pos)
                                                 pos)))
                                  (refresh-line prompt out nline npos)
                                  (list prompt in out nline npos exit))
                                (list prompt in out line pos exit)))))
            (left-arrow .
                        ,(lambda (prompt in out line pos exit)
                           (list prompt in out line (if (> pos 0) (sub1 pos) pos) exit)))
            (right-arrow .
                         ,(lambda (prompt in out line pos exit)
                            (list prompt
                                  in out
                                  line
                                  (if (not (= pos
                                              (string-length line)))
                                      (add1 pos)
                                      pos)
                                  exit)))
            (prev-history .
                          ,(lambda (prompt in out line pos exit)
                             (let ((nline (history 'prev)))
                               (list prompt in out nline (string-length nline) exit))))
            (next-history .
                          ,(lambda (prompt in out line pos exit)
                             (let ((nline (history 'next)))
                               (list prompt in out nline (string-length nline) exit))))
            (delete-until-eol .
                              ,(lambda (prompt in out line pos exit)
                                 (list prompt in out (string-take line pos) pos exit)))
            (jump-to-start-of-line .
                                   ,(lambda (prompt in out line pos exit)
                                      (list prompt in out line 0 exit)))
            (jump-to-eol .
                         ,(lambda (prompt in out line pos exit)
                            (list prompt in out line (string-length line) exit)))
            (escape-sequence .
                             ,(lambda (prompt in out line pos exit)
                                (cond ((get-complete-esc-sequence in) =>
                                       (lambda (seq)
                                         (cond ((alist-ref seq user-esc-sequences) =>
                                                (lambda (e) (e prompt in out line pos exit)))
                                               (else
                                                (case (cadr seq)
                                                  ((#\x43) ((handle 'right-arrow) prompt in out line pos exit))
                                                  ((#\x44) ((handle 'left-arrow) prompt in out line pos exit))
                                                  ((#\x41) ((handle 'prev-history) prompt in out line pos exit))
                                                  ((#\x42) ((handle 'next-history) prompt in out line pos exit))
                                                  (else
                                                   (list prompt in out line pos exit)))))))
                                      (else (list prompt in out line pos exit)))))))

        (define (handle event)
          (cond ((alist-ref event +key-handlers+) =>
                 identity)
                (else (error "Unhandled event " event))))

        (define (refresh-line prompt port line pos)
          (let* ((cols (get-terminal-columns port))
                 (plen (string-length prompt))
                 (chunk-size (- cols plen 1))
                 (chunkno (inexact->exact (floor (/ pos chunk-size))))
                 (start (* chunk-size chunkno))
                 (end (min (string-length line)
                           (+ start chunk-size)))
                 (npos (modulo (- pos start) chunk-size))
                 (delimited-line (substring line start end)))
            (parameterize ((current-output-port port))
                          (display ((esc-seq 'cur-left-edge)))
                          (display prompt)
                          (display (string-fold
                                    (lambda (c r)
                                      (string-append r (convert-if-control-char c)))
                                    ""
                                    delimited-line))
                          (display ((esc-seq 'erase-to-right)))
                          (display ((esc-seq 'cur-left-edge)))
                          (display ((esc-seq 'move-to-col)
                                    (if (= 0 (+ npos plen))
                                        -1
                                        (+ npos plen))))
                          (flush-output))))

        (define (prompt-loop prompt in out line pos return)
          (refresh-line prompt out line pos)
          (apply prompt-loop
                 ((let ((c (read-one-char in)))
                    (cond ((alist-ref c user-key-bindings) => identity)
                          (else
                           (case c
                             ((#\xd)
                              (newline out)
                              (return line))
                             ((#!eof #\x04)
                              (if (string-null? line)
                                  (return #!eof)
                                  (begin
                                    (newline out)
                                    (return line))))
                             ((#\x3) (return ""))
                             ((#\x15)
                              (handle 'discard-and-restart))
                             ((#\x8 #\x7f)
                              (handle 'delete-curr-char))
                             ((#\x14)
                              (handle 'swap-char))
                             ((#\x2)
                              (handle 'left-arrow))
                             ((#\x6)
                              (handle 'right-arrow))
                             ((#\x10)
                              (handle 'prev-history))
                             ((#\xe)
                              (handle 'next-history))
                             ((#\x1b)
                              (handle 'escape-sequence))
                             ((#\xb)
                              (handle 'delete-until-eol))
                             ((#\x1)
                              (handle 'jump-to-start-of-line))
                             ((#\x5)
                              (handle 'jump-to-eol))
                             (else
                              (lambda (prompt in out line pos return)
                                (list
                                 prompt
                                 in out
                                 (string-insert line pos (string c))
                                 (add1 pos)
                                 return)))))))
                  prompt in out line pos return)))

        (define (read-raw prompt in out)
          (let ((l (call-with-current-continuation
                    (lambda (return)
                      (prompt-loop prompt in out "" 0 return)))))
            (history-add! l)))


        (define (parley prompt #!key (in ##sys#standard-input) (out (current-output-port)))
          (let* ((useful-term (terminal-supported? in (get-environment-variable "TERM")))
                 (old-attrs (and useful-term (enable-raw-mode in)))
                 (line (if useful-term
                           (begin
                             (history-init!)
                             (read-raw prompt in out))
                           (begin
                             (printf "~a" prompt)
                             (flush-output out)
                             (read-one-line in)))))
            (if useful-term (restore-terminal-settings in old-attrs))
            line))

        (define (make-parley-port in #!optional prompt)
          (let ((l "")
                (handle #f)
                (p1 prompt)
                (pos 0))
            (letrec ((char-ready?
                      (lambda ()
                        (and (string? l)
                             (< pos (string-length l)))))
                     (get-next-char!
                      (lambda ()
                        (cond ((not l)
                               #!eof)
                              ((char-ready?)
                               (let ((ch (string-ref l pos)))
                                 (set! pos (+ 1 pos))
                                 ch))
                              (else
                               (set! pos 0)
                               (set! l
                                     (let* ((prompt (or p1 ((repl-prompt))))
                                            (r (parley prompt in: in)))
                                       r))
                               (if (string? l)
                                   (set! l (string-append l "\n")))
                               (if (not (eof-object? l))
                                   (get-next-char!)
                                   l))))))
              (set! handle (lambda (s)
                             (print-call-chain)
                             (set! pos 0)
                             (set! l "")
                             (##sys#user-interrupt-hook)))
              (set-signal-handler! signal/int handle)
              (let ((p (make-input-port
                        get-next-char!
                        char-ready?
                        (lambda ()
                          (set-signal-handler! signal/int #f)
                          'closed-parley-port))))
                (set-port-name! p "(parley)")
                p)))))