Use global-port-print-handler instead of current-print; fixes greghen…

…dershott#725

Also, change various ~v to ~s so as not to be affected by a lang like
rhombus changing the handler.

doc/racket-mode.texi

@@ -3557,7 +3557,15 @@ restart by using @code{racket-start-back-end}.
 @node racket-pretty-print
 @subsection racket-pretty-print
 
-Use pretty-print instead of print in REPL@?
+Use pretty-print instead of plain print?
+
+When true, before each run set global-port-print-handler to use
+pretty-print from racket/pretty, which is suitable for
+s-expressions.
+
+Note: A configure-runtime submodule might replace this initial
+value with its own global port print handler -- for example to
+implement printing a non-s-expression syntax.
 
 @node racket-repl-command-file
 @subsection racket-repl-command-file
@@ -4417,7 +4425,7 @@ Face @ref{racket-repl-mode} uses for prompts.
 @node racket-repl-value
 @subsection racket-repl-value
 
-Face @ref{racket-repl-mode} uses for values output by current-print.
+Face @ref{racket-repl-mode} uses for @code{print}-ed values.
 
 @node racket-repl-error-message
 @subsection racket-repl-error-message

racket-custom.el

@@ -398,7 +398,15 @@ restart by using `racket-start-back-end'."
   :safe #'booleanp)
 
 (defcustom racket-pretty-print t
-  "Use pretty-print instead of print in REPL?"
+  "Use pretty-print instead of plain print?
+
+When true, before each run set global-port-print-handler to use
+pretty-print from racket/pretty, which is suitable for
+s-expressions.
+
+Note: A configure-runtime submodule might replace this initial
+value with its own global port print handler -- for example to
+implement printing a non-s-expression syntax."
   :type 'boolean
   :safe #'booleanp)
 
@@ -800,7 +808,7 @@ See the variable `racket-browse-url-function'.")
 
 (defface-racket racket-repl-value
   '((t (:inherit font-lock-constant-face)))
-  "Face `racket-repl-mode' uses for values output by current-print.")
+  "Face `racket-repl-mode' uses for `print'-ed values.")
 
 (defface-racket racket-repl-error-message
   '((t (:inherit error)))

racket/elisp.rkt

@@ -77,7 +77,7 @@
          (? symbol? v)
          (? string? v)) (write v)]
     [(? bytes? bstr)    (write (bytes->string/utf-8 bstr))] ; ???
-    [v                  (eprintf "elisp-write can't write Racket value ~v\n" v)
+    [v                  (eprintf "elisp-write can't write Racket value ~s\n" v)
                         (void)]))
 
 (module+ test

racket/image.rkt

@@ -18,24 +18,35 @@
 (define use-svg? #t)
 (define (set-use-svg?! v) (set! use-svg? v))
 
-(define (convert-image v)
+;; For a given value, pretty-print-size-hook can be called multiple
+;; times (!) followed once by pretty-print-print-hook. So because
+;; convert-and-save does non-trivial work, we cache.
+(define ht (make-weak-hasheq)) ;weak because #624
+
+(define (convert-image v #:remove-from-cache? [remove? #f])
   (and (convertible? v)
-       ;; Rationale for the order here:
-       ;;
-       ;; - Try bounded before unbounded flavors. Because we want
-       ;;   accurate image width, if available, for pretty-printing.
-       ;;
-       ;; - Within each flavor: Try svg (if this Emacs can use it)
-       ;;   before png. Because space.
-       (let ([fmts/exts (if use-svg?
-                            '((svg-bytes+bounds "svg")
-                              (png-bytes+bounds "png")
-                              (svg-bytes        "svg")
-                              (png-bytes        "png"))
-                            '((png-bytes+bounds "png")
-                              (png-bytes        "png")))])
-         (for/or ([fmt/ext (in-list fmts/exts)])
-           (apply convert-and-save v fmt/ext)))))
+       (begin0 (hash-ref! ht v
+                          (λ () (raw-convert-image v)))
+         (when remove?
+           (hash-remove! ht v)))))
+
+(define (raw-convert-image v)
+  ;; Rationale for the order here:
+  ;;
+  ;; - Try bounded before unbounded flavors. Because we want
+  ;;   accurate image width, if available, for pretty-printing.
+  ;;
+  ;; - Within each flavor: Try svg (if this Emacs can use it)
+  ;;   before png. Because space.
+  (define fmts/exts (if use-svg?
+                        '((svg-bytes+bounds "svg")
+                          (png-bytes+bounds "png")
+                          (svg-bytes        "svg")
+                          (png-bytes        "png"))
+                        '((png-bytes+bounds "png")
+                          (png-bytes        "png"))))
+  (for/or ([fmt/ext (in-list fmts/exts)])
+    (apply convert-and-save v fmt/ext)))
 
 (define (convert-and-save v fmt ext)
   (define (default-width _) 4096)

racket/main.rkt

@@ -41,7 +41,7 @@
     [(vector "--do-not-use-svg") (set-use-svg?! #f)]
     [v
      (error '|Racket Mode back end|
-            "Bad command-line arguments:\n~v\n" v)])
+            "Bad command-line arguments:\n~s\n" v)])
 
   ;; Save original current-{input output}-port to give to
   ;; command-server-loop for command I/O.

racket/package.rkt

@@ -89,7 +89,7 @@
                        (for/list ([p (in-list (get-pkg-modules name (pkg-catalog p) (pkg-checksum p)))])
                          (match p
                            [`(lib ,path) path]
-                           [other        (format "~v" other)]))
+                           [other        (format "~s" other)]))
                        string<?)
              'description (cleanse-pkg-desc p))]
     [(list) (void)])

racket/print.rkt

@@ -4,122 +4,38 @@
 #lang racket/base
 
 (require racket/match
-         racket/port
          racket/pretty
          "image.rkt"
-         "repl-output.rkt")
+         (only-in "repl-output.rkt"
+                  repl-output-print-value?))
 
-(provide make-racket-mode-print-handler)
+(provide make-pretty-global-port-print-handler)
 
-(define (make-racket-mode-print-handler pretty? columns pixels/char)
-  (define (racket-mode-print-handler v)
+(define (make-pretty-global-port-print-handler columns pixels/char)
+  (define (racket-mode-pretty-global-port-print-handler v out [depth 0])
     (unless (void? v)
-      (define-values (in out) (make-value-pipe))
-      (parameterize ([current-output-port out]
-                     [print-syntax-width +inf.0])
-        (cond
-          [pretty?
-           (parameterize ([pretty-print-columns columns]
-                          [pretty-print-size-hook (make-pp-size-hook pixels/char)]
-                          [pretty-print-print-hook (make-pp-print-hook)])
-             (pretty-print v))]
-          [else
-           (match (convert-image v)
-             [(cons path-name _pixel-width)
-              (write-special (cons 'image path-name))]
-             [_
-              (print v)])
-           (newline)]))
-      (drain-value-pipe in out)))
-  racket-mode-print-handler)
-
-;; Because pretty-print does a print for each value within a list,
-;; plus for each space and newline, etc., it can result in many calls
-;; to repl-output-value with short strings.
-;;
-;; To avoid this: Use for current-output-port a pipe of unlimited size
-;; to accumulate all the pretty-printed bytes and specials. Finally
-;; drain it using read-bytes-avail! to consolidate runs of bytes
-;; (interrupted only by specials, if any) up to a fixed buffer size.
-;;
-;; One wrinkle: bytes->string/utf-8 could fail if we happen to read
-;; only some of a multi byte utf-8 sequence; issue #715. In that case,
-;; read more bytes and try decoding again. If the buffer is full, grow
-;; it just a little.
-
-(define (make-value-pipe)
-  (make-pipe-with-specials))
-
-(define (drain-value-pipe in out)
-  (flush-output out)
-  (close-output-port out)
-  (let loop ([buffer (make-bytes 8192)]
-             [buffer-read-pos 0])
-    (match (read-bytes-avail! buffer in buffer-read-pos)
-      ;; When read-bytes-avail! returns 0, it means there are bytes
-      ;; available to read but no buffer space remaining. Grow buffer
-      ;; by 8 bytes; 4 bytes max utf-8 sequence plus margin.
-      [0
-       (loop (bytes-append buffer (make-bytes 8))
-             (bytes-length buffer))]
-      [(? exact-nonnegative-integer? len)
-       (match (safe-bytes->string/utf-8 buffer len)
-         [#f
-          (loop buffer (+ buffer-read-pos len))]
-         [(? string? s)
-          (repl-output-value s)
-          (loop buffer 0)])]
-      [(? procedure? read-special)
-       ;; m-p-w-specials ignores the position arguments so just pass
-       ;; something satisfying the contract.
-       (define v (read-special #f #f #f 1))
-       (repl-output-value-special v)
-       (loop buffer 0)]
-      [(? eof-object?) (void)])))
-
-(define (safe-bytes->string/utf-8 buffer len)
-  (with-handlers ([exn:fail:contract? (λ _ #f)])
-    (bytes->string/utf-8 buffer #f 0 len)))
-
-;; pretty-print uses separate size and print hooks -- and the size
-;; hook can even be called more than once per object. Avoid calling
-;; convert-image two (or more!) times per object. That could be slow
-;; for large images; furthermore each call creates a temp file.
-;;
-;; Instead: Call convert-image once in the size hook, storing the
-;; result in a hash-table for use across later calls to the size
-;; and/or print hook. Remove in the print hook.
-;;
-;; (Note: Although I had tried using the pre-print and post-print
-;; hooks, they seemed to be called inconsistently.)
-;;
-;; Also: "The print-hook procedure is applied to a value for printing
+      (if (repl-output-print-value?)
+          (parameterize ([print-syntax-width     +inf.0]
+                         [pretty-print-columns   columns]
+                         [pretty-print-size-hook (size-hook pixels/char)]
+                         [pretty-print-print-hook print-hook])
+            (pretty-print v out depth #:newline? #f))
+          (pretty-print v out depth #:newline? #f))))
+  racket-mode-pretty-global-port-print-handler)
+
+;; Return char width of convertible image.
+(define ((size-hook pixels/char) value _display? _port)
+  (match (convert-image value) ;caches
+    [(cons _path-name pixel-width)
+     (inexact->exact
+      (ceiling
+       (/ pixel-width pixels/char)))]
+    [#f #f]))
+
+;; Note: "The print-hook procedure is applied to a value for printing
 ;; when the sizing hook (see pretty-print-size-hook) returns an
 ;; integer size for the value." i.e. But not called otherwise.
-
-(define ht (make-weak-hasheq)) ;weak because #624
-
-(define (make-pp-size-hook pixels/char)
-  (define (racket-mode-size-hook value display? port)
-    (define (not-found)
-      (match (convert-image value)
-        [(cons path-name pixel-width)
-         (define char-width (inexact->exact (ceiling (/ pixel-width pixels/char))))
-         (cons path-name char-width)]
-        [#f #f]))
-    (match (hash-ref! ht value not-found)
-      [(cons _path-name char-width) char-width]
-      [#f #f]))
-  racket-mode-size-hook)
-
-;; Only called if size-hook returned an integer size.
-(define (make-pp-print-hook)
-  (define orig (pretty-print-print-hook))
-  (define (racket-mode-print-hook value display? port)
-    (match (hash-ref ht value #f)
-      [(cons path-name _char-width)
-       (hash-remove! ht value)
-       (write-special (cons 'image path-name))]
-      [_ ;shouldn't happen, but...
-       (orig value display? port)]))
-  racket-mode-print-hook)
+(define (print-hook value _display? port)
+  (match (convert-image value #:remove-from-cache? #t)
+    [(cons path-name _pixel-width)
+     (write-special (cons 'image path-name) port)]))