[Guile-commits] 10/18: Modernize soft ports

[Andy Wingo]

wingo pushed a commit to branch main
in repository guile.

commit f320ce89793e93177e12b0a36b482dec1e242407
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Wed May 31 10:28:50 2023 +0200

    Modernize soft ports
    
    * doc/ref/api-io.texi (Soft Ports): Update docs.
    * module/ice-9/boot-9.scm (make-soft-port): Don't eagerly load soft
    ports.
    * module/ice-9/soft-ports.scm (deprecated-make-soft-port): Rename from
    make-soft-port.
    (make-soft-port): New interface.
---
 doc/ref/api-io.texi         |  75 +++++++++++++++++++++++---
 module/ice-9/boot-9.scm     |  10 ++--
 module/ice-9/soft-ports.scm | 127 ++++++++++++++++++++++++++++++++++++--------
 3 files changed, 178 insertions(+), 34 deletions(-)

diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi
index 70959037e..b6ea593f7 100644
--- a/doc/ref/api-io.texi
+++ b/doc/ref/api-io.texi
@@ -1060,7 +1060,7 @@ initialized with the @var{port} argument.
 * Bytevector Ports:: Ports on a bytevector.
 * String Ports:: Ports on a Scheme string.
 * Custom Ports:: Ports whose implementation you control.
-* Soft Ports:: An older version of custom ports.
+* Soft Ports:: A Guile-specific version of custom ports.
 * Void Ports:: Ports on nothing at all.
 * Low-Level Custom Ports:: Implementing new kinds of port.
 * Low-Level Custom Ports in C:: A C counterpart to make-custom-port.
@@ -1522,14 +1522,75 @@ With custom textual ports:
 @cindex Port, soft
 
 Soft ports are what Guile had before it had custom binary and textual
-ports.  Probably you want to use one of those instead.  @xref{Custom
+ports, and allow for customizable textual input and output.
+
+We recommend soft ports over R6RS custom textual ports because they are
+easier to use while also being more expressive.  R6RS custom textual
+ports operate under the principle that a port has a mutable string
+buffer, and this is reflected in the @code{read} and @code{write}
+procedures which take a buffer, offset, and length.  However in Guile as
+all ports have a byte buffer rather than some having a string buffer,
+the R6RS interface imposes overhead and complexity.
+
+Additionally, and unlike the R6RS interfaces, @code{make-soft-port} from
+the @code{(ice-9 soft-ports)} module accepts keyword arguments, allowing
+for its functionality to be extended over time.
+
+If you find yourself needing more power, notably the ability to seek,
+probably you want to use low-level custom ports.  @xref{Low-Level Custom
 Ports}.
 
-But since you are still here, a @dfn{soft port} is a port based on a
-vector of procedures capable of accepting or delivering characters.  It
-allows emulation of I/O ports.
+@example
+(use-modules (ice-9 soft-ports))
+@end example
+
+@deffn {Scheme Procedure} make-soft-port @
+       [#:id] [#:read-string] [#:write-string] [#:input-waiting?] @
+       [#:close] [#:close-on-gc?]
+Return a new port.  If the @var{read-string} keyword argument is
+present, the port will be an input port.  If @var{write-string} is
+present, the port will be an output port.  If both are supplied, the
+port will be open for input and output.
+
+When the port's internal buffers are empty, @var{read-string} will be
+called with no arguments, and should return a string, or @code{#f} to
+indicate end-of-stream.  Similarly when a port flushes its write buffer,
+the characters in that buffer will be passed to the @var{write-string}
+procedure as its single argument.  @var{write-string} returns
+unspecified values.
+
+If supplied, @var{input-waiting?} should return @code{#t} if the soft
+port has input which would be returned directly by @var{read-string}.
+
+If supplied, @var{close} will be called when the port is closed, with no
+arguments.  If @var{close-on-gc?} is @code{#t}, @var{close} will
+additionally be called when the port becomes unreachable, after flushing
+any pending write buffers.
+@end deffn
+
+With soft ports, the @code{open-string-input-port} example from the
+previous section is more simple:
+
+@example
+(define (open-string-input-port source)
+  (define already-read? #f)
+
+  (define (read-string)
+    (cond
+     (already-read? "")
+     (else
+      (set! already-read? #t)
+      source)))
+
+  (make-soft-port #:id "strport" #:read-string read-string))
+@end example
+
+Note that there was an earlier form of @code{make-soft-port} which was
+exposed in Guile's default environment, and which is still there.  Its
+interface is more clumsy and its users historically expect unbuffered
+input.  This interface will be deprecated, but we document it here.
 
-@deffn {Scheme Procedure} make-soft-port pv modes
+@deffn {Scheme Procedure} deprecated-make-soft-port pv modes
 Return a port capable of receiving or delivering characters as
 specified by the @var{modes} string (@pxref{File Ports,
 open-file}).  @var{pv} must be a vector of length 5 or 6.  Its
@@ -1563,7 +1624,7 @@ For example:
 
 @lisp
 (define stdout (current-output-port))
-(define p (make-soft-port
+(define p (deprecated-make-soft-port
            (vector
             (lambda (c) (write c stdout))
             (lambda (s) (display s stdout))
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 381960406..686a9c87d 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -4700,12 +4700,14 @@ R7RS."
 
 
 
-;;; make-soft-port in the default environment.  FIXME: we should
-;;; figure out how to deprecate this.
+;;; make-soft-port in the default environment.  FIXME: Deprecate, make
+;;; callers import (ice-9 soft-port).
 ;;;
 
-;; FIXME:
-(module-use! the-scm-module (resolve-interface '(ice-9 soft-ports)))
+(define (make-soft-port pv modes)
+  ((module-ref (resolve-interface '(ice-9 soft-ports))
+               'deprecated-make-soft-port)
+   pv modes))
 
 
 
diff --git a/module/ice-9/soft-ports.scm b/module/ice-9/soft-ports.scm
index 1b2b2dc9c..2dc7203c3 100644
--- a/module/ice-9/soft-ports.scm
+++ b/module/ice-9/soft-ports.scm
@@ -29,15 +29,16 @@
   #:use-module (ice-9 match)
   #:use-module (rnrs bytevectors)
   #:use-module (rnrs bytevectors gnu)
-  #:export (make-soft-port))
+  #:export (deprecated-make-soft-port)
+  #:replace (make-soft-port))
 
 (define (type-error proc expecting val)
   (scm-error 'wrong-type-arg proc "Wrong type (expecting `~S'): ~S"
              (list expecting val) (list val)))
 
-(define (soft-port-read %get-char)
+(define (deprecated-soft-port-read %get-char)
   (unless (procedure? %get-char)
-    (type-error "soft-port-read" "procedure" %get-char))
+    (type-error "deprecated-soft-port-read" "procedure" %get-char))
   (define encode-buf-size 10)
   (define buffer (make-bytevector encode-buf-size))
   (define buffer-pos 0)
@@ -71,12 +72,12 @@
         (set! buffer-pos (+ buffer-pos to-copy))
         to-copy))))
 
-(define (soft-port-write %put-string %flush)
+(define (deprecated-soft-port-write %put-string %flush)
   (unless (procedure? %put-string)
-    (type-error "soft-port-write" "procedure" %put-string))
+    (type-error "deprecated-soft-port-write" "procedure" %put-string))
   (when %flush
     (unless (procedure? %flush)
-      (type-error "soft-port-write" "procedure" %flush)))
+      (type-error "deprecated-soft-port-write" "procedure" %flush)))
   (lambda (port bv start count)
     (let* ((bytes (bytevector-slice bv start count))
            (str (call-with-input-bytevector
@@ -91,18 +92,19 @@
       (if %flush (%flush))
       count)))
 
-(define (soft-port-close %close)
+(define (deprecated-soft-port-close %close)
   (unless (procedure? %close)
     (type-error "soft-port-close" "procedure" %close))
   (lambda (port) (%close)))
 
-(define (soft-port-input-waiting? %input-ready)
+(define (deprecated-soft-port-input-waiting? %input-ready)
   (unless (procedure? %input-ready)
-    (type-error "soft-port-close" "procedure" %input-ready))
+    (type-error "deprecated-soft-port-close" "procedure" %input-ready))
   (lambda (port) (< 0 (%input-ready))))
 
-(define (%make-soft-port %put-char %put-string %flush %get-char %close
-                         %input-ready reading? writing? buffering)
+(define (%deprecated-make-soft-port %put-char %put-string %flush %get-char
+                                    %close %input-ready
+                                    reading? writing? buffering)
   (cond
    ((not (or reading? writing?))
     (%make-void-port ""))
@@ -110,13 +112,12 @@
     (let ((port
            (make-custom-port
             #:id "soft-port"
-            #:read (and reading? (soft-port-read %get-char))
-            #:write (and writing? (soft-port-write %put-string %flush))
+            #:read (and reading? (deprecated-soft-port-read %get-char))
+            #:write (and writing? (deprecated-soft-port-write %put-string 
%flush))
             #:seek (lambda (port offset whence)
                      (error "soft ports are not seekable"))
-            #:close (if %close
-                        (soft-port-close %close)
-                        (lambda (port) (values)))
+            #:close (and %close
+                         (deprecated-soft-port-close %close))
             #:get-natural-buffer-sizes (lambda (port read-size write-size)
                                          ;; The in-practice expectation
                                          ;; is that soft ports have
@@ -124,14 +125,14 @@
                                          (values read-size 1))
             #:random-access? (lambda (port) #f)
             #:input-waiting? (if %input-ready
-                                 (soft-port-input-waiting? %input-ready)
+                                 (deprecated-soft-port-input-waiting? 
%input-ready)
                                  (lambda (port) #t))
             #:close-on-gc? #t)))
       (when buffering
         (setvbuf port buffering))
       port))))
 
-(define (make-soft-port vtable modes)
+(define (deprecated-make-soft-port vtable modes)
   "Return a port capable of receiving or delivering characters as
 specified by the @var{modes} string (@pxref{File Ports, open-file}).
 @var{pv} must be a vector of length 5 or 6.  Its components are as
@@ -191,9 +192,89 @@ For example:
           (else #f))))
   (match vtable
     (#(%put-char %put-string %flush %get-char %close)
-     (%make-soft-port %put-char %put-string %flush %get-char %close #f
-                      reading? writing? buffering))
+     (%deprecated-make-soft-port %put-char %put-string %flush %get-char %close
+                                 #f reading? writing? buffering))
     (#(%put-char %put-string %flush %get-char %close %chars-waiting)
-     (%make-soft-port %put-char %put-string %flush %get-char %close
-                      %chars-waiting
-                      reading? writing? buffering))))
+     (%deprecated-make-soft-port %put-char %put-string %flush %get-char %close
+                                 %chars-waiting reading? writing? buffering))))
+
+(define (soft-port-read read-string)
+  (unless (procedure? read-string)
+    (type-error "soft-port-read" "procedure" read-string))
+  (define-values (transcoder get-bytes) (open-bytevector-output-port))
+  (define buffer #f)
+  (define buffer-pos 0)
+  (lambda (port bv start count)
+    (unless (and buffer (< buffer-pos (bytevector-length buffer)))
+      (let* ((str (read-string)))
+        (unless (eq? (port-encoding port) (port-encoding transcoder))
+          (set-port-encoding! transcoder (port-encoding port)))
+        (unless (eq? (port-conversion-strategy port)
+                     (port-conversion-strategy transcoder))
+          (set-port-conversion-strategy! transcoder
+                                         (port-conversion-strategy port)))
+        (put-string transcoder str)
+        (set! buffer (get-bytes))
+        (set! buffer-pos 0)))
+
+    (let ((to-copy (min count (- (bytevector-length buffer) buffer-pos))))
+      (bytevector-copy! buffer buffer-pos bv start to-copy)
+      (if (= (bytevector-length buffer) (+ buffer-pos to-copy))
+          (set! buffer #f)
+          (set! buffer-pos (+ buffer-pos to-copy)))
+      to-copy)))
+
+(define (soft-port-write write-string)
+  (unless (procedure? write-string)
+    (type-error "soft-port-write" "procedure" write-string))
+  (lambda (port bv start count)
+    (write-string
+     (call-with-input-bytevector
+      (bytevector-slice bv start count)
+      (lambda (bport)
+        (set-port-encoding! bport (port-encoding port))
+        (set-port-conversion-strategy!
+         bport
+         (port-conversion-strategy port))
+        (get-string-all bport))))
+    count))
+
+(define* (make-soft-port #:key
+                         (id "soft-port")
+                         (read-string #f)
+                         (write-string #f)
+                         (input-waiting? #f)
+                         (close #f)
+                         (close-on-gc? #f))
+  "Return a new port.  If the @var{read-string} keyword argument is
+present, the port will be an input port.  If @var{write-string} is
+present, the port will be an output port.  If both are supplied, the
+port will be open for input and output.
+
+When the port's internal buffers are empty, @var{read-string} will be
+called with no arguments, and should return a string.  Returning \"\"
+indicates end-of-stream.  Similarly when a port flushes its write
+buffer, the characters in that buffer will be passed to the
+@var{write-string} procedure as its single argument.  @var{write-string}
+returns unspecified values.
+
+If supplied, @var{input-waiting?} should return @code{#t} if the soft
+port has input which would be returned directly by @var{read-string}.
+
+If supplied, @var{close} will be called when the port is closed, with no
+arguments.  If @var{close-on-gc?} is @code{#t}, @var{close} will
+additionally be called when the port becomes unreachable, after flushing
+any pending write buffers."
+  (unless (or read-string write-string)
+    (error "Expected at least one of #:read-string, #:write-string"))
+  (when (and input-waiting? (not read-string))
+    (error "Supplying #:input-waiting? requires a #:read-string"))
+  (make-custom-port
+   #:id id
+   #:read (and read-string (soft-port-read read-string))
+   #:write (and write-string (soft-port-write write-string))
+   #:close (and close (lambda (port) (close)))
+   #:input-waiting? (and input-waiting?
+                         (lambda (port) (input-waiting?)))
+   #:close-on-gc? close-on-gc?
+   #:encoding 'UTF-8))