From 217379abdc837b04511c80373ddd66eca128c856 Mon Sep 17 00:00:00 2001
From: Michiel Borkent <michielborkent@gmail.com>
Date: Tue, 9 Jun 2020 22:56:16 +0200
Subject: [PATCH] [#279, #319] defprotocol and defrecord

---
 reflection.json              |   6 ++
 src/sci/impl/namespaces.cljc |  27 ++++++++-
 src/sci/impl/opts.cljc       |   2 +
 src/sci/impl/protocols.cljc  | 114 +++++++++++++++++++++++++++++++++++
 src/sci/impl/records.cljc    |  36 +++++++++++
 src/sci/impl/utils.cljc      |  11 ++++
 test/sci/protocols_test.cljc |  94 +++++++++++++++++++++++++++++
 test/sci/records_test.cljc   |  39 ++++++++++++
 8 files changed, 328 insertions(+), 1 deletion(-)
 create mode 100644 src/sci/impl/protocols.cljc
 create mode 100644 src/sci/impl/records.cljc
 create mode 100644 test/sci/protocols_test.cljc
 create mode 100644 test/sci/records_test.cljc

diff --git a/reflection.json b/reflection.json
index 67bd306d..cdbdcbc9 100644
--- a/reflection.json
+++ b/reflection.json
@@ -65,5 +65,11 @@
     "allPublicMethods":true,
     "allPublicFields": true,
     "allPublicConstructors": true
+  },
+  {
+    "name":"java.lang.Number",
+    "allPublicMethods":true,
+    "allPublicFields": true,
+    "allPublicConstructors": true
   }
 ]
diff --git a/src/sci/impl/namespaces.cljc b/src/sci/impl/namespaces.cljc
index 03019245..a9f63b8f 100644
--- a/src/sci/impl/namespaces.cljc
+++ b/src/sci/impl/namespaces.cljc
@@ -16,6 +16,8 @@
    [sci.impl.macros :as macros]
    [sci.impl.multimethods :as mm]
    [sci.impl.parser :as parser]
+   [sci.impl.protocols :as protocols]
+   [sci.impl.records :as records]
    [sci.impl.utils :as utils]
    [sci.impl.vars :as vars])
   #?(:cljs (:require-macros [sci.impl.namespaces :refer [copy-var copy-core-var]])))
@@ -572,6 +574,27 @@
    'remove-method (copy-core-var remove-method)
    'remove-all-methods (copy-core-var remove-all-methods)
    ;; end multimethods
+   ;; protocols
+   'defprotocol (with-meta protocols/defprotocol
+                  {:sci/macro true
+                   :sci.impl/op :needs-ctx})
+   'extend (with-meta protocols/extend
+             {:sci.impl/op :needs-ctx})
+   'extends? protocols/extends?
+   'extend-type (with-meta protocols/extend-type
+                  {:sci/macro true
+                   :sci.impl/op :needs-ctx})
+   'extend-protocol (with-meta protocols/extend-protocol
+                      {:sci/macro true
+                       :sci.impl/op :needs-ctx})
+   '-reified-methods #(protocols/getMethods %)
+   '-reified protocols/->Reified
+   'reify (with-meta protocols/reify
+            {:sci/macro true
+             :sci.impl/op :needs-ctx})
+   'protocol-type-impl protocols/type-impl
+   'satisfies? protocols/satisfies?
+   ;; end protocols
    '.. (macrofy double-dot)
    '= (copy-core-var =)
    '< (copy-core-var <)
@@ -658,6 +681,9 @@
    'dedupe (copy-core-var dedupe)
    'defn- (macrofy defn-*)
    'defonce (macrofy defonce*)
+   'defrecord (with-meta records/defrecord
+                {:sci/macro true
+                 :sci.impl/op :needs-ctx})
    'delay (macrofy delay*)
    #?@(:clj ['deliver (copy-core-var deliver)])
    'deref (copy-core-var deref)
@@ -858,7 +884,6 @@
    'repeat (copy-core-var repeat)
    'requiring-resolve (with-meta sci-requiring-resolve {:sci.impl/op :needs-ctx})
    'run! (copy-core-var run!)
-   #?@(:clj ['satisfies? (copy-core-var satisfies?)])
    'set? (copy-core-var set?)
    'sequential? (copy-core-var sequential?)
    'select-keys (copy-core-var select-keys)
diff --git a/src/sci/impl/opts.cljc b/src/sci/impl/opts.cljc
index 91b5ae16..c6dc72dc 100644
--- a/src/sci/impl/opts.cljc
+++ b/src/sci/impl/opts.cljc
@@ -44,6 +44,7 @@
            'java.io.StringWriter java.io.StringWriter
            'java.io.StringReader java.io.StringReader
            'java.lang.Integer Integer
+           'java.lang.Number Number
            'java.lang.Double Double
            'java.lang.ArithmeticException ArithmeticException
            'java.lang.Object Object}
@@ -62,6 +63,7 @@
             String java.lang.String
             ArithmeticException java.lang.ArithmeticException
             Integer java.lang.Integer
+            Number java.lang.Number
             Double java.lang.Double
             Object java.lang.Object}
      :cljs {}))
diff --git a/src/sci/impl/protocols.cljc b/src/sci/impl/protocols.cljc
new file mode 100644
index 00000000..87ae0c58
--- /dev/null
+++ b/src/sci/impl/protocols.cljc
@@ -0,0 +1,114 @@
+(ns sci.impl.protocols
+  {:no-doc true}
+  (:refer-clojure :exclude [defprotocol extend-protocol
+                            extend extend-type reify satisfies?
+                            extends? implements?])
+  (:require [sci.impl.multimethods :as mms]
+            [sci.impl.utils :as utils]
+            [sci.impl.vars :as vars]))
+
+(clojure.core/defprotocol IReified
+  (getInterface [_])
+  (getMethods [_]))
+
+(deftype Reified [interface meths]
+  IReified
+  (getInterface [_] interface)
+  (getMethods [_] meths))
+
+(defn defprotocol [_ _ _ctx protocol-name & signatures]
+  (let [[docstring signatures]
+        (let [sig (first signatures)]
+          (if (string? sig) [sig (rest signatures)]
+              [nil signatures]))
+        expansion
+        `(do
+           (def  ~(with-meta protocol-name
+                    {:doc docstring}) {:methods #{}
+                                       :ns *ns*})
+           ~@(map (fn [[method-name & _]]
+                    `(do
+                       (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#)))
+                       #?(:clj (alter-var-root (var ~protocol-name)
+                                               update :methods conj ~method-name)
+                          :cljs (def ~protocol-name
+                                  (update ~protocol-name :methods conj ~method-name)))))
+                  signatures))]
+    ;; (prn expansion)
+    expansion))
+
+(defn extend-protocol [_ _ ctx protocol-name & impls]
+  (let [impls (utils/split-when #(not (seq? %)) impls)
+        protocol-var (@utils/eval-resolve-state ctx protocol-name)
+        protocol-ns (-> protocol-var deref :ns)
+        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 (str (first meth)))
+                                     ~type
+                                     ~(second meth) ~@(nnext meth)))
+                                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))))
+
+(defn extend-type [_ _ ctx type & proto+meths]
+  (let [proto+meths (utils/split-when #(not (seq? %)) proto+meths)]
+    `(do ~@(map (fn [[proto & meths]]
+                  (let [protocol-var (@utils/eval-resolve-state ctx proto)
+                        protocol-ns (-> protocol-var deref :ns)
+                        pns (str (vars/getName protocol-ns))
+                        fq-meth-name #(symbol pns %)]
+                    `(do
+                       ~@(map (fn [meth]
+                                `(defmethod ~(fq-meth-name (str (first meth)))
+                                   ~type ~(second meth) ~@(nnext meth)))
+                              meths)))) proto+meths))))
+
+(defn reify [_ _ _ctx interface & meths]
+  (let [meths (into {} (map (fn [meth]
+                              `['~(first meth) (fn ~(second meth) ~@(nnext meth))])
+                            meths))]
+    `(clojure.core/-reified ~interface ~meths)))
+
+(defn type-impl [x & _xs]
+  (or (when (instance? sci.impl.protocols.Reified x)
+        :sci.impl.protocols/reified)
+      (some-> x meta :sci.impl/type)
+      (type x)))
+
+(defn satisfies? [protocol obj]
+  (boolean (some #(get-method % (type-impl obj)) (:methods protocol))))
+
+(defn extends?
+  "Returns true if atype extends protocol"
+  [protocol atype]
+  (boolean (some #(get-method % atype) (:methods protocol))))
diff --git a/src/sci/impl/records.cljc b/src/sci/impl/records.cljc
new file mode 100644
index 00000000..0b30ac6e
--- /dev/null
+++ b/src/sci/impl/records.cljc
@@ -0,0 +1,36 @@
+(ns sci.impl.records
+  {:no-doc true}
+  (:refer-clojure :exclude [defrecord])
+  (:require [sci.impl.utils :as utils]
+            [sci.impl.vars :as vars]))
+
+(defn defrecord [_ _ ctx record-name fields & protocol-impls]
+  (let [factory-fn-sym (symbol (str "->" record-name))
+        constructor-sym (symbol (str record-name "."))
+        keys (mapv keyword fields)
+        protocol-impls (utils/split-when symbol? protocol-impls)
+        protocol-impls
+        (mapv (fn [[protocol-name impl]]
+                (let [protocol-var (@utils/eval-resolve-state ctx protocol-name)
+                      protocol-ns (-> protocol-var deref :ns)
+                      pns (str (vars/getName protocol-ns))
+                      fq-meth-name #(symbol pns %)
+                      args (second impl)
+                      this (first args)
+                      bindings (vec (mapcat (fn [field]
+                                              [field (list (keyword field) this)])
+                                            fields))]
+                  `(defmethod ~(fq-meth-name (str (first impl))) '~record-name ~(second impl)
+                     (let ~bindings
+                       ~@(nnext impl)))))
+              protocol-impls)]
+    `(do
+       ;; (prn '~record-name)
+       (def ~record-name '~record-name)
+       (defn ~factory-fn-sym [& args#]
+           (vary-meta (zipmap ~keys args#)
+                      assoc
+                      :sci.impl/record true
+                      :sci.impl/type '~record-name))
+       (def ~constructor-sym ~factory-fn-sym)
+         ~@protocol-impls)))
diff --git a/src/sci/impl/utils.cljc b/src/sci/impl/utils.cljc
index 034a9e39..96f5b0e2 100644
--- a/src/sci/impl/utils.cljc
+++ b/src/sci/impl/utils.cljc
@@ -157,3 +157,14 @@
 (def eval-require-state (volatile! nil))
 (def eval-use-state (volatile! nil))
 (def eval-resolve-state (volatile! nil))
+
+(defn split-when
+  "Like partition-by but splits collection only when `pred` returns
+  a truthy value. E.g. `(split-when odd? [1 2 3 4 5]) => ((1 2) (3 4) (5))`"
+  [pred coll]
+  (lazy-seq
+   (when-let [s (seq coll)]
+     (let [fst (first s)
+           f (complement pred)
+           run (cons fst (take-while #(f %) (next s)))]
+       (cons run (split-when pred (lazy-seq (drop (count run) s))))))))
diff --git a/test/sci/protocols_test.cljc b/test/sci/protocols_test.cljc
new file mode 100644
index 00000000..2726e599
--- /dev/null
+++ b/test/sci/protocols_test.cljc
@@ -0,0 +1,94 @@
+(ns sci.protocols-test
+  (:require #?(:cljs [clojure.string :as str])
+            [clojure.test :refer [deftest is]]
+            [sci.test-utils :as tu]))
+
+(deftest protocol-test
+  (let [prog "
+(ns foo)
+(defprotocol AbstractionA
+  (foo [obj])
+  (bar [obj]))
+
+(ns bar)
+(defprotocol AbstractionB
+  \"A cool protocol\"
+  (fooB [obj x]))
+
+(ns baz)
+(require '[foo :as f :refer [AbstractionA]]
+         '[bar :refer [AbstractionB fooB]])
+
+(extend Number AbstractionA
+  {:foo (fn [_] :number)
+   :bar (fn [_] :bar/number)})
+
+(extend-protocol AbstractionA
+  nil
+  (foo [s] (str \"foo-A!\"))
+  (bar [s] (str \"bar-A!\"))
+  String
+  (foo [s] (str \"foo-A-\" (.toUpperCase s)))
+  (bar [s] (str \"bar-A-\" (.toUpperCase s))))
+
+(extend-type Object
+  AbstractionA
+  (foo [_] :foo/object)
+  (bar [_] :bar/object)
+  AbstractionB
+  (fooB [_ x] x))
+
+[(f/foo nil)
+ (f/bar nil)
+ (f/foo \"Bar\")
+ (f/bar \"Bar\")
+ (f/foo 1)
+ (f/bar 1)
+ (f/foo {})
+ (f/bar {})
+ (fooB {} :fooB/object)
+ (satisfies? AbstractionA 1)]"
+        prog #?(:clj prog
+                :cljs (-> prog
+                          (str/replace "String" "js/String")
+                          (str/replace "Number" "js/Number")
+                          (str/replace "Object" ":default")))]
+    (is (= ["foo-A!"
+            "bar-A!"
+            "foo-A-BAR"
+            "bar-A-BAR"
+            :number
+            :bar/number
+            :foo/object
+            :bar/object
+            :fooB/object
+            true]
+           (tu/eval* prog #?(:clj {}
+                             :cljs {:classes {:allow :all
+                                              'js #js {:String js/String
+                                                       :Number js/Number}}}))))))
+
+(deftest docstring-test
+  (is (= "-------------------------\nuser/Foo\n  cool protocol\n" (tu/eval* "
+(defprotocol Foo \"cool protocol\" (foo [_]))
+(with-out-str (clojure.repl/doc Foo))
+" {}))))
+
+(deftest reify-test
+  (let [prog "
+(defprotocol Fruit (subtotal [item]))
+(def x (reify Fruit (subtotal [_] 1)))
+(subtotal x)"]
+    (is (= 1 (tu/eval* prog {})))))
+
+(deftest extends-test
+  (let [prog "
+(defprotocol Area (get-area [this]))
+(extend-type String Area (get-area [_] 0))
+(extends? Area String)"
+        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}}}))))))
diff --git a/test/sci/records_test.cljc b/test/sci/records_test.cljc
new file mode 100644
index 00000000..377aac66
--- /dev/null
+++ b/test/sci/records_test.cljc
@@ -0,0 +1,39 @@
+(ns sci.records-test
+  (:require [clojure.test :refer [deftest is testing]]
+            [sci.test-utils :as tu]))
+
+(deftest protocol-test
+  (let [prog "
+(defrecord Foo [a b])
+(let [r (->Foo 1 2)]
+  [(:a r) (:b r)])"]
+    (is (= [1 2] (tu/eval* prog {}))))
+  (testing "protocols"
+    (let [prog "
+(ns foo)
+(defprotocol Foo (foo [_] 42))
+(defprotocol Graph (graph [_]))
+
+(ns bar (:require [foo :as f]))
+(defrecord FooRecord [a b]
+  f/Foo (foo [_] (dec a)))
+
+(defrecord BarRecord [a b]
+  f/Foo (foo [_] (inc b)))
+
+(extend FooRecord
+  f/Graph {:graph (fn [x] {:from (:a x) :to (:b x)})})
+
+(let [a (->FooRecord 1 2) b (BarRecord. 1 2)]
+  [(f/foo a) (f/foo b) (f/graph a) (satisfies? f/Graph a)])"]
+      (is (= [0 3 {:from 1, :to 2} true] (tu/eval* prog {}))))))
+
+(deftest extends-test
+  (let [prog "
+(defprotocol Area (get-area [this]))
+(defrecord Rectangle [width height]
+                  Area
+                  (get-area [this]
+                    (* width height)))
+(extends? Area Rectangle)"]
+    (is (true? (tu/eval* prog {})))))