Skip to content

Commit

Permalink
Fix #794: Limited support for IPrintWithWriter in CLJS on custom types (
Browse files Browse the repository at this point in the history 
#798)
  • Loading branch information
@borkdude
borkdude authored Sep 9, 2022
1 parent 57fcb5a commit aa460c3
Show file tree
Hide file tree
Showing 8 changed files with 103 additions and 69 deletions.
2 changes: 0 additions & 2 deletions src/sci/impl/core_protocols.cljc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,10 +4,8 @@
(:require
[sci.impl.types :as types]
[sci.impl.utils :as utils]
[sci.impl.vars :as vars]
[sci.lang :as lang]))


;;;; IDeref

(defmulti #?(:clj deref :cljs -deref) types/type-impl)
Expand Down
109 changes: 61 additions & 48 deletions src/sci/impl/deftype.cljc
View file
Original file line number Diff line number Diff line change
@@ -1,11 +1,11 @@
(ns sci.impl.deftype
{:no-doc true}
(:refer-clojure :exclude [deftype])
(:require [clojure.string :as str]
[sci.impl.types :as types]
[sci.impl.utils :as utils]
[sci.impl.vars :as vars]
[sci.lang]))
(:require
[sci.impl.types :as types]
[sci.impl.utils :as utils]
[sci.impl.vars :as vars]
[sci.lang]))

#?(:clj (set! *warn-on-reflection* true))

Expand Down Expand Up @@ -50,14 +50,22 @@
(-mutate [_ k v]
(set! ext-map (assoc ext-map k v)))

SciPrintMethod
(-sci-print-method [this w]
(if-let [rv var]
(let [m (meta @rv)]
(if-let [pm (:sci.impl/print-method m)]
(pm this w)
(.write ^java.io.Writer w ^String (clojure-str this))))
(.write ^java.io.Writer w ^String (clojure-str this))))
#?@(:clj [SciPrintMethod
(-sci-print-method [this w]
(if-let [rv var]
(let [m (meta rv)]
(if-let [pm (:sci.impl/print-method m)]
(pm this w)
(.write ^java.io.Writer w ^String (clojure-str this))))
(.write ^java.io.Writer w ^String (clojure-str this))))]
:cljs [IPrintWithWriter
(-pr-writer [this w opts]
(if-let [rv var]
(let [m (meta rv)]
(if-let [pm (:sci.impl/print-method m)]
(pm this w opts)
(write-all w (clojure-str this))))
(write-all w (clojure-str this))))])

types/IBox
(getVal [_] ext-map))
Expand Down Expand Up @@ -85,7 +93,9 @@
;; _ (prn :protocol protocol)
#?@(:cljs [protocol (or protocol
(when (= 'Object protocol-name)
::object))])
::object)
(when (= 'IPrintWithWriter protocol-name)
::IPrintWithWriter))])
_ (when-not protocol
(utils/throw-error-with-location
(str "Protocol not found: " protocol-name)
Expand All @@ -104,40 +114,43 @@
(symbol pns (str %))
%)]
(map (fn [[method-name bodies]]
(let [bodies (map rest bodies)
bodies (mapv (fn [impl]
(let [args (first impl)
body (rest impl)
destr (utils/maybe-destructured args body)
args (:params destr)
body (:body destr)
orig-this-sym (first args)
rest-args (rest args)
;; shadows-this? (some #(= orig-this-sym %) rest-args)
this-sym (if true #_shadows-this?
'__sci_this
orig-this-sym)
args (vec (cons this-sym rest-args))
ext-map-binding (gensym)
bindings [ext-map-binding (list 'sci.impl.deftype/-inner-impl this-sym)]
bindings (concat bindings
(mapcat (fn [field]
[field (list 'get ext-map-binding (list 'quote field))])
(reduce disj field-set args)))
bindings (concat bindings [orig-this-sym this-sym])
bindings (vec bindings)]
;; (prn :bindings bindings)
`(~args
(let ~bindings
~@body)))) bodies)]
(@utils/analyze (assoc ctx
:deftype-fields field-set
:local->mutator (zipmap field-set
(map (fn [field]
(fn [this v]
(types/-mutate this field v)))
field-set)))
`(defmethod ~(fq-meth-name method-name) ~rec-type ~@bodies))))
(if (= '-pr-writer method-name)
`(alter-meta! (var ~record-name)
assoc :sci.impl/print-method (fn ~(rest (first bodies))))
(let [bodies (map rest bodies)
bodies (mapv (fn [impl]
(let [args (first impl)
body (rest impl)
destr (utils/maybe-destructured args body)
args (:params destr)
body (:body destr)
orig-this-sym (first args)
rest-args (rest args)
;; shadows-this? (some #(= orig-this-sym %) rest-args)
this-sym (if true #_shadows-this?
'__sci_this
orig-this-sym)
args (vec (cons this-sym rest-args))
ext-map-binding (gensym)
bindings [ext-map-binding (list 'sci.impl.deftype/-inner-impl this-sym)]
bindings (concat bindings
(mapcat (fn [field]
[field (list 'get ext-map-binding (list 'quote field))])
(reduce disj field-set args)))
bindings (concat bindings [orig-this-sym this-sym])
bindings (vec bindings)]
;; (prn :bindings bindings)
`(~args
(let ~bindings
~@body)))) bodies)]
(@utils/analyze (assoc ctx
:deftype-fields field-set
:local->mutator (zipmap field-set
(map (fn [field]
(fn [this v]
(types/-mutate this field v)))
field-set)))
`(defmethod ~(fq-meth-name method-name) ~rec-type ~@bodies)))))
impls)))
protocol-impls
raw-protocol-impls)]
Expand Down
4 changes: 2 additions & 2 deletions src/sci/impl/multimethods.cljc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -120,9 +120,9 @@
(do
(cond
(= (resolve 'clojure.pprint/simple-dispatch) mf#)
(sci.impl.records/-reg-key! @(:sci.impl/var m#) :sci.impl/pprint-simple-dispatch (fn ~@fn-tail))
(alter-meta! (:sci.impl/var m#) assoc :sci.impl/pprint-simple-dispatch (fn ~@fn-tail))
(= (resolve 'clojure.core/print-method) mf#)
(sci.impl.records/-reg-key! @(:sci.impl/var m#) :sci.impl/print-method (fn ~@fn-tail))
(alter-meta! (:sci.impl/var m#) assoc :sci.impl/print-method (fn ~@fn-tail))
:else (clojure.core/multi-fn-add-method-impl ~multifn ~dispatch-val (fn ~@fn-tail))))
(clojure.core/multi-fn-add-method-impl ~multifn ~dispatch-val (fn ~@fn-tail))))
`(clojure.core/multi-fn-add-method-impl ~multifn ~dispatch-val (fn ~@fn-tail))))
Expand Down
8 changes: 5 additions & 3 deletions src/sci/impl/namespaces.cljc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -806,7 +806,7 @@
(defn -create-type [data]
(new sci.lang.Type data nil nil))

(defn -reg-key! [rec-type k v]
#_(defn -reg-key! [rec-type k v]
(when (instance? sci.lang.Type rec-type)
(types/setVal rec-type (assoc (types/getVal rec-type) k v))
rec-type))
Expand All @@ -817,7 +817,7 @@
'toString sci.impl.records/to-string
'-create-record-type -create-type
;; what do we use this for again?
'-reg-key! -reg-key!
;; '-reg-key! -reg-key!
'->record-impl sci.impl.records/->record-impl})


Expand Down Expand Up @@ -1537,7 +1537,9 @@
'ratio? (copy-core-var ratio?)
'rationalize (copy-core-var rationalize)
'seque (copy-core-var seque)
'xml-seq (copy-core-var xml-seq)])})
'xml-seq (copy-core-var xml-seq)])

#?@(:cljs ['-write (copy-var -write clojure-core-ns)])})

(defn dir-fn
[ctx ns]
Expand Down
21 changes: 15 additions & 6 deletions src/sci/impl/protocols.cljc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -203,9 +203,12 @@
(str t))

(defn extend-protocol [form _ ctx protocol-name & impls]
(let [impls (utils/split-when #(not (seq? %)) impls)
(let [print-writer? (= 'IPrintWithWriter protocol-name)
impls (utils/split-when #(not (seq? %)) impls)
protocol-var
(or (@utils/eval-resolve-state ctx (:bindingx ctx) protocol-name)
(when print-writer?
(atom {:ns (sci.lang.Namespace. "dude" {})}))
(utils/throw-error-with-location (str "Protocol not found: " protocol-name) form))
protocol-data (deref protocol-var)
extend-via-metadata (:extend-via-metadata protocol-data)
Expand All @@ -216,11 +219,17 @@
~@(map (fn [[type & meths]]
(let [type #?(:clj type
:cljs (get cljs-type-symbols type type))]
`(do
(clojure.core/alter-var-root
(var ~protocol-name) update :satisfies (fnil conj #{})
(type->str ~type))
~@(process-methods ctx type meths pns extend-via-metadata))))
(if print-writer?
(let [expansion `(do
(clojure.core/alter-meta!
(var ~type) assoc :sci.impl/print-method (fn ~@(rest (first meths))))
)]
expansion)
`(do
(clojure.core/alter-var-root
(var ~protocol-name) update :satisfies (fnil conj #{})
(type->str ~type))
~@(process-methods ctx type meths pns extend-via-metadata)))))
impls))]
expansion))

Expand Down
11 changes: 8 additions & 3 deletions src/sci/impl/records.cljc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -140,7 +140,7 @@
SciPrintMethod
(-sci-print-method [this w]
(if-let [rv var]
(let [m (meta @rv)]
(let [m (meta rv)]
(if-let [pm (:sci.impl/print-method m)]
(pm this w)
(.write ^java.io.Writer w ^String (clojure-str this))))
Expand Down Expand Up @@ -222,8 +222,13 @@

IPrintWithWriter
;; see https://www.mail-archive.com/[email protected]/msg99560.html
(-pr-writer [new-obj writer _]
(write-all writer (clojure-str new-obj)))
(-pr-writer [this w opts]
(if-let [rv var]
(let [m (meta rv)]
(if-let [pm (:sci.impl/print-method m)]
(pm this w opts)
(write-all w (clojure-str this))))
(write-all w (clojure-str this))))

IKVReduce
(-kv-reduce [this f init]
Expand Down
12 changes: 7 additions & 5 deletions src/sci/pprint.cljc
View file
Original file line number Diff line number Diff line change
@@ -1,13 +1,15 @@
(ns sci.pprint
"Require this namespace if you want to extend pretty-printing to
records created with SCI."
(:require [clojure.pprint :as pprint]
[sci.impl.records]
[sci.impl.types :as types]
[sci.lang]))
(:require
[clojure.pprint :as pprint]
[sci.impl.records]
[sci.lang]))

#?(:clj (set! *warn-on-reflection* true))

(defmethod pprint/simple-dispatch sci.impl.records.SciRecord [obj]
(if-let [rv (types/type-impl obj)]
(if-let [rv (.-var ^sci.impl.records.SciRecord obj)]
(let [m (meta rv)]
(if-let [pm (:sci.impl/pprint-simple-dispatch m)]
(pm obj)
Expand Down
5 changes: 5 additions & 0 deletions test/sci/records_test.cljc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -175,6 +175,11 @@
(let [prog "(ns foo) (defrecord A [x y z]) (defmethod print-method A [x writer] (.write writer \"<A>\")) (pr-str [(->A 1)])"]
(is (= "[<A>]" (tu/eval* prog {}))))))

#?(:cljs
(deftest IPrintWithWriter-test
(is (= "dude" (sci/eval-string "(defrecord Foo [x]) (extend-protocol IPrintWithWriter Foo (-pr-writer [o w opts] (-write w \"dude\"))) (pr-str (->Foo))")))
(is (= "dude" (sci/eval-string "(deftype Foo [] IPrintWithWriter (-pr-writer [_ w opts] (-write w \"dude\"))) (pr-str (->Foo))")))))

(deftest deftype-test
(is (= 1 (tu/eval* "(defprotocol GetX (getX [_])) (deftype Foo [x y] GetX (getX [_] x)) (getX (->Foo 1)) " {})))
(let [prog "(deftype Foo [a b]) (let [x (->Foo :a :b)] [(.-a x) (.-b x)])"]
Expand Down

0 comments on commit aa460c3

Please sign in to comment.