;;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
         parley-debug
         terminal-supported?)

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

        (define parley-debug (make-parameter #f))

        (define-syntax dbg
          (syntax-rules ()
            ((_ fmt ...) (if (parley-debug) (fprintf (current-error-port) fmt ...)))))


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

        (define port-list '())

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

        (define (parley? p)
          (and (port? p) (equal? (port-name p)
                                 "(parley)")))

        (define (real-port? p)
          (call-with-current-continuation
           (lambda (k)
             (with-exception-handler
              (lambda (e) (k #f))
              (lambda ()
                (and (port? p) (port->fileno p)))))))

        (define (first-usable-port port plist)
          (cond
           ((and (not (port-closed? port))
                 (real-port? port))
            port)
           ((null? plist) (error "No real port to read from available"))
           (else (first-usable-port (car plist) (cdr plist)))))

        (define (read-one-char port #!optional (plist port-list))
          (let ((real-port (first-usable-port port plist)))
            (unless (char-ready? port)
              (thread-wait-for-i/o! (port->fileno real-port) #:input))
            (read-char port)))

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

        (define (terminal-supported? port term)
          (and (and (port? port) (or (parley? 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-forward   . ,(lambda (n) (sprintf "\x1b[~aC" n)))
            ( move-backward  . ,(lambda (n) (sprintf "\x1b[~aD" n)))
            ( move-to-col    . ,(lambda (col) (sprintf "\x1b[~aG" col)))
            ( save-position  . ,(lambda () "\x1b[s"))
            ( restore-position . ,(lambda () "\x1b[u"))))

        (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 (slurp-all-input port)
          (let loop ((r '()))
            (if (char-ready? port)
                (loop (cons (read-one-char port) r))
                (reverse r))))

        (define (get-column port)
          (display "\x1b[6n")
          (flush-output (current-output-port))
          (let loop ((r '())
                     (c (read-one-char port)))
            (if (or (equal? c #\R)
                    (eof-object? c))
                (string->number (cadr (string-split (list->string (reverse r)) ";R")))
                (loop (cons c r) (read-one-char port)))))

        (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 of the cursor, exit continuation and prompt offset
        ;; 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 offset)
                    (list prompt in out line pos exit offset)))
            (discard-and-restart .
                                 ,(lambda (prompt in out line pos exit offset)
                                    (list prompt in out "" 0 exit offset)))
            (delete-curr-char .
                              ,(lambda (prompt in out line pos exit offset)
                                 (if (> pos 0)
                                     (let ((nline (string-append
                                                   (string-take line (sub1 pos))
                                                   (string-drop line pos))))
                                       (list prompt in out nline (sub1 pos) exit offset))
                                     (list prompt in out line pos exit offset))))
            (swap-char .
                       ,(lambda (prompt in out line pos exit offset)
                          (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 offset)
                                  (list prompt in out nline npos exit offset))
                                (list prompt in out line pos exit offset)))))
            (left-arrow .
                        ,(lambda (prompt in out line pos exit offset)
                           (list prompt in out line (if (> pos 0) (sub1 pos) pos) exit offset)))
            (right-arrow .
                         ,(lambda (prompt in out line pos exit offset)
                            (list prompt
                                  in out
                                  line
                                  (if (not (= pos
                                              (string-length line)))
                                      (add1 pos)
                                      pos)
                                  exit offset)))
            (prev-history .
                          ,(lambda (prompt in out line pos exit offset)
                             (let ((nline (history 'prev)))
                               (list prompt in out nline (string-length nline) exit offset))))
            (next-history .
                          ,(lambda (prompt in out line pos exit offset)
                             (let ((nline (history 'next)))
                               (list prompt in out nline (string-length nline) exit offset))))
            (delete-until-eol .
                              ,(lambda (prompt in out line pos exit offset)
                                 (list prompt in out (string-take line pos) pos exit offset)))
            (jump-to-start-of-line .
                                   ,(lambda (prompt in out line pos exit offset)
                                      (list prompt in out line 0 exit offset)))
            (jump-to-eol .
                         ,(lambda (prompt in out line pos exit offset)
                            (list prompt in out line (string-length line) exit offset)))
            (escape-sequence .
                             ,(lambda (prompt in out line pos exit offset)
                                (cond ((get-complete-esc-sequence in) =>
                                       (lambda (seq)
                                         (cond ((alist-ref seq user-esc-sequences) =>
                                                (lambda (e) (e prompt in out line pos exit offset)))
                                               (else
                                                (case (cadr seq)
                                                  ((#\x43) ((handle 'right-arrow) prompt in out line pos exit offset))
                                                  ((#\x44) ((handle 'left-arrow) prompt in out line pos exit offset))
                                                  ((#\x41) ((handle 'prev-history) prompt in out line pos exit offset))
                                                  ((#\x42) ((handle 'next-history) prompt in out line pos exit offset))
                                                  (else
                                                   (list prompt in out line pos exit offset)))))))
                                      (else (list prompt in out line pos exit offset)))))))

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

        (define (refresh-line prompt port line pos offset)
          (let* ((cols (- (get-terminal-columns port)
                          offset))
                 (plen (+ offset (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 ((esc-seq 'move-to-col) offset))
                          (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 offset)
          (refresh-line prompt out line pos offset)
          (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)
                                  (begin
                                    (display "^D" out)
                                    (return #!eof))
                                  (begin
                                    (newline out)
                                    (return line))))
                             ((#\x3)
                              (display "^C" out)
                              (newline out)
                              (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 offset)
                                (list
                                 prompt
                                 in out
                                 (string-insert line pos (string c))
                                 (add1 pos)
                                 return
                                 offset)))))))
                  prompt in out line pos return offset)))

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

        (define (useful-term? port)
          (terminal-supported?
           (first-usable-port port port-list)
           (get-environment-variable "TERM")))

        (define (parley prompt #!key (in ##sys#standard-input) (out (current-output-port)))
          (set-buffering-mode! out #:none)
          (let* ((parley-port (parley? in))
                 (real-in-port (first-usable-port in port-list))
                 (useful-term (terminal-supported? real-in-port (get-environment-variable "TERM")))
                 (old-attrs (and useful-term (enable-raw-mode real-in-port))))
            (let ((lines (if useful-term
                             (begin
                               (history-init!)
                               (unless (member in port-list)
                                 (set! port-list (cons in port-list)))
                               (let* ((prev-input (and (char-ready? in) (slurp-all-input in)))
                                      (offset (if parley-port 1 (get-column real-in-port))))
                                 (if prev-input
                                     (call-with-input-string
                                         (list->string prev-input)
                                       (lambda (in)
                                         (let loop ((r '()))
                                           (if (eof-object? (peek-char in))
                                               (reverse r)
                                               (loop (cons (read-raw prompt in out offset) r))))))
                                     (read-raw prompt real-in-port out offset))))
                             (begin
                               (dbg "; Warning: dumb terminal")
                               (set-buffering-mode! real-in-port #:none)
                               (when (or (terminal-port? in)
                                         parley-port)
                                 (display prompt out))
                               (flush-output out)
                               (let ((l (read-one-line real-in-port)))
                                 l)))))
              (if old-attrs (restore-terminal-settings real-in-port old-attrs))
              lines)))

        (define (input-missing? line)
          ; Walk the line like Johnny Cash
          (define (wtl lst esc parens brackets str quote-syntax)
            (cond ((null? lst) (or (< 0 parens)
                                   (< 0 brackets)
                                   str
                                   esc
                                   quote-syntax))
                  (esc (wtl (cdr lst) #f parens brackets str #f))
                  (str (wtl (cdr lst) (equal? (car lst) #\\) parens brackets (not (equal? (car lst) #\")) #f))
                  (else (case (car lst)
                          ((#\;) (let (( r (drop-while (lambda (c) (not (equal? c #\newline))) lst)))
                                   (wtl (if (pair? r) (cdr r) r)  #f parens brackets str #f)))
                          ((#\\) (wtl (cdr lst) #t parens brackets str #f))
                          ((#\") (wtl (cdr lst) #f parens brackets (not str) #f))
                          ((#\() (wtl (cdr lst) #f (add1 parens) brackets str #f))
                          ((#\)) (wtl (cdr lst) #f (if (> parens 0) (sub1 parens) parens) brackets str #f))
                          ((#\[) (wtl (cdr lst) #f parens (add1 brackets) str #f))
                          ((#\]) (wtl (cdr lst) #f parens (if (> brackets 0) (sub1 brackets) brackets) str #f))
                          ((#\') (wtl (cdr lst) #f parens brackets str #t))
                          (else (wtl (cdr lst) esc parens brackets str #f))))))
          (wtl (string->list line) #f 0 0 #f #f))

        (define (make-parley-port in #!optional prompt prompt2)
          (let ((l "")
                (handle #f)
                (p1 prompt)
                (p2 (or prompt2 "> "))
                (pos 0))
            (unless (member in port-list)
              (set! port-list (cons in port-list)))
            (letrec ((append-while-incomplete
                      (lambda (start)
                        (let* ((lines (parley (if (string-null? start)
                                                 (or p1 ((repl-prompt)))
                                                 p2)
                                          in: in))
                               (line (if (list? lines) (string-intersperse lines (string #\newline)) lines))
                               (res (and (string? line) (string-append start line))))
                          (cond ((and (eof-object? line) (string-null? start)) line)
                                ((eof-object? line) start)
                                ((input-missing? res)
                                 (append-while-incomplete res))
                                (else res)))))
                     (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
                                     (append-while-incomplete ""))
                               (if (and (useful-term? in) (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)))))