[#365] Control printing in CLJS via *print-fn* rather than *out*

src/sci/core.cljc

@@ -87,6 +87,7 @@
     `(with-bindings ~(apply hash-map bindings)
        (do ~@body))))
 
+;; I/O
 (def in "Sci var that represents sci's `clojure.core/*in*`" sio/in)
 (def out "Sci var that represents sci's `clojure.core/*out*`" sio/out)
 (def err "Sci var that represents sci's `clojure.core/*err*`" sio/err)
@@ -96,6 +97,8 @@
 (def print-level "Sci var that represents sci's `clojure.core/*print-level*`" sio/print-level)
 (def print-meta "Sci var that represents sci's `clojure.core/*print-meta*`" sio/print-meta)
 (def print-readably "Sci var that represents sci's `clojure.core/*print-readably*`" sio/print-readably)
+#?(:cljs (def print-fn "Sci var that represents sci's `cljs.core/*print-fn*`" sio/print-fn))
+#?(:cljs (def print-newline "Sci var that represents sci's `cljs.core/*print-newline*`" sio/print-newline))
 
 (def *1 namespaces/*1)
 (def *2 namespaces/*2)
@@ -121,11 +124,18 @@
   StringWriter.  Returns the string created by any nested printing
   calls."
     [& body]
-    `(let [out# (macros/? :clj (java.io.StringWriter.)
-                          :cljs (goog.string/StringBuffer.))]
-       (with-bindings {out out#}
-         (do ~@body)
-         (str out#)))))
+    (macros/? :clj
+              `(let [out# (java.io.StringWriter.)]
+                 (with-bindings {out out#}
+                   (do ~@body)
+                   (str out#)))
+              :cljs
+              `(let [sb# (goog.string/StringBuffer.)]
+                 (cljs.core/binding []
+                   (with-bindings {sci.core/print-newline true
+                                   sci.core/print-fn (fn [x#] (.append sb# x#))}
+                     (do ~@body)
+                     (str sb#)))))))
 
 (macros/deftime
   (defmacro future

src/sci/impl/analyzer.cljc

@@ -680,14 +680,14 @@
                                             (str "Unable to resolve classname: " t) t))]
                              (assoc m :tag-class clazz))
                            m)))
-        method-expr (name method-expr)
+        method-name (name method-expr)
         args (when args (analyze-children ctx args))
         res #?(:clj (if (class? instance-expr)
                       (if (nil? args)
-                        (if (str/starts-with? method-expr "-")
+                        (if (str/starts-with? method-name "-")
                           (ctx-fn
                            (fn [_ctx _bindings]
-                             (interop/get-static-field [instance-expr (subs method-expr 1)]))
+                             (interop/get-static-field [instance-expr (subs method-name 1)]))
                            nil expr nil)
                           ;; https://clojure.org/reference/java_interop
                           ;; If the second operand is a symbol and no args are
@@ -698,41 +698,43 @@
                           ;; of the same name, in which case it resolves to a
                           ;; call to the method.
                           (if-let [_
-                                   (try (Reflector/getStaticField ^Class instance-expr ^String method-expr)
+                                   (try (Reflector/getStaticField ^Class instance-expr ^String method-name)
                                         (catch IllegalArgumentException _ nil))]
                             (ctx-fn
                              (fn [_ctx _bindings]
-                               (interop/get-static-field [instance-expr method-expr]))
+                               (interop/get-static-field [instance-expr method-name]))
                              nil expr nil)
                             (ctx-fn
                              (fn [ctx bindings]
-                               (eval/eval-static-method-invocation ctx bindings (cons [instance-expr method-expr] args)))
+                               (eval/eval-static-method-invocation ctx bindings (cons [instance-expr method-name] args)))
                              nil
                              expr
                              (assoc (meta expr)
                                     :ns @vars/current-ns
                                     :file @vars/current-file))))
                         (ctx-fn
                          (fn [ctx bindings]
-                           (eval/eval-static-method-invocation ctx bindings (cons [instance-expr method-expr] args)))
+                           (eval/eval-static-method-invocation ctx bindings (cons [instance-expr method-name] args)))
                          nil expr
                          (assoc (meta expr)
                                 :ns @vars/current-ns
                                 :file @vars/current-file)))
                       (ctx-fn (fn [ctx bindings]
-                                (eval/eval-instance-method-invocation ctx bindings instance-expr method-expr args))
+                                (eval/eval-instance-method-invocation ctx bindings instance-expr method-name args))
                               ;; this info is used by set!
                               {::instance-expr instance-expr
-                               ::method-expr method-expr}
+                               ::method-name method-name}
                               expr
                               (assoc (meta expr)
                                      :ns @vars/current-ns
                                      :file @vars/current-file)))
-               :cljs (ctx-fn (fn [ctx bindings]
-                               (eval/eval-instance-method-invocation ctx bindings instance-expr method-expr args))
+               :cljs (ctx-fn
+                      (let [allowed? (identical? method-expr utils/allowed-append)]
+                        (fn [ctx bindings]
+                          (eval/eval-instance-method-invocation ctx bindings instance-expr method-name args allowed?)))
                              ;; this info is used by set!
                              {::instance-expr instance-expr
-                              ::method-expr method-expr}
+                              ::method-name method-name}
                              expr
                              (assoc (meta expr)
                                     :ns @vars/current-ns
@@ -872,7 +874,7 @@
                    (let [obj (analyze ctx obj)
                          v (analyze ctx v)
                          obj (types/info obj)
-                         k (subs (::method-expr obj) 1)
+                         k (subs (::method-name obj) 1)
                          obj (::instance-expr obj)]
                      (ctx-fn (fn [ctx bindings]
                                (let [obj (eval/eval ctx bindings obj)

src/sci/impl/evaluator.cljc

@@ -184,7 +184,7 @@
      (map #(symbol (.getName ^Class %)) (supers clazz))))
 
 (defn eval-instance-method-invocation
-  [ctx bindings instance-expr method-str args]
+  [ctx bindings instance-expr method-str args #?(:cljs allowed)]
   (let [instance-meta (meta instance-expr)
         tag-class (:tag-class instance-meta)
         instance-expr* (eval ctx bindings instance-expr)]
@@ -194,11 +194,13 @@
       (let [instance-class (or tag-class (#?(:clj class :cljs type) instance-expr*))
             class->opts (:class->opts ctx)
             allowed? (or
+                      #?(:cljs allowed)
                       (get class->opts :allow)
                       (let [instance-class-name #?(:clj (.getName ^Class instance-class)
                                                    :cljs (.-name instance-class))
                             instance-class-symbol (symbol instance-class-name)]
-                        (get class->opts instance-class-symbol)))
+                        (get class->opts instance-class-symbol))
+                      #?(:cljs (.log js/console (str method-str))))
             ^Class target-class (if allowed? instance-class
                                     (when-let [f (:public-class ctx)]
                                       (f instance-expr*)))]

src/sci/impl/io.cljc

@@ -5,6 +5,7 @@
                             printf #?@(:cljs [string-print])])
   (:require #?(:cljs [goog.string])
             [sci.impl.unrestrict :refer [*unrestricted*]]
+            #?(:cljs [sci.impl.utils :as utils])
             [sci.impl.vars :as vars]))
 
 #?(:clj (set! *warn-on-reflection* true))
@@ -26,6 +27,15 @@
            (doto (core-dynamic-var '*err*)
              (vars/unbind))))
 
+#?(:cljs
+   (def print-fn
+     (binding [*unrestricted* true]
+       (doto (core-dynamic-var '*print-fn*)
+         (vars/unbind)))))
+
+;; TODO: CLJS print-err-fn
+;; TODO: CLJS print-fn-bodies
+
 (def print-meta
   (core-dynamic-var '*print-meta* false))
 
@@ -34,6 +44,11 @@
 (def print-namespace-maps (core-dynamic-var '*print-namespace-maps* true))
 (def flush-on-newline (core-dynamic-var '*flush-on-newline* *flush-on-newline*))
 (def print-readably (core-dynamic-var '*print-readably* *print-readably*))
+#?(:cljs (def print-newline (core-dynamic-var '*print-newline* *print-newline*)))
+
+#?(:cljs (defn string-print [x]
+           (binding [*print-fn* @print-fn]
+             (cljs.core/string-print x))) )
 
 #?(:clj (defn pr-on
           {:private true
@@ -61,13 +76,14 @@
              (apply pr more))))
    :cljs (defn pr
            [& objs]
-           (binding [*print-length* @print-length
+           (binding [*print-fn* @print-fn
+                     *print-length* @print-length
                      *print-level* @print-level
                      *print-meta* @print-meta
                      *print-namespace-maps* @print-namespace-maps
-                     *print-readably* @print-readably]
-             (.append @out (apply cljs.core/pr-str objs))
-             nil)))
+                     *print-readably* @print-readably
+                     *print-newline* @print-newline]
+             (apply cljs.core/pr objs))))
 
 #?(:clj
    (defn flush
@@ -85,7 +101,8 @@
           nil)
    :cljs (defn newline
            []
-           (println)))
+           (binding [*print-fn* @print-fn]
+             (cljs.core/newline))))
 
 #?(:clj
    (defn pr-str
@@ -103,7 +120,8 @@
                *print-level* @print-level
                *print-meta* @print-meta
                *print-namespace-maps* @print-namespace-maps
-               *print-readably* @print-readably]
+               *print-readably* @print-readably
+               *print-newline* @print-newline]
        (apply cljs.core/pr-str objs))))
 
 #?(:clj
@@ -116,13 +134,14 @@
    :cljs
    (defn prn
      [& objs]
-     (binding [*print-length* @print-length
+     (binding [*print-fn* @print-fn
+               *print-length* @print-length
                *print-level* @print-level
                *print-meta* @print-meta
                *print-namespace-maps* @print-namespace-maps
-               *print-readably* @print-readably]
-       (.append @out (apply cljs.core/prn-str objs))
-       nil)))
+               *print-readably* @print-readably
+               *print-newline* @print-newline]
+       (apply cljs.core/prn objs))))
 
 #?(:clj
    (defn prn-str
@@ -140,7 +159,8 @@
                *print-level* @print-level
                *print-meta* @print-meta
                *print-namespace-maps* @print-namespace-maps
-               *print-readably* @print-readably]
+               *print-readably* @print-readably
+               *print-newline* @print-newline]
        (apply cljs.core/prn-str objs))))
 
 #?(:clj
@@ -151,12 +171,13 @@
    :cljs
    (defn print
      [& objs]
-     (binding [*print-length* @print-length
+     (binding [*print-fn* @print-fn
+               *print-length* @print-length
                *print-level* @print-level
                *print-namespace-maps* @print-namespace-maps
-               *print-readably* nil]
-       (.append @out (apply cljs.core/print-str objs))
-       nil)))
+               *print-readably* nil
+               *print-newline* @print-newline]
+       (apply cljs.core/print objs))))
 
 #?(:clj
    (defn print-str
@@ -174,7 +195,8 @@
                *print-level* @print-level
                *print-meta* @print-meta
                *print-namespace-maps* @print-namespace-maps
-               *print-readably* @print-readably]
+               *print-readably* @print-readably
+               *print-newline* @print-newline]
        (apply cljs.core/print-str objs))))
 
 #?(:clj
@@ -185,13 +207,14 @@
    :cljs
    (defn println
      [& objs]
-     (binding [*print-length* @print-length
+     (binding [*print-fn* @print-fn
+               *print-length* @print-length
                *print-level* @print-level
                *print-meta* @print-meta
                *print-namespace-maps* @print-namespace-maps
-               *print-readably* @print-readably]
-       (.append @out (apply println-str objs))
-       nil)))
+               *print-readably* @print-readably
+               *print-newline* @print-newline]
+       (apply cljs.core/println objs))))
 
 #?(:clj
    (defn printf
@@ -201,10 +224,17 @@
 (defn with-out-str
   [_ _ & body]
   `(let [s# (new #?(:clj java.io.StringWriter
-                    :cljs goog.string.StringBuffer))]
-     (binding [*out* s#]
-       ~@body
-       (str s#))))
+                   :cljs goog.string.StringBuffer))]
+     #?(:clj
+        (binding [*out* s#]
+          ~@body
+          (str s#))
+        :cljs
+        (binding [*print-newline* true
+                  *print-fn* (fn [x#]
+                               (. s# ~utils/allowed-append x#))]
+          ~@body
+          (str s#)))))
 
 #?(:clj
    (defn with-in-str

src/sci/impl/namespaces.cljc

@@ -777,11 +777,13 @@
    '*err* io/err
    '*file* vars/current-file
    '*flush-on-newline* io/flush-on-newline
+   #?@(:cljs ['*print-fn* io/print-fn])
    '*print-length* io/print-length
    '*print-level* io/print-level
    '*print-meta* io/print-meta
    '*print-namespace-maps* io/print-namespace-maps
    '*print-readably* io/print-readably
+   #?@(:cljs ['*print-newline* io/print-newline])
    'newline (copy-core-var io/newline)
    'flush (copy-core-var io/flush)
    'pr (copy-core-var io/pr)

src/sci/impl/utils.cljc

@@ -33,6 +33,10 @@
 
 (def needs-ctx (symbol "needs-ctx"))
 
+#?(:cljs
+   (def allowed-append "used for allowing interop in with-out-str"
+     (symbol "append")))
+
 (defn rethrow-with-location-of-node
   ([ctx ^Throwable e raw-node] (rethrow-with-location-of-node ctx (:bindings ctx) e raw-node))
   ([ctx bindings ^Throwable e raw-node]