[#922,#927] pprint/formatter-out + cl-format with-out-str support (#930)

sci

@@ -1 +1 @@
-Subproject commit e4cfa161b06fa3cfe2c18342aaf8d7ffe2d5ae9d
+Subproject commit 96a54feb9acb397a785d29a0307c8a6de2404c37

src/babashka/impl/pprint.clj

@@ -3,7 +3,9 @@
   (:require [clojure.pprint :as pprint]
             [sci.core :as sci]))
 
-(defonce patch-option-table
+(defonce patched? (volatile! false))
+
+(when-not @patched?
   (alter-var-root #'pprint/write-option-table
                   (fn [m]
                     (zipmap (keys m)
@@ -16,12 +18,21 @@
             #(when-let [v (get t (key %))] [v (val %)])
             m))))
 
-(alter-var-root #'pprint/table-ize (constantly new-table-ize))
+(when-not @patched?
+  (alter-var-root #'pprint/table-ize (constantly new-table-ize))
+  (alter-meta! #'pprint/write-option-table dissoc :private)
+  (alter-meta! #'pprint/with-pretty-writer dissoc :private)
+  (alter-meta! #'pprint/pretty-writer? dissoc :private)
+  (alter-meta! #'pprint/make-pretty-writer dissoc :private)
+  (alter-meta! #'pprint/execute-format dissoc :private))
 
-(alter-meta! #'pprint/write-option-table dissoc :private)
-(alter-meta! #'pprint/with-pretty-writer dissoc :private)
-(alter-meta! #'pprint/pretty-writer? dissoc :private)
-(alter-meta! #'pprint/make-pretty-writer dissoc :private)
+(def pprint-ns (sci/create-ns 'clojure.pprint nil))
+
+(def print-right-margin
+  (sci/new-dynamic-var '*print-right-margin* pprint/*print-right-margin* {:ns pprint-ns}))
+
+(def print-pprint-dispatch
+  (sci/new-dynamic-var '*print-pprint-dispatch* pprint/*print-pprint-dispatch* {:ns pprint-ns}))
 
 (def new-write
   (fn [object & kw-args]
@@ -45,10 +56,8 @@
             (if (nil? optval)
               (.toString ^java.io.StringWriter base-writer))))))))
 
-(alter-var-root #'pprint/write (constantly new-write))
-
-(def pprint-ns (sci/create-ns 'clojure.pprint nil))
-
+(when-not @patched?
+  (alter-var-root #'pprint/write (constantly new-write)))
 
 (defn print-table
   "Prints a collection of maps in a textual table. Prints table headings
@@ -59,11 +68,19 @@
    (binding [*out* @sci/out]
      (pprint/print-table ks rows))))
 
-(def print-right-margin
-  (sci/new-dynamic-var '*print-right-margin* pprint/*print-right-margin* {:ns pprint-ns}))
-
-(def print-pprint-dispatch
-  (sci/new-dynamic-var '*print-pprint-dispatch* pprint/*print-pprint-dispatch* {:ns pprint-ns}))
+(defmacro formatter-out
+  "Makes a function which can directly run format-in. The function is
+  fn [& args] ... and returns nil. This version of the formatter macro is
+  designed to be used with *out* set to an appropriate Writer. In particular,
+  this is meant to be used as part of a pretty printer dispatch method.
+  format-in can be either a control string or a previously compiled format."
+  {:added "1.2"}
+  [format-in]
+  `(let [format-in# ~format-in
+         cf# (if (string? format-in#) (#'clojure.pprint/cached-compile format-in#) format-in#)]
+     (fn [& args#]
+       (let [navigator# (#'clojure.pprint/init-navigator args#)]
+         (#'clojure.pprint/execute-format cf# navigator#)))))
 
 (defn pprint
   "Pretty print object to the optional output writer. If the writer is not provided,
@@ -72,22 +89,59 @@
    (pprint s @sci/out))
   ([s writer]
    (binding [pprint/*print-right-margin* @print-right-margin
-             #_#_pprint/*print-pprint-dispatch* @print-pprint-dispatch]
+             pprint/*print-pprint-dispatch* @print-pprint-dispatch]
      (pprint/pprint s writer))))
 
+(defn cl-format
+   "An implementation of a Common Lisp compatible format function. cl-format formats its
+arguments to an output stream or string based on the format control string given. It 
+supports sophisticated formatting of structured data.
+Writer is an instance of java.io.Writer, true to output to *out* or nil to output 
+to a string, format-in is the format control string and the remaining arguments 
+are the data to be formatted.
+The format control string is a string to be output with embedded 'format directives' 
+describing how to format the various arguments passed in.
+If writer is nil, cl-format returns the formatted result string. Otherwise, cl-format 
+returns nil.
+For example:
+ (let [results [46 38 22]]
+        (cl-format true \"There ~[are~;is~:;are~]~:* ~d result~:p: ~{~d~^, ~}~%\" 
+                   (count results) results))
+Prints to *out*:
+ There are 3 results: 46, 38, 22
+Detailed documentation on format control strings is available in the \"Common Lisp the 
+Language, 2nd edition\", Chapter 22 (available online at:
+http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000) 
+and in the Common Lisp HyperSpec at 
+http://www.lispworks.com/documentation/HyperSpec/Body/22_c.htm
+"
+  [& args]
+  ;; bind *out* to sci/out, so with-out-str works
+  (binding [*out* @sci/out]
+    (apply pprint/cl-format args)))
+
+(defn execute-format
+  "We need to bind sci/out to *out* so all calls to clojure.core/print are directed
+  to the writer bound to *out* by the cl-format logic."
+  [& args]
+  (sci/binding [sci/out *out*]
+    (apply #'pprint/execute-format args)))
+
 (def pprint-namespace
   {'pp (sci/copy-var pprint/pp pprint-ns)
    'pprint (sci/copy-var pprint pprint-ns)
    'print-table (sci/copy-var print-table pprint-ns)
    '*print-right-margin* print-right-margin
-   'cl-format (sci/copy-var pprint/cl-format pprint-ns)
+   'cl-format (sci/copy-var cl-format pprint-ns)
    ;; we alter-var-root-ed write above, so this should copy the right function
    'write (sci/copy-var pprint/write pprint-ns)
    'simple-dispatch (sci/copy-var pprint/simple-dispatch pprint-ns)
-   ;; 'formatter-out (sci/copy-var pprint/formatter-out pprint-ns)
-   ;; 'cached-compile (sci/copy-var pprint/cached-compile pprint-ns) #_(sci/new-var 'cache-compile @#'pprint/cached-compile (meta @#'pprint/cached-compile))
-   ;; 'init-navigator (sci/copy-var pprint/init-navigator pprint-ns)
-   ;; 'execute-format (sci/copy-var pprint/execute-format pprint-ns)
-   ;; 'with-pprint-dispatch (sci/copy-var pprint/with-pprint-dispatch pprint-ns)
-   ;; '*print-pprint-dispatch* print-pprint-dispatch
+   'formatter-out (sci/copy-var formatter-out pprint-ns)
+   'cached-compile (sci/copy-var pprint/cached-compile pprint-ns) #_(sci/new-var 'cache-compile @#'pprint/cached-compile (meta @#'pprint/cached-compile))
+   'init-navigator (sci/copy-var pprint/init-navigator pprint-ns)
+   'execute-format (sci/copy-var execute-format pprint-ns)
+   'with-pprint-dispatch (sci/copy-var pprint/with-pprint-dispatch pprint-ns)
+   '*print-pprint-dispatch* print-pprint-dispatch
    })
+
+(vreset! patched? true)

test/babashka/main_test.clj

@@ -12,10 +12,11 @@
    [sci.core :as sci]))
 
 (defn bb [input & args]
-  (edn/read-string
-   {:readers *data-readers*
-    :eof nil}
-   (apply test-utils/bb (when (some? input) (str input)) (map str args))))
+  (test-utils/normalize
+   (edn/read-string
+    {:readers *data-readers*
+     :eof nil}
+    (apply test-utils/bb (when (some? input) (str input)) (map str args)))))
 
 (deftest parse-opts-test
   (is (= "1667"
@@ -170,20 +171,18 @@
 (defn foo [x y]
   (+ x y))" name))
       (is (= "(defn foo [x y]\n  (+ x y))\n"
-             (test-utils/normalize
-               (bb nil (format "
+             (bb nil (format "
 (load-file \"%s\")
 (require '[clojure.repl :refer [source]])
 (with-out-str (source %s/foo))"
-                         (test-utils/escape-file-paths (.getPath tmp))
-                         name))))))
+                             (test-utils/escape-file-paths (.getPath tmp))
+                             name)))))
     (testing "print source from file on classpath"
       (is (= "(defn foo [x y]\n  (+ x y))\n"
-             (test-utils/normalize
-               (bb nil
-                   "-cp" dir
-                   "-e" (format "(require '[clojure.repl :refer [source]] '[%s])" name)
-                   "-e" (format "(with-out-str (source %s/foo))" name))))))))
+             (bb nil
+                 "-cp" dir
+                 "-e" (format "(require '[clojure.repl :refer [source]] '[%s])" name)
+                 "-e" (format "(with-out-str (source %s/foo))" name)))))))
 
 (deftest eval-test
   (is (= "120\n" (test-utils/bb nil "(eval '(do (defn foo [x y] (+ x y))
@@ -452,17 +451,28 @@
     (is (string? (bb nil "(let [sw (java.io.StringWriter.)] (clojure.pprint/pprint (range 10) sw) (str sw))"))))
   (testing "*print-right-margin*"
     (is (= "(0\n 1\n 2\n 3\n 4\n 5\n 6\n 7\n 8\n 9)\n"
-          (test-utils/normalize (bb nil "
+           (bb nil "
 (let [sw (java.io.StringWriter.)]
   (binding [clojure.pprint/*print-right-margin* 5]
-    (clojure.pprint/pprint (range 10) sw)) (str sw))"))))
+    (clojure.pprint/pprint (range 10) sw)) (str sw))")))
     (is (= "(0 1 2 3 4 5 6 7 8 9)\n"
-          (test-utils/normalize (bb nil "
+           (bb nil "
 (let [sw (java.io.StringWriter.)]
   (binding [clojure.pprint/*print-right-margin* 50]
-    (clojure.pprint/pprint (range 10) sw)) (str sw))")))))
+    (clojure.pprint/pprint (range 10) sw)) (str sw))"))))
   (testing "print-table writes to sci/out"
-    (is (str/includes? (test-utils/bb "(with-out-str (clojure.pprint/print-table [{:a 1} {:a 2}]))") "----"))))
+    (is (str/includes? (test-utils/bb "(with-out-str (clojure.pprint/print-table [{:a 1} {:a 2}]))") "----")))
+  (testing "cl-format writes to sci/out"
+    (is (= "[1, 2, 3]" (bb nil "(with-out-str (clojure.pprint/cl-format true \"~<[~;~@{~w~^, ~:_~}~;]~:>\" [1,2,3]))"))))
+  (testing "formatter-out"
+    (is (= "[1, 2, 3]\n"
+           (bb nil (pr-str '(do (require '[clojure.pprint :as pprint])
+                                (def print-array (pprint/formatter-out "~<[~;~@{~w~^, ~:_~}~;]~:>"))
+                                (pprint/with-pprint-dispatch
+                                  #(if (seqable? %)
+                                     (print-array %)
+                                     (print %))
+                                  (with-out-str (pprint/pprint [1 2 3]))))))))))
 
 (deftest read-string-test
   (testing "namespaced keyword via alias"