Skip to content

Commit

Permalink
[#378] Prefer metadata override over extend-protocol (#623)
Browse files Browse the repository at this point in the history
  • Loading branch information
@borkdude
borkdude authored Oct 1, 2021
1 parent b58c8c4 commit 8f5d84b
Show file tree
Hide file tree
Showing 2 changed files with 42 additions and 35 deletions.
47 changes: 24 additions & 23 deletions src/sci/impl/protocols.cljc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -19,19 +19,22 @@
[nil signatures]))
current-ns (str (vars/current-ns-name))
fq-name (symbol current-ns (str protocol-name))
extend-meta (:extend-via-metadata opts)
expansion
`(do
(def ~(with-meta protocol-name
{:doc docstring}) {:methods #{}
:name '~fq-name
:ns *ns*})
{:doc docstring}) (cond->
{:methods #{}
:name '~fq-name
:ns *ns*}
~extend-meta (assoc :extend-via-metadata true)))
~@(map (fn [[method-name & _]]
(let [fq-name (symbol (str current-ns) (str method-name))
impls [`(defmulti ~method-name clojure.core/protocol-type-impl)
`(defmethod ~method-name :sci.impl.protocols/reified [x# & args#]
(let [methods# (clojure.core/-reified-methods x#)]
(apply (get methods# '~method-name) x# args#)))]
impls (if (:extend-via-metadata opts)
impls (if extend-meta
(conj impls
`(defmethod ~method-name :default [x# & args#]
(let [meta# (meta x#)
Expand All @@ -57,42 +60,40 @@
(defn extend-protocol [_ _ ctx protocol-name & impls]
(let [impls (utils/split-when #(not (seq? %)) impls)
protocol-var (@utils/eval-resolve-state ctx (:bindingx ctx) protocol-name)
protocol-ns (-> protocol-var deref :ns)
protocol-data (deref protocol-var)
extend-via-metadata (:extend-via-metadata protocol-data)
protocol-ns (:ns protocol-data)
pns (str (vars/getName protocol-ns))
fq-meth-name #(symbol pns %)
expansion
`(do ~@(map (fn [[type & meths]]
`(do
~@(map (fn [meth]
`(defmethod ~(fq-meth-name (name (first meth)))
~type
~(second meth) ~@(nnext meth)))
~@(map (fn [[meth-name args & body]]
(let [fq (fq-meth-name (name meth-name))]
`(defmethod ~fq
~type
~args ~(if extend-via-metadata
`(let [farg# ~(first args)]
(if-let [m# (meta farg#)]
(if-let [meth# (get m# '~fq)]
(apply meth# ~args)
(do ~@body))
(do ~@body)))
`(do ~@body)))))
meths)))
impls))]
#_(prn expansion)
expansion))

(defn extend [ctx atype & proto+mmaps]
(doseq [[proto mmap] (partition 2 proto+mmaps)
:let [proto-ns (:ns proto)
pns (vars/getName proto-ns)]]
#_(when-not (protocol? proto)
(throw (new #?(:clj IllegalArgumentException
:cljs js/Error)
(str proto " is not a protocol"))))
#_(when (implements? proto atype)
(throw (new #?(:clj IllegalArgumentException
:cljs js/Error)
(str atype " already directly implements " (:on-interface proto) " for protocol:"
(:var proto)))))
(doseq [[fn-name f] mmap]
(let [fn-sym (symbol (name fn-name))
env @(:env ctx)
multi-method-var (get-in env [:namespaces pns fn-sym])
multi-method @multi-method-var]
(mms/multi-fn-add-method-impl multi-method atype f))
)
#_(-reset-methods (vars/alter-var-root (:var proto) assoc-in [:impls atype] mmap))))
(mms/multi-fn-add-method-impl multi-method atype f)))))

(defn extend-type [_ _ ctx atype & proto+meths]
(let [proto+meths (utils/split-when #(not (seq? %)) proto+meths)]
Expand Down Expand Up @@ -121,7 +122,7 @@
;; in CLJS we currently don't support mixing "classes" and protocols,
;; hence, the instance is always a Reified, thus we can avoid calling
;; the slower satisfies?
:cljs (instance? sci.impl.types.Reified obj))
:cljs (instance? sci.impl.types/Reified obj))
(contains? (types/getProtocols obj) protocol)
;; can be record that is implementing this protocol
;; or a type like String, etc. that implements a protocol via extend-type, etc.
Expand Down
30 changes: 18 additions & 12 deletions test/sci/protocols_test.cljc
View file
Original file line number Diff line number Diff line change
@@ -1,5 +1,6 @@
(ns sci.protocols-test
(:require #?(:cljs [clojure.string :as str])
[clojure.string :as str]
[clojure.test :refer [deftest is testing]]
[sci.test-utils :as tu]))

Expand Down Expand Up @@ -68,6 +69,14 @@
'js #js {:String js/String
:Number js/Number}}}))))))


(defn eval* [prog]
(tu/eval* #?(:clj prog
:cljs (str/replace prog "Object" ":default"))
#?(:clj {}
:cljs {:classes {:allow :all
'js #js {:String js/String}}})))

(deftest docstring-test
(is (= "-------------------------\nuser/Foo\n cool protocol\n" (tu/eval* "
(defprotocol Foo \"cool protocol\" (foo [_]))
Expand All @@ -89,9 +98,7 @@
prog #?(:clj prog
:cljs (-> prog
(str/replace "String" "js/String")))]
(is (true? (tu/eval* prog #?(:clj {}
:cljs {:classes {:allow :all
'js #js {:String js/String}}})))))
(is (true? (eval* prog))))
(testing "Aliases are allowed and ignored"
(let [prog "
(ns foo) (defprotocol Foo (foo [this]))
Expand All @@ -106,9 +113,7 @@
prog #?(:clj prog
:cljs (-> prog
(str/replace "String" "js/String")))]
(is (true? (tu/eval* prog #?(:clj {}
:cljs {:classes {:allow :all
'js #js {:String js/String}}})))))
(is (true? (eval* prog))))
(let [prog "
(ns foo) (defprotocol Foo (foo [this]))
(ns bar (:require [foo :as f]))
Expand All @@ -122,9 +127,7 @@
prog #?(:clj prog
:cljs (-> prog
(str/replace "String" "js/String")))]
(is (true? (tu/eval* prog #?(:clj {}
:cljs {:classes {:allow :all
'js #js {:String js/String}}})))))))
(is (true? (eval* prog))))))

(deftest extend-via-metadata-test
(let [prog "
Expand Down Expand Up @@ -156,9 +159,7 @@
prog #?(:clj prog
:cljs (-> prog
(str/replace "String" "js/String")))]
(is (= [100 95 3 1] (tu/eval* prog #?(:clj {}
:cljs {:classes {:allow :all
'js #js {:String js/String}}}))))))
(is (= [100 95 3 1] (eval* prog)))))

#?(:clj
(deftest import-test
Expand All @@ -179,3 +180,8 @@
[(satisfies? Foo (reify Foo))
(satisfies? Bar (reify Foo))]
"] (is (= [true false] (tu/eval* prog {}))))))

(deftest order-test
(testing "extend-via-metadata overrides extend-protocol, only if option given"
(is (= :object (eval* "(defprotocol Foo (foo [this])) (extend-protocol Foo Object (foo [this] :object)) (foo (vary-meta {} assoc `foo (fn [_] :meta)))")))
(is (= :meta (eval* "(defprotocol Foo :extend-via-metadata true (foo [this])) (extend-protocol Foo Object (foo [this] :object)) (foo (vary-meta {} assoc `foo (fn [_] :meta)))")))))

0 comments on commit 8f5d84b

Please sign in to comment.