making (chibi term edit-line) portable, using from (chibi snow interface)

lib/chibi/snow/interface.scm

@@ -70,24 +70,19 @@
           (history-insert! input-history str)
           (check str (proc str) lp)))))))
 
-(define (input-hidden prompt)
-  (show #t prompt)
-  (flush-output-port)
-  (let ((res (with-stty '(not echo) (lambda () (read-line)))))
-    (show #t "\n")
-    res))
-
 (define (input-password cfg name prompt1 . o)
   (let ((prompt2 (or (and (pair? o) (car o))
                      (string-append prompt1 " (confirmation): "))))
     (let lp ()
-      (let ((password (input-hidden prompt1)))
+      (let ((password (edit-line 'hidden?: #t 'prompt: prompt1)))
+        (newline)
         (cond
          ((equal? password "")
           (show #t "password must be non-empty\n")
           (lp))
          (else
-          (let ((conf (input-hidden prompt2)))
+          (let ((conf (edit-line 'hidden?: #t 'prompt: prompt2)))
+            (newline)
             (cond
              ((not (equal? password conf))
               (show #t "password didn't match\n")

lib/chibi/snow/interface.sld

@@ -4,15 +4,15 @@
           restore-history save-history)
   (import (scheme base) (scheme char) (scheme read) (scheme write)
           (scheme file) (scheme process-context) (srfi 1)
-          (chibi config) (chibi pathname) (chibi show))
+          (chibi config) (chibi pathname) (chibi show)
+          (chibi term edit-line))
   (cond-expand
    (chibi
-    (import (chibi filesystem) (chibi stty)))
+    (import (chibi filesystem)))
    (chicken
-    (import posix stty)
+    (import posix)
     (begin
-      (define (create-directory* dir) (create-directory dir #t))
+      (define (create-directory* dir) (create-directory dir #t))))
-      (define (edit-line ))))
    (sagittarius
     (import (only (sagittarius) create-directory)
             (chibi string))
@@ -30,28 +30,5 @@
                        (and (not (equal? parent dir))
                             (not (file-exists? parent))
                             (create-directory* parent mode)
-                            (create-directory dir mode))))))))
+                            (create-directory dir mode)))))))))))
-      (define (with-stty spec thunk)
-        (thunk)))))
-  (cond-expand
-   (chibi
-    (import (chibi term edit-line)))
-   (else
-    (begin
-      (define (get-key ls key . o)
-        (let ((x (memq key ls)))
-          (if (and x (pair? (cdr x))) (cadr x) (and (pair? o) (car o)))))
-      (define (edit-line . args)
-        (let ((in (if (and (pair? args) (input-port? (car args)))
-                      (car args)
-                      (current-input-port)))
-              (out (if (and (eq? in (car args))
-                            (pair? (cdr args))
-                            (output-port? (cadr args)))
-                       (cadr args)
-                       (current-output-port)))
-              (prompter (get-key args 'prompt: "> ")))
-          (display (if (procedure? prompter) (prompter) prompter) out)
-          (flush-output-port out)
-          (read-line in))))))
   (include "interface.scm"))

lib/chibi/term/edit-line.scm

@@ -1,6 +1,6 @@
 ;;;; edit-line.scm - pure scheme line editor
 ;;
-;; Copyright (c) 2011-2012 Alex Shinn.  All rights reserved.
+;; Copyright (c) 2011-2017 Alex Shinn.  All rights reserved.
 ;; BSD-style license: http://synthcode.com/license.txt
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -11,7 +11,7 @@
   (write-char #\[ out)
   (if arg (display arg out))
   (write-char ch out)
-  (flush-output out))
+  (flush-output-port out))
 
 ;; we use zero-based columns
 (define (terminal-goto-col out n)  (terminal-escape out #\G (+ n 1)))
@@ -430,7 +430,7 @@
       (if (< (buffer-row buf) (buffer-max-row buf))
           (terminal-up out (- (buffer-max-row buf) (buffer-row buf))))))
     (terminal-goto-col out (buffer-col buf))
-    (flush-output out)
+    (flush-output-port out)
     (buffer-cleared?-set! buf #f)))
 
 (define (buffer-refresh buf out)
@@ -481,7 +481,7 @@
                (not (string-index #\newline x))))
       ;; fast path - append to end of buffer w/o wrapping to next line
       (display x out)
-      (flush-output out)
+      (flush-output-port out)
       (buffer-col-set! buf (+ (buffer-col buf) len))
       (buffer-cleared?-set! buf #f))
      (else
@@ -662,7 +662,7 @@
      (((buffer-complete? buf) buf)
       (command/end-of-line ch buf out return)
       (display "\r\n" out)
-      (flush-output out)
+      (flush-output-port out)
       (return))
      (else
       (command/self-insert ch buf out return)))))
@@ -679,7 +679,7 @@
   (display "^C" out)
   (newline out)
   (stty out '(icanon isig echo))
-  (exit))
+  (return '^C))
 
 (define (command/beep ch buf out return)
   (write-char (integer->char 7) out))
@@ -785,6 +785,7 @@
          (single-line? (get-key args 'single-line?: #f))
          (fresh-line (get-key args 'fresh-line: #f))
          (no-stty? (get-key args 'no-stty?: #f))
+         (hidden? (get-key args 'hidden?: #f))
          (keymap0 (get-key args 'keymap:
                            (if (get-key args 'catch-control-c?: #f)
                                standard-cancel-keymap
@@ -797,6 +798,7 @@
       (let* ((width (or terminal-width (get-terminal-width out) 80))
              (prompt (if (procedure? prompter) (prompter) prompter))
              (done? #f)
+             (tmp-out (if hidden? (open-output-string) out))
              (return (lambda o (set! done? (if (pair? o) (car o) #t)))))
         ;; Maybe start at a fresh line.
         (cond
@@ -815,7 +817,7 @@
         (buffer-single-line?-set! buf single-line?)
         (if single-line? (buffer-start-set! buf (buffer-min buf)))
         (buffer-refresh buf out)
-        (flush-output out)
+        (flush-output-port out)
         ((if no-stty? (lambda (out f) (f)) with-raw-io)
          out
          (lambda ()
@@ -833,9 +835,9 @@
                                       (buffer-clear buf out)
                                       (print-exception exn out)
                                       (buffer-draw buf out)))
-                         (x ch buf out return))
+                         (x ch buf tmp-out return))
-                       (flush-output out)
+                       (flush-output-port tmp-out)
-                       (buffer-refresh buf out)
+                       (buffer-refresh buf tmp-out)
                        (if done?
                            (and (not (eq? done? 'eof)) (buffer->string buf))
                            (lp keymap)))

lib/chibi/term/edit-line.sld

@@ -7,5 +7,32 @@
           buffer-clear buffer-refresh buffer-draw
           buffer-row buffer-col
           make-keymap make-standard-keymap)
-  (import (chibi) (chibi ast) (chibi stty) (chibi process) (srfi 9) (srfi 33))
+  (import (scheme base) (scheme char) (scheme write))
+  (cond-expand
+   ((library (srfi 33))
+    (import (srfi 33)))
+   (else
+    (import (srfi 60))))
+  (cond-expand
+   (chibi
+    (import (chibi stty)))
+   (chicken
+    (import stty))
+   (else
+    (define (with-stty spec thunk)
+      (thunk))))
+  (cond-expand
+   (chibi
+    (import (only (chibi) protect print-exception)
+            (chibi ast)))
+   (else
+    (begin
+      (define-syntax protect
+        (syntax-rules () (protect . x) (guard . x)))
+      (define (print-exception exn . o)
+        (let ((out (if (pair? o) (car o) (current-error-port))))
+          (write exn out)
+          (newline out)))
+      (define (exception? x) #f)
+      (define (exception-kind x) #f))))
   (include "edit-line.scm"))