;; Copyright 2014 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?
 refresh-line
 singleline-refresh
 multiline-refresh

 mark-more-input?

 state-line
 state-line-set!
 state-offset
 state-offset-set!
 state-pos
 state-pos-set!
 state-prompt

 let-slots
 
 ; testing purposes only
 wait-for-input! set-buffering-mode! parley-read history)

(import chicken scheme)

(use data-structures extras lolevel miscmacros ports
     (rename posix (set-buffering-mode! -set-buffering-mode!))
     (srfi 1 13 18 71) stty)

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

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

(define-syntax with-state/copy
  (syntax-rules ()
    ((_ state body ...)
     (lambda (state)
       (let ((state state))
         body ...
         state)))))

(define-syntax
  let-slots
  (ir-macro-transformer
   (lambda (e i c)
     (let* ((slots (caadr e))
            (struct-name (cadadr e))
            (struct (car (cddadr e)))
            (body (cddr e)))
       `(let ,(map (lambda (s)
                     `(,s (,(i (apply symbol-append (map strip-syntax (list struct-name '-  s)))) ,struct)))
                    slots)
          ,@body)))))

(define-record state prompt in out offset line pos cols start-row dirty?)

(define-record-printer (state s out)
  (fprintf out "#,(state ~a ~a ~s)" (state-offset s) (state-pos s) (state-line s)))

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

;; for testing purposes
(define wait-for-input! (make-parameter (lambda (port)
                                          (thread-wait-for-i/o! (port->fileno port) #:input))))

(define set-buffering-mode! (make-parameter -set-buffering-mode!))
;;

(define mark-more-input? (make-parameter "…"))

(define port-list '())

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

(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)
  (unless (char-ready? port)
    ((wait-for-input!) port))
  (read-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))
    (stty port '(cs8 opost))
    ((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"))
    ( cursor-up . ,(lambda (n) (sprintf "\x1b[~aA" n)))
    ( cursor-down . ,(lambda (n) (sprintf "\x1b[~aB" n)))
    ( 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)))
    ( move-to        . ,(lambda (row col) (sprintf "\x1b[~a;~af" row col)))
    ( save-position  . ,(lambda () "\x1b[s"))
    ( restore-position . ,(lambda () "\x1b[u"))
    ( erase-screen   . ,(lambda (n) (sprintf "\x1b[~aJ" n)))))

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

(define (history-init! #!optional (items '()))
  (when (not (history)) (history (make-history-cursor items))))

(define (history-add! line)
  (unless (or (not (history)) (equal? line "") (eof-object? line))
    ((history) 'add line))
  line)

(define (history-to-file filename #!optional port)
  (when (and port (not (parley? port)))
    (error "Not a parley port " port))
  (parameterize ((history
                  (if port (##sys#slot port 11) (history))))
                (with-output-to-file filename
                  (lambda ()
                    (for-each print ((history) '->list))))))

(define (history-from-file filename)
  (history-init! (with-input-from-file filename read-lines)))

(define (make-history-cursor h)
  (unless (list? h) (error "Wrong type for history " h))
  (let ((h h)
        (pos -1)
        (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 -1))
            ((->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 -1)
             (when (>= (length h)
                    (history-max-lines))
                   (set-cdr! (list-tail h (sub1 (history-max-lines)))
                           '())))
            ((next)
             (cond ((> pos 0)
                    (set! pos (sub1 pos))
                    (list-ref h pos))
                   (else
                    (set! pos -1)
                    "")))
            ((prev)
             (cond ((null? h) "")
                   (else
                      (when (< (add1 pos) (length h))
                        (set! pos (add1 pos)))
                      (list-ref h pos))))
            (else (list-ref h pos)))))))

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

(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 (get-cursor-position 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))
        (let ((result (string-split (list->string (reverse r)) "[;R"))) ;; FIXME no error checking might return #f (and did so sometimes!)
          (values (string->number (cadr result))
                  (sub1 (string->number (caddr result)))))
        (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 . values)
    (discard-and-restart . ,(with-state/copy
                             s
                             (state-line-set! s "")
                             (state-pos-set! s 0)
                             (state-dirty?-set! s #t)))
    (delete-last-char .
                      ,(with-state/copy
                        s
                        (let-slots ((pos line) state s)
                                   (when (< 0 pos)
                                         (state-line-set! s
                                                          (string-append
                                                           (string-take line (sub1 pos))
                                                           (string-drop line  pos)))
                                         (state-pos-set! s (sub1 pos))
                                         (state-dirty?-set! s #t)))))
    (delete-curr-char .
                      ,(with-state/copy
                        s
                        (let-slots ((pos line) state s)
                                   (if (< pos (string-length line))
                                       (state-line-set! s
                                                        (string-append
                                                         (string-take line pos)
                                                         (string-drop line (add1 pos))))
                                       (state-dirty?-set! s #t)))))
    (swap-char .
               ,(with-state/copy
                 s
                 (let-slots ((pos line) state s)
                            (let ((len (string-length line)))
                              (when (and (> pos 0)
                                         (< pos len))
                                    (let ((a (string-ref line (sub1 pos)))
                                          (b (string-ref line pos)))
                                      (string-set! line pos a)
                                      (string-set! line (sub1 pos) b)
                                      (state-line-set! s line)
                                      (unless (= pos (sub1 len))
                                              (state-pos-set! s (add1 pos)))
                                      ((refresh-line) s redraw-line: #t)))))))
    (left-arrow .
                ,(with-state/copy
                  s
                  (when (> (state-pos s) 0)
                        (state-pos-set! s (sub1 (state-pos s))))))

    (right-arrow .
                 ,(with-state/copy
                   s
                   (unless (= (string-length (state-line s)) (state-pos s))
                           (state-pos-set! s (add1 (state-pos s))))))

    (prev-history .
                  ,(with-state/copy
                    s
                    (state-line-set! s ((history) 'prev))
                    (state-pos-set! s (string-length (state-line s)))
                    (state-dirty?-set! s #t)))

    (next-history .
                  ,(with-state/copy
                    s
                    (state-line-set! s ((history) 'next))
                    (state-pos-set! s (string-length (state-line s)))
                    (state-dirty?-set! s #t)))

    (delete-until-eol .
                      ,(with-state/copy
                        s
                        (let-slots ((line pos) state s)
                                   (state-line-set! s (string-take line pos))
                                   (state-dirty?-set! s #t))))

    (jump-to-start-of-line .
                           ,(with-state/copy
                             s
                             (state-pos-set! s 0)))

    (jump-to-eol .
                 ,(with-state/copy
                   s
                   (state-pos-set! s (string-length (state-line s)))))

    (escape-sequence .
                     ,(with-state/copy
                       s
                       (cond ((escape-sequence-handler-ref (get-complete-esc-sequence (state-in s))) =>
                              (lambda (handler)
                                (set! s (handler s)))))))
    (erase-screen .
                  ,(lambda (s)
                     (let-slots ((out) state s)
                                (display ((esc-seq 'erase-screen) 2) out)
                                (display ((esc-seq 'move-to) 1 1) out)
                                (state-start-row-set! s #f)
                                (state-dirty?-set! s #t))
                     s))))

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

(define +escape-sequence-handlers+
  `((#\x43 . ,(handle 'right-arrow))
    (#\x44 . ,(handle 'left-arrow))
    (#\x41 . ,(handle 'prev-history))
    (#\x42 . ,(handle 'next-history))))

(define (escape-sequence-handler-ref seq)
  (and seq (or (alist-ref (second seq) user-esc-sequences)
               (alist-ref (second seq) +escape-sequence-handlers+))))

(define (singleline-refresh parley-state #!key redraw-line)
  (let-slots ((prompt out line pos offset) state parley-state)
             (let* ((rows cols (terminal-size out))
                    (plen (string-length prompt))
                    (chunks (string-chop (string-append prompt line)
                                         (- cols offset)))
                    (chunkno (quotient (+ pos plen) (- cols offset)))
                    (pos-in-chunk (modulo (+ pos plen)
                                          (-  cols offset)))
                    (line-chunk (cond
                                 ((null? chunks) "") ;; Empty prompt
                                 ((< chunkno (length chunks))
                                  (list-ref chunks chunkno))
                                 (else (list-ref chunks (sub1 chunkno))))))
               (parameterize ((current-output-port out))
                             (display ((esc-seq 'move-to-col) offset))
                             (display ((esc-seq 'erase-to-right)))
                             (display line-chunk)
                             ;; FIXME is this really a good idea?
                             (when (mark-more-input?)
                                   (cond ((and
                                           (< 0 chunkno)
                                           (< (add1 chunkno) (length chunks))
                                           (< (inexact->exact (floor (* cols 0.1)))
                                              pos-in-chunk
                                              (inexact->exact (floor (* cols 0.9)))))
                                          (display ((esc-seq 'move-to-col) 0))
                                          (display (mark-more-input?))
                                          (display ((esc-seq 'move-to-col) cols))
                                          (display (mark-more-input?)))
                                         ((and (< 1 (length chunks))
                                               (< (add1 chunkno) (length chunks))
                                               (< pos-in-chunk
                                                  (inexact->exact (floor (* cols 0.9)))))
                                          (display ((esc-seq 'move-to-col) cols))
                                          (display (mark-more-input?)))
                                         ((and (> chunkno 0)
                                               (> pos-in-chunk
                                                  (inexact->exact (floor (* cols 0.1)))))
                                          (display ((esc-seq 'move-to-col) 0))
                                          (display (mark-more-input?)))))
                             ;; +1 b/c point is set after the typed char
                             (display ((esc-seq 'move-to-col) (add1 pos-in-chunk)))
                             (flush-output)))))

(define (multiline-refresh parley-state #!key redraw-line)
  (let-slots ((prompt in out line pos offset start-row) state parley-state)
             (let ((rows cols (terminal-size out))
                   (current-row current-col (get-cursor-position in))
                   (prompt-length (string-length prompt)))
               (unless start-row
                       (state-start-row-set! parley-state current-row)
                       (set! start-row current-row))
               (parameterize ((current-output-port out))
                             (display ((esc-seq 'move-to) start-row offset))
                             (when redraw-line
                                   (display "\x1b[0J") ;; erase screen from cursor position to end of screen
                                   (display "\x1b[?25l") ;; hide cursor

                                   (let ((lines (string-chop (string-append prompt line)
                                                             (- cols offset))))
                                     (display (car lines))
                                     (for-each (lambda (l)
                                                 (when (= (get-cursor-position in) rows)
                                                       (newline)
                                                       (state-start-row-set! parley-state (sub1 start-row))
                                                       (dec! start-row))
                                                 (display l))
                                               (cdr lines))))
                             (display (apply (esc-seq 'move-to)
                                             (linepos->coords start-row pos (+ offset prompt-length) cols)))
                             (display "\x1b[?25h") ;; show cursor
                             (flush-output)))))

(define (linepos->coords start-row pos prompt-length cols)
  (let ((pos (+ pos prompt-length)))
    (list (+ start-row (inexact->exact (floor (/ pos cols))))
          (add1 (modulo pos cols)))))

(define refresh-line (make-parameter singleline-refresh))

(define (prompt-loop ps return)
  ((refresh-line) ps redraw-line: (state-dirty? ps))
  (state-dirty?-set! ps #f)
  (let-slots ((pos line in out) state ps)
             (prompt-loop
              ((let ((c (read-one-char in)))
                 (cond ((alist-ref c user-key-bindings) => identity)
                       (else
                        (case c
                          ((#\newline)
                           (newline out)
                           (return line))
                          ((#\xd)
                           (newline out)
                           (return line))
                          ((#!eof)
                           (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-last-char))
                          ((#\x4)
                           (if (string-null? line)
                               (begin
                                 (display "^D" out)
                                 (return #!eof))
                               (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))
                          ((#\xc)
                           (handle 'erase-screen))
                          ((#\x1)
                           (handle 'jump-to-start-of-line))
                          ((#\x5)
                           (handle 'jump-to-eol))
                          (else
                           (lambda (s) ;; insert char at point
                             (let ((s2 s))
                               (state-line-set! s2 (string-insert line pos (string c)))
                               (state-pos-set! s2 (add1 pos))
                               (state-dirty?-set! s2 #t)
                               s2)))))))
               ps) return)))

(define (read-raw prompt in out line offset)
  (let ((l (call-with-current-continuation
            (lambda (return)
              (prompt-loop (make-state prompt in out offset line (string-length line) #f #f #t) return)))))
    (history-add! l)))

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

(define parley-read
  (let ((read-one-line (lambda (port wait)
                         (let loop ((l '()))
                           (let ((c (if (or wait (char-ready? port))
                                        (read-one-char port)
                                        #f)))
                             (cond ((or (not c)
                                        (equal? c #\newline)
                                        (equal? c #\return))
                                    (list->string (reverse l)))
                               ((eof-object? c) c)
                               (else
                                 (loop (cons c l)))))))))
    (lambda (in out prompt useful-term)
      (when useful-term
        (history-init!))
      (let ((parley-port (parley? in))
            (prev-input (and (char-ready? in)
                             (read-one-line in #f))))
        (cond
         (prev-input
          (history-add! prev-input))
         (else
          (if useful-term
              (read-raw prompt in out "" (if parley-port
                                             0
                                             (let-values (((row col) (get-cursor-position in)))
                                               col)))
              (begin
                (dbg "; Warning: dumb terminal")
                ((set-buffering-mode!) in #:none)
                (when (or (terminal-port? in)
                          parley-port)
                      (display prompt out))
                (flush-output out)
                (read-one-line in #t)))))))))

(define (parley prompt #!key (in ##sys#standard-input) (out (current-output-port)))
  ((set-buffering-mode!) out #:none)
  (let* ((real-in-port (first-usable-port in port-list))
         (useful-term  (useful-term? in))
         (old-attrs (and useful-term
                         (enable-raw-mode real-in-port)))
         (_ (unless (member in port-list)
              (set! port-list (cons in port-list))))
         (lines (parley-read real-in-port out prompt useful-term)))
    (if old-attrs
      (restore-terminal-settings real-in-port old-attrs))
    lines))

;; XXX Does not catch #,(foo), passes out on first error
(define (input-missing? line)
  (not (condition-case (with-input-from-string
                           line
                         (lambda ()
                           (let l ((o (read)))
                             (unless (eof-object? o) (l (read))))))
                       (e (exn syntax) (equal? (get-condition-property e 'exn 'arguments) '(#\))))
                       (exn () (signal exn)))))

;; parley uses port slot 11 to store the history because we need the
;; port argument to get to the history, this mimics make-input-port
;; from the ports unit directly
(define (make-parley-port in #!key prompt prompt2 history-file)
  (define (flush-history p)
    (when history-file
          (history-to-file history-file p)))
  (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* ((line (let ((r (parley (cond ((string-null? start)
                                                      (or p1 ((repl-prompt))))
                                                     ((useful-term? in) p2)
                                                     (else ""))
                                               in: in)))
                                (if (eof-object? r)
                                  r
                                  (string-append r (string #\newline)))))
                        (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)))))
             (parley-char-ready?
              (lambda ()
                (and (string? l)
                     (< pos (string-length l)))))
             (get-next-char!
              (lambda ()
                (cond ((eof-object? l) #!eof)
                      ((parley-char-ready?)
                       (let ((ch (string-ref l pos)))
                         (set! pos (add1 pos))
                         ch))
                      (else
                       (set! pos 0)
                       (set! l
                         (append-while-incomplete ""))
                       (get-next-char!))))))

      ;; XXX Set the signal handler to clear the internal state, why print a call chain here?
      (set! handle (lambda (s)
                     (print-call-chain)
                     (set! pos 0)
                     (set! l "")
                     (##sys#user-interrupt-hook)))
      (set-signal-handler! signal/int handle)

      (let* ((class
              (vector
               (lambda (p)              ; read-char
                 (parameterize ((history (##sys#slot p 11)))
                               (let ([last (##sys#slot p 10)])
                                 (cond [last
                                        (##sys#setislot p 10 #f)
                                        last]
                                       [else (get-next-char!)] ) )) )
               (lambda (p)              ; peek-char
                 (parameterize ((history (##sys#slot p 11)))
                               (let ([last (##sys#slot p 10)])
                                 (if last
                                     last
                                     (let ([last (get-next-char!)])
                                       (##sys#setslot p 10 last)
                                       last)  ) )))
               #f                       ; write-char
               #f                       ; write-string
               (lambda (p)              ; close
                                        ; reset handler to the user one if it exists
                 (set-signal-handler! signal/int (##sys#user-interrupt-hook))
                 (unless (##sys#slot p 8) (flush-history p))
                 (##sys#setislot p 8 #t))
               #f                       ; flush-output
               (lambda (p)              ; char-ready?
                 (parley-char-ready?) )
               #f                       ; read-string!
               #f                       ; read-line
               #f))                     ; read-buffered
             (data (vector #f))
             (port (##sys#make-port #t class "(parley)" 'custom)) )
        (##sys#set-port-data! port data)
        (parameterize
         ((history #f))
         (if (and history-file (file-read-access? history-file))
             (history-from-file history-file)
             (history-init!))
         (##sys#setslot port 11 (history)))
        (set-finalizer! port flush-history)
        (on-exit (lambda ()
                   (flush-history port)))
        port)))))