From a5808f2a979a38651c68f4e20ea46001bc849511 Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 12 Dec 2023 14:10:32 +0100 Subject: [PATCH 001/428] compiler test stub --- test/hyperfiddle/electric_compiler_test.clj | 28 +++++++++++++++++++++ 1 file changed, 28 insertions(+) create mode 100644 test/hyperfiddle/electric_compiler_test.clj diff --git a/test/hyperfiddle/electric_compiler_test.clj b/test/hyperfiddle/electric_compiler_test.clj new file mode 100644 index 000000000..accfbc37b --- /dev/null +++ b/test/hyperfiddle/electric_compiler_test.clj @@ -0,0 +1,28 @@ +(ns hyperfiddle.electric-compiler-test + (:require [hyperfiddle.rcf :as rcf :refer [tests]] + [hyperfiddle.electric.impl.lang-de :as lang] + [hyperfiddle.electric.impl.runtime-de :as r])) + +;; tests that turn electric code into clojure code +;; basically no IR, we emit clojure code directly + +;; (e/defn Foo [x] +;; (inc x)) ; hyperfiddle.electric-compiler-test/Foo:10:3 +;; (r/apply (r/static inc) (r/local 'x)) + +;; lang/source-map with same signature as lang/compile +;; it returns the same structure as r/defs +;; but instead of the definitions it contains the metadata +#_(defn r/apply [..] + (try (apply f args) + (catch Throwable e (find-source-map-info path)))) + +(tests + ;; (defn lang/compile [env form] + (lang/compile-client {} 1) + ;; r/defs takes & flows with an implicit context (managed in runtime, thread-local or such) + ;; context - path of the node you're constructing in the call stack + := `(r/defs (r/static 1)) + + + ) From 8cb22f303ba5e0fc7875cbafcf8d73ac27e75869 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Tue, 12 Dec 2023 14:44:28 +0100 Subject: [PATCH 002/428] update missionary --- deps.edn | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/deps.edn b/deps.edn index d668bfa16..294ffc814 100644 --- a/deps.edn +++ b/deps.edn @@ -4,7 +4,7 @@ :deps {com.cognitect/transit-clj {:mvn/version "1.0.329"} com.cognitect/transit-cljs {:mvn/version "0.8.269"} com.hyperfiddle/rcf {:mvn/version "20220926-202227"} - missionary/missionary {:mvn/version "b.31"} + missionary/missionary {:mvn/version "b.33"} org.clojure/clojure {:mvn/version "1.12.0-alpha4"} org.clojure/clojurescript {:mvn/version "1.11.60"} org.clojure/tools.analyzer.jvm {:mvn/version "1.2.2"} ;; used by Electric From 821a718865819956b881ddec14d8f8b437e6a834 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Tue, 12 Dec 2023 15:16:03 +0100 Subject: [PATCH 003/428] first compiler tests --- src/hyperfiddle/electric/impl/runtime_de.cljc | 120 ++++++++++++++++++ test/hyperfiddle/electric_compiler_test.clj | 112 +++++++++++++++- 2 files changed, 231 insertions(+), 1 deletion(-) create mode 100644 src/hyperfiddle/electric/impl/runtime_de.cljc diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc new file mode 100644 index 000000000..4007e1620 --- /dev/null +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -0,0 +1,120 @@ +(ns hyperfiddle.electric.impl.runtime-de + (:require [hyperfiddle.electric.impl.local :as l] + [hyperfiddle.incseq :as i] + [missionary.core :as m]) + #?(:clj (:import (clojure.lang IFn IDeref)))) + +(def peer-slot-step 0) +(def peer-slot-done 1) +(def peer-slot-defs 2) +(def peer-slot-tier 3) +(def peer-slot-input 4) +(def peer-slot-store 5) +(def peer-slots 6) + +(defmacro defs [& forms] + `(fn [i#] (case i# ~@(interleave (range) forms)))) + +(defn pure [form] + (i/fixed (m/cp form))) + +(defn static [form] + (pure form)) + +(defn error [^String msg] + #?(:clj (Error. msg) + :cljs (js/Error. msg))) + +(deftype Failer [done e] + IFn + (#?(:clj invoke :cljs -invoke) [_]) + IDeref + (#?(:clj deref :cljs -deref) [_] + (done) (throw e))) + +(deftype Unbound [k] + IFn + (#?(:clj invoke :cljs -invoke) [_ step done] + (step) (->Failer done (error (str "Unbound electric var lookup - " k))))) + +(def current (l/local)) + +(deftype Tier [parent env]) + +(defn lookup [k] + (let [^objects peer (l/get-local current)] + (loop [^Tier tier (aget peer peer-slot-tier)] + (case tier + nil (->Unbound k) + (if-some [s (get (.-env tier) k)] + s (recur (.-parent tier))))))) + +(defn resolve-node [^objects context tier id] + (let [prev (l/get-local current) + prev-tier (aget prev peer-slot-tier)] + (l/set-local current context) + (aset context peer-slot-tier tier) + (try ((aget context peer-slot-defs) id) + (finally + (aset context peer-slot-tier prev-tier) + (l/set-local current prev))))) + +(deftype NodePs [^objects peer k ps] + IFn + (#?(:clj invoke :cljs -invoke) [_] + (aset peer peer-slot-store + (dissoc (aget peer peer-slot-store) k)) + (ps)) + IDeref + (#?(:clj deref :cljs -deref) [_] @ps)) + +(deftype Node [^objects peer tier id] + IFn + (#?(:clj invoke :cljs -invoke) [_ step done] + ((let [k [tier id] + store (aget peer peer-slot-store)] + (if-some [s (get store k)] + s (let [n (resolve-node peer tier id) + s (m/signal i/combine (fn [step done] (->NodePs peer k (n step done))))] + (aset peer peer-slot-store (assoc store k s)) s))) step done))) + +(defn local [id] + (let [peer (l/get-local current) + tier (aget peer peer-slot-tier)] + (->Node peer tier id))) + +(defn remote [id]) + +(deftype Ctor [node env]) + +(defn ctor [id & args] + (let [peer (l/get-local current) + tier (aget peer peer-slot-tier)] + (pure (->Ctor (->Node peer tier id) {})))) + +(deftype Var [context k] + IFn + (#?(:clj invoke :cljs -invoke) [_ ^Ctor ctor incseq] + (->Ctor (.-node ctor) (assoc (.-env ctor) k incseq)))) + +(defn var [k] + (pure (->Var (l/get-local current) k))) + +(defn free [id] + ) + +(defn call [expr] + + ) + +(def ap + (partial i/latest-product + (fn + ([f] (f)) + ([f a] (f a)) + ([f a b] (f a b)) + ([f a b c] (f a b c)) + ([f a b c d] (f a b c d)) + ([f a b c d & e] (apply f a b c d e))))) + +(def join i/latest-concat) \ No newline at end of file diff --git a/test/hyperfiddle/electric_compiler_test.clj b/test/hyperfiddle/electric_compiler_test.clj index accfbc37b..fcdd40b9c 100644 --- a/test/hyperfiddle/electric_compiler_test.clj +++ b/test/hyperfiddle/electric_compiler_test.clj @@ -1,5 +1,6 @@ (ns hyperfiddle.electric-compiler-test - (:require [hyperfiddle.rcf :as rcf :refer [tests]] + (:require [hyperfiddle.electic :as-alias e] + [hyperfiddle.rcf :as rcf :refer [tests]] [hyperfiddle.electric.impl.lang-de :as lang] [hyperfiddle.electric.impl.runtime-de :as r])) @@ -24,5 +25,114 @@ ;; context - path of the node you're constructing in the call stack := `(r/defs (r/static 1)) + ;; transfer + (lang/compile-client {} + `(e/client "Hello world")) := + `(r/defs + (r/static "Hello world")) + (lang/compile-client {} + `(e/client + (let [x "Hello world" + y "Hello world"] + [x y]))) := + `(r/defs + (r/ap (r/static vector) (r/local 1) (r/local 2)) + (r/static "Hello world") + (r/static "Hello world")) + + (lang/compile-server {} + `(e/client "Hello world")) := + `(r/defs + (r/remote 0)) ;; 0 refers to client's r/defs + + ;; function application + (lang/compile-client {} + `(e/client (prn "Hello world"))) := + `(r/defs + (r/ap (r/static prn) (r/static "Hello world"))) + + ;; lexical scope + (lang/compile-client {} + `(e/client (let [a :foo] [a a]))) := + `(r/defs + (r/ap (r/static vector) (r/local 1) (r/local 1)) + (r/static :foo)) + + (lang/compile-client {} + `(e/client + (let [a (e/server :foo)] + (e/server (prn a))))) := + `(r/defs + (r/remote 0)) + (lang/compile-server {} + `(e/client + (let [a (e/server :foo)] + (e/server (prn a))))) := + `(r/defs + (r/ap (r/static prn) (r/local 1)) + (r/static :foo)) + + ;; join (e/watch !x) + ;; (i/fixed continuous-flow) -> incremental sequence of 1 element + (lang/compile-client {} + `(e/client (e/join (i/fixed (m/watch !x))))) := + `(r/defs + (r/join (r/ap (r/static i/fixed) (r/ap (r/static m/watch) (r/static !x))))) + + ;; pure (get the incseq of an expression) (e/pure (e/join x)) is (e/join (e/pure x)) is x + (lang/compile-client {} + `(e/client (e/pure :foo))) := + `(r/defs + (r/pure (r/static :foo))) + + ;; ctor (e/fn [] foo) -> (e/ctor foo) (previously ::c/closure) + (lang/compile-client {} + `(e/client (e/ctor :foo))) := + `(r/defs + (r/ctor 1) + (r/static :foo)) + + ;; call (aka new, but with no argument and only for ctors) + (lang/compile-client {} + `(e/client (e/call (e/ctor :foo)))) := + `(r/defs + (r/call (r/ctor 1)) + (r/static :foo)) + + ;; lexical closure + (lang/compile-client {} + `(e/client + (let [a :foo] + (e/call (e/ctor a))))) := + `(r/defs + (r/call (r/ctor 1 (r/local 2))) + (r/free 0) + (r/static :foo)) + + (lang/compile-client {} + `(e/client + (let [a :foo] + (e/call (e/ctor (e/ctor a)))))) := + `(r/defs + (r/call (r/ctor 1 (r/local 3))) + (r/ctor 2 (r/free 0)) + (r/free 0) + (r/static :foo)) + + ;; conditionals + (lang/compile-client {} + `(e/client (case :x nil :y :z))) := + `(r/defs + (r/call (r/ap (r/ap (r/static hash-map) + (r/static nil) (r/ctor 1)) + (r/static :x) (r/ctor 2))) + (r/static :y) + (r/static :z)) + + ;; var + (e/def x) + (lang/compile-client {} `(e/client (var x))) := + `(r/defs (r/var (quote x))) + ) From 956ef537592bb5b80870d7d5b359c27cc827abc2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Thu, 14 Dec 2023 08:41:48 +0100 Subject: [PATCH 004/428] another test - free --- test/hyperfiddle/electric_compiler_test.clj | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/test/hyperfiddle/electric_compiler_test.clj b/test/hyperfiddle/electric_compiler_test.clj index fcdd40b9c..dc9c9bac3 100644 --- a/test/hyperfiddle/electric_compiler_test.clj +++ b/test/hyperfiddle/electric_compiler_test.clj @@ -134,5 +134,17 @@ (lang/compile-client {} `(e/client (var x))) := `(r/defs (r/var (quote x))) + (lang/compile-client {} + `(let [a :foo, b :bar, c :baz] + [(e/ctor [a b]) (e/ctor [b c])])) := + `(r/defs + (r/ap (r/static vector) + (r/ctor 4 (r/local 1) (r/local 2)) + (r/ctor 5 (r/local 2) (r/local 3))) + (r/static :foo) + (r/static :bar) + (r/static :baz) + (r/ap (r/static vector) (r/free 0) (r/free 1)) + (r/ap (r/static vector) (r/free 0) (r/free 1))) ) From b1b60cf87cae074ce0f7dc003f749f4b7f1b9710 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Thu, 14 Dec 2023 08:44:39 +0100 Subject: [PATCH 005/428] fix build --- src/hyperfiddle/electric/impl/runtime_de.cljc | 122 ++++++++++++------ 1 file changed, 81 insertions(+), 41 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 4007e1620..fabf29acc 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -7,7 +7,6 @@ (def peer-slot-step 0) (def peer-slot-done 1) (def peer-slot-defs 2) -(def peer-slot-tier 3) (def peer-slot-input 4) (def peer-slot-store 5) (def peer-slots 6) @@ -37,27 +36,29 @@ (#?(:clj invoke :cljs -invoke) [_ step done] (step) (->Failer done (error (str "Unbound electric var lookup - " k))))) -(def current (l/local)) +(def this (l/local)) -(deftype Tier [parent env]) +(deftype Tier [parent ctor static dynamic]) +(deftype Ctor [peer id free vars]) + +(defn ctor [id & free] + (let [^Tier tier (l/get-local this) + ^Ctor ctor (.-ctor tier) + ^objects peer (.-peer ctor)] + (pure (->Ctor peer id (object-array free) {})))) + +(defn bind [^Ctor ctor peer k v] + (when-not (identical? peer (.-peer ctor)) + (throw (error "Can't bind foreign constructor."))) + (->Ctor peer (.-id ctor) (.-free ctor) + (assoc (.-vars ctor) k v))) (defn lookup [k] - (let [^objects peer (l/get-local current)] - (loop [^Tier tier (aget peer peer-slot-tier)] - (case tier - nil (->Unbound k) - (if-some [s (get (.-env tier) k)] - s (recur (.-parent tier))))))) - -(defn resolve-node [^objects context tier id] - (let [prev (l/get-local current) - prev-tier (aget prev peer-slot-tier)] - (l/set-local current context) - (aset context peer-slot-tier tier) - (try ((aget context peer-slot-defs) id) - (finally - (aset context peer-slot-tier prev-tier) - (l/set-local current prev))))) + (loop [^Tier tier (l/get-local this)] + (let [^Ctor ctor (.-ctor tier)] + (if-some [s (get (.-vars ctor) k)] + s (if-some [p (.-parent tier)] + (recur p) (->Unbound k)))))) (deftype NodePs [^objects peer k ps] IFn @@ -68,40 +69,47 @@ IDeref (#?(:clj deref :cljs -deref) [_] @ps)) -(deftype Node [^objects peer tier id] +(defn resolve-node [^objects peer tier id] + (let [k [tier id] + store (aget peer peer-slot-store)] + (if-some [s (get store k)] + s (let [n (let [that (l/get-local this)] + (l/set-local this tier) + (try ((aget peer peer-slot-defs) id) + (finally + (l/set-local this that)))) + s (m/signal i/combine (fn [step done] (->NodePs peer k (n step done))))] + (aset peer peer-slot-store (assoc store k s)) s)))) + +(deftype Node [peer tier id] IFn (#?(:clj invoke :cljs -invoke) [_ step done] - ((let [k [tier id] - store (aget peer peer-slot-store)] - (if-some [s (get store k)] - s (let [n (resolve-node peer tier id) - s (m/signal i/combine (fn [step done] (->NodePs peer k (n step done))))] - (aset peer peer-slot-store (assoc store k s)) s))) step done))) + ((resolve-node peer tier id) step done))) (defn local [id] - (let [peer (l/get-local current) - tier (aget peer peer-slot-tier)] + (let [^Tier tier (l/get-local this) + ^Ctor ctor (.-ctor tier) + ^objects peer (.-peer ctor)] (->Node peer tier id))) (defn remote [id]) -(deftype Ctor [node env]) - -(defn ctor [id & args] - (let [peer (l/get-local current) - tier (aget peer peer-slot-tier)] - (pure (->Ctor (->Node peer tier id) {})))) - -(deftype Var [context k] +(deftype Var [peer k] IFn - (#?(:clj invoke :cljs -invoke) [_ ^Ctor ctor incseq] - (->Ctor (.-node ctor) (assoc (.-env ctor) k incseq)))) + (#?(:clj invoke :cljs -invoke) [_ ctor v] + (bind ctor peer k v))) (defn var [k] - (pure (->Var (l/get-local current) k))) + (let [^Tier tier (l/get-local this) + ^Ctor ctor (.-ctor tier) + ^objects peer (.-peer ctor)] + (pure (->Var peer k)))) (defn free [id] - ) + (let [^Tier tier (l/get-local this) + ^Ctor ctor (.-ctor tier) + ^objects free (.-free ctor)] + (aget free id))) (defn call [expr] @@ -117,4 +125,36 @@ ([f a b c d] (f a b c d)) ([f a b c d & e] (apply f a b c d e))))) -(def join i/latest-concat) \ No newline at end of file +(def join i/latest-concat) + +(defn context-input-notify [^objects state done?] + + ) + +(deftype PeerPs [^objects state] + IFn + (#?(:clj invoke :cljs -invoke) [_] + + + ) + IDeref + (#?(:clj deref :cljs -deref) [_] + + + )) + +(defn peer [msgs defs] + (fn [step done] + (let [peer (object-array peer-slots)] + (aset peer peer-slot-step step) + (aset peer peer-slot-done done) + (aset peer peer-slot-defs defs) + (aset peer peer-slot-store {}) + (aset peer peer-slot-input + ((m/stream (m/observe msgs)) + #(context-input-notify peer false) + #(context-input-notify peer true))) + + (->Ctor peer 0 (object-array 0) {}) + + (->PeerPs peer)))) \ No newline at end of file From c3d3d2adeadd2dee24f1ac2b6107084d14dde7fa Mon Sep 17 00:00:00 2001 From: xificurC Date: Fri, 15 Dec 2023 21:19:19 +0100 Subject: [PATCH 006/428] port expander, cleanup --- deps.edn | 2 + src/hyperfiddle/electric/impl/compiler.clj | 211 ++++++++++++++++++ src/hyperfiddle/electric/impl/runtime_de.cljc | 32 ++- .../electric/impl/expand_de_test.cljc | 179 +++++++++++++++ 4 files changed, 423 insertions(+), 1 deletion(-) create mode 100644 src/hyperfiddle/electric/impl/compiler.clj create mode 100644 test/hyperfiddle/electric/impl/expand_de_test.cljc diff --git a/deps.edn b/deps.edn index 294ffc814..a35857d8b 100644 --- a/deps.edn +++ b/deps.edn @@ -5,6 +5,7 @@ com.cognitect/transit-cljs {:mvn/version "0.8.269"} com.hyperfiddle/rcf {:mvn/version "20220926-202227"} missionary/missionary {:mvn/version "b.33"} + dom-top/dom-top {:mvn/version "1.0.9"} org.clojure/clojure {:mvn/version "1.12.0-alpha4"} org.clojure/clojurescript {:mvn/version "1.11.60"} org.clojure/tools.analyzer.jvm {:mvn/version "1.2.2"} ;; used by Electric @@ -16,6 +17,7 @@ thheller/shadow-cljs {:mvn/version "2.22.10"} reagent/reagent {:mvn/version "1.1.1"} ; for reagent interop demo ch.qos.logback/logback-classic {:mvn/version "1.2.11"} ; logging implementation + lambdaisland/deep-diff2 {:mvn/version "2.10.211"} info.sunng/ring-jetty9-adapter {:mvn/version "0.14.3" ;; "0.14.3" (Jetty 9) is Java 8 compatible; ;; "0.17.7" (Jetty 10) is NOT Java 8 compatible diff --git a/src/hyperfiddle/electric/impl/compiler.clj b/src/hyperfiddle/electric/impl/compiler.clj new file mode 100644 index 000000000..e2a4fb4a3 --- /dev/null +++ b/src/hyperfiddle/electric/impl/compiler.clj @@ -0,0 +1,211 @@ +(ns hyperfiddle.electric.impl.compiler + (:require [cljs.analyzer :as cljs-ana] + [cljs.core] + [cljs.env] + [contrib.assert :as ca] + [contrib.debug] + [hyperfiddle.electric :as-alias e] + [hyperfiddle.electric.impl.runtime-de :as r] + [hyperfiddle.rcf :as rcf :refer [tests]])) + +(defn- fn-> [f a] (fn [o] (f o a))) + +(declare -expand-all-in-try) + +(defn resolve-cljs [env sym] + (when (not= '. sym) + (let [!found? (volatile! true) + resolved (binding [cljs-ana/*cljs-warnings* (assoc cljs-ana/*cljs-warnings* :undeclared-ns false)] + (cljs-ana/resolve-var env sym + (fn [env prefix suffix] + (cljs-ana/confirm-var-exists env prefix suffix + (fn [_ _ _] (vreset! !found? false)))) nil))] + (when (and resolved @!found? (not (:macro resolved))) + ;; If the symbol is unqualified and is from a different ns (through e.g. :refer) + ;; cljs returns only :name and :ns. We cannot tell if it resolved to a macro. + ;; We recurse with the fully qualified symbol to get all the information. + ;; The symbol can also resolve to a local in which case we're done. + ;; TODO how to trigger these in tests? + (if (and (simple-symbol? sym) (not= (:ns env) (:ns resolved)) (not= :local (:op resolved))) + (recur env (ca/check qualified-symbol? (:name resolved) {:sym sym, :resolved resolved})) + resolved))))) + +(defn serialized-require [sym] + ;; we might be expanding clj code before the ns got loaded (during cljs compilation) + ;; to correctly lookup vars the ns needs to be loaded + ;; since shadow-cljs compiles in parallel we need to serialize the requires + (when-not (get (loaded-libs) sym) + (try (#'clojure.core/serialized-require sym) ; try bc it can be cljs file + (catch java.io.FileNotFoundException _)))) + +(defn macroexpand-clj [o] (serialized-require (ns-name *ns*)) (macroexpand-1 o)) + +(defn expand-referred-or-local-macros [o cljs-macro-env] + ;; (:require [some.ns :refer [some-macro]]) + ;; `some-macro` might be a macro and cljs expander lookup fails to find it + ;; another case is when a cljc file :require-macros itself without refering the macros + (if-some [vr (when (simple-symbol? (first o)) (resolve (first o)))] + (if (and (not (class? vr)) (.isMacro ^clojure.lang.Var vr)) + (apply vr o cljs-macro-env (rest o)) + o) + o)) + +(defn expand-macro [env o] + (let [[f & args] o, n (name f), e (dec (count n))] + (if (= "." n) + o + (if (and (not= ".." n) (= \. (nth n e))) + `(new ~(symbol (namespace f) (subs n 0 e)) ~@args) + (if (some? (re-find #"^\.[^.]" n)) + (list* '. (first args) (symbol (subs n 1)) (rest args)) + (if (= :cljs (get (::peers env) (::current env))) + (let [cljs-env (::cljs-env env)] + (if (resolve-cljs cljs-env f) + o + (let [cljs-macro-env (cond-> cljs-env (::ns cljs-env) (assoc :ns (::ns cljs-env)))] + (if-some [expander (cljs-ana/get-expander f cljs-macro-env)] + (apply expander o cljs-macro-env args) + (expand-referred-or-local-macros o cljs-macro-env))))) + (macroexpand-clj o))))))) + +(defn find-local [env sym] (find (:locals env) sym)) +(defn add-local [env sym] (update env :locals assoc sym ::unknown)) + +(def ^:dynamic *electric* true) + +(defn ?meta [metao o] + (if (instance? clojure.lang.IObj o) + (cond-> o (meta metao) (vary-meta #(merge (meta metao) %))) + o)) + +(defn -expand-all [o env] + (cond + (and (seq? o) (seq o)) + (if (find-local env (first o)) + (list* (first o) (mapv (fn-> -expand-all env) (rest o))) + (case (first o) + ;; (ns ns* deftype* defrecord* var) + + (do) (if (nnext o) + (let [body (mapv #(list `e/drain %) (next o)) + body (conj (pop body) (second (peek body)))] ; last arg isn't drained + (recur (?meta o (cons `e/amb body)) env)) + (recur (?meta o (second o)) env)) + + (let*) (let [[_ bs & body] o + [bs2 env2] (reduce + (fn [[bs env] [sym v]] + [(conj bs sym (-expand-all v env)) (add-local env sym)]) + [[] env] + (partition-all 2 bs))] + (?meta o (list* 'let* bs2 (mapv (fn-> -expand-all env2) body)))) + + (loop*) (let [[_ bs & body] o + [bs2 env2] (reduce + (fn [[bs env] [sym v]] + [(conj bs sym (-expand-all v env)) (add-local env sym)]) + [[] env] + (partition-all 2 bs))] + (recur (?meta o `(binding [rec (::closure (let [~@(interleave (take-nth 2 bs2) r/arg-sym)] + ~@body))] + (new rec ~@(take-nth 2 (next bs2))))) env2)) + + (case clojure.core/case) + (let [[_ v & clauses] o + has-default-clause? (odd? (count clauses)) + clauses2 (cond-> clauses has-default-clause? butlast) + xpand (fn-> -expand-all env)] + (?meta o (list* 'case (xpand v) + (cond-> (into [] (comp (partition-all 2) (mapcat (fn [[match expr]] [match (xpand expr)]))) + clauses2) + has-default-clause? (conj (xpand (last clauses))))))) + + (quote) o + + (fn*) (let [[?name more] (if (symbol? (second o)) [(second o) (nnext o)] [nil (next o)]) + arities (cond-> more (vector? (first more)) list)] + (?meta o (apply list + (into (if ?name ['fn* ?name] ['fn*]) + (map (fn [[syms & body]] + (binding [*electric* false] + (list* syms (mapv (fn-> -expand-all (reduce add-local env syms)) body))))) + arities)))) + + (letfn*) (let [[_ bs & body] o + env2 (reduce add-local env (take-nth 2 bs)) + xpand (fn-> -expand-all env2) + bs2 (into [] (comp (partition-all 2) + (mapcat (fn [[sym v]] [sym (binding [*electric* false] (xpand v))]))) + bs)] + (?meta o `(let* [~(vec (take-nth 2 bs2)) (::letfn ~bs2)] ~@(mapv xpand body)))) + + (try) (throw (ex-info "try is TODO" {:o o})) #_(list* 'try (mapv (fn-> -all-in-try env) (rest o))) + + (binding clojure.core/binding) + (let [[_ bs & body] o] + (?meta o (list* 'binding (into [] (comp (partition-all 2) (mapcat (fn [[sym v]] [sym (-expand-all v env)]))) bs) + (mapv #(-expand-all % env) body)))) + + (set!) (if *electric* + (recur (?meta o `((fn* [v#] (set! ~(nth o 1) v#)) ~(nth o 2))) env) + (?meta o (list 'set! (-expand-all (nth o 1) env) (-expand-all (nth o 2) env)))) + + (::toggle) (concat (take 3 o) + (let [env (assoc env ::current (second o))] + (mapv (fn-> -expand-all env) (drop 3 o)))) + + #_else + (if (symbol? (first o)) + (let [o2 (expand-macro env o)] + (if (identical? o o2) + (?meta o (list* (first o) (mapv (fn-> -expand-all env) (rest o)))) + (recur (?meta o o2) env))) + (?meta o (list* (-expand-all (first o) env) (mapv (fn-> -expand-all env) (next o))))))) + + (map-entry? o) (clojure.lang.MapEntry. (-expand-all (key o) env) (-expand-all (val o) env)) + (coll? o) (?meta (meta o) (into (empty o) (map (fn-> -expand-all env)) o)) + :else o)) + +#_(defn -expand-all-in-try [o env] + (if (seq? o) + (if (find-local env (first o)) + (list* (first o) (mapv (fn-> -expand-all env) (rest o))) + (case (first o) + (catch) (let [[_ typ sym & body] o, env2 (add-local env sym)] + (list* 'catch typ sym (mapv (fn-> -expand-all env2) body))) + #_else (-expand-all o env))) + (-expand-all o env))) + +;; :js-globals -> cljs env +;; :locals -> cljs or electric env +;; ::lang/peers -> electric env +;; if ::current = :clj expand with clj environment +;; if ::current = :cljs expand with cljs environment + +(defn enrich-for-require-macros-lookup [cljs-env nssym] + (if-some [src (cljs-ana/locate-src nssym)] + (let [ast (:ast (with-redefs [cljs-ana/missing-use-macro? (constantly nil)] + (binding [cljs-ana/*passes* []] + (cljs-ana/parse-ns src {:load-macros true, :restore false}))))] + ;; we parsed the ns form without `ns-side-effects` because it triggers weird bugs + ;; this means the macro nss from `:require-macros` might not be loaded + (run! serialized-require (-> ast :require-macros vals set)) + (assoc cljs-env ::ns ast)) + cljs-env)) + +(tests "enrich of clj source file is noop" + (cljs.env/ensure (enrich-for-require-macros-lookup {:a 1} 'clojure.core)) := {:a 1}) + +;; takes an electric environment, which can be clj or cljs +;; if it's clj we need to prep the cljs environment (cljs.env/ensure + cljs.analyzer/empty-env with patched ns) +;; we need to be able to swap the environments infinite number of times + +(defn ->common-env [env] + (if (::cljs-env env) + env + (assoc env ::cljs-env + (if (contains? env :js-globals) + env + (cond-> (cljs.analyzer/empty-env) (:ns env) (enrich-for-require-macros-lookup (:ns env))))))) + +(defn expand-all [env o] (cljs.env/ensure (-expand-all o (->common-env env)))) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index fabf29acc..1fa67d570 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -4,6 +4,36 @@ [missionary.core :as m]) #?(:clj (:import (clojure.lang IFn IDeref)))) +#?(:clj + (def arg-sym + (map (comp symbol + (partial intern *ns*) + (fn [i] + (with-meta (symbol (str "%" i)) + {::type ::node}))) + (range)))) +;; pre-define the first 20 for e/fn varargs expansion +(def ^{::type ::node} %0) +(def ^{::type ::node} %1) +(def ^{::type ::node} %2) +(def ^{::type ::node} %3) +(def ^{::type ::node} %4) +(def ^{::type ::node} %5) +(def ^{::type ::node} %6) +(def ^{::type ::node} %7) +(def ^{::type ::node} %8) +(def ^{::type ::node} %9) +(def ^{::type ::node} %10) +(def ^{::type ::node} %11) +(def ^{::type ::node} %12) +(def ^{::type ::node} %13) +(def ^{::type ::node} %14) +(def ^{::type ::node} %15) +(def ^{::type ::node} %16) +(def ^{::type ::node} %17) +(def ^{::type ::node} %18) +(def ^{::type ::node} %19) + (def peer-slot-step 0) (def peer-slot-done 1) (def peer-slot-defs 2) @@ -157,4 +187,4 @@ (->Ctor peer 0 (object-array 0) {}) - (->PeerPs peer)))) \ No newline at end of file + (->PeerPs peer)))) diff --git a/test/hyperfiddle/electric/impl/expand_de_test.cljc b/test/hyperfiddle/electric/impl/expand_de_test.cljc new file mode 100644 index 000000000..ac4d97882 --- /dev/null +++ b/test/hyperfiddle/electric/impl/expand_de_test.cljc @@ -0,0 +1,179 @@ +(ns hyperfiddle.electric.impl.expand-de-test + (:require #?(:clj [cljs.env]) + #?(:clj [cljs.analyzer]) + #?(:clj [hyperfiddle.electric.impl.compiler :as c]) + #?(:clj [hyperfiddle.electric.impl.runtime-de :as r]) + #?(:clj [hyperfiddle.electric :as-alias e]) + [hyperfiddle.electric.impl.expand-require-referred :as ref :refer [referred]] + #?(:clj [hyperfiddle.rcf :as rcf :refer [tests]])) + #?(:cljs (:require-macros [hyperfiddle.electric.impl.expand-macro :as mac :refer [twice]]))) + +#?(:clj + (defmacro all [o] `(c/expand-all ~(if (:js-globals &env) + (assoc &env ::c/peers {:client :cljs, :server :cljs}, ::c/current :client) + {:locals &env, ::c/peers {:client :clj, :server :clj}, ::c/current :client}) + ~o))) + +#?(:clj (defmacro test-peer-expansion [] (if (:js-globals &env) :cljs :clj))) + +#?(:clj (deftype X [])) + +#?(:clj (def has-line-meta? (comp number? :line meta))) + +#?(:clj + (tests + (all nil) := nil + (all 1) := 1 + (all '(inc 1)) := '(inc 1) + (has-line-meta? (all '(inc 1))) := true + (all '[(-> 1 inc)]) := '[(inc 1)] + (has-line-meta? (-> (all '[(-> 1 inc)]) first)) := true + (all '{(-> 1 inc) (-> 1 inc)}) := '{(inc 1) (inc 1)} + (all (seq '(-> 1 inc))) := '(inc 1) + + (all '(let [x 1] x)) := '(let* [x 1] x) + (has-line-meta? (all '(let [x 1] x))) := true + (all '(let [x (let [y 1] y)] x)) := '(let* [x (let* [y 1] y)] x) + + (all '(do 1 2)) := (all `(e/amb (e/drain 1) 2)) + (has-line-meta? (all '(do 1 2))) := true + (all '(do (let [x 1] x) (let [y 2] y))) := (all `(e/amb (e/drain (let* [~'x 1] ~'x)) (let* [~'y 2] ~'y))) + (all '(do (-> 1 inc))) := '(inc 1) + (has-line-meta? (all '(do (-> 1 inc)))) := true + + (all '(inc (let [x 1] x))) := '(inc (let* [x 1] x)) + + (all '(let [with-open inc] (with-open 1))) := '(let* [with-open inc] (with-open 1)) + (all '(let [with-open inc, x (with-open inc)] x)) := '(let* [with-open inc, x (with-open inc)] x) + + (all '(case (-> 1 inc) (2) (-> 2 inc) (with-open) 3 4)) := '(case (inc 1) (2) (inc 2) (with-open) 3 4) + (has-line-meta? (all '(case (-> 1 inc) (2) (-> 2 inc) (with-open) 3 4))) := true + + (all ''(-> 1 inc)) := ''(-> 1 inc) + + (all '(fn [x] 1)) := '(fn* ([x] 1)) + (has-line-meta? (all '(fn [x] 1))) := true + (all '(fn foo [x] 1)) := '(fn* foo ([x] 1)) + (all '(fn foo ([x] 1))) := '(fn* foo ([x] 1)) + (all '(fn [with-open] (with-open 1))) := '(fn* ([with-open] (with-open 1))) + (all '(fn [x] (-> x inc))) := '(fn* ([x] (inc x))) + + (all '(fn* [x] x)) := '(fn* ([x] x)) ; fn* can come from elsewhere with a non-wrapped single arity + (has-line-meta? (all '(fn* [x] x))) := true + + (let [x (all '(letfn [(foo [with-open] (with-open 1)) ; don't expand with-open + (bar [x] (-> x inc)) ; expand -> + (baz [x] (->> x)) ; don't expand ->>, it is shadowed in letfn scope + (->> [x] x)] + (-> (->> x) inc)))] + x := '(let* [[foo bar baz ->>] + (:hyperfiddle.electric.impl.compiler/letfn [foo (fn* foo ([with-open] (with-open 1))) + bar (fn* bar ([x] (inc x))) + baz (fn* baz ([x] (->> x))) + ->> (fn* ->> ([x] x))])] + (inc (->> x))) + (has-line-meta? x) := true) + + (let [[f v :as x] (all '(set! (.-x (-> [(java.awt.Point. (-> 0 inc) 2)] first)) (-> 2 inc))) + fnbody (-> f second second butlast)] ; to extract (fn* ([gensym] -this-> (set! .. gensym))) + fnbody := '(set! (. (first [(new java.awt.Point (inc 0) 2)]) -x)) + v := '(inc 2) + (has-line-meta? x) := true) + + (all '(new java.awt.Point (-> 0 inc) 1)) := '(new java.awt.Point (inc 0) 1) + (all '(java.awt.Point. (-> 0 inc) 1)) := '(new java.awt.Point (inc 0) 1) + (all '(new (missionary.core/seed [(-> 0 inc)]))) := '(new (missionary.core/seed [(inc 0)])) + + ;; TODO next iteration + ;; (all '(try (-> 1 inc) + ;; (catch Throwable with-open (with-open 1)) + ;; (finally (-> 0 dec)))) + ;; := '(try (inc 1) + ;; (catch Throwable with-open (with-open 1)) + ;; (finally (dec 0))) + + ;; (all '(try true)) := '(try true) + ;; ;; works outside RCF + ;; ;; (let [with-open inc] (all '(with-open 1))) + ;; ;; := '(with-open 1) + + ;; (all '(catch (-> 1 inc))) := '(catch (inc 1)) + + (let [x (all '(loop [with-open inc, x 2] (-> x with-open)))] + x := `(~'binding [c/rec + (::c/closure + (let* [~'with-open r/%0, ~'x r/%1] + (~'with-open ~'x)))] + (new c/rec ~'inc 2)) + (has-line-meta? x) := true) + + (let [x (all '(binding [x (-> 1 inc)] (-> x inc)))] + x := '(binding [x (inc 1)] (inc x)) + (has-line-meta? x) := true) + + (let [x (all '((-> inc) 1))] + x := '(inc 1) + (has-line-meta? x) := true) + + (all '()) := '() + + (all '(hyperfiddle.impl.expand-test/X.)) := '(new hyperfiddle.impl.expand-test/X) + + (c/-expand-all '(#{:ok} 1) {:js-globals {}}) + + "cljs var lookup doesn't produce undeclared-ns warnings" + (let [!warns (atom [])] + (cljs.env/ensure + (cljs.analyzer/with-warning-handlers [(fn [typ env extra] + (when (typ cljs.analyzer/*cljs-warnings*) + (swap! !warns conj [typ env extra])))] + (binding [*err* *out*] + (with-out-str (c/-expand-all '(r/reflect 1) {::c/peers {:client :cljs, :server :clj} ::c/current :client}))))) + @!warns := []) + + "expansion is peer-aware" + (c/expand-all {::c/peers {:client :cljs, :server :clj}, ::c/current :server} + `[(test-peer-expansion) (::c/toggle :client {} (test-peer-expansion))]) + := `[:clj (::c/toggle :client {} :cljs)] + + (c/expand-all {::c/peers {:client :cljs, :server :clj}, ::c/current :client} + `[(test-peer-expansion) (::c/toggle :server {} (test-peer-expansion))]) + := `[:cljs (::c/toggle :server {} :clj)] + + "cljs require-macros work in clj expansion" + (c/expand-all {::c/peers {:client :cljs, :server :clj}, ::c/current :client, :ns 'hyperfiddle.electric.impl.expand-test} + '(hyperfiddle.electric.impl.expand-macro/twice 1)) + := '[1 1] + (c/expand-all {::c/peers {:client :cljs, :server :clj}, ::c/current :client, :ns 'hyperfiddle.electric.impl.expand-test} + '(mac/twice 1)) + := '[1 1] + (c/expand-all {::c/peers {:client :cljs, :server :clj}, ::c/current :client, :ns 'hyperfiddle.electric.impl.expand-test} + '(twice 1)) + := '[1 1] + + "require referred macros work in cljs" + (c/expand-all {::c/peers {:client :cljs, :server :clj}, ::c/current :client, :ns 'hyperfiddle.electric.impl.expand-test} + '(referred)) + := :referred + + "required macros work in cljs when fully qualified" + (c/expand-all {::c/peers {:client :cljs, :server :clj}, ::c/current :client, :ns 'hyperfiddle.electric.impl.expand-test} + '(hyperfiddle.electric.impl.expand-require-referred/referred)) + := :referred + + "required macros work in cljs when alias qualified" + (c/expand-all {::c/peers {:client :cljs, :server :clj}, ::c/current :client, :ns 'hyperfiddle.electric.impl.expand-test} + '(ref/referred)) + := :referred + + (println " ok"))) + +;; doesn't work in `tests` +#?(:clj + (when-not (= '(let* [x 1]) + (binding [*ns* (create-ns 'hyperfiddle.electric.impl.expand-unloaded)] + (c/expand-all {::c/peers {:client :cljs, :server :clj} + ::c/current :server, ::c/me :client + :ns 'hyperfiddle.electric.impl.expand-unloaded} + '(let [x 1])))) + (throw (ex-info "clj macroexpansion for unloaded ns fails" {})))) From dc5ee72cc2c36ca93866ff4ae7d9be12f676a679 Mon Sep 17 00:00:00 2001 From: xificurC Date: Fri, 15 Dec 2023 21:21:51 +0100 Subject: [PATCH 007/428] cleanup --- src/hyperfiddle/electric/impl/compiler.clj | 4 ++-- src/hyperfiddle/electric/impl/runtime_de.cljc | 2 ++ test/hyperfiddle/electric/impl/expand_de_test.cljc | 4 ++-- 3 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/hyperfiddle/electric/impl/compiler.clj b/src/hyperfiddle/electric/impl/compiler.clj index e2a4fb4a3..86c346450 100644 --- a/src/hyperfiddle/electric/impl/compiler.clj +++ b/src/hyperfiddle/electric/impl/compiler.clj @@ -106,9 +106,9 @@ [(conj bs sym (-expand-all v env)) (add-local env sym)]) [[] env] (partition-all 2 bs))] - (recur (?meta o `(binding [rec (::closure (let [~@(interleave (take-nth 2 bs2) r/arg-sym)] + (recur (?meta o `(binding [r/rec (::closure (let [~@(interleave (take-nth 2 bs2) r/arg-sym)] ~@body))] - (new rec ~@(take-nth 2 (next bs2))))) env2)) + (new r/rec ~@(take-nth 2 (next bs2))))) env2)) (case clojure.core/case) (let [[_ v & clauses] o diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 1fa67d570..c58b4823c 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -4,6 +4,8 @@ [missionary.core :as m]) #?(:clj (:import (clojure.lang IFn IDeref)))) +(def ^{::type ::node, :doc "for loop/recur impl"} rec) + #?(:clj (def arg-sym (map (comp symbol diff --git a/test/hyperfiddle/electric/impl/expand_de_test.cljc b/test/hyperfiddle/electric/impl/expand_de_test.cljc index ac4d97882..1d0519d7e 100644 --- a/test/hyperfiddle/electric/impl/expand_de_test.cljc +++ b/test/hyperfiddle/electric/impl/expand_de_test.cljc @@ -100,11 +100,11 @@ ;; (all '(catch (-> 1 inc))) := '(catch (inc 1)) (let [x (all '(loop [with-open inc, x 2] (-> x with-open)))] - x := `(~'binding [c/rec + x := `(~'binding [r/rec (::c/closure (let* [~'with-open r/%0, ~'x r/%1] (~'with-open ~'x)))] - (new c/rec ~'inc 2)) + (new r/rec ~'inc 2)) (has-line-meta? x) := true) (let [x (all '(binding [x (-> 1 inc)] (-> x inc)))] From e864688cd876665daebfe36e9ddebdb9ffbb64ef Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Tue, 19 Dec 2023 10:25:45 +0100 Subject: [PATCH 008/428] low-level API --- src/hyperfiddle/electric/impl/lang_de.cljc | 41 +++ src/hyperfiddle/electric/impl/runtime_de.cljc | 280 +++++++++++------- test/hyperfiddle/electric_compiler_test.clj | 152 ++++++---- 3 files changed, 305 insertions(+), 168 deletions(-) create mode 100644 src/hyperfiddle/electric/impl/lang_de.cljc diff --git a/src/hyperfiddle/electric/impl/lang_de.cljc b/src/hyperfiddle/electric/impl/lang_de.cljc new file mode 100644 index 000000000..4c8798e78 --- /dev/null +++ b/src/hyperfiddle/electric/impl/lang_de.cljc @@ -0,0 +1,41 @@ +(ns hyperfiddle.electric.impl.lang-de + (:require [hyperfiddle.electric.impl.runtime-de :as r] + [hyperfiddle.incseq :as i])) + +(def ^:dynamic *tier*) + +(defn invoke [f & args] + (apply f args)) + +(defmacro defs [& exprs] + `(fn [tier# id#] + (binding [*tier* tier#] + (case id# + ~(interleave (range) exprs))))) + +(defmacro static [expr] + `(r/pure ~expr)) + +(defmacro ap [& args] + `(i/latest-product invoke ~@args)) + +(defmacro free [id] + `(r/ctor-free (r/tier-ctor *tier*) ~id)) + +(defmacro local [id] + `(r/tier-local *tier* ~id)) + +(defmacro remote [id] + `(r/tier-local *tier* ~id)) + +(defmacro ctor [& args] + `(r/pure (r/peer-ctor (r/tier-peer *tier*) ~@args))) + +(defmacro call [id] + `(i/latest-concat (r/tier-slot *tier* ~id))) + +(defmacro join [expr] + `(i/latest-concat ~expr)) + +(defmacro var [id] + `(r/pure (r/peer-var (r/tier-peer *tier*) (quote ~id)))) \ No newline at end of file diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index c58b4823c..172648b81 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -1,6 +1,5 @@ (ns hyperfiddle.electric.impl.runtime-de - (:require [hyperfiddle.electric.impl.local :as l] - [hyperfiddle.incseq :as i] + (:require [hyperfiddle.incseq :as i] [missionary.core :as m]) #?(:clj (:import (clojure.lang IFn IDeref)))) @@ -36,22 +35,13 @@ (def ^{::type ::node} %18) (def ^{::type ::node} %19) -(def peer-slot-step 0) -(def peer-slot-done 1) -(def peer-slot-defs 2) -(def peer-slot-input 4) -(def peer-slot-store 5) -(def peer-slots 6) - -(defmacro defs [& forms] - `(fn [i#] (case i# ~@(interleave (range) forms)))) +(def peer-slot-input 0) +(def peer-slot-store 1) +(def peer-slots 2) (defn pure [form] (i/fixed (m/cp form))) -(defn static [form] - (pure form)) - (defn error [^String msg] #?(:clj (Error. msg) :cljs (js/Error. msg))) @@ -68,125 +58,187 @@ (#?(:clj invoke :cljs -invoke) [_ step done] (step) (->Failer done (error (str "Unbound electric var lookup - " k))))) -(def this (l/local)) +(deftype Ctor [peer slots output free vars]) + +(deftype Peer [step done defs state] + IFn + (#?(:clj invoke :cljs -invoke) [_] + (prn :cancel-peer) -(deftype Tier [parent ctor static dynamic]) -(deftype Ctor [peer id free vars]) + ) + IDeref + (#?(:clj deref :cljs -deref) [_] + (prn :transfer-peer) -(defn ctor [id & free] - (let [^Tier tier (l/get-local this) - ^Ctor ctor (.-ctor tier) - ^objects peer (.-peer ctor)] - (pure (->Ctor peer id (object-array free) {})))) + )) (defn bind [^Ctor ctor peer k v] (when-not (identical? peer (.-peer ctor)) (throw (error "Can't bind foreign constructor."))) - (->Ctor peer (.-id ctor) (.-free ctor) + (->Ctor peer (.-slots ctor) (.-output ctor) (.-free ctor) (assoc (.-vars ctor) k v))) -(defn lookup [k] - (loop [^Tier tier (l/get-local this)] - (let [^Ctor ctor (.-ctor tier)] - (if-some [s (get (.-vars ctor) k)] - s (if-some [p (.-parent tier)] - (recur p) (->Unbound k)))))) +(defrecord Var [peer k] + IFn + (#?(:clj invoke :cljs -invoke) [_ ctor v] + (bind ctor peer k v))) + +(declare tier-ctor) +(declare ctor-peer) -(deftype NodePs [^objects peer k ps] +(deftype StoredPs [k ps] IFn (#?(:clj invoke :cljs -invoke) [_] - (aset peer peer-slot-store - (dissoc (aget peer peer-slot-store) k)) + (let [peer (.-state (ctor-peer (tier-ctor (:tier k))))] + (aset peer peer-slot-store + (dissoc (aget peer peer-slot-store) k))) (ps)) IDeref (#?(:clj deref :cljs -deref) [_] @ps)) -(defn resolve-node [^objects peer tier id] - (let [k [tier id] - store (aget peer peer-slot-store)] - (if-some [s (get store k)] - s (let [n (let [that (l/get-local this)] - (l/set-local this tier) - (try ((aget peer peer-slot-defs) id) - (finally - (l/set-local this that)))) - s (m/signal i/combine (fn [step done] (->NodePs peer k (n step done))))] - (aset peer peer-slot-store (assoc store k s)) s)))) - -(deftype Node [peer tier id] - IFn - (#?(:clj invoke :cljs -invoke) [_ step done] - ((resolve-node peer tier id) step done))) +(defn get-flow [^Tier tier id] + ((.-defs (ctor-peer (tier-ctor tier))) tier id)) -(defn local [id] - (let [^Tier tier (l/get-local this) - ^Ctor ctor (.-ctor tier) - ^objects peer (.-peer ctor)] - (->Node peer tier id))) - -(defn remote [id]) - -(deftype Var [peer k] +(defrecord Node [tier id] IFn - (#?(:clj invoke :cljs -invoke) [_ ctor v] - (bind ctor peer k v))) - -(defn var [k] - (let [^Tier tier (l/get-local this) - ^Ctor ctor (.-ctor tier) - ^objects peer (.-peer ctor)] - (pure (->Var peer k)))) - -(defn free [id] - (let [^Tier tier (l/get-local this) - ^Ctor ctor (.-ctor tier) - ^objects free (.-free ctor)] - (aget free id))) - -(defn call [expr] + (#?(:clj invoke :cljs -invoke) [node step done] + ((let [^objects peer (.-state (ctor-peer (tier-ctor tier))) + store (aget peer peer-slot-store)] + (if-some [s (get store node)] + s (let [n (get-flow tier id) + s (m/signal i/combine (fn [step done] (->StoredPs node (n step done))))] + (aset peer peer-slot-store (assoc store node s)) s))) + step done))) + +(deftype Tier [parent slot-id ^Ctor ctor] + IFn + (#?(:clj invoke :cljs -invoke) [tier step done] + ((->Node tier (.-output ctor)) step done))) +(defrecord Slot [tier id] + IFn + (#?(:clj invoke :cljs -invoke) [slot step done] + ((let [^Ctor ctor (tier-ctor tier) + ^objects peer (.-state (ctor-peer ctor)) + store (aget peer peer-slot-store)] + (if-some [s (get store slot)] + s (let [n (i/latest-product + (fn [ctor] + (when-not (instance? Ctor ctor) + (throw (error (str "Not a constructor - " ctor)))) + (when-not (identical? peer (.-peer ^Ctor ctor)) + (throw (error "Can't call foreign constructor."))) + (->Tier tier id ctor)) + (get-flow tier (nth (.-slots ctor) id))) + s (m/signal i/combine (fn [step done] (->StoredPs slot (n step done))))] + (aset peer peer-slot-store (assoc store slot s)) s))) + step done))) + +(defn context-input-notify [^Peer peer done?] + ;; TODO ) -(def ap - (partial i/latest-product - (fn - ([f] (f)) - ([f a] (f a)) - ([f a b] (f a b)) - ([f a b c] (f a b c)) - ([f a b c d] (f a b c d)) - ([f a b c d & e] (apply f a b c d e))))) - -(def join i/latest-concat) - -(defn context-input-notify [^objects state done?] - +(defn ctor-peer + "Returns the peer of given constructor." + {:tag Peer} + [^Ctor ctor] + (.-peer ctor)) + +(defn tier-parent + "Returns the parent tier of given tier if not root, nil otherwise." + {:tag Tier} + [^Tier tier] + (.-parent tier)) + +(defn tier-slot-id + "Returns the index of the slot of given tier within its parent." + [^Tier tier] + (.-slot-id tier)) + +(defn tier-slot + "Returns the slot for given tier and id." + {:tag Slot} + [^Tier tier id] + (->Slot tier id)) + +(defn tier-slot-count + "Returns the count of children of given tier." + [^Tier tier] + (count (.-slots (tier-ctor tier)))) + +(defn tier-output + "Returns the output of given tier." + {:tag Node} + [^Tier tier] + (->Node tier (.-output (tier-ctor tier)))) + +(defn tier-ctor + "Returns the constructor of given tier." + {:tag Ctor} + [^Tier tier] + (.-ctor tier)) + +(defn tier-peer + "Returns the peer of given tier." + {:tag Peer} + [tier] + (ctor-peer (tier-ctor tier))) + +(defn tier-lookup + "Returns the value associated with given key in the dynamic environment of given tier." + [tier k] + (loop [tier tier] + (if-some [s (get (.-vars (tier-ctor tier)) k)] + s (if-some [p (tier-parent tier)] + (recur p) (->Unbound k))))) + +(defn peer-ctor " +Returns a constructor for given peer, with slots defined by given vector of ids, output defined by given id, and +given free variables. +" [peer slots output & free] + (->Ctor peer slots output (object-array free) {})) + +(defn tier-local + "Returns the incremental sequence signal defined by given id in given tier." + [tier id] + (->Node tier id)) + +(defn tier-remote [tier id] + ;; TODO ) -(deftype PeerPs [^objects state] - IFn - (#?(:clj invoke :cljs -invoke) [_] - - - ) - IDeref - (#?(:clj deref :cljs -deref) [_] - - - )) - -(defn peer [msgs defs] - (fn [step done] - (let [peer (object-array peer-slots)] - (aset peer peer-slot-step step) - (aset peer peer-slot-done done) - (aset peer peer-slot-defs defs) - (aset peer peer-slot-store {}) - (aset peer peer-slot-input - ((m/stream (m/observe msgs)) - #(context-input-notify peer false) - #(context-input-notify peer true))) - - (->Ctor peer 0 (object-array 0) {}) - - (->PeerPs peer)))) +(defn peer-var + "Returns the var associated with given key in given peer." + [^Peer peer k] + (->Var peer k)) + +(defn ctor-free + "Returns the i-th free variable of given constructor." + [^Ctor ctor i] + (aget ^objects (.-free ctor) i)) + +(defn tier-slot + "Returns the i-th slot of given tier." + [^Tier tier i] + (->Slot tier i)) + +(defn peer " +Returns a peer definition from given node definitions and root constructor. +" [defs slots output] + (fn [msgs] + (fn [step done] + (let [state (object-array peer-slots) + peer (->Peer step done defs state)] + (aset state peer-slot-store {}) + (aset state peer-slot-input + ((m/stream (m/observe msgs)) + #(context-input-notify peer false) + #(context-input-notify peer true))) + + ((m/reduce (fn [_ x] (prn :output x)) nil + (->Tier nil 0 + (->Ctor peer slots output + (object-array 0) {}))) + #(prn :success %) #(prn :failure %)) + + peer)))) \ No newline at end of file diff --git a/test/hyperfiddle/electric_compiler_test.clj b/test/hyperfiddle/electric_compiler_test.clj index dc9c9bac3..c45fd91ca 100644 --- a/test/hyperfiddle/electric_compiler_test.clj +++ b/test/hyperfiddle/electric_compiler_test.clj @@ -23,128 +23,172 @@ (lang/compile-client {} 1) ;; r/defs takes & flows with an implicit context (managed in runtime, thread-local or such) ;; context - path of the node you're constructing in the call stack - := `(r/defs (r/static 1)) + := `(r/peer + (lang/defs + (lang/static 1)) + [] 0) ;; transfer (lang/compile-client {} `(e/client "Hello world")) := - `(r/defs - (r/static "Hello world")) + `(r/peer + (lang/defs + (lang/static "Hello world")) + [] 0) (lang/compile-client {} `(e/client (let [x "Hello world" y "Hello world"] [x y]))) := - `(r/defs - (r/ap (r/static vector) (r/local 1) (r/local 2)) - (r/static "Hello world") - (r/static "Hello world")) + `(r/peer + (lang/defs + (lang/static "Hello world") + (lang/static "Hello world") + (lang/ap (lang/static vector) (lang/local 1) (lang/local 2))) + [] 2) (lang/compile-server {} `(e/client "Hello world")) := - `(r/defs - (r/remote 0)) ;; 0 refers to client's r/defs + `(r/peer + (lang/defs + (lang/remote 0)) ;; 0 refers to client's r/defs + [] 0) ;; function application (lang/compile-client {} `(e/client (prn "Hello world"))) := - `(r/defs - (r/ap (r/static prn) (r/static "Hello world"))) + `(r/peer + (lang/defs + (lang/ap (lang/static prn) (lang/static "Hello world"))) + [] 0) ;; lexical scope (lang/compile-client {} `(e/client (let [a :foo] [a a]))) := - `(r/defs - (r/ap (r/static vector) (r/local 1) (r/local 1)) - (r/static :foo)) + `(r/peer + (lang/defs + (lang/static :foo) + (lang/ap (lang/static vector) (lang/local 1) (lang/local 1))) + [] 1) (lang/compile-client {} `(e/client (let [a (e/server :foo)] (e/server (prn a))))) := - `(r/defs - (r/remote 0)) + `(r/peer + (lang/defs + (lang/remote 0)) + [] 0) (lang/compile-server {} `(e/client (let [a (e/server :foo)] (e/server (prn a))))) := - `(r/defs - (r/ap (r/static prn) (r/local 1)) - (r/static :foo)) + `(r/peer + (lang/defs + (lang/static :foo) + (lang/ap (lang/static prn) (lang/local 0))) + [] 1) ;; join (e/watch !x) ;; (i/fixed continuous-flow) -> incremental sequence of 1 element (lang/compile-client {} `(e/client (e/join (i/fixed (m/watch !x))))) := - `(r/defs - (r/join (r/ap (r/static i/fixed) (r/ap (r/static m/watch) (r/static !x))))) + `(r/peer + (lang/defs + (lang/join (lang/ap (lang/static i/fixed) + (lang/ap (lang/static m/watch) + (lang/static !x))))) + [] 0) ;; pure (get the incseq of an expression) (e/pure (e/join x)) is (e/join (e/pure x)) is x (lang/compile-client {} `(e/client (e/pure :foo))) := - `(r/defs - (r/pure (r/static :foo))) + `(r/peer + (lang/defs + (lang/static (lang/static :foo))) + [] 0) ;; ctor (e/fn [] foo) -> (e/ctor foo) (previously ::c/closure) (lang/compile-client {} `(e/client (e/ctor :foo))) := - `(r/defs - (r/ctor 1) - (r/static :foo)) + `(r/peer + (lang/defs + (lang/static :foo) + (lang/ctor [] 0)) + [] 1) ;; call (aka new, but with no argument and only for ctors) (lang/compile-client {} `(e/client (e/call (e/ctor :foo)))) := - `(r/defs - (r/call (r/ctor 1)) - (r/static :foo)) + `(r/peer + (lang/defs + (lang/static :foo) + (lang/ctor [] 0) + (lang/call 0)) + [1] 2) ;; lexical closure (lang/compile-client {} `(e/client (let [a :foo] (e/call (e/ctor a))))) := - `(r/defs - (r/call (r/ctor 1 (r/local 2))) - (r/free 0) - (r/static :foo)) + `(r/peer + (lang/defs + (lang/static :foo) + (lang/free 0) + (lang/ctor [] 1 (lang/local 0)) + (lang/call 0)) + [2] 3) (lang/compile-client {} `(e/client (let [a :foo] (e/call (e/ctor (e/ctor a)))))) := - `(r/defs - (r/call (r/ctor 1 (r/local 3))) - (r/ctor 2 (r/free 0)) - (r/free 0) - (r/static :foo)) + `(r/peer + (lang/defs + (lang/static :foo) + (lang/free 0) + (lang/ctor [] 1 (lang/free 0)) + (lang/ctor [] 2 (lang/local 0)) + (lang/call 0)) + [3] 4) ;; conditionals (lang/compile-client {} `(e/client (case :x nil :y :z))) := - `(r/defs - (r/call (r/ap (r/ap (r/static hash-map) - (r/static nil) (r/ctor 1)) - (r/static :x) (r/ctor 2))) - (r/static :y) - (r/static :z)) + `(r/peer + (lang/defs + (lang/static :y) + (lang/static :z) + (lang/ap (lang/ap (lang/static hash-map) + (lang/static nil) (lang/ctor [] 0)) + (lang/static :x) (lang/ctor [] 1)) + (lang/call 0)) + [2] 3) ;; var (e/def x) (lang/compile-client {} `(e/client (var x))) := - `(r/defs (r/var (quote x))) + `(r/peer + (lang/defs + (lang/var x)) + [] 0) (lang/compile-client {} `(let [a :foo, b :bar, c :baz] [(e/ctor [a b]) (e/ctor [b c])])) := - `(r/defs - (r/ap (r/static vector) - (r/ctor 4 (r/local 1) (r/local 2)) - (r/ctor 5 (r/local 2) (r/local 3))) - (r/static :foo) - (r/static :bar) - (r/static :baz) - (r/ap (r/static vector) (r/free 0) (r/free 1)) - (r/ap (r/static vector) (r/free 0) (r/free 1))) + `(r/peer + (lang/defs + (lang/static :foo) + (lang/static :bar) + (lang/static :baz) + (lang/ap (lang/static vector) + (lang/free 0) (lang/free 1)) + (lang/ap (lang/static vector) + (lang/free 0) (lang/free 1)) + (lang/ap (lang/static vector) + (lang/ctor 3 (lang/local 0) (lang/local 1)) + (lang/ctor 4 (lang/local 1) (lang/local 2)))) + [] 5) ) From a2c560ceb1965c057acdd82e9a2c77e79441e218 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Tue, 19 Dec 2023 10:33:12 +0100 Subject: [PATCH 009/428] fix build --- src/hyperfiddle/electric/impl/runtime_de.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 172648b81..281ad3b1b 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -96,7 +96,7 @@ IDeref (#?(:clj deref :cljs -deref) [_] @ps)) -(defn get-flow [^Tier tier id] +(defn get-flow [tier id] ((.-defs (ctor-peer (tier-ctor tier))) tier id)) (defrecord Node [tier id] From 5da1c351f9507b737c03a57cfff7f86d36461d9b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Tue, 19 Dec 2023 11:05:02 +0100 Subject: [PATCH 010/428] fix indices in compiler test suite --- test/hyperfiddle/electric_compiler_test.clj | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/hyperfiddle/electric_compiler_test.clj b/test/hyperfiddle/electric_compiler_test.clj index c45fd91ca..22b5739d9 100644 --- a/test/hyperfiddle/electric_compiler_test.clj +++ b/test/hyperfiddle/electric_compiler_test.clj @@ -44,7 +44,7 @@ (lang/defs (lang/static "Hello world") (lang/static "Hello world") - (lang/ap (lang/static vector) (lang/local 1) (lang/local 2))) + (lang/ap (lang/static vector) (lang/local 0) (lang/local 1))) [] 2) (lang/compile-server {} From 29f4c24982858a249b03112bf684c125f26b7c52 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Tue, 19 Dec 2023 15:11:59 +0100 Subject: [PATCH 011/428] e/fn self-recursion --- src/hyperfiddle/electric/impl/lang_de.cljc | 6 ++-- src/hyperfiddle/electric/impl/runtime_de.cljc | 6 ++-- test/hyperfiddle/electric_compiler_test.clj | 36 +++++++++++++++++++ 3 files changed, 43 insertions(+), 5 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de.cljc b/src/hyperfiddle/electric/impl/lang_de.cljc index 4c8798e78..3e972a846 100644 --- a/src/hyperfiddle/electric/impl/lang_de.cljc +++ b/src/hyperfiddle/electric/impl/lang_de.cljc @@ -28,8 +28,10 @@ (defmacro remote [id] `(r/tier-local *tier* ~id)) -(defmacro ctor [& args] - `(r/pure (r/peer-ctor (r/tier-peer *tier*) ~@args))) +(defmacro ctor [slots output & free] + `(r/pure (r/peer-ctor (r/tier-peer *tier*) ~slots ~output + (doto (object-array ~(count free)) + ~@(map-indexed (partial list `aset) free))))) (defmacro call [id] `(i/latest-concat (r/tier-slot *tier* ~id))) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 281ad3b1b..994fcc0de 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -194,9 +194,9 @@ (defn peer-ctor " Returns a constructor for given peer, with slots defined by given vector of ids, output defined by given id, and -given free variables. -" [peer slots output & free] - (->Ctor peer slots output (object-array free) {})) +given array of free variables. +" [peer slots output free] + (->Ctor peer slots output free {})) (defn tier-local "Returns the incremental sequence signal defined by given id in given tier." diff --git a/test/hyperfiddle/electric_compiler_test.clj b/test/hyperfiddle/electric_compiler_test.clj index 22b5739d9..36f180144 100644 --- a/test/hyperfiddle/electric_compiler_test.clj +++ b/test/hyperfiddle/electric_compiler_test.clj @@ -1,5 +1,6 @@ (ns hyperfiddle.electric-compiler-test (:require [hyperfiddle.electic :as-alias e] + [hyperfiddle.incseq :as i] [hyperfiddle.rcf :as rcf :refer [tests]] [hyperfiddle.electric.impl.lang-de :as lang] [hyperfiddle.electric.impl.runtime-de :as r])) @@ -191,4 +192,39 @@ (lang/ctor 4 (lang/local 1) (lang/local 2)))) [] 5) + (lang/compile-client {} + `(new (e/fn Foo [] (Foo.)))) := + `(r/peer + (fn [tier id] + (case id + 0 (r/ctor-free (r/tier-ctor tier) 0) + 1 (let [free (object-array 1) + ctor (r/peer-ctor (r/tier-peer tier) [] 0 free)] + (aset free 0 (r/pure ctor)) + (r/pure ctor)) + 2 (i/latest-concat (r/tier-slot tier 0)))) + [1] 2) + + (lang/compile-client {} + `(e/letfn [(Foo [] (Bar.)) + (Bar [] (Foo.))] + (Foo.))) := + `(r/peer + (fn [tier id] + (case id + 0 (r/ctor-free (r/tier-ctor tier) 1) + 1 (r/ctor-free (r/tier-ctor tier) 0) + 2 (let [Foo-free (object-array 2) + Foo-ctor (r/peer-ctor (r/tier-peer tier) [] 0 Foo-free) + Bar-free (object-array 2) + Bar-ctor (r/peer-ctor (r/tier-peer tier) [] 1 Bar-free)] + (aset Foo-free 0 (r/pure Foo-ctor)) + (aset Foo-free 1 (r/pure Bar-ctor)) + (aset Bar-free 0 (r/pure Foo-ctor)) + (aset Bar-free 1 (r/pure Bar-ctor)) + (r/pure {:Foo Foo-ctor :Bar Bar-ctor})) + 3 (i/latest-product :Foo (r/tier-local tier 0)) + 4 (i/latest-concat (r/tier-slot tier 0)))) + [3] 4) + ) From 4e27a9b5b99d27d44224146ec19bf6669e978de2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Tue, 19 Dec 2023 20:27:59 +0100 Subject: [PATCH 012/428] fix foreign checks --- src/hyperfiddle/electric/impl/runtime_de.cljc | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 994fcc0de..6afe188f7 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -56,7 +56,7 @@ (deftype Unbound [k] IFn (#?(:clj invoke :cljs -invoke) [_ step done] - (step) (->Failer done (error (str "Unbound electric var lookup - " k))))) + (step) (->Failer done (error (str "Unbound electric var lookup - " (pr-str k)))))) (deftype Ctor [peer slots output free vars]) @@ -119,19 +119,20 @@ IFn (#?(:clj invoke :cljs -invoke) [slot step done] ((let [^Ctor ctor (tier-ctor tier) - ^objects peer (.-state (ctor-peer ctor)) - store (aget peer peer-slot-store)] + ^Peer peer (ctor-peer ctor) + ^objects state (.-state peer) + store (aget state peer-slot-store)] (if-some [s (get store slot)] s (let [n (i/latest-product (fn [ctor] (when-not (instance? Ctor ctor) - (throw (error (str "Not a constructor - " ctor)))) - (when-not (identical? peer (.-peer ^Ctor ctor)) + (throw (error (str "Not a constructor - " (pr-str ctor))))) + (when-not (identical? peer (ctor-peer ctor)) (throw (error "Can't call foreign constructor."))) (->Tier tier id ctor)) (get-flow tier (nth (.-slots ctor) id))) s (m/signal i/combine (fn [step done] (->StoredPs slot (n step done))))] - (aset peer peer-slot-store (assoc store slot s)) s))) + (aset state peer-slot-store (assoc store slot s)) s))) step done))) (defn context-input-notify [^Peer peer done?] From e65073188b17d3fe39dabe3d4ce94b6019abdafe Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 20 Dec 2023 10:55:21 +0100 Subject: [PATCH 013/428] compiler - literals, let, macros, function call --- src/contrib/triple_store.clj | 48 +++ src/hyperfiddle/electric/impl/compiler.clj | 211 ---------- src/hyperfiddle/electric/impl/lang_de.cljc | 43 -- src/hyperfiddle/electric/impl/runtime_de.cljc | 4 +- src/hyperfiddle/electric_local_def_de.cljc | 20 + test/contrib/triple_store_test.clj | 12 + .../electric/impl/expand_de_test.cljc | 26 +- test/hyperfiddle/electric_compiler_test.clj | 383 ++++++++++-------- 8 files changed, 304 insertions(+), 443 deletions(-) create mode 100644 src/contrib/triple_store.clj delete mode 100644 src/hyperfiddle/electric/impl/compiler.clj delete mode 100644 src/hyperfiddle/electric/impl/lang_de.cljc create mode 100644 src/hyperfiddle/electric_local_def_de.cljc create mode 100644 test/contrib/triple_store_test.clj diff --git a/src/contrib/triple_store.clj b/src/contrib/triple_store.clj new file mode 100644 index 000000000..d7a656c6a --- /dev/null +++ b/src/contrib/triple_store.clj @@ -0,0 +1,48 @@ +(ns contrib.triple-store + (:require [dom-top.core :refer [loopr]])) + +;; ts - triple store +;; e - entity (id of entity) +;; a - attribute (key of map) +;; v - value (val of map) +;; o - options +;; nd - node, the entity map +;; ch - cache + +;; [{:db/id 1, :foo 1, :bar 1} +;; {:db/id 2, :foo 1, :bar 2}] +;; eav 1 :foo -> 1 +;; ave :foo 1 -> (sorted-set 1 2) <- sorted so e.g. :parent e is well ordered +;; vea 1 1 -> #{:foo :bar} +(defrecord TripleStore [o eav ave vea]) + +(defn ->ts ([] (->ts {})) ([o] (->TripleStore o {} {} {}))) + +(defn add [ts nd] + (let [e (get nd :db/id) + [eav ave vea] + (loopr [eav (:eav ts), ave (:ave ts), vea (:vea ts)] + [[a v] nd] + (recur (update eav e assoc a v) + (update ave a update v (fnil conj (sorted-set)) e) + (update vea v update e (fnil conj #{}) a)))] + (->TripleStore (:o ts) eav ave vea))) + +(defn upd [ts e a f] + (let [v0 (-> ts :eav (get e) (get a)) + eav (update (:eav ts) e update a f) + v1 (-> eav (get e) (get a)) + ave (update (:ave ts) a update v1 (fnil conj (sorted-set)) e) + ave (cond-> ave (contains? (get ave a) v0) (update a update v0 disj e)) + vea (update (:vea ts) v1 update e (fnil conj #{}) a) + vea (cond-> vea (contains? (get vea v0) e) (update v0 update e disj a))] + (->TripleStore (:o ts) eav ave vea))) + +(defn get-entity [ts e] (get (:eav ts) e)) + +(defn ->datoms [ts] + (loopr [datoms (transient [])] + [[e av] (:eav ts) + [a v] av] + (recur (conj! datoms [e a v])) + (persistent! datoms))) diff --git a/src/hyperfiddle/electric/impl/compiler.clj b/src/hyperfiddle/electric/impl/compiler.clj deleted file mode 100644 index 86c346450..000000000 --- a/src/hyperfiddle/electric/impl/compiler.clj +++ /dev/null @@ -1,211 +0,0 @@ -(ns hyperfiddle.electric.impl.compiler - (:require [cljs.analyzer :as cljs-ana] - [cljs.core] - [cljs.env] - [contrib.assert :as ca] - [contrib.debug] - [hyperfiddle.electric :as-alias e] - [hyperfiddle.electric.impl.runtime-de :as r] - [hyperfiddle.rcf :as rcf :refer [tests]])) - -(defn- fn-> [f a] (fn [o] (f o a))) - -(declare -expand-all-in-try) - -(defn resolve-cljs [env sym] - (when (not= '. sym) - (let [!found? (volatile! true) - resolved (binding [cljs-ana/*cljs-warnings* (assoc cljs-ana/*cljs-warnings* :undeclared-ns false)] - (cljs-ana/resolve-var env sym - (fn [env prefix suffix] - (cljs-ana/confirm-var-exists env prefix suffix - (fn [_ _ _] (vreset! !found? false)))) nil))] - (when (and resolved @!found? (not (:macro resolved))) - ;; If the symbol is unqualified and is from a different ns (through e.g. :refer) - ;; cljs returns only :name and :ns. We cannot tell if it resolved to a macro. - ;; We recurse with the fully qualified symbol to get all the information. - ;; The symbol can also resolve to a local in which case we're done. - ;; TODO how to trigger these in tests? - (if (and (simple-symbol? sym) (not= (:ns env) (:ns resolved)) (not= :local (:op resolved))) - (recur env (ca/check qualified-symbol? (:name resolved) {:sym sym, :resolved resolved})) - resolved))))) - -(defn serialized-require [sym] - ;; we might be expanding clj code before the ns got loaded (during cljs compilation) - ;; to correctly lookup vars the ns needs to be loaded - ;; since shadow-cljs compiles in parallel we need to serialize the requires - (when-not (get (loaded-libs) sym) - (try (#'clojure.core/serialized-require sym) ; try bc it can be cljs file - (catch java.io.FileNotFoundException _)))) - -(defn macroexpand-clj [o] (serialized-require (ns-name *ns*)) (macroexpand-1 o)) - -(defn expand-referred-or-local-macros [o cljs-macro-env] - ;; (:require [some.ns :refer [some-macro]]) - ;; `some-macro` might be a macro and cljs expander lookup fails to find it - ;; another case is when a cljc file :require-macros itself without refering the macros - (if-some [vr (when (simple-symbol? (first o)) (resolve (first o)))] - (if (and (not (class? vr)) (.isMacro ^clojure.lang.Var vr)) - (apply vr o cljs-macro-env (rest o)) - o) - o)) - -(defn expand-macro [env o] - (let [[f & args] o, n (name f), e (dec (count n))] - (if (= "." n) - o - (if (and (not= ".." n) (= \. (nth n e))) - `(new ~(symbol (namespace f) (subs n 0 e)) ~@args) - (if (some? (re-find #"^\.[^.]" n)) - (list* '. (first args) (symbol (subs n 1)) (rest args)) - (if (= :cljs (get (::peers env) (::current env))) - (let [cljs-env (::cljs-env env)] - (if (resolve-cljs cljs-env f) - o - (let [cljs-macro-env (cond-> cljs-env (::ns cljs-env) (assoc :ns (::ns cljs-env)))] - (if-some [expander (cljs-ana/get-expander f cljs-macro-env)] - (apply expander o cljs-macro-env args) - (expand-referred-or-local-macros o cljs-macro-env))))) - (macroexpand-clj o))))))) - -(defn find-local [env sym] (find (:locals env) sym)) -(defn add-local [env sym] (update env :locals assoc sym ::unknown)) - -(def ^:dynamic *electric* true) - -(defn ?meta [metao o] - (if (instance? clojure.lang.IObj o) - (cond-> o (meta metao) (vary-meta #(merge (meta metao) %))) - o)) - -(defn -expand-all [o env] - (cond - (and (seq? o) (seq o)) - (if (find-local env (first o)) - (list* (first o) (mapv (fn-> -expand-all env) (rest o))) - (case (first o) - ;; (ns ns* deftype* defrecord* var) - - (do) (if (nnext o) - (let [body (mapv #(list `e/drain %) (next o)) - body (conj (pop body) (second (peek body)))] ; last arg isn't drained - (recur (?meta o (cons `e/amb body)) env)) - (recur (?meta o (second o)) env)) - - (let*) (let [[_ bs & body] o - [bs2 env2] (reduce - (fn [[bs env] [sym v]] - [(conj bs sym (-expand-all v env)) (add-local env sym)]) - [[] env] - (partition-all 2 bs))] - (?meta o (list* 'let* bs2 (mapv (fn-> -expand-all env2) body)))) - - (loop*) (let [[_ bs & body] o - [bs2 env2] (reduce - (fn [[bs env] [sym v]] - [(conj bs sym (-expand-all v env)) (add-local env sym)]) - [[] env] - (partition-all 2 bs))] - (recur (?meta o `(binding [r/rec (::closure (let [~@(interleave (take-nth 2 bs2) r/arg-sym)] - ~@body))] - (new r/rec ~@(take-nth 2 (next bs2))))) env2)) - - (case clojure.core/case) - (let [[_ v & clauses] o - has-default-clause? (odd? (count clauses)) - clauses2 (cond-> clauses has-default-clause? butlast) - xpand (fn-> -expand-all env)] - (?meta o (list* 'case (xpand v) - (cond-> (into [] (comp (partition-all 2) (mapcat (fn [[match expr]] [match (xpand expr)]))) - clauses2) - has-default-clause? (conj (xpand (last clauses))))))) - - (quote) o - - (fn*) (let [[?name more] (if (symbol? (second o)) [(second o) (nnext o)] [nil (next o)]) - arities (cond-> more (vector? (first more)) list)] - (?meta o (apply list - (into (if ?name ['fn* ?name] ['fn*]) - (map (fn [[syms & body]] - (binding [*electric* false] - (list* syms (mapv (fn-> -expand-all (reduce add-local env syms)) body))))) - arities)))) - - (letfn*) (let [[_ bs & body] o - env2 (reduce add-local env (take-nth 2 bs)) - xpand (fn-> -expand-all env2) - bs2 (into [] (comp (partition-all 2) - (mapcat (fn [[sym v]] [sym (binding [*electric* false] (xpand v))]))) - bs)] - (?meta o `(let* [~(vec (take-nth 2 bs2)) (::letfn ~bs2)] ~@(mapv xpand body)))) - - (try) (throw (ex-info "try is TODO" {:o o})) #_(list* 'try (mapv (fn-> -all-in-try env) (rest o))) - - (binding clojure.core/binding) - (let [[_ bs & body] o] - (?meta o (list* 'binding (into [] (comp (partition-all 2) (mapcat (fn [[sym v]] [sym (-expand-all v env)]))) bs) - (mapv #(-expand-all % env) body)))) - - (set!) (if *electric* - (recur (?meta o `((fn* [v#] (set! ~(nth o 1) v#)) ~(nth o 2))) env) - (?meta o (list 'set! (-expand-all (nth o 1) env) (-expand-all (nth o 2) env)))) - - (::toggle) (concat (take 3 o) - (let [env (assoc env ::current (second o))] - (mapv (fn-> -expand-all env) (drop 3 o)))) - - #_else - (if (symbol? (first o)) - (let [o2 (expand-macro env o)] - (if (identical? o o2) - (?meta o (list* (first o) (mapv (fn-> -expand-all env) (rest o)))) - (recur (?meta o o2) env))) - (?meta o (list* (-expand-all (first o) env) (mapv (fn-> -expand-all env) (next o))))))) - - (map-entry? o) (clojure.lang.MapEntry. (-expand-all (key o) env) (-expand-all (val o) env)) - (coll? o) (?meta (meta o) (into (empty o) (map (fn-> -expand-all env)) o)) - :else o)) - -#_(defn -expand-all-in-try [o env] - (if (seq? o) - (if (find-local env (first o)) - (list* (first o) (mapv (fn-> -expand-all env) (rest o))) - (case (first o) - (catch) (let [[_ typ sym & body] o, env2 (add-local env sym)] - (list* 'catch typ sym (mapv (fn-> -expand-all env2) body))) - #_else (-expand-all o env))) - (-expand-all o env))) - -;; :js-globals -> cljs env -;; :locals -> cljs or electric env -;; ::lang/peers -> electric env -;; if ::current = :clj expand with clj environment -;; if ::current = :cljs expand with cljs environment - -(defn enrich-for-require-macros-lookup [cljs-env nssym] - (if-some [src (cljs-ana/locate-src nssym)] - (let [ast (:ast (with-redefs [cljs-ana/missing-use-macro? (constantly nil)] - (binding [cljs-ana/*passes* []] - (cljs-ana/parse-ns src {:load-macros true, :restore false}))))] - ;; we parsed the ns form without `ns-side-effects` because it triggers weird bugs - ;; this means the macro nss from `:require-macros` might not be loaded - (run! serialized-require (-> ast :require-macros vals set)) - (assoc cljs-env ::ns ast)) - cljs-env)) - -(tests "enrich of clj source file is noop" - (cljs.env/ensure (enrich-for-require-macros-lookup {:a 1} 'clojure.core)) := {:a 1}) - -;; takes an electric environment, which can be clj or cljs -;; if it's clj we need to prep the cljs environment (cljs.env/ensure + cljs.analyzer/empty-env with patched ns) -;; we need to be able to swap the environments infinite number of times - -(defn ->common-env [env] - (if (::cljs-env env) - env - (assoc env ::cljs-env - (if (contains? env :js-globals) - env - (cond-> (cljs.analyzer/empty-env) (:ns env) (enrich-for-require-macros-lookup (:ns env))))))) - -(defn expand-all [env o] (cljs.env/ensure (-expand-all o (->common-env env)))) diff --git a/src/hyperfiddle/electric/impl/lang_de.cljc b/src/hyperfiddle/electric/impl/lang_de.cljc deleted file mode 100644 index 3e972a846..000000000 --- a/src/hyperfiddle/electric/impl/lang_de.cljc +++ /dev/null @@ -1,43 +0,0 @@ -(ns hyperfiddle.electric.impl.lang-de - (:require [hyperfiddle.electric.impl.runtime-de :as r] - [hyperfiddle.incseq :as i])) - -(def ^:dynamic *tier*) - -(defn invoke [f & args] - (apply f args)) - -(defmacro defs [& exprs] - `(fn [tier# id#] - (binding [*tier* tier#] - (case id# - ~(interleave (range) exprs))))) - -(defmacro static [expr] - `(r/pure ~expr)) - -(defmacro ap [& args] - `(i/latest-product invoke ~@args)) - -(defmacro free [id] - `(r/ctor-free (r/tier-ctor *tier*) ~id)) - -(defmacro local [id] - `(r/tier-local *tier* ~id)) - -(defmacro remote [id] - `(r/tier-local *tier* ~id)) - -(defmacro ctor [slots output & free] - `(r/pure (r/peer-ctor (r/tier-peer *tier*) ~slots ~output - (doto (object-array ~(count free)) - ~@(map-indexed (partial list `aset) free))))) - -(defmacro call [id] - `(i/latest-concat (r/tier-slot *tier* ~id))) - -(defmacro join [expr] - `(i/latest-concat ~expr)) - -(defmacro var [id] - `(r/pure (r/peer-var (r/tier-peer *tier*) (quote ~id)))) \ No newline at end of file diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 6afe188f7..88fe8428a 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -3,6 +3,8 @@ [missionary.core :as m]) #?(:clj (:import (clojure.lang IFn IDeref)))) +(def ^:dynamic *tier*) + (def ^{::type ::node, :doc "for loop/recur impl"} rec) #?(:clj @@ -242,4 +244,4 @@ Returns a peer definition from given node definitions and root constructor. (object-array 0) {}))) #(prn :success %) #(prn :failure %)) - peer)))) \ No newline at end of file + peer)))) diff --git a/src/hyperfiddle/electric_local_def_de.cljc b/src/hyperfiddle/electric_local_def_de.cljc new file mode 100644 index 000000000..e4a4d5b1a --- /dev/null +++ b/src/hyperfiddle/electric_local_def_de.cljc @@ -0,0 +1,20 @@ +(ns hyperfiddle.electric-local-def-de + (:refer-clojure :exclude [def defn]) + #?(:cljs (:require-macros hyperfiddle.electric-local-def-de)) + (:require [clojure.core :as cc] + [contrib.cljs-target] + [hyperfiddle.electric.impl.lang-de :as lang])) + +(cc/defn ->local-config [env] + (let [p (if (:js-globals env) :cljs :clj)] {::lang/peers {:client p, :server p}, ::lang/current :server})) + +(cc/defn ->single-peer-config [env] + (let [p (if (and (:js-globals env) (contrib.cljs-target/do-nodejs true)) :client :server)] + {::lang/peers {p (if (:js-globals env) :cljs :clj)}, ::lang/current p, ::lang/me p})) + +(defmacro compile-client [form] + (let [env (merge &env (->local-config &env) {::lang/me :client})] + `(lang/compile '~form ~env ))) +(defmacro compile-server [form] + (let [env (merge &env (->local-config &env) {::lang/me :server})] + `(lang/compile '~form ~env ))) diff --git a/test/contrib/triple_store_test.clj b/test/contrib/triple_store_test.clj new file mode 100644 index 000000000..a1e0e9784 --- /dev/null +++ b/test/contrib/triple_store_test.clj @@ -0,0 +1,12 @@ +(ns contrib.triple-store-test + (:require [contrib.triple-store :as ts] + [hyperfiddle.rcf :as rcf :refer [tests]])) + +(tests + (-> (ts/->ts) (ts/add {:db/id 1, :foo 2}) (ts/get-entity 1) :foo) := 2 + (-> (ts/->ts) (ts/add {:db/id 1, :foo 1}) (ts/add {:db/id 2, :foo 1}) :ave :foo (get 1)) := #{1 2} + (-> (ts/->ts) (ts/add {:db/id 1, :foo 2, :bar 2}) :vea (get 2) (get 1)) := #{:foo :bar} + (-> (ts/->ts) (ts/add {:db/id 1, :foo 2, :bar 2}) (ts/get-entity 1) (select-keys [:foo :bar :baz])) := {:foo 2, :bar 2} + + (-> (ts/->ts) (ts/add {:db/id '_}) (ts/upd '_ :x (fnil inc 0)) (ts/upd '_ :x (fnil inc 0)) (ts/get-entity '_) :x) := 2 + ) diff --git a/test/hyperfiddle/electric/impl/expand_de_test.cljc b/test/hyperfiddle/electric/impl/expand_de_test.cljc index 1d0519d7e..b5313c7b3 100644 --- a/test/hyperfiddle/electric/impl/expand_de_test.cljc +++ b/test/hyperfiddle/electric/impl/expand_de_test.cljc @@ -41,6 +41,14 @@ (all '(do (-> 1 inc))) := '(inc 1) (has-line-meta? (all '(do (-> 1 inc)))) := true + "implicit `do`s expand. Electric is pure" + (all '(let [] 1 2)) := (all '(let [] (do 1 2))) + (all '(loop [] 1 2)) := (all '(loop [] (do 1 2))) + (all '(fn [] 1 2)) := (all '(fn [] (do 1 2))) + (all '(letfn [] 1 2)) := (all '(letfn [] (do 1 2))) + (all '(binding [] 1 2)) := (all '(binding [] (do 1 2))) + + (all '(inc (let [x 1] x))) := '(inc (let* [x 1] x)) (all '(let [with-open inc] (with-open 1))) := '(let* [with-open inc] (with-open 1)) @@ -68,9 +76,9 @@ (-> (->> x) inc)))] x := '(let* [[foo bar baz ->>] (:hyperfiddle.electric.impl.compiler/letfn [foo (fn* foo ([with-open] (with-open 1))) - bar (fn* bar ([x] (inc x))) - baz (fn* baz ([x] (->> x))) - ->> (fn* ->> ([x] x))])] + bar (fn* bar ([x] (inc x))) + baz (fn* baz ([x] (->> x))) + ->> (fn* ->> ([x] x))])] (inc (->> x))) (has-line-meta? x) := true) @@ -170,10 +178,10 @@ ;; doesn't work in `tests` #?(:clj - (when-not (= '(let* [x 1]) - (binding [*ns* (create-ns 'hyperfiddle.electric.impl.expand-unloaded)] - (c/expand-all {::c/peers {:client :cljs, :server :clj} - ::c/current :server, ::c/me :client - :ns 'hyperfiddle.electric.impl.expand-unloaded} - '(let [x 1])))) + (when-not (= 'let* (first + (binding [*ns* (create-ns 'hyperfiddle.electric.impl.expand-unloaded)] + (c/expand-all {::c/peers {:client :cljs, :server :clj} + ::c/current :server, ::c/me :client + :ns 'hyperfiddle.electric.impl.expand-unloaded} + '(let [x 1]))))) (throw (ex-info "clj macroexpansion for unloaded ns fails" {})))) diff --git a/test/hyperfiddle/electric_compiler_test.clj b/test/hyperfiddle/electric_compiler_test.clj index 36f180144..1005ad92b 100644 --- a/test/hyperfiddle/electric_compiler_test.clj +++ b/test/hyperfiddle/electric_compiler_test.clj @@ -3,7 +3,10 @@ [hyperfiddle.incseq :as i] [hyperfiddle.rcf :as rcf :refer [tests]] [hyperfiddle.electric.impl.lang-de :as lang] - [hyperfiddle.electric.impl.runtime-de :as r])) + [hyperfiddle.electric.impl.runtime-de :as r] + [hyperfiddle.electric-local-def-de :as l] + [hyperfiddle.incseq :as i] + [missionary.core :as m])) ;; tests that turn electric code into clojure code ;; basically no IR, we emit clojure code directly @@ -16,215 +19,237 @@ ;; it returns the same structure as r/defs ;; but instead of the definitions it contains the metadata #_(defn r/apply [..] - (try (apply f args) - (catch Throwable e (find-source-map-info path)))) + (try (apply f args) + (catch Throwable e (find-source-map-info path)))) (tests + (l/compile-client 1) := `(r/peer (lang/r-defs (lang/r-static 1)) [] 0) + (l/compile-server 1) := `(r/peer (lang/r-defs (lang/r-static 1)) [] 0) + + (l/compile-server (prn "hello world")) := `(r/peer (lang/r-defs (lang/r-ap (lang/r-static ~'prn) (lang/r-static "hello world"))) [] 0) + (l/compile-client (let [x "Hello world", y "Hello world"] [x y])) + := `(r/peer (lang/r-defs + (lang/r-static "Hello world") + (lang/r-static "Hello world") + (lang/r-ap (lang/r-static vector) (lang/r-local 0) (lang/r-local 1))) [] 0) + + (l/compile-client (concat (let [x 1] [x x]) (let [y 2] [y y]))) + := `(r/peer (lang/r-defs + (lang/r-static 1) + (lang/r-static 2) + (lang/r-ap (lang/r-static ~'concat) + (lang/r-ap (lang/r-static vector) (lang/r-local 0) (lang/r-local 0)) + (lang/r-ap (lang/r-static vector) (lang/r-local 1) (lang/r-local 1)))) [] 0) + + (l/compile-client (i/fixed (m/watch (atom 0)))) + := `(r/peer (lang/r-defs + (lang/r-ap (lang/r-static ~'i/fixed) + (lang/r-ap (lang/r-static ~'m/watch) + (lang/r-ap (lang/r-static ~'atom) + (lang/r-static 0))))) [] 0) + + ) +(comment ;; (defn lang/compile [env form] - (lang/compile-client {} 1) + (l/compile-client 1) ;; r/defs takes & flows with an implicit context (managed in runtime, thread-local or such) ;; context - path of the node you're constructing in the call stack := `(r/peer - (lang/defs - (lang/static 1)) + (lang/r-defs + (lang/r-static 1)) [] 0) ;; transfer - (lang/compile-client {} - `(e/client "Hello world")) := + (l/compile-client (e/client "Hello world")) := `(r/peer - (lang/defs - (lang/static "Hello world")) - [] 0) - (lang/compile-client {} - `(e/client - (let [x "Hello world" - y "Hello world"] - [x y]))) := - `(r/peer - (lang/defs - (lang/static "Hello world") - (lang/static "Hello world") - (lang/ap (lang/static vector) (lang/local 0) (lang/local 1))) - [] 2) - - (lang/compile-server {} - `(e/client "Hello world")) := - `(r/peer - (lang/defs - (lang/remote 0)) ;; 0 refers to client's r/defs + (lang/r-defs + (lang/r-static "Hello world")) [] 0) + (l/compile-client (e/client + (let [x "Hello world" + y "Hello world"] + [x y]))) + := `(r/peer + (lang/r-defs + (lang/r-static "Hello world") + (lang/r-static "Hello world") + (lang/r-ap (lang/r-static vector) (lang/r-local 0) (lang/r-local 1))) + [] 2) + + (l/compile-server (e/client "Hello world")) + := `(r/peer + (lang/r-defs + (lang/r-remote 0)) ;; 0 refers to client's r/defs + [] 0) ;; function application - (lang/compile-client {} - `(e/client (prn "Hello world"))) := - `(r/peer - (lang/defs - (lang/ap (lang/static prn) (lang/static "Hello world"))) - [] 0) + (l/compile-client (e/client (prn "Hello world"))) + := `(r/peer + (lang/r-defs + (lang/r-ap (lang/r-static prn) (lang/r-static "Hello world"))) + [] 0) ;; lexical scope - (lang/compile-client {} - `(e/client (let [a :foo] [a a]))) := - `(r/peer - (lang/defs - (lang/static :foo) - (lang/ap (lang/static vector) (lang/local 1) (lang/local 1))) - [] 1) - - (lang/compile-client {} - `(e/client - (let [a (e/server :foo)] - (e/server (prn a))))) := - `(r/peer - (lang/defs - (lang/remote 0)) - [] 0) - (lang/compile-server {} - `(e/client - (let [a (e/server :foo)] - (e/server (prn a))))) := - `(r/peer - (lang/defs - (lang/static :foo) - (lang/ap (lang/static prn) (lang/local 0))) - [] 1) + (l/compile-client (e/client (let [a :foo] [a a]))) + := `(r/peer + (lang/r-defs + (lang/r-static :foo) + (lang/r-ap (lang/r-static vector) (lang/r-local 1) (lang/r-local 1))) + [] 1) + + (l/compile-client (e/client + (let [a (e/server :foo)] + (e/server (prn a))))) + := `(r/peer + (lang/r-defs + (lang/r-remote 0)) + [] 0) + (l/compile-server (e/client + (let [a (e/server :foo)] + (e/server (prn a))))) + := `(r/peer + (lang/r-defs + (lang/r-static :foo) + (lang/r-ap (lang/r-static prn) (lang/r-local 0))) + [] 1) ;; join (e/watch !x) ;; (i/fixed continuous-flow) -> incremental sequence of 1 element - (lang/compile-client {} - `(e/client (e/join (i/fixed (m/watch !x))))) := - `(r/peer - (lang/defs - (lang/join (lang/ap (lang/static i/fixed) - (lang/ap (lang/static m/watch) - (lang/static !x))))) - [] 0) + (l/compile-client `(e/client (e/join (i/fixed (m/watch !x))))) + := `(r/peer + (lang/r-defs + (lang/r-join (lang/r-ap (lang/r-static i/fixed) + (lang/r-ap (lang/r-static m/watch) + (lang/r-static !x))))) + [] 0) ;; pure (get the incseq of an expression) (e/pure (e/join x)) is (e/join (e/pure x)) is x - (lang/compile-client {} - `(e/client (e/pure :foo))) := - `(r/peer - (lang/defs - (lang/static (lang/static :foo))) - [] 0) + (l/compile-client (e/client (e/pure :foo))) + := `(r/peer + (lang/r-defs + (lang/r-static (lang/r-static :foo))) + [] 0) ;; ctor (e/fn [] foo) -> (e/ctor foo) (previously ::c/closure) - (lang/compile-client {} - `(e/client (e/ctor :foo))) := - `(r/peer - (lang/defs - (lang/static :foo) - (lang/ctor [] 0)) - [] 1) + (l/compile-client (e/client (e/ctor :foo))) + := `(r/peer + (lang/r-defs + (lang/r-static :foo) + (lang/r-ctor [] 0)) + [] 1) ;; call (aka new, but with no argument and only for ctors) - (lang/compile-client {} - `(e/client (e/call (e/ctor :foo)))) := - `(r/peer - (lang/defs - (lang/static :foo) - (lang/ctor [] 0) - (lang/call 0)) - [1] 2) + (l/compile-client (e/client (e/call (e/ctor :foo)))) + := `(r/peer + (lang/r-defs + (lang/r-static :foo) + (lang/r-ctor [] 0) + (lang/r-call 0)) + [1] 2) ;; lexical closure - (lang/compile-client {} - `(e/client - (let [a :foo] - (e/call (e/ctor a))))) := - `(r/peer - (lang/defs - (lang/static :foo) - (lang/free 0) - (lang/ctor [] 1 (lang/local 0)) - (lang/call 0)) - [2] 3) - - (lang/compile-client {} - `(e/client - (let [a :foo] - (e/call (e/ctor (e/ctor a)))))) := - `(r/peer - (lang/defs - (lang/static :foo) - (lang/free 0) - (lang/ctor [] 1 (lang/free 0)) - (lang/ctor [] 2 (lang/local 0)) - (lang/call 0)) - [3] 4) + (l/compile-client (e/client + (let [a :foo] + (e/call (e/ctor a))))) + := `(r/peer + (lang/r-defs + (lang/r-static :foo) + (lang/r-free 0) + (lang/r-ctor [] 1 (lang/r-local 0)) + (lang/r-call 0)) + [2] 3) + + (l/compile-client (e/client + (let [a :foo] + (e/call (e/ctor (e/ctor a)))))) + := `(r/peer + (lang/r-defs + (lang/r-static :foo) + (lang/r-free 0) + (lang/r-ctor [] 1 (lang/r-free 0)) + (lang/r-ctor [] 2 (lang/r-local 0)) + (lang/r-call 0)) + [3] 4) ;; conditionals - (lang/compile-client {} - `(e/client (case :x nil :y :z))) := - `(r/peer - (lang/defs - (lang/static :y) - (lang/static :z) - (lang/ap (lang/ap (lang/static hash-map) - (lang/static nil) (lang/ctor [] 0)) - (lang/static :x) (lang/ctor [] 1)) - (lang/call 0)) - [2] 3) + (l/compile-client `(e/client (case :x nil :y :z))) + := `(r/peer + (lang/r-defs + (lang/r-static :y) + (lang/r-static :z) + (lang/r-ap (lang/r-ap (lang/r-static hash-map) + (lang/r-static nil) (lanr-ctoror [] 0)) + (lang/r-static :x) (lanr-ctoror [] 1)) + (lang/r-call 0)) + [2] 3) ;; var (e/def x) - (lang/compile-client {} `(e/client (var x))) := - `(r/peer - (lang/defs - (lang/var x)) - [] 0) + (l/compile-client (e/client (var x))) + := `(r/peer + (lang/r-defs + (lang/r-var x)) + [] 0) - (lang/compile-client {} - `(let [a :foo, b :bar, c :baz] - [(e/ctor [a b]) (e/ctor [b c])])) := - `(r/peer - (lang/defs - (lang/static :foo) - (lang/static :bar) - (lang/static :baz) - (lang/ap (lang/static vector) - (lang/free 0) (lang/free 1)) - (lang/ap (lang/static vector) - (lang/free 0) (lang/free 1)) - (lang/ap (lang/static vector) - (lang/ctor 3 (lang/local 0) (lang/local 1)) - (lang/ctor 4 (lang/local 1) (lang/local 2)))) - [] 5) - - (lang/compile-client {} - `(new (e/fn Foo [] (Foo.)))) := - `(r/peer - (fn [tier id] - (case id - 0 (r/ctor-free (r/tier-ctor tier) 0) - 1 (let [free (object-array 1) - ctor (r/peer-ctor (r/tier-peer tier) [] 0 free)] - (aset free 0 (r/pure ctor)) - (r/pure ctor)) - 2 (i/latest-concat (r/tier-slot tier 0)))) - [1] 2) - - (lang/compile-client {} - `(e/letfn [(Foo [] (Bar.)) - (Bar [] (Foo.))] - (Foo.))) := - `(r/peer - (fn [tier id] - (case id - 0 (r/ctor-free (r/tier-ctor tier) 1) - 1 (r/ctor-free (r/tier-ctor tier) 0) - 2 (let [Foo-free (object-array 2) - Foo-ctor (r/peer-ctor (r/tier-peer tier) [] 0 Foo-free) - Bar-free (object-array 2) - Bar-ctor (r/peer-ctor (r/tier-peer tier) [] 1 Bar-free)] - (aset Foo-free 0 (r/pure Foo-ctor)) - (aset Foo-free 1 (r/pure Bar-ctor)) - (aset Bar-free 0 (r/pure Foo-ctor)) - (aset Bar-free 1 (r/pure Bar-ctor)) - (r/pure {:Foo Foo-ctor :Bar Bar-ctor})) - 3 (i/latest-product :Foo (r/tier-local tier 0)) - 4 (i/latest-concat (r/tier-slot tier 0)))) - [3] 4) + (l/compile-client (let [a :foo, b :bar, c :baz] + [(e/ctor [a b]) (e/ctor [b c])])) + := `(r/peer + (lang/r-defs + (lang/r-static :foo) + (lang/r-static :bar) + (lang/r-static :baz) + (lang/r-ap (lang/r-static vector) + (lang/r-free 0) (lang/r-free 1)) + (lang/r-ap (lang/r-static vector) + (lang/r-free 0) (lang/r-free 1)) + (lang/r-ap (lang/r-static vector) + (lang/r-ctor 3 (lang/r-local 0) (lang/r-local 1)) + (lang/r-ctor 4 (lang/r-local 1) (lang/r-local 2)))) + [] 5) + + (l/compile-client (new (e/fn Foo [] (Foo.)))) + := `(r/peer + (fn [tier id] + (case id + 0 (r/ctor-free (r/tier-ctor tier) 0) + 1 (let [free (object-array 1) + ctor (r/peer-ctor (r/tier-peer tier) [] 0 free)] + (aset free 0 (r/pure ctor)) + (r/pure ctor)) + 2 (i/latest-concat (r/tier-slot tier 0)))) + [1] 2) + + (l/compile-client (e/letfn [(Foo [] (Bar.)) + (Bar [] (Foo.))] + (Foo.))) + := `(r/peer + (fn [tier id] + (case id + 0 (r/ctor-free (r/tier-ctor tier) 1) + 1 (r/ctor-free (r/tier-ctor tier) 0) + 2 (let [Foo-free (object-array 2) + Foo-ctor (r/peer-ctor (r/tier-peer tier) [] 0 Foo-free) + Bar-free (object-array 2) + Bar-ctor (r/peer-ctor (r/tier-peer tier) [] 1 Bar-free)] + (aset Foo-free 0 (r/pure Foo-ctor)) + (aset Foo-free 1 (r/pure Bar-ctor)) + (aset Bar-free 0 (r/pure Foo-ctor)) + (aset Bar-free 1 (r/pure Bar-ctor)) + (r/pure {:Foo Foo-ctor :Bar Bar-ctor})) + 3 (i/latest-product :Foo (r/tier-local tier 0)) + 4 (i/latest-concat (r/tier-slot tier 0)))) + [3] 4) + + (l/compile-client (let [a :foo, b :bar, c :baz] + [(e/ctor [a b]) (e/ctor [b c])])) + := `(r/defs + (r/ap (r/static vector) + (r/ctor 4 (r/local 1) (r/local 2)) + (r/ctor 5 (r/local 2) (r/local 3))) + (r/static :foo) + (r/static :bar) + (r/static :baz) + (r/ap (r/static vector) (r/free 0) (r/free 1)) + (r/ap (r/static vector) (r/free 0) (r/free 1))) ) From 7b6c277b1db1ef0637874ad2459d73464705752e Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 20 Dec 2023 15:00:50 +0100 Subject: [PATCH 014/428] fix tests, commit forgotten file --- src/hyperfiddle/electric/impl/lang_de.clj | 555 ++++++++++++++++++ .../electric/impl/expand_de_test.cljc | 10 +- 2 files changed, 560 insertions(+), 5 deletions(-) create mode 100644 src/hyperfiddle/electric/impl/lang_de.clj diff --git a/src/hyperfiddle/electric/impl/lang_de.clj b/src/hyperfiddle/electric/impl/lang_de.clj new file mode 100644 index 000000000..ef53a3d1f --- /dev/null +++ b/src/hyperfiddle/electric/impl/lang_de.clj @@ -0,0 +1,555 @@ +(ns hyperfiddle.electric.impl.lang-de + (:refer-clojure :exclude [compile]) + (:require [cljs.analyzer :as cljs-ana] + [cljs.core] + [cljs.env] + [clojure.string :as str] + [contrib.assert :as ca] + [contrib.debug] + [contrib.triple-store :as ts] + [dom-top.core :refer [loopr]] + [hyperfiddle.electric :as-alias e] + [hyperfiddle.electric.impl.analyzer :as ana] + [hyperfiddle.electric.impl.runtime-de :as r] + [hyperfiddle.incseq :as i] + [hyperfiddle.rcf :as rcf :refer [tests]])) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; HIGH-LEVEL RUNTIME API ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defn r-invoke [f & args] + (apply f args)) + +(defmacro r-defs [& exprs] + `(fn [tier# id#] + (binding [r/*tier* tier#] + (case id# + ~(interleave (range) exprs))))) + +(defmacro r-static [expr] + `(r/pure ~expr)) + +(defmacro r-ap [& args] + `(i/latest-product r-invoke ~@args)) + +(defmacro r-free [id] + `(r/ctor-free (r/tier-ctor r/*tier*) ~id)) + +(defmacro r-local [id] + `(r/tier-local r/*tier* ~id)) + +(defmacro r-remote [id] + `(r/tier-local r/*tier* ~id)) + +(defmacro r-ctor [slots output & free] + `(r/pure (r/peer-ctor (r/tier-peer r/*tier*) ~slots ~output + (doto (object-array ~(count free)) + ~@(map-indexed (partial list `aset) free))))) + +(defmacro r-call [id] + `(i/latest-concat (r/tier-slot r/*tier* ~id))) + +(defmacro r-join [expr] + `(i/latest-concat ~expr)) + +(defmacro r-var [id] + `(r/pure (r/peer-var (r/tier-peer r/*tier*) (quote ~id)))) + +;;;;;;;;;;;;;;;; +;;; EXPANDER ;;; +;;;;;;;;;;;;;;;; + +(defn- fn-> [f a] (fn [o] (f o a))) + +(declare -expand-all-in-try) + +(defn resolve-cljs [env sym] + (when (not= '. sym) + (let [!found? (volatile! true) + resolved (binding [cljs-ana/*cljs-warnings* (assoc cljs-ana/*cljs-warnings* :undeclared-ns false)] + (cljs-ana/resolve-var env sym + (fn [env prefix suffix] + (cljs-ana/confirm-var-exists env prefix suffix + (fn [_ _ _] (vreset! !found? false)))) nil))] + (when (and resolved @!found? (not (:macro resolved))) + ;; If the symbol is unqualified and is from a different ns (through e.g. :refer) + ;; cljs returns only :name and :ns. We cannot tell if it resolved to a macro. + ;; We recurse with the fully qualified symbol to get all the information. + ;; The symbol can also resolve to a local in which case we're done. + ;; TODO how to trigger these in tests? + (if (and (simple-symbol? sym) (not= (:ns env) (:ns resolved)) (not= :local (:op resolved))) + (recur env (ca/check qualified-symbol? (:name resolved) {:sym sym, :resolved resolved})) + resolved))))) + +(defn serialized-require [sym] + ;; we might be expanding clj code before the ns got loaded (during cljs compilation) + ;; to correctly lookup vars the ns needs to be loaded + ;; since shadow-cljs compiles in parallel we need to serialize the requires + (when-not (get (loaded-libs) sym) + (try (#'clojure.core/serialized-require sym) ; try bc it can be cljs file + (catch java.io.FileNotFoundException _)))) + +(defn macroexpand-clj [o] (serialized-require (ns-name *ns*)) (macroexpand-1 o)) + +(defn expand-referred-or-local-macros [o cljs-macro-env] + ;; (:require [some.ns :refer [some-macro]]) + ;; `some-macro` might be a macro and cljs expander lookup fails to find it + ;; another case is when a cljc file :require-macros itself without refering the macros + (if-some [vr (when (simple-symbol? (first o)) (resolve (first o)))] + (if (and (not (class? vr)) (.isMacro ^clojure.lang.Var vr)) + (apply vr o cljs-macro-env (rest o)) + o) + o)) + +(defn expand-macro [env o] + (let [[f & args] o, n (name f), e (dec (count n))] + (if (= "." n) + o + (if (and (not= ".." n) (= \. (nth n e))) + `(new ~(symbol (namespace f) (subs n 0 e)) ~@args) + (if (some? (re-find #"^\.[^.]" n)) + (list* '. (first args) (symbol (subs n 1)) (rest args)) + (if (= :cljs (get (::peers env) (::current env))) + (let [cljs-env (::cljs-env env)] + (if (resolve-cljs cljs-env f) + o + (let [cljs-macro-env (cond-> cljs-env (::ns cljs-env) (assoc :ns (::ns cljs-env)))] + (if-some [expander (cljs-ana/get-expander f cljs-macro-env)] + (apply expander o cljs-macro-env args) + (expand-referred-or-local-macros o cljs-macro-env))))) + (macroexpand-clj o))))))) + +(defn find-local-entry [env sym] (find (:locals env) sym)) +(defn add-local [env sym] (update env :locals assoc sym ::unknown)) + +(def ^:dynamic *electric* true) + +(defn ?meta [metao o] + (if (instance? clojure.lang.IObj o) + (cond-> o (meta metao) (vary-meta #(merge (meta metao) %))) + o)) + +(defn -expand-all [o env] + (cond + (and (seq? o) (seq o)) + (if (find-local-entry env (first o)) + (list* (first o) (mapv (fn-> -expand-all env) (rest o))) + (case (first o) + ;; (ns ns* deftype* defrecord* var) + + (do) (if (nnext o) + (let [body (mapv #(list `e/drain %) (next o)) + body (conj (pop body) (second (peek body)))] ; last arg isn't drained + (recur (?meta o (cons `e/amb body)) env)) + (recur (?meta o (second o)) env)) + + (let*) (let [[_ bs & body] o + [bs2 env2] (reduce + (fn [[bs env] [sym v]] + [(conj bs sym (-expand-all v env)) (add-local env sym)]) + [[] env] + (partition-all 2 bs))] + (?meta o (list 'let* bs2 (-expand-all (?meta body (cons 'do body)) env2)))) + + (loop*) (let [[_ bs & body] o + [bs2 env2] (reduce + (fn [[bs env] [sym v]] + [(conj bs sym (-expand-all v env)) (add-local env sym)]) + [[] env] + (partition-all 2 bs))] + (recur (?meta o `(binding [r/rec (::closure (let [~@(interleave (take-nth 2 bs2) r/arg-sym)] + ~@body))] + (new r/rec ~@(take-nth 2 (next bs2))))) env2)) + + (case clojure.core/case) + (let [[_ v & clauses] o + has-default-clause? (odd? (count clauses)) + clauses2 (cond-> clauses has-default-clause? butlast) + xpand (fn-> -expand-all env)] + (?meta o (list* 'case (xpand v) + (cond-> (into [] (comp (partition-all 2) (mapcat (fn [[match expr]] [match (xpand expr)]))) + clauses2) + has-default-clause? (conj (xpand (last clauses))))))) + + (quote) o + + (fn*) (let [[?name more] (if (symbol? (second o)) [(second o) (nnext o)] [nil (next o)]) + arities (cond-> more (vector? (first more)) list)] + (?meta o (apply list + (into (if ?name ['fn* ?name] ['fn*]) + (map (fn [[syms & body]] + (binding [*electric* false] + (list syms (-expand-all (cons 'do body) (reduce add-local env syms)))))) + arities)))) + + (letfn*) (let [[_ bs & body] o + env2 (reduce add-local env (take-nth 2 bs)) + xpand (fn-> -expand-all env2) + bs2 (into [] (comp (partition-all 2) + (mapcat (fn [[sym v]] [sym (binding [*electric* false] (xpand v))]))) + bs)] + (?meta o `(let* [~(vec (take-nth 2 bs2)) (::letfn ~bs2)] ~(-expand-all (cons 'do body) env2)))) + + ;; TODO expand `do` + (try) (throw (ex-info "try is TODO" {:o o})) #_(list* 'try (mapv (fn-> -all-in-try env) (rest o))) + + (binding clojure.core/binding) + (let [[_ bs & body] o] + (?meta o (list 'binding (into [] (comp (partition-all 2) (mapcat (fn [[sym v]] [sym (-expand-all v env)]))) bs) + (-expand-all (cons 'do body) env)))) + + (set!) (if *electric* + (recur (?meta o `((fn* [v#] (set! ~(nth o 1) v#)) ~(nth o 2))) env) + (?meta o (list 'set! (-expand-all (nth o 1) env) (-expand-all (nth o 2) env)))) + + ;; (::toggle :client {:debug :info} form) + (::toggle) (?meta o (seq (conj (into [] (take 3) o) + (-expand-all (cons 'do (drop 3 o)) (assoc env ::current (second o)))))) + + #_else + (if (symbol? (first o)) + (let [o2 (expand-macro env o)] + (if (identical? o o2) + (?meta o (list* (first o) (mapv (fn-> -expand-all env) (rest o)))) + (recur (?meta o o2) env))) + (?meta o (list* (-expand-all (first o) env) (mapv (fn-> -expand-all env) (next o))))))) + + (map-entry? o) (clojure.lang.MapEntry. (-expand-all (key o) env) (-expand-all (val o) env)) + (coll? o) (?meta (meta o) (into (empty o) (map (fn-> -expand-all env)) o)) + :else o)) + +#_(defn -expand-all-in-try [o env] + (if (seq? o) + (if (find-local-entry env (first o)) + (list* (first o) (mapv (fn-> -expand-all env) (rest o))) + (case (first o) + (catch) (let [[_ typ sym & body] o, env2 (add-local env sym)] + (list* 'catch typ sym (mapv (fn-> -expand-all env2) body))) + #_else (-expand-all o env))) + (-expand-all o env))) + +;; :js-globals -> cljs env +;; :locals -> cljs or electric env +;; ::lang/peers -> electric env +;; if ::current = :clj expand with clj environment +;; if ::current = :cljs expand with cljs environment + +(defn enrich-for-require-macros-lookup [cljs-env nssym] + (if-some [src (cljs-ana/locate-src nssym)] + (let [ast (:ast (with-redefs [cljs-ana/missing-use-macro? (constantly nil)] + (binding [cljs-ana/*passes* []] + (cljs-ana/parse-ns src {:load-macros true, :restore false}))))] + ;; we parsed the ns form without `ns-side-effects` because it triggers weird bugs + ;; this means the macro nss from `:require-macros` might not be loaded + (run! serialized-require (-> ast :require-macros vals set)) + (assoc cljs-env ::ns ast)) + cljs-env)) + +(tests "enrich of clj source file is noop" + (cljs.env/ensure (enrich-for-require-macros-lookup {:a 1} 'clojure.core)) := {:a 1}) + +;; takes an electric environment, which can be clj or cljs +;; if it's clj we need to prep the cljs environment (cljs.env/ensure + cljs.analyzer/empty-env with patched ns) +;; we need to be able to swap the environments infinite number of times + +(defn ->common-env [env] + (if (::cljs-env env) + env + (assoc env ::cljs-env + (if (contains? env :js-globals) + env + (cond-> (cljs.analyzer/empty-env) (:ns env) (enrich-for-require-macros-lookup (:ns env))))))) + +(defn expand-all [env o] (cljs.env/ensure (-expand-all o (->common-env env)))) + +;;;;;;;;;;;;;;;; +;;; COMPILER ;;; +;;;;;;;;;;;;;;;; + +(defn get-configs-to-compile [conf lang] + (into #{} + (comp + (keep (fn [[peer peer-lang]] (when (= lang peer-lang) peer))) + (mapcat (fn [peer] (into [] (comp (filter (fn [current] (or (not (::only conf)) (get (::only conf) current)))) + (map (fn [current] (assoc conf ::me peer, ::current current)))) + (keys (::peers conf)))))) + (::peers conf))) + +(tests + (get-configs-to-compile {::peers {:client :clj :server :cljs}, ::current :client} :cljs) + := #{{::peers {:client :clj :server :cljs}, ::me :server, ::current :client} + {::peers {:client :clj :server :cljs}, ::me :server, ::current :server}} + + (get-configs-to-compile {::peers {:client :clj :server :clj}, ::current :client} :clj) + := #{{::peers {:client :clj :server :clj}, ::me :client, ::current :client} + {::peers {:client :clj :server :clj}, ::me :client, ::current :server} + {::peers {:client :clj :server :clj}, ::me :server ::current :client} + {::peers {:client :clj :server :clj}, ::me :server ::current :server}} + + (get-configs-to-compile {::peers {:client :clj :server :clj}, ::current :client, ::only #{:client}} :clj) + := #{{::peers {:client :clj :server :clj}, ::me :client, ::current :client, ::only #{:client}} + {::peers {:client :clj :server :clj}, ::me :server, ::current :client, ::only #{:client}}} + ) + +(defn mksym [x & xs] + (if (or (symbol? x) (keyword? x)) + (symbol (namespace x) (apply str (name x) (map name (flatten xs)))) + (symbol (apply str (name x) (map name (flatten xs)))))) +(defn as-node [o] (vary-meta o assoc ::type ::node)) +(defn node? [mt] (-> mt ::type #{::node})) +(defn as-node-signifier [o] (vary-meta o assoc ::type ::node-signifier)) +(defn node-signifier? [mt] (-> mt ::type #{::node-signifier})) +(defn signifier->node [sym cfg] (mksym sym "_hf_" (::me cfg) "_" (::current cfg))) + +(defn find-local [sym env] (-> env :locals (get sym))) +(defn find-electric-local [sym env] (let [local (find-local sym env)] (when (::pub local) local))) + +(defn- find-node-signifier [sym env] + (case (get (::peers env) (::me env)) + :clj (when-some [^clojure.lang.Var vr (resolve env sym)] + (when (-> vr meta node-signifier?) + (symbol (-> vr .ns str) (-> vr .sym str)))) + :cljs (when-some [vr (resolve-cljs env sym)] + (when (-> vr :meta node-signifier?) + (symbol (-> vr :name str)))))) ; there's `:ns` but `:name` already contains the ns (?) + +(defn- find-node [sym env] + (case (get (::peers env) (::me env)) + :clj (when-some [^clojure.lang.Var vr (resolve env sym)] + (when (-> vr meta node?) + (symbol (-> vr .ns str) (-> vr .sym str)))) + :cljs (when-some [vr (resolve-cljs env sym)] + (when (-> vr :meta node?) + (symbol (-> vr :name str)))))) ; there's `:ns` but `:name` already contains the ns (?) + +(declare analyze-me analyze-them) + +(defn get-them [env] (-> env ::peers keys set (disj (::current env)) first)) +(defn toggle [env] (assoc env ::current (get-them env))) + +(tests + (toggle {::peers {:client :cljs, :server :clj} ::current :server}) + := {::peers {:client :cljs, :server :clj} ::current :client}) + +(defn fail! + ([env msg] (fail! env msg {})) + ([env msg data] (throw (ex-info (str "in" (some->> (::def env) (str " ")) ": " (-> env ::last peek pr-str) "\n" msg) + (merge {:form (-> env ::last pop peek) :in (::def env) :for ((juxt ::me ::current) env)} data))))) + +(defn cannot-resolve! [env form] + (fail! env (str "I cannot resolve " "`"form"`" + (when-let [them (get-them env)] + (let [site (name them)] + (str ", maybe it's defined only on the " site "?" + \newline "If `" form "` is supposed to be a macro, you might need to :refer it in the :require-macros clause.")))) + {:locals (keys (:locals env))})) + +(defn ns-qualify [node] (if (namespace node) node (symbol (str *ns*) (str node)))) + +(tests + (ns-qualify 'foo) := `foo + (ns-qualify 'a/b) := 'a/b) + +(defn qualify-sym-in-var-node "If ast node is `:var`, update :form to be a fully qualified symbol" [env ast] + (if (and (= :var (:op ast)) (not (-> ast :env :def-var))) + (assoc ast :form (case (get (::peers env) (::current env)) + :clj (symbol (str (:ns (:meta ast))) (str (:name (:meta ast)))) + :cljs (:name (:info ast)))) + ast)) + +(defn ->meta [o env] (merge (::meta (find-electric-local o env)) (meta o))) + +(defn closure + "Analyze a cc/fn form, looking for electric defs and electric lexical bindings references. + Rewrites the cc/fn form into a closure over electric dynamic and lexical scopes. + Return a pair [closure form, references to close over]. + + e.g.: + (let [x 1] + (binding [y 2] + (fn [arg] [x y arg]))) + + => + [(fn [x123 y123] + (fn [& rest-args123] + (binding [y y123] + (let [x x123] + (apply (fn [arg] [x y arg]) rest-args123))))) + [x y]] + " + [env form] + (let [refered-evars (atom {}) + refered-lexical (atom {}) + edef? (fn [ast] (or (#{::node ::node-signifier} (-> ast :meta ::type)) + (#{::node ::node-signifier} (-> ast :info :meta ::type)))) + dynamic? (fn [ast] (or (:assignable? ast) ; clj + (:dynamic (:meta (:info ast))) ; cljs + )) + lexical? (fn [ast] (or (::provided? ast) ; clj + (::provided? (:info ast)) ;cljs + )) + namespaced? (fn [ast] (qualified-symbol? (:form ast))) + safe-let-name (fn [sym] (if (qualified-symbol? sym) + (symbol (str/replace (str (munge sym)) #"\." "_")) + sym)) + record-lexical! (fn [{:keys [form]}] + (swap! refered-lexical assoc (with-meta form (->meta form env)) + (gensym (name form)))) + record-edef! (fn [{:keys [form] :as ast}] + (if (dynamic? ast) + (swap! refered-evars assoc form #_(ana/var-name ast) (gensym (name form))) + (record-lexical! ast))) + env (update env :locals update-vals #(if (map? %) (assoc % ::provided? true) {::provided? true})) + rewrite-ast (fn [ast] + (cond + (edef? ast) (do (record-edef! ast) + (cond (dynamic? ast) (qualify-sym-in-var-node env ast) + (namespaced? ast) (update ast :form safe-let-name) + :else ast)) + (lexical? ast) (do (record-lexical! ast) ast) + :else (qualify-sym-in-var-node env ast))) + form (case (get (::peers env) (::current env)) + :clj (-> (ana/analyze-clj env form) + (ana/walk-clj rewrite-ast) + (ana/emit-clj)) + :cljs (-> (binding [cljs.analyzer/*cljs-warning-handlers* + [(fn [_warning-type _env _extra])]] + (ana/analyze-cljs env form)) + (ana/walk-cljs rewrite-ast) + (ana/emit-cljs))) + rest-args-sym (gensym "rest-args") + all-syms (merge @refered-evars @refered-lexical) + [syms gensyms] [(keys all-syms) (vals all-syms)] + fn? (and (seq? form) (#{'fn 'fn* 'clojure.core/fn 'clojure.core/fn* 'cljs.core/fn 'cljs.core/fn*} (first form))) + form (if fn? + `(apply ~form ~rest-args-sym) + form) + form (if (seq @refered-lexical) + `(let [~@(flatten (map (fn [[k v]] [(safe-let-name k) v]) @refered-lexical))] + ~form) + form) + form (if (seq @refered-evars) + `(binding [~@(flatten (seq @refered-evars))] + ~form) + form) + form (if fn? + `(fn [~@gensyms] (fn [~'& ~rest-args-sym] ~form)) + `(fn [~@gensyms] ~form))] + [form syms])) + +(defn bound-js-fn + "Given a js global resolving to a function (e.g js/alert, js/console.log required-js-ns/js-fn), ensures it + is called under the correct `this` context." + [sym] + (let [fields (str/split (name sym) #"\.")] + `(.bind ~sym ~(symbol (namespace sym) + (if (seq (rest fields)) + (str/join (interpose '. (butlast fields))) + "globalThis"))))) + +(defn- class-constructor-call? [env f] + (and (symbol? f) (not (or (find-local f env) (find-node-signifier f env) (find-node f env))))) + +(defn with-interop-locals [env syms] (update env :locals merge (zipmap syms (repeat {})))) + +(defn resolve-static-field [sym] + (when-some [ns (some-> (namespace sym) symbol)] + (when-some [cls (resolve ns)] + (when (class? cls) + (clojure.lang.Reflector/getField cls (name sym) true))))) + +(defn get-children-e [ts e] (-> ts :ave ::parent (get e))) +(defn get-root-e [ts] (first (get-children-e ts '_))) + +(defn find-let-ref [sym pe ts] + (loop [pe pe] + (when pe + (let [p (ts/get-entity ts pe)] + (if (and (= ::let (::type p)) (= sym (::sym p))) + pe + (recur (::parent p))))))) + +(defn analyze [form pe {{::keys [env ->id]} :o :as ts}] + (cond + (and (seq? form) (seq form)) + (let [[op & args] form] + (case op + (let*) (loopr [ts ts, pe pe] + [[s v] (eduction (partition-all 2) (first args))] + (let [e (->id)] + (recur (analyze v e (ts/add ts {:db/id e, ::parent pe, ::type ::let, ::sym s})) e)) + (analyze (second args) pe ts)) + #_else (let [e (->id)] + (reduce (fn [ts nx] (analyze nx e ts)) (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) form)))) + + (vector? form) (recur (?meta form (cons `vector form)) pe ts) + + (symbol? form) + (if-some [lx-e (find-let-ref form pe ts)] + (ts/add ts {:db/id (->id), ::parent pe, ::type ::let-ref, ::ref lx-e, ::sym form}) + (ts/add ts {:db/id (->id), ::parent pe, ::type ::static, ::v form}) + ) + + :else + (ts/add ts {:db/id (->id), ::parent pe, ::type ::static, ::v form}))) + +(comment + (let [x 1] x) + (r-defs + (r-local 1) + (r-static 1)) + + (concat (let [x 1] [x x]) (let [y 2] [y y])) + (r-defs + (r-ap (r-static concat) + (r-ap (r-static vector) (r-local 1) (r-local 1)) + (r-ap (r-static vector)) (r-local 2) (r-local 2)) + (r-static 1) + (r-static 2)) + + ) + +(defn ->->id [] (let [!i (long-array [-1])] (fn [] (aset !i 0 (unchecked-inc (aget !i 0)))))) + +(defn compile-me [pe {{::keys [env ->id]} :o :as ts}] + (let [find-return-node (fn [ts e] + (let [nd (get (:eav ts) e)] + (case (::type nd) ::let (recur ts (second (get-children-e ts e))) #_else e))) + order (fn order [ts ->id e] + (let [nd (get (:eav ts) e)] + (if (::order nd) + ts + (case (::type nd) + ::static ts + ::ap (reduce (fn [ts e] (order ts ->id e)) ts (get-children-e ts e)) + ::let (reduce (fn [ts e] (order ts ->id e)) + (ts/upd ts e ::order (fn [_] (->id))) + (get-children-e ts e)) + ::let-ref (order ts ->id (::ref nd)) + #_else (throw (ex-info (str "cannot order: " (::type nd)) {:nd nd})))))) + ts (order ts (->->id) (find-return-node ts (get-root-e ts))) + gen-let (fn gen-let [ts e] + (let [nd (get (:eav ts) e)] + (case (::type nd) + ::static (list `r-static (::v nd)) + ::ap (cons `r-ap (mapv #(gen-let ts %) (get-children-e ts e))) + ::let (gen-let ts (first (get-children-e ts e))) + ::let-ref (list `r-local (->> nd ::ref (get (:eav ts)) ::order)) + #_else (throw (ex-info (str "cannot gen: " (::type nd)) {:nd nd}))))) + gen-ret (fn gen-ret [ts e] + (let [nd (get (:eav ts) e)] + (case (::type nd) + ::static (list `r-static (::v nd)) + ::ap (cons `r-ap (mapv #(gen-ret ts %) (get-children-e ts e))) + ::let (gen-ret ts (second (get-children-e ts e))) + ::let-ref (list `r-local (->> nd ::ref (get (:eav ts)) ::order))))) + defs (mapv #(gen-let ts %) (->> ts :ave ::order vals (reduce into) (sort-by #(->> % (get (:eav ts)) ::order))))] + ;; (run! prn (->> ts :eav vals (sort-by :db/id))) + `(r/peer (r-defs ~@(conj defs (gen-ret ts (find-return-node ts (get-root-e ts))))) [] 0) + ;; (cons `r/defs (conj defs (gen-ret ts (find-return-node ts (get-root-e ts))))) + #_(list `r/defs (->runtime-call ts (get-root ts))))) + +(defn compile [form env] + (let [ts (ts/->ts {::->id (->->id), ::env env})] + (compile-me '_ (analyze (expand-all env form) '_ ts)))) diff --git a/test/hyperfiddle/electric/impl/expand_de_test.cljc b/test/hyperfiddle/electric/impl/expand_de_test.cljc index b5313c7b3..339c178d6 100644 --- a/test/hyperfiddle/electric/impl/expand_de_test.cljc +++ b/test/hyperfiddle/electric/impl/expand_de_test.cljc @@ -1,7 +1,7 @@ (ns hyperfiddle.electric.impl.expand-de-test (:require #?(:clj [cljs.env]) #?(:clj [cljs.analyzer]) - #?(:clj [hyperfiddle.electric.impl.compiler :as c]) + #?(:clj [hyperfiddle.electric.impl.lang-de :as c]) #?(:clj [hyperfiddle.electric.impl.runtime-de :as r]) #?(:clj [hyperfiddle.electric :as-alias e]) [hyperfiddle.electric.impl.expand-require-referred :as ref :refer [referred]] @@ -75,10 +75,10 @@ (->> [x] x)] (-> (->> x) inc)))] x := '(let* [[foo bar baz ->>] - (:hyperfiddle.electric.impl.compiler/letfn [foo (fn* foo ([with-open] (with-open 1))) - bar (fn* bar ([x] (inc x))) - baz (fn* baz ([x] (->> x))) - ->> (fn* ->> ([x] x))])] + (::c/letfn [foo (fn* foo ([with-open] (with-open 1))) + bar (fn* bar ([x] (inc x))) + baz (fn* baz ([x] (->> x))) + ->> (fn* ->> ([x] x))])] (inc (->> x))) (has-line-meta? x) := true) From d6383564b0fc93759a528119b4e19f9d292c2013 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Wed, 20 Dec 2023 19:05:28 +0100 Subject: [PATCH 015/428] add test for ctor with slots --- src/hyperfiddle/electric/impl/lang_de.clj | 3 +++ test/hyperfiddle/electric_compiler_test.clj | 9 +++++++++ 2 files changed, 12 insertions(+) diff --git a/src/hyperfiddle/electric/impl/lang_de.clj b/src/hyperfiddle/electric/impl/lang_de.clj index ef53a3d1f..89787b0f7 100644 --- a/src/hyperfiddle/electric/impl/lang_de.clj +++ b/src/hyperfiddle/electric/impl/lang_de.clj @@ -56,6 +56,9 @@ (defmacro r-var [id] `(r/pure (r/peer-var (r/tier-peer r/*tier*) (quote ~id)))) +(defmacro r-lookup [id] + `(r/tier-lookup r/*tier* (quote ~id))) + ;;;;;;;;;;;;;;;; ;;; EXPANDER ;;; ;;;;;;;;;;;;;;;; diff --git a/test/hyperfiddle/electric_compiler_test.clj b/test/hyperfiddle/electric_compiler_test.clj index 1005ad92b..e033bed7c 100644 --- a/test/hyperfiddle/electric_compiler_test.clj +++ b/test/hyperfiddle/electric_compiler_test.clj @@ -252,4 +252,13 @@ (r/ap (r/static vector) (r/free 0) (r/free 1)) (r/ap (r/static vector) (r/free 0) (r/free 1))) + #_(e/defn Foo []) + (l/compile-client `(e/ctor (e/call Foo))) := + `(r/peer + (l/defs + (l/lookup Foo) + (l/call 0) + (l/ctor [0] 1)) + [] 2) + ) From 6e25d50e7be9b67effa3b900e1a7ac34f85e3868 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Wed, 20 Dec 2023 19:08:15 +0100 Subject: [PATCH 016/428] fix refactor --- test/hyperfiddle/electric_compiler_test.clj | 26 ++++++++++----------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/test/hyperfiddle/electric_compiler_test.clj b/test/hyperfiddle/electric_compiler_test.clj index e033bed7c..43b90546c 100644 --- a/test/hyperfiddle/electric_compiler_test.clj +++ b/test/hyperfiddle/electric_compiler_test.clj @@ -242,23 +242,23 @@ (l/compile-client (let [a :foo, b :bar, c :baz] [(e/ctor [a b]) (e/ctor [b c])])) - := `(r/defs - (r/ap (r/static vector) - (r/ctor 4 (r/local 1) (r/local 2)) - (r/ctor 5 (r/local 2) (r/local 3))) - (r/static :foo) - (r/static :bar) - (r/static :baz) - (r/ap (r/static vector) (r/free 0) (r/free 1)) - (r/ap (r/static vector) (r/free 0) (r/free 1))) + := `(lang/r-defs + (lang/r-ap (lang/r-static vector) + (lang/r-ctor 4 (lang/r-local 1) (lang/r-local 2)) + (lang/r-ctor 5 (lang/r-local 2) (lang/r-local 3))) + (lang/r-static :foo) + (lang/r-static :bar) + (lang/r-static :baz) + (lang/r-ap (lang/r-static vector) (lang/r-free 0) (lang/r-free 1)) + (lang/r-ap (lang/r-static vector) (lang/r-free 0) (lang/r-free 1))) #_(e/defn Foo []) (l/compile-client `(e/ctor (e/call Foo))) := `(r/peer - (l/defs - (l/lookup Foo) - (l/call 0) - (l/ctor [0] 1)) + (lang/r-defs + (lang/r-lookup Foo) + (lang/r-call 0) + (lang/r-ctor [0] 1)) [] 2) ) From 5e04ce0f11aef71e9148771ac5390de39d049aac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Thu, 21 Dec 2023 09:49:56 +0100 Subject: [PATCH 017/428] test for e/tier --- test/hyperfiddle/electric_compiler_test.clj | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/test/hyperfiddle/electric_compiler_test.clj b/test/hyperfiddle/electric_compiler_test.clj index 43b90546c..bb45ff89b 100644 --- a/test/hyperfiddle/electric_compiler_test.clj +++ b/test/hyperfiddle/electric_compiler_test.clj @@ -261,4 +261,11 @@ (lang/r-ctor [0] 1)) [] 2) + (l/compile-client `e/tier) := + `(r/peer + (fn [tier id] + (case id + 0 (r/pure tier))) + [] 0) + ) From a229de63b4a2c02a772828c73e57d21388d88ba0 Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 20 Dec 2023 15:37:21 +0100 Subject: [PATCH 018/428] fix result index --- src/hyperfiddle/electric/impl/lang_de.clj | 2 +- test/hyperfiddle/electric_compiler_test.clj | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de.clj b/src/hyperfiddle/electric/impl/lang_de.clj index 89787b0f7..2890e19cf 100644 --- a/src/hyperfiddle/electric/impl/lang_de.clj +++ b/src/hyperfiddle/electric/impl/lang_de.clj @@ -549,7 +549,7 @@ ::let-ref (list `r-local (->> nd ::ref (get (:eav ts)) ::order))))) defs (mapv #(gen-let ts %) (->> ts :ave ::order vals (reduce into) (sort-by #(->> % (get (:eav ts)) ::order))))] ;; (run! prn (->> ts :eav vals (sort-by :db/id))) - `(r/peer (r-defs ~@(conj defs (gen-ret ts (find-return-node ts (get-root-e ts))))) [] 0) + `(r/peer (r-defs ~@(conj defs (gen-ret ts (find-return-node ts (get-root-e ts))))) [] ~(count defs)) ;; (cons `r/defs (conj defs (gen-ret ts (find-return-node ts (get-root-e ts))))) #_(list `r/defs (->runtime-call ts (get-root ts))))) diff --git a/test/hyperfiddle/electric_compiler_test.clj b/test/hyperfiddle/electric_compiler_test.clj index bb45ff89b..6c69dca98 100644 --- a/test/hyperfiddle/electric_compiler_test.clj +++ b/test/hyperfiddle/electric_compiler_test.clj @@ -31,7 +31,7 @@ := `(r/peer (lang/r-defs (lang/r-static "Hello world") (lang/r-static "Hello world") - (lang/r-ap (lang/r-static vector) (lang/r-local 0) (lang/r-local 1))) [] 0) + (lang/r-ap (lang/r-static vector) (lang/r-local 0) (lang/r-local 1))) [] 2) (l/compile-client (concat (let [x 1] [x x]) (let [y 2] [y y]))) := `(r/peer (lang/r-defs @@ -39,7 +39,7 @@ (lang/r-static 2) (lang/r-ap (lang/r-static ~'concat) (lang/r-ap (lang/r-static vector) (lang/r-local 0) (lang/r-local 0)) - (lang/r-ap (lang/r-static vector) (lang/r-local 1) (lang/r-local 1)))) [] 0) + (lang/r-ap (lang/r-static vector) (lang/r-local 1) (lang/r-local 1)))) [] 2) (l/compile-client (i/fixed (m/watch (atom 0)))) := `(r/peer (lang/r-defs From 00a45a919fc4fe25ddfdd66c45140c13d7a83ca7 Mon Sep 17 00:00:00 2001 From: xificurC Date: Fri, 22 Dec 2023 17:12:20 +0100 Subject: [PATCH 019/428] ctor free vars --- src/hyperfiddle/electric/impl/lang_de.clj | 124 ++++++++++++-------- test/hyperfiddle/electric_compiler_test.clj | 86 ++++++++++++++ 2 files changed, 160 insertions(+), 50 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de.clj b/src/hyperfiddle/electric/impl/lang_de.clj index 2890e19cf..704fa1354 100644 --- a/src/hyperfiddle/electric/impl/lang_de.clj +++ b/src/hyperfiddle/electric/impl/lang_de.clj @@ -33,10 +33,10 @@ (defmacro r-ap [& args] `(i/latest-product r-invoke ~@args)) -(defmacro r-free [id] +(defmacro r-free [id] ; looks up a free (closed over) expr in ctor `(r/ctor-free (r/tier-ctor r/*tier*) ~id)) -(defmacro r-local [id] +(defmacro r-local [id] ; looks up a local (from defs block) expr `(r/tier-local r/*tier* ~id)) (defmacro r-remote [id] @@ -476,15 +476,16 @@ (defn analyze [form pe {{::keys [env ->id]} :o :as ts}] (cond (and (seq? form) (seq form)) - (let [[op & args] form] - (case op - (let*) (loopr [ts ts, pe pe] - [[s v] (eduction (partition-all 2) (first args))] + (case (first form) + (let*) (let [[_ bs bform] form] + (loopr [ts ts, pe pe] + [[s v] (eduction (partition-all 2) bs)] (let [e (->id)] (recur (analyze v e (ts/add ts {:db/id e, ::parent pe, ::type ::let, ::sym s})) e)) - (analyze (second args) pe ts)) - #_else (let [e (->id)] - (reduce (fn [ts nx] (analyze nx e ts)) (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) form)))) + (analyze bform pe ts))) + (::ctor) (let [e (->id)] (recur (second form) e (ts/add ts {:db/id e, ::parent pe, ::type ::ctor}))) + #_else (let [e (->id)] + (reduce (fn [ts nx] (analyze nx e ts)) (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) form))) (vector? form) (recur (?meta form (cons `vector form)) pe ts) @@ -497,61 +498,84 @@ :else (ts/add ts {:db/id (->id), ::parent pe, ::type ::static, ::v form}))) -(comment - (let [x 1] x) - (r-defs - (r-local 1) - (r-static 1)) - - (concat (let [x 1] [x x]) (let [y 2] [y y])) - (r-defs - (r-ap (r-static concat) - (r-ap (r-static vector) (r-local 1) (r-local 1)) - (r-ap (r-static vector)) (r-local 2) (r-local 2)) - (r-static 1) - (r-static 2)) - - ) - (defn ->->id [] (let [!i (long-array [-1])] (fn [] (aset !i 0 (unchecked-inc (aget !i 0)))))) +(defn trim [ss bound] + (if (empty? ss) ss (let [f (first ss)] (if (> f bound) ss (recur (disj ss f) bound))))) + +(tests (trim (sorted-set 1 2 3 4) 2) := (sorted-set 3 4)) (defn compile-me [pe {{::keys [env ->id]} :o :as ts}] (let [find-return-node (fn [ts e] (let [nd (get (:eav ts) e)] (case (::type nd) ::let (recur ts (second (get-children-e ts e))) #_else e))) - order (fn order [ts ->id e] + order (fn order [ts ->order e] ; gives each toplevel flow an order index (let [nd (get (:eav ts) e)] (if (::order nd) ts (case (::type nd) ::static ts - ::ap (reduce (fn [ts e] (order ts ->id e)) ts (get-children-e ts e)) - ::let (reduce (fn [ts e] (order ts ->id e)) - (ts/upd ts e ::order (fn [_] (->id))) + ::ap (reduce (fn [ts e] (order ts ->order e)) ts (get-children-e ts e)) + ::let (reduce (fn [ts e] (order ts ->order e)) + (ts/upd ts e ::order (fn [_] (->order))) (get-children-e ts e)) - ::let-ref (order ts ->id (::ref nd)) + ::let-ref (order ts ->order (::ref nd)) + ::ctor (let [ce (first (get-children-e ts e)) + ts (order ts ->order ce)] + (cond-> ts + (not (::order (get (:eav ts) ce))) (ts/upd ce ::order (fn [_] (->order))))) #_else (throw (ex-info (str "cannot order: " (::type nd)) {:nd nd})))))) - ts (order ts (->->id) (find-return-node ts (get-root-e ts))) - gen-let (fn gen-let [ts e] - (let [nd (get (:eav ts) e)] - (case (::type nd) - ::static (list `r-static (::v nd)) - ::ap (cons `r-ap (mapv #(gen-let ts %) (get-children-e ts e))) - ::let (gen-let ts (first (get-children-e ts e))) - ::let-ref (list `r-local (->> nd ::ref (get (:eav ts)) ::order)) - #_else (throw (ex-info (str "cannot gen: " (::type nd)) {:nd nd}))))) - gen-ret (fn gen-ret [ts e] - (let [nd (get (:eav ts) e)] - (case (::type nd) - ::static (list `r-static (::v nd)) - ::ap (cons `r-ap (mapv #(gen-ret ts %) (get-children-e ts e))) - ::let (gen-ret ts (second (get-children-e ts e))) - ::let-ref (list `r-local (->> nd ::ref (get (:eav ts)) ::order))))) - defs (mapv #(gen-let ts %) (->> ts :ave ::order vals (reduce into) (sort-by #(->> % (get (:eav ts)) ::order))))] + ;; free-of-ctor - pointer to ctor + ;; free-idx - index of this free var in ctor free array + ;; parent-free - present if there's a parent ctor closing over this free var, index in parent free array + capture-frees (fn capture-frees [ts] + (loopr [ts ts, prev-e 0, letrefs-e (or (->> ts :ave ::type ::let-ref) [])] + [ctor-e (or (->> ts :ave ::type ::ctor) [])] + (let [letrefs2-e (trim letrefs-e ctor-e) + refs-e (into (sorted-set) (map #(::ref (get (:eav ts) %))) letrefs2-e) + frees-e (into (sorted-set) (take-while #(< % ctor-e)) refs-e) + ->free-idx (->->id)] + (recur (reduce (fn [ts free-e] + (ts/add ts (merge {:db/id (->id), ::free-of-ctor ctor-e + ::ref free-e, ::free-idx (->free-idx)} + (when (< free-e prev-e) + {::parent-free + (let [parent-frees-e (-> ts :ave ::free-of-ctor (get prev-e))] + (reduce (fn [_ pfe] + (let [pf (get (:eav ts) pfe)] + (when (= free-e (::ref pf)) + (reduced (::free-idx pf))))) + nil parent-frees-e))})))) + ts frees-e) + ctor-e letrefs2-e)) + ts)) + ;; _ (run! prn (->> ts :eav vals (sort-by :db/id))) + ts (-> ts (order (->->id) (find-return-node ts (get-root-e ts))) capture-frees) + gen (fn gen [ts e ctor-e top?] ; `top?` - let at top compiles to the value, otherwise to reference of it + (let [nd (get (:eav ts) e) + frees-e (-> ts :ave ::free-of-ctor (get ctor-e)) + ref->idx (reduce (fn [ac free-e] + (let [nd (get (:eav ts) free-e)] + (assoc ac (::ref nd) (::free-idx nd)))) {} frees-e)] + (case (::type nd) + ::static (list `r-static (::v nd)) + ::ap (cons `r-ap (mapv #(gen ts % ctor-e false) (get-children-e ts e))) + ::let (gen ts ((if top? first second) (get-children-e ts e)) ctor-e false) + ::let-ref (if-some [idx (ref->idx (::ref nd))] + (list `r-free idx) + (list `r-local (->> nd ::ref (get (:eav ts)) ::order))) + ::ctor (list* `r-ctor '[] (->> e (get-children-e ts) first (get (:eav ts)) ::order) + (mapv #(let [nd (get (:eav ts) %)] + (if-some [pfe (::parent-free nd)] + (list `r-free pfe) + (list `r-local (->> nd ::ref (get (:eav ts)) ::order)))) + (-> ts :ave ::free-of-ctor (get e)))) + #_else (throw (ex-info (str "cannot gen-top: " (::type nd)) {:nd nd}))))) + defs (mapv #(gen ts % (::parent (get (:eav ts) %)) true) + (->> ts :ave ::order vals (reduce into) (sort-by #(->> % (get (:eav ts)) ::order))))] ;; (run! prn (->> ts :eav vals (sort-by :db/id))) - `(r/peer (r-defs ~@(conj defs (gen-ret ts (find-return-node ts (get-root-e ts))))) [] ~(count defs)) - ;; (cons `r/defs (conj defs (gen-ret ts (find-return-node ts (get-root-e ts))))) - #_(list `r/defs (->runtime-call ts (get-root ts))))) + `(r/peer (r-defs ~@(conj defs (let [ret-e (find-return-node ts (get-root-e ts))] + (gen ts ret-e (::parent (get (:eav ts) ret-e)) true)))) + [] ~(count defs)))) (defn compile [form env] (let [ts (ts/->ts {::->id (->->id), ::env env})] diff --git a/test/hyperfiddle/electric_compiler_test.clj b/test/hyperfiddle/electric_compiler_test.clj index 6c69dca98..67ce3c69e 100644 --- a/test/hyperfiddle/electric_compiler_test.clj +++ b/test/hyperfiddle/electric_compiler_test.clj @@ -48,6 +48,92 @@ (lang/r-ap (lang/r-static ~'atom) (lang/r-static 0))))) [] 0) + (l/compile-client (::lang/ctor :foo)) + := `(r/peer + (lang/r-defs + (lang/r-static :foo) + (lang/r-ctor [] 0)) + [] 1) + + (l/compile-client (let [a 1] (::lang/ctor a))) + := `(r/peer + (lang/r-defs + (lang/r-static 1) + (lang/r-free 0) + (lang/r-ctor [] 1 (lang/r-local 0))) + [] 2) + + (l/compile-client (let [a 1] (::lang/ctor (let [a 2] a)))) + := `(r/peer + (lang/r-defs + (lang/r-static 2) + (lang/r-ctor [] 0)) + [] 1) + + (l/compile-client (let [a 1] (::lang/ctor (::lang/ctor a)))) + := `(r/peer + (lang/r-defs + (lang/r-static 1) + (lang/r-free 0) + (lang/r-ctor [] 1 (lang/r-free 0)) + (lang/r-ctor [] 2 (lang/r-local 0))) + [] 3) + + (l/compile-client (let [a 1] (::lang/ctor [a (let [a 2] (::lang/ctor a))]))) + := `(r/peer + (lang/r-defs + (lang/r-static 1) + (lang/r-static 2) + (lang/r-free 0) + (lang/r-ap (lang/r-static vector) + (lang/r-free 0) + (lang/r-ctor [] 2 (lang/r-local 1))) + (lang/r-ctor [] 3 (lang/r-local 0))) + [] 4) + + (l/compile-client (let [a 1] (::lang/ctor (::lang/ctor (::lang/ctor a))))) + := `(r/peer + (lang/r-defs + (lang/r-static 1) + (lang/r-free 0) + (lang/r-ctor [] 1 (lang/r-free 0)) + (lang/r-ctor [] 2 (lang/r-free 0)) + (lang/r-ctor [] 3 (lang/r-local 0))) + [] 4) + + (l/compile-client (let [a 1, b 2] (::lang/ctor [a (::lang/ctor b)]))) + := `(r/peer + (lang/r-defs + (lang/r-static 1) + (lang/r-static 2) + (lang/r-free 0) + (lang/r-ap (lang/r-static clojure.core/vector) + (lang/r-free 0) + (lang/r-ctor [] 2 (lang/r-free 1))) + (lang/r-ctor [] 3 (lang/r-local 0) (lang/r-local 1))) + [] + 4) + + (l/compile-client (let [a 1, b 2] (::lang/ctor [b (::lang/ctor a)]))) + := `(r/peer + (lang/r-defs + (lang/r-static 2) + (lang/r-static 1) + (lang/r-free 0) + (lang/r-ap (lang/r-static clojure.core/vector) + (lang/r-free 1) + (lang/r-ctor [] 2 (lang/r-free 0))) + (lang/r-ctor [] 3 (lang/r-local 1) (lang/r-local 0))) + [] + 4) + + ;; (l/compile-client (::lang/call (::lang/ctor :foo))) + ;; := `(r/peer + ;; (lang/r-defs + ;; (lang/r-static :foo) + ;; (lang/r-ctor [] 0) + ;; (lang/r-call 0)) + ;; [1] 2) ) (comment ;; (defn lang/compile [env form] From 5deaf8fd5cae2fc25fddb5f5b352badc40f34ef8 Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 2 Jan 2024 13:19:26 +0100 Subject: [PATCH 020/428] compiler: call --- src/contrib/triple_store.clj | 2 + src/hyperfiddle/electric/impl/lang_de.clj | 46 +++++++---- test/hyperfiddle/electric_compiler_test.clj | 89 ++++++++++++++++++--- 3 files changed, 114 insertions(+), 23 deletions(-) diff --git a/src/contrib/triple_store.clj b/src/contrib/triple_store.clj index d7a656c6a..e4ca3b7b8 100644 --- a/src/contrib/triple_store.clj +++ b/src/contrib/triple_store.clj @@ -38,6 +38,8 @@ vea (cond-> vea (contains? (get vea v0) e) (update v0 update e disj a))] (->TripleStore (:o ts) eav ave vea))) +(defn asc [ts e a v] (upd ts e a (fn [_] v))) + (defn get-entity [ts e] (get (:eav ts) e)) (defn ->datoms [ts] diff --git a/src/hyperfiddle/electric/impl/lang_de.clj b/src/hyperfiddle/electric/impl/lang_de.clj index 704fa1354..19f744afd 100644 --- a/src/hyperfiddle/electric/impl/lang_de.clj +++ b/src/hyperfiddle/electric/impl/lang_de.clj @@ -484,6 +484,7 @@ (recur (analyze v e (ts/add ts {:db/id e, ::parent pe, ::type ::let, ::sym s})) e)) (analyze bform pe ts))) (::ctor) (let [e (->id)] (recur (second form) e (ts/add ts {:db/id e, ::parent pe, ::type ::ctor}))) + (::call) (let [e (->id)] (recur (second form) e (ts/add ts {:db/id e, ::parent pe, ::type ::call}))) #_else (let [e (->id)] (reduce (fn [ts nx] (analyze nx e ts)) (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) form))) @@ -499,15 +500,12 @@ (ts/add ts {:db/id (->id), ::parent pe, ::type ::static, ::v form}))) (defn ->->id [] (let [!i (long-array [-1])] (fn [] (aset !i 0 (unchecked-inc (aget !i 0)))))) -(defn trim [ss bound] - (if (empty? ss) ss (let [f (first ss)] (if (> f bound) ss (recur (disj ss f) bound))))) - -(tests (trim (sorted-set 1 2 3 4) 2) := (sorted-set 3 4)) (defn compile-me [pe {{::keys [env ->id]} :o :as ts}] (let [find-return-node (fn [ts e] (let [nd (get (:eav ts) e)] (case (::type nd) ::let (recur ts (second (get-children-e ts e))) #_else e))) + ensure-ordered (fn [ts ->order e] (cond-> ts (not (::order (get (:eav ts) e))) (ts/asc e ::order (->order)))) order (fn order [ts ->order e] ; gives each toplevel flow an order index (let [nd (get (:eav ts) e)] (if (::order nd) @@ -519,19 +517,36 @@ (ts/upd ts e ::order (fn [_] (->order))) (get-children-e ts e)) ::let-ref (order ts ->order (::ref nd)) - ::ctor (let [ce (first (get-children-e ts e)) + ::ctor (let [ce (first (get-children-e ts e))] + (ensure-ordered (order ts ->order ce) ->order ce)) + ::call (let [ce (first (get-children-e ts e)) ts (order ts ->order ce)] - (cond-> ts - (not (::order (get (:eav ts) ce))) (ts/upd ce ::order (fn [_] (->order))))) + (cond-> ts (= ::ctor (::type (get (:eav ts) ce))) (ensure-ordered ->order ce))) #_else (throw (ex-info (str "cannot order: " (::type nd)) {:nd nd})))))) + index-calls (fn index-calls [ts] + (let [->idx (->->id)] + (reduce (fn [ts e] + (let [ce (first (get-children-e ts e)) + ctor-ord (loop [ce ce] + (if-some [ref-e (-> ts :eav (get ce) ::ref)] + (recur ref-e) + (-> ts :eav (get ce) ::order)))] + (-> ts (ts/asc e ::ctor-order ctor-ord) (ts/asc e ::call-idx (->idx))))) + ts (-> ts :ave ::type ::call)))) + get-letrefs-e (fn get-letrefs-e [ts e] + (loop [letrefs-e (sorted-set) unwalked-e (get-children-e ts e)] + (if-some [[ce & more-e] unwalked-e] + (recur (cond-> letrefs-e (= ::let-ref (::type (get (:eav ts) ce))) (conj ce)) + (into more-e (get-children-e ts ce))) + letrefs-e))) ;; free-of-ctor - pointer to ctor ;; free-idx - index of this free var in ctor free array ;; parent-free - present if there's a parent ctor closing over this free var, index in parent free array capture-frees (fn capture-frees [ts] - (loopr [ts ts, prev-e 0, letrefs-e (or (->> ts :ave ::type ::let-ref) [])] + (loopr [ts ts, prev-e 0] [ctor-e (or (->> ts :ave ::type ::ctor) [])] - (let [letrefs2-e (trim letrefs-e ctor-e) - refs-e (into (sorted-set) (map #(::ref (get (:eav ts) %))) letrefs2-e) + (let [letrefs-e (get-letrefs-e ts ctor-e) + refs-e (into (sorted-set) (map #(::ref (get (:eav ts) %))) letrefs-e) frees-e (into (sorted-set) (take-while #(< % ctor-e)) refs-e) ->free-idx (->->id)] (recur (reduce (fn [ts free-e] @@ -546,10 +561,10 @@ (reduced (::free-idx pf))))) nil parent-frees-e))})))) ts frees-e) - ctor-e letrefs2-e)) + ctor-e)) ts)) ;; _ (run! prn (->> ts :eav vals (sort-by :db/id))) - ts (-> ts (order (->->id) (find-return-node ts (get-root-e ts))) capture-frees) + ts (-> ts (order (->->id) (find-return-node ts (get-root-e ts))) capture-frees index-calls) gen (fn gen [ts e ctor-e top?] ; `top?` - let at top compiles to the value, otherwise to reference of it (let [nd (get (:eav ts) e) frees-e (-> ts :ave ::free-of-ctor (get ctor-e)) @@ -569,13 +584,16 @@ (list `r-free pfe) (list `r-local (->> nd ::ref (get (:eav ts)) ::order)))) (-> ts :ave ::free-of-ctor (get e)))) - #_else (throw (ex-info (str "cannot gen-top: " (::type nd)) {:nd nd}))))) + ::call (list `r-call (::call-idx nd)) + #_else (throw (ex-info (str "cannot gen: " (::type nd)) {:nd nd}))))) + gen-call-ctors-vec (fn gen-call-ctors-vec [ts] + (into [] (map #(-> ts :eav (get %) ::ctor-order)) (-> ts :ave ::type ::call))) defs (mapv #(gen ts % (::parent (get (:eav ts) %)) true) (->> ts :ave ::order vals (reduce into) (sort-by #(->> % (get (:eav ts)) ::order))))] ;; (run! prn (->> ts :eav vals (sort-by :db/id))) `(r/peer (r-defs ~@(conj defs (let [ret-e (find-return-node ts (get-root-e ts))] (gen ts ret-e (::parent (get (:eav ts) ret-e)) true)))) - [] ~(count defs)))) + ~(gen-call-ctors-vec ts) ~(count defs)))) (defn compile [form env] (let [ts (ts/->ts {::->id (->->id), ::env env})] diff --git a/test/hyperfiddle/electric_compiler_test.clj b/test/hyperfiddle/electric_compiler_test.clj index 67ce3c69e..5dd1a68ad 100644 --- a/test/hyperfiddle/electric_compiler_test.clj +++ b/test/hyperfiddle/electric_compiler_test.clj @@ -127,14 +127,85 @@ [] 4) - ;; (l/compile-client (::lang/call (::lang/ctor :foo))) - ;; := `(r/peer - ;; (lang/r-defs - ;; (lang/r-static :foo) - ;; (lang/r-ctor [] 0) - ;; (lang/r-call 0)) - ;; [1] 2) + (l/compile-client (let [x (::lang/ctor :foo)] x)) + := `(r/peer + (lang/r-defs + (lang/r-ctor [] 1) + (lang/r-static :foo) + (lang/r-local 0)) + [] 2) + + (l/compile-client (let [x (::lang/ctor :foo), y x] (::lang/call y))) + := `(r/peer + (lang/r-defs + (lang/r-local 1) + (lang/r-ctor [] 2) + (lang/r-static :foo) + (lang/r-call 0)) + [0] 3) + + (l/compile-client (::lang/call (::lang/ctor :foo))) + := `(r/peer + (lang/r-defs + (lang/r-static :foo) + (lang/r-ctor [] 0) + (lang/r-call 0)) + [1] 2) + + (l/compile-client (vector 1 (::lang/call (::lang/ctor :foo)))) + := `(r/peer + (lang/r-defs + (lang/r-static :foo) + (lang/r-ctor [] 0) + (lang/r-ap (lang/r-static ~'vector) + (lang/r-static 1) + (lang/r-call 0))) + [1] 2) + + (l/compile-client (let [x (::lang/ctor :foo)] [(::lang/call x) (::lang/call x)])) + := `(r/peer + (lang/r-defs + (lang/r-ctor [] 1) + (lang/r-static :foo) + (lang/r-ap (lang/r-static clojure.core/vector) + (lang/r-call 0) + (lang/r-call 1))) + [0 0] + 2) + := `(r/peer + (lang/r-defs + (lang/r-ctor [] 1) + (lang/r-static :foo) + (lang/r-local 0) + (lang/r-local 0) + (lang/r-ap (lang/r-static clojure.core/vector) + (lang/r-call 0) + (lang/r-call 1))) + [2 3] 4) + + (l/compile-client [(::lang/call (::lang/ctor :foo)) (::lang/call (::lang/ctor :bar))]) + := `(r/peer + (lang/r-defs + (lang/r-static :foo) + (lang/r-ctor [] 0) + (lang/r-static :bar) + (lang/r-ctor [] 2) + (lang/r-ap (lang/r-static clojure.core/vector) + (lang/r-call 0) + (lang/r-call 1))) + [1 3] 4) + + (l/compile-client (let [a :foo] (::lang/call (::lang/ctor (::lang/ctor a))))) + := `(r/peer + (lang/r-defs + (lang/r-static :foo) + (lang/r-free 0) + (lang/r-ctor [] 1 (lang/r-free 0)) + (lang/r-ctor [] 2 (lang/r-local 0)) + (lang/r-call 0)) + [3] 4) ) + (comment ;; (defn lang/compile [env form] (l/compile-client 1) @@ -264,8 +335,8 @@ (lang/r-static :y) (lang/r-static :z) (lang/r-ap (lang/r-ap (lang/r-static hash-map) - (lang/r-static nil) (lanr-ctoror [] 0)) - (lang/r-static :x) (lanr-ctoror [] 1)) + (lang/r-static nil) (lang/r-ctor [] 0)) + (lang/r-static :x) (lang/r-ctor [] 1)) (lang/r-call 0)) [2] 3) From e10d435ff8fb3a586f48105ce9a806fdc96999fb Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 2 Jan 2024 14:35:23 +0100 Subject: [PATCH 021/428] refactor --- src/hyperfiddle/electric/impl/lang_de.clj | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/hyperfiddle/electric/impl/lang_de.clj b/src/hyperfiddle/electric/impl/lang_de.clj index 19f744afd..c5a2482d4 100644 --- a/src/hyperfiddle/electric/impl/lang_de.clj +++ b/src/hyperfiddle/electric/impl/lang_de.clj @@ -514,7 +514,7 @@ ::static ts ::ap (reduce (fn [ts e] (order ts ->order e)) ts (get-children-e ts e)) ::let (reduce (fn [ts e] (order ts ->order e)) - (ts/upd ts e ::order (fn [_] (->order))) + (ts/asc ts e ::order (->order)) (get-children-e ts e)) ::let-ref (order ts ->order (::ref nd)) ::ctor (let [ce (first (get-children-e ts e))] From 6991e1040ac65eaf3435af9f7e3e90f7944f659f Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 2 Jan 2024 16:13:33 +0100 Subject: [PATCH 022/428] compiler: case, quote, map literal --- src/hyperfiddle/electric/impl/lang_de.clj | 12 ++++++++- test/hyperfiddle/electric_compiler_test.clj | 28 +++++++++++++++++++++ 2 files changed, 39 insertions(+), 1 deletion(-) diff --git a/src/hyperfiddle/electric/impl/lang_de.clj b/src/hyperfiddle/electric/impl/lang_de.clj index c5a2482d4..61590cdf4 100644 --- a/src/hyperfiddle/electric/impl/lang_de.clj +++ b/src/hyperfiddle/electric/impl/lang_de.clj @@ -483,12 +483,22 @@ (let [e (->id)] (recur (analyze v e (ts/add ts {:db/id e, ::parent pe, ::type ::let, ::sym s})) e)) (analyze bform pe ts))) + (case) (let [[_ test & brs] form + [default brs2] (if (odd? (count brs)) [(last brs) (butlast brs)] [:TODO brs])] + (loopr [bs [], mp {}] + [[v br] (partition 2 brs2)] + (let [b (gensym "case-val")] + (recur (conj bs b `(::ctor ~br)) + (reduce (fn [ac nx] (assoc ac (list 'quote nx) b)) mp (if (seq v) v [v])))) + (recur `(let* ~bs (::call (~mp ~test (::ctor ~default)))) pe ts))) + (quote) (ts/add ts {:db/id (->id), ::parent pe, ::type ::static, ::v (list 'quote (second form))}) (::ctor) (let [e (->id)] (recur (second form) e (ts/add ts {:db/id e, ::parent pe, ::type ::ctor}))) (::call) (let [e (->id)] (recur (second form) e (ts/add ts {:db/id e, ::parent pe, ::type ::call}))) #_else (let [e (->id)] (reduce (fn [ts nx] (analyze nx e ts)) (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) form))) (vector? form) (recur (?meta form (cons `vector form)) pe ts) + (map? form) (recur (?meta form (cons `hash-map (eduction cat form))) pe ts) (symbol? form) (if-some [lx-e (find-let-ref form pe ts)] @@ -521,7 +531,7 @@ (ensure-ordered (order ts ->order ce) ->order ce)) ::call (let [ce (first (get-children-e ts e)) ts (order ts ->order ce)] - (cond-> ts (= ::ctor (::type (get (:eav ts) ce))) (ensure-ordered ->order ce))) + (cond-> ts (not (= ::let-ref (::type (get (:eav ts) ce)))) (ensure-ordered ->order ce))) #_else (throw (ex-info (str "cannot order: " (::type nd)) {:nd nd})))))) index-calls (fn index-calls [ts] (let [->idx (->->id)] diff --git a/test/hyperfiddle/electric_compiler_test.clj b/test/hyperfiddle/electric_compiler_test.clj index 5dd1a68ad..88a91980f 100644 --- a/test/hyperfiddle/electric_compiler_test.clj +++ b/test/hyperfiddle/electric_compiler_test.clj @@ -204,6 +204,34 @@ (lang/r-ctor [] 2 (lang/r-local 0)) (lang/r-call 0)) [3] 4) + + ;; ({nil (ctor :y)} :x (ctor :z)) + (l/compile-client (case :x nil :y :z)) + := `(r/peer + (lang/r-defs + (lang/r-ctor [] 1) + (lang/r-static :y) + (lang/r-static :z) + (lang/r-ap (lang/r-ap (lang/r-static clojure.core/hash-map) + (lang/r-static 'nil) (lang/r-local 0)) + (lang/r-static :x) + (lang/r-ctor [] 2)) + (lang/r-call 0)) + [3] 4) + + (l/compile-client (case 'foo (foo bar) :share-this :else)) + := `(r/peer + (lang/r-defs + (lang/r-ctor [] 1) + (lang/r-static :share-this) + (lang/r-static :else) + (lang/r-ap (lang/r-ap (lang/r-static clojure.core/hash-map) + (lang/r-static '~'foo) (lang/r-local 0) + (lang/r-static '~'bar) (lang/r-local 0)) + (lang/r-static '~'foo) + (lang/r-ctor [] 2)) + (lang/r-call 0)) + [3] 4) ) (comment From 2efb4ce414cc9d65506cb61451a247c650137ccc Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 2 Jan 2024 16:14:38 +0100 Subject: [PATCH 023/428] refactor --- src/hyperfiddle/electric/impl/lang_de.clj | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/hyperfiddle/electric/impl/lang_de.clj b/src/hyperfiddle/electric/impl/lang_de.clj index 61590cdf4..af0c7deda 100644 --- a/src/hyperfiddle/electric/impl/lang_de.clj +++ b/src/hyperfiddle/electric/impl/lang_de.clj @@ -491,7 +491,7 @@ (recur (conj bs b `(::ctor ~br)) (reduce (fn [ac nx] (assoc ac (list 'quote nx) b)) mp (if (seq v) v [v])))) (recur `(let* ~bs (::call (~mp ~test (::ctor ~default)))) pe ts))) - (quote) (ts/add ts {:db/id (->id), ::parent pe, ::type ::static, ::v (list 'quote (second form))}) + (quote) (ts/add ts {:db/id (->id), ::parent pe, ::type ::static, ::v form}) (::ctor) (let [e (->id)] (recur (second form) e (ts/add ts {:db/id e, ::parent pe, ::type ::ctor}))) (::call) (let [e (->id)] (recur (second form) e (ts/add ts {:db/id e, ::parent pe, ::type ::call}))) #_else (let [e (->id)] From bfc5b4ab84fb4c902158af504d7d15c6207845b3 Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 3 Jan 2024 12:09:43 +0100 Subject: [PATCH 024/428] compiler: pure, join --- src/hyperfiddle/electric/impl/lang_de.clj | 9 +++++++++ test/hyperfiddle/electric_compiler_test.clj | 12 ++++++++++++ 2 files changed, 21 insertions(+) diff --git a/src/hyperfiddle/electric/impl/lang_de.clj b/src/hyperfiddle/electric/impl/lang_de.clj index af0c7deda..195e88faa 100644 --- a/src/hyperfiddle/electric/impl/lang_de.clj +++ b/src/hyperfiddle/electric/impl/lang_de.clj @@ -50,6 +50,9 @@ (defmacro r-call [id] `(i/latest-concat (r/tier-slot r/*tier* ~id))) +(defmacro r-join [expr] + `(r/pure ~expr)) + (defmacro r-join [expr] `(i/latest-concat ~expr)) @@ -494,6 +497,8 @@ (quote) (ts/add ts {:db/id (->id), ::parent pe, ::type ::static, ::v form}) (::ctor) (let [e (->id)] (recur (second form) e (ts/add ts {:db/id e, ::parent pe, ::type ::ctor}))) (::call) (let [e (->id)] (recur (second form) e (ts/add ts {:db/id e, ::parent pe, ::type ::call}))) + (::pure) (let [e (->id)] (recur (second form) e (ts/add ts {:db/id e, ::parent pe, ::type ::pure}))) + (::join) (let [e (->id)] (recur (second form) e (ts/add ts {:db/id e, ::parent pe, ::type ::join}))) #_else (let [e (->id)] (reduce (fn [ts nx] (analyze nx e ts)) (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) form))) @@ -532,6 +537,8 @@ ::call (let [ce (first (get-children-e ts e)) ts (order ts ->order ce)] (cond-> ts (not (= ::let-ref (::type (get (:eav ts) ce)))) (ensure-ordered ->order ce))) + ::pure (recur ts ->order (first (get-children-e ts e))) + ::join (recur ts ->order (first (get-children-e ts e))) #_else (throw (ex-info (str "cannot order: " (::type nd)) {:nd nd})))))) index-calls (fn index-calls [ts] (let [->idx (->->id)] @@ -595,6 +602,8 @@ (list `r-local (->> nd ::ref (get (:eav ts)) ::order)))) (-> ts :ave ::free-of-ctor (get e)))) ::call (list `r-call (::call-idx nd)) + ::pure (list `r-pure (gen ts (first (get-children-e ts e)) ctor-e top?)) + ::join (list `r-join (gen ts (first (get-children-e ts e)) ctor-e top?)) #_else (throw (ex-info (str "cannot gen: " (::type nd)) {:nd nd}))))) gen-call-ctors-vec (fn gen-call-ctors-vec [ts] (into [] (map #(-> ts :eav (get %) ::ctor-order)) (-> ts :ave ::type ::call))) diff --git a/test/hyperfiddle/electric_compiler_test.clj b/test/hyperfiddle/electric_compiler_test.clj index 88a91980f..dc747bd14 100644 --- a/test/hyperfiddle/electric_compiler_test.clj +++ b/test/hyperfiddle/electric_compiler_test.clj @@ -232,6 +232,18 @@ (lang/r-ctor [] 2)) (lang/r-call 0)) [3] 4) + + (l/compile-client (::lang/pure :foo)) + := `(r/peer + (lang/r-defs + (lang/r-pure (lang/r-static :foo))) + [] 0) + + (l/compile-client (::lang/join (::lang/pure :foo))) + := `(r/peer + (lang/r-defs + (lang/r-join (lang/r-pure (lang/r-static :foo)))) + [] 0) ) (comment From 81b67053a1bdcf99a720be4d0c013eab28c53bef Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 4 Jan 2024 22:04:07 +0100 Subject: [PATCH 025/428] triple store: don't fill in vea index, not used --- src/contrib/triple_store.clj | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/contrib/triple_store.clj b/src/contrib/triple_store.clj index e4ca3b7b8..16c3d18e2 100644 --- a/src/contrib/triple_store.clj +++ b/src/contrib/triple_store.clj @@ -13,7 +13,8 @@ ;; {:db/id 2, :foo 1, :bar 2}] ;; eav 1 :foo -> 1 ;; ave :foo 1 -> (sorted-set 1 2) <- sorted so e.g. :parent e is well ordered -;; vea 1 1 -> #{:foo :bar} +;; vea 1 1 -> #{:foo :bar} CURRENTLY NOT USED/FILLED + (defrecord TripleStore [o eav ave vea]) (defn ->ts ([] (->ts {})) ([o] (->TripleStore o {} {} {}))) @@ -25,7 +26,8 @@ [[a v] nd] (recur (update eav e assoc a v) (update ave a update v (fnil conj (sorted-set)) e) - (update vea v update e (fnil conj #{}) a)))] + vea + #_(update vea v update e (fnil conj #{}) a)))] (->TripleStore (:o ts) eav ave vea))) (defn upd [ts e a f] @@ -34,8 +36,10 @@ v1 (-> eav (get e) (get a)) ave (update (:ave ts) a update v1 (fnil conj (sorted-set)) e) ave (cond-> ave (contains? (get ave a) v0) (update a update v0 disj e)) - vea (update (:vea ts) v1 update e (fnil conj #{}) a) - vea (cond-> vea (contains? (get vea v0) e) (update v0 update e disj a))] + vea (:vea ts) + ;; vea (update (:vea ts) v1 update e (fnil conj #{}) a) + ;; vea (cond-> vea (contains? (get vea v0) e) (update v0 update e disj a)) + ] (->TripleStore (:o ts) eav ave vea))) (defn asc [ts e a v] (upd ts e a (fn [_] v))) From b379a9f3cd57d1593345ef438ad2bc25b85d1b77 Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 4 Jan 2024 22:04:56 +0100 Subject: [PATCH 026/428] compiler: source maps --- src/hyperfiddle/electric/impl/lang_de.clj | 67 ++++++++++++++++----- src/hyperfiddle/electric_local_def_de.cljc | 10 ++- test/hyperfiddle/electric_compiler_test.clj | 51 +++++++++++++++- 3 files changed, 107 insertions(+), 21 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de.clj b/src/hyperfiddle/electric/impl/lang_de.clj index 195e88faa..f1493bc4a 100644 --- a/src/hyperfiddle/electric/impl/lang_de.clj +++ b/src/hyperfiddle/electric/impl/lang_de.clj @@ -476,6 +476,10 @@ pe (recur (::parent p))))))) +(defn ?add-source-map [{{::keys [->id]} :o :as ts} pe form] + (let [mt (meta form)] + (cond-> ts (:line mt) (ts/add {:db/id (->id), ::source-map-of pe, ::line (:line mt), ::column (:column mt)})))) + (defn analyze [form pe {{::keys [env ->id]} :o :as ts}] (cond (and (seq? form) (seq form)) @@ -484,7 +488,8 @@ (loopr [ts ts, pe pe] [[s v] (eduction (partition-all 2) bs)] (let [e (->id)] - (recur (analyze v e (ts/add ts {:db/id e, ::parent pe, ::type ::let, ::sym s})) e)) + (recur (analyze v e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::let, ::sym s}) + (?add-source-map e form))) e)) (analyze bform pe ts))) (case) (let [[_ test & brs] form [default brs2] (if (odd? (count brs)) [(last brs) (butlast brs)] [:TODO brs])] @@ -493,26 +498,35 @@ (let [b (gensym "case-val")] (recur (conj bs b `(::ctor ~br)) (reduce (fn [ac nx] (assoc ac (list 'quote nx) b)) mp (if (seq v) v [v])))) - (recur `(let* ~bs (::call (~mp ~test (::ctor ~default)))) pe ts))) + (recur (?meta form `(let* ~bs (::call (~mp ~test (::ctor ~default))))) pe ts))) (quote) (ts/add ts {:db/id (->id), ::parent pe, ::type ::static, ::v form}) - (::ctor) (let [e (->id)] (recur (second form) e (ts/add ts {:db/id e, ::parent pe, ::type ::ctor}))) - (::call) (let [e (->id)] (recur (second form) e (ts/add ts {:db/id e, ::parent pe, ::type ::call}))) - (::pure) (let [e (->id)] (recur (second form) e (ts/add ts {:db/id e, ::parent pe, ::type ::pure}))) - (::join) (let [e (->id)] (recur (second form) e (ts/add ts {:db/id e, ::parent pe, ::type ::join}))) + (::ctor) (let [e (->id)] (recur (second form) e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ctor}) + (?add-source-map e form)))) + (::call) (let [e (->id)] (recur (second form) e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::call}) + (?add-source-map e form)))) + (::pure) (let [e (->id)] (recur (second form) e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::pure}) + (?add-source-map e form)))) + (::join) (let [e (->id)] (recur (second form) e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::join}) + (?add-source-map e form)))) #_else (let [e (->id)] - (reduce (fn [ts nx] (analyze nx e ts)) (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) form))) + (reduce (fn [ts nx] (analyze nx e ts)) (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) + (?add-source-map e form)) form))) (vector? form) (recur (?meta form (cons `vector form)) pe ts) (map? form) (recur (?meta form (cons `hash-map (eduction cat form))) pe ts) (symbol? form) - (if-some [lx-e (find-let-ref form pe ts)] - (ts/add ts {:db/id (->id), ::parent pe, ::type ::let-ref, ::ref lx-e, ::sym form}) - (ts/add ts {:db/id (->id), ::parent pe, ::type ::static, ::v form}) - ) + (let [e (->id)] + (if-some [lr-e (find-let-ref form pe ts)] + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::let-ref, ::ref lr-e, ::sym form}) + (?add-source-map e form)) + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::static, ::v form}) + (?add-source-map e form)))) :else - (ts/add ts {:db/id (->id), ::parent pe, ::type ::static, ::v form}))) + (let [e (->id)] + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::static, ::v form}) + (?add-source-map e form))))) (defn ->->id [] (let [!i (long-array [-1])] (fn [] (aset !i 0 (unchecked-inc (aget !i 0)))))) @@ -605,14 +619,35 @@ ::pure (list `r-pure (gen ts (first (get-children-e ts e)) ctor-e top?)) ::join (list `r-join (gen ts (first (get-children-e ts e)) ctor-e top?)) #_else (throw (ex-info (str "cannot gen: " (::type nd)) {:nd nd}))))) + get-source-map (fn get-source-map [ts e] + (let [eav (:eav ts)] + (loop [e e] + (or (get eav (-> ts :ave ::source-map-of (get e) first)) + (some-> (-> eav (get e) ::parent) recur))))) + gen-sm (fn gen-sm [ts e top?] ; `top?` - let at top compiles to the value, otherwise to reference of it + (let [nd (get (:eav ts) e)] + (case (::type nd) + ::static (get-source-map ts e) + ::ap (cons (get-source-map ts e) (mapv #(gen-sm ts % false) (get-children-e ts e))) + ::let (gen-sm ts ((if top? first second) (get-children-e ts e)) false) + ::let-ref nil + ::ctor (get-source-map ts e) + ::call (get-source-map ts e) + ::pure (list (get-source-map ts e) (gen-sm ts (first (get-children-e ts e)) top?)) + ::join (list (get-source-map ts e) (gen-sm ts (first (get-children-e ts e)) top?)) + #_else (throw (ex-info (str "cannot gen-sm: " (::type nd)) {:nd nd}))))) gen-call-ctors-vec (fn gen-call-ctors-vec [ts] (into [] (map #(-> ts :eav (get %) ::ctor-order)) (-> ts :ave ::type ::call))) - defs (mapv #(gen ts % (::parent (get (:eav ts) %)) true) - (->> ts :ave ::order vals (reduce into) (sort-by #(->> % (get (:eav ts)) ::order))))] + roots (->> ts :ave ::order vals (reduce into) (sort-by #(->> % (get (:eav ts)) ::order)))] ;; (run! prn (->> ts :eav vals (sort-by :db/id))) - `(r/peer (r-defs ~@(conj defs (let [ret-e (find-return-node ts (get-root-e ts))] + (cond-> {:source + `(r/peer (r-defs ~@(conj (mapv #(gen ts % (::parent (get (:eav ts) %)) true) roots) + (let [ret-e (find-return-node ts (get-root-e ts))] (gen ts ret-e (::parent (get (:eav ts) ret-e)) true)))) - ~(gen-call-ctors-vec ts) ~(count defs)))) + ~(gen-call-ctors-vec ts) ~(count roots))} + (::include-source-map env) (assoc :source-map + (conj (mapv #(gen-sm ts % true) roots) + (gen-sm ts (find-return-node ts (get-root-e ts)) true)))))) (defn compile [form env] (let [ts (ts/->ts {::->id (->->id), ::env env})] diff --git a/src/hyperfiddle/electric_local_def_de.cljc b/src/hyperfiddle/electric_local_def_de.cljc index e4a4d5b1a..d423652df 100644 --- a/src/hyperfiddle/electric_local_def_de.cljc +++ b/src/hyperfiddle/electric_local_def_de.cljc @@ -14,7 +14,13 @@ (defmacro compile-client [form] (let [env (merge &env (->local-config &env) {::lang/me :client})] - `(lang/compile '~form ~env ))) + `(:source (lang/compile '~form ~env)))) +(defmacro compile-client-source-map [form] + (let [env (merge &env (->local-config &env) {::lang/me :client})] + `(:source-map (lang/compile '~form (assoc ~env ::lang/include-source-map true))))) +(defmacro compile-client-with-source-map [form] + (let [env (merge &env (->local-config &env) {::lang/me :client})] + `(lang/compile '~form (assoc ~env ::lang/include-source-map true)))) (defmacro compile-server [form] (let [env (merge &env (->local-config &env) {::lang/me :server})] - `(lang/compile '~form ~env ))) + `(:source (lang/compile '~form ~env)))) diff --git a/test/hyperfiddle/electric_compiler_test.clj b/test/hyperfiddle/electric_compiler_test.clj index dc747bd14..ccb8cd407 100644 --- a/test/hyperfiddle/electric_compiler_test.clj +++ b/test/hyperfiddle/electric_compiler_test.clj @@ -246,6 +246,51 @@ [] 0) ) +(tests + ;; ( ) + ;; source-map => ::line ::column + (number? (-> (l/compile-client-source-map (prn "hello world")) first ::lang/line)) := true + (let [sm (l/compile-client-source-map (let [x "Hello world", y "Hello world"] [x y])) + line (-> sm first ::lang/line)] + (number? line) := true ; x + (-> sm second ::lang/line) := line ; y + (-> sm (nth 2) first ::lang/line) := line ; ap + (-> sm (nth 2) second ::lang/line) := line) ; [] + + (let [sm (l/compile-client-source-map (::lang/ctor :foo)) + line (-> sm first ::lang/line)] + (number? line) := true ; static :foo + (-> sm second ::lang/line) := line) ; ctor + + (let [sm (l/compile-client-source-map (::lang/call (::lang/ctor :foo))) + line (-> sm first ::lang/line)] + (number? line) := true ; static :foo + (-> sm (nth 1) ::lang/line) := line ; ctor + (-> sm (nth 2) ::lang/line) := line) ; call + + (let [sm (l/compile-client-source-map (::lang/pure :foo))] + (number? (-> sm ffirst ::lang/line)) := true) ; pure + + (let [sm (l/compile-client-source-map (::lang/join (::lang/pure :foo)))] + (number? (-> sm ffirst ::lang/line)) := true) ; join + + (let [sm (l/compile-client-source-map (case :x nil :y :z)) + line (-> sm first ::lang/line)] + (every? #(= line (::lang/line (cond-> % (seq? %) first))) sm) := true) ; every toplevel case flow + + (let [sm (l/compile-client-source-map (-> 1 inc))] + (number? (-> sm ffirst ::lang/line)) := true) ; ap + + (let [sm (l/compile-client-source-map (do 1 2))] + (every? number? (eduction (map #(cond-> % (seq? %) first)) (map ::lang/line) (first sm)))) ; every toplevel do flow + + ;; TODO `loop` needs binding and electric defs + ;; (let [sm (l/compile-client-with-source-map (loop [x 1] (recur (inc x))))]) + + ;; TODO `set!` needs cc/fn + ;; (let [sm (l/compile-client-with-source-map (set! (.-x (Object.)) 1))]) + ) + (comment ;; (defn lang/compile [env form] (l/compile-client 1) @@ -316,8 +361,8 @@ := `(r/peer (lang/r-defs (lang/r-join (lang/r-ap (lang/r-static i/fixed) - (lang/r-ap (lang/r-static m/watch) - (lang/r-static !x))))) + (lang/r-ap (lang/r-static m/watch) + (lang/r-static !x))))) [] 0) ;; pure (get the incseq of an expression) (e/pure (e/join x)) is (e/join (e/pure x)) is x @@ -375,7 +420,7 @@ (lang/r-static :y) (lang/r-static :z) (lang/r-ap (lang/r-ap (lang/r-static hash-map) - (lang/r-static nil) (lang/r-ctor [] 0)) + (lang/r-static nil) (lang/r-ctor [] 0)) (lang/r-static :x) (lang/r-ctor [] 1)) (lang/r-call 0)) [2] 3) From 47cbf7a73fcef3a9f24c34a803e71071cb1f8e5c Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 11 Jan 2024 12:52:49 +0100 Subject: [PATCH 027/428] compiler: cc/fn --- src/hyperfiddle/electric/impl/lang_de.clj | 7 ++++++ src/hyperfiddle/electric_local_def_de.cljc | 2 +- test/hyperfiddle/electric_compiler_test.clj | 25 +++++++++++++++++++++ 3 files changed, 33 insertions(+), 1 deletion(-) diff --git a/src/hyperfiddle/electric/impl/lang_de.clj b/src/hyperfiddle/electric/impl/lang_de.clj index f1493bc4a..963e60895 100644 --- a/src/hyperfiddle/electric/impl/lang_de.clj +++ b/src/hyperfiddle/electric/impl/lang_de.clj @@ -489,6 +489,7 @@ [[s v] (eduction (partition-all 2) bs)] (let [e (->id)] (recur (analyze v e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::let, ::sym s}) + (update-in [:o ::env :locals s] assoc ::electric-let true, :db/id e) (?add-source-map e form))) e)) (analyze bform pe ts))) (case) (let [[_ test & brs] form @@ -500,6 +501,12 @@ (reduce (fn [ac nx] (assoc ac (list 'quote nx) b)) mp (if (seq v) v [v])))) (recur (?meta form `(let* ~bs (::call (~mp ~test (::ctor ~default))))) pe ts))) (quote) (ts/add ts {:db/id (->id), ::parent pe, ::type ::static, ::v form}) + (fn*) (let [e (->id), ce (->id) + [form refs] (closure env form) + ts2 (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) + (?add-source-map e form) + (ts/add {:db/id ce, ::parent e, ::type ::static, ::v form}))] + (reduce (fn [ts nx] (analyze nx e ts)) ts2 refs)) (::ctor) (let [e (->id)] (recur (second form) e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ctor}) (?add-source-map e form)))) (::call) (let [e (->id)] (recur (second form) e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::call}) diff --git a/src/hyperfiddle/electric_local_def_de.cljc b/src/hyperfiddle/electric_local_def_de.cljc index d423652df..44a87ce6f 100644 --- a/src/hyperfiddle/electric_local_def_de.cljc +++ b/src/hyperfiddle/electric_local_def_de.cljc @@ -13,7 +13,7 @@ {::lang/peers {p (if (:js-globals env) :cljs :clj)}, ::lang/current p, ::lang/me p})) (defmacro compile-client [form] - (let [env (merge &env (->local-config &env) {::lang/me :client})] + (let [env (merge &env (->local-config &env) {::lang/me :client, :ns (list 'quote (ns-name *ns*))})] `(:source (lang/compile '~form ~env)))) (defmacro compile-client-source-map [form] (let [env (merge &env (->local-config &env) {::lang/me :client})] diff --git a/test/hyperfiddle/electric_compiler_test.clj b/test/hyperfiddle/electric_compiler_test.clj index ccb8cd407..5566dc62c 100644 --- a/test/hyperfiddle/electric_compiler_test.clj +++ b/test/hyperfiddle/electric_compiler_test.clj @@ -244,6 +244,31 @@ (lang/r-defs (lang/r-join (lang/r-pure (lang/r-static :foo)))) [] 0) + + (l/compile-client ((fn [] 1))) + ;; ;; rest-args gensym breaks testability + ;; ;; also, testing this deep is counter-productive, we're testing the implementation (internals) + ;; := `(r/peer + ;; (lang/r-defs + ;; (lang/r-ap + ;; (lang/r-ap + ;; (lang/r-static + ;; (clojure.core/fn [] + ;; (clojure.core/fn [& rest-args32938] + ;; (clojure.core/apply (fn* ([] 1)) rest-args32938))))))) + ;; [] 0) + + (l/compile-client (let [x 1] (fn [] x))) + ;; := `(r/peer + ;; (lang/r-defs + ;; (lang/r-static 1) + ;; (lang/r-ap (lang/r-static + ;; (clojure.core/fn [x32133] + ;; (clojure.core/fn [& rest-args32134] + ;; (clojure.core/let [x x32133] + ;; (clojure.core/apply (fn* ([] x)) rest-args32134))))) + ;; (lang/r-local 0))) + ;; [] 1) ) (tests From 76b337f628a2ac103d7b3cc8b1ca5dfb4400c005 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Fri, 12 Jan 2024 10:52:43 +0100 Subject: [PATCH 028/428] new design with dynamic sites + unified defs --- src/hyperfiddle/electric/impl/runtime_de.cljc | 406 ++++++++++-------- test/hyperfiddle/electric_compiler_test.clj | 385 ++++++++--------- 2 files changed, 406 insertions(+), 385 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 88fe8428a..52729b987 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -3,46 +3,24 @@ [missionary.core :as m]) #?(:clj (:import (clojure.lang IFn IDeref)))) -(def ^:dynamic *tier*) - -(def ^{::type ::node, :doc "for loop/recur impl"} rec) - -#?(:clj - (def arg-sym - (map (comp symbol - (partial intern *ns*) - (fn [i] - (with-meta (symbol (str "%" i)) - {::type ::node}))) - (range)))) -;; pre-define the first 20 for e/fn varargs expansion -(def ^{::type ::node} %0) -(def ^{::type ::node} %1) -(def ^{::type ::node} %2) -(def ^{::type ::node} %3) -(def ^{::type ::node} %4) -(def ^{::type ::node} %5) -(def ^{::type ::node} %6) -(def ^{::type ::node} %7) -(def ^{::type ::node} %8) -(def ^{::type ::node} %9) -(def ^{::type ::node} %10) -(def ^{::type ::node} %11) -(def ^{::type ::node} %12) -(def ^{::type ::node} %13) -(def ^{::type ::node} %14) -(def ^{::type ::node} %15) -(def ^{::type ::node} %16) -(def ^{::type ::node} %17) -(def ^{::type ::node} %18) -(def ^{::type ::node} %19) +(deftype Peer [step done defs ^objects state] + IFn + (#?(:clj invoke :cljs -invoke) [_] + (prn :cancel-peer) -(def peer-slot-input 0) -(def peer-slot-store 1) -(def peer-slots 2) + ) + IDeref + (#?(:clj deref :cljs -deref) [_] + (prn :transfer-peer) + + )) + +(deftype Pure [values] + IFn + (#?(:clj invoke :cljs -invoke) [_ step done] + ((apply i/fixed (map #(m/cp %) values)) step done))) -(defn pure [form] - (i/fixed (m/cp form))) +(defn pure [& xs] (->Pure xs)) (defn error [^String msg] #?(:clj (Error. msg) @@ -60,174 +38,163 @@ (#?(:clj invoke :cljs -invoke) [_ step done] (step) (->Failer done (error (str "Unbound electric var lookup - " (pr-str k)))))) -(deftype Ctor [peer slots output free vars]) +(deftype Cdef [frees nodes calls result build]) -(deftype Peer [step done defs state] - IFn - (#?(:clj invoke :cljs -invoke) [_] - (prn :cancel-peer) +(def cdef ->Cdef) - ) - IDeref - (#?(:clj deref :cljs -deref) [_] - (prn :transfer-peer) +(deftype Ctor [^Peer peer key idx ^objects free env]) - )) +(defn bind [^Ctor ctor k v] + (->Ctor (.-peer ctor) (.-key ctor) (.-idx ctor) (.-free ctor) + (assoc (.-env ctor) k v))) -(defn bind [^Ctor ctor peer k v] - (when-not (identical? peer (.-peer ctor)) - (throw (error "Can't bind foreign constructor."))) - (->Ctor peer (.-slots ctor) (.-output ctor) (.-free ctor) - (assoc (.-vars ctor) k v))) - -(defrecord Var [peer k] - IFn - (#?(:clj invoke :cljs -invoke) [_ ctor v] - (bind ctor peer k v))) +(defn ctor-peer + "Returns the peer of given constructor." + {:tag Peer} + [^Ctor ctor] + (.-peer ctor)) -(declare tier-ctor) -(declare ctor-peer) +(defn ctor-cdef + "Returns the cdef of given constructor." + {:tag Cdef} + [^Ctor ctor] + (((.-defs (ctor-peer ctor)) (.-key ctor)) (.-idx ctor))) -(deftype StoredPs [k ps] +;; TODO local? +(deftype Frame [parent call-id ^Ctor ctor ^objects signals] IFn - (#?(:clj invoke :cljs -invoke) [_] - (let [peer (.-state (ctor-peer (tier-ctor (:tier k))))] - (aset peer peer-slot-store - (dissoc (aget peer peer-slot-store) k))) - (ps)) - IDeref - (#?(:clj deref :cljs -deref) [_] @ps)) - -(defn get-flow [tier id] - ((.-defs (ctor-peer (tier-ctor tier))) tier id)) + (#?(:clj invoke :cljs -invoke) [_ step done] + (let [cdef (ctor-cdef ctor)] + ((aget signals + (+ (count (.-nodes cdef)) + (count (.-calls cdef)))) + step done)))) + +(defn frame-ctor + "Returns the constructor of given frame." + {:tag Ctor} + [^Frame frame] + (.-ctor frame)) -(defrecord Node [tier id] +(deftype Node [frame id] IFn - (#?(:clj invoke :cljs -invoke) [node step done] - ((let [^objects peer (.-state (ctor-peer (tier-ctor tier))) - store (aget peer peer-slot-store)] - (if-some [s (get store node)] - s (let [n (get-flow tier id) - s (m/signal i/combine (fn [step done] (->StoredPs node (n step done))))] - (aset peer peer-slot-store (assoc store node s)) s))) + (#?(:clj invoke :cljs -invoke) [_ step done] + ((aget (.-signals frame) + (bit-shift-left id 1)) step done))) -(deftype Tier [parent slot-id ^Ctor ctor] +(deftype Call [frame id] IFn - (#?(:clj invoke :cljs -invoke) [tier step done] - ((->Node tier (.-output ctor)) step done))) + (#?(:clj invoke :cljs -invoke) [_ step done] + (let [cdef (ctor-cdef (frame-ctor frame))] + ((aget (.-signals frame) + (+ (count (.-nodes cdef)) id)) + step done)))) + +(defn make-frame [^Frame frame call-id ctor] + (let [cdef (ctor-cdef ctor) + length (+ (count (.-nodes cdef)) + (count (.-calls cdef))) + signals (object-array (inc length)) + frame (->Frame frame call-id ctor signals)] + (aset signals length ((.-build cdef) frame)) frame)) + +(defn define-node + "Defines signals node id for given frame." + [^Frame frame id incseq] + (let [signals (.-signals frame)] + (when-not (nil? (aget signals id)) + (throw (error "Can't redefine signal node."))) + (aset signals id (m/signal i/combine incseq)) nil)) + +(defn define-call + "Defines call site id for given frame." + [^Frame frame id incseq] + (let [signals (.-signals frame) + slot (-> (.-nodes (ctor-cdef (frame-ctor frame))) + (count) (+ id))] + (when-not (nil? (aget signals slot)) + (throw (error "Can't redefine call site."))) + (aset signals slot + (m/signal i/combine + (i/latest-product + (fn [ctor] + (when-not (instance? Ctor ctor) + (throw (error (str "Not a constructor - " (pr-str ctor))))) + (when-not (identical? (ctor-peer (frame-ctor frame)) (ctor-peer ctor)) + (throw (error "Can't call foreign constructor."))) + (make-frame frame id ctor)) incseq))) nil)) + +(defn define-free + "Defines free variable id for given constructor." + [^Ctor ctor id incseq] + (let [free (.-free ctor)] + (when-not (nil? (aget free id)) + (throw (error "Can't redefine free variable."))) + (aset free id incseq) nil)) + +(defn frame-parent + "Returns the parent frame of given frame if not root, nil otherwise." + {:tag Frame} + [^Frame frame] + (.-parent frame)) + +(defn frame-call-id + "Returns the call id of given frame." + [^Frame frame] + (.-call-id frame)) + +(defn frame-call-count + "Returns the call count of given frame." + [^Frame frame] + (.-calls (ctor-cdef (frame-ctor frame)))) + +(defn lookup + "Returns the value associated with given key in the dynamic environment of given frame." + ([^Frame frame key] + (lookup frame key (->Unbound key))) + ([^Frame frame key nf] + (loop [frame frame] + (if-some [s ((.-env (frame-ctor frame)) key)] + s (if-some [p (frame-parent frame)] + (recur p) nf))))) + +(defn make-ctor + "Returns a fresh constructor for cdef coordinates key and idx." + [^Frame frame key idx] + (let [^Peer peer (ctor-peer (frame-ctor frame)) + ^Cdef cdef (((.-defs peer) key) idx)] + (->Ctor peer key idx (object-array (.-frees cdef)) {}))) + +(defn node + "Returns the signal node id for given frame." + [^Frame frame id] + (->Node frame id)) + +(defn free + "Returns the free variable id for given frame." + [^Frame frame id] + (aget (.-free (frame-ctor frame)) id)) + +(defn call + "Returns the call site id for given frame." + [^Frame frame id] + (->Call frame id)) + +(def join i/latest-concat) +(def ap (partial i/latest-product (fn [f & args] (apply f args)))) -(defrecord Slot [tier id] - IFn - (#?(:clj invoke :cljs -invoke) [slot step done] - ((let [^Ctor ctor (tier-ctor tier) - ^Peer peer (ctor-peer ctor) - ^objects state (.-state peer) - store (aget state peer-slot-store)] - (if-some [s (get store slot)] - s (let [n (i/latest-product - (fn [ctor] - (when-not (instance? Ctor ctor) - (throw (error (str "Not a constructor - " (pr-str ctor))))) - (when-not (identical? peer (ctor-peer ctor)) - (throw (error "Can't call foreign constructor."))) - (->Tier tier id ctor)) - (get-flow tier (nth (.-slots ctor) id))) - s (m/signal i/combine (fn [step done] (->StoredPs slot (n step done))))] - (aset state peer-slot-store (assoc store slot s)) s))) - step done))) +(def peer-slot-input 0) +(def peer-slot-store 1) +(def peer-slots 2) (defn context-input-notify [^Peer peer done?] ;; TODO ) -(defn ctor-peer - "Returns the peer of given constructor." - {:tag Peer} - [^Ctor ctor] - (.-peer ctor)) - -(defn tier-parent - "Returns the parent tier of given tier if not root, nil otherwise." - {:tag Tier} - [^Tier tier] - (.-parent tier)) - -(defn tier-slot-id - "Returns the index of the slot of given tier within its parent." - [^Tier tier] - (.-slot-id tier)) - -(defn tier-slot - "Returns the slot for given tier and id." - {:tag Slot} - [^Tier tier id] - (->Slot tier id)) - -(defn tier-slot-count - "Returns the count of children of given tier." - [^Tier tier] - (count (.-slots (tier-ctor tier)))) - -(defn tier-output - "Returns the output of given tier." - {:tag Node} - [^Tier tier] - (->Node tier (.-output (tier-ctor tier)))) - -(defn tier-ctor - "Returns the constructor of given tier." - {:tag Ctor} - [^Tier tier] - (.-ctor tier)) - -(defn tier-peer - "Returns the peer of given tier." - {:tag Peer} - [tier] - (ctor-peer (tier-ctor tier))) - -(defn tier-lookup - "Returns the value associated with given key in the dynamic environment of given tier." - [tier k] - (loop [tier tier] - (if-some [s (get (.-vars (tier-ctor tier)) k)] - s (if-some [p (tier-parent tier)] - (recur p) (->Unbound k))))) - -(defn peer-ctor " -Returns a constructor for given peer, with slots defined by given vector of ids, output defined by given id, and -given array of free variables. -" [peer slots output free] - (->Ctor peer slots output free {})) - -(defn tier-local - "Returns the incremental sequence signal defined by given id in given tier." - [tier id] - (->Node tier id)) - -(defn tier-remote [tier id] - ;; TODO - ) - -(defn peer-var - "Returns the var associated with given key in given peer." - [^Peer peer k] - (->Var peer k)) - -(defn ctor-free - "Returns the i-th free variable of given constructor." - [^Ctor ctor i] - (aget ^objects (.-free ctor) i)) - -(defn tier-slot - "Returns the i-th slot of given tier." - [^Tier tier i] - (->Slot tier i)) - (defn peer " -Returns a peer definition from given node definitions and root constructor. -" [defs slots output] +Returns a peer definition from given definitions and main key. +" [defs main & args] (fn [msgs] (fn [step done] (let [state (object-array peer-slots) @@ -238,10 +205,67 @@ Returns a peer definition from given node definitions and root constructor. #(context-input-notify peer false) #(context-input-notify peer true))) - ((m/reduce (fn [_ x] (prn :output x)) nil - (->Tier nil 0 - (->Ctor peer slots output - (object-array 0) {}))) + ((->> args + (into {} (map-indexed (fn [i arg] [i (pure arg)]))) + (->Ctor peer main 0 (object-array 0)) + (make-frame nil 0) + (m/reduce (fn [_ x] (prn :output x)) nil)) #(prn :success %) #(prn :failure %)) peer)))) + +(comment + (defn r! [defs main & args] + (((apply peer defs main args) + (fn [!] (prn :boot) #())) + #(prn :s %) + #(prn :f %))) + + ;; pure + (r! {::Main [(cdef 0 [] [] nil (fn [frame] (pure "hello world")))]} ::Main) + + ;; variable + (def !x (atom 0)) + (r! {::Main [(cdef 0 [] [] nil (fn [frame] (join (pure (i/fixed (m/watch !x))))))]} ::Main) + (swap! !x inc) + + ;; conditional + (def !x (atom false)) + (r! {::Main [(cdef 0 [] [nil] nil + (fn [frame] + (define-call frame 0 + (ap (pure {false (make-ctor frame ::Main 1) + true (make-ctor frame ::Main 2)}) + (i/fixed (m/watch !x)))) + (join (call frame 0)))) + (cdef 0 [] [] nil + (fn [frame] + (pure "foo"))) + (cdef 0 [] [] nil + (fn [frame] + (pure "bar")))]} + ::Main) + (swap! !x not) + + ;; amb + (def !x (atom "bar")) + (r! {::Main [(cdef 0 [] [nil] nil + (fn [frame] + (define-call frame 0 + (pure + (make-ctor frame ::Main 1) + (make-ctor frame ::Main 2) + (make-ctor frame ::Main 3))) + (join (call frame 0)))) + (cdef 0 [] [] nil + (fn [frame] + (pure "foo"))) + (cdef 0 [] [] nil + (fn [frame] + (i/fixed (m/watch !x)))) + (cdef 0 [] [] nil + (fn [frame] + (pure "baz")))]} ::Main) + (reset! !x "bar") + + ) \ No newline at end of file diff --git a/test/hyperfiddle/electric_compiler_test.clj b/test/hyperfiddle/electric_compiler_test.clj index 5566dc62c..c7632299d 100644 --- a/test/hyperfiddle/electric_compiler_test.clj +++ b/test/hyperfiddle/electric_compiler_test.clj @@ -22,6 +22,7 @@ (try (apply f args) (catch Throwable e (find-source-map-info path)))) +;; TODO rewrite or remove (tests (l/compile-client 1) := `(r/peer (lang/r-defs (lang/r-static 1)) [] 0) (l/compile-server 1) := `(r/peer (lang/r-defs (lang/r-static 1)) [] 0) @@ -316,223 +317,219 @@ ;; (let [sm (l/compile-client-with-source-map (set! (.-x (Object.)) 1))]) ) +;; cdef = definition of the static structure of an e/ctor +;; args : +;; * free variable count +;; * a vector of node sites +;; * a vector of call sites +;; * the result site (comment - ;; (defn lang/compile [env form] - (l/compile-client 1) - ;; r/defs takes & flows with an implicit context (managed in runtime, thread-local or such) - ;; context - path of the node you're constructing in the call stack - := `(r/peer - (lang/r-defs - (lang/r-static 1)) - [] 0) + (l/compile ::Main 1) + := `[(r/cdef 0 [] [] nil + (fn [frame] + (r/pure 1)))] - ;; transfer - (l/compile-client (e/client "Hello world")) := - `(r/peer - (lang/r-defs - (lang/r-static "Hello world")) - [] 0) - (l/compile-client (e/client - (let [x "Hello world" - y "Hello world"] - [x y]))) - := `(r/peer - (lang/r-defs - (lang/r-static "Hello world") - (lang/r-static "Hello world") - (lang/r-ap (lang/r-static vector) (lang/r-local 0) (lang/r-local 1))) - [] 2) - - (l/compile-server (e/client "Hello world")) - := `(r/peer - (lang/r-defs - (lang/r-remote 0)) ;; 0 refers to client's r/defs - [] 0) + (l/compile ::Main `(e/client "Hello world")) := + `[(r/cdef 0 [] [] :client + (fn [frame] + (r/pure "Hello world")))] ;; function application - (l/compile-client (e/client (prn "Hello world"))) - := `(r/peer - (lang/r-defs - (lang/r-ap (lang/r-static prn) (lang/r-static "Hello world"))) - [] 0) + (l/compile ::Main (e/client (prn "Hello world"))) + := `[(r/cdef 0 [] [] :client + (fn [frame] + (r/ap (r/lookup frame :clojure.core/prn (r/pure prn)) (r/pure "hello world"))))] ;; lexical scope - (l/compile-client (e/client (let [a :foo] [a a]))) - := `(r/peer - (lang/r-defs - (lang/r-static :foo) - (lang/r-ap (lang/r-static vector) (lang/r-local 1) (lang/r-local 1))) - [] 1) - - (l/compile-client (e/client - (let [a (e/server :foo)] - (e/server (prn a))))) - := `(r/peer - (lang/r-defs - (lang/r-remote 0)) - [] 0) - (l/compile-server (e/client - (let [a (e/server :foo)] - (e/server (prn a))))) - := `(r/peer - (lang/r-defs - (lang/r-static :foo) - (lang/r-ap (lang/r-static prn) (lang/r-local 0))) - [] 1) + (l/compile ::Main (e/client (let [a :foo] [a a]))) + := `[(r/cdef 0 [:client] [] :client + (fn [frame] + (r/define-node frame 0 (r/pure :foo)) + (r/ap (r/lookup frame :clojure.core/vector (r/pure vector)) + (r/node frame 0) (r/node frame 0))))] + ;; lexical scope + (l/compile ::Main `(e/client + (let [x "Hello" + y "world"] + [x y]))) + := `[(r/cdef 0 [:client :client] [] :client + (fn [frame] + (r/define-node frame 0 (r/pure "Hello")) + (r/define-node frame 1 (r/pure "world")) + (r/ap (r/lookup frame :clojure.core/vector (r/pure vector)) + (r/node frame 0) (r/node frame 1))))] + + (l/compile ::Main `(e/client + (let [a (e/server :foo)] + (e/server (prn a))))) + := `[(r/cdef 0 [:server] [] :server + (fn [frame] + (r/define-node frame 0 (r/pure :foo)) + (r/ap (r/lookup frame :clojure.core/prn (r/pure prn)) + (r/node frame 0))))] + + ;; (def !x (atom 0)) ;; join (e/watch !x) ;; (i/fixed continuous-flow) -> incremental sequence of 1 element - (l/compile-client `(e/client (e/join (i/fixed (m/watch !x))))) - := `(r/peer - (lang/r-defs - (lang/r-join (lang/r-ap (lang/r-static i/fixed) - (lang/r-ap (lang/r-static m/watch) - (lang/r-static !x))))) - [] 0) + (l/compile ::Main `(e/client (e/join (i/fixed (m/watch !x))))) + := `[(r/cdef 0 [] [] :client + (fn [frame] + (r/join + (r/ap (r/lookup frame ::i/fixed (r/pure i/fixed)) + (r/ap (r/lookup frame ::m/watch (r/pure m/watch)) + (r/lookup frame ::!x (r/pure !x)))))))] ;; pure (get the incseq of an expression) (e/pure (e/join x)) is (e/join (e/pure x)) is x - (l/compile-client (e/client (e/pure :foo))) - := `(r/peer - (lang/r-defs - (lang/r-static (lang/r-static :foo))) - [] 0) + (l/compile ::Main `(e/client (e/pure :foo))) + := `[(r/cdef 0 [] [] :client + (fn [frame] + (r/pure (r/pure :foo))))] ;; ctor (e/fn [] foo) -> (e/ctor foo) (previously ::c/closure) - (l/compile-client (e/client (e/ctor :foo))) - := `(r/peer - (lang/r-defs - (lang/r-static :foo) - (lang/r-ctor [] 0)) - [] 1) + (l/compile ::Main `(e/client (e/ctor :foo))) + := `[(r/cdef 0 [] [] :client + (fn [frame] + (r/pure (r/make-ctor frame ::Main 1)))) + (r/cdef 0 [] [] nil + (fn [frame] + (r/pure :foo)))] ;; call (aka new, but with no argument and only for ctors) - (l/compile-client (e/client (e/call (e/ctor :foo)))) - := `(r/peer - (lang/r-defs - (lang/r-static :foo) - (lang/r-ctor [] 0) - (lang/r-call 0)) - [1] 2) + (l/compile ::Main `(e/client (e/call (e/ctor :foo)))) + := `[(r/cdef 0 [] [:client] :client + (fn [frame] + (r/define-call frame 0 (r/pure (r/make-ctor frame ::Main 1))) + (r/join (r/call frame 0)))) + (r/cdef 0 [] [] nil + (fn [frame] + (r/pure :foo)))] ;; lexical closure - (l/compile-client (e/client - (let [a :foo] - (e/call (e/ctor a))))) - := `(r/peer - (lang/r-defs - (lang/r-static :foo) - (lang/r-free 0) - (lang/r-ctor [] 1 (lang/r-local 0)) - (lang/r-call 0)) - [2] 3) - - (l/compile-client (e/client - (let [a :foo] - (e/call (e/ctor (e/ctor a)))))) - := `(r/peer - (lang/r-defs - (lang/r-static :foo) - (lang/r-free 0) - (lang/r-ctor [] 1 (lang/r-free 0)) - (lang/r-ctor [] 2 (lang/r-local 0)) - (lang/r-call 0)) - [3] 4) + (l/compile ::Main `(e/client + (let [a :foo] + (e/call (e/ctor a))))) + := `[(r/cdef 0 [:client] [:client] :client + (fn [frame] + (r/define-node frame 0 (r/pure :foo)) + (r/define-call frame 0 (r/pure (doto (r/make-ctor frame ::Main 1) + (r/define-free 0 (r/node frame 0))))) + (r/join (r/call frame 0)))) + (r/cdef 1 [] [] nil + (fn [frame] + (r/free frame 0)))] + + (l/compile ::Main `(e/client + (let [a :foo] + (e/call (e/ctor (e/ctor a)))))) + := `[(r/cdef 0 [:client] [:client] :client + (fn [frame] + (r/define-node frame 0 (r/pure :foo)) + (r/define-call frame 0 (r/pure (doto (r/make-ctor frame ::Main 1) + (r/define-free 0 (r/node frame 0))))) + (r/join (r/call frame 0)))) + (r/cdef 1 [] [] nil + (fn [frame] + (r/pure (doto (r/make-ctor frame ::Main 2) + (r/define-free 0 (r/free frame 0)))))) + (r/cdef 1 [] [] nil + (fn [frame] + (r/free frame 0)))] ;; conditionals - (l/compile-client `(e/client (case :x nil :y :z))) - := `(r/peer - (lang/r-defs - (lang/r-static :y) - (lang/r-static :z) - (lang/r-ap (lang/r-ap (lang/r-static hash-map) - (lang/r-static nil) (lang/r-ctor [] 0)) - (lang/r-static :x) (lang/r-ctor [] 1)) - (lang/r-call 0)) - [2] 3) - - ;; var - (e/def x) - (l/compile-client (e/client (var x))) - := `(r/peer - (lang/r-defs - (lang/r-var x)) - [] 0) - - (l/compile-client (let [a :foo, b :bar, c :baz] - [(e/ctor [a b]) (e/ctor [b c])])) - := `(r/peer - (lang/r-defs - (lang/r-static :foo) - (lang/r-static :bar) - (lang/r-static :baz) - (lang/r-ap (lang/r-static vector) - (lang/r-free 0) (lang/r-free 1)) - (lang/r-ap (lang/r-static vector) - (lang/r-free 0) (lang/r-free 1)) - (lang/r-ap (lang/r-static vector) - (lang/r-ctor 3 (lang/r-local 0) (lang/r-local 1)) - (lang/r-ctor 4 (lang/r-local 1) (lang/r-local 2)))) - [] 5) - - (l/compile-client (new (e/fn Foo [] (Foo.)))) - := `(r/peer - (fn [tier id] - (case id - 0 (r/ctor-free (r/tier-ctor tier) 0) - 1 (let [free (object-array 1) - ctor (r/peer-ctor (r/tier-peer tier) [] 0 free)] - (aset free 0 (r/pure ctor)) - (r/pure ctor)) - 2 (i/latest-concat (r/tier-slot tier 0)))) - [1] 2) - - (l/compile-client (e/letfn [(Foo [] (Bar.)) + (l/compile ::Main `(case :x nil :y :z)) + := `[(r/cdef 0 [] [nil] nil + (fn [frame] + (r/define-call frame 0 + (r/ap + (r/ap + (r/lookup frame :clojure.core/hash-map (r/pure hash-map)) + (r/pure nil) (r/make-ctor frame ::Main 1)) + (r/pure :x) + (r/pure (r/make-ctor frame ::Main 2)))) + (r/join (r/call frame 0)))) + (r/cdef 0 [] [] nil + (fn [frame] + (r/pure :y))) + (r/cdef 0 [] [] nil + (fn [frame] + (r/pure :z)))] + + (l/compile ::Main (new (e/fn Foo [] (Foo.)))) + := `[(r/cdef 0 [] [nil] nil + (fn [frame] + (r/define-call frame 0 + (let [ctor (r/make-ctor frame ::Main 1)] + (r/define-free ctor 0 (r/pure ctor)) + (r/pure ctor))) + (r/join (r/call frame 0)))) + (r/cdef 1 [] [nil] nil + (fn [frame] + (r/define-call frame 0 (r/free frame 0)) + (r/join (r/call frame 0))))] + + (l/compile ::Main (e/letfn [(Foo [] (Bar.)) (Bar [] (Foo.))] (Foo.))) - := `(r/peer - (fn [tier id] - (case id - 0 (r/ctor-free (r/tier-ctor tier) 1) - 1 (r/ctor-free (r/tier-ctor tier) 0) - 2 (let [Foo-free (object-array 2) - Foo-ctor (r/peer-ctor (r/tier-peer tier) [] 0 Foo-free) - Bar-free (object-array 2) - Bar-ctor (r/peer-ctor (r/tier-peer tier) [] 1 Bar-free)] - (aset Foo-free 0 (r/pure Foo-ctor)) - (aset Foo-free 1 (r/pure Bar-ctor)) - (aset Bar-free 0 (r/pure Foo-ctor)) - (aset Bar-free 1 (r/pure Bar-ctor)) - (r/pure {:Foo Foo-ctor :Bar Bar-ctor})) - 3 (i/latest-product :Foo (r/tier-local tier 0)) - 4 (i/latest-concat (r/tier-slot tier 0)))) - [3] 4) - - (l/compile-client (let [a :foo, b :bar, c :baz] + := `[(r/cdef 0 [] [nil] nil + (fn [frame] + (let [ctor-foo (r/make-ctor frame ::Main 1) + ctor-bar (r/make-ctor frame ::Main 2)] + (r/define-free ctor-foo 0 (r/pure ctor-foo)) + (r/define-free ctor-foo 1 (r/pure ctor-bar)) + (r/define-free ctor-bar 0 (r/pure ctor-bar)) + (r/define-free ctor-bar 1 (r/pure ctor-foo)) + (r/define-call frame 0 (r/pure ctor-foo)) + (r/join (r/call frame 0))))) + (r/cdef 2 [] [nil] nil + (fn [frame] + (r/define-call frame 0 (r/free frame 1)) + (r/join (r/call frame 0)))) + (r/cdef 2 [] [nil] nil + (fn [frame] + (r/define-call frame 0 (r/free frame 1)) + (r/join (r/call frame 0))))] + + (l/compile ::Main (let [a :foo, b :bar, c :baz] [(e/ctor [a b]) (e/ctor [b c])])) - := `(lang/r-defs - (lang/r-ap (lang/r-static vector) - (lang/r-ctor 4 (lang/r-local 1) (lang/r-local 2)) - (lang/r-ctor 5 (lang/r-local 2) (lang/r-local 3))) - (lang/r-static :foo) - (lang/r-static :bar) - (lang/r-static :baz) - (lang/r-ap (lang/r-static vector) (lang/r-free 0) (lang/r-free 1)) - (lang/r-ap (lang/r-static vector) (lang/r-free 0) (lang/r-free 1))) + := `[(r/cdef 0 [nil nil nil] [] nil + (fn [frame] + (r/define-node frame 0 (r/pure :foo)) + (r/define-node frame 1 (r/pure :bar)) + (r/define-node frame 2 (r/pure :baz)) + (r/ap (r/lookup frame :clojure.core/vector (r/pure clojure.core/vector)) + (let [ctor (r/make-ctor frame ::Main 1)] + (r/define-free ctor 0 (r/node frame 0)) + (r/define-free ctor 1 (r/node frame 1)) + (r/pure ctor)) + (let [ctor (r/make-ctor frame ::Main 2)] + (r/define-free ctor 0 (r/node frame 1)) + (r/define-free ctor 1 (r/node frame 2)) + (r/pure ctor))))) + (r/cdef 2 [] [] nil + (fn [frame] + (r/ap (r/lookup frame :clojure.core/vector (r/pure clojure.core/vector)) + (r/free frame 0) + (r/free frame 1)))) + (r/cdef 2 [] [] nil + (fn [frame] + (r/ap (r/lookup frame :clojure.core/vector (r/pure clojure.core/vector)) + (r/free frame 0) + (r/free frame 1))))] #_(e/defn Foo []) - (l/compile-client `(e/ctor (e/call Foo))) := - `(r/peer - (lang/r-defs - (lang/r-lookup Foo) - (lang/r-call 0) - (lang/r-ctor [0] 1)) - [] 2) - - (l/compile-client `e/tier) := - `(r/peer - (fn [tier id] - (case id - 0 (r/pure tier))) - [] 0) + (l/compile ::Main `(e/ctor (e/call Foo))) := + `[(r/cdef 0 [] [] nil + (fn [frame] + (r/pure (r/make-ctor frame ::Main 1)))) + (r/cdef 0 [] [nil] nil + (fn [frame] + (r/define-call frame 0 (r/lookup frame ::Foo (r/pure (r/make-ctor frame ::Foo 0)))) + (r/join (r/call frame 0))))] + + (l/compile ::Main `e/frame) := + `[(r/cdef 0 [] [] nil + (fn [frame] + (r/pure frame)))] ) From d3d7ec56dc701e341499c8006ca87d8bf8bb4372 Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 15 Jan 2024 20:36:19 +0100 Subject: [PATCH 029/428] next compiler: literals, fns, macros, siting, let --- src/contrib/test_match.clj | 175 ++++++ src/contrib/triple_store.clj | 6 +- src/hyperfiddle/electric/impl/lang_de2.clj | 511 ++++++++++++++++++ src/hyperfiddle/electric/impl/runtime_de.cljc | 13 +- src/hyperfiddle/electric_local_def_de.cljc | 9 +- test/contrib/triple_store_test.clj | 4 +- test/hyperfiddle/electric_compiler_test.clj | 64 ++- 7 files changed, 772 insertions(+), 10 deletions(-) create mode 100644 src/contrib/test_match.clj create mode 100644 src/hyperfiddle/electric/impl/lang_de2.clj diff --git a/src/contrib/test_match.clj b/src/contrib/test_match.clj new file mode 100644 index 000000000..bc25dcf54 --- /dev/null +++ b/src/contrib/test_match.clj @@ -0,0 +1,175 @@ +(ns contrib.test-match + (:require [contrib.debug :as dbg] + [hyperfiddle.rcf :as rcf :refer [tests]] + [fipp.ednize])) + +(set! *warn-on-reflection* true) + +;; test matcher +;; goal: succinct, simple, useful test output +;; patterns: +;; _ -> any value +;; _& -> any values +;; view f subpat -> match subpat on (f v) +;; +;; missing: +;; - strict map check (all keys) +;; - compiler instead of interpreter +;; - locals inside pattern +;; - unification (logical vars) +;; - guard predicates +;; +;; differences to matcher-combinators: +;; - no pretty printing. Result can be used programatically +;; - more concise syntax +;; - fits on 1 page +;; - test framework agnostic +;; +;; how to check if pattern matched? +;; (= v (test-match v pat)) +;; this is also RCF-friendly + +(deftype Diff [a b] + Object + (toString [_] (str "<>")) + (hashCode [_] (+ (.hashCode a) (.hashCode b))) + (equals [_ that] + (and (instance? Diff that) + (= a (.-a ^Diff that)) (= b (.-b ^Diff that)))) + clojure.lang.IPersistentCollection + (equiv [this that] (.equals this that)) + fipp.ednize/IEdn + (-edn [_] (list '<Diff 1 [2]) := (->Diff 1 [2]) + #{(->Diff 1 [2])} := #{(->Diff 1 [2])} + ) + +(defmethod print-method Diff [^Diff d ^java.io.Writer w] + (.write w "<>")) + +(deftype Missing [] + Object (toString [_] "_") + fipp.ednize/IEdn (-edn [_] '_) + ) +(defmethod print-method Missing [_ ^java.io.Writer w] (.write w "_")) +(def missing (Missing.)) + +(defn pair [v pat] + (loop [v v, pat pat, ret []] + (let [v* (if (seq v) (first v) missing) + pat* (if (seq pat) (first pat) missing)] + (if (= missing v* pat*) + ret + (recur (rest v) (rest pat) (conj ret [v* pat*])))))) + +(tests + (pair [1] [:a]) := [[1 :a]] + (pair [1 2] [:a]) := [[1 :a] [2 missing]] + (pair [1] [:a :b]) := [[1 :a] [missing :b]] + ) + +(defn test-match [v pat] + (cond + (coll? pat) (if (and (or (list? pat) (seq? pat)) (= `view (first pat))) + ;; TODO turn into pattern compiler so we don't need `eval` + (let [[_ ap subpat] pat, subv (eval (list ap v)), ret (test-match subv subpat)] + (if (= subv ret) v ret)) + ;; if (contrib.debug/dbgv (instance? (class pat) v)) + (if (coll? v) + (cond + (map? v) + (if (map? pat) + (let [[v pat] (reduce-kv (fn [[ac pat] k v] + (if (contains? pat k) + [(assoc ac k (test-match v (get pat k))) (dissoc pat k)] + [(assoc ac k v) pat])) + [{} pat] v)] + (reduce-kv (fn [ac k pat] (assoc ac k (test-match missing pat))) v pat)) + (->Diff v pat)) + + (set? v) + (if (set? pat) + (reduce (fn [v nx] (if (contains? v nx) v (conj v (->Diff missing nx)))) v pat) + (->Diff v pat)) + + :else + (let [ret (first (reduce (fn [[ac care?] [v pat]] + (if care? + (let [ret (test-match v pat)] + (if (= ::dont-care ret) + [(conj ac v) false] + [(conj ac ret) care?])) + [(conj ac v) false])) + [(empty v) true] (pair v pat))) + listy-v? (or (list? v) (seq? v)), listy-pat? (or (list? pat) (seq? pat))] + (if (and (seq v) (every? #(instance? Diff %) ret)) + (->Diff (into (empty v) (map #(.-a ^Diff %)) ret) + (into (empty pat) (map #(.-b ^Diff %)) (cond-> ret (not= listy-v? listy-pat?) reverse))) + (cond-> ret (or (list? v) (seq? v)) reverse)))) + (->Diff v pat))) + (= `_& pat) ::dont-care + (= `_ pat) v + (= v pat) v + :else (->Diff v pat)) + ) + +(tests + (test-match 1 1) := 1 + (test-match :x :x) := :x + (test-match 1 0) := (->Diff 1 0) + (test-match 1 2) := (->Diff 1 2) + (test-match [1 2] [1 2]) := [1 2] + (test-match [1 2] [1 0]) := [1 (->Diff 2 0)] + (test-match '(1 2) [1 0]) := (list 1 (->Diff 2 0)) + (test-match '(1 2) '(1 2)) := '(1 2) + (class (test-match '(1 2) '(1 2))) := (class '(1 2)) + (test-match [1 2 3] [1 2]) := [1 2 (->Diff 3 missing)] + (test-match [1 2] [1 2 3]) := [1 2 (->Diff missing 3)] + (test-match [1 2 3] [1 `_&]) := [1 2 3] + (test-match [1 2 3] [1 `_ 3]) := [1 2 3] + (test-match [1 2] [1 2 `_]) := [1 2 missing] + (test-match [1 [2 3]] [1 [2 `_]]) := [1 [2 3]] + (test-match `(inc (dec x)) `(inc (dec _))) := `(inc (dec x)) + (test-match {:x 1} {:x `_}) := {:x 1} + (test-match {:x 1} 1) := (->Diff {:x 1} 1) + (test-match 1 {:x 1}) := (->Diff 1 {:x 1}) + (test-match {:x 1} {:x 1 :y 2}) := {:x 1 :y (->Diff missing 2)} + (test-match {:x 1} {:x 1 :y `_}) := {:x 1 :y missing} + (test-match {:x 1, :y 2} {:y 2}) := {:x 1, :y 2} + (test-match {:x [1 2], :y 3} {:x [1 `_]}) := {:x [1 2], :y 3} + (test-match [1 2] `(view first 1)) := [1 2] + (test-match [1 2] `(view first 2)) := (->Diff 1 2) + (test-match [1 2] `[(view identity 0) 2]) := [(->Diff 1 0) 2] + (test-match [1 2] [3 4]) := (->Diff [1 2] [3 4]) + (test-match '(1 2) [3 4]) := (->Diff '(1 2) [3 4]) + (test-match [1 2] '(3 4)) := (->Diff [1 2] '(3 4)) + (test-match '(1 2) '(3 4)) := (->Diff '(1 2) '(3 4)) + (test-match [] []) := [] + (test-match #{1 2 3} #{1 2}) := #{1 2 3} + (test-match #{1 2} #{2 3}) := #{1 2 (->Diff missing 3)} + (test-match #{1 2 3} [1 2]) := (->Diff #{1 2 3} [1 2]) + (test-match {:a 1} [:a 1]) := (->Diff {:a 1} [:a 1]) + + (require '[hyperfiddle.electric.impl.lang-de :as-alias lang]) + (require '[hyperfiddle.electric.impl.runtime-de :as-alias r]) + (let [v `(r/peer + (lang/r-defs + (lang/r-static 1) + (lang/r-ap (lang/r-static + (clojure.core/fn [x32133] + (clojure.core/fn [& rest-args32134] + (clojure.core/let [x x32133] + (clojure.core/apply (fn* ([] x)) rest-args32134))))) + (lang/r-local 0))) + [] 1)] + (test-match v + `(r/peer + (lang/r-defs + (lang/r-static 1) + (lang/r-ap (lang/r-static (clojure.core/fn _&)) + (lang/r-local 0))) + [] 1)) := v) + ) diff --git a/src/contrib/triple_store.clj b/src/contrib/triple_store.clj index 16c3d18e2..9ea964098 100644 --- a/src/contrib/triple_store.clj +++ b/src/contrib/triple_store.clj @@ -34,8 +34,10 @@ (let [v0 (-> ts :eav (get e) (get a)) eav (update (:eav ts) e update a f) v1 (-> eav (get e) (get a)) - ave (update (:ave ts) a update v1 (fnil conj (sorted-set)) e) - ave (cond-> ave (contains? (get ave a) v0) (update a update v0 disj e)) + ave (if (= v0 v1) + (:ave ts) + (let [ave (update (:ave ts) a update v1 (fnil conj (sorted-set)) e)] + (cond-> ave (contains? (get ave a) v0) (update a update v0 disj e)))) vea (:vea ts) ;; vea (update (:vea ts) v1 update e (fnil conj #{}) a) ;; vea (cond-> vea (contains? (get vea v0) e) (update v0 update e disj a)) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj new file mode 100644 index 000000000..bf63ad47c --- /dev/null +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -0,0 +1,511 @@ +(ns hyperfiddle.electric.impl.lang-de2 + (:refer-clojure :exclude [compile]) + (:require [cljs.analyzer :as cljs-ana] + [cljs.core] + [cljs.env] + [clojure.string :as str] + [contrib.assert :as ca] + [contrib.debug] + [contrib.triple-store :as ts] + [dom-top.core :refer [loopr]] + [hyperfiddle.electric :as-alias e] + [hyperfiddle.electric.impl.analyzer :as ana] + [hyperfiddle.electric.impl.expand :as expand] + [hyperfiddle.electric.impl.runtime-de :as r] + [hyperfiddle.rcf :as rcf :refer [tests]])) + +;;;;;;;;;;;;;;;; +;;; EXPANDER ;;; +;;;;;;;;;;;;;;;; + +(defn- fn-> [f a] (fn [o] (f o a))) + +(declare -expand-all-in-try) + +(defn resolve-cljs [env sym] + (when (not= '. sym) + (let [!found? (volatile! true) + resolved (binding [cljs-ana/*cljs-warnings* (assoc cljs-ana/*cljs-warnings* :undeclared-ns false)] + (cljs-ana/resolve-var env sym + (fn [env prefix suffix] + (cljs-ana/confirm-var-exists env prefix suffix + (fn [_ _ _] (vreset! !found? false)))) nil))] + (when (and resolved @!found? (not (:macro resolved))) + ;; If the symbol is unqualified and is from a different ns (through e.g. :refer) + ;; cljs returns only :name and :ns. We cannot tell if it resolved to a macro. + ;; We recurse with the fully qualified symbol to get all the information. + ;; The symbol can also resolve to a local in which case we're done. + ;; TODO how to trigger these in tests? + (if (and (simple-symbol? sym) (not= (:ns env) (:ns resolved)) (not= :local (:op resolved))) + (recur env (ca/check qualified-symbol? (:name resolved) {:sym sym, :resolved resolved})) + resolved))))) + +(defn serialized-require [sym] + ;; we might be expanding clj code before the ns got loaded (during cljs compilation) + ;; to correctly lookup vars the ns needs to be loaded + ;; since shadow-cljs compiles in parallel we need to serialize the requires + (when-not (get (loaded-libs) sym) + (try (#'clojure.core/serialized-require sym) ; try bc it can be cljs file + (catch java.io.FileNotFoundException _)))) + +(defn macroexpand-clj [o] (serialized-require (ns-name *ns*)) (macroexpand-1 o)) + +(defn expand-referred-or-local-macros [o cljs-macro-env] + ;; (:require [some.ns :refer [some-macro]]) + ;; `some-macro` might be a macro and cljs expander lookup fails to find it + ;; another case is when a cljc file :require-macros itself without refering the macros + (if-some [vr (when (simple-symbol? (first o)) (resolve (first o)))] + (if (and (not (class? vr)) (.isMacro ^clojure.lang.Var vr)) + (apply vr o cljs-macro-env (rest o)) + o) + o)) + +(defn expand-macro [env o] + (let [[f & args] o, n (name f), e (dec (count n))] + (if (= "." n) + o + (if (and (not= ".." n) (= \. (nth n e))) + `(new ~(symbol (namespace f) (subs n 0 e)) ~@args) + (if (some? (re-find #"^\.[^.]" n)) + (list* '. (first args) (symbol (subs n 1)) (rest args)) + (if (= :cljs (get (::peers env) (::current env))) + (let [cljs-env (::cljs-env env)] + (if (resolve-cljs cljs-env f) + o + (let [cljs-macro-env (cond-> cljs-env (::ns cljs-env) (assoc :ns (::ns cljs-env)))] + (if-some [expander (cljs-ana/get-expander f cljs-macro-env)] + (apply expander o cljs-macro-env args) + (expand-referred-or-local-macros o cljs-macro-env))))) + (macroexpand-clj o))))))) + +(defn find-local-entry [env sym] (find (:locals env) sym)) +(defn add-local [env sym] (update env :locals assoc sym ::unknown)) + +(def ^:dynamic *electric* true) + +(defn ?meta [metao o] + (if (instance? clojure.lang.IObj o) + (cond-> o (meta metao) (vary-meta #(merge (meta metao) %))) + o)) + +(defn -expand-all [o env] + (cond + (and (seq? o) (seq o)) + (if (find-local-entry env (first o)) + (list* (first o) (mapv (fn-> -expand-all env) (rest o))) + (case (first o) + ;; (ns ns* deftype* defrecord* var) + + (do) (if (nnext o) + (let [body (mapv #(list `e/drain %) (next o)) + body (conj (pop body) (second (peek body)))] ; last arg isn't drained + (recur (?meta o (cons `e/amb body)) env)) + (recur (?meta o (second o)) env)) + + (let*) (let [[_ bs & body] o + [bs2 env2] (reduce + (fn [[bs env] [sym v]] + [(conj bs sym (-expand-all v env)) (add-local env sym)]) + [[] env] + (partition-all 2 bs))] + (?meta o (list 'let* bs2 (-expand-all (?meta body (cons 'do body)) env2)))) + + (loop*) (let [[_ bs & body] o + [bs2 env2] (reduce + (fn [[bs env] [sym v]] + [(conj bs sym (-expand-all v env)) (add-local env sym)]) + [[] env] + (partition-all 2 bs))] + (recur (?meta o `(binding [r/rec (::closure (let [~@(interleave (take-nth 2 bs2) r/arg-sym)] + ~@body))] + (new r/rec ~@(take-nth 2 (next bs2))))) env2)) + + (case clojure.core/case) + (let [[_ v & clauses] o + has-default-clause? (odd? (count clauses)) + clauses2 (cond-> clauses has-default-clause? butlast) + xpand (fn-> -expand-all env)] + (?meta o (list* 'case (xpand v) + (cond-> (into [] (comp (partition-all 2) (mapcat (fn [[match expr]] [match (xpand expr)]))) + clauses2) + has-default-clause? (conj (xpand (last clauses))))))) + + (quote) o + + (fn*) (let [[?name more] (if (symbol? (second o)) [(second o) (nnext o)] [nil (next o)]) + arities (cond-> more (vector? (first more)) list)] + (?meta o (apply list + (into (if ?name ['fn* ?name] ['fn*]) + (map (fn [[syms & body]] + (binding [*electric* false] + (list syms (-expand-all (cons 'do body) (reduce add-local env syms)))))) + arities)))) + + (letfn*) (let [[_ bs & body] o + env2 (reduce add-local env (take-nth 2 bs)) + xpand (fn-> -expand-all env2) + bs2 (into [] (comp (partition-all 2) + (mapcat (fn [[sym v]] [sym (binding [*electric* false] (xpand v))]))) + bs)] + (?meta o `(let* [~(vec (take-nth 2 bs2)) (::letfn ~bs2)] ~(-expand-all (cons 'do body) env2)))) + + ;; TODO expand `do` + (try) (throw (ex-info "try is TODO" {:o o})) #_(list* 'try (mapv (fn-> -all-in-try env) (rest o))) + + (binding clojure.core/binding) + (let [[_ bs & body] o] + (?meta o (list 'binding (into [] (comp (partition-all 2) (mapcat (fn [[sym v]] [sym (-expand-all v env)]))) bs) + (-expand-all (cons 'do body) env)))) + + (set!) (if *electric* + (recur (?meta o `((fn* [v#] (set! ~(nth o 1) v#)) ~(nth o 2))) env) + (?meta o (list 'set! (-expand-all (nth o 1) env) (-expand-all (nth o 2) env)))) + + (::site) (?meta o (seq (conj (into [] (take 2) o) + (-expand-all (cons 'do (drop 2 o)) (assoc env ::current (second o)))))) + + #_else + (if (symbol? (first o)) + (let [o2 (expand-macro env o)] + (if (identical? o o2) + (?meta o (list* (first o) (mapv (fn-> -expand-all env) (rest o)))) + (recur (?meta o o2) env))) + (?meta o (list* (-expand-all (first o) env) (mapv (fn-> -expand-all env) (next o))))))) + + (map-entry? o) (clojure.lang.MapEntry. (-expand-all (key o) env) (-expand-all (val o) env)) + (coll? o) (?meta (meta o) (into (empty o) (map (fn-> -expand-all env)) o)) + :else o)) + +#_(defn -expand-all-in-try [o env] + (if (seq? o) + (if (find-local-entry env (first o)) + (list* (first o) (mapv (fn-> -expand-all env) (rest o))) + (case (first o) + (catch) (let [[_ typ sym & body] o, env2 (add-local env sym)] + (list* 'catch typ sym (mapv (fn-> -expand-all env2) body))) + #_else (-expand-all o env))) + (-expand-all o env))) + +;; :js-globals -> cljs env +;; :locals -> cljs or electric env +;; ::lang/peers -> electric env +;; if ::current = :clj expand with clj environment +;; if ::current = :cljs expand with cljs environment + +(defn enrich-for-require-macros-lookup [cljs-env nssym] + (if-some [src (cljs-ana/locate-src nssym)] + (let [ast (:ast (with-redefs [cljs-ana/missing-use-macro? (constantly nil)] + (binding [cljs-ana/*passes* []] + (cljs-ana/parse-ns src {:load-macros true, :restore false}))))] + ;; we parsed the ns form without `ns-side-effects` because it triggers weird bugs + ;; this means the macro nss from `:require-macros` might not be loaded + (run! serialized-require (-> ast :require-macros vals set)) + (assoc cljs-env ::ns ast)) + cljs-env)) + +(tests "enrich of clj source file is noop" + (cljs.env/ensure (enrich-for-require-macros-lookup {:a 1} 'clojure.core)) := {:a 1}) + +;; takes an electric environment, which can be clj or cljs +;; if it's clj we need to prep the cljs environment (cljs.env/ensure + cljs.analyzer/empty-env with patched ns) +;; we need to be able to swap the environments infinite number of times + +(defn ->common-env [env] + (if (::cljs-env env) + env + (assoc env ::cljs-env + (if (contains? env :js-globals) + env + (cond-> (cljs.analyzer/empty-env) (:ns env) (enrich-for-require-macros-lookup (:ns env))))))) + +(defn expand-all [env o] (cljs.env/ensure (-expand-all o (->common-env env)))) + +;;;;;;;;;;;;;;;; +;;; COMPILER ;;; +;;;;;;;;;;;;;;;; + +(defn mksym [x & xs] + (if (or (symbol? x) (keyword? x)) + (symbol (namespace x) (apply str (name x) (map name (flatten xs)))) + (symbol (apply str (name x) (map name (flatten xs)))))) + +(defn fail! + ([env msg] (fail! env msg {})) + ([env msg data] (throw (ex-info (str "in" (some->> (::def env) (str " ")) ": " (-> env ::last peek pr-str) "\n" msg) + (merge {:form (-> env ::last pop peek) :in (::def env) :for ((juxt ::me ::current) env)} data))))) + +(defn get-them [env] (-> env ::peers keys set (disj (::current env)) first)) + +(defn cannot-resolve! [env form] + (fail! env (str "I cannot resolve " "`"form"`" + (when-let [them (get-them env)] + (let [site (name them)] + (str ", maybe it's defined only on the " site "?" + \newline "If `" form "` is supposed to be a macro, you might need to :refer it in the :require-macros clause.")))) + {:locals (keys (:locals env))})) + +(defn ns-qualify [node] (if (namespace node) node (symbol (str *ns*) (str node)))) + +(tests + (ns-qualify 'foo) := `foo + (ns-qualify 'a/b) := 'a/b) + +(defn qualify-sym-in-var-node "If ast node is `:var`, update :form to be a fully qualified symbol" [env ast] + (if (and (= :var (:op ast)) (not (-> ast :env :def-var))) + (assoc ast :form (case (get (::peers env) (::current env)) + :clj (symbol (str (:ns (:meta ast))) (str (:name (:meta ast)))) + :cljs (:name (:info ast)))) + ast)) + +(defn find-local [f env] "TODO" nil) +(defn find-electric-local [o env] "TODO" nil) + +(defn ->meta [o env] (merge (::meta (find-electric-local o env)) (meta o))) + +(defn closure + "Analyze a cc/fn form, looking for electric defs and electric lexical bindings references. + Rewrites the cc/fn form into a closure over electric dynamic and lexical scopes. + Return a pair [closure form, references to close over]. + + e.g.: + (let [x 1] + (binding [y 2] + (fn [arg] [x y arg]))) + + => + [(fn [x123 y123] + (fn [& rest-args123] + (binding [y y123] + (let [x x123] + (apply (fn [arg] [x y arg]) rest-args123))))) + [x y]] + " + [env form] + (let [refered-evars (atom {}) + refered-lexical (atom {}) + edef? (fn [ast] (or (#{::node ::node-signifier} (-> ast :meta ::type)) + (#{::node ::node-signifier} (-> ast :info :meta ::type)))) + dynamic? (fn [ast] (or (:assignable? ast) ; clj + (:dynamic (:meta (:info ast))) ; cljs + )) + lexical? (fn [ast] (or (::provided? ast) ; clj + (::provided? (:info ast)) ;cljs + )) + namespaced? (fn [ast] (qualified-symbol? (:form ast))) + safe-let-name (fn [sym] (if (qualified-symbol? sym) + (symbol (str/replace (str (munge sym)) #"\." "_")) + sym)) + record-lexical! (fn [{:keys [form]}] + (swap! refered-lexical assoc (with-meta form (->meta form env)) + (gensym (name form)))) + record-edef! (fn [{:keys [form] :as ast}] + (if (dynamic? ast) + (swap! refered-evars assoc form #_(ana/var-name ast) (gensym (name form))) + (record-lexical! ast))) + env (update env :locals update-vals #(if (map? %) (assoc % ::provided? true) {::provided? true})) + rewrite-ast (fn [ast] + (cond + (edef? ast) (do (record-edef! ast) + (cond (dynamic? ast) (qualify-sym-in-var-node env ast) + (namespaced? ast) (update ast :form safe-let-name) + :else ast)) + (lexical? ast) (do (record-lexical! ast) ast) + :else (qualify-sym-in-var-node env ast))) + form (case (get (::peers env) (::current env)) + :clj (-> (ana/analyze-clj env form) + (ana/walk-clj rewrite-ast) + (ana/emit-clj)) + :cljs (-> (binding [cljs.analyzer/*cljs-warning-handlers* + [(fn [_warning-type _env _extra])]] + (ana/analyze-cljs env form)) + (ana/walk-cljs rewrite-ast) + (ana/emit-cljs))) + rest-args-sym (gensym "rest-args") + all-syms (merge @refered-evars @refered-lexical) + [syms gensyms] [(keys all-syms) (vals all-syms)] + fn? (and (seq? form) (#{'fn 'fn* 'clojure.core/fn 'clojure.core/fn* 'cljs.core/fn 'cljs.core/fn*} (first form))) + form (if fn? + `(apply ~form ~rest-args-sym) + form) + form (if (seq @refered-lexical) + `(let [~@(flatten (map (fn [[k v]] [(safe-let-name k) v]) @refered-lexical))] + ~form) + form) + form (if (seq @refered-evars) + `(binding [~@(flatten (seq @refered-evars))] + ~form) + form) + form (if fn? + `(fn [~@gensyms] (fn [~'& ~rest-args-sym] ~form)) + `(fn [~@gensyms] ~form))] + [form syms])) + +(defn bound-js-fn + "Given a js global resolving to a function (e.g js/alert, js/console.log required-js-ns/js-fn), ensures it + is called under the correct `this` context." + [sym] + (let [fields (str/split (name sym) #"\.")] + `(.bind ~sym ~(symbol (namespace sym) + (if (seq (rest fields)) + (str/join (interpose '. (butlast fields))) + "globalThis"))))) + +(defn class-constructor-call? [env f] (and (symbol? f) (not (find-local f env)))) +(defn with-interop-locals [env syms] (update env :locals merge (zipmap syms (repeat {})))) + +(defn resolve-static-field [sym] + (when-some [ns (some-> (namespace sym) symbol)] + (when-some [cls (resolve ns)] + (when (class? cls) + (clojure.lang.Reflector/getField cls (name sym) true))))) + +(defn get-children-e [ts e] (-> ts :ave ::parent (get e))) +(defn get-root-e [ts] (first (get-children-e ts '_))) + +(defn find-let-ref [sym pe ts] + (loop [pe pe] + (when pe + (let [p (ts/get-entity ts pe)] + (if (and (= ::let (::type p)) (= sym (::sym p))) + pe + (recur (::parent p))))))) + +(defn ?add-source-map [{{::keys [->id]} :o :as ts} pe form] + (let [mt (meta form)] + (cond-> ts (:line mt) (ts/add {:db/id (->id), ::source-map-of pe, ::line (:line mt), ::column (:column mt)})))) + +(defn analyze [form pe {{::keys [env ->id]} :o :as ts}] + (cond + (and (seq? form) (seq form)) + (case (first form) + (let*) (let [[_ bs bform] form] + (loopr [ts ts, pe pe] + [[s v] (eduction (partition-all 2) bs)] + (let [e (->id)] + (recur (analyze v e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::let, ::sym s}) + (update-in [:o ::env :locals s] assoc ::electric-let true, :db/id e) + (?add-source-map e form))) e)) + (analyze bform pe ts))) + (case) (let [[_ test & brs] form + [default brs2] (if (odd? (count brs)) [(last brs) (butlast brs)] [:TODO brs])] + (loopr [bs [], mp {}] + [[v br] (partition 2 brs2)] + (let [b (gensym "case-val")] + (recur (conj bs b `(::ctor ~br)) + (reduce (fn [ac nx] (assoc ac (list 'quote nx) b)) mp (if (seq v) v [v])))) + (recur (?meta form `(let* ~bs (::call (~mp ~test (::ctor ~default))))) pe ts))) + (quote) (ts/add ts {:db/id (->id), ::parent pe, ::type ::static, ::v form}) + (fn*) (let [e (->id), ce (->id) + [form refs] (closure env form) + ts2 (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) + (?add-source-map e form) + (ts/add {:db/id ce, ::parent e, ::type ::static, ::v form}))] + (reduce (fn [ts nx] (analyze nx e ts)) ts2 refs)) + (::ctor) (let [e (->id)] (recur (second form) e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ctor}) + (?add-source-map e form)))) + (::call) (let [e (->id)] (recur (second form) e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::call}) + (?add-source-map e form)))) + (::pure) (let [e (->id)] (recur (second form) e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::pure}) + (?add-source-map e form)))) + (::join) (let [e (->id)] (recur (second form) e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::join}) + (?add-source-map e form)))) + (::site) (let [[_ site bform] form, e (->id)] + (recur bform e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::site, ::site site}) + (?add-source-map e form)))) + #_else (let [e (->id)] + (reduce (fn [ts nx] (analyze nx e ts)) (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) + (?add-source-map e form)) form))) + + (vector? form) (recur (?meta form (cons `vector form)) pe ts) + (map? form) (recur (?meta form (cons `hash-map (eduction cat form))) pe ts) + + (symbol? form) + (let [e (->id)] + (if-some [lr-e (find-let-ref form pe ts)] + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::let-ref, ::ref lr-e, ::sym form}) + (?add-source-map e form)) + (case (get (::peers env) (::current env)) + :clj (if (resolve-static-field form) + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::static, ::v form}) + (?add-source-map e form)) + (if-some [v (resolve form)] + (if (var? v) + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::var, ::var (symbol v)}) + (?add-source-map e form)) + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::static, ::v form}) + (?add-source-map e form))) + (cannot-resolve! env form))) + :cljs (expand/resolve-cljs env form) + #_else (throw (ex-info (str "unknown site: " (get (::peers env) (::current env))) {:env env}))))) + + :else + (let [e (->id)] + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::static, ::v form}) + (?add-source-map e form))))) + +(defn ->->id [] (let [!i (long-array [-1])] (fn [] (aset !i 0 (unchecked-inc (aget !i 0)))))) + +(defn get-site [ts e] + (loop [pe (::parent (get (:eav ts) e))] + (and pe + (let [nd (get (:eav ts) pe)] (if (= ::site (::type nd)) (::site nd) (recur (::parent nd))))))) + +(defn compile + ([nm form env] + (let [{{::keys [env ->id]} :o :as ts} (analyze (expand-all env form) '_ (ts/->ts {::->id (->->id), ::env env})) + find-return-node-e (fn [ts e] + (let [nd (get (:eav ts) e)] + (case (::type nd) + ::let (recur ts (second (get-children-e ts e))) + ::site (recur ts (first (get-children-e ts e))) + #_else e))) + ret-e (find-return-node-e ts (get-root-e ts)) + ->ref-id (->->id) + count-nodes (fn count-nodes [ts e] + (let [nd (get (:eav ts) e)] + (case (::type nd) + ::static ts + ::ap (reduce count-nodes ts (get-children-e ts e)) + ::site (recur ts (first (get-children-e ts e))) + ::var ts + ::let-ref + (let [used (::used (get (:eav ts) (::ref nd)))] + (cond-> (ts/upd ts (::ref nd) ::used #(conj (or % #{}) e)) + (nil? used) (recur (find-return-node-e ts (first (get-children-e ts (::ref nd)))))))))) + index-nodes (fn index-nodes [ts e] + (let [nd (get (:eav ts) e)] + (case (::type nd) + ::static ts + ::ap (reduce index-nodes ts (get-children-e ts e)) + ::site (recur ts (first (get-children-e ts e))) + ::var ts + ::let-ref (recur (if-some [used (::used (get (:eav ts) (::ref nd)))] + (if (or (> (count used) 1) + (not= (get-site ts e) (get-site ts (::ref nd)))) + (ts/upd ts (::ref nd) ::refidx #(or % (->ref-id))) + ts) + ts) + (find-return-node-e ts (first (get-children-e ts (::ref nd))))) + #_else (throw (ex-info (str "cannot index-nodes " (::type nd)) nd))))) + ts (-> ts (count-nodes ret-e) (index-nodes ret-e)) + gen (fn gen [ts e] + (let [nd (get (:eav ts) e)] + (case (::type nd) + ::static (list `r/pure (::v nd)) + ::ap (list* `r/ap (mapv #(gen ts %) (get-children-e ts e))) + ::var (list `r/lookup 'frame (keyword (::var nd)) (list `r/pure (::var nd))) + ::let (recur ts (find-return-node-e ts (second (get-children-e ts e)))) + ::let-ref (if-some [idx (::refidx (get (:eav ts) (::ref nd)))] + (list `r/node 'frame idx) + (gen ts (find-return-node-e ts (first (get-children-e ts (::ref nd))))))))) + nodes (mapv (fn [[idx es]] [idx (first es)]) (sort-by first (::refidx (:ave ts)))) + gen-node-init (fn gen-node-init [ts] + (mapv (fn [[idx e]] (list `r/define-node 'frame idx + (gen ts (find-return-node-e ts (first (get-children-e ts e)))))) + nodes)) + ] + ;; (run! prn (->> ts :eav vals (sort-by :db/id))) + (let [e (find-return-node-e ts (get-root-e ts))] + `[(r/cdef 0 ~(mapv #(get-site ts (second %)) nodes) [] ~(get-site ts e) + (fn [~'frame] ~@(gen-node-init ts) ~(gen ts e)))]) + ))) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 52729b987..716e3ca84 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -268,4 +268,15 @@ Returns a peer definition from given definitions and main key. (pure "baz")))]} ::Main) (reset! !x "bar") - ) \ No newline at end of file + ) + +(def ^{::type ::node, :doc "for loop/recur impl"} rec) + +#?(:clj + (def arg-sym + (map (comp symbol + (partial intern *ns*) + (fn [i] + (with-meta (symbol (str "%" i)) + {::type ::node}))) + (range)))) diff --git a/src/hyperfiddle/electric_local_def_de.cljc b/src/hyperfiddle/electric_local_def_de.cljc index 44a87ce6f..7db650e79 100644 --- a/src/hyperfiddle/electric_local_def_de.cljc +++ b/src/hyperfiddle/electric_local_def_de.cljc @@ -1,9 +1,9 @@ (ns hyperfiddle.electric-local-def-de - (:refer-clojure :exclude [def defn]) + (:refer-clojure :exclude [def defn compile]) #?(:cljs (:require-macros hyperfiddle.electric-local-def-de)) (:require [clojure.core :as cc] [contrib.cljs-target] - [hyperfiddle.electric.impl.lang-de :as lang])) + #?(:clj [hyperfiddle.electric.impl.lang-de2 :as lang]))) (cc/defn ->local-config [env] (let [p (if (:js-globals env) :cljs :clj)] {::lang/peers {:client p, :server p}, ::lang/current :server})) @@ -24,3 +24,8 @@ (defmacro compile-server [form] (let [env (merge &env (->local-config &env) {::lang/me :server})] `(:source (lang/compile '~form ~env)))) + +(cc/defn ->electric-env [env] + (if (:js-globals env) env {:locals env :ns (ns-name *ns*)})) + +(defmacro compile [nm form] `(lang/compile ~nm '~form '~(merge (->local-config &env) (->electric-env &env)))) diff --git a/test/contrib/triple_store_test.clj b/test/contrib/triple_store_test.clj index a1e0e9784..dbceabdf6 100644 --- a/test/contrib/triple_store_test.clj +++ b/test/contrib/triple_store_test.clj @@ -5,8 +5,10 @@ (tests (-> (ts/->ts) (ts/add {:db/id 1, :foo 2}) (ts/get-entity 1) :foo) := 2 (-> (ts/->ts) (ts/add {:db/id 1, :foo 1}) (ts/add {:db/id 2, :foo 1}) :ave :foo (get 1)) := #{1 2} - (-> (ts/->ts) (ts/add {:db/id 1, :foo 2, :bar 2}) :vea (get 2) (get 1)) := #{:foo :bar} + ;; (-> (ts/->ts) (ts/add {:db/id 1, :foo 2, :bar 2}) :vea (get 2) (get 1)) := #{:foo :bar} (-> (ts/->ts) (ts/add {:db/id 1, :foo 2, :bar 2}) (ts/get-entity 1) (select-keys [:foo :bar :baz])) := {:foo 2, :bar 2} (-> (ts/->ts) (ts/add {:db/id '_}) (ts/upd '_ :x (fnil inc 0)) (ts/upd '_ :x (fnil inc 0)) (ts/get-entity '_) :x) := 2 + + (-> (ts/->ts) (ts/add {:db/id 1}) (ts/asc 1 :x 2) (ts/asc 1 :x 2) :ave :x (get 2)) := #{1} ) diff --git a/test/hyperfiddle/electric_compiler_test.clj b/test/hyperfiddle/electric_compiler_test.clj index c7632299d..8808ad8d0 100644 --- a/test/hyperfiddle/electric_compiler_test.clj +++ b/test/hyperfiddle/electric_compiler_test.clj @@ -2,10 +2,11 @@ (:require [hyperfiddle.electic :as-alias e] [hyperfiddle.incseq :as i] [hyperfiddle.rcf :as rcf :refer [tests]] - [hyperfiddle.electric.impl.lang-de :as lang] + [hyperfiddle.electric.impl.lang-de2 :as lang] [hyperfiddle.electric.impl.runtime-de :as r] [hyperfiddle.electric-local-def-de :as l] - [hyperfiddle.incseq :as i] + [contrib.test-match :refer [test-match]] + [fipp.edn] [missionary.core :as m])) ;; tests that turn electric code into clojure code @@ -22,8 +23,63 @@ (try (apply f args) (catch Throwable e (find-source-map-info path)))) -;; TODO rewrite or remove +(defmacro match [code matcher] + `(let [ret# ~code, match# (test-match ret# ~matcher)] + ret# := match# + (when (not= ret# match#) (fipp.edn/pprint match#)))) + (tests + (match (l/compile ::Main 1) + `[(r/cdef 0 [] [] nil + (fn [~'frame] + (r/pure 1)))]) + + (match (l/compile ::Main (::lang/site :client "Hello world")) + `[(r/cdef 0 [] [] :client + (fn [~'frame] + (r/pure "Hello world")))]) + + (match (l/compile ::Main (::lang/site :client (prn "Hello world"))) + `[(r/cdef 0 [] [] :client + (fn [~'frame] + (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure prn)) (r/pure "Hello world"))))]) + + (match (l/compile ::Main (::lang/site :client (let [a :foo] [a a]))) + `[(r/cdef 0 [:client] [] :client + (fn [~'frame] + (r/define-node ~'frame 0 (r/pure :foo)) + (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure vector)) + (r/node ~'frame 0) (r/node ~'frame 0))))]) + + (match (l/compile ::Main (let [a :foo] [a a])) + `[(r/cdef 0 [nil] [] nil + (fn [~'frame] + (r/define-node ~'frame 0 (r/pure :foo)) + (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure vector)) + (r/node ~'frame 0) (r/node ~'frame 0))))]) + + (match (l/compile ::Main (let [a (let [b :foo] [b b])] [a a])) + `[(r/cdef 0 [nil nil] [] nil + (fn [~'frame] + (r/define-node ~'frame 0 (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure vector)) + (r/node ~'frame 1) (r/node ~'frame 1))) + (r/define-node ~'frame 1 (r/pure :foo)) + (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure vector)) + (r/node ~'frame 0) (r/node ~'frame 0))))]) + + (match (l/compile ::Main (let [a 1] a)) + `[(r/cdef 0 [] [] nil (fn [~'frame] (r/pure 1)))]) + + (match (l/compile ::Main (::lang/site :client (let [a 1] (::lang/site :server (prn a))))) + `[(r/cdef 0 [:client] [] :server + (fn [~'frame] + (r/define-node ~'frame 0 (r/pure 1)) + (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure clojure.core/prn)) + (r/node ~'frame 0))))]) + ) + +;; TODO rewrite or remove +(comment (l/compile-client 1) := `(r/peer (lang/r-defs (lang/r-static 1)) [] 0) (l/compile-server 1) := `(r/peer (lang/r-defs (lang/r-static 1)) [] 0) @@ -272,7 +328,7 @@ ;; [] 1) ) -(tests +(comment ; TODO rewrite for new iteration ;; ( ) ;; source-map => ::line ::column (number? (-> (l/compile-client-source-map (prn "hello world")) first ::lang/line)) := true From 49b3ad379d076636fa2c7b09055253be1fd7c7e9 Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 17 Jan 2024 16:12:13 +0100 Subject: [PATCH 030/428] compiler: fix let siting --- src/hyperfiddle/electric/impl/lang_de2.clj | 8 +-- test/hyperfiddle/electric_compiler_test.clj | 57 +++++---------------- 2 files changed, 17 insertions(+), 48 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index bf63ad47c..4d158ae8d 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -481,7 +481,8 @@ ::var ts ::let-ref (recur (if-some [used (::used (get (:eav ts) (::ref nd)))] (if (or (> (count used) 1) - (not= (get-site ts e) (get-site ts (::ref nd)))) + (not= (get-site ts e) + (get-site ts (find-return-node-e ts (first (get-children-e ts (::ref nd))))))) (ts/upd ts (::ref nd) ::refidx #(or % (->ref-id))) ts) ts) @@ -505,7 +506,6 @@ nodes)) ] ;; (run! prn (->> ts :eav vals (sort-by :db/id))) - (let [e (find-return-node-e ts (get-root-e ts))] - `[(r/cdef 0 ~(mapv #(get-site ts (second %)) nodes) [] ~(get-site ts e) - (fn [~'frame] ~@(gen-node-init ts) ~(gen ts e)))]) + `[(r/cdef 0 ~(mapv #(get-site ts (find-return-node-e ts (first (get-children-e ts (second %))))) nodes) [] ~(get-site ts ret-e) + (fn [~'frame] ~@(gen-node-init ts) ~(gen ts ret-e)))] ))) diff --git a/test/hyperfiddle/electric_compiler_test.clj b/test/hyperfiddle/electric_compiler_test.clj index 8808ad8d0..67e0f9374 100644 --- a/test/hyperfiddle/electric_compiler_test.clj +++ b/test/hyperfiddle/electric_compiler_test.clj @@ -76,6 +76,19 @@ (r/define-node ~'frame 0 (r/pure 1)) (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure clojure.core/prn)) (r/node ~'frame 0))))]) + + (match (l/compile ::Main (::lang/site :client (let [x "Hello", y "world"] [x y]))) + `[(r/cdef 0 [] [] :client + (fn [~'frame] + (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure clojure.core/vector)) + (r/pure "Hello") (r/pure "world"))))]) + + (match (l/compile ::Main (::lang/site :client (let [a (::lang/site :server :foo)] (::lang/site :server (prn a))))) + `[(r/cdef 0 [] [] :server + (clojure.core/fn [~'frame] + (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure clojure.core/prn)) + (r/pure :foo))))]) + ) ;; TODO rewrite or remove @@ -380,50 +393,6 @@ ;; * a vector of call sites ;; * the result site (comment - (l/compile ::Main 1) - := `[(r/cdef 0 [] [] nil - (fn [frame] - (r/pure 1)))] - - (l/compile ::Main `(e/client "Hello world")) := - `[(r/cdef 0 [] [] :client - (fn [frame] - (r/pure "Hello world")))] - - ;; function application - (l/compile ::Main (e/client (prn "Hello world"))) - := `[(r/cdef 0 [] [] :client - (fn [frame] - (r/ap (r/lookup frame :clojure.core/prn (r/pure prn)) (r/pure "hello world"))))] - - ;; lexical scope - (l/compile ::Main (e/client (let [a :foo] [a a]))) - := `[(r/cdef 0 [:client] [] :client - (fn [frame] - (r/define-node frame 0 (r/pure :foo)) - (r/ap (r/lookup frame :clojure.core/vector (r/pure vector)) - (r/node frame 0) (r/node frame 0))))] - - ;; lexical scope - (l/compile ::Main `(e/client - (let [x "Hello" - y "world"] - [x y]))) - := `[(r/cdef 0 [:client :client] [] :client - (fn [frame] - (r/define-node frame 0 (r/pure "Hello")) - (r/define-node frame 1 (r/pure "world")) - (r/ap (r/lookup frame :clojure.core/vector (r/pure vector)) - (r/node frame 0) (r/node frame 1))))] - - (l/compile ::Main `(e/client - (let [a (e/server :foo)] - (e/server (prn a))))) - := `[(r/cdef 0 [:server] [] :server - (fn [frame] - (r/define-node frame 0 (r/pure :foo)) - (r/ap (r/lookup frame :clojure.core/prn (r/pure prn)) - (r/node frame 0))))] ;; (def !x (atom 0)) ;; join (e/watch !x) From 206e5bd8ceb373072625601a0372fbec57be0186 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Wed, 17 Jan 2024 21:59:16 +0100 Subject: [PATCH 031/428] fix latest-product spurious termination --- src/hyperfiddle/incseq.cljc | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/src/hyperfiddle/incseq.cljc b/src/hyperfiddle/incseq.cljc index ee403ed91..3dac0c419 100644 --- a/src/hyperfiddle/incseq.cljc +++ b/src/hyperfiddle/incseq.cljc @@ -746,7 +746,7 @@ combined with given function. (if (== arity item) (do (aset state slot-push nil) (if (zero? (aget state slot-live)) - (aget state slot-terminator) nop)) + (do (prn :a) (aget state slot-terminator)) nop)) (do (aset ready i arity) (recur item (rem (unchecked-inc-int i) arity)))))))) (let [x (aget state slot-value)] @@ -755,7 +755,7 @@ combined with given function. (terminated [^objects state] ((locking state (if (zero? (aset state slot-live (dec (aget state slot-live)))) - (if (zero? (aget state slot-push)) (aget state slot-terminator) nop) nop)))) + (if (nil? (aget state slot-push)) (aget state slot-terminator) nop) nop)))) (input-ready [^objects state item] ((locking state (let [^objects processes (aget state slot-processes) @@ -1548,6 +1548,18 @@ optional `compare` function, `clojure.core/compare` by default. (q {:grow 1 :degree 1 :shrink 0 :permutation {} :change {0 :b} :freeze #{}}) @ps := {:degree 1, :permutation {}, :grow 1, :shrink 0, :change {0 [:a :b]}, :freeze #{}}) + (let [q (queue) + ps ((latest-product vector + (fn [n t] (n) (->Ps q #(% :cancel) #(do (t) (%)))) + (fn [n t] (n) (->Ps q #(% :cancel) #(do (t) (%))))) + #(q :step) #(q :done))] + (q) := :step + (q {:grow 1 :degree 1 :shrink 0 :permutation {} :change {0 :a} :freeze #{}}) + (q {:grow 1 :degree 1 :shrink 0 :permutation {} :change {0 :b} :freeze #{}}) + @ps := {:degree 1, :permutation {}, :grow 1, :shrink 0, :change {0 [:a :b]}, :freeze #{}} + (q) := :done + (q) :throws #?(:clj java.util.NoSuchElementException :cljs js/Error)) + (let [q (queue) ps ((latest-product vector (fn [n t] (q n) (->Ps q #(% :cancel) #(%))) From 7373b5ec43c14fd232681089324efd9cfc47217d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Wed, 17 Jan 2024 22:06:37 +0100 Subject: [PATCH 032/428] prn cleanup --- src/hyperfiddle/incseq.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/hyperfiddle/incseq.cljc b/src/hyperfiddle/incseq.cljc index 3dac0c419..7e7729e80 100644 --- a/src/hyperfiddle/incseq.cljc +++ b/src/hyperfiddle/incseq.cljc @@ -746,7 +746,7 @@ combined with given function. (if (== arity item) (do (aset state slot-push nil) (if (zero? (aget state slot-live)) - (do (prn :a) (aget state slot-terminator)) nop)) + (aget state slot-terminator) nop)) (do (aset ready i arity) (recur item (rem (unchecked-inc-int i) arity)))))))) (let [x (aget state slot-value)] From 313746ee22728ee4fe89123e10828c73834b74da Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 18 Jan 2024 09:43:19 +0100 Subject: [PATCH 033/428] compiler: join --- src/hyperfiddle/electric/impl/lang_de2.clj | 11 ++++++++--- test/hyperfiddle/electric_compiler_test.clj | 8 ++++++++ 2 files changed, 16 insertions(+), 3 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 4d158ae8d..15a54a5d8 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -468,10 +468,12 @@ ::ap (reduce count-nodes ts (get-children-e ts e)) ::site (recur ts (first (get-children-e ts e))) ::var ts + ::join ts ::let-ref (let [used (::used (get (:eav ts) (::ref nd)))] (cond-> (ts/upd ts (::ref nd) ::used #(conj (or % #{}) e)) - (nil? used) (recur (find-return-node-e ts (first (get-children-e ts (::ref nd)))))))))) + (nil? used) (recur (find-return-node-e ts (first (get-children-e ts (::ref nd))))))) + #_else (throw (ex-info (str "cannot count-nodes on " (::type nd)) (or nd {})))))) index-nodes (fn index-nodes [ts e] (let [nd (get (:eav ts) e)] (case (::type nd) @@ -479,6 +481,7 @@ ::ap (reduce index-nodes ts (get-children-e ts e)) ::site (recur ts (first (get-children-e ts e))) ::var ts + ::join ts ::let-ref (recur (if-some [used (::used (get (:eav ts) (::ref nd)))] (if (or (> (count used) 1) (not= (get-site ts e) @@ -487,7 +490,7 @@ ts) ts) (find-return-node-e ts (first (get-children-e ts (::ref nd))))) - #_else (throw (ex-info (str "cannot index-nodes " (::type nd)) nd))))) + #_else (throw (ex-info (str "cannot index-nodes on " (::type nd)) (or nd {})))))) ts (-> ts (count-nodes ret-e) (index-nodes ret-e)) gen (fn gen [ts e] (let [nd (get (:eav ts) e)] @@ -495,10 +498,12 @@ ::static (list `r/pure (::v nd)) ::ap (list* `r/ap (mapv #(gen ts %) (get-children-e ts e))) ::var (list `r/lookup 'frame (keyword (::var nd)) (list `r/pure (::var nd))) + ::join (list `r/join (gen ts (first (get-children-e ts e)))) ::let (recur ts (find-return-node-e ts (second (get-children-e ts e)))) ::let-ref (if-some [idx (::refidx (get (:eav ts) (::ref nd)))] (list `r/node 'frame idx) - (gen ts (find-return-node-e ts (first (get-children-e ts (::ref nd))))))))) + (gen ts (find-return-node-e ts (first (get-children-e ts (::ref nd)))))) + #_else (throw (ex-info (str "cannot gen on " (::type nd)) (or nd {})))))) nodes (mapv (fn [[idx es]] [idx (first es)]) (sort-by first (::refidx (:ave ts)))) gen-node-init (fn gen-node-init [ts] (mapv (fn [[idx e]] (list `r/define-node 'frame idx diff --git a/test/hyperfiddle/electric_compiler_test.clj b/test/hyperfiddle/electric_compiler_test.clj index 67e0f9374..b0941967e 100644 --- a/test/hyperfiddle/electric_compiler_test.clj +++ b/test/hyperfiddle/electric_compiler_test.clj @@ -89,6 +89,14 @@ (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure clojure.core/prn)) (r/pure :foo))))]) + (def !x (atom 0)) + (l/compile ::Main (::lang/site :client (::lang/join (i/fixed (m/watch !x))))) + := `[(r/cdef 0 [] [] :client + (fn [~'frame] + (r/join + (r/ap (r/lookup ~'frame ::i/fixed (r/pure i/fixed)) + (r/ap (r/lookup ~'frame ::m/watch (r/pure m/watch)) + (r/lookup ~'frame ::!x (r/pure !x)))))))] ) ;; TODO rewrite or remove From 3e591aaddcfd232e003f8ea3c017d61430b16c6a Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 18 Jan 2024 10:02:51 +0100 Subject: [PATCH 034/428] refactor --- src/hyperfiddle/electric/impl/lang_de2.clj | 34 ++++++++++++---------- 1 file changed, 19 insertions(+), 15 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 15a54a5d8..75e23ebf6 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -360,7 +360,8 @@ (clojure.lang.Reflector/getField cls (name sym) true))))) (defn get-children-e [ts e] (-> ts :ave ::parent (get e))) -(defn get-root-e [ts] (first (get-children-e ts '_))) +(defn get-child-e [ts e] (first (get-children-e ts e))) +(defn get-root-e [ts] (get-child-e ts '_)) (defn find-let-ref [sym pe ts] (loop [pe pe] @@ -450,46 +451,49 @@ (and pe (let [nd (get (:eav ts) pe)] (if (= ::site (::type nd)) (::site nd) (recur (::parent nd))))))) +(defn ->let-val-e [ts e] (first (get-children-e ts e))) +(defn ->let-body-e [ts e] (second (get-children-e ts e))) + (defn compile ([nm form env] (let [{{::keys [env ->id]} :o :as ts} (analyze (expand-all env form) '_ (ts/->ts {::->id (->->id), ::env env})) - find-return-node-e (fn [ts e] + get-ret-e (fn [ts e] (let [nd (get (:eav ts) e)] (case (::type nd) - ::let (recur ts (second (get-children-e ts e))) - ::site (recur ts (first (get-children-e ts e))) + ::let (recur ts (->let-body-e ts e)) + ::site (recur ts (get-child-e ts e)) #_else e))) - ret-e (find-return-node-e ts (get-root-e ts)) + ret-e (get-ret-e ts (get-root-e ts)) ->ref-id (->->id) count-nodes (fn count-nodes [ts e] (let [nd (get (:eav ts) e)] (case (::type nd) ::static ts ::ap (reduce count-nodes ts (get-children-e ts e)) - ::site (recur ts (first (get-children-e ts e))) + ::site (recur ts (get-child-e ts e)) ::var ts ::join ts ::let-ref (let [used (::used (get (:eav ts) (::ref nd)))] (cond-> (ts/upd ts (::ref nd) ::used #(conj (or % #{}) e)) - (nil? used) (recur (find-return-node-e ts (first (get-children-e ts (::ref nd))))))) + (nil? used) (recur (get-ret-e ts (->let-val-e ts (::ref nd)))))) #_else (throw (ex-info (str "cannot count-nodes on " (::type nd)) (or nd {})))))) index-nodes (fn index-nodes [ts e] (let [nd (get (:eav ts) e)] (case (::type nd) ::static ts ::ap (reduce index-nodes ts (get-children-e ts e)) - ::site (recur ts (first (get-children-e ts e))) + ::site (recur ts (get-child-e ts e)) ::var ts ::join ts ::let-ref (recur (if-some [used (::used (get (:eav ts) (::ref nd)))] (if (or (> (count used) 1) (not= (get-site ts e) - (get-site ts (find-return-node-e ts (first (get-children-e ts (::ref nd))))))) + (get-site ts (get-ret-e ts (->let-val-e ts (::ref nd)))))) (ts/upd ts (::ref nd) ::refidx #(or % (->ref-id))) ts) ts) - (find-return-node-e ts (first (get-children-e ts (::ref nd))))) + (get-ret-e ts (->let-val-e ts (::ref nd)))) #_else (throw (ex-info (str "cannot index-nodes on " (::type nd)) (or nd {})))))) ts (-> ts (count-nodes ret-e) (index-nodes ret-e)) gen (fn gen [ts e] @@ -498,19 +502,19 @@ ::static (list `r/pure (::v nd)) ::ap (list* `r/ap (mapv #(gen ts %) (get-children-e ts e))) ::var (list `r/lookup 'frame (keyword (::var nd)) (list `r/pure (::var nd))) - ::join (list `r/join (gen ts (first (get-children-e ts e)))) - ::let (recur ts (find-return-node-e ts (second (get-children-e ts e)))) + ::join (list `r/join (gen ts (get-child-e ts e))) + ::let (recur ts (get-ret-e ts (->let-body-e ts e))) ::let-ref (if-some [idx (::refidx (get (:eav ts) (::ref nd)))] (list `r/node 'frame idx) - (gen ts (find-return-node-e ts (first (get-children-e ts (::ref nd)))))) + (gen ts (get-ret-e ts (->let-val-e ts (::ref nd))))) #_else (throw (ex-info (str "cannot gen on " (::type nd)) (or nd {})))))) nodes (mapv (fn [[idx es]] [idx (first es)]) (sort-by first (::refidx (:ave ts)))) gen-node-init (fn gen-node-init [ts] (mapv (fn [[idx e]] (list `r/define-node 'frame idx - (gen ts (find-return-node-e ts (first (get-children-e ts e)))))) + (gen ts (get-ret-e ts (->let-val-e ts e))))) nodes)) ] ;; (run! prn (->> ts :eav vals (sort-by :db/id))) - `[(r/cdef 0 ~(mapv #(get-site ts (find-return-node-e ts (first (get-children-e ts (second %))))) nodes) [] ~(get-site ts ret-e) + `[(r/cdef 0 ~(mapv #(get-site ts (get-ret-e ts (->let-val-e ts (second %)))) nodes) [] ~(get-site ts ret-e) (fn [~'frame] ~@(gen-node-init ts) ~(gen ts ret-e)))] ))) From 1bead2b89c8c2681935f66603a048ed5a89aeb9d Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 18 Jan 2024 10:14:48 +0100 Subject: [PATCH 035/428] update site in env --- src/hyperfiddle/electric/impl/lang_de2.clj | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 75e23ebf6..78bd7cebe 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -412,7 +412,8 @@ (?add-source-map e form)))) (::site) (let [[_ site bform] form, e (->id)] (recur bform e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::site, ::site site}) - (?add-source-map e form)))) + (?add-source-map e form) + (update :o update ::env assoc ::current site)))) #_else (let [e (->id)] (reduce (fn [ts nx] (analyze nx e ts)) (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) (?add-source-map e form)) form))) From aa484945ee46823ec46a23b85aa4b643b822d6d0 Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 18 Jan 2024 11:08:36 +0100 Subject: [PATCH 036/428] copy expander updates over, simplify env helpers --- src/hyperfiddle/electric/impl/lang_de2.clj | 83 ++++++++++++++++------ 1 file changed, 62 insertions(+), 21 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 78bd7cebe..bf9950304 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -14,6 +14,16 @@ [hyperfiddle.electric.impl.runtime-de :as r] [hyperfiddle.rcf :as rcf :refer [tests]])) +;;;;;;;;;;; +;;; ENV ;;; +;;;;;;;;;;; + +(defn clj-env? [env] (not (contains? env :locals))) +(defn electric-env? [env] (contains? env ::peers)) +(defn cljs-env? [env] (and (contains? env :locals) (not (electric-env? env)))) +(defn normalize-env [env] (if (clj-env? env) {:locals env, :ns {:name (ns-name *ns*)}} env)) +(defn get-ns [env] (-> env :ns :name)) + ;;;;;;;;;;;;;;;; ;;; EXPANDER ;;; ;;;;;;;;;;;;;;;; @@ -26,17 +36,18 @@ (when (not= '. sym) (let [!found? (volatile! true) resolved (binding [cljs-ana/*cljs-warnings* (assoc cljs-ana/*cljs-warnings* :undeclared-ns false)] - (cljs-ana/resolve-var env sym - (fn [env prefix suffix] - (cljs-ana/confirm-var-exists env prefix suffix - (fn [_ _ _] (vreset! !found? false)))) nil))] + (let [res (cljs-ana/resolve-var env sym nil nil)] + (when (and (not= :js-var (:op res)) (:name res) (namespace (:name res))) + (cljs-ana/confirm-var-exists env (-> res :name namespace symbol) (-> res :name name symbol) + (fn [_ _ _] (vreset! !found? false)))) + res))] (when (and resolved @!found? (not (:macro resolved))) ;; If the symbol is unqualified and is from a different ns (through e.g. :refer) ;; cljs returns only :name and :ns. We cannot tell if it resolved to a macro. ;; We recurse with the fully qualified symbol to get all the information. ;; The symbol can also resolve to a local in which case we're done. ;; TODO how to trigger these in tests? - (if (and (simple-symbol? sym) (not= (:ns env) (:ns resolved)) (not= :local (:op resolved))) + (if (and (simple-symbol? sym) (not= (get-ns env) (:ns resolved)) (not= :local (:op resolved))) (recur env (ca/check qualified-symbol? (:name resolved) {:sym sym, :resolved resolved})) resolved))))) @@ -192,33 +203,63 @@ ;; if ::current = :clj expand with clj environment ;; if ::current = :cljs expand with cljs environment +;; the ns cache relies on external eviction in shadow-cljs reload hook +(def !cljs-ns-cache (atom {})) + (defn enrich-for-require-macros-lookup [cljs-env nssym] - (if-some [src (cljs-ana/locate-src nssym)] - (let [ast (:ast (with-redefs [cljs-ana/missing-use-macro? (constantly nil)] - (binding [cljs-ana/*passes* []] - (cljs-ana/parse-ns src {:load-macros true, :restore false}))))] - ;; we parsed the ns form without `ns-side-effects` because it triggers weird bugs - ;; this means the macro nss from `:require-macros` might not be loaded - (run! serialized-require (-> ast :require-macros vals set)) - (assoc cljs-env ::ns ast)) - cljs-env)) + (if-some [ast (get @!cljs-ns-cache nssym)] + (assoc cljs-env ::ns ast) + (if-some [src (cljs-ana/locate-src nssym)] + (let [ast (:ast (with-redefs [cljs-ana/missing-use-macro? (constantly nil)] + (binding [cljs-ana/*passes* []] + (cljs-ana/parse-ns src {:load-macros true, :restore false}))))] + ;; we parsed the ns form without `ns-side-effects` because it triggers weird bugs + ;; this means the macro nss from `:require-macros` might not be loaded + (run! serialized-require (-> ast :require-macros vals set)) + (swap! !cljs-ns-cache assoc nssym ast) + (assoc cljs-env ::ns ast)) + cljs-env))) (tests "enrich of clj source file is noop" (cljs.env/ensure (enrich-for-require-macros-lookup {:a 1} 'clojure.core)) := {:a 1}) -;; takes an electric environment, which can be clj or cljs -;; if it's clj we need to prep the cljs environment (cljs.env/ensure + cljs.analyzer/empty-env with patched ns) -;; we need to be able to swap the environments infinite number of times - -(defn ->common-env [env] +(let [-base-cljs-env {:context :statement + :locals {} + :fn-scope [] + :js-globals (into {} + (map #(vector % {:op :js-var :name % :ns 'js}) + '(alert window document console escape unescape + screen location navigator history location + global process require module exports)))}] + (defn ->cljs-env + ([] (->cljs-env (ns-name *ns*))) + ([nssym] (cond-> -base-cljs-env nssym (assoc :ns {:name nssym}))))) + +(def !default-cljs-compiler-env (delay (cljs.env/default-compiler-env))) + +;; adapted from cljs.env +(defmacro ensure-cljs-compiler + [& body] + `(let [val# cljs.env/*compiler*] + (if (nil? val#) + (push-thread-bindings + (hash-map (var cljs.env/*compiler*) @!default-cljs-compiler-env))) + (try + ~@body + (finally + (if (nil? val#) + (pop-thread-bindings)))))) + +(defn ensure-cljs-env [env] (if (::cljs-env env) env (assoc env ::cljs-env (if (contains? env :js-globals) env - (cond-> (cljs.analyzer/empty-env) (:ns env) (enrich-for-require-macros-lookup (:ns env))))))) + (let [nssym (get-ns env)] + (cond-> (->cljs-env nssym) nssym (enrich-for-require-macros-lookup nssym))))))) -(defn expand-all [env o] (cljs.env/ensure (-expand-all o (->common-env env)))) +(defn expand-all [env o] (ensure-cljs-compiler (-expand-all o (ensure-cljs-env env)))) ;;;;;;;;;;;;;;;; ;;; COMPILER ;;; From 5c99fdd72547498cfee09b2201d553b597f8aa48 Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 18 Jan 2024 13:17:26 +0100 Subject: [PATCH 037/428] cljs compiler support --- src/hyperfiddle/electric/impl/lang_de2.clj | 257 +++++++++--------- src/hyperfiddle/electric_local_def_de.cljc | 16 +- ...r_test.clj => electric_compiler_test.cljc} | 0 3 files changed, 143 insertions(+), 130 deletions(-) rename test/hyperfiddle/{electric_compiler_test.clj => electric_compiler_test.cljc} (100%) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index bf9950304..5f2ae3f34 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -10,7 +10,6 @@ [dom-top.core :refer [loopr]] [hyperfiddle.electric :as-alias e] [hyperfiddle.electric.impl.analyzer :as ana] - [hyperfiddle.electric.impl.expand :as expand] [hyperfiddle.electric.impl.runtime-de :as r] [hyperfiddle.rcf :as rcf :refer [tests]])) @@ -24,6 +23,74 @@ (defn normalize-env [env] (if (clj-env? env) {:locals env, :ns {:name (ns-name *ns*)}} env)) (defn get-ns [env] (-> env :ns :name)) +(defn serialized-require [sym] + ;; we might be expanding clj code before the ns got loaded (during cljs compilation) + ;; to correctly lookup vars the ns needs to be loaded + ;; since shadow-cljs compiles in parallel we need to serialize the requires + (when-not (get (loaded-libs) sym) + (try (#'clojure.core/serialized-require sym) ; try bc it can be cljs file + (catch java.io.FileNotFoundException _)))) + +;; the ns cache relies on external eviction in shadow-cljs reload hook +(def !cljs-ns-cache (atom {})) + +(defn enrich-for-require-macros-lookup [cljs-env nssym] + (if-some [ast (get @!cljs-ns-cache nssym)] + (assoc cljs-env :ns ast) + (if-some [src (contrib.debug/dbg (cljs-ana/locate-src nssym))] + (let [ast (:ast (with-redefs [cljs-ana/missing-use-macro? (constantly nil)] + (binding [cljs-ana/*passes* []] + (cljs-ana/parse-ns src {:load-macros true, :restore false}))))] + ;; we parsed the ns form without `ns-side-effects` because it triggers weird bugs + ;; this means the macro nss from `:require-macros` might not be loaded + (run! serialized-require (-> ast :require-macros vals set)) + (swap! !cljs-ns-cache assoc nssym ast) + (assoc cljs-env :ns ast)) + cljs-env))) + +(tests "enrich of clj source file is noop" + (cljs.env/ensure (enrich-for-require-macros-lookup {:a 1} 'clojure.core)) := {:a 1}) + +(let [-base-cljs-env {:context :statement + :locals {} + :fn-scope [] + :js-globals (into {} + (map #(vector % {:op :js-var :name % :ns 'js}) + '(alert window document console escape unescape + screen location navigator history location + global process require module exports)))}] + (defn ->cljs-env + ([] (->cljs-env (ns-name *ns*))) + ([nssym] (cond-> -base-cljs-env nssym (assoc :ns {:name nssym}))))) + +(def !default-cljs-compiler-env + (delay + (cljs.env/ensure + (cljs-ana/analyze-file "cljs/core.cljs") ; needed in general, to resolve cljs.core vars + cljs.env/*compiler*))) + +;; adapted from cljs.env +(defmacro ensure-cljs-compiler + [& body] + `(let [val# cljs.env/*compiler*] + (if (nil? val#) + (push-thread-bindings + (hash-map (var cljs.env/*compiler*) @!default-cljs-compiler-env))) + (try + ~@body + (finally + (if (nil? val#) + (pop-thread-bindings)))))) + +(defn ensure-cljs-env [env] + (if (::cljs-env env) + env + (assoc env ::cljs-env + (if (contains? env :js-globals) + env + (let [nssym (get-ns env)] + (cond-> (->cljs-env nssym) nssym (enrich-for-require-macros-lookup nssym))))))) + ;;;;;;;;;;;;;;;; ;;; EXPANDER ;;; ;;;;;;;;;;;;;;;; @@ -51,13 +118,13 @@ (recur env (ca/check qualified-symbol? (:name resolved) {:sym sym, :resolved resolved})) resolved))))) -(defn serialized-require [sym] - ;; we might be expanding clj code before the ns got loaded (during cljs compilation) - ;; to correctly lookup vars the ns needs to be loaded - ;; since shadow-cljs compiles in parallel we need to serialize the requires - (when-not (get (loaded-libs) sym) - (try (#'clojure.core/serialized-require sym) ; try bc it can be cljs file - (catch java.io.FileNotFoundException _)))) +(comment + (cljs.env/ensure (cljs-ana/resolve-var (cljs-ana/empty-env) 'prn nil nil)) + (->cljs-env) + (cljs-ana/empty-env) + (require '[hyperfiddle.electric.impl.expand :as expand]) + (cljs.env/ensure (resolve-cljs (cljs-ana/empty-env) 'prn)) + ) (defn macroexpand-clj [o] (serialized-require (ns-name *ns*)) (macroexpand-1 o)) @@ -203,61 +270,6 @@ ;; if ::current = :clj expand with clj environment ;; if ::current = :cljs expand with cljs environment -;; the ns cache relies on external eviction in shadow-cljs reload hook -(def !cljs-ns-cache (atom {})) - -(defn enrich-for-require-macros-lookup [cljs-env nssym] - (if-some [ast (get @!cljs-ns-cache nssym)] - (assoc cljs-env ::ns ast) - (if-some [src (cljs-ana/locate-src nssym)] - (let [ast (:ast (with-redefs [cljs-ana/missing-use-macro? (constantly nil)] - (binding [cljs-ana/*passes* []] - (cljs-ana/parse-ns src {:load-macros true, :restore false}))))] - ;; we parsed the ns form without `ns-side-effects` because it triggers weird bugs - ;; this means the macro nss from `:require-macros` might not be loaded - (run! serialized-require (-> ast :require-macros vals set)) - (swap! !cljs-ns-cache assoc nssym ast) - (assoc cljs-env ::ns ast)) - cljs-env))) - -(tests "enrich of clj source file is noop" - (cljs.env/ensure (enrich-for-require-macros-lookup {:a 1} 'clojure.core)) := {:a 1}) - -(let [-base-cljs-env {:context :statement - :locals {} - :fn-scope [] - :js-globals (into {} - (map #(vector % {:op :js-var :name % :ns 'js}) - '(alert window document console escape unescape - screen location navigator history location - global process require module exports)))}] - (defn ->cljs-env - ([] (->cljs-env (ns-name *ns*))) - ([nssym] (cond-> -base-cljs-env nssym (assoc :ns {:name nssym}))))) - -(def !default-cljs-compiler-env (delay (cljs.env/default-compiler-env))) - -;; adapted from cljs.env -(defmacro ensure-cljs-compiler - [& body] - `(let [val# cljs.env/*compiler*] - (if (nil? val#) - (push-thread-bindings - (hash-map (var cljs.env/*compiler*) @!default-cljs-compiler-env))) - (try - ~@body - (finally - (if (nil? val#) - (pop-thread-bindings)))))) - -(defn ensure-cljs-env [env] - (if (::cljs-env env) - env - (assoc env ::cljs-env - (if (contains? env :js-globals) - env - (let [nssym (get-ns env)] - (cond-> (->cljs-env nssym) nssym (enrich-for-require-macros-lookup nssym))))))) (defn expand-all [env o] (ensure-cljs-compiler (-expand-all o (ensure-cljs-env env)))) @@ -478,7 +490,7 @@ (-> (ts/add ts {:db/id e, ::parent pe, ::type ::static, ::v form}) (?add-source-map e form))) (cannot-resolve! env form))) - :cljs (expand/resolve-cljs env form) + :cljs (resolve-cljs (::cljs-env env) form) #_else (throw (ex-info (str "unknown site: " (get (::peers env) (::current env))) {:env env}))))) :else @@ -498,65 +510,66 @@ (defn compile ([nm form env] - (let [{{::keys [env ->id]} :o :as ts} (analyze (expand-all env form) '_ (ts/->ts {::->id (->->id), ::env env})) - get-ret-e (fn [ts e] - (let [nd (get (:eav ts) e)] - (case (::type nd) - ::let (recur ts (->let-body-e ts e)) - ::site (recur ts (get-child-e ts e)) - #_else e))) - ret-e (get-ret-e ts (get-root-e ts)) - ->ref-id (->->id) - count-nodes (fn count-nodes [ts e] - (let [nd (get (:eav ts) e)] - (case (::type nd) - ::static ts - ::ap (reduce count-nodes ts (get-children-e ts e)) - ::site (recur ts (get-child-e ts e)) - ::var ts - ::join ts - ::let-ref - (let [used (::used (get (:eav ts) (::ref nd)))] - (cond-> (ts/upd ts (::ref nd) ::used #(conj (or % #{}) e)) - (nil? used) (recur (get-ret-e ts (->let-val-e ts (::ref nd)))))) - #_else (throw (ex-info (str "cannot count-nodes on " (::type nd)) (or nd {})))))) - index-nodes (fn index-nodes [ts e] + (ensure-cljs-compiler + (let [{{::keys [env ->id]} :o :as ts} (analyze (expand-all env form) '_ (ts/->ts {::->id (->->id), ::env (ensure-cljs-env env)})) + get-ret-e (fn [ts e] (let [nd (get (:eav ts) e)] (case (::type nd) - ::static ts - ::ap (reduce index-nodes ts (get-children-e ts e)) + ::let (recur ts (->let-body-e ts e)) ::site (recur ts (get-child-e ts e)) - ::var ts - ::join ts - ::let-ref (recur (if-some [used (::used (get (:eav ts) (::ref nd)))] - (if (or (> (count used) 1) - (not= (get-site ts e) - (get-site ts (get-ret-e ts (->let-val-e ts (::ref nd)))))) - (ts/upd ts (::ref nd) ::refidx #(or % (->ref-id))) + #_else e))) + ret-e (get-ret-e ts (get-root-e ts)) + ->ref-id (->->id) + count-nodes (fn count-nodes [ts e] + (let [nd (get (:eav ts) e)] + (case (::type nd) + ::static ts + ::ap (reduce count-nodes ts (get-children-e ts e)) + ::site (recur ts (get-child-e ts e)) + ::var ts + ::join ts + ::let-ref + (let [used (::used (get (:eav ts) (::ref nd)))] + (cond-> (ts/upd ts (::ref nd) ::used #(conj (or % #{}) e)) + (nil? used) (recur (get-ret-e ts (->let-val-e ts (::ref nd)))))) + #_else (throw (ex-info (str "cannot count-nodes on " (::type nd)) (or nd {})))))) + index-nodes (fn index-nodes [ts e] + (let [nd (get (:eav ts) e)] + (case (::type nd) + ::static ts + ::ap (reduce index-nodes ts (get-children-e ts e)) + ::site (recur ts (get-child-e ts e)) + ::var ts + ::join ts + ::let-ref (recur (if-some [used (::used (get (:eav ts) (::ref nd)))] + (if (or (> (count used) 1) + (not= (get-site ts e) + (get-site ts (get-ret-e ts (->let-val-e ts (::ref nd)))))) + (ts/upd ts (::ref nd) ::refidx #(or % (->ref-id))) + ts) ts) - ts) - (get-ret-e ts (->let-val-e ts (::ref nd)))) - #_else (throw (ex-info (str "cannot index-nodes on " (::type nd)) (or nd {})))))) - ts (-> ts (count-nodes ret-e) (index-nodes ret-e)) - gen (fn gen [ts e] - (let [nd (get (:eav ts) e)] - (case (::type nd) - ::static (list `r/pure (::v nd)) - ::ap (list* `r/ap (mapv #(gen ts %) (get-children-e ts e))) - ::var (list `r/lookup 'frame (keyword (::var nd)) (list `r/pure (::var nd))) - ::join (list `r/join (gen ts (get-child-e ts e))) - ::let (recur ts (get-ret-e ts (->let-body-e ts e))) - ::let-ref (if-some [idx (::refidx (get (:eav ts) (::ref nd)))] - (list `r/node 'frame idx) - (gen ts (get-ret-e ts (->let-val-e ts (::ref nd))))) - #_else (throw (ex-info (str "cannot gen on " (::type nd)) (or nd {})))))) - nodes (mapv (fn [[idx es]] [idx (first es)]) (sort-by first (::refidx (:ave ts)))) - gen-node-init (fn gen-node-init [ts] - (mapv (fn [[idx e]] (list `r/define-node 'frame idx - (gen ts (get-ret-e ts (->let-val-e ts e))))) - nodes)) - ] - ;; (run! prn (->> ts :eav vals (sort-by :db/id))) - `[(r/cdef 0 ~(mapv #(get-site ts (get-ret-e ts (->let-val-e ts (second %)))) nodes) [] ~(get-site ts ret-e) - (fn [~'frame] ~@(gen-node-init ts) ~(gen ts ret-e)))] - ))) + (get-ret-e ts (->let-val-e ts (::ref nd)))) + #_else (throw (ex-info (str "cannot index-nodes on " (::type nd)) (or nd {})))))) + ts (-> ts (count-nodes ret-e) (index-nodes ret-e)) + gen (fn gen [ts e] + (let [nd (get (:eav ts) e)] + (case (::type nd) + ::static (list `r/pure (::v nd)) + ::ap (list* `r/ap (mapv #(gen ts %) (get-children-e ts e))) + ::var (list `r/lookup 'frame (keyword (::var nd)) (list `r/pure (::var nd))) + ::join (list `r/join (gen ts (get-child-e ts e))) + ::let (recur ts (get-ret-e ts (->let-body-e ts e))) + ::let-ref (if-some [idx (::refidx (get (:eav ts) (::ref nd)))] + (list `r/node 'frame idx) + (gen ts (get-ret-e ts (->let-val-e ts (::ref nd))))) + #_else (throw (ex-info (str "cannot gen on " (::type nd)) (or nd {})))))) + nodes (mapv (fn [[idx es]] [idx (first es)]) (sort-by first (::refidx (:ave ts)))) + gen-node-init (fn gen-node-init [ts] + (mapv (fn [[idx e]] (list `r/define-node 'frame idx + (gen ts (get-ret-e ts (->let-val-e ts e))))) + nodes)) + ] + ;; (run! prn (->> ts :eav vals (sort-by :db/id))) + `[(r/cdef 0 ~(mapv #(get-site ts (get-ret-e ts (->let-val-e ts (second %)))) nodes) [] ~(get-site ts ret-e) + (fn [~'frame] ~@(gen-node-init ts) ~(gen ts ret-e)))] + )))) diff --git a/src/hyperfiddle/electric_local_def_de.cljc b/src/hyperfiddle/electric_local_def_de.cljc index 7db650e79..79063277f 100644 --- a/src/hyperfiddle/electric_local_def_de.cljc +++ b/src/hyperfiddle/electric_local_def_de.cljc @@ -1,17 +1,20 @@ (ns hyperfiddle.electric-local-def-de - (:refer-clojure :exclude [def defn compile]) + (:refer-clojure :exclude [compile]) #?(:cljs (:require-macros hyperfiddle.electric-local-def-de)) (:require [clojure.core :as cc] [contrib.cljs-target] - #?(:clj [hyperfiddle.electric.impl.lang-de2 :as lang]))) + #?(:clj [hyperfiddle.electric.impl.lang-de2 :as lang] + :cljs [hyperfiddle.electric.impl.lang-de2 :as-alias lang]))) -(cc/defn ->local-config [env] +(defn ->local-config [env] (let [p (if (:js-globals env) :cljs :clj)] {::lang/peers {:client p, :server p}, ::lang/current :server})) -(cc/defn ->single-peer-config [env] +(defn ->single-peer-config [env] (let [p (if (and (:js-globals env) (contrib.cljs-target/do-nodejs true)) :client :server)] {::lang/peers {p (if (:js-globals env) :cljs :clj)}, ::lang/current p, ::lang/me p})) +(def web-config {::lang/peers {:client :cljs, :server :clj}, ::lang/current :server}) + (defmacro compile-client [form] (let [env (merge &env (->local-config &env) {::lang/me :client, :ns (list 'quote (ns-name *ns*))})] `(:source (lang/compile '~form ~env)))) @@ -25,7 +28,4 @@ (let [env (merge &env (->local-config &env) {::lang/me :server})] `(:source (lang/compile '~form ~env)))) -(cc/defn ->electric-env [env] - (if (:js-globals env) env {:locals env :ns (ns-name *ns*)})) - -(defmacro compile [nm form] `(lang/compile ~nm '~form '~(merge (->local-config &env) (->electric-env &env)))) +(defmacro compile [nm form] `(lang/compile ~nm '~form '~(merge web-config (lang/normalize-env &env)))) diff --git a/test/hyperfiddle/electric_compiler_test.clj b/test/hyperfiddle/electric_compiler_test.cljc similarity index 100% rename from test/hyperfiddle/electric_compiler_test.clj rename to test/hyperfiddle/electric_compiler_test.cljc From fb08f1cf412fee6a2155ad0142c662babdf9dddb Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 18 Jan 2024 18:00:51 +0100 Subject: [PATCH 038/428] compiler: cljs var resolving, locals --- src/hyperfiddle/electric/impl/lang_de2.clj | 49 ++++++++++++++------ src/hyperfiddle/electric_local_def_de.cljc | 4 +- test/hyperfiddle/electric_compiler_test.cljc | 16 +++---- 3 files changed, 46 insertions(+), 23 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 5f2ae3f34..ff94ff83d 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -37,7 +37,7 @@ (defn enrich-for-require-macros-lookup [cljs-env nssym] (if-some [ast (get @!cljs-ns-cache nssym)] (assoc cljs-env :ns ast) - (if-some [src (contrib.debug/dbg (cljs-ana/locate-src nssym))] + (if-some [src (cljs-ana/locate-src nssym)] (let [ast (:ast (with-redefs [cljs-ana/missing-use-macro? (constantly nil)] (binding [cljs-ana/*passes* []] (cljs-ana/parse-ns src {:load-macros true, :restore false}))))] @@ -428,6 +428,18 @@ (let [mt (meta form)] (cond-> ts (:line mt) (ts/add {:db/id (->id), ::source-map-of pe, ::line (:line mt), ::column (:column mt)})))) +(defn untwin [s] + (if (= "cljs.core" (namespace s)) + (let [clj (symbol "clojure.core" (name s))] + (if (resolve clj) clj s)) + s)) + +(tests + (untwin 'cljs.core/prn) := 'clojure.core/prn + (untwin 'a/b) := 'a/b + (untwin 'a) := 'a + (untwin 'cljs.core/not-in-clj) := 'cljs.core/not-in-clj) + (defn analyze [form pe {{::keys [env ->id]} :o :as ts}] (cond (and (seq? form) (seq form)) @@ -479,19 +491,28 @@ (if-some [lr-e (find-let-ref form pe ts)] (-> (ts/add ts {:db/id e, ::parent pe, ::type ::let-ref, ::ref lr-e, ::sym form}) (?add-source-map e form)) - (case (get (::peers env) (::current env)) - :clj (if (resolve-static-field form) - (-> (ts/add ts {:db/id e, ::parent pe, ::type ::static, ::v form}) - (?add-source-map e form)) - (if-some [v (resolve form)] - (if (var? v) - (-> (ts/add ts {:db/id e, ::parent pe, ::type ::var, ::var (symbol v)}) - (?add-source-map e form)) - (-> (ts/add ts {:db/id e, ::parent pe, ::type ::static, ::v form}) - (?add-source-map e form))) - (cannot-resolve! env form))) - :cljs (resolve-cljs (::cljs-env env) form) - #_else (throw (ex-info (str "unknown site: " (get (::peers env) (::current env))) {:env env}))))) + (if (contains? (:locals env) form) + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::static, ::v form}) + (?add-source-map e form)) + (case (get (::peers env) (::current env)) + :clj (if (resolve-static-field form) + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::static, ::v form}) + (?add-source-map e form)) + (if-some [v (resolve form)] + (if (var? v) + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::var, ::var (symbol v)}) + (?add-source-map e form)) + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::static, ::v form}) + (?add-source-map e form))) + (cannot-resolve! env form))) + :cljs (if-some [v (resolve-cljs (::cljs-env env) form)] + (if (= :var (:op v)) + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::var, ::var (untwin (:name v))}) + (?add-source-map e form)) + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::static, ::v form}) + (?add-source-map e form))) + (cannot-resolve! env form)) + #_else (throw (ex-info (str "unknown site: " (get (::peers env) (::current env))) {:env env})))))) :else (let [e (->id)] diff --git a/src/hyperfiddle/electric_local_def_de.cljc b/src/hyperfiddle/electric_local_def_de.cljc index 79063277f..1b16e1cfb 100644 --- a/src/hyperfiddle/electric_local_def_de.cljc +++ b/src/hyperfiddle/electric_local_def_de.cljc @@ -28,4 +28,6 @@ (let [env (merge &env (->local-config &env) {::lang/me :server})] `(:source (lang/compile '~form ~env)))) -(defmacro compile [nm form] `(lang/compile ~nm '~form '~(merge web-config (lang/normalize-env &env)))) +(defmacro compile + ([nm form] `(compile ~nm identity ~form)) + ([nm env-fn form] `(lang/compile ~nm '~form (~env-fn '~(merge web-config (lang/normalize-env &env)))))) diff --git a/test/hyperfiddle/electric_compiler_test.cljc b/test/hyperfiddle/electric_compiler_test.cljc index b0941967e..ca5b59e24 100644 --- a/test/hyperfiddle/electric_compiler_test.cljc +++ b/test/hyperfiddle/electric_compiler_test.cljc @@ -89,14 +89,14 @@ (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure clojure.core/prn)) (r/pure :foo))))]) - (def !x (atom 0)) - (l/compile ::Main (::lang/site :client (::lang/join (i/fixed (m/watch !x))))) - := `[(r/cdef 0 [] [] :client - (fn [~'frame] - (r/join - (r/ap (r/lookup ~'frame ::i/fixed (r/pure i/fixed)) - (r/ap (r/lookup ~'frame ::m/watch (r/pure m/watch)) - (r/lookup ~'frame ::!x (r/pure !x)))))))] + (match (l/compile ::Main #(update % :locals assoc '!x (atom 0)) + (::lang/site :client (::lang/join (i/fixed (m/watch !x))))) + `[(r/cdef 0 [] [] :client + (fn [~'frame] + (r/join + (r/ap (r/lookup ~'frame ::i/fixed (r/pure i/fixed)) + (r/ap (r/lookup ~'frame ::m/watch (r/pure m/watch)) + (r/pure ~'!x))))))]) ) ;; TODO rewrite or remove From cc137e5e28b4bf9e29fff15dd979a28b27b27d92 Mon Sep 17 00:00:00 2001 From: xificurC Date: Fri, 19 Jan 2024 12:03:04 +0100 Subject: [PATCH 039/428] compiler: cljs var resolving, ambiguous vars --- src/hyperfiddle/electric/impl/lang_de2.clj | 64 ++++++++++++-------- src/hyperfiddle/electric_local_def_de.cljc | 10 ++- test/hyperfiddle/electric_compiler_test.cljc | 38 +++++++++--- 3 files changed, 76 insertions(+), 36 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index ff94ff83d..29052ef75 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -20,6 +20,7 @@ (defn clj-env? [env] (not (contains? env :locals))) (defn electric-env? [env] (contains? env ::peers)) (defn cljs-env? [env] (and (contains? env :locals) (not (electric-env? env)))) +(defn ->env-type [env] (if (:js-globals env) :cljs :clj)) (defn normalize-env [env] (if (clj-env? env) {:locals env, :ns {:name (ns-name *ns*)}} env)) (defn get-ns [env] (-> env :ns :name)) @@ -284,7 +285,7 @@ (defn fail! ([env msg] (fail! env msg {})) - ([env msg data] (throw (ex-info (str "in" (some->> (::def env) (str " ")) ": " (-> env ::last peek pr-str) "\n" msg) + ([env msg data] (throw (ex-info (str (when-some [d (::def env)] (str "in " d ":\n")) msg) (merge {:form (-> env ::last pop peek) :in (::def env) :for ((juxt ::me ::current) env)} data))))) (defn get-them [env] (-> env ::peers keys set (disj (::current env)) first)) @@ -297,6 +298,9 @@ \newline "If `" form "` is supposed to be a macro, you might need to :refer it in the :require-macros clause.")))) {:locals (keys (:locals env))})) +(defn ambiguous-resolve! [env sym] + (fail! env (str "Unsited symbol `" sym "` resolves to different vars on different peers. Please resolve ambiguity by siting the expression using it."))) + (defn ns-qualify [node] (if (namespace node) node (symbol (str *ns*) (str node)))) (tests @@ -440,6 +444,25 @@ (untwin 'a) := 'a (untwin 'cljs.core/not-in-clj) := 'cljs.core/not-in-clj) +(defn analyze-clj-symbol [form e pe] + (if (resolve-static-field form) + {:db/id e, ::parent pe, ::type ::static, ::v form} + (when-some [v (resolve form)] + (if (var? v) + {:db/id e, ::parent pe, ::type ::var, ::var form, ::qualified-var (symbol v)} + {:db/id e, ::parent pe, ::type ::static, ::v form})))) + +(defn analyze-cljs-symbol [form e pe env] + (when-some [v (resolve-cljs (::cljs-env env) form)] + (if (= :var (:op v)) + {:db/id e, ::parent pe, ::type ::var, ::var form, ::qualified-var (untwin (:name v))} + {:db/id e, ::parent pe, ::type ::static, ::v form}))) + +(defn get-site [ts e] + (loop [e e] + (and e + (let [nd (get (:eav ts) e)] (if (= ::site (::type nd)) (::site nd) (recur (::parent nd))))))) + (defn analyze [form pe {{::keys [env ->id]} :o :as ts}] (cond (and (seq? form) (seq form)) @@ -495,24 +518,19 @@ (-> (ts/add ts {:db/id e, ::parent pe, ::type ::static, ::v form}) (?add-source-map e form)) (case (get (::peers env) (::current env)) - :clj (if (resolve-static-field form) - (-> (ts/add ts {:db/id e, ::parent pe, ::type ::static, ::v form}) - (?add-source-map e form)) - (if-some [v (resolve form)] - (if (var? v) - (-> (ts/add ts {:db/id e, ::parent pe, ::type ::var, ::var (symbol v)}) - (?add-source-map e form)) - (-> (ts/add ts {:db/id e, ::parent pe, ::type ::static, ::v form}) - (?add-source-map e form))) - (cannot-resolve! env form))) - :cljs (if-some [v (resolve-cljs (::cljs-env env) form)] - (if (= :var (:op v)) - (-> (ts/add ts {:db/id e, ::parent pe, ::type ::var, ::var (untwin (:name v))}) - (?add-source-map e form)) - (-> (ts/add ts {:db/id e, ::parent pe, ::type ::static, ::v form}) - (?add-source-map e form))) + :clj (if-some [v (analyze-clj-symbol form e pe)] + (-> (ts/add ts (assoc v ::resolved-in :clj)) (?add-source-map e form)) + (cannot-resolve! env form)) + :cljs (if-some [v (analyze-cljs-symbol form e pe env)] + (-> (ts/add ts (assoc v ::resolved-in :cljs)) (?add-source-map e form)) (cannot-resolve! env form)) - #_else (throw (ex-info (str "unknown site: " (get (::peers env) (::current env))) {:env env})))))) + #_unsited (let [langs (set (vals (::peers env))) + vs (->> langs (into #{} (map #(case % + :clj (analyze-clj-symbol form e pe) + :cljs (analyze-cljs-symbol form e pe env)))))] + (cond (contains? vs nil) (cannot-resolve! env form) + (> (count vs) 1) (ambiguous-resolve! env form) + :else (-> (ts/add ts (first vs)) (?add-source-map e form)))))))) :else (let [e (->id)] @@ -521,11 +539,6 @@ (defn ->->id [] (let [!i (long-array [-1])] (fn [] (aset !i 0 (unchecked-inc (aget !i 0)))))) -(defn get-site [ts e] - (loop [pe (::parent (get (:eav ts) e))] - (and pe - (let [nd (get (:eav ts) pe)] (if (= ::site (::type nd)) (::site nd) (recur (::parent nd))))))) - (defn ->let-val-e [ts e] (first (get-children-e ts e))) (defn ->let-body-e [ts e] (second (get-children-e ts e))) @@ -577,7 +590,10 @@ (case (::type nd) ::static (list `r/pure (::v nd)) ::ap (list* `r/ap (mapv #(gen ts %) (get-children-e ts e))) - ::var (list `r/lookup 'frame (keyword (::var nd)) (list `r/pure (::var nd))) + ::var (let [in (::resolved-in nd)] + (if (or (nil? in) (= in (->env-type env))) + (list `r/lookup 'frame (keyword (::qualified-var nd)) (list `r/pure (::qualified-var nd))) + (list `r/lookup 'frame (keyword (::qualified-var nd))))) ::join (list `r/join (gen ts (get-child-e ts e))) ::let (recur ts (get-ret-e ts (->let-body-e ts e))) ::let-ref (if-some [idx (::refidx (get (:eav ts) (::ref nd)))] diff --git a/src/hyperfiddle/electric_local_def_de.cljc b/src/hyperfiddle/electric_local_def_de.cljc index 1b16e1cfb..9a85b9053 100644 --- a/src/hyperfiddle/electric_local_def_de.cljc +++ b/src/hyperfiddle/electric_local_def_de.cljc @@ -7,13 +7,13 @@ :cljs [hyperfiddle.electric.impl.lang-de2 :as-alias lang]))) (defn ->local-config [env] - (let [p (if (:js-globals env) :cljs :clj)] {::lang/peers {:client p, :server p}, ::lang/current :server})) + (let [p (if (:js-globals env) :cljs :clj)] {::lang/peers {:client p, :server p}})) (defn ->single-peer-config [env] (let [p (if (and (:js-globals env) (contrib.cljs-target/do-nodejs true)) :client :server)] - {::lang/peers {p (if (:js-globals env) :cljs :clj)}, ::lang/current p, ::lang/me p})) + {::lang/peers {p (if (:js-globals env) :cljs :clj)}, ::lang/me p})) -(def web-config {::lang/peers {:client :cljs, :server :clj}, ::lang/current :server}) +(def web-config {::lang/peers {:client :cljs, :server :clj}}) (defmacro compile-client [form] (let [env (merge &env (->local-config &env) {::lang/me :client, :ns (list 'quote (ns-name *ns*))})] @@ -31,3 +31,7 @@ (defmacro compile ([nm form] `(compile ~nm identity ~form)) ([nm env-fn form] `(lang/compile ~nm '~form (~env-fn '~(merge web-config (lang/normalize-env &env)))))) + +(defmacro compile-as-if-client + ([nm form] `(compile-as-if-client ~nm identity ~form)) + ([nm env-fn form] `(lang/compile ~nm '~form (~env-fn '~(merge web-config (lang/->cljs-env)))))) diff --git a/test/hyperfiddle/electric_compiler_test.cljc b/test/hyperfiddle/electric_compiler_test.cljc index ca5b59e24..74e4da107 100644 --- a/test/hyperfiddle/electric_compiler_test.cljc +++ b/test/hyperfiddle/electric_compiler_test.cljc @@ -5,9 +5,12 @@ [hyperfiddle.electric.impl.lang-de2 :as lang] [hyperfiddle.electric.impl.runtime-de :as r] [hyperfiddle.electric-local-def-de :as l] - [contrib.test-match :refer [test-match]] + #?(:clj [hyperfiddle.electric-compiler-test-clj :refer [cannot-be-unsited]] + :cljs [hyperfiddle.electric-compiler-test-cljs :refer [cannot-be-unsited]]) + [contrib.test-match :as tm] [fipp.edn] - [missionary.core :as m])) + [missionary.core :as m]) + #?(:clj (:import [clojure.lang ExceptionInfo]))) ;; tests that turn electric code into clojure code ;; basically no IR, we emit clojure code directly @@ -24,9 +27,10 @@ (catch Throwable e (find-source-map-info path)))) (defmacro match [code matcher] - `(let [ret# ~code, match# (test-match ret# ~matcher)] + `(let [ret# ~code, match# (tm/test-match ret# ~matcher)] ret# := match# - (when (not= ret# match#) (fipp.edn/pprint match#)))) + (when (not= ret# match#) (fipp.edn/pprint match#)) + match#)) (tests (match (l/compile ::Main 1) @@ -42,13 +46,29 @@ (match (l/compile ::Main (::lang/site :client (prn "Hello world"))) `[(r/cdef 0 [] [] :client (fn [~'frame] - (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure prn)) (r/pure "Hello world"))))]) + (r/ap (r/lookup ~'frame :clojure.core/prn) (r/pure "Hello world"))))]) + + (match (l/compile ::Main (::lang/site :client (undefined?))) + `[(r/cdef 0 [] [] :client + (fn [~'frame] + (r/ap (r/lookup ~'frame :cljs.core/undefined?))))]) + + (match (l/compile-as-if-client ::Main (::lang/site :client (undefined?))) + `[(r/cdef 0 [] [] :client + (fn [~'frame] + (r/ap (r/lookup ~'frame :cljs.core/undefined? (r/pure cljs.core/undefined?)))))]) + + ;; TODO return site is :server + (l/compile ::Main (::lang/site :server (let [x 1] (::lang/site :client x)))) + + (let [ex (try (l/compile ::Main cannot-be-unsited) (catch ExceptionInfo e e))] + (ex-message ex) := "Unsited symbol `cannot-be-unsited` resolves to different vars on different peers. Please resolve ambiguity by siting the expression using it.") (match (l/compile ::Main (::lang/site :client (let [a :foo] [a a]))) `[(r/cdef 0 [:client] [] :client (fn [~'frame] (r/define-node ~'frame 0 (r/pure :foo)) - (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure vector)) + (r/ap (r/lookup ~'frame :clojure.core/vector) (r/node ~'frame 0) (r/node ~'frame 0))))]) (match (l/compile ::Main (let [a :foo] [a a])) @@ -80,7 +100,7 @@ (match (l/compile ::Main (::lang/site :client (let [x "Hello", y "world"] [x y]))) `[(r/cdef 0 [] [] :client (fn [~'frame] - (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure clojure.core/vector)) + (r/ap (r/lookup ~'frame :clojure.core/vector) (r/pure "Hello") (r/pure "world"))))]) (match (l/compile ::Main (::lang/site :client (let [a (::lang/site :server :foo)] (::lang/site :server (prn a))))) @@ -94,8 +114,8 @@ `[(r/cdef 0 [] [] :client (fn [~'frame] (r/join - (r/ap (r/lookup ~'frame ::i/fixed (r/pure i/fixed)) - (r/ap (r/lookup ~'frame ::m/watch (r/pure m/watch)) + (r/ap (r/lookup ~'frame ::i/fixed) + (r/ap (r/lookup ~'frame ::m/watch) (r/pure ~'!x))))))]) ) From d631435699d0383e25e81110bdf64838560147c9 Mon Sep 17 00:00:00 2001 From: xificurC Date: Fri, 19 Jan 2024 12:22:15 +0100 Subject: [PATCH 040/428] compiler: fix codegen for site --- src/hyperfiddle/electric/impl/lang_de2.clj | 1 + test/hyperfiddle/electric_compiler_test.cljc | 15 +++++++++++++++ 2 files changed, 16 insertions(+) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 29052ef75..fd3f45e22 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -595,6 +595,7 @@ (list `r/lookup 'frame (keyword (::qualified-var nd)) (list `r/pure (::qualified-var nd))) (list `r/lookup 'frame (keyword (::qualified-var nd))))) ::join (list `r/join (gen ts (get-child-e ts e))) + ::site (recur ts (get-child-e ts e)) ::let (recur ts (get-ret-e ts (->let-body-e ts e))) ::let-ref (if-some [idx (::refidx (get (:eav ts) (::ref nd)))] (list `r/node 'frame idx) diff --git a/test/hyperfiddle/electric_compiler_test.cljc b/test/hyperfiddle/electric_compiler_test.cljc index 74e4da107..294305d26 100644 --- a/test/hyperfiddle/electric_compiler_test.cljc +++ b/test/hyperfiddle/electric_compiler_test.cljc @@ -117,6 +117,21 @@ (r/ap (r/lookup ~'frame ::i/fixed) (r/ap (r/lookup ~'frame ::m/watch) (r/pure ~'!x))))))]) + + (match (l/compile ::Main (prn (::lang/site :client 1))) + `[(r/cdef 0 [] [] nil + (fn [~'frame] + (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure clojure.core/prn)) + (r/pure 1))))]) + + #_(let [!x (atom 0)] + (match (l/compile ::Main (::lang/site :server (::lang/join (i/fixed (m/watch !x))))) + `[(r/cdef 0 [] [] :server + (fn [~'frame] + (r/join + (r/ap (r/lookup ~'frame ::i/fixed) + (r/ap (r/lookup ~'frame ::m/watch) + (r/pure ~'!x))))))])) ) ;; TODO rewrite or remove From f67f10476f2460fb8a4de7c6262e0281ab5c1941 Mon Sep 17 00:00:00 2001 From: xificurC Date: Fri, 19 Jan 2024 15:58:28 +0100 Subject: [PATCH 041/428] cleanup, simplify env injection into compiler test --- src/hyperfiddle/electric_local_def_de.cljc | 8 +--- test/hyperfiddle/electric_compiler_test.cljc | 42 ++++++++------------ 2 files changed, 17 insertions(+), 33 deletions(-) diff --git a/src/hyperfiddle/electric_local_def_de.cljc b/src/hyperfiddle/electric_local_def_de.cljc index 9a85b9053..a4713a102 100644 --- a/src/hyperfiddle/electric_local_def_de.cljc +++ b/src/hyperfiddle/electric_local_def_de.cljc @@ -28,10 +28,4 @@ (let [env (merge &env (->local-config &env) {::lang/me :server})] `(:source (lang/compile '~form ~env)))) -(defmacro compile - ([nm form] `(compile ~nm identity ~form)) - ([nm env-fn form] `(lang/compile ~nm '~form (~env-fn '~(merge web-config (lang/normalize-env &env)))))) - -(defmacro compile-as-if-client - ([nm form] `(compile-as-if-client ~nm identity ~form)) - ([nm env-fn form] `(lang/compile ~nm '~form (~env-fn '~(merge web-config (lang/->cljs-env)))))) +#?(:clj (defmacro test-compile [nm env form] `(lang/compile ~nm '~form (merge web-config (lang/normalize-env ~env))))) diff --git a/test/hyperfiddle/electric_compiler_test.cljc b/test/hyperfiddle/electric_compiler_test.cljc index 294305d26..08f7b103c 100644 --- a/test/hyperfiddle/electric_compiler_test.cljc +++ b/test/hyperfiddle/electric_compiler_test.cljc @@ -33,52 +33,52 @@ match#)) (tests - (match (l/compile ::Main 1) + (match (l/test-compile ::Main 1) `[(r/cdef 0 [] [] nil (fn [~'frame] (r/pure 1)))]) - (match (l/compile ::Main (::lang/site :client "Hello world")) + (match (l/test-compile ::Main (::lang/site :client "Hello world")) `[(r/cdef 0 [] [] :client (fn [~'frame] (r/pure "Hello world")))]) - (match (l/compile ::Main (::lang/site :client (prn "Hello world"))) + (match (l/test-compile ::Main (::lang/site :client (prn "Hello world"))) `[(r/cdef 0 [] [] :client (fn [~'frame] (r/ap (r/lookup ~'frame :clojure.core/prn) (r/pure "Hello world"))))]) - (match (l/compile ::Main (::lang/site :client (undefined?))) + (match (l/test-compile ::Main (::lang/site :client (undefined?))) `[(r/cdef 0 [] [] :client (fn [~'frame] (r/ap (r/lookup ~'frame :cljs.core/undefined?))))]) - (match (l/compile-as-if-client ::Main (::lang/site :client (undefined?))) + (match (l/test-compile ::Main (lang/->cljs-env) (::lang/site :client (undefined?))) `[(r/cdef 0 [] [] :client (fn [~'frame] (r/ap (r/lookup ~'frame :cljs.core/undefined? (r/pure cljs.core/undefined?)))))]) ;; TODO return site is :server - (l/compile ::Main (::lang/site :server (let [x 1] (::lang/site :client x)))) + (l/test-compile ::Main (::lang/site :server (let [x 1] (::lang/site :client x)))) - (let [ex (try (l/compile ::Main cannot-be-unsited) (catch ExceptionInfo e e))] + (let [ex (try (l/test-compile ::Main cannot-be-unsited) (catch ExceptionInfo e e))] (ex-message ex) := "Unsited symbol `cannot-be-unsited` resolves to different vars on different peers. Please resolve ambiguity by siting the expression using it.") - (match (l/compile ::Main (::lang/site :client (let [a :foo] [a a]))) + (match (l/test-compile ::Main (::lang/site :client (let [a :foo] [a a]))) `[(r/cdef 0 [:client] [] :client (fn [~'frame] (r/define-node ~'frame 0 (r/pure :foo)) (r/ap (r/lookup ~'frame :clojure.core/vector) (r/node ~'frame 0) (r/node ~'frame 0))))]) - (match (l/compile ::Main (let [a :foo] [a a])) + (match (l/test-compile ::Main (let [a :foo] [a a])) `[(r/cdef 0 [nil] [] nil (fn [~'frame] (r/define-node ~'frame 0 (r/pure :foo)) (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure vector)) (r/node ~'frame 0) (r/node ~'frame 0))))]) - (match (l/compile ::Main (let [a (let [b :foo] [b b])] [a a])) + (match (l/test-compile ::Main (let [a (let [b :foo] [b b])] [a a])) `[(r/cdef 0 [nil nil] [] nil (fn [~'frame] (r/define-node ~'frame 0 (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure vector)) @@ -87,30 +87,29 @@ (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure vector)) (r/node ~'frame 0) (r/node ~'frame 0))))]) - (match (l/compile ::Main (let [a 1] a)) + (match (l/test-compile ::Main (let [a 1] a)) `[(r/cdef 0 [] [] nil (fn [~'frame] (r/pure 1)))]) - (match (l/compile ::Main (::lang/site :client (let [a 1] (::lang/site :server (prn a))))) + (match (l/test-compile ::Main (::lang/site :client (let [a 1] (::lang/site :server (prn a))))) `[(r/cdef 0 [:client] [] :server (fn [~'frame] (r/define-node ~'frame 0 (r/pure 1)) (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure clojure.core/prn)) (r/node ~'frame 0))))]) - (match (l/compile ::Main (::lang/site :client (let [x "Hello", y "world"] [x y]))) + (match (l/test-compile ::Main (::lang/site :client (let [x "Hello", y "world"] [x y]))) `[(r/cdef 0 [] [] :client (fn [~'frame] (r/ap (r/lookup ~'frame :clojure.core/vector) (r/pure "Hello") (r/pure "world"))))]) - (match (l/compile ::Main (::lang/site :client (let [a (::lang/site :server :foo)] (::lang/site :server (prn a))))) + (match (l/test-compile ::Main (::lang/site :client (let [a (::lang/site :server :foo)] (::lang/site :server (prn a))))) `[(r/cdef 0 [] [] :server (clojure.core/fn [~'frame] (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure clojure.core/prn)) (r/pure :foo))))]) - (match (l/compile ::Main #(update % :locals assoc '!x (atom 0)) - (::lang/site :client (::lang/join (i/fixed (m/watch !x))))) + (match (l/test-compile ::Main {'!x (atom 0)} (::lang/site :client (::lang/join (i/fixed (m/watch !x))))) `[(r/cdef 0 [] [] :client (fn [~'frame] (r/join @@ -118,20 +117,11 @@ (r/ap (r/lookup ~'frame ::m/watch) (r/pure ~'!x))))))]) - (match (l/compile ::Main (prn (::lang/site :client 1))) + (match (l/test-compile ::Main (prn (::lang/site :client 1))) `[(r/cdef 0 [] [] nil (fn [~'frame] (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure clojure.core/prn)) (r/pure 1))))]) - - #_(let [!x (atom 0)] - (match (l/compile ::Main (::lang/site :server (::lang/join (i/fixed (m/watch !x))))) - `[(r/cdef 0 [] [] :server - (fn [~'frame] - (r/join - (r/ap (r/lookup ~'frame ::i/fixed) - (r/ap (r/lookup ~'frame ::m/watch) - (r/pure ~'!x))))))])) ) ;; TODO rewrite or remove From cf26fffac17d3ee9d274f7d60b659abf92e23584 Mon Sep 17 00:00:00 2001 From: xificurC Date: Fri, 19 Jan 2024 16:38:04 +0100 Subject: [PATCH 042/428] compiler: improve site deduction --- src/hyperfiddle/electric/impl/lang_de2.clj | 30 +++++++++++++++----- test/hyperfiddle/electric_compiler_test.cljc | 5 ++-- 2 files changed, 26 insertions(+), 9 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index fd3f45e22..01ada8675 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -458,10 +458,29 @@ {:db/id e, ::parent pe, ::type ::var, ::var form, ::qualified-var (untwin (:name v))} {:db/id e, ::parent pe, ::type ::static, ::v form}))) +(defn ->let-val-e [ts e] (first (get-children-e ts e))) +(defn ->let-body-e [ts e] (second (get-children-e ts e))) + +(defn get-ret-e [ts e] + (let [nd (get (:eav ts) e)] + (case (::type nd) + ::let (recur ts (->let-body-e ts e)) + ::site (recur ts (get-child-e ts e)) + #_else e))) + +(defn find-sitable-parent [ts e] + (when-some [pe (::parent (get (:eav ts) e))] + (case (::type (get (:eav ts) pe)) + ::site (recur ts pe) + #_else pe))) + (defn get-site [ts e] (loop [e e] - (and e - (let [nd (get (:eav ts) e)] (if (= ::site (::type nd)) (::site nd) (recur (::parent nd))))))) + (when-some [nd (get (:eav ts) e)] + (case (::type nd) + ::let-ref (recur (->> nd ::ref (->let-val-e ts) (get-ret-e ts))) + ::site (::site nd) + #_else (recur (::parent nd)))))) (defn analyze [form pe {{::keys [env ->id]} :o :as ts}] (cond @@ -539,9 +558,6 @@ (defn ->->id [] (let [!i (long-array [-1])] (fn [] (aset !i 0 (unchecked-inc (aget !i 0)))))) -(defn ->let-val-e [ts e] (first (get-children-e ts e))) -(defn ->let-body-e [ts e] (second (get-children-e ts e))) - (defn compile ([nm form env] (ensure-cljs-compiler @@ -577,8 +593,8 @@ ::join ts ::let-ref (recur (if-some [used (::used (get (:eav ts) (::ref nd)))] (if (or (> (count used) 1) - (not= (get-site ts e) - (get-site ts (get-ret-e ts (->let-val-e ts (::ref nd)))))) + (not= (get-site ts (find-sitable-parent ts e)) + (get-site ts (->> nd ::ref (->let-val-e ts) (get-ret-e ts))))) (ts/upd ts (::ref nd) ::refidx #(or % (->ref-id))) ts) ts) diff --git a/test/hyperfiddle/electric_compiler_test.cljc b/test/hyperfiddle/electric_compiler_test.cljc index 08f7b103c..c45898379 100644 --- a/test/hyperfiddle/electric_compiler_test.cljc +++ b/test/hyperfiddle/electric_compiler_test.cljc @@ -58,8 +58,9 @@ (fn [~'frame] (r/ap (r/lookup ~'frame :cljs.core/undefined? (r/pure cljs.core/undefined?)))))]) - ;; TODO return site is :server - (l/test-compile ::Main (::lang/site :server (let [x 1] (::lang/site :client x)))) + (match (l/test-compile ::Main (::lang/site :server (let [x 1] (::lang/site :client x)))) + `[(r/cdef 0 [] [] :server + (fn [~'frame] (r/pure 1)))]) (let [ex (try (l/test-compile ::Main cannot-be-unsited) (catch ExceptionInfo e e))] (ex-message ex) := "Unsited symbol `cannot-be-unsited` resolves to different vars on different peers. Please resolve ambiguity by siting the expression using it.") From d14b843afcf412c6ba3680d25cf0803388dde905 Mon Sep 17 00:00:00 2001 From: xificurC Date: Fri, 19 Jan 2024 16:58:48 +0100 Subject: [PATCH 043/428] compiler: pure --- src/hyperfiddle/electric/impl/lang_de2.clj | 7 +++++-- test/hyperfiddle/electric_compiler_test.cljc | 22 +++++--------------- 2 files changed, 10 insertions(+), 19 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 01ada8675..e57ea749b 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -577,7 +577,8 @@ ::ap (reduce count-nodes ts (get-children-e ts e)) ::site (recur ts (get-child-e ts e)) ::var ts - ::join ts + ::join (recur ts (get-child-e ts e)) + ::pure (recur ts (get-child-e ts e)) ::let-ref (let [used (::used (get (:eav ts) (::ref nd)))] (cond-> (ts/upd ts (::ref nd) ::used #(conj (or % #{}) e)) @@ -590,7 +591,8 @@ ::ap (reduce index-nodes ts (get-children-e ts e)) ::site (recur ts (get-child-e ts e)) ::var ts - ::join ts + ::join (recur ts (get-child-e ts e)) + ::pure (recur ts (get-child-e ts e)) ::let-ref (recur (if-some [used (::used (get (:eav ts) (::ref nd)))] (if (or (> (count used) 1) (not= (get-site ts (find-sitable-parent ts e)) @@ -611,6 +613,7 @@ (list `r/lookup 'frame (keyword (::qualified-var nd)) (list `r/pure (::qualified-var nd))) (list `r/lookup 'frame (keyword (::qualified-var nd))))) ::join (list `r/join (gen ts (get-child-e ts e))) + ::pure (list `r/pure (gen ts (get-child-e ts e))) ::site (recur ts (get-child-e ts e)) ::let (recur ts (get-ret-e ts (->let-body-e ts e))) ::let-ref (if-some [idx (::refidx (get (:eav ts) (::ref nd)))] diff --git a/test/hyperfiddle/electric_compiler_test.cljc b/test/hyperfiddle/electric_compiler_test.cljc index c45898379..a75740c30 100644 --- a/test/hyperfiddle/electric_compiler_test.cljc +++ b/test/hyperfiddle/electric_compiler_test.cljc @@ -123,6 +123,11 @@ (fn [~'frame] (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure clojure.core/prn)) (r/pure 1))))]) + + (match (l/test-compile ::Main (::lang/site :client (::lang/pure :foo))) + `[(r/cdef 0 [] [] :client + (fn [~'frame] + (r/pure (r/pure :foo))))]) ) ;; TODO rewrite or remove @@ -428,23 +433,6 @@ ;; * the result site (comment - ;; (def !x (atom 0)) - ;; join (e/watch !x) - ;; (i/fixed continuous-flow) -> incremental sequence of 1 element - (l/compile ::Main `(e/client (e/join (i/fixed (m/watch !x))))) - := `[(r/cdef 0 [] [] :client - (fn [frame] - (r/join - (r/ap (r/lookup frame ::i/fixed (r/pure i/fixed)) - (r/ap (r/lookup frame ::m/watch (r/pure m/watch)) - (r/lookup frame ::!x (r/pure !x)))))))] - - ;; pure (get the incseq of an expression) (e/pure (e/join x)) is (e/join (e/pure x)) is x - (l/compile ::Main `(e/client (e/pure :foo))) - := `[(r/cdef 0 [] [] :client - (fn [frame] - (r/pure (r/pure :foo))))] - ;; ctor (e/fn [] foo) -> (e/ctor foo) (previously ::c/closure) (l/compile ::Main `(e/client (e/ctor :foo))) := `[(r/cdef 0 [] [] :client From 148767488c088dd2445f05068cbc19959eb599b5 Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 23 Jan 2024 09:37:38 +0100 Subject: [PATCH 044/428] compiler: ctor --- src/contrib/triple_store.clj | 12 +- src/hyperfiddle/electric/impl/lang_de2.clj | 177 ++++++++----- src/hyperfiddle/electric_local_def_de.cljc | 4 +- test/contrib/triple_store_test.clj | 2 + test/hyperfiddle/electric_compiler_test.cljc | 250 ++++++++++--------- 5 files changed, 263 insertions(+), 182 deletions(-) diff --git a/src/contrib/triple_store.clj b/src/contrib/triple_store.clj index 9ea964098..725885db5 100644 --- a/src/contrib/triple_store.clj +++ b/src/contrib/triple_store.clj @@ -1,5 +1,7 @@ (ns contrib.triple-store - (:require [dom-top.core :refer [loopr]])) + (:refer-clojure :exclude [find]) + (:require [dom-top.core :refer [loopr]] + [clojure.set :as set])) ;; ts - triple store ;; e - entity (id of entity) @@ -54,3 +56,11 @@ [a v] av] (recur (conj! datoms [e a v])) (persistent! datoms))) + +;;;;;;;;;;;;;;; +;;; HELPERS ;;; +;;;;;;;;;;;;;;; + +(defn ->node [ts e] (get (:eav ts) e)) +(defn find [ts & kvs] + (reduce set/intersection (into [] (comp (partition-all 2) (map (fn [[k v]] (-> ts :ave (get k) (get v))))) kvs))) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index e57ea749b..8fa78058d 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -6,6 +6,7 @@ [clojure.string :as str] [contrib.assert :as ca] [contrib.debug] + [clojure.set :as set] [contrib.triple-store :as ts] [dom-top.core :refer [loopr]] [hyperfiddle.electric :as-alias e] @@ -558,75 +559,129 @@ (defn ->->id [] (let [!i (long-array [-1])] (fn [] (aset !i 0 (unchecked-inc (aget !i 0)))))) +(defn find-ctor-e [ts e] + (let [pe (::parent (get (:eav ts) e))] + (if (or (nil? pe) (= ::ctor (::type (get (:eav ts) pe)))) pe (recur ts pe)))) + (defn compile ([nm form env] (ensure-cljs-compiler - (let [{{::keys [env ->id]} :o :as ts} (analyze (expand-all env form) '_ (ts/->ts {::->id (->->id), ::env (ensure-cljs-env env)})) - get-ret-e (fn [ts e] - (let [nd (get (:eav ts) e)] - (case (::type nd) - ::let (recur ts (->let-body-e ts e)) - ::site (recur ts (get-child-e ts e)) - #_else e))) - ret-e (get-ret-e ts (get-root-e ts)) - ->ref-id (->->id) - count-nodes (fn count-nodes [ts e] - (let [nd (get (:eav ts) e)] - (case (::type nd) - ::static ts - ::ap (reduce count-nodes ts (get-children-e ts e)) - ::site (recur ts (get-child-e ts e)) - ::var ts - ::join (recur ts (get-child-e ts e)) - ::pure (recur ts (get-child-e ts e)) - ::let-ref - (let [used (::used (get (:eav ts) (::ref nd)))] - (cond-> (ts/upd ts (::ref nd) ::used #(conj (or % #{}) e)) - (nil? used) (recur (get-ret-e ts (->let-val-e ts (::ref nd)))))) - #_else (throw (ex-info (str "cannot count-nodes on " (::type nd)) (or nd {})))))) - index-nodes (fn index-nodes [ts e] - (let [nd (get (:eav ts) e)] - (case (::type nd) - ::static ts - ::ap (reduce index-nodes ts (get-children-e ts e)) - ::site (recur ts (get-child-e ts e)) - ::var ts - ::join (recur ts (get-child-e ts e)) - ::pure (recur ts (get-child-e ts e)) - ::let-ref (recur (if-some [used (::used (get (:eav ts) (::ref nd)))] - (if (or (> (count used) 1) - (not= (get-site ts (find-sitable-parent ts e)) - (get-site ts (->> nd ::ref (->let-val-e ts) (get-ret-e ts))))) - (ts/upd ts (::ref nd) ::refidx #(or % (->ref-id))) - ts) - ts) - (get-ret-e ts (->let-val-e ts (::ref nd)))) - #_else (throw (ex-info (str "cannot index-nodes on " (::type nd)) (or nd {})))))) - ts (-> ts (count-nodes ret-e) (index-nodes ret-e)) - gen (fn gen [ts e] + (let [->id (->->id), ->ctor-idx (->->id) + ts (analyze (expand-all env form) 0 (ts/add (ts/->ts {::->id ->id, ::env (ensure-cljs-env env)}) + {:db/id (->id), ::type ::ctor, ::parent '_})) + mark-used-ctors (fn mark-used-ctors [ts e] + (let [nd (get (:eav ts) e)] + (case (::type nd) + (::static ::var) ts + (::ap) (reduce mark-used-ctors ts (get-children-e ts e)) + (::site ::join ::pure) (recur ts (get-child-e ts e)) + (::ctor) (recur (ts/asc ts e ::ctor-idx (->ctor-idx)) (get-child-e ts e)) + (::let) (recur ts (->let-body-e ts e)) + (::let-ref) (recur ts (get-ret-e ts (->let-val-e ts (::ref nd)))) + #_else (throw (ex-info (str "cannot mark-used-ctors on " (pr-str (::type nd))) (or nd {})))))) + ts (mark-used-ctors ts 0) + ctors-e (reduce into (-> ts :ave ::ctor-idx vals)) + ->node-idx (let [mp (zipmap ctors-e (repeatedly ->->id))] + (fn ->node-idx [ctor-e] ((get mp ctor-e)))) + ->free-idx (let [mp (zipmap ctors-e (repeatedly ->->id))] + (fn ->free-idx [ctor-e] ((get mp ctor-e)))) + ensure-node (fn ensure-node [ts ref-e] + (let [ctor-e (find-ctor-e ts ref-e)] + (cond-> ts (-> ts :ave ::ctor-ref (get ref-e) empty?) + (ts/add {:db/id (->id), ::node-idx (->node-idx ctor-e) + ::ctor-node ctor-e, ::ctor-ref ref-e})))) + ->node-idx (fn ->node-idx [ts ctor-e ref-e] + (::node-idx (get (:eav ts) + (first (set/intersection (-> ts :ave ::ctor-node (get ctor-e)) + (-> ts :ave ::ctor-ref (get ref-e))))))) + ensure-free-node (fn ensure-free-node [ts ref-e ctor-e] + (cond-> ts (empty? (set/intersection (-> ts :ave ::ctor-free (get ctor-e)) + (-> ts :ave ::closed-ref (get ref-e)))) + (ts/add {:db/id (->id), ::free-idx (->free-idx ctor-e) ::ctor-free ctor-e + ::closed-ref ref-e, ::closed-over ::node}))) + ensure-free-free (fn ensure-free-free [ts ref-e ctor-e] + (cond-> ts (empty? (set/intersection (-> ts :ave ::ctor-free (get ctor-e)) + (-> ts :ave ::closed-ref (get ref-e)))) + (ts/add {:db/id (->id), ::free-idx (->free-idx ctor-e) ::ctor-free ctor-e + ::closed-ref ref-e, ::closed-over ::free}))) + ensure-free-frees (fn ensure-free-frees [ts ref-e ctors-e] + (reduce (fn [ts ctor-e] (ensure-free-free ts ref-e ctor-e)) ts ctors-e)) + handle-let-refs (fn handle-let-refs [ts e] ; nodes and frees (closed over) + (let [nd (get (:eav ts) e)] + (case (::type nd) + (::static ::var) ts + (::ap) (reduce handle-let-refs ts (get-children-e ts e)) + (::site ::join ::pure ::ctor) (recur ts (get-child-e ts e)) + (::let) (recur ts (->let-body-e ts e)) + (::let-ref) + (let [ref-nd (get (:eav ts) (::ref nd)) + ctors-e (loop [ac '(), e (::parent (get (:eav ts) e))] + (if (= (::ref nd) e) + ac + (recur (cond-> ac (= ::ctor (::type (get (:eav ts) e))) (conj e)) + (::parent (get (:eav ts) e))))) + ts (ts/asc ts (::ref nd) ::walked-val true) ; only walk binding once + ts (if (seq ctors-e) ; closed over + (-> ts (ensure-node (::ref nd)) + (ensure-free-node (::ref nd) (first ctors-e)) + (ensure-free-frees (::ref nd) (rest ctors-e))) + (cond-> (ts/upd ts (::ref nd) ::refcnt (fnil inc 0)) + (or (= 1 (::refcnt ref-nd)) + (not= (get-site ts (find-sitable-parent ts e)) + (get-site ts (->let-val-e ts (::ref nd))))) + (ensure-node (::ref nd))))] + (cond-> ts + (not (::walked-val ref-nd)) (recur (get-ret-e ts (->let-val-e ts (::ref nd)))))) + #_else (throw (ex-info (str "cannot handle-let-refs on " (::type nd)) (or nd {})))))) + ts (-> ts (handle-let-refs 0)) + gen (fn gen [ts ctor-e e] (let [nd (get (:eav ts) e)] (case (::type nd) ::static (list `r/pure (::v nd)) - ::ap (list* `r/ap (mapv #(gen ts %) (get-children-e ts e))) + ::ap (list* `r/ap (mapv #(gen ts ctor-e %) (get-children-e ts e))) ::var (let [in (::resolved-in nd)] (if (or (nil? in) (= in (->env-type env))) (list `r/lookup 'frame (keyword (::qualified-var nd)) (list `r/pure (::qualified-var nd))) (list `r/lookup 'frame (keyword (::qualified-var nd))))) - ::join (list `r/join (gen ts (get-child-e ts e))) - ::pure (list `r/pure (gen ts (get-child-e ts e))) - ::site (recur ts (get-child-e ts e)) - ::let (recur ts (get-ret-e ts (->let-body-e ts e))) - ::let-ref (if-some [idx (::refidx (get (:eav ts) (::ref nd)))] - (list `r/node 'frame idx) - (gen ts (get-ret-e ts (->let-val-e ts (::ref nd))))) - #_else (throw (ex-info (str "cannot gen on " (::type nd)) (or nd {})))))) - nodes (mapv (fn [[idx es]] [idx (first es)]) (sort-by first (::refidx (:ave ts)))) - gen-node-init (fn gen-node-init [ts] - (mapv (fn [[idx e]] (list `r/define-node 'frame idx - (gen ts (get-ret-e ts (->let-val-e ts e))))) - nodes)) - ] + ::join (list `r/join (gen ts ctor-e (get-child-e ts e))) + ::pure (list `r/pure (gen ts ctor-e (get-child-e ts e))) + ::site (recur ts ctor-e (get-child-e ts e)) + ::ctor (list `r/pure + (let [ctor (list `r/make-ctor 'frame nm (::ctor-idx nd)) + frees-e (-> ts :ave ::ctor-free (get e))] + (if (seq frees-e) + (list* `doto ctor + (mapv (fn [e] + (let [nd (ts/->node ts e)] + (list `r/define-free (::free-idx nd) + (case (::closed-over nd) + ::node (list `r/node 'frame (->node-idx ts (find-ctor-e ts (::ctor-free nd)) (::closed-ref nd))) + ::free (list `r/free 'frame (->> (ts/find ts ::ctor-free (find-ctor-e ts (::ctor-free nd)) + ::closed-ref (::closed-ref nd)) + first (ts/->node ts) ::free-idx)))))) + frees-e)) + ctor))) + ::let (recur ts ctor-e (get-ret-e ts (->let-body-e ts e))) + ::let-ref + (if-some [node-e (first (ts/find ts ::ctor-node ctor-e, ::ctor-ref (::ref nd)))] + (list `r/node 'frame (::node-idx (get (:eav ts) node-e))) + (if-some [free-e (first (ts/find ts ::ctor-free ctor-e))] + (list `r/free 'frame (::free-idx (ts/->node ts free-e))) + (recur ts ctor-e (get-ret-e ts (->let-val-e ts (::ref nd)))))) + #_else (throw (ex-info (str "cannot gen on " (pr-str (::type nd))) (or nd {})))))) + get-ctor-nodes-e (fn get-ctor-nodes-e [ts ctor-e] + (->> (-> ts :ave ::ctor-node (get ctor-e)) + (filterv #(::node-idx (get (:eav ts) %))))) + gen-node-init (fn gen-node-init [ts ctor-e node-e] + (let [nd (get (:eav ts) node-e)] + (list `r/define-node 'frame (::node-idx nd) + (gen ts ctor-e (get-ret-e ts (->let-val-e ts (::ctor-ref nd)))))))] ;; (run! prn (->> ts :eav vals (sort-by :db/id))) - `[(r/cdef 0 ~(mapv #(get-site ts (get-ret-e ts (->let-val-e ts (second %)))) nodes) [] ~(get-site ts ret-e) - (fn [~'frame] ~@(gen-node-init ts) ~(gen ts ret-e)))] - )))) + (->> ctors-e + (mapv (fn [ctor-e] + (let [ret-e (get-ret-e ts (get-child-e ts ctor-e)), nodes-e (get-ctor-nodes-e ts ctor-e)] + `(r/cdef ~(count (ts/find ts ::ctor-free ctor-e)) + ~(mapv #(get-site ts (->> (get (:eav ts) %) ::ctor-ref (->let-val-e ts) (get-ret-e ts))) + nodes-e) + [] ~(get-site ts ret-e) + (fn [~'frame] ~@(mapv #(gen-node-init ts ctor-e %) nodes-e) ~(gen ts ctor-e ret-e))))))))))) diff --git a/src/hyperfiddle/electric_local_def_de.cljc b/src/hyperfiddle/electric_local_def_de.cljc index a4713a102..34f821209 100644 --- a/src/hyperfiddle/electric_local_def_de.cljc +++ b/src/hyperfiddle/electric_local_def_de.cljc @@ -28,4 +28,6 @@ (let [env (merge &env (->local-config &env) {::lang/me :server})] `(:source (lang/compile '~form ~env)))) -#?(:clj (defmacro test-compile [nm env form] `(lang/compile ~nm '~form (merge web-config (lang/normalize-env ~env))))) +#?(:clj (defmacro test-compile + ([nm form] `(test-compile ~nm {} ~form)) + ([nm env form] `(lang/compile ~nm '~form (merge web-config (lang/normalize-env ~env)))))) diff --git a/test/contrib/triple_store_test.clj b/test/contrib/triple_store_test.clj index dbceabdf6..a13aeebfc 100644 --- a/test/contrib/triple_store_test.clj +++ b/test/contrib/triple_store_test.clj @@ -11,4 +11,6 @@ (-> (ts/->ts) (ts/add {:db/id '_}) (ts/upd '_ :x (fnil inc 0)) (ts/upd '_ :x (fnil inc 0)) (ts/get-entity '_) :x) := 2 (-> (ts/->ts) (ts/add {:db/id 1}) (ts/asc 1 :x 2) (ts/asc 1 :x 2) :ave :x (get 2)) := #{1} + + (-> (ts/->ts) (ts/add {:db/id 1, :foo 1, :bar 1}) (ts/add {:db/id 2, :foo 1, :bar 1}) (ts/find :foo 1 :bar 1)) := #{1 2} ) diff --git a/test/hyperfiddle/electric_compiler_test.cljc b/test/hyperfiddle/electric_compiler_test.cljc index a75740c30..40ed6fdb3 100644 --- a/test/hyperfiddle/electric_compiler_test.cljc +++ b/test/hyperfiddle/electric_compiler_test.cljc @@ -82,11 +82,11 @@ (match (l/test-compile ::Main (let [a (let [b :foo] [b b])] [a a])) `[(r/cdef 0 [nil nil] [] nil (fn [~'frame] - (r/define-node ~'frame 0 (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure vector)) - (r/node ~'frame 1) (r/node ~'frame 1))) - (r/define-node ~'frame 1 (r/pure :foo)) + (r/define-node ~'frame 0 (r/pure :foo)) + (r/define-node ~'frame 1 (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure vector)) + (r/node ~'frame 0) (r/node ~'frame 0))) (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure vector)) - (r/node ~'frame 0) (r/node ~'frame 0))))]) + (r/node ~'frame 1) (r/node ~'frame 1))))]) (match (l/test-compile ::Main (let [a 1] a)) `[(r/cdef 0 [] [] nil (fn [~'frame] (r/pure 1)))]) @@ -128,122 +128,143 @@ `[(r/cdef 0 [] [] :client (fn [~'frame] (r/pure (r/pure :foo))))]) - ) -;; TODO rewrite or remove -(comment - (l/compile-client 1) := `(r/peer (lang/r-defs (lang/r-static 1)) [] 0) - (l/compile-server 1) := `(r/peer (lang/r-defs (lang/r-static 1)) [] 0) - - (l/compile-server (prn "hello world")) := `(r/peer (lang/r-defs (lang/r-ap (lang/r-static ~'prn) (lang/r-static "hello world"))) [] 0) - (l/compile-client (let [x "Hello world", y "Hello world"] [x y])) - := `(r/peer (lang/r-defs - (lang/r-static "Hello world") - (lang/r-static "Hello world") - (lang/r-ap (lang/r-static vector) (lang/r-local 0) (lang/r-local 1))) [] 2) - - (l/compile-client (concat (let [x 1] [x x]) (let [y 2] [y y]))) - := `(r/peer (lang/r-defs - (lang/r-static 1) - (lang/r-static 2) - (lang/r-ap (lang/r-static ~'concat) - (lang/r-ap (lang/r-static vector) (lang/r-local 0) (lang/r-local 0)) - (lang/r-ap (lang/r-static vector) (lang/r-local 1) (lang/r-local 1)))) [] 2) - - (l/compile-client (i/fixed (m/watch (atom 0)))) - := `(r/peer (lang/r-defs - (lang/r-ap (lang/r-static ~'i/fixed) - (lang/r-ap (lang/r-static ~'m/watch) - (lang/r-ap (lang/r-static ~'atom) - (lang/r-static 0))))) [] 0) - - (l/compile-client (::lang/ctor :foo)) - := `(r/peer - (lang/r-defs - (lang/r-static :foo) - (lang/r-ctor [] 0)) - [] 1) + (match (l/test-compile ::Main (concat (let [x 1] [x x]) (let [y 2] [y y]))) + `[(r/cdef 0 [nil nil] [] nil + (fn [~'frame] + (r/define-node ~'frame 0 (r/pure 1)) + (r/define-node ~'frame 1 (r/pure 2)) + (r/ap (r/lookup ~'frame :clojure.core/concat (r/pure clojure.core/concat)) + (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure clojure.core/vector)) + (r/node ~'frame 0) + (r/node ~'frame 0)) + (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure clojure.core/vector)) + (r/node ~'frame 1) + (r/node ~'frame 1)))))] + ) + + (match (l/test-compile ::Main (::lang/ctor :foo)) + `[(r/cdef 0 [] [] nil + (fn [~'frame] + (r/pure (r/make-ctor ~'frame ::Main 1)))) + (r/cdef 0 [] [] nil + (fn [~'frame] + (r/pure :foo)))]) - (l/compile-client (let [a 1] (::lang/ctor a))) - := `(r/peer - (lang/r-defs - (lang/r-static 1) - (lang/r-free 0) - (lang/r-ctor [] 1 (lang/r-local 0))) - [] 2) + (match (l/test-compile ::Main (let [a 1] (::lang/ctor a))) + `[(r/cdef 0 [nil] [] nil + (fn [~'frame] + (r/define-node ~'frame 0 (r/pure 1)) + (r/pure (doto (r/make-ctor ~'frame ::Main 1) + (r/define-free 0 (r/node ~'frame 0)))))) + (r/cdef 1 [] [] nil + (fn [~'frame] + (r/free ~'frame 0)))]) - (l/compile-client (let [a 1] (::lang/ctor (let [a 2] a)))) - := `(r/peer - (lang/r-defs - (lang/r-static 2) - (lang/r-ctor [] 0)) - [] 1) + (match (l/test-compile ::Main (let [a 1] (::lang/ctor (let [a 2] a)))) + `[(r/cdef 0 [] [] nil + (fn [~'frame] + (r/pure (r/make-ctor ~'frame ::Main 1)))) + (r/cdef 0 [] [] nil + (fn [~'frame] + (r/pure 2)))]) - (l/compile-client (let [a 1] (::lang/ctor (::lang/ctor a)))) - := `(r/peer - (lang/r-defs - (lang/r-static 1) - (lang/r-free 0) - (lang/r-ctor [] 1 (lang/r-free 0)) - (lang/r-ctor [] 2 (lang/r-local 0))) - [] 3) + (match (l/test-compile ::Main (let [a 1] (::lang/ctor (::lang/ctor a)))) + `[(r/cdef 0 [nil] [] nil + (fn [~'frame] + (r/define-node ~'frame 0 (r/pure 1)) + (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 1) + (r/define-free 0 (r/node ~'frame 0)))))) + (r/cdef 1 [] [] nil + (fn [~'frame] + (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 2) + (r/define-free 0 (r/free ~'frame 0)))))) + (r/cdef 1 [] [] nil + (fn [~'frame] + (r/free ~'frame 0)))]) - (l/compile-client (let [a 1] (::lang/ctor [a (let [a 2] (::lang/ctor a))]))) - := `(r/peer - (lang/r-defs - (lang/r-static 1) - (lang/r-static 2) - (lang/r-free 0) - (lang/r-ap (lang/r-static vector) - (lang/r-free 0) - (lang/r-ctor [] 2 (lang/r-local 1))) - (lang/r-ctor [] 3 (lang/r-local 0))) - [] 4) + (match (l/test-compile ::Main (let [a 1] (::lang/ctor [a (let [a 2] (::lang/ctor a))]))) + `[(r/cdef 0 [nil] [] nil + (fn [~'frame] + (r/define-node ~'frame 0 (r/pure 1)) + (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 1) + (r/define-free 0 (r/node ~'frame 0)))))) + (r/cdef 1 [nil] [] nil + (fn [~'frame] + (r/define-node ~'frame 0 (r/pure 2)) + (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure clojure.core/vector)) + (r/free ~'frame 0) + (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 2) + (r/define-free 0 (r/node ~'frame 0))))))) + (r/cdef 1 [] [] nil + (fn [~'frame] + (r/free ~'frame 0)))]) - (l/compile-client (let [a 1] (::lang/ctor (::lang/ctor (::lang/ctor a))))) - := `(r/peer - (lang/r-defs - (lang/r-static 1) - (lang/r-free 0) - (lang/r-ctor [] 1 (lang/r-free 0)) - (lang/r-ctor [] 2 (lang/r-free 0)) - (lang/r-ctor [] 3 (lang/r-local 0))) - [] 4) + (match (l/test-compile ::Main (let [a 1] (::lang/ctor (::lang/ctor (::lang/ctor a))))) + `[(r/cdef 0 [nil] [] nil + (fn [~'frame] + (r/define-node ~'frame 0 (r/pure 1)) + (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 1) + (r/define-free 0 (r/node ~'frame 0)))))) + (r/cdef 1 [] [] nil + (fn [~'frame] + (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 2) + (r/define-free 0 (r/free ~'frame 0)))))) + (r/cdef 1 [] [] nil + (fn [~'frame] + (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 3) + (r/define-free 0 (r/free ~'frame 0)))))) + (r/cdef 1 [] [] nil + (fn [~'frame] + (r/free ~'frame 0)))]) - (l/compile-client (let [a 1, b 2] (::lang/ctor [a (::lang/ctor b)]))) - := `(r/peer - (lang/r-defs - (lang/r-static 1) - (lang/r-static 2) - (lang/r-free 0) - (lang/r-ap (lang/r-static clojure.core/vector) - (lang/r-free 0) - (lang/r-ctor [] 2 (lang/r-free 1))) - (lang/r-ctor [] 3 (lang/r-local 0) (lang/r-local 1))) - [] - 4) + (match (l/test-compile ::Main (let [a 1, b 2] (::lang/ctor [a (::lang/ctor b)]))) + `[(r/cdef 0 [nil nil] [] nil + (fn [~'frame] + (r/define-node ~'frame 0 (r/pure 1)) + (r/define-node ~'frame 1 (r/pure 2)) + (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 1) + (r/define-free 0 (r/node ~'frame 0)) + (r/define-free 1 (r/node ~'frame 1)))))) + (r/cdef 2 [] [] nil + (fn [~'frame] + (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure clojure.core/vector)) + (r/free ~'frame 0) + (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 2) + (r/define-free 0 (r/free ~'frame 1))))))) + (r/cdef 1 [] [] nil + (fn [~'frame] + (r/free ~'frame 0)))]) - (l/compile-client (let [a 1, b 2] (::lang/ctor [b (::lang/ctor a)]))) - := `(r/peer - (lang/r-defs - (lang/r-static 2) - (lang/r-static 1) - (lang/r-free 0) - (lang/r-ap (lang/r-static clojure.core/vector) - (lang/r-free 1) - (lang/r-ctor [] 2 (lang/r-free 0))) - (lang/r-ctor [] 3 (lang/r-local 1) (lang/r-local 0))) - [] - 4) + (match (l/test-compile ::Main (let [a 1, b 2] (::lang/ctor [b (::lang/ctor a)]))) + `[(r/cdef 0 [nil nil] [] nil + (fn [~'frame] + (r/define-node ~'frame 0 (r/pure 2)) + (r/define-node ~'frame 1 (r/pure 1)) + (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 1) + (r/define-free 0 (r/node ~'frame 0)) + (r/define-free 1 (r/node ~'frame 1)))))) + (r/cdef 2 [] [] nil + (fn [~'frame] + (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure clojure.core/vector)) + (r/free ~'frame 0) + (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 2) + (r/define-free 0 (r/free ~'frame 1))))))) + (r/cdef 1 [] [] nil + (fn [~'frame] + (r/free ~'frame 0)))]) - (l/compile-client (let [x (::lang/ctor :foo)] x)) - := `(r/peer - (lang/r-defs - (lang/r-ctor [] 1) - (lang/r-static :foo) - (lang/r-local 0)) - [] 2) + (match (l/test-compile ::Main (let [x (::lang/ctor :foo)] x)) + `[(r/cdef 0 [] [] nil + (fn [~'frame] + (r/pure (r/make-ctor ~'frame ::Main 1)))) + (r/cdef 0 [] [] nil + (fn [~'frame] + (r/pure :foo)))]) + ) +;; TODO rewrite or remove +(comment (l/compile-client (let [x (::lang/ctor :foo), y x] (::lang/call y))) := `(r/peer (lang/r-defs @@ -433,15 +454,6 @@ ;; * the result site (comment - ;; ctor (e/fn [] foo) -> (e/ctor foo) (previously ::c/closure) - (l/compile ::Main `(e/client (e/ctor :foo))) - := `[(r/cdef 0 [] [] :client - (fn [frame] - (r/pure (r/make-ctor frame ::Main 1)))) - (r/cdef 0 [] [] nil - (fn [frame] - (r/pure :foo)))] - ;; call (aka new, but with no argument and only for ctors) (l/compile ::Main `(e/client (e/call (e/ctor :foo)))) := `[(r/cdef 0 [] [:client] :client From 20d94ffbacc7f4b2b1273448860f47644c5d12f0 Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 23 Jan 2024 17:31:43 +0100 Subject: [PATCH 045/428] compiler: call --- deps.edn | 1 + src/hyperfiddle/electric/impl/lang_de2.clj | 98 ++++-- .../impl/compiler_test.cljc} | 323 ++++++++---------- .../electric/impl/compiler_test_clj.clj | 3 + .../electric/impl/compiler_test_cljs.cljs | 3 + 5 files changed, 213 insertions(+), 215 deletions(-) rename test/hyperfiddle/{electric_compiler_test.cljc => electric/impl/compiler_test.cljc} (75%) create mode 100644 test/hyperfiddle/electric/impl/compiler_test_clj.clj create mode 100644 test/hyperfiddle/electric/impl/compiler_test_cljs.cljs diff --git a/deps.edn b/deps.edn index a35857d8b..8eed964a8 100644 --- a/deps.edn +++ b/deps.edn @@ -6,6 +6,7 @@ com.hyperfiddle/rcf {:mvn/version "20220926-202227"} missionary/missionary {:mvn/version "b.33"} dom-top/dom-top {:mvn/version "1.0.9"} + fipp/fipp {:mvn/version "0.6.26"} org.clojure/clojure {:mvn/version "1.12.0-alpha4"} org.clojure/clojurescript {:mvn/version "1.11.60"} org.clojure/tools.analyzer.jvm {:mvn/version "1.2.2"} ;; used by Electric diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 8fa78058d..0447baf35 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -574,8 +574,10 @@ (case (::type nd) (::static ::var) ts (::ap) (reduce mark-used-ctors ts (get-children-e ts e)) - (::site ::join ::pure) (recur ts (get-child-e ts e)) - (::ctor) (recur (ts/asc ts e ::ctor-idx (->ctor-idx)) (get-child-e ts e)) + (::site ::join ::pure ::call) (recur ts (get-child-e ts e)) + (::ctor) (if (::ctor-idx nd) + ts + (recur (ts/asc ts e ::ctor-idx (->ctor-idx)) (get-child-e ts e))) (::let) (recur ts (->let-body-e ts e)) (::let-ref) (recur ts (get-ret-e ts (->let-val-e ts (::ref nd)))) #_else (throw (ex-info (str "cannot mark-used-ctors on " (pr-str (::type nd))) (or nd {})))))) @@ -608,32 +610,49 @@ (reduce (fn [ts ctor-e] (ensure-free-free ts ref-e ctor-e)) ts ctors-e)) handle-let-refs (fn handle-let-refs [ts e] ; nodes and frees (closed over) (let [nd (get (:eav ts) e)] - (case (::type nd) - (::static ::var) ts - (::ap) (reduce handle-let-refs ts (get-children-e ts e)) - (::site ::join ::pure ::ctor) (recur ts (get-child-e ts e)) - (::let) (recur ts (->let-body-e ts e)) - (::let-ref) - (let [ref-nd (get (:eav ts) (::ref nd)) - ctors-e (loop [ac '(), e (::parent (get (:eav ts) e))] - (if (= (::ref nd) e) - ac - (recur (cond-> ac (= ::ctor (::type (get (:eav ts) e))) (conj e)) - (::parent (get (:eav ts) e))))) - ts (ts/asc ts (::ref nd) ::walked-val true) ; only walk binding once - ts (if (seq ctors-e) ; closed over - (-> ts (ensure-node (::ref nd)) - (ensure-free-node (::ref nd) (first ctors-e)) - (ensure-free-frees (::ref nd) (rest ctors-e))) - (cond-> (ts/upd ts (::ref nd) ::refcnt (fnil inc 0)) - (or (= 1 (::refcnt ref-nd)) - (not= (get-site ts (find-sitable-parent ts e)) - (get-site ts (->let-val-e ts (::ref nd))))) - (ensure-node (::ref nd))))] - (cond-> ts - (not (::walked-val ref-nd)) (recur (get-ret-e ts (->let-val-e ts (::ref nd)))))) - #_else (throw (ex-info (str "cannot handle-let-refs on " (::type nd)) (or nd {})))))) - ts (-> ts (handle-let-refs 0)) + (case (::type nd) + (::static ::var) ts + (::ap) (reduce handle-let-refs ts (get-children-e ts e)) + (::site ::join ::pure ::ctor ::call) (recur ts (get-child-e ts e)) + (::let) (recur ts (->let-body-e ts e)) + (::let-ref) + (let [ref-nd (get (:eav ts) (::ref nd)) + ctors-e (loop [ac '(), e (::parent (get (:eav ts) e))] + (if (= (::ref nd) e) + ac + (recur (cond-> ac (= ::ctor (::type (get (:eav ts) e))) (conj e)) + (::parent (get (:eav ts) e))))) + ts (ts/asc ts (::ref nd) ::walked-val true) ; only walk binding once + ts (if (seq ctors-e) ; closed over + (-> ts (ensure-node (::ref nd)) + (ensure-free-node (::ref nd) (first ctors-e)) + (ensure-free-frees (::ref nd) (rest ctors-e))) + (cond-> (ts/upd ts (::ref nd) ::refcnt (fnil inc 0)) + (or (= 1 (::refcnt ref-nd)) + (not= (get-site ts (find-sitable-parent ts e)) + (get-site ts (->let-val-e ts (::ref nd))))) + (ensure-node (::ref nd))))] + (cond-> ts + (not (::walked-val ref-nd)) (recur (get-ret-e ts (->let-val-e ts (::ref nd)))))) + #_else (throw (ex-info (str "cannot handle-let-refs on " (::type nd)) (or nd {})))))) + ->call-idx (let [mp (zipmap ctors-e (repeatedly ->->id))] + (fn ->call-idx [ctor-e] ((get mp ctor-e)))) + mark-used-calls (fn mark-used-calls [ts ctor-e e] + (let [nd (ts/->node ts e)] + (case (::type nd) + (::static ::var) ts + (::ap) (reduce #(mark-used-calls % ctor-e %2) ts (get-children-e ts e)) + (::site ::join ::pure) (recur ts ctor-e (get-child-e ts e)) + (::ctor) (recur ts e (get-child-e ts e)) + (::call) (if (::call-idx nd) + ts + (recur (-> ts (ts/asc e ::call-idx (->call-idx ctor-e)) + (ts/asc e ::ctor-call ctor-e)) + ctor-e (get-child-e ts e))) + (::let) (recur ts ctor-e (->let-body-e ts e)) + (::let-ref) (let [nx-e (get-ret-e ts (->let-val-e ts (::ref nd)))] + (recur ts (find-ctor-e ts nx-e) nx-e))))) + ts (-> ts (handle-let-refs 0) (mark-used-calls 0 (get-ret-e ts (get-child-e ts 0)))) gen (fn gen [ts ctor-e e] (let [nd (get (:eav ts) e)] (case (::type nd) @@ -661,6 +680,7 @@ first (ts/->node ts) ::free-idx)))))) frees-e)) ctor))) + ::call (list `r/join (list `r/call 'frame (::call-idx (ts/->node ts e)))) ::let (recur ts ctor-e (get-ret-e ts (->let-body-e ts e))) ::let-ref (if-some [node-e (first (ts/find ts ::ctor-node ctor-e, ::ctor-ref (::ref nd)))] @@ -669,19 +689,25 @@ (list `r/free 'frame (::free-idx (ts/->node ts free-e))) (recur ts ctor-e (get-ret-e ts (->let-val-e ts (::ref nd)))))) #_else (throw (ex-info (str "cannot gen on " (pr-str (::type nd))) (or nd {})))))) - get-ctor-nodes-e (fn get-ctor-nodes-e [ts ctor-e] - (->> (-> ts :ave ::ctor-node (get ctor-e)) - (filterv #(::node-idx (get (:eav ts) %))))) gen-node-init (fn gen-node-init [ts ctor-e node-e] (let [nd (get (:eav ts) node-e)] (list `r/define-node 'frame (::node-idx nd) - (gen ts ctor-e (get-ret-e ts (->let-val-e ts (::ctor-ref nd)))))))] + (gen ts ctor-e (get-ret-e ts (->let-val-e ts (::ctor-ref nd))))))) + gen-call-init (fn gen-call-init [ts ctor-e e] + (list `r/define-call 'frame (::call-idx (ts/->node ts e)) + (gen ts ctor-e (get-ret-e ts (get-child-e ts e)))))] ;; (run! prn (->> ts :eav vals (sort-by :db/id))) (->> ctors-e (mapv (fn [ctor-e] - (let [ret-e (get-ret-e ts (get-child-e ts ctor-e)), nodes-e (get-ctor-nodes-e ts ctor-e)] + (let [ret-e (get-ret-e ts (get-child-e ts ctor-e)) + nodes-e (ts/find ts ::ctor-node ctor-e) + calls-e (ts/find ts ::ctor-call ctor-e)] `(r/cdef ~(count (ts/find ts ::ctor-free ctor-e)) - ~(mapv #(get-site ts (->> (get (:eav ts) %) ::ctor-ref (->let-val-e ts) (get-ret-e ts))) + ~(mapv #(get-site ts (->> (ts/->node ts %) ::ctor-ref (->let-val-e ts) (get-ret-e ts))) nodes-e) - [] ~(get-site ts ret-e) - (fn [~'frame] ~@(mapv #(gen-node-init ts ctor-e %) nodes-e) ~(gen ts ctor-e ret-e))))))))))) + ~(mapv #(get-site ts %) calls-e) + ~(get-site ts ret-e) + (fn [~'frame] + ~@(mapv #(gen-node-init ts ctor-e %) nodes-e) + ~@(mapv #(gen-call-init ts ctor-e %) calls-e) + ~(gen ts ctor-e ret-e))))))))))) diff --git a/test/hyperfiddle/electric_compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc similarity index 75% rename from test/hyperfiddle/electric_compiler_test.cljc rename to test/hyperfiddle/electric/impl/compiler_test.cljc index 40ed6fdb3..9778db243 100644 --- a/test/hyperfiddle/electric_compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -1,12 +1,12 @@ -(ns hyperfiddle.electric-compiler-test +(ns hyperfiddle.electric.impl.compiler-test (:require [hyperfiddle.electic :as-alias e] [hyperfiddle.incseq :as i] - [hyperfiddle.rcf :as rcf :refer [tests]] [hyperfiddle.electric.impl.lang-de2 :as lang] [hyperfiddle.electric.impl.runtime-de :as r] [hyperfiddle.electric-local-def-de :as l] - #?(:clj [hyperfiddle.electric-compiler-test-clj :refer [cannot-be-unsited]] - :cljs [hyperfiddle.electric-compiler-test-cljs :refer [cannot-be-unsited]]) + #?(:clj [hyperfiddle.electric.impl.compiler-test-clj :refer [cannot-be-unsited]] + :cljs [hyperfiddle.electric.impl.compiler-test-cljs :refer [cannot-be-unsited]]) + [hyperfiddle.rcf :as rcf :refer [tests]] [contrib.test-match :as tm] [fipp.edn] [missionary.core :as m]) @@ -28,16 +28,36 @@ (defmacro match [code matcher] `(let [ret# ~code, match# (tm/test-match ret# ~matcher)] + ;; (t/is (= ret# match#)) ret# := match# (when (not= ret# match#) (fipp.edn/pprint match#)) match#)) -(tests +(tests "test-simplest" (match (l/test-compile ::Main 1) `[(r/cdef 0 [] [] nil (fn [~'frame] (r/pure 1)))]) + (match (l/test-compile ::Main (prn "Hello world")) + `[(r/cdef 0 [] [] nil + (fn [~'frame] + (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure prn)) (r/pure "Hello world"))))]) + (match (l/test-compile ::Main (prn (::lang/site :client 1))) + `[(r/cdef 0 [] [] nil + (fn [~'frame] + (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure clojure.core/prn)) + (r/pure 1))))])) + +(tests "test-join" + (match (l/test-compile ::Main {'!x (atom 0)} (::lang/join (i/fixed (m/watch !x)))) + `[(r/cdef 0 [] [] nil + (fn [~'frame] + (r/join + (r/ap (r/lookup ~'frame ::i/fixed (r/pure i/fixed)) + (r/ap (r/lookup ~'frame ::m/watch (r/pure m/watch)) + (r/pure ~'!x))))))])) +(tests "test-siting" (match (l/test-compile ::Main (::lang/site :client "Hello world")) `[(r/cdef 0 [] [] :client (fn [~'frame] @@ -63,8 +83,9 @@ (fn [~'frame] (r/pure 1)))]) (let [ex (try (l/test-compile ::Main cannot-be-unsited) (catch ExceptionInfo e e))] - (ex-message ex) := "Unsited symbol `cannot-be-unsited` resolves to different vars on different peers. Please resolve ambiguity by siting the expression using it.") + (ex-message ex) := "Unsited symbol `cannot-be-unsited` resolves to different vars on different peers. Please resolve ambiguity by siting the expression using it.")) +(tests "test-let" (match (l/test-compile ::Main (::lang/site :client (let [a :foo] [a a]))) `[(r/cdef 0 [:client] [] :client (fn [~'frame] @@ -109,26 +130,6 @@ (clojure.core/fn [~'frame] (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure clojure.core/prn)) (r/pure :foo))))]) - - (match (l/test-compile ::Main {'!x (atom 0)} (::lang/site :client (::lang/join (i/fixed (m/watch !x))))) - `[(r/cdef 0 [] [] :client - (fn [~'frame] - (r/join - (r/ap (r/lookup ~'frame ::i/fixed) - (r/ap (r/lookup ~'frame ::m/watch) - (r/pure ~'!x))))))]) - - (match (l/test-compile ::Main (prn (::lang/site :client 1))) - `[(r/cdef 0 [] [] nil - (fn [~'frame] - (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure clojure.core/prn)) - (r/pure 1))))]) - - (match (l/test-compile ::Main (::lang/site :client (::lang/pure :foo))) - `[(r/cdef 0 [] [] :client - (fn [~'frame] - (r/pure (r/pure :foo))))]) - (match (l/test-compile ::Main (concat (let [x 1] [x x]) (let [y 2] [y y]))) `[(r/cdef 0 [nil nil] [] nil (fn [~'frame] @@ -140,9 +141,15 @@ (r/node ~'frame 0)) (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure clojure.core/vector)) (r/node ~'frame 1) - (r/node ~'frame 1)))))] - ) + (r/node ~'frame 1)))))])) + +(tests "test-pure" + (match (l/test-compile ::Main (::lang/site :client (::lang/pure :foo))) + `[(r/cdef 0 [] [] :client + (fn [~'frame] + (r/pure (r/pure :foo))))])) +(tests "test-ctor" (match (l/test-compile ::Main (::lang/ctor :foo)) `[(r/cdef 0 [] [] nil (fn [~'frame] @@ -258,123 +265,122 @@ `[(r/cdef 0 [] [] nil (fn [~'frame] (r/pure (r/make-ctor ~'frame ::Main 1)))) + (r/cdef 0 [] [] nil + (fn [~'frame] + (r/pure :foo)))])) + +(tests "test-call" + (match (l/test-compile ::Main (::lang/call (::lang/ctor :foo))) + `[(r/cdef 0 [] [nil] nil + (fn [~'frame] + (r/define-call ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) + (r/join (r/call ~'frame 0)))) (r/cdef 0 [] [] nil (fn [~'frame] (r/pure :foo)))]) - ) -;; TODO rewrite or remove -(comment - (l/compile-client (let [x (::lang/ctor :foo), y x] (::lang/call y))) - := `(r/peer - (lang/r-defs - (lang/r-local 1) - (lang/r-ctor [] 2) - (lang/r-static :foo) - (lang/r-call 0)) - [0] 3) - - (l/compile-client (::lang/call (::lang/ctor :foo))) - := `(r/peer - (lang/r-defs - (lang/r-static :foo) - (lang/r-ctor [] 0) - (lang/r-call 0)) - [1] 2) - - (l/compile-client (vector 1 (::lang/call (::lang/ctor :foo)))) - := `(r/peer - (lang/r-defs - (lang/r-static :foo) - (lang/r-ctor [] 0) - (lang/r-ap (lang/r-static ~'vector) - (lang/r-static 1) - (lang/r-call 0))) - [1] 2) - - (l/compile-client (let [x (::lang/ctor :foo)] [(::lang/call x) (::lang/call x)])) - := `(r/peer - (lang/r-defs - (lang/r-ctor [] 1) - (lang/r-static :foo) - (lang/r-ap (lang/r-static clojure.core/vector) - (lang/r-call 0) - (lang/r-call 1))) - [0 0] - 2) - := `(r/peer - (lang/r-defs - (lang/r-ctor [] 1) - (lang/r-static :foo) - (lang/r-local 0) - (lang/r-local 0) - (lang/r-ap (lang/r-static clojure.core/vector) - (lang/r-call 0) - (lang/r-call 1))) - [2 3] 4) - - (l/compile-client [(::lang/call (::lang/ctor :foo)) (::lang/call (::lang/ctor :bar))]) - := `(r/peer - (lang/r-defs - (lang/r-static :foo) - (lang/r-ctor [] 0) - (lang/r-static :bar) - (lang/r-ctor [] 2) - (lang/r-ap (lang/r-static clojure.core/vector) - (lang/r-call 0) - (lang/r-call 1))) - [1 3] 4) - - (l/compile-client (let [a :foo] (::lang/call (::lang/ctor (::lang/ctor a))))) - := `(r/peer - (lang/r-defs - (lang/r-static :foo) - (lang/r-free 0) - (lang/r-ctor [] 1 (lang/r-free 0)) - (lang/r-ctor [] 2 (lang/r-local 0)) - (lang/r-call 0)) - [3] 4) + (match (l/test-compile ::Main (let [x (::lang/ctor :foo), y x] (::lang/call y))) + `[(r/cdef 0 [] [nil] nil + (fn [~'frame] + (r/define-call ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) + (r/join (r/call ~'frame 0)))) + (r/cdef 0 [] [] nil + (fn [~'frame] + (r/pure :foo)))]) + + (match (l/test-compile ::Main (vector 1 (::lang/call (::lang/ctor :foo)))) + `[(r/cdef 0 [] [nil] nil + (fn [~'frame] + (r/define-call ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) + (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure clojure.core/vector)) + (r/pure 1) + (r/join (r/call ~'frame 0))))) + (r/cdef 0 [] [] nil + (fn [~'frame] (r/pure :foo)))]) + + (match (l/test-compile ::Main (let [x (::lang/ctor :foo)] [(::lang/call x) (::lang/call x)])) + `[(r/cdef 0 [nil] [nil nil] nil + (fn [~'frame] + (r/define-node ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) + (r/define-call ~'frame 0 (r/node ~'frame 0)) + (r/define-call ~'frame 1 (r/node ~'frame 0)) + (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure clojure.core/vector)) + (r/join (r/call ~'frame 0)) + (r/join (r/call ~'frame 1))))) + (r/cdef 0 [] [] nil + (fn [~'frame] (r/pure :foo)))]) + + (match (l/test-compile ::Main [(::lang/call (::lang/ctor :foo)) (::lang/call (::lang/ctor :bar))]) + `[(r/cdef 0 [] [nil nil] nil + (fn [~'frame] + (r/define-call ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) + (r/define-call ~'frame 1 (r/pure (r/make-ctor ~'frame ::Main 2))) + (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure clojure.core/vector)) + (r/join (r/call ~'frame 0)) + (r/join (r/call ~'frame 1))))) + (r/cdef 0 [] [] nil + (fn [~'frame] + (r/pure :foo))) + (r/cdef 0 [] [] nil + (fn [~'frame] + (r/pure :bar)))]) + + (match (l/test-compile ::Main (let [a :foo] (::lang/call (::lang/ctor (::lang/ctor a))))) + `[(r/cdef 0 [nil] [nil] nil + (fn [~'frame] + (r/define-node ~'frame 0 (r/pure :foo)) + (r/define-call ~'frame 0 (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 1) + (r/define-free 0 (r/node ~'frame 0))))) + (r/join (r/call ~'frame 0)))) + (r/cdef 1 [] [] nil + (fn [~'frame] + (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 2) + (r/define-free 0 (r/free ~'frame 0)))))) + (r/cdef 1 [] [] nil + (fn [~'frame] + (r/free ~'frame 0)))])) +(tests "test-conditionals" ;; ({nil (ctor :y)} :x (ctor :z)) - (l/compile-client (case :x nil :y :z)) - := `(r/peer - (lang/r-defs - (lang/r-ctor [] 1) - (lang/r-static :y) - (lang/r-static :z) - (lang/r-ap (lang/r-ap (lang/r-static clojure.core/hash-map) - (lang/r-static 'nil) (lang/r-local 0)) - (lang/r-static :x) - (lang/r-ctor [] 2)) - (lang/r-call 0)) - [3] 4) - - (l/compile-client (case 'foo (foo bar) :share-this :else)) - := `(r/peer - (lang/r-defs - (lang/r-ctor [] 1) - (lang/r-static :share-this) - (lang/r-static :else) - (lang/r-ap (lang/r-ap (lang/r-static clojure.core/hash-map) - (lang/r-static '~'foo) (lang/r-local 0) - (lang/r-static '~'bar) (lang/r-local 0)) - (lang/r-static '~'foo) - (lang/r-ctor [] 2)) - (lang/r-call 0)) - [3] 4) - - (l/compile-client (::lang/pure :foo)) - := `(r/peer - (lang/r-defs - (lang/r-pure (lang/r-static :foo))) - [] 0) - - (l/compile-client (::lang/join (::lang/pure :foo))) - := `(r/peer - (lang/r-defs - (lang/r-join (lang/r-pure (lang/r-static :foo)))) - [] 0) + (match (l/test-compile ::Main (case :x nil :y :z)) + `[(r/cdef 0 [] [nil] nil + (fn [~'frame] + (r/define-call ~'frame 0 (r/ap (r/ap (r/lookup ~'frame :clojure.core/hash-map (r/pure clojure.core/hash-map)) + (r/pure 'nil) (r/pure (r/make-ctor ~'frame ::Main 1))) + (r/pure :x) + (r/pure (r/make-ctor ~'frame ::Main 2)))) + (r/join (r/call ~'frame 0)))) + (r/cdef 0 [] [] nil + (fn [~'frame] + (r/pure :y))) + (r/cdef 0 [] [] nil + (fn [~'frame] + (r/pure :z)))]) + + (match (l/test-compile ::Main (case 'foo (foo bar) :share-this :else)) + `[(r/cdef 0 [nil] [nil] nil + (fn [~'frame] + (r/define-node ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) + (r/define-call ~'frame 0 (r/ap (r/ap (r/lookup ~'frame :clojure.core/hash-map (r/pure clojure.core/hash-map)) + (r/pure '~'foo) (r/node ~'frame 0) + (r/pure '~'bar) (r/node ~'frame 0)) + (r/pure '~'foo) + (r/pure (r/make-ctor ~'frame ::Main 2)))) + (r/join (r/call ~'frame 0)))) + (r/cdef 0 [] [] nil + (fn [~'frame] + (r/pure :share-this))) + (r/cdef 0 [] [] nil + (fn [~'frame] + (r/pure :else)))]) + + ;; (match (l/test-compile ::Main (if 1 2 3))) + ) + +;; TODO test site is cleared on ctor boundary +;; TODO rewrite or remove +(comment (l/compile-client ((fn [] 1))) ;; ;; rest-args gensym breaks testability ;; ;; also, testing this deep is counter-productive, we're testing the implementation (internals) @@ -454,47 +460,6 @@ ;; * the result site (comment - ;; call (aka new, but with no argument and only for ctors) - (l/compile ::Main `(e/client (e/call (e/ctor :foo)))) - := `[(r/cdef 0 [] [:client] :client - (fn [frame] - (r/define-call frame 0 (r/pure (r/make-ctor frame ::Main 1))) - (r/join (r/call frame 0)))) - (r/cdef 0 [] [] nil - (fn [frame] - (r/pure :foo)))] - - ;; lexical closure - (l/compile ::Main `(e/client - (let [a :foo] - (e/call (e/ctor a))))) - := `[(r/cdef 0 [:client] [:client] :client - (fn [frame] - (r/define-node frame 0 (r/pure :foo)) - (r/define-call frame 0 (r/pure (doto (r/make-ctor frame ::Main 1) - (r/define-free 0 (r/node frame 0))))) - (r/join (r/call frame 0)))) - (r/cdef 1 [] [] nil - (fn [frame] - (r/free frame 0)))] - - (l/compile ::Main `(e/client - (let [a :foo] - (e/call (e/ctor (e/ctor a)))))) - := `[(r/cdef 0 [:client] [:client] :client - (fn [frame] - (r/define-node frame 0 (r/pure :foo)) - (r/define-call frame 0 (r/pure (doto (r/make-ctor frame ::Main 1) - (r/define-free 0 (r/node frame 0))))) - (r/join (r/call frame 0)))) - (r/cdef 1 [] [] nil - (fn [frame] - (r/pure (doto (r/make-ctor frame ::Main 2) - (r/define-free 0 (r/free frame 0)))))) - (r/cdef 1 [] [] nil - (fn [frame] - (r/free frame 0)))] - ;; conditionals (l/compile ::Main `(case :x nil :y :z)) := `[(r/cdef 0 [] [nil] nil diff --git a/test/hyperfiddle/electric/impl/compiler_test_clj.clj b/test/hyperfiddle/electric/impl/compiler_test_clj.clj new file mode 100644 index 000000000..862b8f3a3 --- /dev/null +++ b/test/hyperfiddle/electric/impl/compiler_test_clj.clj @@ -0,0 +1,3 @@ +(ns hyperfiddle.electric.impl.compiler-test-clj) + +(def cannot-be-unsited) diff --git a/test/hyperfiddle/electric/impl/compiler_test_cljs.cljs b/test/hyperfiddle/electric/impl/compiler_test_cljs.cljs new file mode 100644 index 000000000..a7211ebeb --- /dev/null +++ b/test/hyperfiddle/electric/impl/compiler_test_cljs.cljs @@ -0,0 +1,3 @@ +(ns hyperfiddle.electric.impl.compiler-test-cljs) + +(def cannot-be-unsited) From aab7c7038187cea426c18bd8ee6c3a21d6f7122d Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 24 Jan 2024 21:38:41 +0100 Subject: [PATCH 046/428] compiler: if --- src/hyperfiddle/electric/impl/lang_de2.clj | 8 ++-- .../electric/impl/compiler_test.cljc | 21 +++++++-- .../electric/impl/expand_de_test.cljc | 47 ++++++++++--------- 3 files changed, 48 insertions(+), 28 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 0447baf35..c0084632c 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -41,8 +41,8 @@ (assoc cljs-env :ns ast) (if-some [src (cljs-ana/locate-src nssym)] (let [ast (:ast (with-redefs [cljs-ana/missing-use-macro? (constantly nil)] - (binding [cljs-ana/*passes* []] - (cljs-ana/parse-ns src {:load-macros true, :restore false}))))] + (binding [cljs-ana/*passes* [cljs-ana/ns-side-effects]] + (cljs-ana/parse-ns src {:load-macros true, :analyze-deps true, :restore false}))))] ;; we parsed the ns form without `ns-side-effects` because it triggers weird bugs ;; this means the macro nss from `:require-macros` might not be loaded (run! serialized-require (-> ast :require-macros vals set)) @@ -210,6 +210,8 @@ clauses2) has-default-clause? (conj (xpand (last clauses))))))) + (if) (let [[_ test then else] o] (?meta o (list 'case test '(nil false) else then))) + (quote) o (fn*) (let [[?name more] (if (symbol? (second o)) [(second o) (nnext o)] [nil (next o)]) @@ -242,7 +244,7 @@ (?meta o (list 'set! (-expand-all (nth o 1) env) (-expand-all (nth o 2) env)))) (::site) (?meta o (seq (conj (into [] (take 2) o) - (-expand-all (cons 'do (drop 2 o)) (assoc env ::current (second o)))))) + (-expand-all (cons 'do (drop 2 o)) (assoc env ::current (second o)))))) #_else (if (symbol? (first o)) diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index 9778db243..b3a9514cb 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -1,13 +1,13 @@ (ns hyperfiddle.electric.impl.compiler-test (:require [hyperfiddle.electic :as-alias e] [hyperfiddle.incseq :as i] - [hyperfiddle.electric.impl.lang-de2 :as lang] + #?(:clj [hyperfiddle.electric.impl.lang-de2 :as lang]) [hyperfiddle.electric.impl.runtime-de :as r] [hyperfiddle.electric-local-def-de :as l] #?(:clj [hyperfiddle.electric.impl.compiler-test-clj :refer [cannot-be-unsited]] :cljs [hyperfiddle.electric.impl.compiler-test-cljs :refer [cannot-be-unsited]]) [hyperfiddle.rcf :as rcf :refer [tests]] - [contrib.test-match :as tm] + #?(:clj [contrib.test-match :as tm]) [fipp.edn] [missionary.core :as m]) #?(:clj (:import [clojure.lang ExceptionInfo]))) @@ -374,7 +374,22 @@ (fn [~'frame] (r/pure :else)))]) - ;; (match (l/test-compile ::Main (if 1 2 3))) + (match (l/test-compile ::Main (if 1 2 3)) + `[(r/cdef 0 [nil] [nil] nil + (fn [~'frame] + (r/define-node ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) + (r/define-call ~'frame 0 (r/ap (r/ap (r/lookup ~'frame :clojure.core/hash-map (r/pure clojure.core/hash-map)) + (r/pure 'nil) (r/node ~'frame 0) + (r/pure 'false) (r/node ~'frame 0)) + (r/pure 1) + (r/pure (r/make-ctor ~'frame ::Main 2)))) + (r/join (r/call ~'frame 0)))) + (r/cdef 0 [] [] nil + (fn [~'frame] + (r/pure 3))) + (r/cdef 0 [] [] nil + (fn [~'frame] + (r/pure 2)))]) ) ;; TODO test site is cleared on ctor boundary diff --git a/test/hyperfiddle/electric/impl/expand_de_test.cljc b/test/hyperfiddle/electric/impl/expand_de_test.cljc index 339c178d6..8153cf4f9 100644 --- a/test/hyperfiddle/electric/impl/expand_de_test.cljc +++ b/test/hyperfiddle/electric/impl/expand_de_test.cljc @@ -1,7 +1,7 @@ (ns hyperfiddle.electric.impl.expand-de-test (:require #?(:clj [cljs.env]) #?(:clj [cljs.analyzer]) - #?(:clj [hyperfiddle.electric.impl.lang-de :as c]) + #?(:clj [hyperfiddle.electric.impl.lang-de2 :as l]) #?(:clj [hyperfiddle.electric.impl.runtime-de :as r]) #?(:clj [hyperfiddle.electric :as-alias e]) [hyperfiddle.electric.impl.expand-require-referred :as ref :refer [referred]] @@ -9,9 +9,9 @@ #?(:cljs (:require-macros [hyperfiddle.electric.impl.expand-macro :as mac :refer [twice]]))) #?(:clj - (defmacro all [o] `(c/expand-all ~(if (:js-globals &env) - (assoc &env ::c/peers {:client :cljs, :server :cljs}, ::c/current :client) - {:locals &env, ::c/peers {:client :clj, :server :clj}, ::c/current :client}) + (defmacro all [o] `(l/expand-all ~(if (:js-globals &env) + (assoc &env ::l/peers {:client :cljs, :server :cljs}, ::l/current :client) + {:locals &env, ::l/peers {:client :clj, :server :clj}, ::l/current :client}) ~o))) #?(:clj (defmacro test-peer-expansion [] (if (:js-globals &env) :cljs :clj))) @@ -57,6 +57,9 @@ (all '(case (-> 1 inc) (2) (-> 2 inc) (with-open) 3 4)) := '(case (inc 1) (2) (inc 2) (with-open) 3 4) (has-line-meta? (all '(case (-> 1 inc) (2) (-> 2 inc) (with-open) 3 4))) := true + (all '(if 1 2 3)) := '(case 1 (nil false) 3 2) + (has-line-meta? (all '(if 1 2 3))) := true + (all ''(-> 1 inc)) := ''(-> 1 inc) (all '(fn [x] 1)) := '(fn* ([x] 1)) @@ -75,7 +78,7 @@ (->> [x] x)] (-> (->> x) inc)))] x := '(let* [[foo bar baz ->>] - (::c/letfn [foo (fn* foo ([with-open] (with-open 1))) + (::l/letfn [foo (fn* foo ([with-open] (with-open 1))) bar (fn* bar ([x] (inc x))) baz (fn* baz ([x] (->> x))) ->> (fn* ->> ([x] x))])] @@ -109,7 +112,7 @@ (let [x (all '(loop [with-open inc, x 2] (-> x with-open)))] x := `(~'binding [r/rec - (::c/closure + (::l/closure (let* [~'with-open r/%0, ~'x r/%1] (~'with-open ~'x)))] (new r/rec ~'inc 2)) @@ -127,7 +130,7 @@ (all '(hyperfiddle.impl.expand-test/X.)) := '(new hyperfiddle.impl.expand-test/X) - (c/-expand-all '(#{:ok} 1) {:js-globals {}}) + (l/-expand-all '(#{:ok} 1) {:js-globals {}}) "cljs var lookup doesn't produce undeclared-ns warnings" (let [!warns (atom [])] @@ -136,41 +139,41 @@ (when (typ cljs.analyzer/*cljs-warnings*) (swap! !warns conj [typ env extra])))] (binding [*err* *out*] - (with-out-str (c/-expand-all '(r/reflect 1) {::c/peers {:client :cljs, :server :clj} ::c/current :client}))))) + (with-out-str (l/-expand-all '(r/reflect 1) {::l/peers {:client :cljs, :server :clj} ::l/current :client}))))) @!warns := []) "expansion is peer-aware" - (c/expand-all {::c/peers {:client :cljs, :server :clj}, ::c/current :server} - `[(test-peer-expansion) (::c/toggle :client {} (test-peer-expansion))]) - := `[:clj (::c/toggle :client {} :cljs)] + (l/expand-all {::l/peers {:client :cljs, :server :clj}, ::l/current :server} + `[(test-peer-expansion) (::l/site :client (test-peer-expansion))]) + := `[:clj (::l/site :client :cljs)] - (c/expand-all {::c/peers {:client :cljs, :server :clj}, ::c/current :client} - `[(test-peer-expansion) (::c/toggle :server {} (test-peer-expansion))]) - := `[:cljs (::c/toggle :server {} :clj)] + (l/expand-all {::l/peers {:client :cljs, :server :clj}, ::l/current :client} + `[(test-peer-expansion) (::l/site :server (test-peer-expansion))]) + := `[:cljs (::l/site :server :clj)] "cljs require-macros work in clj expansion" - (c/expand-all {::c/peers {:client :cljs, :server :clj}, ::c/current :client, :ns 'hyperfiddle.electric.impl.expand-test} + (l/expand-all {::l/peers {:client :cljs, :server :clj}, ::l/current :client, :ns {:name 'hyperfiddle.electric.impl.expand-de-test}} '(hyperfiddle.electric.impl.expand-macro/twice 1)) := '[1 1] - (c/expand-all {::c/peers {:client :cljs, :server :clj}, ::c/current :client, :ns 'hyperfiddle.electric.impl.expand-test} + (l/expand-all {::l/peers {:client :cljs, :server :clj}, ::l/current :client, :ns {:name 'hyperfiddle.electric.impl.expand-de-test}} '(mac/twice 1)) := '[1 1] - (c/expand-all {::c/peers {:client :cljs, :server :clj}, ::c/current :client, :ns 'hyperfiddle.electric.impl.expand-test} + (l/expand-all {::l/peers {:client :cljs, :server :clj}, ::l/current :client, :ns {:name 'hyperfiddle.electric.impl.expand-de-test}} '(twice 1)) := '[1 1] "require referred macros work in cljs" - (c/expand-all {::c/peers {:client :cljs, :server :clj}, ::c/current :client, :ns 'hyperfiddle.electric.impl.expand-test} + (l/expand-all {::l/peers {:client :cljs, :server :clj}, ::l/current :client, :ns {:name 'hyperfiddle.electric.impl.expand-de-test}} '(referred)) := :referred "required macros work in cljs when fully qualified" - (c/expand-all {::c/peers {:client :cljs, :server :clj}, ::c/current :client, :ns 'hyperfiddle.electric.impl.expand-test} + (l/expand-all {::l/peers {:client :cljs, :server :clj}, ::l/current :client, :ns {:name 'hyperfiddle.electric.impl.expand-de-test}} '(hyperfiddle.electric.impl.expand-require-referred/referred)) := :referred "required macros work in cljs when alias qualified" - (c/expand-all {::c/peers {:client :cljs, :server :clj}, ::c/current :client, :ns 'hyperfiddle.electric.impl.expand-test} + (l/expand-all {::l/peers {:client :cljs, :server :clj}, ::l/current :client, :ns {:name 'hyperfiddle.electric.impl.expand-de-test}} '(ref/referred)) := :referred @@ -180,8 +183,8 @@ #?(:clj (when-not (= 'let* (first (binding [*ns* (create-ns 'hyperfiddle.electric.impl.expand-unloaded)] - (c/expand-all {::c/peers {:client :cljs, :server :clj} - ::c/current :server, ::c/me :client + (l/expand-all {::l/peers {:client :cljs, :server :clj} + ::l/current :server, ::l/me :client :ns 'hyperfiddle.electric.impl.expand-unloaded} '(let [x 1]))))) (throw (ex-info "clj macroexpansion for unloaded ns fails" {})))) From 8667d1fc1c01da3df6339b0d8ad0e38f408f0a7f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Thu, 25 Jan 2024 10:54:56 +0100 Subject: [PATCH 047/428] i/items --- src/hyperfiddle/incseq.cljc | 207 ++++++++++++++++++++++++++++++++++++ 1 file changed, 207 insertions(+) diff --git a/src/hyperfiddle/incseq.cljc b/src/hyperfiddle/incseq.cljc index 7e7729e80..b9b04b711 100644 --- a/src/hyperfiddle/incseq.cljc +++ b/src/hyperfiddle/incseq.cljc @@ -39,6 +39,7 @@ successive sequence diffs. Incremental sequences are applicative functors with ` (:refer-clojure :exclude [cycle int-array]) (:require [hyperfiddle.rcf :refer [tests]]) (:import #?(:clj (clojure.lang IFn IDeref)) + #?(:clj (java.util.concurrent.locks ReentrantLock)) missionary.Cancelled)) @@ -1351,6 +1352,212 @@ optional `compare` function, `clojure.core/compare` by default. :change {0 curr} :freeze #{}}))))))))))))))) +(def ^{:arglists '([incseq]) + :doc " +"} items + (let [slot-lock 0 + slot-busy 1 + slot-buffer 2 + slot-output 3 + slot-input 4 + slots 5 + item-slot-parent 0 + item-slot-frozen 1 + item-slot-state 2 + item-slot-fail 3 + item-slot-next 4 + item-slot-step 5 + item-slot-done 6 + item-slots 7] + (letfn [(acquire [^objects state] + #?(:clj (let [^ReentrantLock lock (aget state slot-lock) + held (.isHeldByCurrentThread lock)] + (.lock lock) held) + :cljs (let [held (aget state slot-lock)] + (aset state slot-lock true) held))) + (release [^objects state held] + (if held + #?(:clj (.unlock ^ReentrantLock (aget state slot-lock)) + :cljs (aset state slot-lock held)) + (let [^objects output (aget state slot-output) + ^objects head (aget output item-slot-parent)] + (aset output item-slot-parent nil) + #?(:clj (.unlock ^ReentrantLock (aget state slot-lock)) + :cljs (aset state slot-lock held)) + (loop [^objects head head] + (when-not (nil? head) + (let [item (aget head item-slot-next)] + (aset head item-slot-next nil) + (if-some [step (aget head item-slot-step)] + (step) (let [done (aget head item-slot-done)] + (aset head item-slot-done nil) (done))) + (recur item))))))) + (ensure-capacity [^objects state n] + (let [^objects b (aget state slot-buffer) + l (alength b)] + (if (< l n) + (let [a (object-array + (loop [l l] + (let [l (bit-shift-left l 1)] + (if (< l n) (recur l) l))))] + #?(:cljs (dotimes [i l] (aset a i (aget b i))) + :clj (System/arraycopy b 0 a 0 l)) + (aset state slot-buffer a)) b))) + (apply-cycle [^objects buffer cycle] + (let [i (nth cycle 0) + x (aget buffer i) + j (loop [i i + k 1] + (let [j (nth cycle k) + y (aget buffer j) + k (unchecked-inc-int k)] + (aset buffer i y) + (if (< k (count cycle)) + (recur j k) j)))] + (aset buffer j x) buffer)) + (detach [^objects buffer i] + (propagate-freeze buffer i) (aset buffer i nil) buffer) + (propagate-change [^objects buffer i x] + (aset ^objects (aget buffer i) item-slot-state x) buffer) + (propagate-freeze [^objects buffer i] + (aset ^objects (aget buffer i) item-slot-frozen true) buffer) + (item-failure [done] + (done) (throw (#?(:clj Error. :cljs js/Error.) "Illegal concurrent cursor."))) + (item-cancel [^objects item] + (let [parent (aget item item-slot-parent) + held (acquire parent)] + (when-not (aget item item-slot-fail) + (aset item item-slot-fail true) + (when (identical? item (aget item item-slot-next)) + (notify parent item))) + (release parent held))) + (item-transfer [^objects item] + (let [parent (aget item item-slot-parent) + held (acquire parent)] + (input-transfer parent) + (if (aget item item-slot-fail) + (do (aset item item-slot-step nil) + (notify parent item) + (release parent held) + (throw (Cancelled. "Cursor cancelled."))) + (let [state (aget item item-slot-state)] + (if (aget item item-slot-frozen) + (do (aset item item-slot-step nil) + (notify parent item)) + (aset item item-slot-next item)) + (release parent held) state)))) + (create-item [^objects parent i] + (let [item (object-array item-slots)] + (aset ^objects (aget parent slot-buffer) i item) + (aset item item-slot-parent parent) + (aset item item-slot-frozen false) + (aset item item-slot-state item) parent)) + (get-cursor [^objects item] + (fn [step done] + (let [parent (aget item item-slot-parent) + held (acquire parent)] + (if (nil? (aget item item-slot-done)) + (do (aset item item-slot-fail false) + (aset item item-slot-step step) + (aset item item-slot-done done) + (notify parent item) + (release parent held) + (->Ps item item-cancel item-transfer)) + (do (release parent held) (step) + (->Ps done {} item-failure)))))) + (input-transfer [^objects state] + (when (aget state slot-busy) + (let [^objects output (aget state slot-output)] + (loop [] + (if (aget output item-slot-frozen) + (when-some [^objects buffer (aget state slot-buffer)] + (let [n (loop [i 0] + (if (< i (alength buffer)) + (if-some [^objects item (aget buffer i)] + (do (aset item item-slot-frozen true) + (recur (inc i))) i) i))] + (when (nil? (aget output item-slot-state)) + (aset output item-slot-state (empty-diff n))))) + (try + (let [{:keys [grow degree shrink permutation change freeze]} @(aget state slot-input) + ^objects buffer (ensure-capacity state degree) + created (range (- degree grow) degree) + iperm (inverse permutation) + indices (into #{} (map (fn [i] (iperm i i))) created)] + (reduce create-item state created) + (reduce apply-cycle buffer (decompose permutation)) + (reduce detach buffer (range (- degree shrink) degree)) + (reduce-kv propagate-change buffer change) + (reduce propagate-freeze buffer freeze) + (let [diff {:grow grow + :degree degree + :shrink shrink + :permutation permutation + :change (reduce + (fn [m i] + (assoc m i (get-cursor (aget buffer i)))) + {} indices) + :freeze indices}] + (aset output item-slot-state + (if-some [d (aget output item-slot-state)] + (combine d diff) diff)))) + (catch #?(:clj Throwable :cljs :default) e + (aset output item-slot-fail true) + (aset output item-slot-state e)))) + (when (aset state slot-busy (not (aget state slot-busy))) (recur)))))) + (input-ready [^objects state] + (let [held (acquire state) + ^objects buffer (aget state slot-buffer) + ^objects output (aget state slot-output) + ^objects head (aget output item-slot-parent)] + (aset state slot-busy (not (aget state slot-busy))) + (aset output item-slot-parent + (loop [i 0 + h (when (identical? output (aget output item-slot-next)) + (aset output item-slot-next head) output)] + (if (< i (alength buffer)) + (if-some [^objects item (aget buffer i)] + (recur (inc i) + (if (identical? item (aget item item-slot-next)) + (do (aset item item-slot-next h) item) h)) h) h))) + (release state held))) + (notify [^objects state ^objects item] + (let [^objects output (aget state slot-output)] + (aset item item-slot-next (aget output item-slot-parent)) + (aset output item-slot-parent item))) + (cancel [^objects state] + ((aget state slot-input))) + (transfer [^objects state] + (let [^objects output (aget state slot-output) + held (acquire state)] + (input-transfer state) + (let [diff (aget output item-slot-state)] + (aset output item-slot-state nil) + (if (aget output item-slot-frozen) + (do (aset output item-slot-step nil) + (notify state output)) + (aset output item-slot-next output)) + (if (aget output item-slot-fail) + (do (release state held) (throw diff)) + (do (release state held) diff)))))] + (fn [incseq] + (fn [step done] + (let [state (object-array slots) + output (object-array item-slots)] + (aset output item-slot-next output) + (aset output item-slot-frozen false) + (aset output item-slot-fail false) + (aset output item-slot-step step) + (aset output item-slot-done done) + (aset state slot-lock #?(:clj (ReentrantLock.) :cljs false)) + (aset state slot-busy false) + (aset state slot-buffer (object-array 1)) + (aset state slot-output output) + (aset state slot-input + (incseq #(input-ready state) + #(do (aset output item-slot-frozen true) + (input-ready state)))) + (->Ps state cancel transfer))))))) ;; unit tests From a0288cff8eb4e8c66b6088b46c5aa362dcef3785 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Thu, 25 Jan 2024 10:56:18 +0100 Subject: [PATCH 048/428] runtime first tests --- src/hyperfiddle/electric/impl/runtime_de.cljc | 78 +++++-------------- .../electric/impl/runtime_test.cljc | 26 +++++++ 2 files changed, 44 insertions(+), 60 deletions(-) create mode 100644 test/hyperfiddle/electric/impl/runtime_test.cljc diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 716e3ca84..58fc1d5a7 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -15,12 +15,14 @@ )) +(defn invariant [x] (m/cp x)) + (deftype Pure [values] IFn (#?(:clj invoke :cljs -invoke) [_ step done] - ((apply i/fixed (map #(m/cp %) values)) step done))) + ((apply i/fixed (map invariant values)) step done))) -(defn pure [& xs] (->Pure xs)) +(def pure (comp ->Pure vector)) (defn error [^String msg] #?(:clj (Error. msg) @@ -48,6 +50,9 @@ (->Ctor (.-peer ctor) (.-key ctor) (.-idx ctor) (.-free ctor) (assoc (.-env ctor) k v))) +(defn bind-args [^Ctor ctor & args] + (reduce (partial apply bind) ctor (eduction (map-indexed vector) args))) + (defn ctor-peer "Returns the peer of given constructor." {:tag Peer} @@ -79,9 +84,7 @@ (deftype Node [frame id] IFn (#?(:clj invoke :cljs -invoke) [_ step done] - ((aget (.-signals frame) - (bit-shift-left id 1)) - step done))) + ((aget (.-signals frame) id) step done))) (deftype Call [frame id] IFn @@ -182,8 +185,11 @@ (->Call frame id)) (def join i/latest-concat) + (def ap (partial i/latest-product (fn [f & args] (apply f args)))) +(def singletons (comp (partial i/latest-product (comp (partial m/signal i/combine) i/fixed)) i/items)) + (def peer-slot-input 0) (def peer-slot-store 1) (def peer-slots 2) @@ -209,66 +215,18 @@ Returns a peer definition from given definitions and main key. (into {} (map-indexed (fn [i arg] [i (pure arg)]))) (->Ctor peer main 0 (object-array 0)) (make-frame nil 0) + (m/signal i/combine) (m/reduce (fn [_ x] (prn :output x)) nil)) #(prn :success %) #(prn :failure %)) peer)))) -(comment - (defn r! [defs main & args] - (((apply peer defs main args) - (fn [!] (prn :boot) #())) - #(prn :s %) - #(prn :f %))) - - ;; pure - (r! {::Main [(cdef 0 [] [] nil (fn [frame] (pure "hello world")))]} ::Main) - - ;; variable - (def !x (atom 0)) - (r! {::Main [(cdef 0 [] [] nil (fn [frame] (join (pure (i/fixed (m/watch !x))))))]} ::Main) - (swap! !x inc) - - ;; conditional - (def !x (atom false)) - (r! {::Main [(cdef 0 [] [nil] nil - (fn [frame] - (define-call frame 0 - (ap (pure {false (make-ctor frame ::Main 1) - true (make-ctor frame ::Main 2)}) - (i/fixed (m/watch !x)))) - (join (call frame 0)))) - (cdef 0 [] [] nil - (fn [frame] - (pure "foo"))) - (cdef 0 [] [] nil - (fn [frame] - (pure "bar")))]} - ::Main) - (swap! !x not) - - ;; amb - (def !x (atom "bar")) - (r! {::Main [(cdef 0 [] [nil] nil - (fn [frame] - (define-call frame 0 - (pure - (make-ctor frame ::Main 1) - (make-ctor frame ::Main 2) - (make-ctor frame ::Main 3))) - (join (call frame 0)))) - (cdef 0 [] [] nil - (fn [frame] - (pure "foo"))) - (cdef 0 [] [] nil - (fn [frame] - (i/fixed (m/watch !x)))) - (cdef 0 [] [] nil - (fn [frame] - (pure "baz")))]} ::Main) - (reset! !x "bar") - - ) +;; local only +(defn root-frame [defs main] + (->> (->Ctor (->Peer nil nil defs nil) + main 0 (object-array 0) {}) + (make-frame nil 0) + (m/signal i/combine))) (def ^{::type ::node, :doc "for loop/recur impl"} rec) diff --git a/test/hyperfiddle/electric/impl/runtime_test.cljc b/test/hyperfiddle/electric/impl/runtime_test.cljc new file mode 100644 index 000000000..c0e163942 --- /dev/null +++ b/test/hyperfiddle/electric/impl/runtime_test.cljc @@ -0,0 +1,26 @@ +(ns hyperfiddle.electric.impl.runtime-test + (:require [missionary.core :as m] + [hyperfiddle.incseq :as i] + [hyperfiddle.electric :as-alias e] + [hyperfiddle.electric.impl.lang-de2 :as l] + [hyperfiddle.electric.impl.runtime-de :as r] + [hyperfiddle.rcf :as rcf :refer [tests %]])) + +(defn on-diff! [cb incseq] + ((m/reduce (fn [_ d] (cb d) nil) nil incseq) + cb (fn [e] #?(:clj (.printStackTrace ^Throwable e) + :cljs (.error js/console e))))) + +(defmacro root-frame [form] + `(r/root-frame {::Main ~(l/compile ::Main form &env)} ::Main)) + +(tests + (on-diff! rcf/tap (root-frame "hello electric")) + % := {:grow 1, :degree 1, :shrink 0, :permutation {}, :change {0 "hello electric"}, :freeze #{0}} + % := nil) + +(tests + (def !x (atom :foo)) + (on-diff! rcf/tap (root-frame (e/join (i/fixed (m/watch !x))))) + (reset! !x :bar) + ) \ No newline at end of file From 3eecbf7998cf889b97608cbc9eb0f836ee0cc29f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Thu, 25 Jan 2024 13:25:21 +0100 Subject: [PATCH 049/428] runtime more tests --- test/hyperfiddle/electric/impl/runtime_test.cljc | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/test/hyperfiddle/electric/impl/runtime_test.cljc b/test/hyperfiddle/electric/impl/runtime_test.cljc index c0e163942..a40124033 100644 --- a/test/hyperfiddle/electric/impl/runtime_test.cljc +++ b/test/hyperfiddle/electric/impl/runtime_test.cljc @@ -2,7 +2,7 @@ (:require [missionary.core :as m] [hyperfiddle.incseq :as i] [hyperfiddle.electric :as-alias e] - [hyperfiddle.electric.impl.lang-de2 :as l] + #?(:clj [hyperfiddle.electric.impl.lang-de2 :as l]) [hyperfiddle.electric.impl.runtime-de :as r] [hyperfiddle.rcf :as rcf :refer [tests %]])) @@ -12,7 +12,10 @@ :cljs (.error js/console e))))) (defmacro root-frame [form] - `(r/root-frame {::Main ~(l/compile ::Main form &env)} ::Main)) + `(r/root-frame {::Main ~(l/compile ::Main form + (assoc (l/normalize-env &env) + ::l/peers {:client :clj, :server :clj}))} + ::Main)) (tests (on-diff! rcf/tap (root-frame "hello electric")) @@ -21,6 +24,7 @@ (tests (def !x (atom :foo)) - (on-diff! rcf/tap (root-frame (e/join (i/fixed (m/watch !x))))) + (on-diff! rcf/tap (root-frame (::l/join (i/fixed (m/watch !x))))) + % := {:degree 1, :permutation {}, :grow 1, :shrink 0, :change {0 :foo}, :freeze #{}} (reset! !x :bar) - ) \ No newline at end of file + % := {:degree 1, :permutation {}, :grow 0, :shrink 0, :change {0 :bar}, :freeze #{}}) \ No newline at end of file From 0b25491d40d6a34c5029d9f2da5d4c8ba9cb8f00 Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 25 Jan 2024 12:12:56 +0100 Subject: [PATCH 050/428] copmiler: lookup --- src/hyperfiddle/electric/impl/lang_de2.clj | 13 ++++++++----- test/hyperfiddle/electric/impl/compiler_test.cljc | 9 +++++++-- 2 files changed, 15 insertions(+), 7 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index c0084632c..cc6006467 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -9,7 +9,7 @@ [clojure.set :as set] [contrib.triple-store :as ts] [dom-top.core :refer [loopr]] - [hyperfiddle.electric :as-alias e] + [hyperfiddle.electric-de :as-alias e] [hyperfiddle.electric.impl.analyzer :as ana] [hyperfiddle.electric.impl.runtime-de :as r] [hyperfiddle.rcf :as rcf :refer [tests]])) @@ -210,7 +210,8 @@ clauses2) has-default-clause? (conj (xpand (last clauses))))))) - (if) (let [[_ test then else] o] (?meta o (list 'case test '(nil false) else then))) + (if) (let [[_ test then else] o, xpand (fn-> -expand-all env)] + (?meta o (list 'case (xpand test) '(nil false) (xpand else) (xpand then)))) (quote) o @@ -524,6 +525,7 @@ (recur bform e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::site, ::site site}) (?add-source-map e form) (update :o update ::env assoc ::current site)))) + (::lookup) (let [[_ sym] form] (ts/add ts {:db/id (->id), ::parent pe, ::type ::lookup, ::sym sym})) #_else (let [e (->id)] (reduce (fn [ts nx] (analyze nx e ts)) (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) (?add-source-map e form)) form))) @@ -574,7 +576,7 @@ mark-used-ctors (fn mark-used-ctors [ts e] (let [nd (get (:eav ts) e)] (case (::type nd) - (::static ::var) ts + (::static ::var ::lookup) ts (::ap) (reduce mark-used-ctors ts (get-children-e ts e)) (::site ::join ::pure ::call) (recur ts (get-child-e ts e)) (::ctor) (if (::ctor-idx nd) @@ -613,7 +615,7 @@ handle-let-refs (fn handle-let-refs [ts e] ; nodes and frees (closed over) (let [nd (get (:eav ts) e)] (case (::type nd) - (::static ::var) ts + (::static ::var ::lookup) ts (::ap) (reduce handle-let-refs ts (get-children-e ts e)) (::site ::join ::pure ::ctor ::call) (recur ts (get-child-e ts e)) (::let) (recur ts (->let-body-e ts e)) @@ -642,7 +644,7 @@ mark-used-calls (fn mark-used-calls [ts ctor-e e] (let [nd (ts/->node ts e)] (case (::type nd) - (::static ::var) ts + (::static ::var ::lookup) ts (::ap) (reduce #(mark-used-calls % ctor-e %2) ts (get-children-e ts e)) (::site ::join ::pure) (recur ts ctor-e (get-child-e ts e)) (::ctor) (recur ts e (get-child-e ts e)) @@ -683,6 +685,7 @@ frees-e)) ctor))) ::call (list `r/join (list `r/call 'frame (::call-idx (ts/->node ts e)))) + ::lookup (list `r/lookup 'frame (::sym nd)) ::let (recur ts ctor-e (get-ret-e ts (->let-body-e ts e))) ::let-ref (if-some [node-e (first (ts/find ts ::ctor-node ctor-e, ::ctor-ref (::ref nd)))] diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index b3a9514cb..4f58d7f8f 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -389,8 +389,13 @@ (r/pure 3))) (r/cdef 0 [] [] nil (fn [~'frame] - (r/pure 2)))]) - ) + (r/pure 2)))])) + +(tests "test-lookup" + (match (l/test-compile ::Main (::lang/lookup 0)) + `[(r/cdef 0 [] [] nil + (fn [~'frame] + (r/lookup ~'frame 0)))])) ;; TODO test site is cleared on ctor boundary From c39cc0a8831f3a4d7af2b3c947e436680a834a8f Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 25 Jan 2024 15:41:43 +0100 Subject: [PATCH 051/428] failing cljs test --- test/hyperfiddle/electric/impl/compiler_test.cljc | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index 4f58d7f8f..97a296440 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -397,6 +397,11 @@ (fn [~'frame] (r/lookup ~'frame 0)))])) +(defn should-work-in-cljs []) + +(tests "test-unsited-cljs-fn" + (match (l/test-compile ::Main (should-work-in-cljs)))) + ;; TODO test site is cleared on ctor boundary ;; TODO rewrite or remove From 000a0f4d7f07cde80e71a6a1b69355fc9ab72812 Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 25 Jan 2024 16:13:35 +0100 Subject: [PATCH 052/428] failing fizzbuzz test --- .../electric/impl/runtime_test.cljc | 20 +++++++++++++++++-- 1 file changed, 18 insertions(+), 2 deletions(-) diff --git a/test/hyperfiddle/electric/impl/runtime_test.cljc b/test/hyperfiddle/electric/impl/runtime_test.cljc index a40124033..244e0cea0 100644 --- a/test/hyperfiddle/electric/impl/runtime_test.cljc +++ b/test/hyperfiddle/electric/impl/runtime_test.cljc @@ -1,7 +1,7 @@ (ns hyperfiddle.electric.impl.runtime-test (:require [missionary.core :as m] [hyperfiddle.incseq :as i] - [hyperfiddle.electric :as-alias e] + [hyperfiddle.electric-de :as e] #?(:clj [hyperfiddle.electric.impl.lang-de2 :as l]) [hyperfiddle.electric.impl.runtime-de :as r] [hyperfiddle.rcf :as rcf :refer [tests %]])) @@ -27,4 +27,20 @@ (on-diff! rcf/tap (root-frame (::l/join (i/fixed (m/watch !x))))) % := {:degree 1, :permutation {}, :grow 1, :shrink 0, :change {0 :foo}, :freeze #{}} (reset! !x :bar) - % := {:degree 1, :permutation {}, :grow 0, :shrink 0, :change {0 :bar}, :freeze #{}}) \ No newline at end of file + % := {:degree 1, :permutation {}, :grow 0, :shrink 0, :change {0 :bar}, :freeze #{}}) + +(tests + (def !n (atom 10)) + (def !fizz (atom "Fizz")) + (def !buzz (atom "Buzz")) + (on-diff! rcf/tap (root-frame (e/server (let [fizz (e/watch !fizz) ; i/fixed + m/watch + e/join + buzz (e/watch !buzz) + is (e/diff-by identity (range 1 (inc (e/watch !n)))) ; variable in time and space + results (e/cursor [i is] + (cond + (zero? (mod i (* 3 5))) (str fizz buzz) + (zero? (mod i 3)) fizz + (zero? (mod i 5)) buzz + :else i))] + (println results))))) + % := {}) From dd4f7bdadd60dbead4cdfaae2a24e0a76aaff4f3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Thu, 25 Jan 2024 17:55:10 +0100 Subject: [PATCH 053/428] fix latest-product for arity > 4 --- src/hyperfiddle/incseq.cljc | 25 +++++++++++++++---------- 1 file changed, 15 insertions(+), 10 deletions(-) diff --git a/src/hyperfiddle/incseq.cljc b/src/hyperfiddle/incseq.cljc index b9b04b711..c0247c92f 100644 --- a/src/hyperfiddle/incseq.cljc +++ b/src/hyperfiddle/incseq.cljc @@ -805,16 +805,21 @@ combined with given function. (aset state slot-processes (object-array arity)) (aset state slot-ready ready) (aset state slot-counts - (loop [i 1] - (let [n (bit-shift-left i 1)] - (if (< i arity) - (recur n) - (let [arr (int-array n)] - (loop [i (unchecked-add-int i arity)] - (when (< i n) - (aset arr i 1) - (recur (unchecked-inc-int i)))) - arr))))) + (let [o (loop [o 1] + (if (< o arity) + (recur (bit-shift-left o 1)) o)) + n (bit-shift-left o 1) + arr (int-array n)] + (loop [f (unchecked-subtract o arity) + o o + n n] + (when (< 1 o) + (loop [i (unchecked-subtract n f)] + (when (< i n) + (aset arr i 1) + (recur (unchecked-inc i)))) + (recur (bit-shift-right f 1) + (bit-shift-right o 1) o))) arr)) (aset state slot-live (identity arity)) (aset state slot-value (empty-diff 0)) (reduce-kv input-spawn state diffs) From 63a6f49049b2edc648495c8590e65e01f494654f Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 25 Jan 2024 18:34:02 +0100 Subject: [PATCH 054/428] electric_de --- src/hyperfiddle/electric_de.cljc | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) create mode 100644 src/hyperfiddle/electric_de.cljc diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc new file mode 100644 index 000000000..42c706667 --- /dev/null +++ b/src/hyperfiddle/electric_de.cljc @@ -0,0 +1,25 @@ +(ns hyperfiddle.electric-de + (:refer-clojure :exclude [fn]) + (:require #?(:clj [hyperfiddle.electric.impl.lang-de2 :as lang]) + [hyperfiddle.electric.impl.runtime-de :as r] + [hyperfiddle.incseq :as i] + [missionary.core :as m] + [hyperfiddle.electric-local-def-de :as l]) + #?(:cljs (:require-macros hyperfiddle.electric-de))) + +(defmacro join [flow] `(::lang/join ~flow)) +(defmacro input [flow] `(join (i/fixed ~flow))) +(defmacro watch [ref] `(input (m/watch ~ref))) +(defmacro ctor [expr] `(::lang/ctor ~expr)) +(defmacro call [ctor] `(::lang/call ~ctor)) +(defmacro pure [v] `(::lang/pure ~v)) +(defmacro amb [& exprs] `(call (join (r/pure ~@(mapv #(list `ctor %) exprs))))) +(defmacro fn [bs & body] + `(ctor + (let [~@(interleave bs (eduction (map #(list ::lang/lookup %)) (range)))] + ~@body))) +(defmacro cursor [[sym v] & body] `(call (r/bind-args (fn [~sym] ~@body) (join (r/singletons (pure ~v)))))) +(defmacro diff-by [f xs] `(join (i/diff-by ~f (join (r/singletons (pure ~xs)))))) +;; (defmacro drain [expr] `(join (i/drain (pure ~expr)))) +(defmacro client [& body] `(::lang/site :client ~@body)) +(defmacro server [& body] `(::lang/site :server ~@body)) From 332d4410dbf5e0b7f3b9ad7d8ce1492e5c4c5eaf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Thu, 25 Jan 2024 18:41:46 +0100 Subject: [PATCH 055/428] runtime tests - conditional, amb --- .../electric/impl/runtime_test.cljc | 19 +++++++++++++++++-- 1 file changed, 17 insertions(+), 2 deletions(-) diff --git a/test/hyperfiddle/electric/impl/runtime_test.cljc b/test/hyperfiddle/electric/impl/runtime_test.cljc index 244e0cea0..eefa6ad85 100644 --- a/test/hyperfiddle/electric/impl/runtime_test.cljc +++ b/test/hyperfiddle/electric/impl/runtime_test.cljc @@ -1,6 +1,5 @@ (ns hyperfiddle.electric.impl.runtime-test (:require [missionary.core :as m] - [hyperfiddle.incseq :as i] [hyperfiddle.electric-de :as e] #?(:clj [hyperfiddle.electric.impl.lang-de2 :as l]) [hyperfiddle.electric.impl.runtime-de :as r] @@ -24,11 +23,27 @@ (tests (def !x (atom :foo)) - (on-diff! rcf/tap (root-frame (::l/join (i/fixed (m/watch !x))))) + (on-diff! rcf/tap (root-frame (e/watch !x))) % := {:degree 1, :permutation {}, :grow 1, :shrink 0, :change {0 :foo}, :freeze #{}} (reset! !x :bar) % := {:degree 1, :permutation {}, :grow 0, :shrink 0, :change {0 :bar}, :freeze #{}}) +(tests + (def !x (atom false)) + (on-diff! rcf/tap + (root-frame (if (e/watch !x) "foo" "bar"))) + % := {:degree 1, :permutation {}, :grow 1, :shrink 0, :change {0 "bar"}, :freeze #{0}} + (swap! !x not) + % := {:degree 2, :permutation {0 1, 1 0}, :grow 1, :shrink 1, :change {0 "foo"}, :freeze #{0}}) + +(tests + (def !bar (atom :bar)) + (on-diff! rcf/tap + (root-frame (e/amb :foo (e/watch !bar) :baz))) + % := {:degree 3, :permutation {}, :grow 3, :shrink 0, :change {0 :foo, 1 :bar, 2 :baz}, :freeze #{0 2}} + (reset! !bar :BAR) + % := {:degree 3, :permutation {}, :grow 0, :shrink 0, :change {1 :BAR}, :freeze #{}}) + (tests (def !n (atom 10)) (def !fizz (atom "Fizz")) From 5b4cfe4b782b3186b7409067e24c260947831e8e Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 25 Jan 2024 20:03:02 +0100 Subject: [PATCH 056/428] fix invalid keyword error by adding lang_de2.cljs --- src/hyperfiddle/electric/impl/lang_de2.cljs | 2 ++ src/hyperfiddle/electric_de.cljc | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) create mode 100644 src/hyperfiddle/electric/impl/lang_de2.cljs diff --git a/src/hyperfiddle/electric/impl/lang_de2.cljs b/src/hyperfiddle/electric/impl/lang_de2.cljs new file mode 100644 index 000000000..3f6892542 --- /dev/null +++ b/src/hyperfiddle/electric/impl/lang_de2.cljs @@ -0,0 +1,2 @@ +(ns hyperfiddle.electric.impl.lang-de2) + diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 42c706667..5adb9744d 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -1,6 +1,6 @@ (ns hyperfiddle.electric-de (:refer-clojure :exclude [fn]) - (:require #?(:clj [hyperfiddle.electric.impl.lang-de2 :as lang]) + (:require [hyperfiddle.electric.impl.lang-de2 :as lang] [hyperfiddle.electric.impl.runtime-de :as r] [hyperfiddle.incseq :as i] [missionary.core :as m] From 56fedd40dc2876af62b411ed8c6b697e70a7b0e3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Fri, 26 Jan 2024 09:24:28 +0100 Subject: [PATCH 057/428] fix diff-by --- src/hyperfiddle/electric_de.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 5adb9744d..6c21b6750 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -19,7 +19,7 @@ (let [~@(interleave bs (eduction (map #(list ::lang/lookup %)) (range)))] ~@body))) (defmacro cursor [[sym v] & body] `(call (r/bind-args (fn [~sym] ~@body) (join (r/singletons (pure ~v)))))) -(defmacro diff-by [f xs] `(join (i/diff-by ~f (join (r/singletons (pure ~xs)))))) +(defmacro diff-by [f xs] `(join (i/diff-by ~f (join (i/items (pure ~xs)))))) ;; (defmacro drain [expr] `(join (i/drain (pure ~expr)))) (defmacro client [& body] `(::lang/site :client ~@body)) (defmacro server [& body] `(::lang/site :server ~@body)) From 35b755942644c543b235c76ee404c9ff3d9c19d5 Mon Sep 17 00:00:00 2001 From: xificurC Date: Fri, 26 Jan 2024 09:25:36 +0100 Subject: [PATCH 058/428] fix require --- test/hyperfiddle/electric/impl/compiler_test.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index 97a296440..d033618dd 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -1,5 +1,5 @@ (ns hyperfiddle.electric.impl.compiler-test - (:require [hyperfiddle.electic :as-alias e] + (:require [hyperfiddle.electric-de :as e] [hyperfiddle.incseq :as i] #?(:clj [hyperfiddle.electric.impl.lang-de2 :as lang]) [hyperfiddle.electric.impl.runtime-de :as r] From 10f776847d62761da517e96c223faac4544ea736 Mon Sep 17 00:00:00 2001 From: xificurC Date: Fri, 26 Jan 2024 09:55:12 +0100 Subject: [PATCH 059/428] compiler: fix free index lookup --- src/hyperfiddle/electric/impl/lang_de2.clj | 2 +- .../electric/impl/compiler_test.cljc | 26 ++++++++++++++++--- .../electric/impl/runtime_test.cljc | 16 +++++++----- 3 files changed, 32 insertions(+), 12 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index cc6006467..bc91551bc 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -690,7 +690,7 @@ ::let-ref (if-some [node-e (first (ts/find ts ::ctor-node ctor-e, ::ctor-ref (::ref nd)))] (list `r/node 'frame (::node-idx (get (:eav ts) node-e))) - (if-some [free-e (first (ts/find ts ::ctor-free ctor-e))] + (if-some [free-e (first (ts/find ts ::ctor-free ctor-e, ::closed-ref (::ref nd)))] (list `r/free 'frame (::free-idx (ts/->node ts free-e))) (recur ts ctor-e (get-ret-e ts (->let-val-e ts (::ref nd)))))) #_else (throw (ex-info (str "cannot gen on " (pr-str (::type nd))) (or nd {})))))) diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index d033618dd..ec9528d3e 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -389,7 +389,22 @@ (r/pure 3))) (r/cdef 0 [] [] nil (fn [~'frame] - (r/pure 2)))])) + (r/pure 2)))]) + (match (l/test-compile ::Main (let [fizz "fizz", buzz "buzz"] + (e/ctor (str fizz buzz)))) + `[(r/cdef 0 [nil nil] [] nil + (fn [~'frame] + (r/define-node ~'frame 0 (r/pure "fizz")) + (r/define-node ~'frame 1 (r/pure "buzz")) + (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 1) + (r/define-free 0 (r/node ~'frame 0)) + (r/define-free 1 (r/node ~'frame 1)))))) + (r/cdef 2 [] [] nil + (fn [~'frame] + (r/ap (r/lookup ~'frame :clojure.core/str (r/pure clojure.core/str)) + (r/free ~'frame 0) + (r/free ~'frame 1))))]) + ) (tests "test-lookup" (match (l/test-compile ::Main (::lang/lookup 0)) @@ -397,11 +412,14 @@ (fn [~'frame] (r/lookup ~'frame 0)))])) -(defn should-work-in-cljs []) +;; (defn should-work-in-cljs []) -(tests "test-unsited-cljs-fn" - (match (l/test-compile ::Main (should-work-in-cljs)))) +;; (tests "test-unsited-cljs-fn" +;; (match (l/test-compile ::Main (should-work-in-cljs)))) +(comment + (l/test-compile ::Main (let [fizz "fizz", buzz "buzz"] + (e/ctor (str fizz buzz))))) ;; TODO test site is cleared on ctor boundary ;; TODO rewrite or remove diff --git a/test/hyperfiddle/electric/impl/runtime_test.cljc b/test/hyperfiddle/electric/impl/runtime_test.cljc index eefa6ad85..82f66381a 100644 --- a/test/hyperfiddle/electric/impl/runtime_test.cljc +++ b/test/hyperfiddle/electric/impl/runtime_test.cljc @@ -45,17 +45,19 @@ % := {:degree 3, :permutation {}, :grow 0, :shrink 0, :change {1 :BAR}, :freeze #{}}) (tests - (def !n (atom 10)) + (def !n (atom 20)) (def !fizz (atom "Fizz")) (def !buzz (atom "Buzz")) (on-diff! rcf/tap (root-frame (e/server (let [fizz (e/watch !fizz) ; i/fixed + m/watch + e/join buzz (e/watch !buzz) is (e/diff-by identity (range 1 (inc (e/watch !n)))) ; variable in time and space results (e/cursor [i is] - (cond - (zero? (mod i (* 3 5))) (str fizz buzz) - (zero? (mod i 3)) fizz - (zero? (mod i 5)) buzz - :else i))] - (println results))))) + [i (cond + (zero? (mod i (* 3 5))) (str fizz buzz) + (zero? (mod i 3)) fizz + (zero? (mod i 5)) buzz + :else i)])] + (prn results))))) + % := {} + (swap! !n inc) % := {}) From 3da675843d8ca2be67d5c38b88e3815efff89d81 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Fri, 26 Jan 2024 10:47:02 +0100 Subject: [PATCH 060/428] diff-by glitch fix, runtime tests - diff-by, cursor, fizzbuzz --- src/hyperfiddle/electric/impl/runtime_de.cljc | 2 +- src/hyperfiddle/electric_de.cljc | 4 +- .../electric/impl/runtime_test.cljc | 38 +++++++++++++------ 3 files changed, 30 insertions(+), 14 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 58fc1d5a7..8fd0a9045 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -188,7 +188,7 @@ (def ap (partial i/latest-product (fn [f & args] (apply f args)))) -(def singletons (comp (partial i/latest-product (comp (partial m/signal i/combine) i/fixed)) i/items)) +(def fixed-signals (comp (partial m/signal i/combine) i/fixed)) (def peer-slot-input 0) (def peer-slot-store 1) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 6c21b6750..9af718ef3 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -8,7 +8,7 @@ #?(:cljs (:require-macros hyperfiddle.electric-de))) (defmacro join [flow] `(::lang/join ~flow)) -(defmacro input [flow] `(join (i/fixed ~flow))) +(defmacro input [& flows] `(join (r/fixed-signals ~@flows))) (defmacro watch [ref] `(input (m/watch ~ref))) (defmacro ctor [expr] `(::lang/ctor ~expr)) (defmacro call [ctor] `(::lang/call ~ctor)) @@ -18,7 +18,7 @@ `(ctor (let [~@(interleave bs (eduction (map #(list ::lang/lookup %)) (range)))] ~@body))) -(defmacro cursor [[sym v] & body] `(call (r/bind-args (fn [~sym] ~@body) (join (r/singletons (pure ~v)))))) +(defmacro cursor [[sym v] & body] `(call (r/bind-args (fn [~sym] ~@body) (r/fixed-signals (join (i/items (pure ~v))))))) (defmacro diff-by [f xs] `(join (i/diff-by ~f (join (i/items (pure ~xs)))))) ;; (defmacro drain [expr] `(join (i/drain (pure ~expr)))) (defmacro client [& body] `(::lang/site :client ~@body)) diff --git a/test/hyperfiddle/electric/impl/runtime_test.cljc b/test/hyperfiddle/electric/impl/runtime_test.cljc index 82f66381a..9619ac665 100644 --- a/test/hyperfiddle/electric/impl/runtime_test.cljc +++ b/test/hyperfiddle/electric/impl/runtime_test.cljc @@ -1,5 +1,6 @@ (ns hyperfiddle.electric.impl.runtime-test - (:require [missionary.core :as m] + (:require [hyperfiddle.incseq :as i] + [missionary.core :as m] [hyperfiddle.electric-de :as e] #?(:clj [hyperfiddle.electric.impl.lang-de2 :as l]) [hyperfiddle.electric.impl.runtime-de :as r] @@ -44,20 +45,35 @@ (reset! !bar :BAR) % := {:degree 3, :permutation {}, :grow 0, :shrink 0, :change {1 :BAR}, :freeze #{}}) +(tests + (def !xs (atom [0 1 2])) + (on-diff! rcf/tap (root-frame (e/diff-by identity (e/watch !xs)))) + % := {:degree 3, :permutation {}, :grow 3, :shrink 0, :change {0 0, 1 1, 2 2}, :freeze #{}} + (swap! !xs conj 3) + % := {:degree 4, :permutation {}, :grow 1, :shrink 0, :change {3 3}, :freeze #{}}) + +(tests + (def !xs (atom [0 1 2])) + (on-diff! rcf/tap (root-frame (e/cursor [x (e/diff-by identity (e/watch !xs))] (+ x x)))) + % := {:degree 3, :permutation {}, :grow 3, :shrink 0, :change {0 0, 1 2, 2 4}, :freeze #{}} + (swap! !xs conj 3) + % := {:degree 4, :permutation {}, :grow 1, :shrink 0, :change {3 6}, :freeze #{}}) + (tests (def !n (atom 20)) (def !fizz (atom "Fizz")) (def !buzz (atom "Buzz")) (on-diff! rcf/tap (root-frame (e/server (let [fizz (e/watch !fizz) ; i/fixed + m/watch + e/join buzz (e/watch !buzz) - is (e/diff-by identity (range 1 (inc (e/watch !n)))) ; variable in time and space - results (e/cursor [i is] - [i (cond - (zero? (mod i (* 3 5))) (str fizz buzz) - (zero? (mod i 3)) fizz - (zero? (mod i 5)) buzz - :else i)])] - (prn results))))) - % := {} + is (e/diff-by identity (range 1 (inc (e/watch !n))))] ; variable in time and space + (e/cursor [i is] + [i (cond + (zero? (mod i (* 3 5))) (str fizz buzz) + (zero? (mod i 3)) fizz + (zero? (mod i 5)) buzz + :else i)]))))) + % := {:degree 20, :permutation {}, :grow 20, :shrink 0, :change {0 [1 1], 7 [8 8], 1 [2 2], 4 [5 "Buzz"], 15 [16 16], 13 [14 14], 6 [7 7], 17 [18 "Fizz"], 3 [4 4], 12 [13 13], 2 [3 "Fizz"], 19 [20 "Buzz"], 11 [12 "Fizz"], 9 [10 "Buzz"], 5 [6 "Fizz"], 14 [15 "FizzBuzz"], 16 [17 17], 10 [11 11], 18 [19 19], 8 [9 "Fizz"]}, :freeze #{}} (swap! !n inc) - % := {}) + % := {:degree 21, :permutation {}, :grow 1, :shrink 0, :change {20 [21 "Fizz"]}, :freeze #{}} + (reset! !fizz "Fuzz") + % := {:degree 21, :permutation {}, :grow 0, :shrink 0, :change {20 [21 "Fuzz"], 2 [3 "Fuzz"], 5 [6 "Fuzz"], 8 [9 "Fuzz"], 11 [12 "Fuzz"], 14 [15 "FuzzBuzz"], 17 [18 "Fuzz"]}, :freeze #{}}) From 6ed375fc12a5ea48a01a87f066ef8c51b7bc895b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Fri, 26 Jan 2024 11:25:04 +0100 Subject: [PATCH 061/428] parallel cursor, test sql join --- src/hyperfiddle/electric_de.cljc | 11 +++++++- .../electric/impl/runtime_test.cljc | 25 +++++++++++++++++++ 2 files changed, 35 insertions(+), 1 deletion(-) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 9af718ef3..f32e908f4 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -18,8 +18,17 @@ `(ctor (let [~@(interleave bs (eduction (map #(list ::lang/lookup %)) (range)))] ~@body))) -(defmacro cursor [[sym v] & body] `(call (r/bind-args (fn [~sym] ~@body) (r/fixed-signals (join (i/items (pure ~v))))))) + (defmacro diff-by [f xs] `(join (i/diff-by ~f (join (i/items (pure ~xs)))))) ;; (defmacro drain [expr] `(join (i/drain (pure ~expr)))) (defmacro client [& body] `(::lang/site :client ~@body)) (defmacro server [& body] `(::lang/site :server ~@body)) + +(defmacro cursor [bindings & body] + (case bindings + [] `(do ~@body) + (let [[args exprs] (apply map vector (partition-all 2 bindings))] + `(call (r/bind-args (fn ~args ~@body) + ~@(map (clojure.core/fn [expr] + `(r/fixed-signals (join (i/items (pure ~expr))))) + exprs)))))) \ No newline at end of file diff --git a/test/hyperfiddle/electric/impl/runtime_test.cljc b/test/hyperfiddle/electric/impl/runtime_test.cljc index 9619ac665..3b1c822e7 100644 --- a/test/hyperfiddle/electric/impl/runtime_test.cljc +++ b/test/hyperfiddle/electric/impl/runtime_test.cljc @@ -77,3 +77,28 @@ % := {:degree 21, :permutation {}, :grow 1, :shrink 0, :change {20 [21 "Fizz"]}, :freeze #{}} (reset! !fizz "Fuzz") % := {:degree 21, :permutation {}, :grow 0, :shrink 0, :change {20 [21 "Fuzz"], 2 [3 "Fuzz"], 5 [6 "Fuzz"], 8 [9 "Fuzz"], 11 [12 "Fuzz"], 14 [15 "FuzzBuzz"], 17 [18 "Fuzz"]}, :freeze #{}}) + +(tests + (def !animals + (atom [{:name "betsy" :owner "brian" :kind "cow"} + {:name "jake" :owner "brian" :kind "horse"} + {:name "josie" :owner "dawn" :kind "cow"}])) + (def !personalities + (atom [{:kind "cow" :personality "stoic"} + {:kind "horse" :personality "skittish"}])) + (on-diff! rcf/tap + (root-frame + (let [ks #{:kind}] + (e/cursor [animal (e/diff-by identity (e/watch !animals)) + personality (e/diff-by identity (e/watch !personalities))] + (if (= (select-keys animal ks) (select-keys personality ks)) + (merge animal personality) (e/amb)))))) + % := {:degree 3, :permutation {}, :grow 3, :shrink 0, :freeze #{}, + :change {0 {:name "betsy", :owner "brian", :kind "cow", :personality "stoic"}, + 1 {:name "jake", :owner "brian", :kind "horse", :personality "skittish"}, + 2 {:name "josie", :owner "dawn", :kind "cow", :personality "stoic"}}} + (swap! !animals conj {:name "bob" :owner "jack" :kind "horse"}) + % := {:degree 4, :permutation {}, :grow 1, :shrink 0, :freeze #{}, + :change {3 {:name "bob", :owner "jack", :kind "horse", :personality "skittish"}}} + (swap! !animals pop) + % := {:degree 4, :permutation {}, :grow 0, :shrink 1, :change {}, :freeze #{}}) \ No newline at end of file From c27720798e2a84b8861e2de0eba82516a3a4226f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Fri, 26 Jan 2024 11:53:03 +0100 Subject: [PATCH 062/428] cursor docstring --- src/hyperfiddle/electric_de.cljc | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index f32e908f4..9520386ae 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -24,7 +24,18 @@ (defmacro client [& body] `(::lang/site :client ~@body)) (defmacro server [& body] `(::lang/site :server ~@body)) -(defmacro cursor [bindings & body] +(defmacro cursor " +Syntax : +```clojure +(cursor [sym1 table1 + sym2 table2 + ,,, ,,, + symN tableN] + & body) +``` +For each tuple in the cartesian product of `table1 table2 ,,, tableN`, calls body in an implicit `do` with symbols +`sym1 sym2 ,,, symN` bound to the singleton tables for this tuple. Returns the concatenation of all body results. +" [bindings & body] (case bindings [] `(do ~@body) (let [[args exprs] (apply map vector (partition-all 2 bindings))] From d49f979fd50c6aa8658ab70780ec31458a098d74 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Fri, 26 Jan 2024 13:15:25 +0100 Subject: [PATCH 063/428] diff-by docstring --- src/hyperfiddle/electric_de.cljc | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 9520386ae..f55d79533 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -19,7 +19,14 @@ (let [~@(interleave bs (eduction (map #(list ::lang/lookup %)) (range)))] ~@body))) -(defmacro diff-by [f xs] `(join (i/diff-by ~f (join (i/items (pure ~xs)))))) +(defmacro diff-by " +Syntax : +```clojure +(diff-by kf xs) +``` +Stabilizes successive states of collection `xs` with function `kf`. Returns each item as a table. +" [f xs] `(join (i/diff-by ~f (join (i/items (pure ~xs)))))) + ;; (defmacro drain [expr] `(join (i/drain (pure ~expr)))) (defmacro client [& body] `(::lang/site :client ~@body)) (defmacro server [& body] `(::lang/site :server ~@body)) From 90d729ed2f7c34e1b44d400ad7aba49aed1a1d63 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Fri, 26 Jan 2024 13:24:57 +0100 Subject: [PATCH 064/428] amb, input, watch docstrings --- src/hyperfiddle/electric_de.cljc | 28 +++++++++++++++++++++++++--- 1 file changed, 25 insertions(+), 3 deletions(-) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index f55d79533..90dd67b92 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -8,17 +8,39 @@ #?(:cljs (:require-macros hyperfiddle.electric-de))) (defmacro join [flow] `(::lang/join ~flow)) -(defmacro input [& flows] `(join (r/fixed-signals ~@flows))) -(defmacro watch [ref] `(input (m/watch ~ref))) (defmacro ctor [expr] `(::lang/ctor ~expr)) (defmacro call [ctor] `(::lang/call ~ctor)) (defmacro pure [v] `(::lang/pure ~v)) -(defmacro amb [& exprs] `(call (join (r/pure ~@(mapv #(list `ctor %) exprs))))) + (defmacro fn [bs & body] `(ctor (let [~@(interleave bs (eduction (map #(list ::lang/lookup %)) (range)))] ~@body))) +(defmacro amb " +Syntax : +```clojure +(amb table1 table2 ,,, tableN) +``` +Returns the concatenation of `table1 table2 ,,, tableN`. +" [& exprs] `(call (join (r/pure ~@(mapv #(list `ctor %) exprs))))) + +(defmacro input " +Syntax : +```clojure +(input cf) +``` +Returns the current state of current continuous flow `cf`. +" [& flows] `(join (r/fixed-signals ~@flows))) + +(defmacro watch " +Syntax : +```clojure +(watch !ref) +``` +Returns the current state of current reference `!ref`. +" [ref] `(input (m/watch ~ref))) + (defmacro diff-by " Syntax : ```clojure From 772dc492db2e12f552470882e82ef431c6e95b17 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Fri, 26 Jan 2024 13:30:39 +0100 Subject: [PATCH 065/428] pure, join docstrings --- src/hyperfiddle/electric_de.cljc | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 90dd67b92..886497761 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -7,10 +7,24 @@ [hyperfiddle.electric-local-def-de :as l]) #?(:cljs (:require-macros hyperfiddle.electric-de))) -(defmacro join [flow] `(::lang/join ~flow)) (defmacro ctor [expr] `(::lang/ctor ~expr)) (defmacro call [ctor] `(::lang/call ~ctor)) -(defmacro pure [v] `(::lang/pure ~v)) + +(defmacro pure " +Syntax : +```clojure +(pure table) +``` +Returns the incremental sequence describing `table`. +" [expr] `(::lang/pure ~expr)) + +(defmacro join " +Syntax : +```clojure +(join incseq) +``` +Returns the successive states of items described by `incseq`. +" [flow] `(::lang/join ~flow)) (defmacro fn [bs & body] `(ctor From 9cccd8c21686bcb944d30e18d8ff5caa8b2714d8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Fri, 26 Jan 2024 17:17:32 +0100 Subject: [PATCH 066/428] as-vec, for-by - impl + docstring + test --- src/hyperfiddle/electric_de.cljc | 30 ++++++++++++++++++- .../electric/impl/runtime_test.cljc | 21 ++++++++++++- 2 files changed, 49 insertions(+), 2 deletions(-) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 886497761..9c3f2f7cb 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -85,4 +85,32 @@ For each tuple in the cartesian product of `table1 table2 ,,, tableN`, calls bod `(call (r/bind-args (fn ~args ~@body) ~@(map (clojure.core/fn [expr] `(r/fixed-signals (join (i/items (pure ~expr))))) - exprs)))))) \ No newline at end of file + exprs)))))) + +(defmacro as-vec " +Syntax : +```clojure +(as-vec table) +``` +Returns a single vector containing elements of `table`. +" [expr] `(input (m/reductions i/patch-vec (pure ~expr)))) + +(defmacro for-by " +Syntax : +```clojure +(for-by kf [sym1 coll1 + sym2 coll2 + ,,, ,,, + symN collN] + & body) +``` +Stabilizes successives states of `coll1 coll2 ,,, collN` with function `kf`. For each tuple in the cartesian product of +resulting tables, calls body in an implicit `do` with symbols `sym1 sym2 ,,, symN` bound to the singleton tables for +this tuple. Returns the concatenation of all body results as a single vector. +" [kf bindings & body] + `(as-vec + ~((clojure.core/fn rec [bindings] + (if-some [[sym expr & bindings] bindings] + `(cursor [~sym (diff-by ~kf ~expr)] + ~(rec bindings)) `(do ~@body))) + (seq bindings)))) \ No newline at end of file diff --git a/test/hyperfiddle/electric/impl/runtime_test.cljc b/test/hyperfiddle/electric/impl/runtime_test.cljc index 3b1c822e7..36a9f147f 100644 --- a/test/hyperfiddle/electric/impl/runtime_test.cljc +++ b/test/hyperfiddle/electric/impl/runtime_test.cljc @@ -101,4 +101,23 @@ % := {:degree 4, :permutation {}, :grow 1, :shrink 0, :freeze #{}, :change {3 {:name "bob", :owner "jack", :kind "horse", :personality "skittish"}}} (swap! !animals pop) - % := {:degree 4, :permutation {}, :grow 0, :shrink 1, :change {}, :freeze #{}}) \ No newline at end of file + % := {:degree 4, :permutation {}, :grow 0, :shrink 1, :change {}, :freeze #{}}) + +(tests + (def !x (atom "hello")) + (def !y (atom "electric")) + (on-diff! rcf/tap + (root-frame (e/as-vec (e/amb (e/watch !x) (e/watch !y))))) + % := {:degree 1, :permutation {}, :grow 1, :shrink 0, :change {0 ["hello" "electric"]}, :freeze #{}} + (reset! !y "world") + % := {:degree 1, :permutation {}, :grow 0, :shrink 0, :change {0 ["hello" "world"]}, :freeze #{}}) + +(tests + (def !n (atom 3)) + (on-diff! rcf/tap + (root-frame (e/for-by identity [x (range (e/watch !n)) + y (range x)] + [x y]))) + % := {:degree 1, :permutation {}, :grow 1, :shrink 0, :change {0 [[1 0] [2 0] [2 1]]}, :freeze #{}} + (swap! !n inc) + % := {:degree 1, :permutation {}, :grow 0, :shrink 0, :change {0 [[1 0] [2 0] [2 1] [3 0] [3 1] [3 2]]}, :freeze #{}}) \ No newline at end of file From 511fc0c5d386de2583c39a66ac664705c21b38a5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Fri, 26 Jan 2024 18:30:27 +0100 Subject: [PATCH 067/428] drain - impl + docstring + test --- src/hyperfiddle/electric/impl/runtime_de.cljc | 5 +++++ src/hyperfiddle/electric_de.cljc | 9 ++++++++- test/hyperfiddle/electric/impl/runtime_test.cljc | 11 ++++++++++- 3 files changed, 23 insertions(+), 2 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 8fd0a9045..7c137ae96 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -190,6 +190,11 @@ (def fixed-signals (comp (partial m/signal i/combine) i/fixed)) +(defn drain [incseq] + (m/ap + (m/amb (i/empty-diff 0) + (do (m/?> incseq) (m/amb))))) + (def peer-slot-input 0) (def peer-slot-store 1) (def peer-slots 2) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 9c3f2f7cb..5852c8e8d 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -63,7 +63,14 @@ Syntax : Stabilizes successive states of collection `xs` with function `kf`. Returns each item as a table. " [f xs] `(join (i/diff-by ~f (join (i/items (pure ~xs)))))) -;; (defmacro drain [expr] `(join (i/drain (pure ~expr)))) +(defmacro drain " +Syntax : +```clojure +(drain expr) +``` +Samples and discards `expr` synchronously with changes. Returns nothing. +" [expr] `(join (r/drain (pure ~expr)))) + (defmacro client [& body] `(::lang/site :client ~@body)) (defmacro server [& body] `(::lang/site :server ~@body)) diff --git a/test/hyperfiddle/electric/impl/runtime_test.cljc b/test/hyperfiddle/electric/impl/runtime_test.cljc index 36a9f147f..ed429dd06 100644 --- a/test/hyperfiddle/electric/impl/runtime_test.cljc +++ b/test/hyperfiddle/electric/impl/runtime_test.cljc @@ -120,4 +120,13 @@ [x y]))) % := {:degree 1, :permutation {}, :grow 1, :shrink 0, :change {0 [[1 0] [2 0] [2 1]]}, :freeze #{}} (swap! !n inc) - % := {:degree 1, :permutation {}, :grow 0, :shrink 0, :change {0 [[1 0] [2 0] [2 1] [3 0] [3 1] [3 2]]}, :freeze #{}}) \ No newline at end of file + % := {:degree 1, :permutation {}, :grow 0, :shrink 0, :change {0 [[1 0] [2 0] [2 1] [3 0] [3 1] [3 2]]}, :freeze #{}}) + +(tests + (def !x (atom 0)) + (on-diff! rcf/tap + (root-frame (e/drain (rcf/tap (e/watch !x))))) + % := 0 + % := {:degree 0, :permutation {}, :grow 0, :shrink 0, :change {}, :freeze #{}} + (swap! !x inc) + % := 1) \ No newline at end of file From 81b27d5d24ebab36451c32a80b910de8df4c2c83 Mon Sep 17 00:00:00 2001 From: xificurC Date: Fri, 26 Jan 2024 22:26:22 +0100 Subject: [PATCH 068/428] compiler: fix cljs var resolving This commit removes some strictness from the compiler's symbol analysis and allows unknown symbols to pass through optimistically as vars. Before we'd not compile and produce a helpful error message. Now the error message might be less helpful, depending on what happens during cljs compilation. It might result in an unfriendly runtime error. The long term goal is to write our own, pure analyzer. This is a short term fix to unblock DE. Note this is broken in current v2 IC version too, so this is strictly an improvement. --- src/hyperfiddle/electric/impl/lang_de2.clj | 21 +++++++++++++++---- .../electric/impl/compiler_test.cljc | 16 +++++++++++--- .../electric/impl/expand_de_test.cljc | 4 ++-- .../impl/expand_require_referred.cljc | 2 ++ 4 files changed, 34 insertions(+), 9 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index bc91551bc..d1ce497da 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -88,7 +88,7 @@ (if (::cljs-env env) env (assoc env ::cljs-env - (if (contains? env :js-globals) + (if (contains? (:ns env) :requires) env (let [nssym (get-ns env)] (cond-> (->cljs-env nssym) nssym (enrich-for-require-macros-lookup nssym))))))) @@ -126,6 +126,7 @@ (cljs-ana/empty-env) (require '[hyperfiddle.electric.impl.expand :as expand]) (cljs.env/ensure (resolve-cljs (cljs-ana/empty-env) 'prn)) + (ensure-cljs-compiler (cljs-ana/parse 'ns (->cljs-env) '(ns foo (:require [hyperfiddle.electric :as e])) 'ns {})) ) (defn macroexpand-clj [o] (serialized-require (ns-name *ns*)) (macroexpand-1 o)) @@ -462,6 +463,11 @@ {:db/id e, ::parent pe, ::type ::var, ::var form, ::qualified-var (untwin (:name v))} {:db/id e, ::parent pe, ::type ::static, ::v form}))) +(defn resolve-cljs-alias [env sym] + (if (simple-symbol? sym) + (symbol (-> env :ns :name str) (name sym)) + (or (cljs-ana/resolve-ns-alias env sym) (cljs-ana/resolve-macro-ns-alias env sym)))) + (defn ->let-val-e [ts e] (first (get-children-e ts e))) (defn ->let-body-e [ts e] (second (get-children-e ts e))) @@ -547,13 +553,20 @@ (cannot-resolve! env form)) :cljs (if-some [v (analyze-cljs-symbol form e pe env)] (-> (ts/add ts (assoc v ::resolved-in :cljs)) (?add-source-map e form)) - (cannot-resolve! env form)) + ;; optimistically resolve on cljs + ;; we don't load the whole ns file so we cannot resolve all vars + ;; loading the whole ns would undermine previous work + (let [sym (resolve-cljs-alias env form)] + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::var, ::var form, ::qualified-var (untwin sym), ::resolved-in :cljs}) + (?add-source-map e form)))) #_unsited (let [langs (set (vals (::peers env))) vs (->> langs (into #{} (map #(case % :clj (analyze-clj-symbol form e pe) - :cljs (analyze-cljs-symbol form e pe env)))))] + :cljs (or (analyze-cljs-symbol form e pe env) + (let [sym (resolve-cljs-alias env form)] + {:db/id e, ::parent pe, ::type ::var, ::var form, ::qualified-var (untwin sym), :cljs true}))))))] (cond (contains? vs nil) (cannot-resolve! env form) - (> (count vs) 1) (ambiguous-resolve! env form) + (> (count (into #{} (map ::qualified-var) vs)) 1) (ambiguous-resolve! env form) :else (-> (ts/add ts (first vs)) (?add-source-map e form)))))))) :else diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index ec9528d3e..7a240b837 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -7,6 +7,7 @@ #?(:clj [hyperfiddle.electric.impl.compiler-test-clj :refer [cannot-be-unsited]] :cljs [hyperfiddle.electric.impl.compiler-test-cljs :refer [cannot-be-unsited]]) [hyperfiddle.rcf :as rcf :refer [tests]] + [hyperfiddle.electric.impl.expand-require-referred :as ref :refer [referred referred-fn]] #?(:clj [contrib.test-match :as tm]) [fipp.edn] [missionary.core :as m]) @@ -33,6 +34,11 @@ (when (not= ret# match#) (fipp.edn/pprint match#)) match#)) +;; no `:=`, these just need to compile +(tests (l/test-compile ::Main (lang/->cljs-env) referred-fn)) +(tests (l/test-compile ::Main (lang/->cljs-env) ref/referred-fn)) +(tests (l/test-compile ::Main (lang/->cljs-env) hyperfiddle.electric.impl.expand-require-referred/referred-fn)) + (tests "test-simplest" (match (l/test-compile ::Main 1) `[(r/cdef 0 [] [] nil @@ -412,10 +418,14 @@ (fn [~'frame] (r/lookup ~'frame 0)))])) -;; (defn should-work-in-cljs []) +(defn should-work-in-cljs []) -;; (tests "test-unsited-cljs-fn" -;; (match (l/test-compile ::Main (should-work-in-cljs)))) +(tests "test-unsited-cljs-fn" + (match (l/test-compile ::Main (should-work-in-cljs)) + `[(r/cdef 0 [] [] nil + (fn [~'frame] + (r/ap (r/lookup ~'frame ::should-work-in-cljs + (r/pure should-work-in-cljs)))))])) (comment (l/test-compile ::Main (let [fizz "fizz", buzz "buzz"] diff --git a/test/hyperfiddle/electric/impl/expand_de_test.cljc b/test/hyperfiddle/electric/impl/expand_de_test.cljc index 8153cf4f9..c77c61de7 100644 --- a/test/hyperfiddle/electric/impl/expand_de_test.cljc +++ b/test/hyperfiddle/electric/impl/expand_de_test.cljc @@ -3,7 +3,7 @@ #?(:clj [cljs.analyzer]) #?(:clj [hyperfiddle.electric.impl.lang-de2 :as l]) #?(:clj [hyperfiddle.electric.impl.runtime-de :as r]) - #?(:clj [hyperfiddle.electric :as-alias e]) + #?(:clj [hyperfiddle.electric-de :as e]) [hyperfiddle.electric.impl.expand-require-referred :as ref :refer [referred]] #?(:clj [hyperfiddle.rcf :as rcf :refer [tests]])) #?(:cljs (:require-macros [hyperfiddle.electric.impl.expand-macro :as mac :refer [twice]]))) @@ -185,6 +185,6 @@ (binding [*ns* (create-ns 'hyperfiddle.electric.impl.expand-unloaded)] (l/expand-all {::l/peers {:client :cljs, :server :clj} ::l/current :server, ::l/me :client - :ns 'hyperfiddle.electric.impl.expand-unloaded} + :ns {:name 'hyperfiddle.electric.impl.expand-unloaded}} '(let [x 1]))))) (throw (ex-info "clj macroexpansion for unloaded ns fails" {})))) diff --git a/test/hyperfiddle/electric/impl/expand_require_referred.cljc b/test/hyperfiddle/electric/impl/expand_require_referred.cljc index 76fa93ff8..5c46ed024 100644 --- a/test/hyperfiddle/electric/impl/expand_require_referred.cljc +++ b/test/hyperfiddle/electric/impl/expand_require_referred.cljc @@ -1,3 +1,5 @@ (ns hyperfiddle.electric.impl.expand-require-referred) (defmacro referred [] :referred) + +(defn referred-fn []) From 196d3fe34ea04250bc053c24cca72fd4bda8aaee Mon Sep 17 00:00:00 2001 From: xificurC Date: Fri, 26 Jan 2024 22:35:34 +0100 Subject: [PATCH 069/428] fix browser tests compilation --- src/hyperfiddle/electric/impl/runtime_de.cljc | 4 ++-- src/hyperfiddle/incseq.cljc | 6 ++---- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 7c137ae96..517ffdfe6 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -81,12 +81,12 @@ [^Frame frame] (.-ctor frame)) -(deftype Node [frame id] +(deftype Node [^Frame frame id] IFn (#?(:clj invoke :cljs -invoke) [_ step done] ((aget (.-signals frame) id) step done))) -(deftype Call [frame id] +(deftype Call [^Frame frame id] IFn (#?(:clj invoke :cljs -invoke) [_ step done] (let [cdef (ctor-cdef (frame-ctor frame))] diff --git a/src/hyperfiddle/incseq.cljc b/src/hyperfiddle/incseq.cljc index c0247c92f..f6c53707d 100644 --- a/src/hyperfiddle/incseq.cljc +++ b/src/hyperfiddle/incseq.cljc @@ -1357,9 +1357,7 @@ optional `compare` function, `clojure.core/compare` by default. :change {0 curr} :freeze #{}}))))))))))))))) -(def ^{:arglists '([incseq]) - :doc " -"} items +(def ^{:arglists '([incseq])} items (let [slot-lock 0 slot-busy 1 slot-buffer 2 @@ -1852,4 +1850,4 @@ optional `compare` function, `clojure.core/compare` by default. :change {0 (fn [n t] (n) (->Ps q #(% :cancel) #(%)))}}) (q {:grow 1 :degree 1 :shrink 0 :permutation {} :change {0 "hello"} :freeze #{}}) @ps := {:degree 2 :permutation {0 1, 1 0} :grow 1 :shrink 0 :change {0 "hello"} :freeze #{}} - (q) := :cancel))) \ No newline at end of file + (q) := :cancel))) From ebfd8a57f0d705845a19e0c7d3975d3c04f88b2a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Mon, 29 Jan 2024 11:59:22 +0100 Subject: [PATCH 070/428] binding test --- src/hyperfiddle/electric/impl/runtime_de.cljc | 11 ++++++++--- .../electric/impl/compiler_test.cljc | 18 ++++++++++++++++++ 2 files changed, 26 insertions(+), 3 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 517ffdfe6..22d175934 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -46,9 +46,14 @@ (deftype Ctor [^Peer peer key idx ^objects free env]) -(defn bind [^Ctor ctor k v] - (->Ctor (.-peer ctor) (.-key ctor) (.-idx ctor) (.-free ctor) - (assoc (.-env ctor) k v))) +(defn bind + ([^Ctor ctor] ctor) + ([^Ctor ctor k v] + (->Ctor (.-peer ctor) (.-key ctor) (.-idx ctor) (.-free ctor) + (assoc (.-env ctor) k v))) + ([^Ctor ctor k v & kvs] + (->Ctor (.-peer ctor) (.-key ctor) (.-idx ctor) (.-free ctor) + (apply assoc (.-env ctor) k v kvs)))) (defn bind-args [^Ctor ctor & args] (reduce (partial apply bind) ctor (eduction (map-indexed vector) args))) diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index 7a240b837..a0660f8a4 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -427,6 +427,24 @@ (r/ap (r/lookup ~'frame ::should-work-in-cljs (r/pure should-work-in-cljs)))))])) +(tests "binding" + (match (l/test-compile ::Main + (binding [inc dec, dec inc] + (inc (dec 0)))) + `[(r/cdef 0 [nil nil] [nil] nil + (fn [~'frame] + (r/define-node ~'frame 0 (r/lookup ~'frame :clojure.core/dec (r/pure dec))) + (r/define-node ~'frame 1 (r/lookup ~'frame :clojure.core/inc (r/pure inc))) + (r/define-call ~'frame 0 (r/ap (r/pure r/bind) + (r/pure (r/make-ctor ~'frame ::Main 1)) + (r/pure :clojure.core/inc) (r/node ~'frame 0) + (r/pure :clojure.core/dec) (r/node ~'frame 1))) + (r/join (r/call ~'frame 0)))) + (r/cdef 0 [] [] nil + (r/ap (r/lookup ~'frame :clojure.core/inc (r/pure inc)) + (r/ap (r/lookup ~'frame :clojure.core/dec (r/pure dec)) + (r/pure 0))))])) + (comment (l/test-compile ::Main (let [fizz "fizz", buzz "buzz"] (e/ctor (str fizz buzz))))) From 6a8c9be9a984b46398388496651e4b970b850747 Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 29 Jan 2024 13:15:09 +0100 Subject: [PATCH 071/428] compiler: ctor site clearing --- src/hyperfiddle/electric/impl/lang_de2.clj | 4 ++-- test/hyperfiddle/electric/impl/compiler_test.cljc | 14 +++++++++++++- 2 files changed, 15 insertions(+), 3 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index d1ce497da..594d5a41f 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -519,8 +519,8 @@ (?add-source-map e form) (ts/add {:db/id ce, ::parent e, ::type ::static, ::v form}))] (reduce (fn [ts nx] (analyze nx e ts)) ts2 refs)) - (::ctor) (let [e (->id)] (recur (second form) e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ctor}) - (?add-source-map e form)))) + (::ctor) (let [e (->id)] (recur (list ::site nil (second form)) e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ctor}) + (?add-source-map e form)))) (::call) (let [e (->id)] (recur (second form) e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::call}) (?add-source-map e form)))) (::pure) (let [e (->id)] (recur (second form) e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::pure}) diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index a0660f8a4..ba6572fb3 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -427,7 +427,19 @@ (r/ap (r/lookup ~'frame ::should-work-in-cljs (r/pure should-work-in-cljs)))))])) -(tests "binding" +(tests "test-ctor-site-clearing" + (match (l/test-compile ::Main (e/client (e/ctor (let [x 1] [x x])))) + `[(r/cdef 0 [] [] :client + (fn [~'frame] + (r/pure (r/make-ctor ~'frame ::Main 1)))) + (r/cdef 0 [nil] [] nil + (fn [~'frame] + (r/define-node ~'frame 0 (r/pure 1)) + (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure vector)) + (r/node ~'frame 0) + (r/node ~'frame 0))))])) + +#_(tests "binding" (match (l/test-compile ::Main (binding [inc dec, dec inc] (inc (dec 0)))) From 9aa14cf426696d1979eed7009079dbaff7adc323 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Mon, 29 Jan 2024 16:09:00 +0100 Subject: [PATCH 072/428] fixed binding test --- test/hyperfiddle/electric/impl/compiler_test.cljc | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index ba6572fb3..3c1b2c7be 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -447,10 +447,9 @@ (fn [~'frame] (r/define-node ~'frame 0 (r/lookup ~'frame :clojure.core/dec (r/pure dec))) (r/define-node ~'frame 1 (r/lookup ~'frame :clojure.core/inc (r/pure inc))) - (r/define-call ~'frame 0 (r/ap (r/pure r/bind) - (r/pure (r/make-ctor ~'frame ::Main 1)) - (r/pure :clojure.core/inc) (r/node ~'frame 0) - (r/pure :clojure.core/dec) (r/node ~'frame 1))) + (r/define-call ~'frame 0 (r/pure (r/bind (r/make-ctor ~'frame ::Main 1) + :clojure.core/inc (r/node ~'frame 0) + :clojure.core/dec (r/node ~'frame 1)))) (r/join (r/call ~'frame 0)))) (r/cdef 0 [] [] nil (r/ap (r/lookup ~'frame :clojure.core/inc (r/pure inc)) From d4d50c6991a2663df7e34e421eb35a1e0eb58688 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Tue, 30 Jan 2024 17:32:33 +0100 Subject: [PATCH 073/428] runtime type info --- src/hyperfiddle/electric/impl/runtime_de.cljc | 64 +++++++++++++++---- 1 file changed, 50 insertions(+), 14 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 22d175934..5de286e85 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -22,7 +22,50 @@ (#?(:clj invoke :cljs -invoke) [_ step done] ((apply i/fixed (map invariant values)) step done))) -(def pure (comp ->Pure vector)) +(def pure " +(FN (IS VOID)) +(FN (IS T) T) +(FN (IS T) T T) +(FN (IS T) T T T) +" (comp ->Pure vector)) + +(defn invoke + ([f] (f)) + ([f a] (f a)) + ([f a b] (f a b)) + ([f a b c] (f a b c)) + ([f a b c d] (f a b c d)) + ([f a b c d & es] (apply f a b c d es))) + +(deftype Ap [inputs] + IFn + (#?(:clj invoke :cljs -invoke) [_ step done] + ((apply i/latest-product invoke inputs) step done))) + +(def ap " +(FN (IS T) (IS (FN T))) +(FN (IS T) (IS (FN T A)) (IS A)) +(FN (IS T) (IS (FN T A B)) (IS A) (IS B)) +(FN (IS T) (IS (FN T A B C)) (IS A) (IS B) (IS C)) +" (comp ->Ap vector)) + +(def join " +(FN (IS T) (IS (IS T))) +" i/latest-concat) + +(def fixed-signals " +(FN (IS VOID)) +(FN (IS T) (CF T)) +(FN (IS T) (CF T) (CF T)) +(FN (IS T) (CF T) (CF T) (CF T)) +" (comp (partial m/signal i/combine) i/fixed)) + +(defn drain " +(FN (IS VOID) (IS T)) +" [incseq] + (m/ap + (m/amb (i/empty-diff 0) + (do (m/?> incseq) (m/amb))))) (defn error [^String msg] #?(:clj (Error. msg) @@ -46,8 +89,12 @@ (deftype Ctor [^Peer peer key idx ^objects free env]) -(defn bind - ([^Ctor ctor] ctor) +(defn bind " +(FN (CTOR T) (CTOR T)) +(FN (CTOR T) (CTOR T) (VAR A) (IS A)) +(FN (CTOR T) (CTOR T) (VAR A) (IS A) (VAR B) (IS B)) +(FN (CTOR T) (CTOR T) (VAR A) (IS A) (VAR B) (IS B) (VAR C) (IS C)) +" ([^Ctor ctor] ctor) ([^Ctor ctor k v] (->Ctor (.-peer ctor) (.-key ctor) (.-idx ctor) (.-free ctor) (assoc (.-env ctor) k v))) @@ -189,17 +236,6 @@ [^Frame frame id] (->Call frame id)) -(def join i/latest-concat) - -(def ap (partial i/latest-product (fn [f & args] (apply f args)))) - -(def fixed-signals (comp (partial m/signal i/combine) i/fixed)) - -(defn drain [incseq] - (m/ap - (m/amb (i/empty-diff 0) - (do (m/?> incseq) (m/amb))))) - (def peer-slot-input 0) (def peer-slot-store 1) (def peer-slots 2) From 31f6035c1c2049a05bae0e54e1cb73d6143f1504 Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 31 Jan 2024 09:43:51 +0100 Subject: [PATCH 074/428] compiler: binding, collapse ap with pures --- src/contrib/test_match.clj | 14 +- src/hyperfiddle/electric/impl/lang_de2.clj | 249 +++++++++++------- .../electric/impl/compiler_test.cljc | 22 +- 3 files changed, 171 insertions(+), 114 deletions(-) diff --git a/src/contrib/test_match.clj b/src/contrib/test_match.clj index bc25dcf54..694ad9c04 100644 --- a/src/contrib/test_match.clj +++ b/src/contrib/test_match.clj @@ -71,6 +71,14 @@ (pair [1] [:a :b]) := [[1 :a] [missing :b]] ) +(defn diffs-over-50%? [v] (> (/ (count ((group-by #(instance? Diff %) v) true)) (count v)) 0.5)) + +(tests + (diffs-over-50%? [1 2 3]) := false + (diffs-over-50%? [(->Diff 1 2) (->Diff 2 3) 3]) + (diffs-over-50%? [(->Diff 1 2) 2]) := false + (diffs-over-50%? [(->Diff 1 2) (->Diff 2 3)]) := true) + (defn test-match [v pat] (cond (coll? pat) (if (and (or (list? pat) (seq? pat)) (= `view (first pat))) @@ -105,9 +113,9 @@ [(conj ac v) false])) [(empty v) true] (pair v pat))) listy-v? (or (list? v) (seq? v)), listy-pat? (or (list? pat) (seq? pat))] - (if (and (seq v) (every? #(instance? Diff %) ret)) - (->Diff (into (empty v) (map #(.-a ^Diff %)) ret) - (into (empty pat) (map #(.-b ^Diff %)) (cond-> ret (not= listy-v? listy-pat?) reverse))) + (if (and (seq v) (diffs-over-50%? ret)) + (->Diff (into (empty v) (map #(if (instance? Diff %) (.-a ^Diff %) %)) ret) + (into (empty pat) (map #(if (instance? Diff %) (.-b ^Diff %) %)) (cond-> ret (not= listy-v? listy-pat?) reverse))) (cond-> ret (or (list? v) (seq? v)) reverse)))) (->Diff v pat))) (= `_& pat) ::dont-care diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 594d5a41f..33f051894 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -283,11 +283,6 @@ ;;; COMPILER ;;; ;;;;;;;;;;;;;;;; -(defn mksym [x & xs] - (if (or (symbol? x) (keyword? x)) - (symbol (namespace x) (apply str (name x) (map name (flatten xs)))) - (symbol (apply str (name x) (map name (flatten xs)))))) - (defn fail! ([env msg] (fail! env msg {})) ([env msg data] (throw (ex-info (str (when-some [d (::def env)] (str "in " d ":\n")) msg) @@ -423,7 +418,6 @@ (defn get-children-e [ts e] (-> ts :ave ::parent (get e))) (defn get-child-e [ts e] (first (get-children-e ts e))) -(defn get-root-e [ts] (get-child-e ts '_)) (defn find-let-ref [sym pe ts] (loop [pe pe] @@ -449,25 +443,40 @@ (untwin 'a) := 'a (untwin 'cljs.core/not-in-clj) := 'cljs.core/not-in-clj) -(defn analyze-clj-symbol [form e pe] +(defn analyze-clj-symbol [form] (if (resolve-static-field form) - {:db/id e, ::parent pe, ::type ::static, ::v form} + ::static (when-some [v (resolve form)] - (if (var? v) - {:db/id e, ::parent pe, ::type ::var, ::var form, ::qualified-var (symbol v)} - {:db/id e, ::parent pe, ::type ::static, ::v form})))) + (if (var? v) (symbol v) ::static)))) -(defn analyze-cljs-symbol [form e pe env] +(defn analyze-cljs-symbol [form env] (when-some [v (resolve-cljs (::cljs-env env) form)] - (if (= :var (:op v)) - {:db/id e, ::parent pe, ::type ::var, ::var form, ::qualified-var (untwin (:name v))} - {:db/id e, ::parent pe, ::type ::static, ::v form}))) + (if (= :var (:op v)) (untwin (:name v)) ::static))) (defn resolve-cljs-alias [env sym] (if (simple-symbol? sym) (symbol (-> env :ns :name str) (name sym)) (or (cljs-ana/resolve-ns-alias env sym) (cljs-ana/resolve-macro-ns-alias env sym)))) +(defn assume-cljs-var [sym env] (untwin (resolve-cljs-alias env sym))) + +(defn resolve-symbol [sym env] + (case (get (::peers env) (::current env)) + :clj (let [v (analyze-clj-symbol sym)] (case v nil (cannot-resolve! env sym) #_else [:clj v])) + :cljs [:cljs (or (analyze-cljs-symbol sym env) + ;; optimistically resolve on cljs + ;; we don't load the whole ns file so we cannot resolve all vars + ;; loading the whole ns would undermine previous work + (assume-cljs-var sym env))] + #_unsited (let [langs (set (vals (::peers env))) + vs (->> langs (into #{} (map #(case % + :clj (analyze-clj-symbol sym) + :cljs (or (analyze-cljs-symbol sym env) + (assume-cljs-var sym env))))))] + (cond (contains? vs nil) (cannot-resolve! env sym) + (> (count vs) 1) (ambiguous-resolve! env sym) + :else [nil (first vs)])))) + (defn ->let-val-e [ts e] (first (get-children-e ts e))) (defn ->let-body-e [ts e] (second (get-children-e ts e))) @@ -492,7 +501,13 @@ ::site (::site nd) #_else (recur (::parent nd)))))) -(defn analyze [form pe {{::keys [env ->id]} :o :as ts}] +(defn get-lookup-key [sym env] + (let [[_ sym] (resolve-symbol sym env)] + (case sym + ::static (throw (ex-info (str "`" sym "` did not resolve as a var") {::form sym})) + #_else (keyword sym)))) + +(defn analyze [form pe env {{::keys [->id]} :o :as ts}] (cond (and (seq? form) (seq form)) (case (first form) @@ -500,10 +515,10 @@ (loopr [ts ts, pe pe] [[s v] (eduction (partition-all 2) bs)] (let [e (->id)] - (recur (analyze v e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::let, ::sym s}) - (update-in [:o ::env :locals s] assoc ::electric-let true, :db/id e) - (?add-source-map e form))) e)) - (analyze bform pe ts))) + (recur (analyze v e (update-in env [:locals s] assoc ::electric-let true, :db/id e) + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::let, ::sym s}) + (?add-source-map e form))) e)) + (analyze bform pe env ts))) (case) (let [[_ test & brs] form [default brs2] (if (odd? (count brs)) [(last brs) (butlast brs)] [:TODO brs])] (loopr [bs [], mp {}] @@ -511,67 +526,67 @@ (let [b (gensym "case-val")] (recur (conj bs b `(::ctor ~br)) (reduce (fn [ac nx] (assoc ac (list 'quote nx) b)) mp (if (seq v) v [v])))) - (recur (?meta form `(let* ~bs (::call (~mp ~test (::ctor ~default))))) pe ts))) - (quote) (ts/add ts {:db/id (->id), ::parent pe, ::type ::static, ::v form}) + (recur (?meta form `(let* ~bs (::call (~mp ~test (::ctor ~default))))) pe env ts))) + (quote) (let [e (->id)] + (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) + (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form}))) (fn*) (let [e (->id), ce (->id) [form refs] (closure env form) ts2 (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) - (?add-source-map e form) - (ts/add {:db/id ce, ::parent e, ::type ::static, ::v form}))] - (reduce (fn [ts nx] (analyze nx e ts)) ts2 refs)) - (::ctor) (let [e (->id)] (recur (list ::site nil (second form)) e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ctor}) - (?add-source-map e form)))) - (::call) (let [e (->id)] (recur (second form) e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::call}) + (ts/add {:db/id ce, ::parent e, ::type ::pure}) + (ts/add {:db/id (->id), ::parent ce, ::type ::literal, ::v form}) + (?add-source-map e form))] + (reduce (fn [ts nx] (analyze nx e env ts)) ts2 refs)) + (binding) (let [[_ bs bform] form, gs (repeatedly (/ (count bs) 2) gensym)] + (recur `(let* [~@(interleave gs (take-nth 2 (next bs)))] + (::call ((::static-vars r/bind) (::ctor ~bform) + ~@(interleave + (mapv #(get-lookup-key % env) (take-nth 2 bs)) + (mapv #(list ::pure %) gs))))) + pe env ts)) + (::ctor) (let [e (->id), ce (->id)] + (recur (list ::site nil (second form)) + ce env (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) + (ts/add {:db/id ce, ::parent e, ::type ::ctor}) + (?add-source-map e form)))) + (::call) (let [e (->id)] (recur (second form) e env (-> (ts/add ts {:db/id e, ::parent pe, ::type ::call}) (?add-source-map e form)))) - (::pure) (let [e (->id)] (recur (second form) e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::pure}) + (::pure) (let [e (->id)] (recur (second form) e env (-> (ts/add ts {:db/id e, ::parent pe, ::type ::pure}) (?add-source-map e form)))) - (::join) (let [e (->id)] (recur (second form) e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::join}) + (::join) (let [e (->id)] (recur (second form) e env (-> (ts/add ts {:db/id e, ::parent pe, ::type ::join}) (?add-source-map e form)))) (::site) (let [[_ site bform] form, e (->id)] - (recur bform e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::site, ::site site}) - (?add-source-map e form) - (update :o update ::env assoc ::current site)))) + (recur bform e (assoc env ::current site) + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::site, ::site site}) + (?add-source-map e form)))) (::lookup) (let [[_ sym] form] (ts/add ts {:db/id (->id), ::parent pe, ::type ::lookup, ::sym sym})) + (::static-vars) (recur (second form) pe (assoc env ::static-vars true) ts) #_else (let [e (->id)] - (reduce (fn [ts nx] (analyze nx e ts)) (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) + (reduce (fn [ts nx] (analyze nx e env ts)) (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) (?add-source-map e form)) form))) - (vector? form) (recur (?meta form (cons `vector form)) pe ts) - (map? form) (recur (?meta form (cons `hash-map (eduction cat form))) pe ts) + (vector? form) (recur (?meta form (cons `vector form)) pe env ts) + (map? form) (recur (?meta form (cons `hash-map (eduction cat form))) pe env ts) (symbol? form) (let [e (->id)] - (if-some [lr-e (find-let-ref form pe ts)] - (-> (ts/add ts {:db/id e, ::parent pe, ::type ::let-ref, ::ref lr-e, ::sym form}) - (?add-source-map e form)) - (if (contains? (:locals env) form) - (-> (ts/add ts {:db/id e, ::parent pe, ::type ::static, ::v form}) - (?add-source-map e form)) - (case (get (::peers env) (::current env)) - :clj (if-some [v (analyze-clj-symbol form e pe)] - (-> (ts/add ts (assoc v ::resolved-in :clj)) (?add-source-map e form)) - (cannot-resolve! env form)) - :cljs (if-some [v (analyze-cljs-symbol form e pe env)] - (-> (ts/add ts (assoc v ::resolved-in :cljs)) (?add-source-map e form)) - ;; optimistically resolve on cljs - ;; we don't load the whole ns file so we cannot resolve all vars - ;; loading the whole ns would undermine previous work - (let [sym (resolve-cljs-alias env form)] - (-> (ts/add ts {:db/id e, ::parent pe, ::type ::var, ::var form, ::qualified-var (untwin sym), ::resolved-in :cljs}) - (?add-source-map e form)))) - #_unsited (let [langs (set (vals (::peers env))) - vs (->> langs (into #{} (map #(case % - :clj (analyze-clj-symbol form e pe) - :cljs (or (analyze-cljs-symbol form e pe env) - (let [sym (resolve-cljs-alias env form)] - {:db/id e, ::parent pe, ::type ::var, ::var form, ::qualified-var (untwin sym), :cljs true}))))))] - (cond (contains? vs nil) (cannot-resolve! env form) - (> (count (into #{} (map ::qualified-var) vs)) 1) (ambiguous-resolve! env form) - :else (-> (ts/add ts (first vs)) (?add-source-map e form)))))))) + (-> (if-some [lr-e (find-let-ref form pe ts)] + (ts/add ts {:db/id e, ::parent pe, ::type ::let-ref, ::ref lr-e, ::sym form}) + (if (contains? (:locals env) form) + (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) + (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form})) + (let [[resolved-in sym] (resolve-symbol form env)] + (if (or (= ::static sym) (::static-vars env)) + (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) + (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form})) + (ts/add ts (cond-> {:db/id e, ::parent pe, ::type ::var, ::var form, ::qualified-var sym} + resolved-in (assoc ::resolved-in resolved-in))))))) + (?add-source-map e form))) :else (let [e (->id)] - (-> (ts/add ts {:db/id e, ::parent pe, ::type ::static, ::v form}) + (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) + (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form}) (?add-source-map e form))))) (defn ->->id [] (let [!i (long-array [-1])] (fn [] (aset !i 0 (unchecked-inc (aget !i 0)))))) @@ -584,12 +599,12 @@ ([nm form env] (ensure-cljs-compiler (let [->id (->->id), ->ctor-idx (->->id) - ts (analyze (expand-all env form) 0 (ts/add (ts/->ts {::->id ->id, ::env (ensure-cljs-env env)}) - {:db/id (->id), ::type ::ctor, ::parent '_})) + ts (analyze (expand-all env form) 0 (ensure-cljs-env env) + (ts/add (ts/->ts {::->id ->id}) {:db/id (->id), ::type ::ctor, ::parent '_})) mark-used-ctors (fn mark-used-ctors [ts e] (let [nd (get (:eav ts) e)] (case (::type nd) - (::static ::var ::lookup) ts + (::literal ::var ::lookup) ts (::ap) (reduce mark-used-ctors ts (get-children-e ts e)) (::site ::join ::pure ::call) (recur ts (get-child-e ts e)) (::ctor) (if (::ctor-idx nd) @@ -625,30 +640,43 @@ ::closed-ref ref-e, ::closed-over ::free}))) ensure-free-frees (fn ensure-free-frees [ts ref-e ctors-e] (reduce (fn [ts ctor-e] (ensure-free-free ts ref-e ctor-e)) ts ctors-e)) + in-a-call? (fn in-a-call? [ts e] + (loop [e (::parent (ts/->node ts e))] + (when-let [nd (ts/->node ts e)] + (case (::type nd) + ::call true + ::ctor false + #_else (recur (::parent nd)))))) handle-let-refs (fn handle-let-refs [ts e] ; nodes and frees (closed over) - (let [nd (get (:eav ts) e)] + (let [nd (ts/->node ts e)] (case (::type nd) - (::static ::var ::lookup) ts + (::literal ::var ::lookup) ts (::ap) (reduce handle-let-refs ts (get-children-e ts e)) (::site ::join ::pure ::ctor ::call) (recur ts (get-child-e ts e)) (::let) (recur ts (->let-body-e ts e)) (::let-ref) - (let [ref-nd (get (:eav ts) (::ref nd)) - ctors-e (loop [ac '(), e (::parent (get (:eav ts) e))] + (let [ref-nd (ts/->node ts (::ref nd)) + ctors-e (loop [ac '(), e (::parent (ts/->node ts e))] (if (= (::ref nd) e) ac - (recur (cond-> ac (= ::ctor (::type (get (:eav ts) e))) (conj e)) - (::parent (get (:eav ts) e))))) + (recur (cond-> ac (= ::ctor (::type (ts/->node ts e))) (conj e)) + (::parent (ts/->node ts e))))) ts (ts/asc ts (::ref nd) ::walked-val true) ; only walk binding once - ts (if (seq ctors-e) ; closed over + ts (cond + (in-a-call? ts e) + (-> (ts/upd ts (::ref nd) ::in-call #(conj (or % #{}) e)) + (ensure-node (::ref nd))) + + (seq ctors-e) ; closed over (-> ts (ensure-node (::ref nd)) (ensure-free-node (::ref nd) (first ctors-e)) (ensure-free-frees (::ref nd) (rest ctors-e))) - (cond-> (ts/upd ts (::ref nd) ::refcnt (fnil inc 0)) - (or (= 1 (::refcnt ref-nd)) - (not= (get-site ts (find-sitable-parent ts e)) - (get-site ts (->let-val-e ts (::ref nd))))) - (ensure-node (::ref nd))))] + + :else (cond-> (ts/upd ts (::ref nd) ::refcnt (fnil inc 0)) + (or (= 1 (::refcnt ref-nd)) + (not= (get-site ts (find-sitable-parent ts e)) + (get-site ts (->let-val-e ts (::ref nd))))) + (ensure-node (::ref nd))))] (cond-> ts (not (::walked-val ref-nd)) (recur (get-ret-e ts (->let-val-e ts (::ref nd)))))) #_else (throw (ex-info (str "cannot handle-let-refs on " (::type nd)) (or nd {})))))) @@ -657,7 +685,7 @@ mark-used-calls (fn mark-used-calls [ts ctor-e e] (let [nd (ts/->node ts e)] (case (::type nd) - (::static ::var ::lookup) ts + (::literal ::var ::lookup) ts (::ap) (reduce #(mark-used-calls % ctor-e %2) ts (get-children-e ts e)) (::site ::join ::pure) (recur ts ctor-e (get-child-e ts e)) (::ctor) (recur ts e (get-child-e ts e)) @@ -668,35 +696,54 @@ ctor-e (get-child-e ts e))) (::let) (recur ts ctor-e (->let-body-e ts e)) (::let-ref) (let [nx-e (get-ret-e ts (->let-val-e ts (::ref nd)))] - (recur ts (find-ctor-e ts nx-e) nx-e))))) - ts (-> ts (handle-let-refs 0) (mark-used-calls 0 (get-ret-e ts (get-child-e ts 0)))) + (recur ts (find-ctor-e ts nx-e) nx-e)) + #_else (throw (ex-info (str "cannot mark-used-calls on " (::type nd)) (or nd {})))))) + change-parent (fn change-parent [ts e pe] (ts/asc ts e ::parent pe)) + orphan (fn orphan [ts e] (change-parent ts e nil)) + collapse-ap-with-only-pures (fn collapse-ap-with-only-pures [ts] ; (r/ap (r/pure .)+ ) => (r/pure (. . .)) + (reduce (fn [ts ap-e] + (let [ap-nd (ts/->node ts ap-e) + children-e (get-children-e ts ap-e)] + (if (every? #(= ::pure (::type (ts/->node ts %))) children-e) + (let [e (->id), ce (->id)] + (reduce (fn [ts e] + (-> ts (change-parent (get-child-e ts e) ce) + (orphan e))) + (-> ts (ts/add {:db/id e, ::parent (::parent ap-nd), ::type ::pure}) + (ts/add {:db/id ce, ::parent e, ::type ::comp}) + (orphan ap-e)) + children-e)) + ts))) + ts (reverse (ts/find ts ::type ::ap)))) + ts (-> ts (handle-let-refs 0) + (mark-used-calls 0 (get-ret-e ts (get-child-e ts 0))) + collapse-ap-with-only-pures) gen (fn gen [ts ctor-e e] (let [nd (get (:eav ts) e)] (case (::type nd) - ::static (list `r/pure (::v nd)) + ::literal (::v nd) ::ap (list* `r/ap (mapv #(gen ts ctor-e %) (get-children-e ts e))) ::var (let [in (::resolved-in nd)] - (if (or (nil? in) (= in (->env-type env))) - (list `r/lookup 'frame (keyword (::qualified-var nd)) (list `r/pure (::qualified-var nd))) - (list `r/lookup 'frame (keyword (::qualified-var nd))))) + (list* `r/lookup 'frame (keyword (::qualified-var nd)) + (when (or (nil? in) (= in (->env-type env))) [(list `r/pure (::qualified-var nd))]))) ::join (list `r/join (gen ts ctor-e (get-child-e ts e))) ::pure (list `r/pure (gen ts ctor-e (get-child-e ts e))) + ::comp (doall (map #(gen ts ctor-e %) (get-children-e ts e))) ::site (recur ts ctor-e (get-child-e ts e)) - ::ctor (list `r/pure - (let [ctor (list `r/make-ctor 'frame nm (::ctor-idx nd)) - frees-e (-> ts :ave ::ctor-free (get e))] - (if (seq frees-e) - (list* `doto ctor - (mapv (fn [e] - (let [nd (ts/->node ts e)] - (list `r/define-free (::free-idx nd) - (case (::closed-over nd) - ::node (list `r/node 'frame (->node-idx ts (find-ctor-e ts (::ctor-free nd)) (::closed-ref nd))) - ::free (list `r/free 'frame (->> (ts/find ts ::ctor-free (find-ctor-e ts (::ctor-free nd)) - ::closed-ref (::closed-ref nd)) - first (ts/->node ts) ::free-idx)))))) - frees-e)) - ctor))) + ::ctor (let [ctor (list `r/make-ctor 'frame nm (::ctor-idx nd)) + frees-e (-> ts :ave ::ctor-free (get e))] + (if (seq frees-e) + (list* `doto ctor + (mapv (fn [e] + (let [nd (ts/->node ts e)] + (list `r/define-free (::free-idx nd) + (case (::closed-over nd) + ::node (list `r/node 'frame (->node-idx ts (find-ctor-e ts (::ctor-free nd)) (::closed-ref nd))) + ::free (list `r/free 'frame (->> (ts/find ts ::ctor-free (find-ctor-e ts (::ctor-free nd)) + ::closed-ref (::closed-ref nd)) + first (ts/->node ts) ::free-idx)))))) + frees-e)) + ctor)) ::call (list `r/join (list `r/call 'frame (::call-idx (ts/->node ts e)))) ::lookup (list `r/lookup 'frame (::sym nd)) ::let (recur ts ctor-e (get-ret-e ts (->let-body-e ts e))) diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index 3c1b2c7be..af9b40a8d 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -286,9 +286,10 @@ (r/pure :foo)))]) (match (l/test-compile ::Main (let [x (::lang/ctor :foo), y x] (::lang/call y))) - `[(r/cdef 0 [] [nil] nil + `[(r/cdef 0 [nil] [nil] nil (fn [~'frame] - (r/define-call ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) + (r/define-node ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) + (r/define-call ~'frame 0 (r/node ~'frame 0)) (r/join (r/call ~'frame 0)))) (r/cdef 0 [] [] nil (fn [~'frame] @@ -349,10 +350,11 @@ (tests "test-conditionals" ;; ({nil (ctor :y)} :x (ctor :z)) (match (l/test-compile ::Main (case :x nil :y :z)) - `[(r/cdef 0 [] [nil] nil + `[(r/cdef 0 [nil] [nil] nil (fn [~'frame] + (r/define-node ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) (r/define-call ~'frame 0 (r/ap (r/ap (r/lookup ~'frame :clojure.core/hash-map (r/pure clojure.core/hash-map)) - (r/pure 'nil) (r/pure (r/make-ctor ~'frame ::Main 1))) + (r/pure 'nil) (r/node ~'frame 0)) (r/pure :x) (r/pure (r/make-ctor ~'frame ::Main 2)))) (r/join (r/call ~'frame 0)))) @@ -409,8 +411,7 @@ (fn [~'frame] (r/ap (r/lookup ~'frame :clojure.core/str (r/pure clojure.core/str)) (r/free ~'frame 0) - (r/free ~'frame 1))))]) - ) + (r/free ~'frame 1))))])) (tests "test-lookup" (match (l/test-compile ::Main (::lang/lookup 0)) @@ -439,7 +440,7 @@ (r/node ~'frame 0) (r/node ~'frame 0))))])) -#_(tests "binding" +(tests "binding" (match (l/test-compile ::Main (binding [inc dec, dec inc] (inc (dec 0)))) @@ -452,9 +453,10 @@ :clojure.core/dec (r/node ~'frame 1)))) (r/join (r/call ~'frame 0)))) (r/cdef 0 [] [] nil - (r/ap (r/lookup ~'frame :clojure.core/inc (r/pure inc)) - (r/ap (r/lookup ~'frame :clojure.core/dec (r/pure dec)) - (r/pure 0))))])) + (fn [~'frame] + (r/ap (r/lookup ~'frame :clojure.core/inc (r/pure inc)) + (r/ap (r/lookup ~'frame :clojure.core/dec (r/pure dec)) + (r/pure 0)))))])) (comment (l/test-compile ::Main (let [fizz "fizz", buzz "buzz"] From 7e25ee4ca20cebf172b6bf2454939adf947a9a32 Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 31 Jan 2024 10:07:42 +0100 Subject: [PATCH 075/428] compiler: static vector and hash-map vars --- src/hyperfiddle/electric/impl/lang_de2.clj | 4 +- .../electric/impl/compiler_test.cljc | 66 ++++++++++--------- 2 files changed, 36 insertions(+), 34 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 33f051894..f80f3b622 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -565,8 +565,8 @@ (reduce (fn [ts nx] (analyze nx e env ts)) (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) (?add-source-map e form)) form))) - (vector? form) (recur (?meta form (cons `vector form)) pe env ts) - (map? form) (recur (?meta form (cons `hash-map (eduction cat form))) pe env ts) + (vector? form) (recur (?meta form (cons `(::static-vars vector) form)) pe env ts) + (map? form) (recur (?meta form (cons `(::static-vars hash-map) (eduction cat form))) pe env ts) (symbol? form) (let [e (->id)] diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index af9b40a8d..6fb4ac9d1 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -96,23 +96,23 @@ `[(r/cdef 0 [:client] [] :client (fn [~'frame] (r/define-node ~'frame 0 (r/pure :foo)) - (r/ap (r/lookup ~'frame :clojure.core/vector) + (r/ap (r/pure clojure.core/vector) (r/node ~'frame 0) (r/node ~'frame 0))))]) (match (l/test-compile ::Main (let [a :foo] [a a])) `[(r/cdef 0 [nil] [] nil (fn [~'frame] (r/define-node ~'frame 0 (r/pure :foo)) - (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure vector)) + (r/ap (r/pure clojure.core/vector) (r/node ~'frame 0) (r/node ~'frame 0))))]) (match (l/test-compile ::Main (let [a (let [b :foo] [b b])] [a a])) `[(r/cdef 0 [nil nil] [] nil (fn [~'frame] (r/define-node ~'frame 0 (r/pure :foo)) - (r/define-node ~'frame 1 (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure vector)) + (r/define-node ~'frame 1 (r/ap (r/pure clojure.core/vector) (r/node ~'frame 0) (r/node ~'frame 0))) - (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure vector)) + (r/ap (r/pure clojure.core/vector) (r/node ~'frame 1) (r/node ~'frame 1))))]) (match (l/test-compile ::Main (let [a 1] a)) @@ -128,7 +128,7 @@ (match (l/test-compile ::Main (::lang/site :client (let [x "Hello", y "world"] [x y]))) `[(r/cdef 0 [] [] :client (fn [~'frame] - (r/ap (r/lookup ~'frame :clojure.core/vector) + (r/ap (r/pure clojure.core/vector) (r/pure "Hello") (r/pure "world"))))]) (match (l/test-compile ::Main (::lang/site :client (let [a (::lang/site :server :foo)] (::lang/site :server (prn a))))) @@ -136,16 +136,17 @@ (clojure.core/fn [~'frame] (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure clojure.core/prn)) (r/pure :foo))))]) + (match (l/test-compile ::Main (concat (let [x 1] [x x]) (let [y 2] [y y]))) `[(r/cdef 0 [nil nil] [] nil (fn [~'frame] (r/define-node ~'frame 0 (r/pure 1)) (r/define-node ~'frame 1 (r/pure 2)) (r/ap (r/lookup ~'frame :clojure.core/concat (r/pure clojure.core/concat)) - (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure clojure.core/vector)) + (r/ap (r/pure clojure.core/vector) (r/node ~'frame 0) (r/node ~'frame 0)) - (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure clojure.core/vector)) + (r/ap (r/pure clojure.core/vector) (r/node ~'frame 1) (r/node ~'frame 1)))))])) @@ -205,7 +206,7 @@ (r/cdef 1 [nil] [] nil (fn [~'frame] (r/define-node ~'frame 0 (r/pure 2)) - (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure clojure.core/vector)) + (r/ap (r/pure clojure.core/vector) (r/free ~'frame 0) (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 2) (r/define-free 0 (r/node ~'frame 0))))))) @@ -241,7 +242,7 @@ (r/define-free 1 (r/node ~'frame 1)))))) (r/cdef 2 [] [] nil (fn [~'frame] - (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure clojure.core/vector)) + (r/ap (r/pure clojure.core/vector) (r/free ~'frame 0) (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 2) (r/define-free 0 (r/free ~'frame 1))))))) @@ -259,7 +260,7 @@ (r/define-free 1 (r/node ~'frame 1)))))) (r/cdef 2 [] [] nil (fn [~'frame] - (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure clojure.core/vector)) + (r/ap (r/pure clojure.core/vector) (r/free ~'frame 0) (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 2) (r/define-free 0 (r/free ~'frame 1))))))) @@ -273,7 +274,22 @@ (r/pure (r/make-ctor ~'frame ::Main 1)))) (r/cdef 0 [] [] nil (fn [~'frame] - (r/pure :foo)))])) + (r/pure :foo)))]) + + (match (l/test-compile ::Main (let [fizz "fizz", buzz "buzz"] + (e/ctor (str fizz buzz)))) + `[(r/cdef 0 [nil nil] [] nil + (fn [~'frame] + (r/define-node ~'frame 0 (r/pure "fizz")) + (r/define-node ~'frame 1 (r/pure "buzz")) + (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 1) + (r/define-free 0 (r/node ~'frame 0)) + (r/define-free 1 (r/node ~'frame 1)))))) + (r/cdef 2 [] [] nil + (fn [~'frame] + (r/ap (r/lookup ~'frame :clojure.core/str (r/pure clojure.core/str)) + (r/free ~'frame 0) + (r/free ~'frame 1))))])) (tests "test-call" (match (l/test-compile ::Main (::lang/call (::lang/ctor :foo))) @@ -311,7 +327,7 @@ (r/define-node ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) (r/define-call ~'frame 0 (r/node ~'frame 0)) (r/define-call ~'frame 1 (r/node ~'frame 0)) - (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure clojure.core/vector)) + (r/ap (r/pure clojure.core/vector) (r/join (r/call ~'frame 0)) (r/join (r/call ~'frame 1))))) (r/cdef 0 [] [] nil @@ -322,7 +338,7 @@ (fn [~'frame] (r/define-call ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) (r/define-call ~'frame 1 (r/pure (r/make-ctor ~'frame ::Main 2))) - (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure clojure.core/vector)) + (r/ap (r/pure clojure.core/vector) (r/join (r/call ~'frame 0)) (r/join (r/call ~'frame 1))))) (r/cdef 0 [] [] nil @@ -353,7 +369,7 @@ `[(r/cdef 0 [nil] [nil] nil (fn [~'frame] (r/define-node ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) - (r/define-call ~'frame 0 (r/ap (r/ap (r/lookup ~'frame :clojure.core/hash-map (r/pure clojure.core/hash-map)) + (r/define-call ~'frame 0 (r/ap (r/ap (r/pure clojure.core/hash-map) (r/pure 'nil) (r/node ~'frame 0)) (r/pure :x) (r/pure (r/make-ctor ~'frame ::Main 2)))) @@ -369,7 +385,7 @@ `[(r/cdef 0 [nil] [nil] nil (fn [~'frame] (r/define-node ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) - (r/define-call ~'frame 0 (r/ap (r/ap (r/lookup ~'frame :clojure.core/hash-map (r/pure clojure.core/hash-map)) + (r/define-call ~'frame 0 (r/ap (r/ap (r/pure clojure.core/hash-map) (r/pure '~'foo) (r/node ~'frame 0) (r/pure '~'bar) (r/node ~'frame 0)) (r/pure '~'foo) @@ -386,7 +402,7 @@ `[(r/cdef 0 [nil] [nil] nil (fn [~'frame] (r/define-node ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) - (r/define-call ~'frame 0 (r/ap (r/ap (r/lookup ~'frame :clojure.core/hash-map (r/pure clojure.core/hash-map)) + (r/define-call ~'frame 0 (r/ap (r/ap (r/pure clojure.core/hash-map) (r/pure 'nil) (r/node ~'frame 0) (r/pure 'false) (r/node ~'frame 0)) (r/pure 1) @@ -397,21 +413,7 @@ (r/pure 3))) (r/cdef 0 [] [] nil (fn [~'frame] - (r/pure 2)))]) - (match (l/test-compile ::Main (let [fizz "fizz", buzz "buzz"] - (e/ctor (str fizz buzz)))) - `[(r/cdef 0 [nil nil] [] nil - (fn [~'frame] - (r/define-node ~'frame 0 (r/pure "fizz")) - (r/define-node ~'frame 1 (r/pure "buzz")) - (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 1) - (r/define-free 0 (r/node ~'frame 0)) - (r/define-free 1 (r/node ~'frame 1)))))) - (r/cdef 2 [] [] nil - (fn [~'frame] - (r/ap (r/lookup ~'frame :clojure.core/str (r/pure clojure.core/str)) - (r/free ~'frame 0) - (r/free ~'frame 1))))])) + (r/pure 2)))])) (tests "test-lookup" (match (l/test-compile ::Main (::lang/lookup 0)) @@ -436,7 +438,7 @@ (r/cdef 0 [nil] [] nil (fn [~'frame] (r/define-node ~'frame 0 (r/pure 1)) - (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure vector)) + (r/ap (r/pure clojure.core/vector) (r/node ~'frame 0) (r/node ~'frame 0))))])) From a6a63b74e28ff59b357ba52baa8884c1269b9b41 Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 31 Jan 2024 10:11:43 +0100 Subject: [PATCH 076/428] compiler: add ap collapse test --- test/hyperfiddle/electric/impl/compiler_test.cljc | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index 6fb4ac9d1..ad8e5e986 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -442,7 +442,7 @@ (r/node ~'frame 0) (r/node ~'frame 0))))])) -(tests "binding" +(tests "test-binding" (match (l/test-compile ::Main (binding [inc dec, dec inc] (inc (dec 0)))) @@ -460,6 +460,12 @@ (r/ap (r/lookup ~'frame :clojure.core/dec (r/pure dec)) (r/pure 0)))))])) +(tests "test-ap-collapse" + (match (l/test-compile ::Main [1 2]) + `[(r/cdef 0 [] [] nil + (fn [~'frame] + (r/pure (clojure.core/vector 1 2))))])) + (comment (l/test-compile ::Main (let [fizz "fizz", buzz "buzz"] (e/ctor (str fizz buzz))))) From 7125350e507001a3b0799135f5ec375a01bcec9f Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 31 Jan 2024 14:04:18 +0100 Subject: [PATCH 077/428] cleanup --- .../electric/impl/compiler_test.cljc | 19 ------------------- 1 file changed, 19 deletions(-) diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index ad8e5e986..27dd9bbb3 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -552,25 +552,6 @@ ;; * the result site (comment - ;; conditionals - (l/compile ::Main `(case :x nil :y :z)) - := `[(r/cdef 0 [] [nil] nil - (fn [frame] - (r/define-call frame 0 - (r/ap - (r/ap - (r/lookup frame :clojure.core/hash-map (r/pure hash-map)) - (r/pure nil) (r/make-ctor frame ::Main 1)) - (r/pure :x) - (r/pure (r/make-ctor frame ::Main 2)))) - (r/join (r/call frame 0)))) - (r/cdef 0 [] [] nil - (fn [frame] - (r/pure :y))) - (r/cdef 0 [] [] nil - (fn [frame] - (r/pure :z)))] - (l/compile ::Main (new (e/fn Foo [] (Foo.)))) := `[(r/cdef 0 [] [nil] nil (fn [frame] From 60219091a68310259b6c011f9561e1217be27778 Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 31 Jan 2024 15:35:54 +0100 Subject: [PATCH 078/428] broken electric test shim --- src/hyperfiddle/electric/impl/lang_de2.clj | 361 ++++++++++----------- src/hyperfiddle/electric_local_def_de.cljc | 36 +- test/hyperfiddle/electric_de_test.cljc | 14 + 3 files changed, 211 insertions(+), 200 deletions(-) create mode 100644 test/hyperfiddle/electric_de_test.cljc diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index f80f3b622..4380005d2 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -595,184 +595,183 @@ (let [pe (::parent (get (:eav ts) e))] (if (or (nil? pe) (= ::ctor (::type (get (:eav ts) pe)))) pe (recur ts pe)))) -(defn compile - ([nm form env] - (ensure-cljs-compiler - (let [->id (->->id), ->ctor-idx (->->id) - ts (analyze (expand-all env form) 0 (ensure-cljs-env env) - (ts/add (ts/->ts {::->id ->id}) {:db/id (->id), ::type ::ctor, ::parent '_})) - mark-used-ctors (fn mark-used-ctors [ts e] - (let [nd (get (:eav ts) e)] - (case (::type nd) - (::literal ::var ::lookup) ts - (::ap) (reduce mark-used-ctors ts (get-children-e ts e)) - (::site ::join ::pure ::call) (recur ts (get-child-e ts e)) - (::ctor) (if (::ctor-idx nd) - ts - (recur (ts/asc ts e ::ctor-idx (->ctor-idx)) (get-child-e ts e))) - (::let) (recur ts (->let-body-e ts e)) - (::let-ref) (recur ts (get-ret-e ts (->let-val-e ts (::ref nd)))) - #_else (throw (ex-info (str "cannot mark-used-ctors on " (pr-str (::type nd))) (or nd {})))))) - ts (mark-used-ctors ts 0) - ctors-e (reduce into (-> ts :ave ::ctor-idx vals)) - ->node-idx (let [mp (zipmap ctors-e (repeatedly ->->id))] - (fn ->node-idx [ctor-e] ((get mp ctor-e)))) - ->free-idx (let [mp (zipmap ctors-e (repeatedly ->->id))] - (fn ->free-idx [ctor-e] ((get mp ctor-e)))) - ensure-node (fn ensure-node [ts ref-e] - (let [ctor-e (find-ctor-e ts ref-e)] - (cond-> ts (-> ts :ave ::ctor-ref (get ref-e) empty?) - (ts/add {:db/id (->id), ::node-idx (->node-idx ctor-e) - ::ctor-node ctor-e, ::ctor-ref ref-e})))) - ->node-idx (fn ->node-idx [ts ctor-e ref-e] - (::node-idx (get (:eav ts) - (first (set/intersection (-> ts :ave ::ctor-node (get ctor-e)) - (-> ts :ave ::ctor-ref (get ref-e))))))) - ensure-free-node (fn ensure-free-node [ts ref-e ctor-e] - (cond-> ts (empty? (set/intersection (-> ts :ave ::ctor-free (get ctor-e)) - (-> ts :ave ::closed-ref (get ref-e)))) - (ts/add {:db/id (->id), ::free-idx (->free-idx ctor-e) ::ctor-free ctor-e - ::closed-ref ref-e, ::closed-over ::node}))) - ensure-free-free (fn ensure-free-free [ts ref-e ctor-e] - (cond-> ts (empty? (set/intersection (-> ts :ave ::ctor-free (get ctor-e)) - (-> ts :ave ::closed-ref (get ref-e)))) - (ts/add {:db/id (->id), ::free-idx (->free-idx ctor-e) ::ctor-free ctor-e - ::closed-ref ref-e, ::closed-over ::free}))) - ensure-free-frees (fn ensure-free-frees [ts ref-e ctors-e] - (reduce (fn [ts ctor-e] (ensure-free-free ts ref-e ctor-e)) ts ctors-e)) - in-a-call? (fn in-a-call? [ts e] - (loop [e (::parent (ts/->node ts e))] - (when-let [nd (ts/->node ts e)] - (case (::type nd) - ::call true - ::ctor false - #_else (recur (::parent nd)))))) - handle-let-refs (fn handle-let-refs [ts e] ; nodes and frees (closed over) - (let [nd (ts/->node ts e)] - (case (::type nd) - (::literal ::var ::lookup) ts - (::ap) (reduce handle-let-refs ts (get-children-e ts e)) - (::site ::join ::pure ::ctor ::call) (recur ts (get-child-e ts e)) - (::let) (recur ts (->let-body-e ts e)) - (::let-ref) - (let [ref-nd (ts/->node ts (::ref nd)) - ctors-e (loop [ac '(), e (::parent (ts/->node ts e))] - (if (= (::ref nd) e) - ac - (recur (cond-> ac (= ::ctor (::type (ts/->node ts e))) (conj e)) - (::parent (ts/->node ts e))))) - ts (ts/asc ts (::ref nd) ::walked-val true) ; only walk binding once - ts (cond - (in-a-call? ts e) - (-> (ts/upd ts (::ref nd) ::in-call #(conj (or % #{}) e)) - (ensure-node (::ref nd))) - - (seq ctors-e) ; closed over - (-> ts (ensure-node (::ref nd)) - (ensure-free-node (::ref nd) (first ctors-e)) - (ensure-free-frees (::ref nd) (rest ctors-e))) - - :else (cond-> (ts/upd ts (::ref nd) ::refcnt (fnil inc 0)) - (or (= 1 (::refcnt ref-nd)) - (not= (get-site ts (find-sitable-parent ts e)) - (get-site ts (->let-val-e ts (::ref nd))))) - (ensure-node (::ref nd))))] - (cond-> ts - (not (::walked-val ref-nd)) (recur (get-ret-e ts (->let-val-e ts (::ref nd)))))) - #_else (throw (ex-info (str "cannot handle-let-refs on " (::type nd)) (or nd {})))))) - ->call-idx (let [mp (zipmap ctors-e (repeatedly ->->id))] - (fn ->call-idx [ctor-e] ((get mp ctor-e)))) - mark-used-calls (fn mark-used-calls [ts ctor-e e] - (let [nd (ts/->node ts e)] - (case (::type nd) - (::literal ::var ::lookup) ts - (::ap) (reduce #(mark-used-calls % ctor-e %2) ts (get-children-e ts e)) - (::site ::join ::pure) (recur ts ctor-e (get-child-e ts e)) - (::ctor) (recur ts e (get-child-e ts e)) - (::call) (if (::call-idx nd) - ts - (recur (-> ts (ts/asc e ::call-idx (->call-idx ctor-e)) - (ts/asc e ::ctor-call ctor-e)) - ctor-e (get-child-e ts e))) - (::let) (recur ts ctor-e (->let-body-e ts e)) - (::let-ref) (let [nx-e (get-ret-e ts (->let-val-e ts (::ref nd)))] - (recur ts (find-ctor-e ts nx-e) nx-e)) - #_else (throw (ex-info (str "cannot mark-used-calls on " (::type nd)) (or nd {})))))) - change-parent (fn change-parent [ts e pe] (ts/asc ts e ::parent pe)) - orphan (fn orphan [ts e] (change-parent ts e nil)) - collapse-ap-with-only-pures (fn collapse-ap-with-only-pures [ts] ; (r/ap (r/pure .)+ ) => (r/pure (. . .)) - (reduce (fn [ts ap-e] - (let [ap-nd (ts/->node ts ap-e) - children-e (get-children-e ts ap-e)] - (if (every? #(= ::pure (::type (ts/->node ts %))) children-e) - (let [e (->id), ce (->id)] - (reduce (fn [ts e] - (-> ts (change-parent (get-child-e ts e) ce) - (orphan e))) - (-> ts (ts/add {:db/id e, ::parent (::parent ap-nd), ::type ::pure}) - (ts/add {:db/id ce, ::parent e, ::type ::comp}) - (orphan ap-e)) - children-e)) - ts))) - ts (reverse (ts/find ts ::type ::ap)))) - ts (-> ts (handle-let-refs 0) - (mark-used-calls 0 (get-ret-e ts (get-child-e ts 0))) - collapse-ap-with-only-pures) - gen (fn gen [ts ctor-e e] - (let [nd (get (:eav ts) e)] - (case (::type nd) - ::literal (::v nd) - ::ap (list* `r/ap (mapv #(gen ts ctor-e %) (get-children-e ts e))) - ::var (let [in (::resolved-in nd)] - (list* `r/lookup 'frame (keyword (::qualified-var nd)) - (when (or (nil? in) (= in (->env-type env))) [(list `r/pure (::qualified-var nd))]))) - ::join (list `r/join (gen ts ctor-e (get-child-e ts e))) - ::pure (list `r/pure (gen ts ctor-e (get-child-e ts e))) - ::comp (doall (map #(gen ts ctor-e %) (get-children-e ts e))) - ::site (recur ts ctor-e (get-child-e ts e)) - ::ctor (let [ctor (list `r/make-ctor 'frame nm (::ctor-idx nd)) - frees-e (-> ts :ave ::ctor-free (get e))] - (if (seq frees-e) - (list* `doto ctor - (mapv (fn [e] - (let [nd (ts/->node ts e)] - (list `r/define-free (::free-idx nd) - (case (::closed-over nd) - ::node (list `r/node 'frame (->node-idx ts (find-ctor-e ts (::ctor-free nd)) (::closed-ref nd))) - ::free (list `r/free 'frame (->> (ts/find ts ::ctor-free (find-ctor-e ts (::ctor-free nd)) - ::closed-ref (::closed-ref nd)) - first (ts/->node ts) ::free-idx)))))) - frees-e)) - ctor)) - ::call (list `r/join (list `r/call 'frame (::call-idx (ts/->node ts e)))) - ::lookup (list `r/lookup 'frame (::sym nd)) - ::let (recur ts ctor-e (get-ret-e ts (->let-body-e ts e))) - ::let-ref - (if-some [node-e (first (ts/find ts ::ctor-node ctor-e, ::ctor-ref (::ref nd)))] - (list `r/node 'frame (::node-idx (get (:eav ts) node-e))) - (if-some [free-e (first (ts/find ts ::ctor-free ctor-e, ::closed-ref (::ref nd)))] - (list `r/free 'frame (::free-idx (ts/->node ts free-e))) - (recur ts ctor-e (get-ret-e ts (->let-val-e ts (::ref nd)))))) - #_else (throw (ex-info (str "cannot gen on " (pr-str (::type nd))) (or nd {})))))) - gen-node-init (fn gen-node-init [ts ctor-e node-e] - (let [nd (get (:eav ts) node-e)] - (list `r/define-node 'frame (::node-idx nd) - (gen ts ctor-e (get-ret-e ts (->let-val-e ts (::ctor-ref nd))))))) - gen-call-init (fn gen-call-init [ts ctor-e e] - (list `r/define-call 'frame (::call-idx (ts/->node ts e)) - (gen ts ctor-e (get-ret-e ts (get-child-e ts e)))))] - ;; (run! prn (->> ts :eav vals (sort-by :db/id))) - (->> ctors-e - (mapv (fn [ctor-e] - (let [ret-e (get-ret-e ts (get-child-e ts ctor-e)) - nodes-e (ts/find ts ::ctor-node ctor-e) - calls-e (ts/find ts ::ctor-call ctor-e)] - `(r/cdef ~(count (ts/find ts ::ctor-free ctor-e)) - ~(mapv #(get-site ts (->> (ts/->node ts %) ::ctor-ref (->let-val-e ts) (get-ret-e ts))) - nodes-e) - ~(mapv #(get-site ts %) calls-e) - ~(get-site ts ret-e) - (fn [~'frame] - ~@(mapv #(gen-node-init ts ctor-e %) nodes-e) - ~@(mapv #(gen-call-init ts ctor-e %) calls-e) - ~(gen ts ctor-e ret-e))))))))))) +(defn compile [nm form env] + (ensure-cljs-compiler + (let [->id (->->id), ->ctor-idx (->->id) + ts (analyze (expand-all env form) 0 (ensure-cljs-env env) + (ts/add (ts/->ts {::->id ->id}) {:db/id (->id), ::type ::ctor, ::parent '_})) + mark-used-ctors (fn mark-used-ctors [ts e] + (let [nd (get (:eav ts) e)] + (case (::type nd) + (::literal ::var ::lookup) ts + (::ap) (reduce mark-used-ctors ts (get-children-e ts e)) + (::site ::join ::pure ::call) (recur ts (get-child-e ts e)) + (::ctor) (if (::ctor-idx nd) + ts + (recur (ts/asc ts e ::ctor-idx (->ctor-idx)) (get-child-e ts e))) + (::let) (recur ts (->let-body-e ts e)) + (::let-ref) (recur ts (get-ret-e ts (->let-val-e ts (::ref nd)))) + #_else (throw (ex-info (str "cannot mark-used-ctors on " (pr-str (::type nd))) (or nd {})))))) + ts (mark-used-ctors ts 0) + ctors-e (reduce into (-> ts :ave ::ctor-idx vals)) + ->node-idx (let [mp (zipmap ctors-e (repeatedly ->->id))] + (fn ->node-idx [ctor-e] ((get mp ctor-e)))) + ->free-idx (let [mp (zipmap ctors-e (repeatedly ->->id))] + (fn ->free-idx [ctor-e] ((get mp ctor-e)))) + ensure-node (fn ensure-node [ts ref-e] + (let [ctor-e (find-ctor-e ts ref-e)] + (cond-> ts (-> ts :ave ::ctor-ref (get ref-e) empty?) + (ts/add {:db/id (->id), ::node-idx (->node-idx ctor-e) + ::ctor-node ctor-e, ::ctor-ref ref-e})))) + ->node-idx (fn ->node-idx [ts ctor-e ref-e] + (::node-idx (get (:eav ts) + (first (set/intersection (-> ts :ave ::ctor-node (get ctor-e)) + (-> ts :ave ::ctor-ref (get ref-e))))))) + ensure-free-node (fn ensure-free-node [ts ref-e ctor-e] + (cond-> ts (empty? (set/intersection (-> ts :ave ::ctor-free (get ctor-e)) + (-> ts :ave ::closed-ref (get ref-e)))) + (ts/add {:db/id (->id), ::free-idx (->free-idx ctor-e) ::ctor-free ctor-e + ::closed-ref ref-e, ::closed-over ::node}))) + ensure-free-free (fn ensure-free-free [ts ref-e ctor-e] + (cond-> ts (empty? (set/intersection (-> ts :ave ::ctor-free (get ctor-e)) + (-> ts :ave ::closed-ref (get ref-e)))) + (ts/add {:db/id (->id), ::free-idx (->free-idx ctor-e) ::ctor-free ctor-e + ::closed-ref ref-e, ::closed-over ::free}))) + ensure-free-frees (fn ensure-free-frees [ts ref-e ctors-e] + (reduce (fn [ts ctor-e] (ensure-free-free ts ref-e ctor-e)) ts ctors-e)) + in-a-call? (fn in-a-call? [ts e] + (loop [e (::parent (ts/->node ts e))] + (when-let [nd (ts/->node ts e)] + (case (::type nd) + ::call true + ::ctor false + #_else (recur (::parent nd)))))) + handle-let-refs (fn handle-let-refs [ts e] ; nodes and frees (closed over) + (let [nd (ts/->node ts e)] + (case (::type nd) + (::literal ::var ::lookup) ts + (::ap) (reduce handle-let-refs ts (get-children-e ts e)) + (::site ::join ::pure ::ctor ::call) (recur ts (get-child-e ts e)) + (::let) (recur ts (->let-body-e ts e)) + (::let-ref) + (let [ref-nd (ts/->node ts (::ref nd)) + ctors-e (loop [ac '(), e (::parent (ts/->node ts e))] + (if (= (::ref nd) e) + ac + (recur (cond-> ac (= ::ctor (::type (ts/->node ts e))) (conj e)) + (::parent (ts/->node ts e))))) + ts (ts/asc ts (::ref nd) ::walked-val true) ; only walk binding once + ts (cond + (in-a-call? ts e) + (-> (ts/upd ts (::ref nd) ::in-call #(conj (or % #{}) e)) + (ensure-node (::ref nd))) + + (seq ctors-e) ; closed over + (-> ts (ensure-node (::ref nd)) + (ensure-free-node (::ref nd) (first ctors-e)) + (ensure-free-frees (::ref nd) (rest ctors-e))) + + :else (cond-> (ts/upd ts (::ref nd) ::refcnt (fnil inc 0)) + (or (= 1 (::refcnt ref-nd)) + (not= (get-site ts (find-sitable-parent ts e)) + (get-site ts (->let-val-e ts (::ref nd))))) + (ensure-node (::ref nd))))] + (cond-> ts + (not (::walked-val ref-nd)) (recur (get-ret-e ts (->let-val-e ts (::ref nd)))))) + #_else (throw (ex-info (str "cannot handle-let-refs on " (::type nd)) (or nd {})))))) + ->call-idx (let [mp (zipmap ctors-e (repeatedly ->->id))] + (fn ->call-idx [ctor-e] ((get mp ctor-e)))) + mark-used-calls (fn mark-used-calls [ts ctor-e e] + (let [nd (ts/->node ts e)] + (case (::type nd) + (::literal ::var ::lookup) ts + (::ap) (reduce #(mark-used-calls % ctor-e %2) ts (get-children-e ts e)) + (::site ::join ::pure) (recur ts ctor-e (get-child-e ts e)) + (::ctor) (recur ts e (get-child-e ts e)) + (::call) (if (::call-idx nd) + ts + (recur (-> ts (ts/asc e ::call-idx (->call-idx ctor-e)) + (ts/asc e ::ctor-call ctor-e)) + ctor-e (get-child-e ts e))) + (::let) (recur ts ctor-e (->let-body-e ts e)) + (::let-ref) (let [nx-e (get-ret-e ts (->let-val-e ts (::ref nd)))] + (recur ts (find-ctor-e ts nx-e) nx-e)) + #_else (throw (ex-info (str "cannot mark-used-calls on " (::type nd)) (or nd {})))))) + change-parent (fn change-parent [ts e pe] (ts/asc ts e ::parent pe)) + orphan (fn orphan [ts e] (change-parent ts e nil)) + collapse-ap-with-only-pures (fn collapse-ap-with-only-pures [ts] ; (r/ap (r/pure .)+ ) => (r/pure (. . .)) + (reduce (fn [ts ap-e] + (let [ap-nd (ts/->node ts ap-e) + children-e (get-children-e ts ap-e)] + (if (every? #(= ::pure (::type (ts/->node ts %))) children-e) + (let [e (->id), ce (->id)] + (reduce (fn [ts e] + (-> ts (change-parent (get-child-e ts e) ce) + (orphan e))) + (-> ts (ts/add {:db/id e, ::parent (::parent ap-nd), ::type ::pure}) + (ts/add {:db/id ce, ::parent e, ::type ::comp}) + (orphan ap-e)) + children-e)) + ts))) + ts (reverse (ts/find ts ::type ::ap)))) + ts (-> ts (handle-let-refs 0) + (mark-used-calls 0 (get-ret-e ts (get-child-e ts 0))) + collapse-ap-with-only-pures) + gen (fn gen [ts ctor-e e] + (let [nd (get (:eav ts) e)] + (case (::type nd) + ::literal (::v nd) + ::ap (list* `r/ap (mapv #(gen ts ctor-e %) (get-children-e ts e))) + ::var (let [in (::resolved-in nd)] + (list* `r/lookup 'frame (keyword (::qualified-var nd)) + (when (or (nil? in) (= in (->env-type env))) [(list `r/pure (::qualified-var nd))]))) + ::join (list `r/join (gen ts ctor-e (get-child-e ts e))) + ::pure (list `r/pure (gen ts ctor-e (get-child-e ts e))) + ::comp (doall (map #(gen ts ctor-e %) (get-children-e ts e))) + ::site (recur ts ctor-e (get-child-e ts e)) + ::ctor (let [ctor (list `r/make-ctor 'frame nm (::ctor-idx nd)) + frees-e (-> ts :ave ::ctor-free (get e))] + (if (seq frees-e) + (list* `doto ctor + (mapv (fn [e] + (let [nd (ts/->node ts e)] + (list `r/define-free (::free-idx nd) + (case (::closed-over nd) + ::node (list `r/node 'frame (->node-idx ts (find-ctor-e ts (::ctor-free nd)) (::closed-ref nd))) + ::free (list `r/free 'frame (->> (ts/find ts ::ctor-free (find-ctor-e ts (::ctor-free nd)) + ::closed-ref (::closed-ref nd)) + first (ts/->node ts) ::free-idx)))))) + frees-e)) + ctor)) + ::call (list `r/join (list `r/call 'frame (::call-idx (ts/->node ts e)))) + ::lookup (list `r/lookup 'frame (::sym nd)) + ::let (recur ts ctor-e (get-ret-e ts (->let-body-e ts e))) + ::let-ref + (if-some [node-e (first (ts/find ts ::ctor-node ctor-e, ::ctor-ref (::ref nd)))] + (list `r/node 'frame (::node-idx (get (:eav ts) node-e))) + (if-some [free-e (first (ts/find ts ::ctor-free ctor-e, ::closed-ref (::ref nd)))] + (list `r/free 'frame (::free-idx (ts/->node ts free-e))) + (recur ts ctor-e (get-ret-e ts (->let-val-e ts (::ref nd)))))) + #_else (throw (ex-info (str "cannot gen on " (pr-str (::type nd))) (or nd {})))))) + gen-node-init (fn gen-node-init [ts ctor-e node-e] + (let [nd (get (:eav ts) node-e)] + (list `r/define-node 'frame (::node-idx nd) + (gen ts ctor-e (get-ret-e ts (->let-val-e ts (::ctor-ref nd))))))) + gen-call-init (fn gen-call-init [ts ctor-e e] + (list `r/define-call 'frame (::call-idx (ts/->node ts e)) + (gen ts ctor-e (get-ret-e ts (get-child-e ts e)))))] + ;; (run! prn (->> ts :eav vals (sort-by :db/id))) + (->> ctors-e + (mapv (fn [ctor-e] + (let [ret-e (get-ret-e ts (get-child-e ts ctor-e)) + nodes-e (ts/find ts ::ctor-node ctor-e) + calls-e (ts/find ts ::ctor-call ctor-e)] + `(r/cdef ~(count (ts/find ts ::ctor-free ctor-e)) + ~(mapv #(get-site ts (->> (ts/->node ts %) ::ctor-ref (->let-val-e ts) (get-ret-e ts))) + nodes-e) + ~(mapv #(get-site ts %) calls-e) + ~(get-site ts ret-e) + (fn [~'frame] + ~@(mapv #(gen-node-init ts ctor-e %) nodes-e) + ~@(mapv #(gen-call-init ts ctor-e %) calls-e) + ~(gen ts ctor-e ret-e)))))))))) diff --git a/src/hyperfiddle/electric_local_def_de.cljc b/src/hyperfiddle/electric_local_def_de.cljc index 34f821209..04d9d5723 100644 --- a/src/hyperfiddle/electric_local_def_de.cljc +++ b/src/hyperfiddle/electric_local_def_de.cljc @@ -2,32 +2,30 @@ (:refer-clojure :exclude [compile]) #?(:cljs (:require-macros hyperfiddle.electric-local-def-de)) (:require [clojure.core :as cc] + [contrib.assert :as ca] [contrib.cljs-target] - #?(:clj [hyperfiddle.electric.impl.lang-de2 :as lang] - :cljs [hyperfiddle.electric.impl.lang-de2 :as-alias lang]))) + [hyperfiddle.electric.impl.lang-de2 :as lang] + [hyperfiddle.electric.impl.runtime-de :as r] + #?(:clj [hyperfiddle.rcf.analyzer :as ana]) ; todo remove + [missionary.core :as m])) + +#?(:clj + (do + ;; Optionally, tell RCF not to rewrite Electric programs. + (defmethod ana/macroexpand-hook `single [the-var form env args] + (reduced form)))) (defn ->local-config [env] (let [p (if (:js-globals env) :cljs :clj)] {::lang/peers {:client p, :server p}})) -(defn ->single-peer-config [env] - (let [p (if (and (:js-globals env) (contrib.cljs-target/do-nodejs true)) :client :server)] - {::lang/peers {p (if (:js-globals env) :cljs :clj)}, ::lang/me p})) - (def web-config {::lang/peers {:client :cljs, :server :clj}}) -(defmacro compile-client [form] - (let [env (merge &env (->local-config &env) {::lang/me :client, :ns (list 'quote (ns-name *ns*))})] - `(:source (lang/compile '~form ~env)))) -(defmacro compile-client-source-map [form] - (let [env (merge &env (->local-config &env) {::lang/me :client})] - `(:source-map (lang/compile '~form (assoc ~env ::lang/include-source-map true))))) -(defmacro compile-client-with-source-map [form] - (let [env (merge &env (->local-config &env) {::lang/me :client})] - `(lang/compile '~form (assoc ~env ::lang/include-source-map true)))) -(defmacro compile-server [form] - (let [env (merge &env (->local-config &env) {::lang/me :server})] - `(:source (lang/compile '~form ~env)))) - #?(:clj (defmacro test-compile ([nm form] `(test-compile ~nm {} ~form)) ([nm env form] `(lang/compile ~nm '~form (merge web-config (lang/normalize-env ~env)))))) + +#?(:clj (defn run-single [frame] (m/reduce #(do %2) nil frame))) +#?(:clj (defmacro single {:style/indent 0} [conf & body] + (ca/check map? conf) + (let [env (merge (->local-config (lang/normalize-env &env)) conf)] + `(run-single (r/root-frame {::Main ~(lang/compile ::Main `(do ~@body) env)} ::Main))))) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc new file mode 100644 index 000000000..409658906 --- /dev/null +++ b/test/hyperfiddle/electric_de_test.cljc @@ -0,0 +1,14 @@ +(ns hyperfiddle.electric-de-test + (:require [hyperfiddle.rcf :as rcf :refer [tests tap with %]] + [hyperfiddle.electric-local-def-de :as l])) + +;; fails to compile, rcf rewrites `tap` to `RCF__tap` and electric compiler fails to resolve that +;; (tests "hello world" +;; (with ((l/single {} (tap "hello world")) tap tap) +;; % := "hello world")) + +(def hello (l/single {} (tap "hello world"))) +(tests "hello world" + (with (hello tap tap) + % := "hello world" ; returns a diff {:degree 1, :permutation {}, :grow 1, :shrink 0, :change {0 "hello world"}, :freeze #{0}} + )) From 5842ea818f42c3bbeae1125ab526e071a6fe75ce Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 31 Jan 2024 15:56:52 +0100 Subject: [PATCH 079/428] fix electric test shim --- src/hyperfiddle/electric_local_def_de.cljc | 2 +- test/hyperfiddle/electric_de_test.cljc | 11 ++--------- 2 files changed, 3 insertions(+), 10 deletions(-) diff --git a/src/hyperfiddle/electric_local_def_de.cljc b/src/hyperfiddle/electric_local_def_de.cljc index 04d9d5723..6b1c62c1e 100644 --- a/src/hyperfiddle/electric_local_def_de.cljc +++ b/src/hyperfiddle/electric_local_def_de.cljc @@ -27,5 +27,5 @@ #?(:clj (defn run-single [frame] (m/reduce #(do %2) nil frame))) #?(:clj (defmacro single {:style/indent 0} [conf & body] (ca/check map? conf) - (let [env (merge (->local-config (lang/normalize-env &env)) conf)] + (let [env (merge (->local-config &env) (lang/normalize-env &env) conf)] `(run-single (r/root-frame {::Main ~(lang/compile ::Main `(do ~@body) env)} ::Main))))) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 409658906..287ef4f1f 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -2,13 +2,6 @@ (:require [hyperfiddle.rcf :as rcf :refer [tests tap with %]] [hyperfiddle.electric-local-def-de :as l])) -;; fails to compile, rcf rewrites `tap` to `RCF__tap` and electric compiler fails to resolve that -;; (tests "hello world" -;; (with ((l/single {} (tap "hello world")) tap tap) -;; % := "hello world")) - -(def hello (l/single {} (tap "hello world"))) (tests "hello world" - (with (hello tap tap) - % := "hello world" ; returns a diff {:degree 1, :permutation {}, :grow 1, :shrink 0, :change {0 "hello world"}, :freeze #{0}} - )) + (with ((l/single {} (tap "hello world")) tap tap) + % := "hello world")) From 1c983a0a7534be89664e0f4be69d21f98eb21685 Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 31 Jan 2024 16:14:42 +0100 Subject: [PATCH 080/428] fix browser tests --- src/hyperfiddle/electric_local_def_de.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/hyperfiddle/electric_local_def_de.cljc b/src/hyperfiddle/electric_local_def_de.cljc index 6b1c62c1e..029e699ca 100644 --- a/src/hyperfiddle/electric_local_def_de.cljc +++ b/src/hyperfiddle/electric_local_def_de.cljc @@ -24,7 +24,7 @@ ([nm form] `(test-compile ~nm {} ~form)) ([nm env form] `(lang/compile ~nm '~form (merge web-config (lang/normalize-env ~env)))))) -#?(:clj (defn run-single [frame] (m/reduce #(do %2) nil frame))) +(defn run-single [frame] (m/reduce #(do %2) nil frame)) #?(:clj (defmacro single {:style/indent 0} [conf & body] (ca/check map? conf) (let [env (merge (->local-config &env) (lang/normalize-env &env) conf)] From ac6ef9a9864e84b68dff07b435c4901f011bf182 Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 31 Jan 2024 20:40:53 +0100 Subject: [PATCH 081/428] checkpoint, broken for-by --- src/hyperfiddle/electric/impl/lang_de2.clj | 82 +- test/hyperfiddle/electric_de_test.cljc | 2055 +++++++++++++++++++- 2 files changed, 2098 insertions(+), 39 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 4380005d2..ce13a8bc9 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -9,6 +9,7 @@ [clojure.set :as set] [contrib.triple-store :as ts] [dom-top.core :refer [loopr]] + [fipp.edn] [hyperfiddle.electric-de :as-alias e] [hyperfiddle.electric.impl.analyzer :as ana] [hyperfiddle.electric.impl.runtime-de :as r] @@ -309,7 +310,7 @@ (defn qualify-sym-in-var-node "If ast node is `:var`, update :form to be a fully qualified symbol" [env ast] (if (and (= :var (:op ast)) (not (-> ast :env :def-var))) - (assoc ast :form (case (get (::peers env) (::current env)) + (assoc ast :form (case (or (get (::peers env) (::current env)) (->env-type env)) :clj (symbol (str (:ns (:meta ast))) (str (:name (:meta ast)))) :cljs (:name (:info ast)))) ast)) @@ -368,8 +369,8 @@ :else ast)) (lexical? ast) (do (record-lexical! ast) ast) :else (qualify-sym-in-var-node env ast))) - form (case (get (::peers env) (::current env)) - :clj (-> (ana/analyze-clj env form) + form (case (or (get (::peers env) (::current env)) (->env-type env)) + :clj (-> (ana/analyze-clj (update env :ns :name) form) (ana/walk-clj rewrite-ast) (ana/emit-clj)) :cljs (-> (binding [cljs.analyzer/*cljs-warning-handlers* @@ -502,10 +503,12 @@ #_else (recur (::parent nd)))))) (defn get-lookup-key [sym env] - (let [[_ sym] (resolve-symbol sym env)] - (case sym - ::static (throw (ex-info (str "`" sym "` did not resolve as a var") {::form sym})) - #_else (keyword sym)))) + (if (symbol? sym) + (let [[_ sym] (resolve-symbol sym env)] + (case sym + ::static (throw (ex-info (str "`" sym "` did not resolve as a var") {::form sym})) + #_else (keyword sym))) + sym)) (defn analyze [form pe env {{::keys [->id]} :o :as ts}] (cond @@ -525,7 +528,7 @@ [[v br] (partition 2 brs2)] (let [b (gensym "case-val")] (recur (conj bs b `(::ctor ~br)) - (reduce (fn [ac nx] (assoc ac (list 'quote nx) b)) mp (if (seq v) v [v])))) + (reduce (fn [ac nx] (assoc ac (list 'quote nx) b)) mp (if (seq? v) v [v])))) (recur (?meta form `(let* ~bs (::call (~mp ~test (::ctor ~default))))) pe env ts))) (quote) (let [e (->id)] (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) @@ -537,24 +540,27 @@ (ts/add {:db/id (->id), ::parent ce, ::type ::literal, ::v form}) (?add-source-map e form))] (reduce (fn [ts nx] (analyze nx e env ts)) ts2 refs)) - (binding) (let [[_ bs bform] form, gs (repeatedly (/ (count bs) 2) gensym)] - (recur `(let* [~@(interleave gs (take-nth 2 (next bs)))] - (::call ((::static-vars r/bind) (::ctor ~bform) - ~@(interleave - (mapv #(get-lookup-key % env) (take-nth 2 bs)) - (mapv #(list ::pure %) gs))))) - pe env ts)) + (new) (let [[_ F & args] form] (recur `(binding [~@(interleave (range) args)] (::call ~F)) pe env ts)) + (binding clojure.core/binding) (let [[_ bs bform] form, gs (repeatedly (/ (count bs) 2) gensym)] + (recur (if (seq bs) + `(let* [~@(interleave gs (take-nth 2 (next bs)))] + (::call ((::static-vars r/bind) (::ctor ~bform) + ~@(interleave + (mapv #(get-lookup-key % env) (take-nth 2 bs)) + (mapv #(list ::pure %) gs))))) + bform) + pe env ts)) (::ctor) (let [e (->id), ce (->id)] (recur (list ::site nil (second form)) ce env (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) (ts/add {:db/id ce, ::parent e, ::type ::ctor}) (?add-source-map e form)))) (::call) (let [e (->id)] (recur (second form) e env (-> (ts/add ts {:db/id e, ::parent pe, ::type ::call}) - (?add-source-map e form)))) + (?add-source-map e form)))) (::pure) (let [e (->id)] (recur (second form) e env (-> (ts/add ts {:db/id e, ::parent pe, ::type ::pure}) - (?add-source-map e form)))) + (?add-source-map e form)))) (::join) (let [e (->id)] (recur (second form) e env (-> (ts/add ts {:db/id e, ::parent pe, ::type ::join}) - (?add-source-map e form)))) + (?add-source-map e form)))) (::site) (let [[_ site bform] form, e (->id)] (recur bform e (assoc env ::current site) (-> (ts/add ts {:db/id e, ::parent pe, ::type ::site, ::site site}) @@ -563,7 +569,7 @@ (::static-vars) (recur (second form) pe (assoc env ::static-vars true) ts) #_else (let [e (->id)] (reduce (fn [ts nx] (analyze nx e env ts)) (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) - (?add-source-map e form)) form))) + (?add-source-map e form)) form))) (vector? form) (recur (?meta form (cons `(::static-vars vector) form)) pe env ts) (map? form) (recur (?meta form (cons `(::static-vars hash-map) (eduction cat form))) pe env ts) @@ -598,7 +604,9 @@ (defn compile [nm form env] (ensure-cljs-compiler (let [->id (->->id), ->ctor-idx (->->id) - ts (analyze (expand-all env form) 0 (ensure-cljs-env env) + expanded (expand-all env form) + _ (when (::print-expansion env) (fipp.edn/pprint expanded)) + ts (analyze expanded 0 (ensure-cljs-env env) (ts/add (ts/->ts {::->id ->id}) {:db/id (->id), ::type ::ctor, ::parent '_})) mark-used-ctors (fn mark-used-ctors [ts e] (let [nd (get (:eav ts) e)] @@ -613,7 +621,7 @@ (::let-ref) (recur ts (get-ret-e ts (->let-val-e ts (::ref nd)))) #_else (throw (ex-info (str "cannot mark-used-ctors on " (pr-str (::type nd))) (or nd {})))))) ts (mark-used-ctors ts 0) - ctors-e (reduce into (-> ts :ave ::ctor-idx vals)) + ctors-e (into [] (map (comp first second)) (->> ts :ave ::ctor-idx (sort-by first))) ->node-idx (let [mp (zipmap ctors-e (repeatedly ->->id))] (fn ->node-idx [ctor-e] ((get mp ctor-e)))) ->free-idx (let [mp (zipmap ctors-e (repeatedly ->->id))] @@ -760,18 +768,20 @@ gen-call-init (fn gen-call-init [ts ctor-e e] (list `r/define-call 'frame (::call-idx (ts/->node ts e)) (gen ts ctor-e (get-ret-e ts (get-child-e ts e)))))] - ;; (run! prn (->> ts :eav vals (sort-by :db/id))) - (->> ctors-e - (mapv (fn [ctor-e] - (let [ret-e (get-ret-e ts (get-child-e ts ctor-e)) - nodes-e (ts/find ts ::ctor-node ctor-e) - calls-e (ts/find ts ::ctor-call ctor-e)] - `(r/cdef ~(count (ts/find ts ::ctor-free ctor-e)) - ~(mapv #(get-site ts (->> (ts/->node ts %) ::ctor-ref (->let-val-e ts) (get-ret-e ts))) - nodes-e) - ~(mapv #(get-site ts %) calls-e) - ~(get-site ts ret-e) - (fn [~'frame] - ~@(mapv #(gen-node-init ts ctor-e %) nodes-e) - ~@(mapv #(gen-call-init ts ctor-e %) calls-e) - ~(gen ts ctor-e ret-e)))))))))) + (when (::print-db env) (run! prn (->> ts :eav vals (sort-by :db/id)))) + (let [ret (->> ctors-e + (mapv (fn [ctor-e] + (let [ret-e (get-ret-e ts (get-child-e ts ctor-e)) + nodes-e (ts/find ts ::ctor-node ctor-e) + calls-e (ts/find ts ::ctor-call ctor-e)] + `(r/cdef ~(count (ts/find ts ::ctor-free ctor-e)) + ~(mapv #(get-site ts (->> (ts/->node ts %) ::ctor-ref (->let-val-e ts) (get-ret-e ts))) + nodes-e) + ~(mapv #(get-site ts %) calls-e) + ~(get-site ts ret-e) + (fn [~'frame] + ~@(mapv #(gen-node-init ts ctor-e %) nodes-e) + ~@(mapv #(gen-call-init ts ctor-e %) calls-e) + ~(gen ts ctor-e ret-e)))))))] + (when (::print-source env) (fipp.edn/pprint ret)) + ret)))) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 287ef4f1f..83a84b874 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -1,7 +1,2056 @@ (ns hyperfiddle.electric-de-test (:require [hyperfiddle.rcf :as rcf :refer [tests tap with %]] - [hyperfiddle.electric-local-def-de :as l])) + [hyperfiddle.electric-de :as e] + [hyperfiddle.electric-local-def-de :as l] + [hyperfiddle.electric.impl.lang-de2 :as lang] + [missionary.core :as m])) + +(tests "new on local electric closure" + (with ((l/single {} (let [x (e/ctor 1)] (tap (e/call x)))) tap tap) + % := 1)) + +;; TODO class support +;; (defrecord Point [x y]) +;; (tests "new on class" +;; (with ((l/single {} (tap (new Point 1 2))) tap tap) +;; % := (Point. 1 2))) + +;; TODO `m/ap` has `try` in expansion +;; (tests "new on missionary flow" +;; (with ((l/single {::lang/print-expansion true} (tap (e/input (m/ap 1)))) tap tap) +;; % := 1)) + +(tests "new on missionary flow" + (def flow (m/ap 1)) + (with ((l/single {} (tap (e/input flow))) tap tap) + % := 1)) + +(tests "if" + (with ((l/single {} (tap (if true :yes :no))) tap tap) + % := :yes)) + +;; TODO `case` default branch +;; (tests "case" +;; (with ((l/single {} (tap (case 1 1 1 2 2))) tap tap) +;; % := 1)) + +(tests "case" + (with ((l/single {} (tap (case 1 1 1 2 2 #_else nil))) tap tap) + % := 1)) + +(tests "quote" + (with ((l/single {} (tap 'foo)) tap tap) + % := 'foo)) + +#?(:cljs + (tests "js*" + (with ((l/single {} (tap (js* "~{}+1" 1))) tap tap) + % := 2))) + +;; TODO cc/fn +;; (tests "clj fn" +;; (with ((l/single {::lang/print-source true} (let [x 1] (tap (#(inc x))))) tap tap) +;; % := 2)) + +;; TODO `.` +;; #?(:clj +;; (tests "." +;; (with ((l/single {} (tap (. java.time.Instant EPOCH))) tap tap) +;; % := java.time.Instant/EPOCH))) + +;; TODO loop recur +;; (tests "loop/recur" +;; (with ((l/single {} (tap (loop [x 1] (if (odd? x) (recur (dec x)) x)))) tap tap) +;; % := 0)) + +;; TODO def +;; (tests "def" +;; (with ((l/single {} (def DEFD 1)) tap tap)) +;; DEFD := 1) + +;;; MAIN ELECTRIC TEST SUITE (tests "hello world" - (with ((l/single {} (tap "hello world")) tap tap) - % := "hello world")) + (with ((l/single {} (tap "hello world")) tap tap) + % := "hello world")) + +(tests "literals are lifted" + (with ((l/single {} (tap 1)) tap tap) + % := 1)) + +(tests "data literals" + (with ((l/single {} (tap {:a 1})) tap tap) + % := {:a 1})) + +(tests "globals lifted" + (def a 1) + (with ((l/single {} (tap a)) tap tap) + % := 1)) + +(tests + (with ((l/single {} (tap inc)) tap tap) + % := inc)) + +(tests "clojure call" + (with ((l/single {} (tap (inc (inc 1)))) tap tap) + % := 3)) + +(tests "introduce foreign atom" + (def !x (atom 0)) + (with ((l/single {} (tap (e/watch !x))) tap tap) ; clojure flow derived from atom + % := 0 + (swap! !x inc) + % := 1)) + +(tests "introduce foreign missionary signal" + (def !x (atom 0)) ; atoms model variable inputs + (with ((l/single {} (tap (e/input (m/watch !x)))) tap tap) ; clojure flow derived from atom + % := 0 + (swap! !x inc) + % := 1)) + +(tests "reactive closures - call them with (new)" + (with ((l/single {} (tap (let [x 1, F (e/fn [] x)] [(number? x) (new F)]))) tap tap) + % := [true 1])) + +(tests "dataflow diamond - let introduces shared nodes in the dag" + (def !x (atom 0)) + (with ((l/single {} (tap (let [x (e/watch !x)] (+ x x)))) tap tap) + % := 0 + (swap! !x inc) + % := 2 + (swap! !x inc) + % := 4)) + +(tests "broken dataflow diamond (two propagation frames - bad)" + (def !x (atom 0)) + (with ((l/single {} (tap (let [X (m/watch !x)] ; recipe for flow + (+ (e/input X) (e/input X))))) tap tap) ; bad - construct flow twice + % := 0 + (swap! !x inc) + % := 1 ; glitch due to two watch events, + % := 2 ; causing two propagation frames + (swap! !x inc) + % := 3 + % := 4)) + +(tests "reactive function call" + (def !f (atom +)) + (def !x2 (atom 1)) + (with ((l/single {} (tap ((e/watch !f) 0 (e/watch !x2)))) tap tap) + % := 1 + (swap! !x2 inc) + % := 2 + (reset! !f -) + % := -2)) + +(tests "foreign clojure collections. clojure.core/map is not incremental, the arguments are" + (def !xs (atom [1 2 3])) + (def !f (atom inc)) + (with + ((l/single {} (tap (let [f (e/watch !f) + xs (e/watch !xs)] + (clojure.core/map f xs)))) tap tap) + % := [2 3 4] + (swap! !xs conj 4) + % := [2 3 4 5] + (reset! !f dec) + % := [0 1 2 3])) + +(tests "common core macros just work" + (with + ((l/single {} (tap (let [f (e/watch (atom inc)) + xs (e/watch (atom [1 2 3]))] + (->> xs (map f))))) tap tap) + % := [2 3 4])) + +(tests "reactive if" + (def !a (atom 1)) + (def !p (atom :p)) + (def !q (atom :q)) + (with ((l/single {} (tap (if (odd? (e/watch !a)) (e/watch !p) (e/watch !q)))) tap tap) + % := :p + (swap! !a inc) + % := :q + (reset! !p :pp) + (swap! !a inc) + % := :pp)) + +(tests "lazy" + (with ((l/single {} (tap (if false (tap :a) (tap :b)))) tap tap) + % := :b + % := :b)) + +(tests "reactive fn" + (with ((l/single {} (tap (new (e/fn [x] (inc x)) 1))) tap tap) + % := 2)) + +;; TODO defn +;; (l/defn My-inc [x] (inc x)) +;; (tests "reactive defn" +;; (with ((l/single {} (tap (My-inc. 1))) tap tap) +;; % := 2)) + +;; TODO defn +;; (tests "control flow implemented with lazy signals" +;; (l/defn If2 [x a b] ; Key question - how lazy are the parameters? +;; (->> (boolean x) +;; (get {true (e/fn [] a) +;; false (e/fn [] b)}) +;; (new))) + +;; (def !x (atom false)) +;; (def !a (atom :a)) +;; (def !b (atom :b)) +;; (with ((l/single {} (let [x (e/watch !x) +;; a (tap (e/watch !a)) ; lazy +;; b (tap (e/watch !b))] ; lazy +;; (tap (If2. x a b)))) tap tap) +;; % := :a +;; % := :b +;; % := :b +;; (swap! !x not) +;; % := :a)) + +(tests "lazy let" + (def !x (atom false)) + (def !a (atom :a)) + (def !b (atom :b)) + (with ((l/single {} (let [x (e/watch !x) + a (tap (e/watch !a)) + b (tap (e/watch !b))] + (if x a b))) tap tap) + % := :b + (swap! !x not) + % := :a)) + +(tests "reactive case" + (def !a (atom 0)) + (def !p (atom :p)) + (def !q (atom :q)) + (with ((l/single {} (tap (case (e/watch !a) + 0 (e/watch !p) + (e/watch !q)))) tap tap) + % := :p + (swap! !a inc) + % := :q + (reset! !q :qq) + % := :qq)) + +(tests "symbols in electric" + (with ((l/single {} (tap 'x)) tap tap) + % := 'x)) + +(tests "symbols in electric" + (with ((l/single {} (tap '[x])) tap tap) + % := '[x])) + +(tests "case on symbols" + (def !x (atom 'foo)) + (with ((l/single {} (tap (case (e/watch !x) foo 1 2))) tap tap) + % := 1)) + +(tests "case on vector" + (with ((l/single {} (tap (case '[a b] [a b] 1 2))) tap tap) + % := 1)) + +(tests "case with list" + (def !x (atom 'foo)) + (with ((l/single {} (tap (case 'a (a b) 1 2))) tap tap) + % := 1)) + +;; TODO `try` and `case` default +;; (tests "case with no matching clause" +;; (with ((l/single {} (try (case 2 1 1) +;; (catch #?(:clj IllegalArgumentException :cljs js/Error) e (tap [:right (ex-message e)])) +;; (catch #?(:clj Throwable :cljs :default) e (tap [:wrong e])))) tap tap)) +;; % := [:right "No matching clause: 2"]) + +(tests "binding" + (def foo 1) + (with ((l/single {} (tap (binding [foo 2] foo))) tap tap) + % := 2)) + +(tests "binding - fn" + (def foo) + (with ((l/single {} (binding [foo (partial tap)] (foo 1))) tap tap) + % := 1)) + +(tests "binding - e/fn" + (def foo) + (with ((l/single {} (binding [foo (e/fn [x] (tap x))] (foo. 1))) tap tap) + % := 1)) + +(tests "lexical closure" + (with ((l/single {} (tap (new (let [a 1] (e/fn [] a))))) tap tap) + % := 1)) + +(tests "join captures dynamic scope" + (def foo 1) + (with ((l/single {} (let [Q (e/fn [] foo)] + (binding [foo 2] + (tap (Q.))))) tap tap) + % := 2)) + +(tests "if with bindings" + (def !a (atom true)) + (def foo 1) + (with ((l/single {} (tap (binding [foo 2] (if (e/watch !a) foo (- foo))))) tap tap) + % := 2 + (swap! !a not) + % := -2)) + +(def foo4 1) +(tests "if with unwinding binding" + (def !a (atom true)) + (with ((l/single {} (tap (new (binding [foo4 2] (e/fn [] (if (e/watch !a) foo4 (- foo4))))))) tap tap) + % := 1 + (swap! !a not) + % := -1)) + +(def foo 1) +(def bar 2) + +(tests "reactive for" + (def !xs (atom [1 2 3])) + (with ((l/single {} (tap (e/for-by identity [x (e/watch !xs)] (prn x) (inc x)))) tap tap) + % := [2 3 4] + (swap! !xs conj 4) + % := [2 3 4 5])) + +(comment + (def !xs (atom [1 2 3])) + (def it ((l/single {} (tap (e/for-by identity [x (e/watch !xs)] (prn x) (inc x)))) tap tap)) + (swap! !xs conj 4) + (it) + + ) + +;; (tests "reactive for is differential (diff/patch)" +;; (def !xs (atom [1 2 3])) +;; (with ((l/single {} (tap (e/for-by identity [x (e/watch !xs)] (tap x)))) tap tap) +;; (hash-set % % %) := #{1 2 3} ; concurrent, order undefined +;; % := [1 2 3] +;; (swap! !xs conj 4) +;; % := 4 +;; % := [1 2 3 4] +;; (swap! !xs pop) +;; % := [1 2 3] ;; TODO glitch here +;; (swap! !xs assoc 1 :b) +;; % := :b +;; % := [1 :b 3])) + +;; (l/def foo 0) +;; (tests "Reactive for with bindings" +;; (def !items (atom ["a"])) +;; (with ((l/single {} (binding [foo 1] +;; (e/for [item (e/watch !items)] +;; (tap foo) +;; item))) tap tap) + +;; % := 1 +;; (swap! !items conj "b") +;; % := 1)) ; If 0 -> foo’s binding vanished + +;; (tests "reactive for with keyfn" +;; (def !xs (atom [{:id 1 :name "alice"} {:id 2 :name "bob"}])) +;; (with ((l/single {} (tap (e/for-by :id [x (e/watch !xs)] (tap x)))) tap tap) +;; (hash-set % %) := #{{:id 1 :name "alice"} {:id 2 :name "bob"}} +;; % := [{:id 1 :name "alice"} {:id 2 :name "bob"}] +;; (swap! !xs assoc-in [0 :name] "ALICE") +;; % := {:id 1 :name "ALICE"} +;; % := [{:id 1 :name "ALICE"} {:id 2 :name "bob"}])) + +;; (tests "reactive do (this is changing soon)" +;; ; see: https://www.notion.so/hyperfiddle/What-is-do-let-and-implement-ed781cc5645d4e83aa90b04e31988754 +;; ; current behavior is not compatible with cc/let +;; (def !x (atom 0)) +;; (with ((l/single {} (tap (do (tap :a) (tap (e/watch !x))))) tap tap) +;; ; Currently, do is not monadic sequence. +;; ; It's an incremental computation so only rerun what changed in our opinion +;; % := :a +;; % := 0 +;; % := 0 +;; (swap! !x inc) +;; ; no :a +;; % := 1 +;; % := 1)) + +;; (tests "do forces evaluation (introduces eagerness)" +;; ; Current behavior - do stmts are sampled eagerly, as fast as possible +;; (def !a (atom 0)) +;; (def !b (atom 0)) +;; (with ((l/single {} (tap @(doto !b (reset! (tap (new (m/watch !a))))))) tap tap) +;; % := 0 +;; % := 0 +;; (swap! !a inc) +;; ; the ref !b doesn't change, so we don't see 1 again +;; % := 1)) + +;; (comment "entrypoint forces evaluation (introduces eagerness)" ; desired behavior, we think +;; ; Alternative - do stmts are sampled (for effect) when result is sampled + +;; (def !a (atom 0)) +;; (def !b (atom 0)) +;; ((l/single {} (tap @(doto !b (reset! (tap (new (m/watch !a))))))) tap tap) +;; % := 0 +;; % := 0 +;; (swap! !a inc) +;; % := 1 +;; % := 1) + +;; #?(:clj (defn slow-identity [x] (Thread/sleep 30) x)) + +;; #?(:clj +;; (tests +;; (with ((l/single {} (try +;; ; This test asserts that these run concurrently. +;; ; If they block, the final tap would exceed the RCF timeout +;; (tap (e/offload #(slow-identity 1))) +;; (tap (e/offload #(slow-identity 2))) +;; (tap (e/offload #(slow-identity 3))) +;; (tap (e/offload #(slow-identity 4))) +;; (catch Pending _ (tap ::pending)))) tap tap) ; never see pending if thread is blocked +;; % := ::pending +;; (set [% % % %]) := #{3 1 2 4}))) ; concurrent sleeps race + +;; #?(:clj +;; (tests "reactive doto" +;; (defn MutableMap [] (new java.util.HashMap)) +;; (defn PutMap [!m k v] (.put !m k v)) +;; (defn Ref [] (new Object)) +;; (def !z (atom 0)) +;; (def !xx (atom 0)) +;; (with ((l/single {} +;; #_(doto (element "input") +;; (set-attribute! "type" "text") +;; (set-attribute! "value" x)) +;; (tap (doto (MutableMap) ; the doto is incrementalized +;; (PutMap "a" (swap! !z inc)) ; detect effect +;; (PutMap "b" (tap (e/watch !xx)))))) tap tap) +;; % := 0, % := {"a" 1 "b" 0} +;; (swap! !xx inc) +;; % := 1))) ; mutable map is clojure.core/=, therefore skipped + +;; (l/def trace!) +;; (l/defn Div [child] (trace! child) [:div child]) +;; (l/defn Widget [x] (Div. [(Div. x) (Div. :a)])) + +;; (tests "reactive defn" +;; ; best example of this is hiccup incremental maintenance +;; (def !x (atom 0)) +;; (with ((l/single {} (tap (binding [trace! tap] (Widget. (e/watch !x))))) tap tap) +;; % := 0 +;; % := :a +;; % := [[:div 0] [:div :a]] +;; % := [:div [[:div 0] [:div :a]]] +;; (swap! !x inc) +;; % := 1 +;; ; no :a +;; % := [[:div 1] [:div :a]] +;; % := [:div [[:div 1] [:div :a]]])) + +;; (l/def G (e/fn [x] x)) ; reactive fn (DAG). Compiler marks dag with meta +;; (tests "node call vs fn call" +;; (defn f [x] x) ; This var is not marked with meta +;; (def !x (atom 0)) +;; (with ((l/single {} (tap (let [x (e/watch !x)] [(f x) (G. x)]))) tap tap) +;; % := [0 0])) + +;; (l/def G (e/fn [x] x)) +;; (tests "higher order dags" +;; (def !x (atom 0)) +;; (defn f [x] x) +;; (with +;; ((l/single {} +;; (tap (let [ff (fn [x] x) ; foreign clojure fns are sometimes useful, e.g. DOM callbacks +;; Gg (e/fn [x] x) ; but you almost always want reactive lambda, not cc/fn +;; x (e/watch !x)] +;; [(f x) ; var marked +;; (G. x) ; var says node +;; (ff x) ; Must assume interop, for compat with clojure macros +;; (Gg. x) ; Must mark reactive-call +;; (new (e/fn [x] x) x)]))) tap tap) +;; % := [0 0 0 0 0])) + +;; (tests "reactive closures" +;; (def !x (atom 1)) +;; (def !y (atom 10)) +;; (l/def x (e/watch !x)) +;; (l/def y (e/watch !y)) +;; (with ((l/single {} (tap (new (if (odd? x) +;; (e/fn [x] (* y x)) +;; (e/fn [x] (* y x))) +;; x))) tap tap) +;; % := 10 +;; (swap! !x inc) +;; % := 20 +;; (swap! !x inc) +;; % := 30 +;; (swap! !y inc) +;; % := 33 +;; (swap! !y inc) +;; % := 36)) + +;; (tests "reactive closures 2" +;; (def !x (atom 0)) +;; (def !y (atom 0)) +;; (with +;; ((l/single {} (tap (let [x (e/watch !x) +;; y (e/watch !y) +;; F (e/fn [x] (+ y x)) ; constant signal +;; G (if (odd? x) (e/fn [x] (+ y x)) +;; (e/fn [x] (+ y x))) +;; H (new (m/seed [(e/fn [x] (+ y x))]))] +;; [(F. x) +;; (G. x) +;; (H. x)]))) tap tap) +;; % := [0 0 0])) + +;; (tests "reactive clojure.core/fn" +;; (def !x (atom 0)) +;; (def !y (atom 0)) +;; (with +;; ((l/single {} +;; (tap (let [x (e/watch !x) +;; y (e/watch !y) +;; ; rebuild Clojure closure f when y updates +;; f (fn [needle] (+ y needle))] +;; ; (value is fully compatible with fn contract) +;; ; the lambda is as variable as the var it closes over +;; ; well defined. It's not allowed to use dataflow inside FN. Compiler can never reach it +;; ; compiler will walk it to detect the free variables only +;; (f x)))) tap tap) +;; % := 0 +;; (swap! !y inc) +;; % := 1 +;; (swap! !x inc) +;; % := 2)) + +;; (tests "For reference, Clojure exceptions have dynamic scope" +;; (try (let [f (try (fn [] (throw (ex-info "boom" {}))) ; this exception will escape +;; (catch #?(:clj Exception, :cljs :default) _ ::inner))] +;; ; the lambda doesn't know it was constructed in a try/catch block +;; (f)) +;; (catch #?(:clj Exception, :cljs :default) _ ::outer)) +;; := ::outer) + +;; (tests "Reactor crashes on uncaugh exceptions" +;; (def !x (atom true)) +;; (with ((l/single {} (tap (assert (e/watch !x)))) tap tap) +;; % := nil ; assert returns nil or throws +;; (swap! !x not) ; will crash the reactor +;; ;; TODO in old tests an ex-info comes out, why? Is this a FailureInfo? +;; (ex-message %) := "Assert failed: (e/watch !x)" +;; (swap! !x not) ; reactor will not come back. +;; (tap ::nope), % := ::nope)) + +;; (l/defn Boom [] (assert false)) +;; (tests "reactive exceptions" +;; (with ((l/single {} (tap (try +;; (Boom.) +;; (catch #?(:clj AssertionError, :cljs js/Error) e +;; e)))) tap tap) +;; #?(:clj (instance? AssertionError %) +;; :cljs (instance? js/Error %)) := true)) + +;; (tests +;; (with ((l/single {} (tap (try (let [Nf (try (e/fn [] (Boom.)) ; reactive exception uncaught +;; (catch #?(:clj AssertionError, :cljs :default) _ ::inner))] +;; (Nf.)) +;; (catch #?(:clj AssertionError, :cljs :default) _ ::outer)))) tap tap) +;; % := ::outer)) + +;; (l/def inner) +;; (l/def Outer (e/fn [] inner)) + +;; (tests "dynamic scope (note that try/catch has the same structure)" +;; (with ((l/single {} (tap (binding [inner ::inner] (Outer.)))) tap tap) +;; % := ::inner)) + +;; (tests "dynamic scope (note that try/catch has the same structure)" +;; (with ((l/single {} (tap (binding [inner ::outer] +;; (let [Nf (binding [inner ::inner] +;; (e/fn [] (Outer.)))] ; binding out of scope +;; (Nf.))))) tap tap) +;; % := ::outer)) + +;; (tests "lazy parameters. Flows are not run unless sampled" +;; (with ((l/single {} (new (e/fn [_]) (tap :boom))) tap tap) +;; % := :boom)) + +;; (tests "lazy parameters. Flows are not run unless sampled" +;; (with ((l/single {} (let [_ (tap :bang)])) tap tap) ; todo, cc/let should sequence effects for cc compat +;; % := :bang)) + +;; (tests "client/server transfer" +;; ; Pending state is an error state. +;; ; Pending errors will crash the reactor if not caugh +;; (with ((l/single {} (try (tap (e/server (e/client 1))) (catch Pending _))) tap tap) +;; % := 1)) + +;; (l/def foo nil) +;; (tests +;; (with ((l/single {} (try (tap (binding [foo 1] (e/server (e/client foo)))) +;; (catch Pending _))) tap tap) +;; % := 1)) + +;; (l/def foo nil) +;; (tests +;; (with ((l/single {} (try (tap (binding [foo 1] (e/server (new (e/fn [] (e/client foo)))))) +;; (catch Pending _))) tap tap) +;; % := 1)) + +;; (l/def foo1 nil) +;; (l/def Bar1 (e/fn [] (e/client foo1))) +;; (tests +;; (with ((l/single {} (try (tap (binding [foo1 1] (e/server (Bar1.)))) +;; (catch Pending _))) tap tap) +;; % := 1)) + +;; (tests "reactive pending states" +;; ;~(m/reductions {} hyperfiddle.electric.impl.runtime/pending m/none) +;; (with ((l/single {} (tap (try true (catch Pending _ ::pending)))) tap tap) +;; % := true)) + +;; (tests +;; (with ((l/single {} (tap (try (e/server 1) (catch Pending _ ::pending)))) tap tap) +;; % := ::pending ; Use try/catch to intercept special pending state +;; % := 1)) + +;; (tests +;; (with ((l/single {} (tap (try [(tap 1) (tap (e/server 2))] (catch Pending _ ::pending)))) tap tap) +;; % := 1 +;; % := ::pending +;; ; do not see 1 again +;; % := 2 +;; % := [1 2])) + +;; (tests "the same exception is thrown from two places!" +;; (l/defn InputController1 [tap controlled-value] +;; (try controlled-value (catch Pending _ (tap :pending-inner)))) + +;; (with ((l/single {} (try +;; (InputController1. tap (throw (Pending.))) +;; (catch Pending _ (tap :pending-outer)))) tap tap)) +;; % := :pending-inner +;; % := :pending-outer) + +;; (tests "object lifecycle" +;; (def !x (atom 0)) +;; (let [hook (fn [mount! unmount!] +;; (m/observe (fn [!] +;; (mount!) +;; (! nil) +;; #(unmount!)))) +;; dispose! +;; ((l/single {} (tap +;; (let [x (e/watch !x)] +;; (when (even? x) +;; (new (e/fn [x] +;; (new (hook (partial tap 'mount) (partial tap 'unmount))) +;; x) +;; x))))) tap tap)] + +;; % := 'mount +;; % := 0 +;; (swap! !x inc) +;; (hash-set % %) := '#{unmount nil} ;; should ordering matter here ? +;; (swap! !x inc) +;; % := 'mount +;; % := 2 +;; (dispose!) +;; % := 'unmount)) + +;; (tests "object lifecycle 3" +;; (defn observer [x] +;; (fn mount [f] +;; (f (tap [:up x])) +;; (fn unmount [] (tap [:down x])))) + +;; (def !state (atom [1])) +;; (with ((l/single {} (e/for [x (e/watch !state)] (new (m/observe (observer x))))) tap tap) +;; % := [:up 1] +;; (swap! !state conj 2) +;; % := [:up 2] +;; (reset! !state [3]) +;; (hash-set % % %) := #{[:up 3] [:down 1] [:down 2]}) +;; % := [:down 3]) + +;; (tests "object lifecycle 3 with pending state" +;; (def !state (atom [1])) + +;; (defn observer [tap x] +;; (fn mount [f] +;; (tap [::mount x]) +;; (f nil) +;; (fn unmount [] (tap [::unmount x])))) + +;; (let [dispose ((l/single {} (try +;; (e/for [x (e/watch !state)] ; pending state should not trash e/for branches +;; (new (m/observe (observer tap x)))) ; depends on x, which is pending +;; (catch Pending _))) tap tap)] +;; % := [::mount 1] +;; (reset! !state [2]) +;; (hash-set % %) := #{[::mount 2] [::unmount 1]} +;; (reset! !state (Failure. (Pending.))) ; simulate pending state, we cannot use e/server due to distributed glitch +;; % := [::unmount 2] ; FAIL e/for unmounted the branch +;; (reset! !state [2]) +;; % := [::mount 2] ; branch is back up +;; (dispose) +;; % := [::unmount 2])) + +;; (l/def x2 1) +;; (tests "object lifecycle 4" +;; (def !input (atom [1 2])) +;; (defn up-down [x trace!] (m/observe (fn [!] (trace! :up) (! x) #(trace! :down)))) + +;; (with ((l/single {} +;; (tap (e/for [id (new (m/watch !input))] +;; (binding [x2 (do id x2)] +;; (new (up-down x2 tap)))))) tap tap) +;; [% %] := [:up :up] +;; % := [1 1] +;; (swap! !input pop) +;; % := :down +;; % := [1]) +;; % := :down) + +;; (tests "reactive metadata" +;; (def !x (atom 0)) +;; (with ((l/single {} (tap (meta (let [x (with-meta [] {:foo (e/watch !x)})] x)))) tap tap) +;; % := {:foo 0} +;; (swap! !x inc) +;; (tap ::hi) % := ::hi)) + +;; (tests "undefined continuous flow, flow is not defined for the first 10ms" +;; (let [flow (m/ap (m/? (m/sleep 10 :foo)))] +;; (with ((l/single {} (tap (new (new (e/fn [] (let [a (new flow)] (e/fn [] a))))))) tap tap) +;; (ex-message %) := "Undefined continuous flow."))) + +;; (tests +;; (def !x (atom 0)) +;; (with ((l/single {} (tap (try (-> (e/watch !x) +;; (doto (-> even? (when-not (throw (ex-info "odd" {}))))) +;; (/ 2)) +;; (catch #?(:clj Exception, :cljs :default) e (ex-message e))))) tap tap) +;; % := 0 +;; (swap! !x inc) +;; % := "odd" +;; (swap! !x inc) +;; % := 1)) + +;; (tests +;; (def !x (atom 0)) +;; (def !f (atom "hello")) +;; (def e (ex-info "error" {})) +;; (with ((l/single {} +;; (tap (try (if (even? (e/watch !x)) :ok (throw e)) +;; (catch #?(:clj Throwable, :cljs :default) _ :caugh) +;; (finally (tap (e/watch !f)))))) tap tap) +;; % := "hello" +;; % := :ok +;; (swap! !x inc) +;; % := :caugh +;; (reset! !f "world") +;; % := "world" +;; (swap! !x inc) +;; % := :ok)) + +;; (l/def unbound1) +;; (l/def unbound2) +;; (tests +;; (with ((l/single {} (tap (new (e/fn [] (binding [unbound1 1 unbound2 2] (+ unbound1 unbound2)))))) tap tap) +;; % := 3)) + +;; #?(:clj +;; (tests +;; "understand how Clojure handles unbound vars" +;; ; In Clojure, +;; ; Is unbound var defined or undefined behavior? +;; ; What does it mean in CLJS? No vars in cljs. +;; (def ^:dynamic y_964) +;; (bound? #'y_964) := false +;; (.isBound #'y_964) := false +;; (def unbound (clojure.lang.Var$Unbound. #'y_964)) +;; (instance? clojure.lang.Var$Unbound unbound) := true + +;; ; leaking unbounded value +;; (instance? clojure.lang.Var$Unbound y_964) := true + +;; ; not an error in clojure +;; (try y_964 (catch Exception e nil)) +;; (instance? clojure.lang.Var$Unbound *1) := true) +;; ) + +;; (tests "In Electric, accessing an unbound var throws a userland exception" +;; ;; An unbound var is either: +;; ;; - an uninitialized p/def, +;; ;; - an unsatisfied reactive fn parameter (reactive fn called with too few arguments). +;; (l/def x) +;; (with ((l/single {} x) prn tap) +;; (ex-message %) := "Unbound electric var `hyperfiddle.electric-test/x`")) + +;; (tests "Initial p/def binding is readily available in p/run" +;; (def !x (atom 0)) +;; (l/def X (m/watch !x)) +;; (with ((l/single {} (tap (X.))) tap tap) +;; % := 0 +;; (swap! !x inc) +;; % := 1)) + +;; #?(:clj +;; (tests ; GG: IDE doc on hover support +;; "Vars created with p/def have the same metas as created with cc/def" +;; (l/def Documented "p/def" :init) +;; (select-keys (meta (var Documented)) [:name :doc]) +;; := {:name 'Documented +;; :doc "p/def"})) + +;; #?(:clj +;; (tests ; GG: IDE doc on hover support +;; "Vars created with p/defn have the same metas as created with cc/defn" +;; (l/defn Documented "doc" [a b c]) +;; (select-keys (meta (var Documented)) [:name :doc :arglists]) +;; := {:name 'Documented +;; :doc "doc" +;; :arglists '([a b c])})) + +;; (tests "pentagram of death - via Kenny Tilton" +;; ; Key elements: +;; ; - two dependency chains from some property P leading back to one property X; and +;; ; - branching code in the derivation of P that will not travel the second dependency chain until a +;; ; certain condition is met; and +;; ; - by chance, propagation reaches P on the the first path before it reaches some intermediate property +;; ; I on the second dependency chain. +;; ; The consequence is P updating once and reading (for the first time) property I, which has not yet been +;; ; updated hence is inconsistent with the new value of X. This inconsistency is temporary (hence the name +;; ; "glitch") because I will be updated soon enough and P will achieve consistency with X, but if one's +;; ; reactive engine dispatches side effects off state change -- possible trouble. +;; (def !aa (atom 1)) +;; (def !a7 (atom 7)) +;; (with +;; ((l/single {} +;; (let [aa (e/watch !aa) +;; a7 (e/watch !a7) +;; a70 (* 10 a7) +;; bb aa +;; cc (* 10 aa) +;; dd (if (even? bb) +;; (* 10 cc) +;; 42)] +;; (tap (+ a70 bb (* 10000 dd))))) tap tap) +;; % := 420071 +;; (swap! !aa inc) +;; % := 2000072 +;; (swap! !aa inc) +;; % := 420073)) + +;; (tests "pentagram of death reduced" +;; ; the essence of the problem is: +;; ; 1. if/case switch/change the DAG (imagine a railroad switch between two train tracks) +;; ; 2. to have a conditional where the predicate and the consequent have a common dependency +;; (def !x (atom 1)) +;; (with ((l/single {} (tap (let [p (e/watch !x) +;; q (tap (str p)) +;; control (- p)] +;; (case control -1 p -2 q q)))) tap tap) +;; % := "1" ; cc/let sequences effects +;; % := 1 ; cross +;; (swap! !x inc) +;; % := "2" ; q first touched +;; % := "2")) + +;; (tests "for with literal input" +;; (with ((l/single {} (tap (e/for [x [1 2 3]] (tap x)))) tap tap) +;; (hash-set % % %) := #{1 2 3} +;; % := [1 2 3])) + +;; (tests "for with literal input, nested" +;; (def !x (atom 0)) +;; (with ((l/single {} (tap (when (even? (e/watch !x)) +;; (e/for [x [1 2 3]] +;; (tap x))))) tap tap) +;; (hash-set % % %) := #{1 2 3} +;; % := [1 2 3] +;; (swap! !x inc) +;; % := nil)) + +;; (tests "nested closure" +;; (def !x (atom 0)) +;; (with ((l/single {} (tap (new (let [x (e/watch !x)] +;; (if (even? x) +;; (e/fn [] :even) +;; (e/fn [] :odd)))))) tap tap) +;; % := :even +;; (swap! !x inc) +;; % := :odd)) + +;; (tests "simultaneous add and remove in a for with a nested hook" +;; (def !xs (atom [1])) +;; (defn hook +;; ([x] (tap [x])) +;; ([x y] (tap [x y]))) +;; (with +;; ((l/single {} +;; (tap (new (e/hook hook 0 +;; (e/fn [] +;; (e/for [x (e/watch !xs)] +;; (new (e/hook hook x +;; (e/fn [] (str x)))))))))) tap tap) +;; % := [1 nil] +;; % := ["1"] +;; (reset! !xs [2]) +;; % := [2 nil] +;; % := ["2"] +;; % := [1] ;; unmount on next frame ??? +;; ) +;; % := [2] +;; % := [0]) + +;; (tests +;; (def !t (atom true)) +;; (with ((l/single {} +;; (tap (try (let [t (e/watch !t)] +;; (when t t (e/server t))) +;; (catch Pending _ :pending) +;; #_(catch Cancelled _ :cancelled)))) tap tap) +;; % := :pending +;; % := true +;; (swap! !t not) +;; % := nil)) + +;; (tests +;; (def !state (atom true)) +;; (with ((l/single {} (when (e/watch !state) (tap :touch))) tap tap) +;; % := :touch +;; (reset! !state true) +;; (tap ::nope) % := ::nope)) + +;; (tests "e/for in a conditional" +;; (def !state (atom true)) +;; (with ((l/single {} (tap (if (e/watch !state) 1 (e/for [_ []])))) tap tap) +;; % := 1 +;; (swap! !state not) +;; % := [] +;; (swap! !state not) +;; % := 1) +;; ) + + +;; (comment ; we are not sure if this test has value. It is not minimized. +;; (tests "Hack for e/for in a conditional. Passes by accident" ; PASS +;; (def !state (atom true)) +;; (with ((l/single {} (tap (if (e/watch !state) 1 (try (e/for [_ []]) (catch Throwable t (throw t)))))) tap tap) +;; % := 1 +;; (swap! !state not) +;; % := [] +;; (swap! !state not) +;; % := 1))) + +;; (tests "Nested e/for with transfer" +;; (def !state (atom [1])) +;; (l/def state (e/watch !state)) +;; (with ((l/single {} (try (e/for [x (e/server state)] +;; (e/for [y (e/server state)] +;; (tap [x y]))) +;; (catch Cancelled _) +;; (catch Pending _))) tap tap) +;; % := [1 1] +;; (reset! !state [3]) +;; % := [3 3])) + +;; (tests +;; "Static call" +;; (with ((l/single {} (tap (Math/abs -1))) tap tap) +;; % := 1)) + +;; #?(:clj +;; (tests "Dot syntax works (clj only)" +;; (with ((l/single {} (tap (. Math abs -1))) tap tap) +;; % := 1))) + +;; (tests "Sequential destructuring" +;; (with ((l/single {} (tap (let [[x y & zs :as coll] [:a :b :c :d]] [x y zs coll]))) tap tap) +;; % := [:a :b '(:c :d) [:a :b :c :d]])) + +;; (tests "Associative destructuring" +;; (with ((l/single {} (tap (let [{:keys [a ns/b d] +;; :as m +;; :or {d 4}} +;; {:a 1, :ns/b 2 :c 3}] [a b d m]))) tap tap) +;; % := [1 2 4 {:a 1, :ns/b 2, :c 3}])) + +;; (tests "Associative destructuring with various keys" +;; (with ((l/single {} (tap (let [{:keys [a] +;; :ns/keys [b] +;; :syms [c] +;; :ns/syms [d] +;; :strs [e]} +;; {:a 1, :ns/b 2, 'c 3, 'ns/d 4, "e" 5}] +;; [a b c d e]))) tap tap) +;; % := [1 2 3 4 5])) + +;; (tests "fn destructuring" +;; (with ((l/single {} +;; (try +;; (tap (e/client ((fn [{:keys [a] ::keys [b]}] [::client a b]) {:a 1 ::b 2}))) +;; (tap (e/server ((fn [{:keys [a] ::keys [b]}] [::server a b]) {:a 1 ::b 2}))) +;; (catch Pending _))) tap tap)) +;; % := [::client 1 2] +;; % := [::server 1 2]) + +;; (tests +;; (def !xs (atom [false])) +;; (with +;; ((l/single {} +;; (tap (try (e/for [x (e/watch !xs)] +;; (assert x)) +;; (catch #?(:clj Error :cljs js/Error) _ :error)))) tap tap) +;; % := :error +;; (reset! !xs []) +;; % := [])) + +;; (tests "All Pending instances are equal" +;; (= (Pending.) (Pending.)) := true) + +;; (tests +;; "Failure instances are equal if the errors they convey are equal" +;; (= (Failure. (Pending.)) (Failure. (Pending.))) := true + +;; (let [err (ex-info "error" {})] +;; (= err err) := true +;; (= (Failure. err) (Failure. err)) := true +;; (= (ex-info "a" {}) (ex-info "a" {})) := false +;; (= (Failure. (ex-info "err" {})) (Failure. (ex-info "err" {}))) := false)) + +;; (tests ; temporary test because p/run does not serilize to transit. +;; "Electric transit layer serializes unserializable values to nil" +;; (electric-io/decode (electric-io/encode 1)) := 1 +;; (electric-io/decode (electric-io/encode (type 1))) := nil) + +;; ;; HACK sequences cljs async tests. Symptomatic of an RCF issue. +;; ;; Ticket: https://www.notion.so/hyperfiddle/cljs-test-suite-can-produce-false-failures-0b3799f6d2104d698eb6a956b6c51e48 +;; #?(:cljs (t/use-fixtures :each {:after #(t/async done (js/setTimeout done 1))})) + +;; (tests +;; (def !x (atom true)) +;; (with ((l/single {} +;; (try +;; (let [x (e/watch !x)] +;; ; check eager network does not beat the switch +;; (tap (if x (e/server [:server x]) [:client x]))) +;; (catch Pending _))) tap tap) +;; % := [:server true] +;; (swap! !x not) +;; ; the remote tap on the switch has been removed +;; % := [:client false])) + +;; (tests +;; (def !x (atom true)) +;; (l/def x (e/server (e/watch !x))) +;; (with ((l/single {} +;; (try +;; (if (e/server x) ; to be consistent, client should see x first and switch +;; (e/server (tap x)) ; but test shows that the server sees x change before client +;; (e/server x)) +;; (catch Pending _))) tap tap) +;; % := true +;; (swap! !x not) +;; % := false #_ ::rcf/timeout) +;; ; we have to choose: consistency or less latency? +;; ; current behavior - Dustin likes, Leo does not like +;; ) + +;; ;; https://www.notion.so/hyperfiddle/distribution-glitch-stale-local-cache-of-remote-value-should-be-invalidated-pending-47f5e425d6cf43fd9a37981c9d80d2af +;; (tests "glitch - stale local cache of remote value should be invalidated/pending" +;; (def !x (atom 0)) +;; (def dispose ((l/single {} (tap (try (let [x (new (m/watch !x))] +;; ;; pending or both equal +;; [x (e/server x)]) +;; (catch Pending _ ::pending)))) tap tap)) +;; % := ::pending +;; % := [0 0] +;; (swap! !x inc) +;; % := ::pending +;; % := [1 1] +;; (dispose)) + +;; (comment +;; ; https://www.notion.so/hyperfiddle/p-fn-transfer-d43869c673574390b186ccb4df824b39 +;; ((l/single {} +;; (e/server +;; (let [Foo (e/fn [] (type 1))] +;; (tap (Foo.)) +;; (tap (e/client (Foo.)))))) tap tap) +;; % := "class java.lang.Long" +;; % := "class #object[Number]" + +;; ; implications - all ~e/fns~ neutral electric expressions are compiled for both peers, including +;; ; the parts that don't make sense, because you don't know in advance which peer will +;; ; run which function + +;; ; costs: +;; ; increases size of compiler artifacts +;; ; increases compile times +;; ) + +;; (tests +;; (with ((l/single {} (try (e/server +;; (let [foo 1] +;; (tap foo) +;; (tap (e/client foo)))) +;; (catch Pending _))) tap tap) +;; % := 1 +;; % := 1)) + +;; (tests "Today, bindings fail to transfer, resulting in unbound var exception. This will be fixed" +;; ; https://www.notion.so/hyperfiddle/photon-binding-transfer-unification-of-client-server-binding-7e56d9329d224433a1ee3057e96541d1 +;; (l/def foo) +;; (with ((l/single {} (try +;; (e/server +;; (binding [foo 1] +;; (tap foo) +;; (tap (e/client foo)))) +;; (catch Pending _) +;; (catch #?(:clj Error :cljs js/Error) e +;; (tap e)))) tap tap) +;; % := 1 +;; ; % := 1 -- target future behavior +;; (type %) := #?(:clj Error :cljs js/Error))) + +;; (tests "static method call" +;; (with ((l/single {} (tap (Math/max 2 1))) tap tap) +;; % := 2)) + +;; (tests "static method call in e/server" +;; (with ((l/single {} (try (tap (e/server (Math/max 2 1))) +;; (catch Pending _))) tap tap) +;; % := 2)) + +;; (tests "static method call in e/client" +;; (with ((l/single {} (try (tap (e/server (subvec (vec (range 10)) +;; (Math/min 1 1) +;; (Math/min 3 3)))) +;; (catch Pending _))) tap tap) +;; % := [1 2])) + +;; (tests "Inline cc/fn support" +;; (def !state (atom 0)) +;; (l/def global) +;; (with ((l/single {} (let [state (e/watch !state) +;; local [:local state] +;; f (binding [global [:global state]] +;; (fn ([a] [a local hyperfiddle.electric-test/global]) +;; ([a b] [a b local global]) +;; ([a b & cs] [a b cs local global])))] +;; (tap (f state)) +;; (tap (f state :b)) +;; (tap (f state :b :c :d)))) tap tap) +;; % := [0 [:local 0] [:global 0]] +;; % := [0 :b [:local 0] [:global 0]] +;; % := [0 :b '(:c :d) [:local 0] [:global 0]] +;; (swap! !state inc) +;; % := [1 [:local 1] [:global 1]] +;; % := [1 :b [:local 1] [:global 1]] +;; % := [1 :b '(:c :d) [:local 1] [:global 1]])) + +;; (tests "cc/fn lexical bindings are untouched" +;; (with ((l/single {} (let [a 1 +;; b 2 +;; f (fn [a] (let [b 3] [a b]))] +;; (tap (f 2)))) tap tap) +;; % := [2 3])) + +;; (tests "Inline cc/fn shorthand support" +;; (with ((l/single {} (tap (#(inc %) 1))) tap tap) +;; % := 2)) + +;; (tests "inline m/observe support" +;; (let [!state (atom 0)] +;; (with ((l/single {} (let [state (e/watch !state) +;; lifecycle (m/observe (fn [push] +;; (tap :up) +;; (push state) +;; #(tap :down))) +;; val (new lifecycle)] +;; (tap val))) tap tap) +;; % := :up +;; % := 0 +;; (swap! !state inc) +;; % := :down +;; % := :up +;; % := 1) +;; % := :down)) + +;; (tests "Inline letfn support" +;; (with ((l/single {} (tap (letfn [(descent [x] (cond (pos? x) (dec x) +;; (neg? x) (inc x) +;; :else x)) +;; (is-even? [x] (if (zero? x) true (is-odd? (descent x)))) +;; (is-odd? [x] (if (zero? x) false (is-even? (descent x))))] +;; (tap [(is-even? 0) (is-even? 1) (is-even? 2) (is-even? -2)]) +;; (tap [(is-odd? 0) (is-odd? 2) (is-odd? 3) (is-odd? -3)])))) tap tap) +;; % := [true false true true] +;; % := [false false true true] +;; % := [false false true true])) + +;; (tests +;; (with ((l/single {} (try (letfn [(foo [])] +;; (tap (e/watch (atom 1)))) +;; (catch Throwable t (prn t)))) tap tap) +;; % := 1)) + +;; (tests "Inline letfn support" +;; (def !state (atom 0)) +;; (l/def global) +;; (with ((l/single {} (let [state (e/watch !state) +;; local [:local state]] +;; (binding [global [:global state]] +;; (letfn [(f ([a] [a local hyperfiddle.electric-test/global]) +;; ([a b] [a b local global]) +;; ([a b & cs] [a b cs local global]))] +;; (tap (f state)) +;; (tap (f state :b)) +;; (tap (f state :b :c :d)))))) tap tap) +;; % := [0 [:local 0] [:global 0]] +;; % := [0 :b [:local 0] [:global 0]] +;; % := [0 :b '(:c :d) [:local 0] [:global 0]] +;; (swap! !state inc) +;; % := [1 [:local 1] [:global 1]] +;; % := [1 :b [:local 1] [:global 1]] +;; % := [1 :b '(:c :d) [:local 1] [:global 1]])) + +;; #?(:clj +;; (tests "e/fn is undefined in clojure-land" +;; (tap (try (lang/analyze {} `(fn [] (e/fn []))) (catch Throwable e (ex-message (ex-cause e))))) +;; % := "Electric code (hyperfiddle.electric/fn) inside a Clojure function")) + +;; #?(:clj +;; (tests "e/client is undefined in clojure-land" +;; (tap (try (lang/analyze {} `(fn [] (e/client []))) (catch Throwable e (ex-message (ex-cause e))))) +;; % := "Electric code (hyperfiddle.electric/client) inside a Clojure function")) + +;; #?(:clj +;; (tests "e/server is undefined in clojure-land" +;; (tap (try (lang/analyze {} `(fn [] (e/server []))) (catch Throwable e (ex-message (ex-cause e))))) +;; % := "Electric code (hyperfiddle.electric/server) inside a Clojure function")) + +;; #?(:clj +;; (tests "e/server is undefined in clojure-land" +;; (tap (try (lang/analyze {} `(fn [] (e/watch (atom :nomatter)))) (catch Throwable e (ex-message (ex-cause e))))) +;; % := "Electric code (hyperfiddle.electric/watch) inside a Clojure function")) + +;; (tests "cycle" +;; (with ((l/single {} +;; (let [!F (atom (e/fn [] 0))] +;; (tap (new (new (m/watch !F)))) +;; (let [y 1] (reset! !F (e/fn [] y))))) tap tap) +;; % := 0 +;; % := 1)) + +;; #?(:clj ; test broken in cljs, not sure why +;; (tests "loop/recur" +;; (l/defn fib [n] (loop [n n] (if (<= n 2) 1 (+ (recur (dec n)) (recur (- n 2)))))) +;; (with ((l/single {} (tap (e/for [i (range 1 11)] (fib. i)))) tap tap) +;; % := [1 1 2 3 5 8 13 21 34 55]))) + +;; ;; currently broken https://www.notion.so/hyperfiddle/cr-macro-internal-mutation-violates-photon-purity-requirement-119c18755ddd466384beb15f1e2317c5 +;; #_ +;; (tests +;; "inline m/cp support" +;; (let [!state (atom 0)] +;; (with (p/run (let [state (p/watch !state)] +;; (tap (new (m/cp state))))) +;; % := 0 +;; (swap! !state inc) +;; % := 1)) + +;; "inline m/ap support" +;; (let [!state (atom [1])] +;; (with (p/run (let [coll (p/watch !state)] +;; (tap (new (m/ap (tap (m/?< (m/seed coll)))))))) +;; % := 1 +;; % := 1 +;; (swap! !state conj 2) +;; % := 1 +;; % := 2 +;; % := 2))) + +;; (tests "letfn body is electric" +;; (l/def z 3) +;; (def !x (atom 4)) +;; (with ((l/single {} (let [y 2] (letfn [(f [x] (g x)) (g [x] [x y z])] (tap (f (e/watch !x)))))) tap tap) +;; % := [4 2 3] +;; (swap! !x inc) +;; % := [5 2 3])) + +;; ;; currently broken https://www.notion.so/hyperfiddle/cr-macro-internal-mutation-violates-photon-purity-requirement-119c18755ddd466384beb15f1e2317c5 +;; #_ +;; (tests +;; "inline m/sp support" +;; (let [!state (atom 0)] +;; (with (p/run (let [val (p/watch !state) +;; task (m/sp val)] +;; (tap (new (m/relieve {} (m/reductions {} :init (m/ap (m/? task)))))))) +;; % := 0 +;; (swap! !state inc) +;; % := 1 +;; ))) + +;; #?(:clj +;; (tests "set!" +;; (def !y (atom 8)) +;; (with ((l/single {} (let [pt (java.awt.Point. 1 2) +;; y (e/watch !y)] +;; (set! (.-y pt) y) +;; ;; calling (.-y pt) doesn't work, it's deduped +;; (tap [y pt]))) tap tap) +;; % := [8 (java.awt.Point. 1 8)] +;; (swap! !y inc) +;; % := [9 (java.awt.Point. 1 9)]))) + +;; #?(:cljs +;; (do-browser +;; (tests "set!" +;; ;; https://www.notion.so/hyperfiddle/RCF-implicit-do-rewrite-rule-does-not-account-for-let-bindings-61b1ad82771c407198c1f678683bf443 +;; (defn bypass-rcf-bug [[href a]] [href (str/replace (.-href a) #".*/" "")]) +;; (def !href (atom "href1")) +;; (with ((l/single {} (let [a (.createElement js/document "a") +;; href (e/watch !href)] +;; (set! (.-href a) href) +;; (tap [href a]))) tap tap) +;; (bypass-rcf-bug %) := ["href1" "href1"] +;; (reset! !href "href2") +;; (bypass-rcf-bug %) := ["href2" "href2"])))) + +;; #?(:clj (tests "set! with electric value" +;; (with ((l/single {} (tap (let [pt (java.awt.Point. 1 2)] +;; (set! (.-y pt) (new (e/fn [] 0)))))) tap tap) +;; % := 0))) + +;; #?(:cljs (tests "set! with electric value" +;; (with ((l/single {} (tap (let [o (js/Object.)] +;; (set! (.-x o) (new (e/fn [] 0)))))) tap tap) +;; % := 0))) + +;; (tests "e/fn arity check" +;; (with ((l/single {} (try (new (e/fn [x y z] (throw (ex-info "nope" {}))) 100 200 300 400) +;; (catch ExceptionInfo e (tap e)) +;; (catch Cancelled _) +;; (catch Throwable t (prn t)))) tap tap) +;; (ex-message %) := "You called with 4 arguments but it only supports 3")) + +;; (l/defn ThreeThrow [_ _ _] (throw (ex-info "nope"))) +;; (tests "e/fn arity check" +;; (with ((l/single {} (try (new ThreeThrow 100 200 300 400) +;; (catch ExceptionInfo e (tap e)) +;; (catch Cancelled _) +;; (catch Throwable t (prn t)))) tap tap) +;; (ex-message %) := "You called ThreeThrow with 4 arguments but it only supports 3")) + +;; (tests "e/fn arity check" +;; (with ((l/single {} (try (new (e/fn Named [x y] (throw (ex-info "nope" {}))) 100) +;; (catch ExceptionInfo e (tap e)) +;; (catch Cancelled _) +;; (catch Throwable t (prn t)))) tap tap) +;; (ex-message %) := "You called Named with 1 argument but it only supports 2")) + +;; (tests "Partial application" +;; (with ((l/single {} +;; (tap (new (e/partial 0 (e/fn [] :a)) )) +;; (tap (new (e/partial 1 (e/fn [a] a) :a))) +;; (tap (new (e/partial 2 (e/fn [a b] [a b]) :a) :b)) +;; (tap (new (e/partial 4 (e/fn [a b c d] [a b c d]) :a :b) :c :d))) tap tap) +;; % := :a +;; % := :a +;; % := [:a :b] +;; % := [:a :b :c :d])) + +;; (l/def Factorial-gen (e/fn [Rec] +;; (e/fn [n] +;; (if (zero? n) +;; 1 +;; (* n (new Rec (dec n))))))) + +;; (l/def Y "Y-Combinator" +;; (e/fn [f] +;; (new +;; (e/fn [x] (new x x)) +;; (e/fn [x] (new f (e/fn [y] (new (new x x) y))))))) + +;; (tests "Y-Combinator" +;; (let [!n (atom 5)] +;; (with ((l/single {} (tap (new (Y. Factorial-gen) (e/watch !n)))) tap tap) +;; % := 120 +;; (reset! !n 20) +;; % := 2432902008176640000))) + +;; (tests "clojure def inside electric code" +;; (def !x (atom 0)) +;; (with ((l/single {} (def --foo (tap (e/watch !x)))) tap tap) +;; % := 0, --foo := 0 +;; (swap! !x inc) % := 1, --foo := 1)) + +;; (tests "catch handlers are work skipped" +;; (def !x (atom 0)) +;; (with ((l/single {} (try (e/watch !x) +;; (throw (ex-info "hy" {})) +;; (catch ExceptionInfo e (tap e)) +;; (catch Cancelled _ (tap :cancelled)))) tap tap) +;; (ex-message %) := "hy" ; exception tapped by `ExceptionInfo` catch block +;; (swap! !x inc)) ; same exception, so work skipped +;; % := :cancelled) + +;; (tests "pendings don't enter cc/fn's" +;; (with ((l/single {} (try (let [v (new (m/observe (fn [!] (! r/pending) (def ! !) #(do))))] +;; (#(tap [:v %]) v)) +;; (catch Pending _ (tap :pending)) +;; (catch #?(:clj Throwable :cljs :default) e (prn [(type e) (ex-message e)])))) tap tap) +;; % := :pending +;; (! 1) +;; % := [:v 1])) + +;; (tests "catch code reacts to changes" +;; (def !x (atom 0)) +;; (with ((l/single {} (tap (try (throw (ex-info "boom" {})) +;; (catch Throwable _ (e/watch !x))))) tap tap) +;; % := 0 +;; (swap! !x inc) +;; % := 1)) + +;; (tests "Electric dynamic scope is available in cc/fn" +;; (l/def ^:dynamic dynfoo 1) +;; (with ((l/single {} +;; (try +;; ((fn [] +;; (tap dynfoo))) +;; (binding [dynfoo 2] +;; ((fn [] (tap dynfoo)))) +;; (catch #?(:clj Throwable, :cljs js/Error) t (prn t)))) tap tap) +;; % := 1 +;; % := 2)) + +;; #?(:clj ; fail to compile in cljs: `Can't set! local var or non-mutable field` (foo177584 is not dynamic) +;; (tests "l/def are not dynamic by default in cc/fn" +;; (l/def foo177584 1) +;; (with ((l/single {} +;; (try +;; ((fn [] (binding [foo177584 2] (tap foo177584)))) ; foo177584 is not ^:dynamic +;; (catch #?(:clj Throwable, :cljs js/Error) t (tap (ex-message t))))) tap tap) +;; % := "Can't dynamically bind non-dynamic var: hyperfiddle.electric-test/foo177584"))) + +;; (tests "Injecting an l/def binding in cc/fn respects dynamic scope rules" +;; (l/def ^:dynamic dynfoo 1) +;; (with ((l/single {} +;; (try +;; (tap dynfoo) ; electric dynamic context +;; (binding [dynfoo 2] ; rebound in electic context +;; ((fn [] +;; (tap dynfoo) ; injected dynamic context +;; (binding [dynfoo 3] ; rebound in clojure context +;; (tap dynfoo) ; read clojure context +;; ))) +;; (tap dynfoo)) ; cc/fn scope doesn't alter electric scope +;; (catch #?(:clj Throwable, :cljs js/Error) t (prn t)))) tap tap) +;; % := 1 +;; % := 2 +;; % := 3 +;; % := 2)) + +;; (tests "In Clojure, unqualified names first resolves to lexical scope" +;; (def ^:dynamic foo 1) +;; foo := 1 ; no lexical binding shadowing -> resolve to foo var +;; (let [foo 2] ; lexical shadowing +;; foo := 2 ; resolve to lexical scope +;; (binding [#?(:clj foo, :cljs hyperfiddle.electric-test/foo) 3] ; always rebind var in clojure. Cljs requires fully qualified name. +;; foo := 2 ; unqualified name resolves to lexical scope +;; hyperfiddle.electric-test/foo := 3))) ; qualified name resolves to the var + +;; #?(:clj +;; (tests "cc/fn args shadow l/def injections" +;; (l/def ^:dynamic dynfoo 1) +;; (with ((l/single {} +;; (try +;; (tap dynfoo) ; electric dynamic context +;; ((fn [dynfoo] ; dynvar shadowed by argument +;; (tap dynfoo) +;; (binding [dynfoo 2] ; rebinds the vars +;; (tap dynfoo) ; still resolves to argument in lexical scope +;; (tap hyperfiddle.electric-test/dynfoo))) +;; :argument) +;; (catch #?(:clj Throwable, :cljs js/Error) t (prn t)))) tap tap) +;; % := 1 +;; % := :argument +;; % := :argument +;; % := 2))) + +;; #?(:clj +;; (tests "Injected lexical scope respects precedence over injected dynamic scope" +;; (l/def ^:dynamic dynfoo 1) +;; (with ((l/single {} +;; (try +;; (tap dynfoo) +;; (let [dynfoo :shadowed] +;; ((fn [] +;; (tap dynfoo) +;; (binding [dynfoo 2] +;; (tap dynfoo) +;; (tap hyperfiddle.electric-test/dynfoo))) +;; )) +;; (catch #?(:clj Throwable, :cljs js/Error) t (prn t)))) tap tap) +;; % := 1 +;; % := :shadowed +;; % := :shadowed +;; % := 2))) + +;; #?(:clj +;; (tests "Shadowing injected dynamic scope in cc context respects clojure shadowing rules" +;; (l/def ^:dynamic dynfoo 1) +;; (with ((l/single {} +;; (try +;; (tap dynfoo) +;; ((fn [] +;; (tap dynfoo) +;; (let [dynfoo :shadowed] +;; (tap dynfoo) +;; (binding [dynfoo 2] +;; (tap dynfoo) +;; (tap hyperfiddle.electric-test/dynfoo))))) +;; (catch #?(:clj Throwable, :cljs js/Error) t (prn t)))) tap tap) +;; % := 1 +;; % := 1 +;; % := :shadowed +;; % := :shadowed +;; % := 2))) + +;; (tests "snapshot" +;; (def flow (e/-snapshot (m/observe (fn [!] (def ! !) #())))) +;; "1 2 -> 1" +;; (def it (flow #(tap :notified) #(tap :terminated))) +;; (! 1), % := :notified, @it := 1 +;; (! 2) +;; (it), % := :terminated +;; "Pending 1 2 -> Pending 1" +;; (def it (flow #(tap :notified) #(tap :terminated))) +;; (! r/pending), % := :notified, @it := r/pending +;; (! 1), % := :notified, @it := 1 +;; (! 2) +;; (it), % := :terminated +;; "Pending Pending 1 2 -> Pending Pending 1" +;; (def it (flow #(tap :notified) #(tap :terminated))) +;; (! r/pending), % := :notified, @it := r/pending +;; (! r/pending), % := :notified, @it := r/pending +;; (! 1), % := :notified, @it := 1 +;; (! 2) +;; (it), % := :terminated +;; "ex-info 1 2 -> ex-info" +;; (def it (flow #(tap :notified) #(tap :terminated))) +;; (def boom (Failure. (ex-info "boom" {}))) +;; (! boom), % := :notified, @it := boom +;; (! 1) +;; (! 2) +;; (it), % := :terminated +;; "1 Pending 2 -> 1" +;; (def it (flow #(tap :notified) #(tap :terminated))) +;; (! 1), % := :notified, @it := 1 +;; (! r/pending) +;; (! 2) +;; (it), % := :terminated +;; "Pending ex-info 1 -> Pending ex-info" +;; (def it (flow #(tap :notified) #(tap :terminated))) +;; (def boom (Failure. (ex-info "boom" {}))) +;; (! r/pending), % := :notified, @it := r/pending +;; (! boom), % := :notified, @it := boom +;; (! 1) +;; (it), % := :terminated + +;; (tap ::done), % := ::done, (println " ok")) + +;; (tests "for-event" +;; (def ! (atom nil)) +;; (def !resolvers (atom {})) +;; (defn !! [k v] (reset! (@!resolvers k) v)) +;; (with ((l/single {} (tap (try (e/for-event [e (m/observe (fn [!!] (reset! ! !!) #(do)))] +;; (let [!v (atom :pending)] +;; (swap! !resolvers assoc e !v) +;; (try (let [v (e/watch !v)] +;; (case v +;; :pending (throw (Pending.)) +;; :caught (throw (ex-info "caught" {})) +;; :uncaught (throw (ex-info "uncaught" {})) +;; #_else v)) +;; (catch Pending _ :pending) +;; (catch #?(:clj Throwable :cljs :default) e +;; (case (ex-message e) +;; "caught" (reduced nil) +;; #_else (throw e)))))) +;; (catch #?(:clj Throwable :cljs :default) e [(type e) (ex-message e)])))) tap tap) +;; #_init % := [] +;; (@! 0), % := [:pending] +;; (@! 1), % := [:pending :pending] +;; (!! 1 (reduced nil)), % := [:pending nil], % := [:pending] +;; (!! 0 (reduced true)), % := [nil], % := [] +;; (@! 2), % := [:pending] +;; (!! 2 :caught), % := [nil], % := [] +;; (@! 99), % := [:pending] +;; (!! 99 :uncaught), % := [ExceptionInfo "uncaught"] +;; (!! 99 :alive), % := [:alive] +;; (!! 99 (reduced nil)), % := [nil], % := [])) + +;; (tests "for-event-pending" +;; (def ! (atom nil)) +;; (def !resolvers (atom {})) +;; (defn !! [k v] (reset! (@!resolvers k) v)) +;; (def fail (ex-info "i fail" {})) +;; (with ((l/single {} (tap (e/for-event-pending [e (m/observe (fn [!!] (reset! ! !!) #(do)))] +;; (let [!v (atom :pending)] +;; (swap! !resolvers assoc e !v) +;; (let [v (e/watch !v)] +;; (case v +;; :pending (throw (Pending.)) +;; :fail (throw fail) +;; #_else v)))))) tap tap) +;; #_init % := [::e/init] +;; (@! 0), % := [::e/pending e/pending] +;; (@! 1) ;; work skipped +;; (!! 1 nil) ;; work skipped, 0 still pending +;; (!! 0 false) % := [::e/ok false] +;; (@! 2), % := [::e/pending e/pending] +;; (!! 2 :fail), % := [::e/failed fail])) + +;; (tests "for-event-pending-switch" +;; (def ! (atom nil)) +;; (def !resolvers (atom {})) +;; (defn !! [k v] (reset! (@!resolvers k) v)) +;; (def fail (ex-info "i fail" {})) +;; (with ((l/single {} (tap (e/for-event-pending-switch [e (m/observe (fn [!!] (reset! ! !!) #(do)))] +;; (let [!v (atom :pending)] +;; (swap! !resolvers assoc e !v) +;; (e/on-unmount #(tap [:unmounted e])) +;; (let [v (e/watch !v)] +;; (case v +;; :pending (throw (Pending.)) +;; :fail (throw fail) +;; #_else v)))))) tap tap) + +;; #_init % := [::e/init] +;; (@! 0), % := [::e/pending e/pending] +;; (@! 1), % := [:unmounted 0] +;; (@! 2), % := [:unmounted 1] +;; (!! 2 nil), % := [:unmounted 2], % := [::e/ok nil] +;; (@! 3), % := [::e/pending e/pending] +;; (!! 3 :fail), % := [:unmounted 3], % := [::e/failed fail])) + +;; (tests "do-event" +;; (def ! (atom nil)) +;; (def !resolvers (atom {})) +;; (defn !! [k v] (reset! (@!resolvers k) v)) +;; (with ((l/single {} (tap (try (e/do-event [e (m/observe (fn [!!] (reset! ! !!) #(do)))] +;; (tap [:mount e]) +;; (let [!v (atom :pending)] +;; (swap! !resolvers assoc e !v) +;; (try (let [v (e/watch !v)] +;; (case v +;; :pending (throw (Pending.)) +;; :caught (throw (ex-info "caught" {})) +;; :uncaught (throw (ex-info "uncaught" {})) +;; #_else v)) +;; (catch Pending _ :pending) +;; (catch #?(:clj Throwable :cljs :default) e +;; (case (ex-message e) +;; "caught" (reduced nil) +;; #_else (throw e)))))) +;; (catch #?(:clj Throwable :cljs :default) e [(type e) (ex-message e)])))) tap tap) +;; #_init % := nil +;; (@! 0), % := [:mount 0], % := :pending +;; (@! 1) ; skipped, previous still running +;; (!! 0 (reduced false)), % := nil +;; (@! 2), % := [:mount 2], % := :pending +;; (!! 2 :caught), % := nil +;; (@! 9), % := [:mount 9], % := :pending +;; (!! 9 :uncaught), % := [ExceptionInfo "uncaught"] +;; (!! 9 :alive), % := :alive +;; (!! 9 (reduced true)), % := nil)) + +;; (tests "do-event-pending" +;; (def ! (atom nil)) +;; (def !resolvers (atom {})) +;; (defn !! [k v] (reset! (@!resolvers k) v)) +;; (def fail (ex-info "i fail" {})) +;; (with ((l/single {} (tap (e/do-event-pending [e (m/observe (fn [!!] (reset! ! !!) #(do)))] +;; (tap [:mount e]) +;; (let [!v (atom :pending)] +;; (swap! !resolvers assoc e !v) +;; (let [v (e/watch !v)] +;; (case v +;; :pending (throw (Pending.)) +;; :fail (throw fail) +;; #_else v)))))) tap tap) +;; #_init % := [::e/init] +;; (@! 0), % := [:mount 0], % := [::e/pending e/pending] +;; (@! 1) ;; skipped +;; (!! 0 false) % := [::e/ok false] +;; (@! 2), % := [:mount 2], % := [::e/pending e/pending] +;; (!! 2 :fail), % := [::e/failed fail])) + +;; #?(:clj +;; (tests "e/offload starts Pending" +;; (def dfv (m/dfv)) +;; (with ((l/single {} (tap (try (e/offload #(m/? dfv)) +;; (catch Pending ex ex) +;; (catch Throwable ex (prn ex))))) tap tap) +;; % := e/pending +;; (dfv 1) +;; % := 1))) + +;; #?(:clj +;; (tests "e/offload doesn't throw Pending subsequently" +;; (def !dfv (atom (m/dfv))) +;; (with ((l/single {} (tap (try (let [dfv (e/watch !dfv)] +;; (e/offload #(m/? dfv))) +;; (catch Pending ex ex) +;; (catch Throwable ex (prn ex))))) tap tap) +;; % := e/pending +;; (@!dfv 1) +;; % := 1 +;; (reset! !dfv (m/dfv)) +;; (@!dfv 2) +;; % := 2))) + +;; #?(:clj +;; (tests "e/offload on overlap uses latest value and discards previous" +;; (def d1 (m/dfv)) +;; (def !dfv (atom d1)) +;; (with ((l/single {} (try (let [dfv (e/watch !dfv)] +;; (tap (e/offload #(m/? dfv)))) +;; (catch Pending _) +;; (catch Throwable ex (prn [(type ex) (ex-message ex)])))) tap tap) + +;; (def d2 (reset! !dfv (m/dfv))) +;; (d2 2) +;; % := 2 +;; (d1 1)))) + +;; #?(:clj +;; (tests "e/offload thunk is running on another thread" +;; (defn get-thread [] (Thread/currentThread)) +;; (with ((l/single {} (try (tap (e/offload get-thread)) +;; (catch Pending _) +;; (catch Throwable ex (prn ex)))) tap tap) +;; (count (hash-set % (get-thread))) := 2))) + +;; #?(:cljs +;; (do-browser +;; (tests "goog module calls don't trigger warnings" +;; ;; this includes a goog test namespace, so if there are warnings the CI will blow up. +;; ;; The blow up is configured as a shadow build hook in `hyperfiddle.browser-test-setup` +;; (with ((l/single {} (tap (try (hyperfiddle.goog-calls-test/Main.) :ok +;; (catch :default ex (ex-message ex))))) tap tap) +;; % := :ok)))) + +;; (tests +;; (with ((l/single {} (tap (try (new nil) (catch #?(:clj Throwable :cljs :default) e e)))) tap tap) +;; (ex-message %) := "called `new` on nil")) + +;; (tests +;; (with ((l/single {} (tap (try (e/watch :foo) (throw (ex-info "nope" {})) +;; (catch ExceptionInfo e e)))) tap tap) +;; (str/includes? (ex-message %) ":foo") := true)) + +;; (tests "l/def initialized to `nil` works in cc/fn" +;; (l/def foo nil) +;; (with ((l/single {} (binding [foo "foo"] (let [f foo] (#(tap [f foo]))))) tap tap) +;; % := ["foo" "foo"])) + +;; (tests "e/fn varargs" +;; (with ((l/single+ {} (new (e/fn [x & xs] (tap [x xs])) 1 2 3 4)) tap tap) +;; % := [1 [2 3 4]])) +;; (tests "e/fn varargs recursion with recur" +;; (with ((l/single+ {} (new (e/fn [x & xs] (tap [x xs])) 1 2 3 4)) tap tap) +;; % := [1 [2 3 4]])) +;; (tests "e/fn varargs recur is arity-checked" +;; (with ((l/single+ {} (tap (try (new (e/fn [x & xs] (recur)) 1 2 3) +;; (catch ExceptionInfo e e)))) tap tap) +;; (ex-message %) := "You `recur`d in with 0 arguments but it has 2 positional arguments")) + +;; (l/defn MapVararg [& {:keys [x] :or {x 1} :as mp}] [x mp]) +;; (tests "map vararg with no args is nil" +;; (with ((l/single+ {} (tap (MapVararg.))) tap tap) +;; % := [1 nil])) +;; (tests "map vararg with kw args" +;; (with ((l/single+ {} (tap (MapVararg. :x 2))) tap tap) +;; % := [2 {:x 2}])) +;; (tests "map vararg with map arg" +;; (with ((l/single+ {} (tap (MapVararg. {:x 2}))) tap tap) +;; % := [2 {:x 2}])) +;; (tests "map vararg with mixture" +;; (with ((l/single+ {} (tap (MapVararg. :y 3 {:x 2}))) tap tap) +;; % := [2 {:x 2, :y 3}])) +;; (tests "map vararg trailing map takes precedence" +;; (with ((l/single+ {} (tap (MapVararg. :x 3 {:x 2}))) tap tap) +;; % := [2 {:x 2}])) +;; (tests "map vararg with positional arguments" +;; (with ((l/single+ {} (tap (new (e/fn [a & {:keys [x]}] [a x]) 1 :x 2))) tap tap) +;; % := [1 2])) + +;; (tests "e/fn recur is arity checked" +;; (with ((l/single {} (tap (try (new (e/fn X [x] (recur x x)) 1) +;; (catch ExceptionInfo e e)))) tap tap) +;; (ex-message %) := "You `recur`d in X with 2 arguments but it has 1 positional argument")) + +;; (l/defn One [x] x) +;; (l/defn Two [x y] [x y]) +;; (l/defn VarArgs [x & xs] [x xs]) +;; (tests "(new One 1)" +;; (with ((l/single {} (tap (new One 1))) tap tap) +;; % := 1)) +;; (tests "(new VarArgs 1 2 3)" +;; (with ((l/single {} (tap (new VarArgs 1 2 3))) tap tap) +;; % := [1 [2 3]])) +;; (tests "varargs arity is checked" +;; (with ((l/single {} (tap (try (new VarArgs) +;; (catch ExceptionInfo e e)))) tap tap) +;; (ex-message %) := "You called VarArgs with 0 arguments but it only supports 1")) + +;; (tests "e/apply" +;; (with ((l/single+ {} (tap (e/apply VarArgs [1 2 3]))) tap tap) +;; % := [1 [2 3]])) +;; (tests "e/apply" +;; (with ((l/single+ {} (tap (e/apply Two 1 [2]))) tap tap) +;; % := [1 2])) +;; (tests "e/apply" +;; (with ((l/single+ {} (tap (e/apply Two [1 2]))) tap tap) +;; % := [1 2])) +;; (tests "e/apply" +;; (with ((l/single+ {} (tap (e/apply Two [1 (inc 1)]))) tap tap) +;; % := [1 2])) +;; (tests "e/apply" +;; (with ((l/single+ {} (tap (try (e/apply Two [1 2 3]) (throw (ex-info "boo" {})) +;; (catch ExceptionInfo e e)))) tap tap) +;; (ex-message %) := "You called Two with 3 arguments but it only supports 2")) + +;; (tests "multi-arity e/fn" +;; (with ((l/single {} (tap (new (e/fn ([_] :one) ([_ _] :two)) 1))) tap tap) +;; % := :one)) +;; (tests "multi-arity e/fn" +;; (with ((l/single {} (tap (new (e/fn ([_] :one) ([_ _] :two)) 1 2))) tap tap) +;; % := :two)) +;; (tests "multi-arity e/fn" +;; (with ((l/single {} (tap (new (e/fn ([_]) ([_ & xs] (mapv inc xs))) 1 2 3 4))) tap tap) +;; % := [3 4 5])) +;; (tests "multi-arity e/fn" +;; (with ((l/single+ {} (tap (e/apply (e/fn ([_] :one) ([_ _] :two)) 1 [2]))) tap tap) +;; % := :two)) +;; (tests "multi-arity e/fn" +;; (with ((l/single+ {} (tap (e/apply (e/fn ([_]) ([_ & xs] (mapv inc xs))) 1 2 [3 4]))) tap tap) +;; % := [3 4 5])) + +;; (tests "self-recur by name, e/fn" +;; (with ((l/single {} (tap (new (e/fn fib [n] (case n 0 0 1 1 (+ (fib. (- n 1)) (fib. (- n 2))))) 6))) tap tap) +;; % := 8)) +;; (tests "self-recur by name, l/defn" +;; (l/defn Fib [n] (case n 0 0 1 1 (+ (Fib. (- n 1)) (Fib. (- n 2))))) +;; (with ((l/single {} (tap (Fib. 7))) tap tap) +;; % := 13)) +;; (tests "self-recur by name, e/fn thunk" +;; (def !x (atom 2)) +;; (with ((l/single {} (new (e/fn X [] (if (pos-int? (tap (swap! !x dec))) (X.) (tap :done))))) tap tap) +;; % := 1 +;; % := 0 +;; % := :done)) +;; (tests "self-recur by name, to different arity" +;; (with ((l/single {} (tap (new (e/fn X ([] (X. 0)) ([n] (inc n)))))) tap tap) +;; % := 1)) +;; (tests "self-recur by name, varargs" +;; (with ((l/single {} (new (e/fn Chomp [& xs] (if (tap (seq xs)) (Chomp.) (tap :done))) 0 1 2)) tap tap) +;; % := [0 1 2] +;; % := nil +;; % := :done)) + +;; #?(:clj +;; (tests "e/fn multi-arity mistakes" +;; (binding [expand/*electric* true] +;; (try (expand/all {} '(e/fn Named ([x] x) ([y] y))) +;; (catch Throwable e (tap e))) +;; (ex-message (ex-cause %)) := "Conflicting arity definitions in Named: [x] and [y]" + +;; (try (expand/all {} '(e/fn Named ([x] x) ([& ys] ys))) +;; (catch Throwable e (tap e))) +;; (ex-message (ex-cause %)) := "Conflicting arity definitions in Named: [x] and [& ys]" + +;; (try (expand/all {} '(e/fn ([x & ys] x) ([x y & zs] ys))) +;; (catch Throwable e (tap e))) +;; (ex-message (ex-cause %)) := "Conflicting arity definitions: [x & ys] and [x y & zs]"))) + +;; #?(:cljs +;; (tests "#js" +;; (def !x (atom 0)) +;; (with ((l/single {} (let [x (e/watch !x)] +;; (tap #js {:x x}) +;; (tap #js [:x x]))) tap tap) +;; (.-x %) := 0 +;; (aget % 1) := 0 +;; (swap! !x inc) +;; (.-x %) := 1 +;; (aget % 1) := 1))) + +;; #?(:clj +;; (tests "jvm interop" +;; (with ((l/single {} +;; (let [f (java.io.File. "src") +;; pt (java.awt.Point. 1 2)] +;; (tap [(.getName f) ; instance method +;; (.-x pt) ; field access +;; (java.awt.geom.Point2D/distance 0 0 1 0) ; static method +;; ]))) tap tap) +;; % := ["src" 1 1.0]))) + +;; #?(:cljs +;; (tests "js interop" +;; (with ((l/single {} +;; (let [^js o #js {:a 1 :aPlus (fn [n] (inc n))}] +;; (tap [(.aPlus o 1) ; instance method +;; (.-a o) ; field access +;; ]))) tap tap) +;; % := [2 1]))) + +;; #?(:clj +;; (tests "we capture invalid calls" +;; (binding [expand/*electric* true] +;; (try (lang/analyze (assoc (l/->local-config {}) ::lang/current :server ::lang/me :server) '(jjj 1)) +;; (throw (Throwable. "shouldn't")) +;; (catch ExceptionInfo e +;; (ex-message e) := "in: (jjj 1)\nI cannot resolve `jjj`, maybe it's defined only on the client?\nIf `jjj` is supposed to be a macro, you might need to :refer it in the :require-macros clause." +;; (:form (ex-data e)) := 'jjj)) + +;; "in cc/fn" +;; (try (lang/analyze (assoc (l/->local-config {}) ::lang/current :server ::lang/me :server) '(fn [] (jjj 1))) +;; (throw (Throwable. "shouldn't")) +;; (catch ExceptionInfo e +;; (ex-message e) := "in: (jjj 1)\nI cannot resolve `jjj`, maybe it's defined only on the client?\nIf `jjj` is supposed to be a macro, you might need to :refer it in the :require-macros clause." +;; (:form (ex-data e)) := 'jjj)) + +;; "named cc/fn" +;; (try (lang/analyze (assoc (l/->local-config {}) ::lang/current :server ::lang/me :server) '(fn foo [] (jjj 1))) +;; (throw (Throwable. "shouldn't")) +;; (catch ExceptionInfo e +;; (ex-message e) := "in: (jjj 1)\nI cannot resolve `jjj`, maybe it's defined only on the client?\nIf `jjj` is supposed to be a macro, you might need to :refer it in the :require-macros clause." +;; (:form (ex-data e)) := 'jjj)) + +;; "in letfn" +;; (try (lang/analyze (assoc (l/->local-config {}) ::lang/current :server ::lang/me :server) '(letfn [(foo [] (jjj 1))])) +;; (throw (Throwable. "shouldn't")) +;; (catch ExceptionInfo e +;; (ex-message e) := "in: (jjj 1)\nI cannot resolve `jjj`, maybe it's defined only on the client?\nIf `jjj` is supposed to be a macro, you might need to :refer it in the :require-macros clause." +;; (:form (ex-data e)) := 'jjj)) + +;; "arbitrary symbols" +;; (try (lang/analyze (assoc (l/->local-config {}) ::lang/current :server ::lang/me :server) +;; '(let [x js/document.body])) +;; (catch ExceptionInfo e +;; (ex-message e) := "in: (let* [x js/document.body])\nI cannot resolve `js/document.body`, maybe it's defined only on the client?\nIf `js/document.body` is supposed to be a macro, you might need to :refer it in the :require-macros clause." +;; (:form (ex-data e)) := 'js/document.body)) + +;; "clj static field works" +;; (lang/analyze (assoc (l/->local-config {}) ::lang/current :server ::lang/me :server) 'clojure.lang.PersistentArrayMap/EMPTY)))) + +;; (tests "e/server e/client body" +;; (with ((l/single {} (tap (e/client 1 2))) tap tap) +;; % := 2)) + +;; (defn signify [node] (symbol (str/replace (str node) #"_hf_.*" ""))) + +;; #?(:clj +;; (tests "we keep node order" +;; (l/def A 1) +;; (l/def B 2) +;; (l/def C 3) +;; ;; (require '[hyperfiddle.electric.impl.ir-utils :as ir-utils]) + +;; (->> (lang/analyze (assoc (l/->local-config {}) ::lang/current :client ::lang/me :client) +;; '[A (e/server B) C]) +;; ;; ir-utils/unwrite +;; r/find-nodes (mapv signify)) +;; := +;; (->> (lang/analyze (assoc (l/->local-config {}) ::lang/current :client ::lang/me :server) +;; '[A (e/server B) C]) +;; r/find-nodes (mapv signify)))) + +;; #?(:clj +;; (tests "l/def marks the namespace" +;; (l/def Foo 1) +;; (-> *ns* meta ::lang/has-edef?) := true)) + +;; #?(:clj +;; (tests "cljs macroexpansion regression" +;; (binding [expand/*electric* true] +;; (-> (expand/all {::lang/peers {:server :clj, :client :cljs}, ::lang/current :client, ::lang/me :server, :ns 'hyperfiddle.electric-test} +;; '(e/fn Foo [])) +;; first) := ::lang/closure))) + +;; (tests "set literal" +;; (def !v (atom 1)) +;; (with ((l/single {} (tap #{(e/watch !v)})) tap tap) +;; % := #{1} +;; (swap! !v inc) +;; % := #{2})) + +;; (tests "calling an electric defn in a clojure defn as a clojure defn" +;; (l/defn ElectricFn [] 1) +;; (defn clj-fn2 [] (inc (ElectricFn))) +;; (try (clj-fn2) (throw (ex-info "unreachable" {})) +;; (catch ExceptionInfo e (ex-message e) := "I'm an electric value and you called me outside of electric."))) + +;; (tests "let over e/def" +;; (let [x 1] (l/def XX [x x])) +;; (with ((l/single {} (tap XX)) tap tap) +;; % := [1 1])) + +;; #?(:clj +;; (tests "::lang/only filters e/def compilation" +;; (l/def ^{::lang/only #{:server}} ServerOnly 1) +;; (some? (find-var `ServerOnly_hf_server_server)) := true +;; (some? (find-var `ServerOnly_hf_client_server)) := true +;; (not (find-var `ServerOnly_hf_server_client)) := true +;; (not (find-var `ServerOnly_hf_client_client)) := true)) + +;; (deftype FieldAccess [x]) +;; (tests "non-static first arg to . or .. works" +;; (with ((l/single {} (tap (.. (FieldAccess. 1) -x))) tap tap) +;; % := 1)) + +;; (tests "lexical first arg to . or .. works" +;; (with ((l/single {} (let [fa (FieldAccess. 1)] (tap (.. fa -x)))) tap tap) +;; % := 1)) + +;; (tests "()" +;; (with ((l/single {}+ {} (tap ())) tap tap) +;; % := ())) + +;; (tests "(#())" +;; (with ((l/single {}+ {} (tap (#()))) tap tap) +;; % := ())) + +;; (tests "((fn []))" +;; (with ((l/single {}+ {} (tap ((fn [])))) tap tap) +;; % := nil)) + +;; (tests "::lang/non-causal removes causality in `let`" +;; (l/defn ^::lang/non-causal NonCausalLet [tap] +;; (let [_ (tap 1)] (tap 2))) +;; (with ((l/single {} (NonCausalLet. tap)) tap tap) +;; ;; % := 1 +;; % := 2)) + +;; (tests "::lang/non-causal removes causality in `binding`" +;; (l/def NonCausalEDef) +;; (l/defn ^::lang/non-causal NonCausalBinding [tap] +;; (binding [NonCausalEDef (tap 1)] (tap 2))) +;; (with ((l/single {} (NonCausalBinding. tap)) tap tap) +;; ;; % := 1 +;; % := 2)) + +;; (tests "binding in interop fn" +;; (with ((l/single {} (tap ((fn [] (binding [*out* nil] 1))))) tap tap) +;; % := 1)) From 9c9deb8cbdcf11b50f1728bc25b056b46fe0ba55 Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 1 Feb 2024 21:08:34 +0100 Subject: [PATCH 082/428] compiler: (new Class x y z) --- src/hyperfiddle/electric/impl/lang_de2.clj | 110 ++++++++++++--------- test/hyperfiddle/electric_de_test.cljc | 22 ++--- 2 files changed, 76 insertions(+), 56 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index ce13a8bc9..c42582c48 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -444,39 +444,48 @@ (untwin 'a) := 'a (untwin 'cljs.core/not-in-clj) := 'cljs.core/not-in-clj) -(defn analyze-clj-symbol [form] - (if (resolve-static-field form) - ::static - (when-some [v (resolve form)] - (if (var? v) (symbol v) ::static)))) +(defn resolve-node [sym]) -(defn analyze-cljs-symbol [form env] - (when-some [v (resolve-cljs (::cljs-env env) form)] - (if (= :var (:op v)) (untwin (:name v)) ::static))) +(defn analyze-clj-symbol [sym] + (if (resolve-static-field sym) + {::type ::static, ::sym sym} + (when-some [v (resolve sym)] + (if (var? v) {::type ::var, ::sym (symbol v)} {::type ::class, ::sym sym, ::class v})))) + +(defn analyze-cljs-symbol [sym env] + (when-some [v (resolve-cljs (::cljs-env env) sym)] + (if (= :var (:op v)) {::type ::var, ::sym (untwin (:name v))} {::type ::static, ::sym sym}))) (defn resolve-cljs-alias [env sym] (if (simple-symbol? sym) (symbol (-> env :ns :name str) (name sym)) (or (cljs-ana/resolve-ns-alias env sym) (cljs-ana/resolve-macro-ns-alias env sym)))) -(defn assume-cljs-var [sym env] (untwin (resolve-cljs-alias env sym))) +(defn assume-cljs-var [sym env] {::type ::var, ::sym (untwin (resolve-cljs-alias env sym))}) (defn resolve-symbol [sym env] - (case (get (::peers env) (::current env)) - :clj (let [v (analyze-clj-symbol sym)] (case v nil (cannot-resolve! env sym) #_else [:clj v])) - :cljs [:cljs (or (analyze-cljs-symbol sym env) - ;; optimistically resolve on cljs - ;; we don't load the whole ns file so we cannot resolve all vars - ;; loading the whole ns would undermine previous work - (assume-cljs-var sym env))] - #_unsited (let [langs (set (vals (::peers env))) - vs (->> langs (into #{} (map #(case % - :clj (analyze-clj-symbol sym) - :cljs (or (analyze-cljs-symbol sym env) - (assume-cljs-var sym env))))))] - (cond (contains? vs nil) (cannot-resolve! env sym) - (> (count vs) 1) (ambiguous-resolve! env sym) - :else [nil (first vs)])))) + (if-some [local (-> env :locals (get sym))] + (if-some [ref (::electric-let local)] + {::lang nil, ::type ::let-ref, ::sym sym, ::ref ref} + {::lang nil, ::type ::local, ::sym sym}) + (if-some [nd (resolve-node sym)] + {::lang nil, ::type ::node, ::node nd} + (case (get (::peers env) (::current env)) + :clj (let [v (analyze-clj-symbol sym)] (case v nil (cannot-resolve! env sym) #_else (assoc v ::lang :clj))) + :cljs (assoc (or (analyze-cljs-symbol sym env) + ;; optimistically resolve on cljs + ;; we don't load the whole ns file so we cannot resolve all vars + ;; loading the whole ns would undermine previous work + (assume-cljs-var sym env)) + ::lang :cljs) + #_unsited (let [langs (set (vals (::peers env))) + vs (->> langs (into #{} (map #(case % + :clj (analyze-clj-symbol sym) + :cljs (or (analyze-cljs-symbol sym env) + (assume-cljs-var sym env))))))] + (cond (contains? vs nil) (cannot-resolve! env sym) + (> (count vs) 1) (ambiguous-resolve! env sym) + :else (assoc (first vs) ::lang nil))))))) (defn ->let-val-e [ts e] (first (get-children-e ts e))) (defn ->let-body-e [ts e] (second (get-children-e ts e))) @@ -504,9 +513,9 @@ (defn get-lookup-key [sym env] (if (symbol? sym) - (let [[_ sym] (resolve-symbol sym env)] - (case sym - ::static (throw (ex-info (str "`" sym "` did not resolve as a var") {::form sym})) + (let [{::keys [type sym]} (resolve-symbol sym env)] + (case type + (::static ::class) (throw (ex-info (str "`" sym "` did not resolve as a var") {::form sym})) #_else (keyword sym))) sym)) @@ -515,12 +524,12 @@ (and (seq? form) (seq form)) (case (first form) (let*) (let [[_ bs bform] form] - (loopr [ts ts, pe pe] + (loopr [ts ts, pe pe, env env] [[s v] (eduction (partition-all 2) bs)] - (let [e (->id)] - (recur (analyze v e (update-in env [:locals s] assoc ::electric-let true, :db/id e) + (let [e (->id), env (update-in env [:locals s] assoc ::electric-let e)] + (recur (analyze v e env (-> (ts/add ts {:db/id e, ::parent pe, ::type ::let, ::sym s}) - (?add-source-map e form))) e)) + (?add-source-map e form))) e env)) (analyze bform pe env ts))) (case) (let [[_ test & brs] form [default brs2] (if (odd? (count brs)) [(last brs) (butlast brs)] [:TODO brs])] @@ -540,7 +549,19 @@ (ts/add {:db/id (->id), ::parent ce, ::type ::literal, ::v form}) (?add-source-map e form))] (reduce (fn [ts nx] (analyze nx e env ts)) ts2 refs)) - (new) (let [[_ F & args] form] (recur `(binding [~@(interleave (range) args)] (::call ~F)) pe env ts)) + (new) (let [[_ f & args] form + {::keys [lang sym type]} (if (symbol? f) (resolve-symbol f env) {::type ::var, ::sym f})] + (case type + ::class (let [e (->id), ce (->id), cce (->id)] + (reduce (fn [ts arg] (analyze arg e env ts)) + (-> ts (ts/add {:db/id e, ::parent pe, ::type ::ap}) + (ts/add {:db/id ce, ::parent e, ::type ::pure}) + (ts/add {:db/i cce, ::parent ce, ::type ::literal, + ::v (let [gs (repeatedly (count args) gensym)] + `(fn [~@gs] (new ~f ~@gs)))})) + args)) + #_else (recur (if (seq args) `(binding [~@(interleave (range) args)] (::call ~f)) `(::call ~f)) + pe env ts))) (binding clojure.core/binding) (let [[_ bs bform] form, gs (repeatedly (/ (count bs) 2) gensym)] (recur (if (seq bs) `(let* [~@(interleave gs (take-nth 2 (next bs)))] @@ -575,18 +596,19 @@ (map? form) (recur (?meta form (cons `(::static-vars hash-map) (eduction cat form))) pe env ts) (symbol? form) - (let [e (->id)] - (-> (if-some [lr-e (find-let-ref form pe ts)] - (ts/add ts {:db/id e, ::parent pe, ::type ::let-ref, ::ref lr-e, ::sym form}) - (if (contains? (:locals env) form) - (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) - (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form})) - (let [[resolved-in sym] (resolve-symbol form env)] - (if (or (= ::static sym) (::static-vars env)) - (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) - (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form})) - (ts/add ts (cond-> {:db/id e, ::parent pe, ::type ::var, ::var form, ::qualified-var sym} - resolved-in (assoc ::resolved-in resolved-in))))))) + (let [e (->id), ret (resolve-symbol form env)] + (-> (case (::type ret) + (::let-ref) (ts/add ts {:db/id e, ::parent pe, ::type ::let-ref, ::ref (::ref ret), ::sym form}) + (::local) (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) + (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form})) + (::static ::var) (if (::static-vars env) + (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) + (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form})) + (ts/add ts (cond-> {:db/id e, ::parent pe, ::type ::var + ::var form, ::qualified-var (::sym ret)} + (::lang ret) (assoc ::resolved-in (::lang ret))))) + (::node) (throw (ex-info "node todo" {})) + (::class) (ts/add ts {:db/id e, ::parent pe, ::type ::class, ::sym form, ::class (::class ret)})) (?add-source-map e form))) :else diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 83a84b874..787e22b04 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -5,15 +5,14 @@ [hyperfiddle.electric.impl.lang-de2 :as lang] [missionary.core :as m])) -(tests "new on local electric closure" +(tests "call on local electric ctor" (with ((l/single {} (let [x (e/ctor 1)] (tap (e/call x)))) tap tap) % := 1)) -;; TODO class support -;; (defrecord Point [x y]) -;; (tests "new on class" -;; (with ((l/single {} (tap (new Point 1 2))) tap tap) -;; % := (Point. 1 2))) +(defrecord Point [x y]) +(tests "new on class" + (with ((l/single {} (tap (new Point 1 2))) tap tap) + % := (Point. 1 2))) ;; TODO `m/ap` has `try` in expansion ;; (tests "new on missionary flow" @@ -29,13 +28,12 @@ (with ((l/single {} (tap (if true :yes :no))) tap tap) % := :yes)) -;; TODO `case` default branch -;; (tests "case" -;; (with ((l/single {} (tap (case 1 1 1 2 2))) tap tap) -;; % := 1)) +(tests "case" + (with ((l/single {} (tap (case 1 1 1, 2 2))) tap tap) + % := 1)) (tests "case" - (with ((l/single {} (tap (case 1 1 1 2 2 #_else nil))) tap tap) + (with ((l/single {} (tap (case 1 1 1, 2 2, #_else nil))) tap tap) % := 1)) (tests "quote" @@ -311,7 +309,7 @@ (def foo 1) (def bar 2) -(tests "reactive for" +#_(tests "reactive for" (def !xs (atom [1 2 3])) (with ((l/single {} (tap (e/for-by identity [x (e/watch !xs)] (prn x) (inc x)))) tap tap) % := [2 3 4] From 55354e84a0db53321eb957e8bf6d4ad0b776fba2 Mon Sep 17 00:00:00 2001 From: xificurC Date: Fri, 2 Feb 2024 11:16:36 +0100 Subject: [PATCH 083/428] checkpoint --- shadow-cljs.edn | 5 +- src/hyperfiddle/electric/impl/lang_de2.clj | 50 +- src/hyperfiddle/electric_de.cljc | 8 +- src/hyperfiddle/electric_local_def_de.cljc | 2 +- .../impl/expand_require_referred.cljc | 3 +- test/hyperfiddle/electric_de_test.cljc | 3543 +++++++++-------- 6 files changed, 1835 insertions(+), 1776 deletions(-) diff --git a/shadow-cljs.edn b/shadow-cljs.edn index c65ce177a..2461224c1 100644 --- a/shadow-cljs.edn +++ b/shadow-cljs.edn @@ -12,11 +12,12 @@ (user/rcf-shadow-hook)]} :test {:target :node-test :output-to "out/node-tests.js" - :ns-regexp "^(hyperfiddle.electric-[^dom|fulcro]|contrib.(ednish|sexpr-router|missionary-contrib-test)).*$" + :ns-regexp "^(hyperfiddle.electric-(?!dom|fulcro)|contrib.(ednish|sexpr-router|missionary-contrib-test)).*$" :build-options {:cache-level :off} :modules {:main {:entries [hyperfiddle.zero hyperfiddle.electric hyperfiddle.electric-test + hyperfiddle.electric-de-test #_hyperfiddle.missionary-test contrib.missionary-contrib-test contrib.ednish @@ -24,7 +25,7 @@ :compiler-options {:warnings {:redef-in-file false}}} :browser-test {:target :karma :output-to "out/karma-tests.js" - :ns-regexp "^(hyperfiddle.electric-[^fulcro]|contrib.(ednish|sexpr-router|missionary-contrib-test)).*$" + :ns-regexp "^(hyperfiddle.electric-(?!fulcro)|contrib.(ednish|sexpr-router|missionary-contrib-test)).*$" :build-options {:cache-level :off} :build-hooks [(hyperfiddle.browser-test-setup/blow-up-tests-on-warnings)] :modules {:main {:entries [hyperfiddle.zero diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index c42582c48..66620f476 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -450,7 +450,7 @@ (if (resolve-static-field sym) {::type ::static, ::sym sym} (when-some [v (resolve sym)] - (if (var? v) {::type ::var, ::sym (symbol v)} {::type ::class, ::sym sym, ::class v})))) + (if (var? v) {::type ::var, ::sym (symbol v)} {::type ::static, ::sym sym})))) (defn analyze-cljs-symbol [sym env] (when-some [v (resolve-cljs (::cljs-env env) sym)] @@ -515,7 +515,7 @@ (if (symbol? sym) (let [{::keys [type sym]} (resolve-symbol sym env)] (case type - (::static ::class) (throw (ex-info (str "`" sym "` did not resolve as a var") {::form sym})) + (::static) (throw (ex-info (str "`" sym "` did not resolve as a var") {::form sym})) #_else (keyword sym))) sym)) @@ -549,19 +549,15 @@ (ts/add {:db/id (->id), ::parent ce, ::type ::literal, ::v form}) (?add-source-map e form))] (reduce (fn [ts nx] (analyze nx e env ts)) ts2 refs)) - (new) (let [[_ f & args] form - {::keys [lang sym type]} (if (symbol? f) (resolve-symbol f env) {::type ::var, ::sym f})] - (case type - ::class (let [e (->id), ce (->id), cce (->id)] - (reduce (fn [ts arg] (analyze arg e env ts)) - (-> ts (ts/add {:db/id e, ::parent pe, ::type ::ap}) - (ts/add {:db/id ce, ::parent e, ::type ::pure}) - (ts/add {:db/i cce, ::parent ce, ::type ::literal, - ::v (let [gs (repeatedly (count args) gensym)] - `(fn [~@gs] (new ~f ~@gs)))})) - args)) - #_else (recur (if (seq args) `(binding [~@(interleave (range) args)] (::call ~f)) `(::call ~f)) - pe env ts))) + (new) (let [[_ f & args] form, e (->id), ce (->id), cce (->id)] + (reduce (fn [ts arg] (analyze arg e env ts)) + (-> ts + (ts/add {:db/id e, ::parent pe, ::type ::ap}) + (ts/add {:db/id ce, ::parent e, ::type ::pure}) + (ts/add {:db/id cce, ::parent ce, ::type ::literal, + ::v (let [gs (repeatedly (count args) gensym)] + `(fn [~@gs] (new ~f ~@gs)))})) + args)) (binding clojure.core/binding) (let [[_ bs bform] form, gs (repeatedly (/ (count bs) 2) gensym)] (recur (if (seq bs) `(let* [~@(interleave gs (take-nth 2 (next bs)))] @@ -607,8 +603,7 @@ (ts/add ts (cond-> {:db/id e, ::parent pe, ::type ::var ::var form, ::qualified-var (::sym ret)} (::lang ret) (assoc ::resolved-in (::lang ret))))) - (::node) (throw (ex-info "node todo" {})) - (::class) (ts/add ts {:db/id e, ::parent pe, ::type ::class, ::sym form, ::class (::class ret)})) + (::node) (throw (ex-info "node todo" {}))) (?add-source-map e form))) :else @@ -630,6 +625,7 @@ _ (when (::print-expansion env) (fipp.edn/pprint expanded)) ts (analyze expanded 0 (ensure-cljs-env env) (ts/add (ts/->ts {::->id ->id}) {:db/id (->id), ::type ::ctor, ::parent '_})) + _ (when (::print-analysis env) (run! prn (->> ts :eav vals (sort-by :db/id)))) mark-used-ctors (fn mark-used-ctors [ts e] (let [nd (get (:eav ts) e)] (case (::type nd) @@ -691,21 +687,17 @@ (recur (cond-> ac (= ::ctor (::type (ts/->node ts e))) (conj e)) (::parent (ts/->node ts e))))) ts (ts/asc ts (::ref nd) ::walked-val true) ; only walk binding once - ts (cond - (in-a-call? ts e) - (-> (ts/upd ts (::ref nd) ::in-call #(conj (or % #{}) e)) - (ensure-node (::ref nd))) - - (seq ctors-e) ; closed over + ts (cond-> ts (in-a-call? ts e) + (ts/upd (::ref nd) ::in-call #(conj (or % #{}) e))) + ts (if (seq ctors-e) ; closed over (-> ts (ensure-node (::ref nd)) (ensure-free-node (::ref nd) (first ctors-e)) (ensure-free-frees (::ref nd) (rest ctors-e))) - - :else (cond-> (ts/upd ts (::ref nd) ::refcnt (fnil inc 0)) - (or (= 1 (::refcnt ref-nd)) - (not= (get-site ts (find-sitable-parent ts e)) - (get-site ts (->let-val-e ts (::ref nd))))) - (ensure-node (::ref nd))))] + (cond-> (ts/upd ts (::ref nd) ::refcnt (fnil inc 0)) + (or (= 1 (::refcnt ref-nd)) + (not= (get-site ts (find-sitable-parent ts e)) + (get-site ts (->let-val-e ts (::ref nd))))) + (ensure-node (::ref nd))))] (cond-> ts (not (::walked-val ref-nd)) (recur (get-ret-e ts (->let-val-e ts (::ref nd)))))) #_else (throw (ex-info (str "cannot handle-let-refs on " (::type nd)) (or nd {})))))) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 5852c8e8d..95078985a 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -8,7 +8,7 @@ #?(:cljs (:require-macros hyperfiddle.electric-de))) (defmacro ctor [expr] `(::lang/ctor ~expr)) -(defmacro call [ctor] `(::lang/call ~ctor)) +(defmacro $ [F & args] `(binding [~@(interleave (range) args)] (::lang/call ~F))) (defmacro pure " Syntax : @@ -37,7 +37,7 @@ Syntax : (amb table1 table2 ,,, tableN) ``` Returns the concatenation of `table1 table2 ,,, tableN`. -" [& exprs] `(call (join (r/pure ~@(mapv #(list `ctor %) exprs))))) +" [& exprs] `($ (join (r/pure ~@(mapv #(list `ctor %) exprs))))) (defmacro input " Syntax : @@ -89,7 +89,7 @@ For each tuple in the cartesian product of `table1 table2 ,,, tableN`, calls bod (case bindings [] `(do ~@body) (let [[args exprs] (apply map vector (partition-all 2 bindings))] - `(call (r/bind-args (fn ~args ~@body) + `($ (r/bind-args (fn ~args ~@body) ~@(map (clojure.core/fn [expr] `(r/fixed-signals (join (i/items (pure ~expr))))) exprs)))))) @@ -120,4 +120,4 @@ this tuple. Returns the concatenation of all body results as a single vector. (if-some [[sym expr & bindings] bindings] `(cursor [~sym (diff-by ~kf ~expr)] ~(rec bindings)) `(do ~@body))) - (seq bindings)))) \ No newline at end of file + (seq bindings)))) diff --git a/src/hyperfiddle/electric_local_def_de.cljc b/src/hyperfiddle/electric_local_def_de.cljc index 029e699ca..f83427083 100644 --- a/src/hyperfiddle/electric_local_def_de.cljc +++ b/src/hyperfiddle/electric_local_def_de.cljc @@ -25,7 +25,7 @@ ([nm env form] `(lang/compile ~nm '~form (merge web-config (lang/normalize-env ~env)))))) (defn run-single [frame] (m/reduce #(do %2) nil frame)) -#?(:clj (defmacro single {:style/indent 0} [conf & body] +#?(:clj (defmacro single {:style/indent 1} [conf & body] (ca/check map? conf) (let [env (merge (->local-config &env) (lang/normalize-env &env) conf)] `(run-single (r/root-frame {::Main ~(lang/compile ::Main `(do ~@body) env)} ::Main))))) diff --git a/test/hyperfiddle/electric/impl/expand_require_referred.cljc b/test/hyperfiddle/electric/impl/expand_require_referred.cljc index 5c46ed024..ac440372c 100644 --- a/test/hyperfiddle/electric/impl/expand_require_referred.cljc +++ b/test/hyperfiddle/electric/impl/expand_require_referred.cljc @@ -1,4 +1,5 @@ -(ns hyperfiddle.electric.impl.expand-require-referred) +(ns hyperfiddle.electric.impl.expand-require-referred + #?(:require-macros hyperfiddle.electric.impl.expand-require-referred)) (defmacro referred [] :referred) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 787e22b04..30b2f466c 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -1,13 +1,16 @@ (ns hyperfiddle.electric-de-test (:require [hyperfiddle.rcf :as rcf :refer [tests tap with %]] - [hyperfiddle.electric-de :as e] + [hyperfiddle.electric-de :as e :refer [$]] [hyperfiddle.electric-local-def-de :as l] [hyperfiddle.electric.impl.lang-de2 :as lang] [missionary.core :as m])) +(defmacro skip [& _body] + `(pr '~'-)) + (tests "call on local electric ctor" - (with ((l/single {} (let [x (e/ctor 1)] (tap (e/call x)))) tap tap) - % := 1)) + (with ((l/single {} (let [x (e/ctor 1)] (tap ($ x)))) tap tap) + % := 1)) (defrecord Point [x y]) (tests "new on class" @@ -15,11 +18,11 @@ % := (Point. 1 2))) ;; TODO `m/ap` has `try` in expansion -;; (tests "new on missionary flow" -;; (with ((l/single {::lang/print-expansion true} (tap (e/input (m/ap 1)))) tap tap) -;; % := 1)) +(skip "new on missionary flow" + (with ((l/single {::lang/print-expansion true} (tap (e/input (m/ap 1)))) tap tap) + % := 1)) -(tests "new on missionary flow" +(tests "join missionary flow" (def flow (m/ap 1)) (with ((l/single {} (tap (e/input flow))) tap tap) % := 1)) @@ -46,25 +49,25 @@ % := 2))) ;; TODO cc/fn -;; (tests "clj fn" -;; (with ((l/single {::lang/print-source true} (let [x 1] (tap (#(inc x))))) tap tap) -;; % := 2)) +(skip "clj fn" + (with ((l/single {::lang/print-source true} (let [x 1] (tap (#(inc x))))) tap tap) + % := 2)) ;; TODO `.` -;; #?(:clj -;; (tests "." -;; (with ((l/single {} (tap (. java.time.Instant EPOCH))) tap tap) -;; % := java.time.Instant/EPOCH))) +#?(:clj + (skip "." + (with ((l/single {} (tap (. java.time.Instant EPOCH))) tap tap) + % := java.time.Instant/EPOCH))) ;; TODO loop recur -;; (tests "loop/recur" -;; (with ((l/single {} (tap (loop [x 1] (if (odd? x) (recur (dec x)) x)))) tap tap) -;; % := 0)) +(skip "loop/recur" + (with ((l/single {} (tap (loop [x 1] (if (odd? x) (recur (dec x)) x)))) tap tap) + % := 0)) ;; TODO def -;; (tests "def" -;; (with ((l/single {} (def DEFD 1)) tap tap)) -;; DEFD := 1) +(skip "def" + (with ((l/single {} (def DEFD 1)) tap tap)) + DEFD := 1) ;;; MAIN ELECTRIC TEST SUITE @@ -107,8 +110,8 @@ (swap! !x inc) % := 1)) -(tests "reactive closures - call them with (new)" - (with ((l/single {} (tap (let [x 1, F (e/fn [] x)] [(number? x) (new F)]))) tap tap) +(tests "reactive closures - call them with $" + (with ((l/single {} (tap (let [x 1, F (e/fn [] x)] [(number? x) ($ F)]))) tap tap) % := [true 1])) (tests "dataflow diamond - let introduces shared nodes in the dag" @@ -180,35 +183,35 @@ % := :b)) (tests "reactive fn" - (with ((l/single {} (tap (new (e/fn [x] (inc x)) 1))) tap tap) + (with ((l/single {} (tap ($ (e/fn [x] (inc x)) 1))) tap tap) % := 2)) ;; TODO defn ;; (l/defn My-inc [x] (inc x)) -;; (tests "reactive defn" -;; (with ((l/single {} (tap (My-inc. 1))) tap tap) -;; % := 2)) +(skip "reactive defn" + (with ((l/single {} (tap (My-inc. 1))) tap tap) + % := 2)) ;; TODO defn -;; (tests "control flow implemented with lazy signals" -;; (l/defn If2 [x a b] ; Key question - how lazy are the parameters? -;; (->> (boolean x) -;; (get {true (e/fn [] a) -;; false (e/fn [] b)}) -;; (new))) - -;; (def !x (atom false)) -;; (def !a (atom :a)) -;; (def !b (atom :b)) -;; (with ((l/single {} (let [x (e/watch !x) -;; a (tap (e/watch !a)) ; lazy -;; b (tap (e/watch !b))] ; lazy -;; (tap (If2. x a b)))) tap tap) -;; % := :a -;; % := :b -;; % := :b -;; (swap! !x not) -;; % := :a)) +(skip "control flow implemented with lazy signals" + (l/defn If2 [x a b] ; Key question - how lazy are the parameters? + (->> (boolean x) + (get {true (e/fn [] a) + false (e/fn [] b)}) + (new))) + + (def !x (atom false)) + (def !a (atom :a)) + (def !b (atom :b)) + (with ((l/single {} (let [x (e/watch !x) + a (tap (e/watch !a)) ; lazy + b (tap (e/watch !b))] ; lazy + (tap (If2. x a b)))) tap tap) + % := :a + % := :b + % := :b + (swap! !x not) + % := :a)) (tests "lazy let" (def !x (atom false)) @@ -258,11 +261,11 @@ % := 1)) ;; TODO `try` and `case` default -;; (tests "case with no matching clause" -;; (with ((l/single {} (try (case 2 1 1) -;; (catch #?(:clj IllegalArgumentException :cljs js/Error) e (tap [:right (ex-message e)])) -;; (catch #?(:clj Throwable :cljs :default) e (tap [:wrong e])))) tap tap)) -;; % := [:right "No matching clause: 2"]) +(skip "case with no matching clause" + (with ((l/single {} (try (case 2 1 1) + (catch #?(:clj IllegalArgumentException :cljs js/Error) e (tap [:right (ex-message e)])) + (catch #?(:clj Throwable :cljs :default) e (tap [:wrong e])))) tap tap)) + % := [:right "No matching clause: 2"]) (tests "binding" (def foo 1) @@ -276,18 +279,18 @@ (tests "binding - e/fn" (def foo) - (with ((l/single {} (binding [foo (e/fn [x] (tap x))] (foo. 1))) tap tap) + (with ((l/single {} (binding [foo (e/fn [x] (tap x))] ($ foo 1))) tap tap) % := 1)) (tests "lexical closure" - (with ((l/single {} (tap (new (let [a 1] (e/fn [] a))))) tap tap) + (with ((l/single {} (tap ($ (let [a 1] (e/fn [] a))))) tap tap) % := 1)) (tests "join captures dynamic scope" (def foo 1) (with ((l/single {} (let [Q (e/fn [] foo)] (binding [foo 2] - (tap (Q.))))) tap tap) + (tap ($ Q))))) tap tap) % := 2)) (tests "if with bindings" @@ -301,7 +304,7 @@ (def foo4 1) (tests "if with unwinding binding" (def !a (atom true)) - (with ((l/single {} (tap (new (binding [foo4 2] (e/fn [] (if (e/watch !a) foo4 (- foo4))))))) tap tap) + (with ((l/single {} (tap ($ (binding [foo4 2] (e/fn [] (if (e/watch !a) foo4 (- foo4))))))) tap tap) % := 1 (swap! !a not) % := -1)) @@ -309,1061 +312,1123 @@ (def foo 1) (def bar 2) -#_(tests "reactive for" +;; TODO waiting for Leo's fix +(skip "reactive for" (def !xs (atom [1 2 3])) (with ((l/single {} (tap (e/for-by identity [x (e/watch !xs)] (prn x) (inc x)))) tap tap) % := [2 3 4] (swap! !xs conj 4) % := [2 3 4 5])) -(comment - (def !xs (atom [1 2 3])) - (def it ((l/single {} (tap (e/for-by identity [x (e/watch !xs)] (prn x) (inc x)))) tap tap)) - (swap! !xs conj 4) - (it) +(skip "reactive for is differential (diff/patch)" + (def !xs (atom [1 2 3])) + (with ((l/single {} (tap (e/for-by identity [x (e/watch !xs)] (tap x)))) tap tap) + (hash-set % % %) := #{1 2 3} ; concurrent, order undefined + % := [1 2 3] + (swap! !xs conj 4) + % := 4 + % := [1 2 3 4] + (swap! !xs pop) + % := [1 2 3] ;; TODO glitch here + (swap! !xs assoc 1 :b) + % := :b + % := [1 :b 3])) - ) +;; (l/def foo 0) +(skip "Reactive for with bindings" + (def !items (atom ["a"])) + (with ((l/single {} (binding [foo 1] + (e/for [item (e/watch !items)] + (tap foo) + item))) tap tap) -;; (tests "reactive for is differential (diff/patch)" -;; (def !xs (atom [1 2 3])) -;; (with ((l/single {} (tap (e/for-by identity [x (e/watch !xs)] (tap x)))) tap tap) -;; (hash-set % % %) := #{1 2 3} ; concurrent, order undefined -;; % := [1 2 3] -;; (swap! !xs conj 4) -;; % := 4 -;; % := [1 2 3 4] -;; (swap! !xs pop) -;; % := [1 2 3] ;; TODO glitch here -;; (swap! !xs assoc 1 :b) -;; % := :b -;; % := [1 :b 3])) + % := 1 + (swap! !items conj "b") + % := 1)) ; If 0 -> foo’s binding vanished + +(skip "reactive for with keyfn" + (def !xs (atom [{:id 1 :name "alice"} {:id 2 :name "bob"}])) + (with ((l/single {} (tap (e/for-by :id [x (e/watch !xs)] (tap x)))) tap tap) + (hash-set % %) := #{{:id 1 :name "alice"} {:id 2 :name "bob"}} + % := [{:id 1 :name "alice"} {:id 2 :name "bob"}] + (swap! !xs assoc-in [0 :name] "ALICE") + % := {:id 1 :name "ALICE"} + % := [{:id 1 :name "ALICE"} {:id 2 :name "bob"}])) + +(tests "reactive do" + (def !x (atom 0)) + (with ((l/single {} (tap (do (tap :a) (tap (e/watch !x))))) tap tap) + ; Currently, do is not monadic sequence. + ; It's an incremental computation so only rerun what changed in our opinion + % := :a + % := 0 + % := 0 + (swap! !x inc) + ; no :a + % := 1 + % := 1)) -;; (l/def foo 0) -;; (tests "Reactive for with bindings" -;; (def !items (atom ["a"])) -;; (with ((l/single {} (binding [foo 1] -;; (e/for [item (e/watch !items)] -;; (tap foo) -;; item))) tap tap) - -;; % := 1 -;; (swap! !items conj "b") -;; % := 1)) ; If 0 -> foo’s binding vanished - -;; (tests "reactive for with keyfn" -;; (def !xs (atom [{:id 1 :name "alice"} {:id 2 :name "bob"}])) -;; (with ((l/single {} (tap (e/for-by :id [x (e/watch !xs)] (tap x)))) tap tap) -;; (hash-set % %) := #{{:id 1 :name "alice"} {:id 2 :name "bob"}} -;; % := [{:id 1 :name "alice"} {:id 2 :name "bob"}] -;; (swap! !xs assoc-in [0 :name] "ALICE") -;; % := {:id 1 :name "ALICE"} -;; % := [{:id 1 :name "ALICE"} {:id 2 :name "bob"}])) - -;; (tests "reactive do (this is changing soon)" -;; ; see: https://www.notion.so/hyperfiddle/What-is-do-let-and-implement-ed781cc5645d4e83aa90b04e31988754 -;; ; current behavior is not compatible with cc/let -;; (def !x (atom 0)) -;; (with ((l/single {} (tap (do (tap :a) (tap (e/watch !x))))) tap tap) -;; ; Currently, do is not monadic sequence. -;; ; It's an incremental computation so only rerun what changed in our opinion -;; % := :a -;; % := 0 -;; % := 0 -;; (swap! !x inc) -;; ; no :a -;; % := 1 -;; % := 1)) - -;; (tests "do forces evaluation (introduces eagerness)" -;; ; Current behavior - do stmts are sampled eagerly, as fast as possible -;; (def !a (atom 0)) -;; (def !b (atom 0)) -;; (with ((l/single {} (tap @(doto !b (reset! (tap (new (m/watch !a))))))) tap tap) -;; % := 0 -;; % := 0 -;; (swap! !a inc) -;; ; the ref !b doesn't change, so we don't see 1 again -;; % := 1)) - -;; (comment "entrypoint forces evaluation (introduces eagerness)" ; desired behavior, we think -;; ; Alternative - do stmts are sampled (for effect) when result is sampled - -;; (def !a (atom 0)) -;; (def !b (atom 0)) -;; ((l/single {} (tap @(doto !b (reset! (tap (new (m/watch !a))))))) tap tap) -;; % := 0 -;; % := 0 -;; (swap! !a inc) -;; % := 1 -;; % := 1) - -;; #?(:clj (defn slow-identity [x] (Thread/sleep 30) x)) - -;; #?(:clj -;; (tests -;; (with ((l/single {} (try -;; ; This test asserts that these run concurrently. -;; ; If they block, the final tap would exceed the RCF timeout -;; (tap (e/offload #(slow-identity 1))) -;; (tap (e/offload #(slow-identity 2))) -;; (tap (e/offload #(slow-identity 3))) -;; (tap (e/offload #(slow-identity 4))) -;; (catch Pending _ (tap ::pending)))) tap tap) ; never see pending if thread is blocked -;; % := ::pending -;; (set [% % % %]) := #{3 1 2 4}))) ; concurrent sleeps race - -;; #?(:clj -;; (tests "reactive doto" -;; (defn MutableMap [] (new java.util.HashMap)) -;; (defn PutMap [!m k v] (.put !m k v)) -;; (defn Ref [] (new Object)) -;; (def !z (atom 0)) -;; (def !xx (atom 0)) -;; (with ((l/single {} -;; #_(doto (element "input") -;; (set-attribute! "type" "text") -;; (set-attribute! "value" x)) -;; (tap (doto (MutableMap) ; the doto is incrementalized -;; (PutMap "a" (swap! !z inc)) ; detect effect -;; (PutMap "b" (tap (e/watch !xx)))))) tap tap) -;; % := 0, % := {"a" 1 "b" 0} -;; (swap! !xx inc) -;; % := 1))) ; mutable map is clojure.core/=, therefore skipped - -;; (l/def trace!) +(tests "do forces evaluation (introduces eagerness)" + ; Current behavior - do stmts are sampled eagerly, as fast as possible + (def !a (atom 0)) + (def !b (atom 0)) + (with ((l/single {} (tap @(doto !b (reset! (tap (e/watch !a)))))) tap tap) + % := 0 + % := 0 + (swap! !a inc) + ; the ref !b doesn't change, so we don't see 1 again + % := 1)) + +(comment "entrypoint forces evaluation (introduces eagerness)" ; desired behavior, we think + ; Alternative - do stmts are sampled (for effect) when result is sampled + + (def !a (atom 0)) + (def !b (atom 0)) + ((l/single {} (tap @(doto !b (reset! (tap (new (m/watch !a))))))) tap tap) + % := 0 + % := 0 + (swap! !a inc) + % := 1 + % := 1) + +#?(:clj (defn slow-identity [x] (Thread/sleep 30) x)) + +;; TODO try +#?(:clj + (skip + (with ((l/single {} (try + ; This test asserts that these run concurrently. + ; If they block, the final tap would exceed the RCF timeout + (tap (e/offload #(slow-identity 1))) + (tap (e/offload #(slow-identity 2))) + (tap (e/offload #(slow-identity 3))) + (tap (e/offload #(slow-identity 4))) + (catch Pending _ (tap ::pending)))) tap tap) ; never see pending if thread is blocked + % := ::pending + (set [% % % %]) := #{3 1 2 4}))) ; concurrent sleeps race + +#?(:clj + (tests "reactive doto" + (defn MutableMap [] (new java.util.HashMap)) + (defn PutMap [!m k v] (.put !m k v)) + (defn Ref [] (new Object)) + (def !z (atom 0)) + (def !xx (atom 0)) + (with ((l/single {} + #_(doto (element "input") + (set-attribute! "type" "text") + (set-attribute! "value" x)) + (tap (doto (MutableMap) ; the doto is incrementalized + (PutMap "a" (swap! !z inc)) ; detect effect + (PutMap "b" (tap (e/watch !xx)))))) tap tap) + % := 0, % := {"a" 1 "b" 0} + (swap! !xx inc) + % := 1))) ; mutable map is clojure.core/=, therefore skipped + +(def trace!) ;; (l/defn Div [child] (trace! child) [:div child]) ;; (l/defn Widget [x] (Div. [(Div. x) (Div. :a)])) -;; (tests "reactive defn" -;; ; best example of this is hiccup incremental maintenance -;; (def !x (atom 0)) -;; (with ((l/single {} (tap (binding [trace! tap] (Widget. (e/watch !x))))) tap tap) -;; % := 0 -;; % := :a -;; % := [[:div 0] [:div :a]] -;; % := [:div [[:div 0] [:div :a]]] -;; (swap! !x inc) -;; % := 1 -;; ; no :a -;; % := [[:div 1] [:div :a]] -;; % := [:div [[:div 1] [:div :a]]])) +;; TODO defn +(skip "reactive defn" + ; best example of this is hiccup incremental maintenance + (def !x (atom 0)) + (with ((l/single {} (tap (binding [trace! tap] (Widget. (e/watch !x))))) tap tap) + % := 0 + % := :a + % := [[:div 0] [:div :a]] + % := [:div [[:div 0] [:div :a]]] + (swap! !x inc) + % := 1 + ; no :a + % := [[:div 1] [:div :a]] + % := [:div [[:div 1] [:div :a]]])) ;; (l/def G (e/fn [x] x)) ; reactive fn (DAG). Compiler marks dag with meta -;; (tests "node call vs fn call" -;; (defn f [x] x) ; This var is not marked with meta -;; (def !x (atom 0)) -;; (with ((l/single {} (tap (let [x (e/watch !x)] [(f x) (G. x)]))) tap tap) -;; % := [0 0])) +;; TODO defn +(skip "node call vs fn call" + (defn f [x] x) ; This var is not marked with meta + (def !x (atom 0)) + (with ((l/single {} (tap (let [x (e/watch !x)] [(f x) (G. x)]))) tap tap) + % := [0 0])) ;; (l/def G (e/fn [x] x)) -;; (tests "higher order dags" -;; (def !x (atom 0)) -;; (defn f [x] x) -;; (with -;; ((l/single {} -;; (tap (let [ff (fn [x] x) ; foreign clojure fns are sometimes useful, e.g. DOM callbacks -;; Gg (e/fn [x] x) ; but you almost always want reactive lambda, not cc/fn -;; x (e/watch !x)] -;; [(f x) ; var marked -;; (G. x) ; var says node -;; (ff x) ; Must assume interop, for compat with clojure macros -;; (Gg. x) ; Must mark reactive-call -;; (new (e/fn [x] x) x)]))) tap tap) -;; % := [0 0 0 0 0])) - -;; (tests "reactive closures" -;; (def !x (atom 1)) -;; (def !y (atom 10)) -;; (l/def x (e/watch !x)) -;; (l/def y (e/watch !y)) -;; (with ((l/single {} (tap (new (if (odd? x) -;; (e/fn [x] (* y x)) -;; (e/fn [x] (* y x))) -;; x))) tap tap) -;; % := 10 -;; (swap! !x inc) -;; % := 20 -;; (swap! !x inc) -;; % := 30 -;; (swap! !y inc) -;; % := 33 -;; (swap! !y inc) -;; % := 36)) - -;; (tests "reactive closures 2" -;; (def !x (atom 0)) -;; (def !y (atom 0)) -;; (with -;; ((l/single {} (tap (let [x (e/watch !x) -;; y (e/watch !y) -;; F (e/fn [x] (+ y x)) ; constant signal -;; G (if (odd? x) (e/fn [x] (+ y x)) -;; (e/fn [x] (+ y x))) -;; H (new (m/seed [(e/fn [x] (+ y x))]))] -;; [(F. x) -;; (G. x) -;; (H. x)]))) tap tap) -;; % := [0 0 0])) - -;; (tests "reactive clojure.core/fn" -;; (def !x (atom 0)) -;; (def !y (atom 0)) -;; (with -;; ((l/single {} -;; (tap (let [x (e/watch !x) -;; y (e/watch !y) -;; ; rebuild Clojure closure f when y updates -;; f (fn [needle] (+ y needle))] -;; ; (value is fully compatible with fn contract) -;; ; the lambda is as variable as the var it closes over -;; ; well defined. It's not allowed to use dataflow inside FN. Compiler can never reach it -;; ; compiler will walk it to detect the free variables only -;; (f x)))) tap tap) -;; % := 0 -;; (swap! !y inc) -;; % := 1 -;; (swap! !x inc) -;; % := 2)) - -;; (tests "For reference, Clojure exceptions have dynamic scope" -;; (try (let [f (try (fn [] (throw (ex-info "boom" {}))) ; this exception will escape -;; (catch #?(:clj Exception, :cljs :default) _ ::inner))] -;; ; the lambda doesn't know it was constructed in a try/catch block -;; (f)) -;; (catch #?(:clj Exception, :cljs :default) _ ::outer)) -;; := ::outer) - -;; (tests "Reactor crashes on uncaugh exceptions" -;; (def !x (atom true)) -;; (with ((l/single {} (tap (assert (e/watch !x)))) tap tap) -;; % := nil ; assert returns nil or throws -;; (swap! !x not) ; will crash the reactor -;; ;; TODO in old tests an ex-info comes out, why? Is this a FailureInfo? -;; (ex-message %) := "Assert failed: (e/watch !x)" -;; (swap! !x not) ; reactor will not come back. -;; (tap ::nope), % := ::nope)) - -;; (l/defn Boom [] (assert false)) -;; (tests "reactive exceptions" -;; (with ((l/single {} (tap (try -;; (Boom.) -;; (catch #?(:clj AssertionError, :cljs js/Error) e -;; e)))) tap tap) -;; #?(:clj (instance? AssertionError %) -;; :cljs (instance? js/Error %)) := true)) - -;; (tests -;; (with ((l/single {} (tap (try (let [Nf (try (e/fn [] (Boom.)) ; reactive exception uncaught -;; (catch #?(:clj AssertionError, :cljs :default) _ ::inner))] -;; (Nf.)) -;; (catch #?(:clj AssertionError, :cljs :default) _ ::outer)))) tap tap) -;; % := ::outer)) +;; TODO defn +(skip "higher order dags" + (def !x (atom 0)) + (defn f [x] x) + (with + ((l/single {} + (tap (let [ff (fn [x] x) ; foreign clojure fns are sometimes useful, e.g. DOM callbacks + Gg (e/fn [x] x) ; but you almost always want reactive lambda, not cc/fn + x (e/watch !x)] + [(f x) ; var marked + (G. x) ; var says node + (ff x) ; Must assume interop, for compat with clojure macros + (Gg. x) ; Must mark reactive-call + (new (e/fn [x] x) x)]))) tap tap) + % := [0 0 0 0 0])) + +(tests "reactive closures" + (def !x (atom 1)) + (def !y (atom 10)) + (with ((l/single {::lang/print-source true} + (let [x (e/watch !x), y (e/watch !y)] + (tap ($ (if (odd? x) + (e/fn [x] (prn :x1 x) (* y x)) + (e/fn [x] (prn :x2 x) (* y x))) + x)))) tap tap) + % := 10 + (swap! !x inc) + % := 20 + (swap! !x inc) + % := 30 + (swap! !y inc) + % := 33 + (swap! !y inc) + % := 36 + % := :foo + % := :bar + )) -;; (l/def inner) -;; (l/def Outer (e/fn [] inner)) +(comment + (def !x (atom 1)) + (def !y (atom 10)) + (def it ((l/single {} + (let [x (e/watch !x), y (e/watch !y)] + (tap ($ (if (odd? x) + (e/fn [x] (prn :x1 x) (* y x)) + (e/fn [x] (prn :x2 x) (* y x))) + x)))) prn prn)) + ;; :x1 1 + ;; 10 + (swap! !x inc) + ;; :x1 2 + ;; 20 + ;; :x2 2 + ;; 20 + ) -;; (tests "dynamic scope (note that try/catch has the same structure)" -;; (with ((l/single {} (tap (binding [inner ::inner] (Outer.)))) tap tap) -;; % := ::inner)) +#_[(r/cdef 0 [nil nil] [nil] nil + (fn [frame] + (r/define-node frame 0 (r/join (r/ap (r/lookup frame :r/fixed-signals (r/pure r/fixed-signals)) + (r/ap (r/lookup frame ::m/watch (r/pure m/watch)) + (r/lookup frame ::!y (r/pure !y)))))) + (r/define-node frame 1 (r/join (r/ap (r/lookup frame :r/fixed-signals (r/pure r/fixed-signals)) + (r/ap (r/lookup frame ::m/watch (r/pure m/watch)) + (r/lookup frame ::!x (r/pure !x)))))) + (r/define-call frame 0 (r/pure (r/bind (doto (r/make-ctor frame ::l/Main 1) + (r/define-free 0 (r/node frame 0)) + (r/define-free 1 (r/node frame 1))) + 0 (r/node frame 1)))) + (r/ap (r/pure RCF__tap) + (r/join (r/call frame 0))))) + (r/cdef 2 [nil] [nil nil] nil + (fn [frame] + (r/define-node frame 0 (r/pure (doto (r/make-ctor frame ::l/Main 2) + (r/define-free 0 (r/free frame 0))))) + (r/define-call frame 0 (r/join (r/call frame 1))) + (r/define-call frame 1 (r/ap (r/ap (r/pure hash-map) + (r/pure (quote nil)) (r/node frame 0) + (r/pure (quote false)) (r/node frame 0)) + (r/ap (r/lookup frame :odd? (r/pure odd?)) + (r/free frame 1)) + (r/pure (doto (r/make-ctor frame ::l/Main 4) + (r/define-free 0 (r/free frame 0)))))) + (r/join (r/call frame 0)))) + (r/cdef 1 [] [] nil + (fn [frame] + (r/pure (doto (r/make-ctor frame ::l/Main 3) + (r/define-free 0 (r/free frame 0)))))) + (r/cdef 1 [] [] nil + (fn [frame] + (r/ap (r/lookup frame :* (r/pure *)) + (r/free frame 0) + (r/lookup frame 0)))) + (r/cdef 1 [] [] nil + (fn [frame] + (r/pure (doto (r/make-ctor frame ::l/Main 5) + (r/define-free 0 (r/free frame 0)))))) + (r/cdef 1 [] [] nil + (fn [frame] + (r/ap (r/lookup frame :* (r/pure *)) + (r/free frame 0) + (r/lookup frame 0))))] + +(skip "reactive closures 2" + (def !x (atom 0)) + (def !y (atom 0)) + (with + ((l/single {} (tap (let [x (e/watch !x) + y (e/watch !y) + F (e/fn [x] (+ y x)) ; constant signal + G (if (odd? x) (e/fn [x] (+ y x)) + (e/fn [x] (+ y x))) + H (new (m/seed [(e/fn [x] (+ y x))]))] + [(F. x) + (G. x) + (H. x)]))) tap tap) + % := [0 0 0])) + +(skip "reactive clojure.core/fn" + (def !x (atom 0)) + (def !y (atom 0)) + (with + ((l/single {} + (tap (let [x (e/watch !x) + y (e/watch !y) + ; rebuild Clojure closure f when y updates + f (fn [needle] (+ y needle))] + ; (value is fully compatible with fn contract) + ; the lambda is as variable as the var it closes over + ; well defined. It's not allowed to use dataflow inside FN. Compiler can never reach it + ; compiler will walk it to detect the free variables only + (f x)))) tap tap) + % := 0 + (swap! !y inc) + % := 1 + (swap! !x inc) + % := 2)) -;; (tests "dynamic scope (note that try/catch has the same structure)" -;; (with ((l/single {} (tap (binding [inner ::outer] -;; (let [Nf (binding [inner ::inner] -;; (e/fn [] (Outer.)))] ; binding out of scope -;; (Nf.))))) tap tap) -;; % := ::outer)) +(skip "For reference, Clojure exceptions have dynamic scope" + (try (let [f (try (fn [] (throw (ex-info "boom" {}))) ; this exception will escape + (catch #?(:clj Exception, :cljs :default) _ ::inner))] + ; the lambda doesn't know it was constructed in a try/catch block + (f)) + (catch #?(:clj Exception, :cljs :default) _ ::outer)) + := ::outer) + +(skip "Reactor crashes on uncaugh exceptions" + (def !x (atom true)) + (with ((l/single {} (tap (assert (e/watch !x)))) tap tap) + % := nil ; assert returns nil or throws + (swap! !x not) ; will crash the reactor + ;; TODO in old tests an ex-info comes out, why? Is this a FailureInfo? + (ex-message %) := "Assert failed: (e/watch !x)" + (swap! !x not) ; reactor will not come back. + (tap ::nope), % := ::nope)) -;; (tests "lazy parameters. Flows are not run unless sampled" -;; (with ((l/single {} (new (e/fn [_]) (tap :boom))) tap tap) -;; % := :boom)) +;; (l/defn Boom [] (assert false)) +(skip "reactive exceptions" + (with ((l/single {} (tap (try + (Boom.) + (catch #?(:clj AssertionError, :cljs js/Error) e + e)))) tap tap) + #?(:clj (instance? AssertionError %) + :cljs (instance? js/Error %)) := true)) + +(skip + (with ((l/single {} (tap (try (let [Nf (try (e/fn [] (Boom.)) ; reactive exception uncaught + (catch #?(:clj AssertionError, :cljs :default) _ ::inner))] + (Nf.)) + (catch #?(:clj AssertionError, :cljs :default) _ ::outer)))) tap tap) + % := ::outer)) -;; (tests "lazy parameters. Flows are not run unless sampled" -;; (with ((l/single {} (let [_ (tap :bang)])) tap tap) ; todo, cc/let should sequence effects for cc compat -;; % := :bang)) +;; (l/def inner) +;; (l/def Outer (e/fn [] inner)) -;; (tests "client/server transfer" -;; ; Pending state is an error state. -;; ; Pending errors will crash the reactor if not caugh -;; (with ((l/single {} (try (tap (e/server (e/client 1))) (catch Pending _))) tap tap) -;; % := 1)) +(skip "dynamic scope (note that try/catch has the same structure)" + (with ((l/single {} (tap (binding [inner ::inner] (Outer.)))) tap tap) + % := ::inner)) + +(skip "dynamic scope (note that try/catch has the same structure)" + (with ((l/single {} (tap (binding [inner ::outer] + (let [Nf (binding [inner ::inner] + (e/fn [] (Outer.)))] ; binding out of scope + (Nf.))))) tap tap) + % := ::outer)) + +(skip "lazy parameters. Flows are not run unless sampled" + (with ((l/single {} (new (e/fn [_]) (tap :boom))) tap tap) + % := :boom)) + +(skip "lazy parameters. Flows are not run unless sampled" + (with ((l/single {} (let [_ (tap :bang)])) tap tap) ; todo, cc/let should sequence effects for cc compat + % := :bang)) + +(skip "client/server transfer" + ; Pending state is an error state. + ; Pending errors will crash the reactor if not caugh + (with ((l/single {} (try (tap (e/server (e/client 1))) (catch Pending _))) tap tap) + % := 1)) ;; (l/def foo nil) -;; (tests -;; (with ((l/single {} (try (tap (binding [foo 1] (e/server (e/client foo)))) -;; (catch Pending _))) tap tap) -;; % := 1)) +(skip + (with ((l/single {} (try (tap (binding [foo 1] (e/server (e/client foo)))) + (catch Pending _))) tap tap) + % := 1)) ;; (l/def foo nil) -;; (tests -;; (with ((l/single {} (try (tap (binding [foo 1] (e/server (new (e/fn [] (e/client foo)))))) -;; (catch Pending _))) tap tap) -;; % := 1)) +(skip + (with ((l/single {} (try (tap (binding [foo 1] (e/server (new (e/fn [] (e/client foo)))))) + (catch Pending _))) tap tap) + % := 1)) ;; (l/def foo1 nil) ;; (l/def Bar1 (e/fn [] (e/client foo1))) -;; (tests -;; (with ((l/single {} (try (tap (binding [foo1 1] (e/server (Bar1.)))) -;; (catch Pending _))) tap tap) -;; % := 1)) - -;; (tests "reactive pending states" -;; ;~(m/reductions {} hyperfiddle.electric.impl.runtime/pending m/none) -;; (with ((l/single {} (tap (try true (catch Pending _ ::pending)))) tap tap) -;; % := true)) - -;; (tests -;; (with ((l/single {} (tap (try (e/server 1) (catch Pending _ ::pending)))) tap tap) -;; % := ::pending ; Use try/catch to intercept special pending state -;; % := 1)) - -;; (tests -;; (with ((l/single {} (tap (try [(tap 1) (tap (e/server 2))] (catch Pending _ ::pending)))) tap tap) -;; % := 1 -;; % := ::pending -;; ; do not see 1 again -;; % := 2 -;; % := [1 2])) - -;; (tests "the same exception is thrown from two places!" -;; (l/defn InputController1 [tap controlled-value] -;; (try controlled-value (catch Pending _ (tap :pending-inner)))) - -;; (with ((l/single {} (try -;; (InputController1. tap (throw (Pending.))) -;; (catch Pending _ (tap :pending-outer)))) tap tap)) -;; % := :pending-inner -;; % := :pending-outer) - -;; (tests "object lifecycle" -;; (def !x (atom 0)) -;; (let [hook (fn [mount! unmount!] -;; (m/observe (fn [!] -;; (mount!) -;; (! nil) -;; #(unmount!)))) -;; dispose! -;; ((l/single {} (tap -;; (let [x (e/watch !x)] -;; (when (even? x) -;; (new (e/fn [x] -;; (new (hook (partial tap 'mount) (partial tap 'unmount))) -;; x) -;; x))))) tap tap)] - -;; % := 'mount -;; % := 0 -;; (swap! !x inc) -;; (hash-set % %) := '#{unmount nil} ;; should ordering matter here ? -;; (swap! !x inc) -;; % := 'mount -;; % := 2 -;; (dispose!) -;; % := 'unmount)) - -;; (tests "object lifecycle 3" -;; (defn observer [x] -;; (fn mount [f] -;; (f (tap [:up x])) -;; (fn unmount [] (tap [:down x])))) - -;; (def !state (atom [1])) -;; (with ((l/single {} (e/for [x (e/watch !state)] (new (m/observe (observer x))))) tap tap) -;; % := [:up 1] -;; (swap! !state conj 2) -;; % := [:up 2] -;; (reset! !state [3]) -;; (hash-set % % %) := #{[:up 3] [:down 1] [:down 2]}) -;; % := [:down 3]) - -;; (tests "object lifecycle 3 with pending state" -;; (def !state (atom [1])) - -;; (defn observer [tap x] -;; (fn mount [f] -;; (tap [::mount x]) -;; (f nil) -;; (fn unmount [] (tap [::unmount x])))) - -;; (let [dispose ((l/single {} (try -;; (e/for [x (e/watch !state)] ; pending state should not trash e/for branches -;; (new (m/observe (observer tap x)))) ; depends on x, which is pending -;; (catch Pending _))) tap tap)] -;; % := [::mount 1] -;; (reset! !state [2]) -;; (hash-set % %) := #{[::mount 2] [::unmount 1]} -;; (reset! !state (Failure. (Pending.))) ; simulate pending state, we cannot use e/server due to distributed glitch -;; % := [::unmount 2] ; FAIL e/for unmounted the branch -;; (reset! !state [2]) -;; % := [::mount 2] ; branch is back up -;; (dispose) -;; % := [::unmount 2])) +(skip + (with ((l/single {} (try (tap (binding [foo1 1] (e/server (Bar1.)))) + (catch Pending _))) tap tap) + % := 1)) + +(skip "reactive pending states" + ;~(m/reductions {} hyperfiddle.electric.impl.runtime/pending m/none) + (with ((l/single {} (tap (try true (catch Pending _ ::pending)))) tap tap) + % := true)) + +(skip + (with ((l/single {} (tap (try (e/server 1) (catch Pending _ ::pending)))) tap tap) + % := ::pending ; Use try/catch to intercept special pending state + % := 1)) + +(skip + (with ((l/single {} (tap (try [(tap 1) (tap (e/server 2))] (catch Pending _ ::pending)))) tap tap) + % := 1 + % := ::pending + ; do not see 1 again + % := 2 + % := [1 2])) + +(skip "the same exception is thrown from two places!" + (l/defn InputController1 [tap controlled-value] + (try controlled-value (catch Pending _ (tap :pending-inner)))) + + (with ((l/single {} (try + (InputController1. tap (throw (Pending.))) + (catch Pending _ (tap :pending-outer)))) tap tap)) + % := :pending-inner + % := :pending-outer) + +(skip "object lifecycle" + (def !x (atom 0)) + (let [hook (fn [mount! unmount!] + (m/observe (fn [!] + (mount!) + (! nil) + #(unmount!)))) + dispose! + ((l/single {} (tap + (let [x (e/watch !x)] + (when (even? x) + (new (e/fn [x] + (new (hook (partial tap 'mount) (partial tap 'unmount))) + x) + x))))) tap tap)] + + % := 'mount + % := 0 + (swap! !x inc) + (hash-set % %) := '#{unmount nil} ;; should ordering matter here ? + (swap! !x inc) + % := 'mount + % := 2 + (dispose!) + % := 'unmount)) + +(skip "object lifecycle 3" + (defn observer [x] + (fn mount [f] + (f (tap [:up x])) + (fn unmount [] (tap [:down x])))) + + (def !state (atom [1])) + (with ((l/single {} (e/for [x (e/watch !state)] (new (m/observe (observer x))))) tap tap) + % := [:up 1] + (swap! !state conj 2) + % := [:up 2] + (reset! !state [3]) + (hash-set % % %) := #{[:up 3] [:down 1] [:down 2]}) + % := [:down 3]) + +(skip "object lifecycle 3 with pending state" + (def !state (atom [1])) + + (defn observer [tap x] + (fn mount [f] + (tap [::mount x]) + (f nil) + (fn unmount [] (tap [::unmount x])))) + + (let [dispose ((l/single {} (try + (e/for [x (e/watch !state)] ; pending state should not trash e/for branches + (new (m/observe (observer tap x)))) ; depends on x, which is pending + (catch Pending _))) tap tap)] + % := [::mount 1] + (reset! !state [2]) + (hash-set % %) := #{[::mount 2] [::unmount 1]} + (reset! !state (Failure. (Pending.))) ; simulate pending state, we cannot use e/server due to distributed glitch + % := [::unmount 2] ; FAIL e/for unmounted the branch + (reset! !state [2]) + % := [::mount 2] ; branch is back up + (dispose) + % := [::unmount 2])) ;; (l/def x2 1) -;; (tests "object lifecycle 4" -;; (def !input (atom [1 2])) -;; (defn up-down [x trace!] (m/observe (fn [!] (trace! :up) (! x) #(trace! :down)))) - -;; (with ((l/single {} -;; (tap (e/for [id (new (m/watch !input))] -;; (binding [x2 (do id x2)] -;; (new (up-down x2 tap)))))) tap tap) -;; [% %] := [:up :up] -;; % := [1 1] -;; (swap! !input pop) -;; % := :down -;; % := [1]) -;; % := :down) - -;; (tests "reactive metadata" -;; (def !x (atom 0)) -;; (with ((l/single {} (tap (meta (let [x (with-meta [] {:foo (e/watch !x)})] x)))) tap tap) -;; % := {:foo 0} -;; (swap! !x inc) -;; (tap ::hi) % := ::hi)) - -;; (tests "undefined continuous flow, flow is not defined for the first 10ms" -;; (let [flow (m/ap (m/? (m/sleep 10 :foo)))] -;; (with ((l/single {} (tap (new (new (e/fn [] (let [a (new flow)] (e/fn [] a))))))) tap tap) -;; (ex-message %) := "Undefined continuous flow."))) - -;; (tests -;; (def !x (atom 0)) -;; (with ((l/single {} (tap (try (-> (e/watch !x) -;; (doto (-> even? (when-not (throw (ex-info "odd" {}))))) -;; (/ 2)) -;; (catch #?(:clj Exception, :cljs :default) e (ex-message e))))) tap tap) -;; % := 0 -;; (swap! !x inc) -;; % := "odd" -;; (swap! !x inc) -;; % := 1)) - -;; (tests -;; (def !x (atom 0)) -;; (def !f (atom "hello")) -;; (def e (ex-info "error" {})) -;; (with ((l/single {} -;; (tap (try (if (even? (e/watch !x)) :ok (throw e)) -;; (catch #?(:clj Throwable, :cljs :default) _ :caugh) -;; (finally (tap (e/watch !f)))))) tap tap) -;; % := "hello" -;; % := :ok -;; (swap! !x inc) -;; % := :caugh -;; (reset! !f "world") -;; % := "world" -;; (swap! !x inc) -;; % := :ok)) +(skip "object lifecycle 4" + (def !input (atom [1 2])) + (defn up-down [x trace!] (m/observe (fn [!] (trace! :up) (! x) #(trace! :down)))) + + (with ((l/single {} + (tap (e/for [id (new (m/watch !input))] + (binding [x2 (do id x2)] + (new (up-down x2 tap)))))) tap tap) + [% %] := [:up :up] + % := [1 1] + (swap! !input pop) + % := :down + % := [1]) + % := :down) + +(skip "reactive metadata" + (def !x (atom 0)) + (with ((l/single {} (tap (meta (let [x (with-meta [] {:foo (e/watch !x)})] x)))) tap tap) + % := {:foo 0} + (swap! !x inc) + (tap ::hi) % := ::hi)) + +(skip "undefined continuous flow, flow is not defined for the first 10ms" + (let [flow (m/ap (m/? (m/sleep 10 :foo)))] + (with ((l/single {} (tap (new (new (e/fn [] (let [a (new flow)] (e/fn [] a))))))) tap tap) + (ex-message %) := "Undefined continuous flow."))) + +(skip + (def !x (atom 0)) + (with ((l/single {} (tap (try (-> (e/watch !x) + (doto (-> even? (when-not (throw (ex-info "odd" {}))))) + (/ 2)) + (catch #?(:clj Exception, :cljs :default) e (ex-message e))))) tap tap) + % := 0 + (swap! !x inc) + % := "odd" + (swap! !x inc) + % := 1)) + +(skip + (def !x (atom 0)) + (def !f (atom "hello")) + (def e (ex-info "error" {})) + (with ((l/single {} + (tap (try (if (even? (e/watch !x)) :ok (throw e)) + (catch #?(:clj Throwable, :cljs :default) _ :caugh) + (finally (tap (e/watch !f)))))) tap tap) + % := "hello" + % := :ok + (swap! !x inc) + % := :caugh + (reset! !f "world") + % := "world" + (swap! !x inc) + % := :ok)) ;; (l/def unbound1) ;; (l/def unbound2) -;; (tests -;; (with ((l/single {} (tap (new (e/fn [] (binding [unbound1 1 unbound2 2] (+ unbound1 unbound2)))))) tap tap) -;; % := 3)) - -;; #?(:clj -;; (tests -;; "understand how Clojure handles unbound vars" -;; ; In Clojure, -;; ; Is unbound var defined or undefined behavior? -;; ; What does it mean in CLJS? No vars in cljs. -;; (def ^:dynamic y_964) -;; (bound? #'y_964) := false -;; (.isBound #'y_964) := false -;; (def unbound (clojure.lang.Var$Unbound. #'y_964)) -;; (instance? clojure.lang.Var$Unbound unbound) := true - -;; ; leaking unbounded value -;; (instance? clojure.lang.Var$Unbound y_964) := true - -;; ; not an error in clojure -;; (try y_964 (catch Exception e nil)) -;; (instance? clojure.lang.Var$Unbound *1) := true) -;; ) - -;; (tests "In Electric, accessing an unbound var throws a userland exception" -;; ;; An unbound var is either: -;; ;; - an uninitialized p/def, -;; ;; - an unsatisfied reactive fn parameter (reactive fn called with too few arguments). -;; (l/def x) -;; (with ((l/single {} x) prn tap) -;; (ex-message %) := "Unbound electric var `hyperfiddle.electric-test/x`")) - -;; (tests "Initial p/def binding is readily available in p/run" -;; (def !x (atom 0)) -;; (l/def X (m/watch !x)) -;; (with ((l/single {} (tap (X.))) tap tap) -;; % := 0 -;; (swap! !x inc) -;; % := 1)) - -;; #?(:clj -;; (tests ; GG: IDE doc on hover support -;; "Vars created with p/def have the same metas as created with cc/def" -;; (l/def Documented "p/def" :init) -;; (select-keys (meta (var Documented)) [:name :doc]) -;; := {:name 'Documented -;; :doc "p/def"})) - -;; #?(:clj -;; (tests ; GG: IDE doc on hover support -;; "Vars created with p/defn have the same metas as created with cc/defn" -;; (l/defn Documented "doc" [a b c]) -;; (select-keys (meta (var Documented)) [:name :doc :arglists]) -;; := {:name 'Documented -;; :doc "doc" -;; :arglists '([a b c])})) - -;; (tests "pentagram of death - via Kenny Tilton" -;; ; Key elements: -;; ; - two dependency chains from some property P leading back to one property X; and -;; ; - branching code in the derivation of P that will not travel the second dependency chain until a -;; ; certain condition is met; and -;; ; - by chance, propagation reaches P on the the first path before it reaches some intermediate property -;; ; I on the second dependency chain. -;; ; The consequence is P updating once and reading (for the first time) property I, which has not yet been -;; ; updated hence is inconsistent with the new value of X. This inconsistency is temporary (hence the name -;; ; "glitch") because I will be updated soon enough and P will achieve consistency with X, but if one's -;; ; reactive engine dispatches side effects off state change -- possible trouble. -;; (def !aa (atom 1)) -;; (def !a7 (atom 7)) -;; (with -;; ((l/single {} -;; (let [aa (e/watch !aa) -;; a7 (e/watch !a7) -;; a70 (* 10 a7) -;; bb aa -;; cc (* 10 aa) -;; dd (if (even? bb) -;; (* 10 cc) -;; 42)] -;; (tap (+ a70 bb (* 10000 dd))))) tap tap) -;; % := 420071 -;; (swap! !aa inc) -;; % := 2000072 -;; (swap! !aa inc) -;; % := 420073)) - -;; (tests "pentagram of death reduced" -;; ; the essence of the problem is: -;; ; 1. if/case switch/change the DAG (imagine a railroad switch between two train tracks) -;; ; 2. to have a conditional where the predicate and the consequent have a common dependency -;; (def !x (atom 1)) -;; (with ((l/single {} (tap (let [p (e/watch !x) -;; q (tap (str p)) -;; control (- p)] -;; (case control -1 p -2 q q)))) tap tap) -;; % := "1" ; cc/let sequences effects -;; % := 1 ; cross -;; (swap! !x inc) -;; % := "2" ; q first touched -;; % := "2")) - -;; (tests "for with literal input" -;; (with ((l/single {} (tap (e/for [x [1 2 3]] (tap x)))) tap tap) -;; (hash-set % % %) := #{1 2 3} -;; % := [1 2 3])) - -;; (tests "for with literal input, nested" -;; (def !x (atom 0)) -;; (with ((l/single {} (tap (when (even? (e/watch !x)) -;; (e/for [x [1 2 3]] -;; (tap x))))) tap tap) -;; (hash-set % % %) := #{1 2 3} -;; % := [1 2 3] -;; (swap! !x inc) -;; % := nil)) - -;; (tests "nested closure" -;; (def !x (atom 0)) -;; (with ((l/single {} (tap (new (let [x (e/watch !x)] -;; (if (even? x) -;; (e/fn [] :even) -;; (e/fn [] :odd)))))) tap tap) -;; % := :even -;; (swap! !x inc) -;; % := :odd)) - -;; (tests "simultaneous add and remove in a for with a nested hook" -;; (def !xs (atom [1])) -;; (defn hook -;; ([x] (tap [x])) -;; ([x y] (tap [x y]))) -;; (with -;; ((l/single {} -;; (tap (new (e/hook hook 0 -;; (e/fn [] -;; (e/for [x (e/watch !xs)] -;; (new (e/hook hook x -;; (e/fn [] (str x)))))))))) tap tap) -;; % := [1 nil] -;; % := ["1"] -;; (reset! !xs [2]) -;; % := [2 nil] -;; % := ["2"] -;; % := [1] ;; unmount on next frame ??? -;; ) -;; % := [2] -;; % := [0]) - -;; (tests -;; (def !t (atom true)) -;; (with ((l/single {} -;; (tap (try (let [t (e/watch !t)] -;; (when t t (e/server t))) -;; (catch Pending _ :pending) -;; #_(catch Cancelled _ :cancelled)))) tap tap) -;; % := :pending -;; % := true -;; (swap! !t not) -;; % := nil)) - -;; (tests -;; (def !state (atom true)) -;; (with ((l/single {} (when (e/watch !state) (tap :touch))) tap tap) -;; % := :touch -;; (reset! !state true) -;; (tap ::nope) % := ::nope)) - -;; (tests "e/for in a conditional" -;; (def !state (atom true)) -;; (with ((l/single {} (tap (if (e/watch !state) 1 (e/for [_ []])))) tap tap) -;; % := 1 -;; (swap! !state not) -;; % := [] -;; (swap! !state not) -;; % := 1) -;; ) - - -;; (comment ; we are not sure if this test has value. It is not minimized. -;; (tests "Hack for e/for in a conditional. Passes by accident" ; PASS -;; (def !state (atom true)) -;; (with ((l/single {} (tap (if (e/watch !state) 1 (try (e/for [_ []]) (catch Throwable t (throw t)))))) tap tap) -;; % := 1 -;; (swap! !state not) -;; % := [] -;; (swap! !state not) -;; % := 1))) - -;; (tests "Nested e/for with transfer" -;; (def !state (atom [1])) -;; (l/def state (e/watch !state)) -;; (with ((l/single {} (try (e/for [x (e/server state)] -;; (e/for [y (e/server state)] -;; (tap [x y]))) -;; (catch Cancelled _) -;; (catch Pending _))) tap tap) -;; % := [1 1] -;; (reset! !state [3]) -;; % := [3 3])) - -;; (tests -;; "Static call" -;; (with ((l/single {} (tap (Math/abs -1))) tap tap) -;; % := 1)) - -;; #?(:clj -;; (tests "Dot syntax works (clj only)" -;; (with ((l/single {} (tap (. Math abs -1))) tap tap) -;; % := 1))) - -;; (tests "Sequential destructuring" -;; (with ((l/single {} (tap (let [[x y & zs :as coll] [:a :b :c :d]] [x y zs coll]))) tap tap) -;; % := [:a :b '(:c :d) [:a :b :c :d]])) - -;; (tests "Associative destructuring" -;; (with ((l/single {} (tap (let [{:keys [a ns/b d] -;; :as m -;; :or {d 4}} -;; {:a 1, :ns/b 2 :c 3}] [a b d m]))) tap tap) -;; % := [1 2 4 {:a 1, :ns/b 2, :c 3}])) - -;; (tests "Associative destructuring with various keys" -;; (with ((l/single {} (tap (let [{:keys [a] -;; :ns/keys [b] -;; :syms [c] -;; :ns/syms [d] -;; :strs [e]} -;; {:a 1, :ns/b 2, 'c 3, 'ns/d 4, "e" 5}] -;; [a b c d e]))) tap tap) -;; % := [1 2 3 4 5])) - -;; (tests "fn destructuring" -;; (with ((l/single {} -;; (try -;; (tap (e/client ((fn [{:keys [a] ::keys [b]}] [::client a b]) {:a 1 ::b 2}))) -;; (tap (e/server ((fn [{:keys [a] ::keys [b]}] [::server a b]) {:a 1 ::b 2}))) -;; (catch Pending _))) tap tap)) -;; % := [::client 1 2] -;; % := [::server 1 2]) - -;; (tests -;; (def !xs (atom [false])) -;; (with -;; ((l/single {} -;; (tap (try (e/for [x (e/watch !xs)] -;; (assert x)) -;; (catch #?(:clj Error :cljs js/Error) _ :error)))) tap tap) -;; % := :error -;; (reset! !xs []) -;; % := [])) - -;; (tests "All Pending instances are equal" -;; (= (Pending.) (Pending.)) := true) - -;; (tests -;; "Failure instances are equal if the errors they convey are equal" -;; (= (Failure. (Pending.)) (Failure. (Pending.))) := true - -;; (let [err (ex-info "error" {})] -;; (= err err) := true -;; (= (Failure. err) (Failure. err)) := true -;; (= (ex-info "a" {}) (ex-info "a" {})) := false -;; (= (Failure. (ex-info "err" {})) (Failure. (ex-info "err" {}))) := false)) - -;; (tests ; temporary test because p/run does not serilize to transit. -;; "Electric transit layer serializes unserializable values to nil" -;; (electric-io/decode (electric-io/encode 1)) := 1 -;; (electric-io/decode (electric-io/encode (type 1))) := nil) - -;; ;; HACK sequences cljs async tests. Symptomatic of an RCF issue. -;; ;; Ticket: https://www.notion.so/hyperfiddle/cljs-test-suite-can-produce-false-failures-0b3799f6d2104d698eb6a956b6c51e48 -;; #?(:cljs (t/use-fixtures :each {:after #(t/async done (js/setTimeout done 1))})) - -;; (tests -;; (def !x (atom true)) -;; (with ((l/single {} -;; (try -;; (let [x (e/watch !x)] -;; ; check eager network does not beat the switch -;; (tap (if x (e/server [:server x]) [:client x]))) -;; (catch Pending _))) tap tap) -;; % := [:server true] -;; (swap! !x not) -;; ; the remote tap on the switch has been removed -;; % := [:client false])) - -;; (tests -;; (def !x (atom true)) -;; (l/def x (e/server (e/watch !x))) -;; (with ((l/single {} -;; (try -;; (if (e/server x) ; to be consistent, client should see x first and switch -;; (e/server (tap x)) ; but test shows that the server sees x change before client -;; (e/server x)) -;; (catch Pending _))) tap tap) -;; % := true -;; (swap! !x not) -;; % := false #_ ::rcf/timeout) -;; ; we have to choose: consistency or less latency? -;; ; current behavior - Dustin likes, Leo does not like -;; ) - -;; ;; https://www.notion.so/hyperfiddle/distribution-glitch-stale-local-cache-of-remote-value-should-be-invalidated-pending-47f5e425d6cf43fd9a37981c9d80d2af -;; (tests "glitch - stale local cache of remote value should be invalidated/pending" -;; (def !x (atom 0)) -;; (def dispose ((l/single {} (tap (try (let [x (new (m/watch !x))] -;; ;; pending or both equal -;; [x (e/server x)]) -;; (catch Pending _ ::pending)))) tap tap)) -;; % := ::pending -;; % := [0 0] -;; (swap! !x inc) -;; % := ::pending -;; % := [1 1] -;; (dispose)) - -;; (comment -;; ; https://www.notion.so/hyperfiddle/p-fn-transfer-d43869c673574390b186ccb4df824b39 -;; ((l/single {} -;; (e/server -;; (let [Foo (e/fn [] (type 1))] -;; (tap (Foo.)) -;; (tap (e/client (Foo.)))))) tap tap) -;; % := "class java.lang.Long" -;; % := "class #object[Number]" - -;; ; implications - all ~e/fns~ neutral electric expressions are compiled for both peers, including -;; ; the parts that don't make sense, because you don't know in advance which peer will -;; ; run which function - -;; ; costs: -;; ; increases size of compiler artifacts -;; ; increases compile times -;; ) - -;; (tests -;; (with ((l/single {} (try (e/server -;; (let [foo 1] -;; (tap foo) -;; (tap (e/client foo)))) -;; (catch Pending _))) tap tap) -;; % := 1 -;; % := 1)) - -;; (tests "Today, bindings fail to transfer, resulting in unbound var exception. This will be fixed" -;; ; https://www.notion.so/hyperfiddle/photon-binding-transfer-unification-of-client-server-binding-7e56d9329d224433a1ee3057e96541d1 -;; (l/def foo) -;; (with ((l/single {} (try -;; (e/server -;; (binding [foo 1] -;; (tap foo) -;; (tap (e/client foo)))) -;; (catch Pending _) -;; (catch #?(:clj Error :cljs js/Error) e -;; (tap e)))) tap tap) -;; % := 1 -;; ; % := 1 -- target future behavior -;; (type %) := #?(:clj Error :cljs js/Error))) - -;; (tests "static method call" -;; (with ((l/single {} (tap (Math/max 2 1))) tap tap) -;; % := 2)) - -;; (tests "static method call in e/server" -;; (with ((l/single {} (try (tap (e/server (Math/max 2 1))) -;; (catch Pending _))) tap tap) -;; % := 2)) - -;; (tests "static method call in e/client" -;; (with ((l/single {} (try (tap (e/server (subvec (vec (range 10)) -;; (Math/min 1 1) -;; (Math/min 3 3)))) -;; (catch Pending _))) tap tap) -;; % := [1 2])) - -;; (tests "Inline cc/fn support" -;; (def !state (atom 0)) -;; (l/def global) -;; (with ((l/single {} (let [state (e/watch !state) -;; local [:local state] -;; f (binding [global [:global state]] -;; (fn ([a] [a local hyperfiddle.electric-test/global]) -;; ([a b] [a b local global]) -;; ([a b & cs] [a b cs local global])))] -;; (tap (f state)) -;; (tap (f state :b)) -;; (tap (f state :b :c :d)))) tap tap) -;; % := [0 [:local 0] [:global 0]] -;; % := [0 :b [:local 0] [:global 0]] -;; % := [0 :b '(:c :d) [:local 0] [:global 0]] -;; (swap! !state inc) -;; % := [1 [:local 1] [:global 1]] -;; % := [1 :b [:local 1] [:global 1]] -;; % := [1 :b '(:c :d) [:local 1] [:global 1]])) - -;; (tests "cc/fn lexical bindings are untouched" -;; (with ((l/single {} (let [a 1 -;; b 2 -;; f (fn [a] (let [b 3] [a b]))] -;; (tap (f 2)))) tap tap) -;; % := [2 3])) - -;; (tests "Inline cc/fn shorthand support" -;; (with ((l/single {} (tap (#(inc %) 1))) tap tap) -;; % := 2)) - -;; (tests "inline m/observe support" -;; (let [!state (atom 0)] -;; (with ((l/single {} (let [state (e/watch !state) -;; lifecycle (m/observe (fn [push] -;; (tap :up) -;; (push state) -;; #(tap :down))) -;; val (new lifecycle)] -;; (tap val))) tap tap) -;; % := :up -;; % := 0 -;; (swap! !state inc) -;; % := :down -;; % := :up -;; % := 1) -;; % := :down)) - -;; (tests "Inline letfn support" -;; (with ((l/single {} (tap (letfn [(descent [x] (cond (pos? x) (dec x) -;; (neg? x) (inc x) -;; :else x)) -;; (is-even? [x] (if (zero? x) true (is-odd? (descent x)))) -;; (is-odd? [x] (if (zero? x) false (is-even? (descent x))))] -;; (tap [(is-even? 0) (is-even? 1) (is-even? 2) (is-even? -2)]) -;; (tap [(is-odd? 0) (is-odd? 2) (is-odd? 3) (is-odd? -3)])))) tap tap) -;; % := [true false true true] -;; % := [false false true true] -;; % := [false false true true])) - -;; (tests -;; (with ((l/single {} (try (letfn [(foo [])] -;; (tap (e/watch (atom 1)))) -;; (catch Throwable t (prn t)))) tap tap) -;; % := 1)) - -;; (tests "Inline letfn support" -;; (def !state (atom 0)) -;; (l/def global) -;; (with ((l/single {} (let [state (e/watch !state) -;; local [:local state]] -;; (binding [global [:global state]] -;; (letfn [(f ([a] [a local hyperfiddle.electric-test/global]) -;; ([a b] [a b local global]) -;; ([a b & cs] [a b cs local global]))] -;; (tap (f state)) -;; (tap (f state :b)) -;; (tap (f state :b :c :d)))))) tap tap) -;; % := [0 [:local 0] [:global 0]] -;; % := [0 :b [:local 0] [:global 0]] -;; % := [0 :b '(:c :d) [:local 0] [:global 0]] -;; (swap! !state inc) -;; % := [1 [:local 1] [:global 1]] -;; % := [1 :b [:local 1] [:global 1]] -;; % := [1 :b '(:c :d) [:local 1] [:global 1]])) - -;; #?(:clj -;; (tests "e/fn is undefined in clojure-land" -;; (tap (try (lang/analyze {} `(fn [] (e/fn []))) (catch Throwable e (ex-message (ex-cause e))))) -;; % := "Electric code (hyperfiddle.electric/fn) inside a Clojure function")) - -;; #?(:clj -;; (tests "e/client is undefined in clojure-land" -;; (tap (try (lang/analyze {} `(fn [] (e/client []))) (catch Throwable e (ex-message (ex-cause e))))) -;; % := "Electric code (hyperfiddle.electric/client) inside a Clojure function")) - -;; #?(:clj -;; (tests "e/server is undefined in clojure-land" -;; (tap (try (lang/analyze {} `(fn [] (e/server []))) (catch Throwable e (ex-message (ex-cause e))))) -;; % := "Electric code (hyperfiddle.electric/server) inside a Clojure function")) - -;; #?(:clj -;; (tests "e/server is undefined in clojure-land" -;; (tap (try (lang/analyze {} `(fn [] (e/watch (atom :nomatter)))) (catch Throwable e (ex-message (ex-cause e))))) -;; % := "Electric code (hyperfiddle.electric/watch) inside a Clojure function")) - -;; (tests "cycle" -;; (with ((l/single {} -;; (let [!F (atom (e/fn [] 0))] -;; (tap (new (new (m/watch !F)))) -;; (let [y 1] (reset! !F (e/fn [] y))))) tap tap) -;; % := 0 -;; % := 1)) - -;; #?(:clj ; test broken in cljs, not sure why -;; (tests "loop/recur" -;; (l/defn fib [n] (loop [n n] (if (<= n 2) 1 (+ (recur (dec n)) (recur (- n 2)))))) -;; (with ((l/single {} (tap (e/for [i (range 1 11)] (fib. i)))) tap tap) -;; % := [1 1 2 3 5 8 13 21 34 55]))) - -;; ;; currently broken https://www.notion.so/hyperfiddle/cr-macro-internal-mutation-violates-photon-purity-requirement-119c18755ddd466384beb15f1e2317c5 -;; #_ -;; (tests -;; "inline m/cp support" -;; (let [!state (atom 0)] -;; (with (p/run (let [state (p/watch !state)] -;; (tap (new (m/cp state))))) -;; % := 0 -;; (swap! !state inc) -;; % := 1)) - -;; "inline m/ap support" -;; (let [!state (atom [1])] -;; (with (p/run (let [coll (p/watch !state)] -;; (tap (new (m/ap (tap (m/?< (m/seed coll)))))))) -;; % := 1 -;; % := 1 -;; (swap! !state conj 2) -;; % := 1 -;; % := 2 -;; % := 2))) - -;; (tests "letfn body is electric" -;; (l/def z 3) -;; (def !x (atom 4)) -;; (with ((l/single {} (let [y 2] (letfn [(f [x] (g x)) (g [x] [x y z])] (tap (f (e/watch !x)))))) tap tap) -;; % := [4 2 3] -;; (swap! !x inc) -;; % := [5 2 3])) - -;; ;; currently broken https://www.notion.so/hyperfiddle/cr-macro-internal-mutation-violates-photon-purity-requirement-119c18755ddd466384beb15f1e2317c5 -;; #_ -;; (tests -;; "inline m/sp support" -;; (let [!state (atom 0)] -;; (with (p/run (let [val (p/watch !state) -;; task (m/sp val)] -;; (tap (new (m/relieve {} (m/reductions {} :init (m/ap (m/? task)))))))) -;; % := 0 -;; (swap! !state inc) -;; % := 1 -;; ))) - -;; #?(:clj -;; (tests "set!" -;; (def !y (atom 8)) -;; (with ((l/single {} (let [pt (java.awt.Point. 1 2) -;; y (e/watch !y)] -;; (set! (.-y pt) y) -;; ;; calling (.-y pt) doesn't work, it's deduped -;; (tap [y pt]))) tap tap) -;; % := [8 (java.awt.Point. 1 8)] -;; (swap! !y inc) -;; % := [9 (java.awt.Point. 1 9)]))) - -;; #?(:cljs -;; (do-browser -;; (tests "set!" -;; ;; https://www.notion.so/hyperfiddle/RCF-implicit-do-rewrite-rule-does-not-account-for-let-bindings-61b1ad82771c407198c1f678683bf443 -;; (defn bypass-rcf-bug [[href a]] [href (str/replace (.-href a) #".*/" "")]) -;; (def !href (atom "href1")) -;; (with ((l/single {} (let [a (.createElement js/document "a") -;; href (e/watch !href)] -;; (set! (.-href a) href) -;; (tap [href a]))) tap tap) -;; (bypass-rcf-bug %) := ["href1" "href1"] -;; (reset! !href "href2") -;; (bypass-rcf-bug %) := ["href2" "href2"])))) - -;; #?(:clj (tests "set! with electric value" -;; (with ((l/single {} (tap (let [pt (java.awt.Point. 1 2)] -;; (set! (.-y pt) (new (e/fn [] 0)))))) tap tap) -;; % := 0))) - -;; #?(:cljs (tests "set! with electric value" -;; (with ((l/single {} (tap (let [o (js/Object.)] -;; (set! (.-x o) (new (e/fn [] 0)))))) tap tap) -;; % := 0))) - -;; (tests "e/fn arity check" -;; (with ((l/single {} (try (new (e/fn [x y z] (throw (ex-info "nope" {}))) 100 200 300 400) -;; (catch ExceptionInfo e (tap e)) -;; (catch Cancelled _) -;; (catch Throwable t (prn t)))) tap tap) -;; (ex-message %) := "You called with 4 arguments but it only supports 3")) +(skip + (with ((l/single {} (tap (new (e/fn [] (binding [unbound1 1 unbound2 2] (+ unbound1 unbound2)))))) tap tap) + % := 3)) + +#?(:clj +(skip + "understand how Clojure handles unbound vars" + ; In Clojure, + ; Is unbound var defined or undefined behavior? + ; What does it mean in CLJS? No vars in cljs. + (def ^:dynamic y_964) + (bound? #'y_964) := false + (.isBound #'y_964) := false + (def unbound (clojure.lang.Var$Unbound. #'y_964)) + (instance? clojure.lang.Var$Unbound unbound) := true + + ; leaking unbounded value + (instance? clojure.lang.Var$Unbound y_964) := true + + ; not an error in clojure + (try y_964 (catch Exception e nil)) + (instance? clojure.lang.Var$Unbound *1) := true) +) + +(skip "In Electric, accessing an unbound var throws a userland exception" + ;; An unbound var is either: + ;; - an uninitialized p/def, + ;; - an unsatisfied reactive fn parameter (reactive fn called with too few arguments). + (l/def x) + (with ((l/single {} x) prn tap) + (ex-message %) := "Unbound electric var `hyperfiddle.electric-test/x`")) + +(skip "Initial p/def binding is readily available in p/run" + (def !x (atom 0)) + (l/def X (m/watch !x)) + (with ((l/single {} (tap (X.))) tap tap) + % := 0 + (swap! !x inc) + % := 1)) + +#?(:clj + (skip ; GG: IDE doc on hover support + "Vars created with p/def have the same metas as created with cc/def" + (l/def Documented "p/def" :init) + (select-keys (meta (var Documented)) [:name :doc]) + := {:name 'Documented + :doc "p/def"})) + +#?(:clj + (skip ; GG: IDE doc on hover support + "Vars created with p/defn have the same metas as created with cc/defn" + (l/defn Documented "doc" [a b c]) + (select-keys (meta (var Documented)) [:name :doc :arglists]) + := {:name 'Documented + :doc "doc" + :arglists '([a b c])})) + +(skip "pentagram of death - via Kenny Tilton" + ; Key elements: + ; - two dependency chains from some property P leading back to one property X; and + ; - branching code in the derivation of P that will not travel the second dependency chain until a + ; certain condition is met; and + ; - by chance, propagation reaches P on the the first path before it reaches some intermediate property + ; I on the second dependency chain. + ; The consequence is P updating once and reading (for the first time) property I, which has not yet been + ; updated hence is inconsistent with the new value of X. This inconsistency is temporary (hence the name + ; "glitch") because I will be updated soon enough and P will achieve consistency with X, but if one's + ; reactive engine dispatches side effects off state change -- possible trouble. + (def !aa (atom 1)) + (def !a7 (atom 7)) + (with + ((l/single {} + (let [aa (e/watch !aa) + a7 (e/watch !a7) + a70 (* 10 a7) + bb aa + cc (* 10 aa) + dd (if (even? bb) + (* 10 cc) + 42)] + (tap (+ a70 bb (* 10000 dd))))) tap tap) + % := 420071 + (swap! !aa inc) + % := 2000072 + (swap! !aa inc) + % := 420073)) + +(skip "pentagram of death reduced" + ; the essence of the problem is: + ; 1. if/case switch/change the DAG (imagine a railroad switch between two train tracks) + ; 2. to have a conditional where the predicate and the consequent have a common dependency + (def !x (atom 1)) + (with ((l/single {} (tap (let [p (e/watch !x) + q (tap (str p)) + control (- p)] + (case control -1 p -2 q q)))) tap tap) + % := "1" ; cc/let sequences effects + % := 1 ; cross + (swap! !x inc) + % := "2" ; q first touched + % := "2")) + +(skip "for with literal input" + (with ((l/single {} (tap (e/for [x [1 2 3]] (tap x)))) tap tap) + (hash-set % % %) := #{1 2 3} + % := [1 2 3])) + +(skip "for with literal input, nested" + (def !x (atom 0)) + (with ((l/single {} (tap (when (even? (e/watch !x)) + (e/for [x [1 2 3]] + (tap x))))) tap tap) + (hash-set % % %) := #{1 2 3} + % := [1 2 3] + (swap! !x inc) + % := nil)) + +(skip "nested closure" + (def !x (atom 0)) + (with ((l/single {} (tap (new (let [x (e/watch !x)] + (if (even? x) + (e/fn [] :even) + (e/fn [] :odd)))))) tap tap) + % := :even + (swap! !x inc) + % := :odd)) + +(skip "simultaneous add and remove in a for with a nested hook" + (def !xs (atom [1])) + (defn hook + ([x] (tap [x])) + ([x y] (tap [x y]))) + (with + ((l/single {} + (tap (new (e/hook hook 0 + (e/fn [] + (e/for [x (e/watch !xs)] + (new (e/hook hook x + (e/fn [] (str x)))))))))) tap tap) + % := [1 nil] + % := ["1"] + (reset! !xs [2]) + % := [2 nil] + % := ["2"] + % := [1] ;; unmount on next frame ??? + ) + % := [2] + % := [0]) + +(skip + (def !t (atom true)) + (with ((l/single {} + (tap (try (let [t (e/watch !t)] + (when t t (e/server t))) + (catch Pending _ :pending) + #_(catch Cancelled _ :cancelled)))) tap tap) + % := :pending + % := true + (swap! !t not) + % := nil)) + +(skip + (def !state (atom true)) + (with ((l/single {} (when (e/watch !state) (tap :touch))) tap tap) + % := :touch + (reset! !state true) + (tap ::nope) % := ::nope)) + +(skip "e/for in a conditional" + (def !state (atom true)) + (with ((l/single {} (tap (if (e/watch !state) 1 (e/for [_ []])))) tap tap) + % := 1 + (swap! !state not) + % := [] + (swap! !state not) + % := 1) + ) + + +(comment ; we are not sure if this test has value. It is not minimized. + (skip "Hack for e/for in a conditional. Passes by accident" ; PASS + (def !state (atom true)) + (with ((l/single {} (tap (if (e/watch !state) 1 (try (e/for [_ []]) (catch Throwable t (throw t)))))) tap tap) + % := 1 + (swap! !state not) + % := [] + (swap! !state not) + % := 1))) + +(skip "Nested e/for with transfer" + (def !state (atom [1])) + (l/def state (e/watch !state)) + (with ((l/single {} (try (e/for [x (e/server state)] + (e/for [y (e/server state)] + (tap [x y]))) + (catch Cancelled _) + (catch Pending _))) tap tap) + % := [1 1] + (reset! !state [3]) + % := [3 3])) + +(skip + "Static call" + (with ((l/single {} (tap (Math/abs -1))) tap tap) + % := 1)) + +#?(:clj + (skip "Dot syntax works (clj only)" + (with ((l/single {} (tap (. Math abs -1))) tap tap) + % := 1))) + +(skip "Sequential destructuring" + (with ((l/single {} (tap (let [[x y & zs :as coll] [:a :b :c :d]] [x y zs coll]))) tap tap) + % := [:a :b '(:c :d) [:a :b :c :d]])) + +(skip "Associative destructuring" + (with ((l/single {} (tap (let [{:keys [a ns/b d] + :as m + :or {d 4}} + {:a 1, :ns/b 2 :c 3}] [a b d m]))) tap tap) + % := [1 2 4 {:a 1, :ns/b 2, :c 3}])) + +(skip "Associative destructuring with various keys" + (with ((l/single {} (tap (let [{:keys [a] + :ns/keys [b] + :syms [c] + :ns/syms [d] + :strs [e]} + {:a 1, :ns/b 2, 'c 3, 'ns/d 4, "e" 5}] + [a b c d e]))) tap tap) + % := [1 2 3 4 5])) + +(skip "fn destructuring" + (with ((l/single {} + (try + (tap (e/client ((fn [{:keys [a] ::keys [b]}] [::client a b]) {:a 1 ::b 2}))) + (tap (e/server ((fn [{:keys [a] ::keys [b]}] [::server a b]) {:a 1 ::b 2}))) + (catch Pending _))) tap tap)) + % := [::client 1 2] + % := [::server 1 2]) + +(skip + (def !xs (atom [false])) + (with + ((l/single {} + (tap (try (e/for [x (e/watch !xs)] + (assert x)) + (catch #?(:clj Error :cljs js/Error) _ :error)))) tap tap) + % := :error + (reset! !xs []) + % := [])) + +(skip "All Pending instances are equal" + (= (Pending.) (Pending.)) := true) + +(skip + "Failure instances are equal if the errors they convey are equal" + (= (Failure. (Pending.)) (Failure. (Pending.))) := true + + (let [err (ex-info "error" {})] + (= err err) := true + (= (Failure. err) (Failure. err)) := true + (= (ex-info "a" {}) (ex-info "a" {})) := false + (= (Failure. (ex-info "err" {})) (Failure. (ex-info "err" {}))) := false)) + +(skip ; temporary test because p/run does not serilize to transit. + "Electric transit layer serializes unserializable values to nil" + (electric-io/decode (electric-io/encode 1)) := 1 + (electric-io/decode (electric-io/encode (type 1))) := nil) + +;; HACK sequences cljs async tests. Symptomatic of an RCF issue. +;; Ticket: https://www.notion.so/hyperfiddle/cljs-test-suite-can-produce-false-failures-0b3799f6d2104d698eb6a956b6c51e48 +#?(:cljs (t/use-fixtures :each {:after #(t/async done (js/setTimeout done 1))})) + +(skip + (def !x (atom true)) + (with ((l/single {} + (try + (let [x (e/watch !x)] + ; check eager network does not beat the switch + (tap (if x (e/server [:server x]) [:client x]))) + (catch Pending _))) tap tap) + % := [:server true] + (swap! !x not) + ; the remote tap on the switch has been removed + % := [:client false])) + +(skip + (def !x (atom true)) + (l/def x (e/server (e/watch !x))) + (with ((l/single {} + (try + (if (e/server x) ; to be consistent, client should see x first and switch + (e/server (tap x)) ; but test shows that the server sees x change before client + (e/server x)) + (catch Pending _))) tap tap) + % := true + (swap! !x not) + % := false #_ ::rcf/timeout) + ; we have to choose: consistency or less latency? + ; current behavior - Dustin likes, Leo does not like + ) + +;; https://www.notion.so/hyperfiddle/distribution-glitch-stale-local-cache-of-remote-value-should-be-invalidated-pending-47f5e425d6cf43fd9a37981c9d80d2af +(skip "glitch - stale local cache of remote value should be invalidated/pending" + (def !x (atom 0)) + (def dispose ((l/single {} (tap (try (let [x (new (m/watch !x))] + ;; pending or both equal + [x (e/server x)]) + (catch Pending _ ::pending)))) tap tap)) + % := ::pending + % := [0 0] + (swap! !x inc) + % := ::pending + % := [1 1] + (dispose)) + +(comment + ; https://www.notion.so/hyperfiddle/p-fn-transfer-d43869c673574390b186ccb4df824b39 + ((l/single {} + (e/server + (let [Foo (e/fn [] (type 1))] + (tap (Foo.)) + (tap (e/client (Foo.)))))) tap tap) + % := "class java.lang.Long" + % := "class #object[Number]" + + ; implications - all ~e/fns~ neutral electric expressions are compiled for both peers, including + ; the parts that don't make sense, because you don't know in advance which peer will + ; run which function + + ; costs: + ; increases size of compiler artifacts + ; increases compile times + ) + +(skip + (with ((l/single {} (try (e/server + (let [foo 1] + (tap foo) + (tap (e/client foo)))) + (catch Pending _))) tap tap) + % := 1 + % := 1)) + +(skip "Today, bindings fail to transfer, resulting in unbound var exception. This will be fixed" + ; https://www.notion.so/hyperfiddle/photon-binding-transfer-unification-of-client-server-binding-7e56d9329d224433a1ee3057e96541d1 + (l/def foo) + (with ((l/single {} (try + (e/server + (binding [foo 1] + (tap foo) + (tap (e/client foo)))) + (catch Pending _) + (catch #?(:clj Error :cljs js/Error) e + (tap e)))) tap tap) + % := 1 + ; % := 1 -- target future behavior + (type %) := #?(:clj Error :cljs js/Error))) + +(skip "static method call" + (with ((l/single {} (tap (Math/max 2 1))) tap tap) + % := 2)) + +(skip "static method call in e/server" + (with ((l/single {} (try (tap (e/server (Math/max 2 1))) + (catch Pending _))) tap tap) + % := 2)) + +(skip "static method call in e/client" + (with ((l/single {} (try (tap (e/server (subvec (vec (range 10)) + (Math/min 1 1) + (Math/min 3 3)))) + (catch Pending _))) tap tap) + % := [1 2])) + +(skip "Inline cc/fn support" + (def !state (atom 0)) + (l/def global) + (with ((l/single {} (let [state (e/watch !state) + local [:local state] + f (binding [global [:global state]] + (fn ([a] [a local hyperfiddle.electric-test/global]) + ([a b] [a b local global]) + ([a b & cs] [a b cs local global])))] + (tap (f state)) + (tap (f state :b)) + (tap (f state :b :c :d)))) tap tap) + % := [0 [:local 0] [:global 0]] + % := [0 :b [:local 0] [:global 0]] + % := [0 :b '(:c :d) [:local 0] [:global 0]] + (swap! !state inc) + % := [1 [:local 1] [:global 1]] + % := [1 :b [:local 1] [:global 1]] + % := [1 :b '(:c :d) [:local 1] [:global 1]])) + +(skip "cc/fn lexical bindings are untouched" + (with ((l/single {} (let [a 1 + b 2 + f (fn [a] (let [b 3] [a b]))] + (tap (f 2)))) tap tap) + % := [2 3])) + +(skip "Inline cc/fn shorthand support" + (with ((l/single {} (tap (#(inc %) 1))) tap tap) + % := 2)) + +(skip "inline m/observe support" + (let [!state (atom 0)] + (with ((l/single {} (let [state (e/watch !state) + lifecycle (m/observe (fn [push] + (tap :up) + (push state) + #(tap :down))) + val (new lifecycle)] + (tap val))) tap tap) + % := :up + % := 0 + (swap! !state inc) + % := :down + % := :up + % := 1) + % := :down)) + +(skip "Inline letfn support" + (with ((l/single {} (tap (letfn [(descent [x] (cond (pos? x) (dec x) + (neg? x) (inc x) + :else x)) + (is-even? [x] (if (zero? x) true (is-odd? (descent x)))) + (is-odd? [x] (if (zero? x) false (is-even? (descent x))))] + (tap [(is-even? 0) (is-even? 1) (is-even? 2) (is-even? -2)]) + (tap [(is-odd? 0) (is-odd? 2) (is-odd? 3) (is-odd? -3)])))) tap tap) + % := [true false true true] + % := [false false true true] + % := [false false true true])) + +(skip + (with ((l/single {} (try (letfn [(foo [])] + (tap (e/watch (atom 1)))) + (catch Throwable t (prn t)))) tap tap) + % := 1)) + +(skip "Inline letfn support" + (def !state (atom 0)) + (l/def global) + (with ((l/single {} (let [state (e/watch !state) + local [:local state]] + (binding [global [:global state]] + (letfn [(f ([a] [a local hyperfiddle.electric-test/global]) + ([a b] [a b local global]) + ([a b & cs] [a b cs local global]))] + (tap (f state)) + (tap (f state :b)) + (tap (f state :b :c :d)))))) tap tap) + % := [0 [:local 0] [:global 0]] + % := [0 :b [:local 0] [:global 0]] + % := [0 :b '(:c :d) [:local 0] [:global 0]] + (swap! !state inc) + % := [1 [:local 1] [:global 1]] + % := [1 :b [:local 1] [:global 1]] + % := [1 :b '(:c :d) [:local 1] [:global 1]])) + +#?(:clj + (skip "e/fn is undefined in clojure-land" + (tap (try (lang/analyze {} `(fn [] (e/fn []))) (catch Throwable e (ex-message (ex-cause e))))) + % := "Electric code (hyperfiddle.electric/fn) inside a Clojure function")) + +#?(:clj + (skip "e/client is undefined in clojure-land" + (tap (try (lang/analyze {} `(fn [] (e/client []))) (catch Throwable e (ex-message (ex-cause e))))) + % := "Electric code (hyperfiddle.electric/client) inside a Clojure function")) + +#?(:clj + (skip "e/server is undefined in clojure-land" + (tap (try (lang/analyze {} `(fn [] (e/server []))) (catch Throwable e (ex-message (ex-cause e))))) + % := "Electric code (hyperfiddle.electric/server) inside a Clojure function")) + +#?(:clj + (skip "e/server is undefined in clojure-land" + (tap (try (lang/analyze {} `(fn [] (e/watch (atom :nomatter)))) (catch Throwable e (ex-message (ex-cause e))))) + % := "Electric code (hyperfiddle.electric/watch) inside a Clojure function")) + +(skip "cycle" + (with ((l/single {} + (let [!F (atom (e/fn [] 0))] + (tap (new (new (m/watch !F)))) + (let [y 1] (reset! !F (e/fn [] y))))) tap tap) + % := 0 + % := 1)) + +#?(:clj ; test broken in cljs, not sure why + (skip "loop/recur" + (l/defn fib [n] (loop [n n] (if (<= n 2) 1 (+ (recur (dec n)) (recur (- n 2)))))) + (with ((l/single {} (tap (e/for [i (range 1 11)] (fib. i)))) tap tap) + % := [1 1 2 3 5 8 13 21 34 55]))) + +;; currently broken https://www.notion.so/hyperfiddle/cr-macro-internal-mutation-violates-photon-purity-requirement-119c18755ddd466384beb15f1e2317c5 +#_ +(skip + "inline m/cp support" + (let [!state (atom 0)] + (with (p/run (let [state (p/watch !state)] + (tap (new (m/cp state))))) + % := 0 + (swap! !state inc) + % := 1)) + + "inline m/ap support" + (let [!state (atom [1])] + (with (p/run (let [coll (p/watch !state)] + (tap (new (m/ap (tap (m/?< (m/seed coll)))))))) + % := 1 + % := 1 + (swap! !state conj 2) + % := 1 + % := 2 + % := 2))) + +(skip "letfn body is electric" + (l/def z 3) + (def !x (atom 4)) + (with ((l/single {} (let [y 2] (letfn [(f [x] (g x)) (g [x] [x y z])] (tap (f (e/watch !x)))))) tap tap) + % := [4 2 3] + (swap! !x inc) + % := [5 2 3])) + +;; currently broken https://www.notion.so/hyperfiddle/cr-macro-internal-mutation-violates-photon-purity-requirement-119c18755ddd466384beb15f1e2317c5 +#_ +(skip + "inline m/sp support" + (let [!state (atom 0)] + (with (p/run (let [val (p/watch !state) + task (m/sp val)] + (tap (new (m/relieve {} (m/reductions {} :init (m/ap (m/? task)))))))) + % := 0 + (swap! !state inc) + % := 1 + ))) + +#?(:clj + (skip "set!" + (def !y (atom 8)) + (with ((l/single {} (let [pt (java.awt.Point. 1 2) + y (e/watch !y)] + (set! (.-y pt) y) + ;; calling (.-y pt) doesn't work, it's deduped + (tap [y pt]))) tap tap) + % := [8 (java.awt.Point. 1 8)] + (swap! !y inc) + % := [9 (java.awt.Point. 1 9)]))) + +#?(:cljs + (do-browser + (skip "set!" + ;; https://www.notion.so/hyperfiddle/RCF-implicit-do-rewrite-rule-does-not-account-for-let-bindings-61b1ad82771c407198c1f678683bf443 + (defn bypass-rcf-bug [[href a]] [href (str/replace (.-href a) #".*/" "")]) + (def !href (atom "href1")) + (with ((l/single {} (let [a (.createElement js/document "a") + href (e/watch !href)] + (set! (.-href a) href) + (tap [href a]))) tap tap) + (bypass-rcf-bug %) := ["href1" "href1"] + (reset! !href "href2") + (bypass-rcf-bug %) := ["href2" "href2"])))) + +#?(:clj (skip "set! with electric value" + (with ((l/single {} (tap (let [pt (java.awt.Point. 1 2)] + (set! (.-y pt) (new (e/fn [] 0)))))) tap tap) + % := 0))) + +#?(:cljs (skip "set! with electric value" + (with ((l/single {} (tap (let [o (js/Object.)] + (set! (.-x o) (new (e/fn [] 0)))))) tap tap) + % := 0))) + +(skip "e/fn arity check" + (with ((l/single {} (try (new (e/fn [x y z] (throw (ex-info "nope" {}))) 100 200 300 400) + (catch ExceptionInfo e (tap e)) + (catch Cancelled _) + (catch Throwable t (prn t)))) tap tap) + (ex-message %) := "You called with 4 arguments but it only supports 3")) ;; (l/defn ThreeThrow [_ _ _] (throw (ex-info "nope"))) -;; (tests "e/fn arity check" -;; (with ((l/single {} (try (new ThreeThrow 100 200 300 400) -;; (catch ExceptionInfo e (tap e)) -;; (catch Cancelled _) -;; (catch Throwable t (prn t)))) tap tap) -;; (ex-message %) := "You called ThreeThrow with 4 arguments but it only supports 3")) - -;; (tests "e/fn arity check" -;; (with ((l/single {} (try (new (e/fn Named [x y] (throw (ex-info "nope" {}))) 100) -;; (catch ExceptionInfo e (tap e)) -;; (catch Cancelled _) -;; (catch Throwable t (prn t)))) tap tap) -;; (ex-message %) := "You called Named with 1 argument but it only supports 2")) - -;; (tests "Partial application" -;; (with ((l/single {} -;; (tap (new (e/partial 0 (e/fn [] :a)) )) -;; (tap (new (e/partial 1 (e/fn [a] a) :a))) -;; (tap (new (e/partial 2 (e/fn [a b] [a b]) :a) :b)) -;; (tap (new (e/partial 4 (e/fn [a b c d] [a b c d]) :a :b) :c :d))) tap tap) -;; % := :a -;; % := :a -;; % := [:a :b] -;; % := [:a :b :c :d])) +(skip "e/fn arity check" + (with ((l/single {} (try (new ThreeThrow 100 200 300 400) + (catch ExceptionInfo e (tap e)) + (catch Cancelled _) + (catch Throwable t (prn t)))) tap tap) + (ex-message %) := "You called ThreeThrow with 4 arguments but it only supports 3")) + +(skip "e/fn arity check" + (with ((l/single {} (try (new (e/fn Named [x y] (throw (ex-info "nope" {}))) 100) + (catch ExceptionInfo e (tap e)) + (catch Cancelled _) + (catch Throwable t (prn t)))) tap tap) + (ex-message %) := "You called Named with 1 argument but it only supports 2")) + +(skip "Partial application" + (with ((l/single {} + (tap (new (e/partial 0 (e/fn [] :a)) )) + (tap (new (e/partial 1 (e/fn [a] a) :a))) + (tap (new (e/partial 2 (e/fn [a b] [a b]) :a) :b)) + (tap (new (e/partial 4 (e/fn [a b c d] [a b c d]) :a :b) :c :d))) tap tap) + % := :a + % := :a + % := [:a :b] + % := [:a :b :c :d])) ;; (l/def Factorial-gen (e/fn [Rec] ;; (e/fn [n] @@ -1377,678 +1442,678 @@ ;; (e/fn [x] (new x x)) ;; (e/fn [x] (new f (e/fn [y] (new (new x x) y))))))) -;; (tests "Y-Combinator" -;; (let [!n (atom 5)] -;; (with ((l/single {} (tap (new (Y. Factorial-gen) (e/watch !n)))) tap tap) -;; % := 120 -;; (reset! !n 20) -;; % := 2432902008176640000))) - -;; (tests "clojure def inside electric code" -;; (def !x (atom 0)) -;; (with ((l/single {} (def --foo (tap (e/watch !x)))) tap tap) -;; % := 0, --foo := 0 -;; (swap! !x inc) % := 1, --foo := 1)) - -;; (tests "catch handlers are work skipped" -;; (def !x (atom 0)) -;; (with ((l/single {} (try (e/watch !x) -;; (throw (ex-info "hy" {})) -;; (catch ExceptionInfo e (tap e)) -;; (catch Cancelled _ (tap :cancelled)))) tap tap) -;; (ex-message %) := "hy" ; exception tapped by `ExceptionInfo` catch block -;; (swap! !x inc)) ; same exception, so work skipped -;; % := :cancelled) - -;; (tests "pendings don't enter cc/fn's" -;; (with ((l/single {} (try (let [v (new (m/observe (fn [!] (! r/pending) (def ! !) #(do))))] -;; (#(tap [:v %]) v)) -;; (catch Pending _ (tap :pending)) -;; (catch #?(:clj Throwable :cljs :default) e (prn [(type e) (ex-message e)])))) tap tap) -;; % := :pending -;; (! 1) -;; % := [:v 1])) - -;; (tests "catch code reacts to changes" -;; (def !x (atom 0)) -;; (with ((l/single {} (tap (try (throw (ex-info "boom" {})) -;; (catch Throwable _ (e/watch !x))))) tap tap) -;; % := 0 -;; (swap! !x inc) -;; % := 1)) - -;; (tests "Electric dynamic scope is available in cc/fn" -;; (l/def ^:dynamic dynfoo 1) -;; (with ((l/single {} -;; (try -;; ((fn [] -;; (tap dynfoo))) -;; (binding [dynfoo 2] -;; ((fn [] (tap dynfoo)))) -;; (catch #?(:clj Throwable, :cljs js/Error) t (prn t)))) tap tap) -;; % := 1 -;; % := 2)) - -;; #?(:clj ; fail to compile in cljs: `Can't set! local var or non-mutable field` (foo177584 is not dynamic) -;; (tests "l/def are not dynamic by default in cc/fn" -;; (l/def foo177584 1) -;; (with ((l/single {} -;; (try -;; ((fn [] (binding [foo177584 2] (tap foo177584)))) ; foo177584 is not ^:dynamic -;; (catch #?(:clj Throwable, :cljs js/Error) t (tap (ex-message t))))) tap tap) -;; % := "Can't dynamically bind non-dynamic var: hyperfiddle.electric-test/foo177584"))) - -;; (tests "Injecting an l/def binding in cc/fn respects dynamic scope rules" -;; (l/def ^:dynamic dynfoo 1) -;; (with ((l/single {} -;; (try -;; (tap dynfoo) ; electric dynamic context -;; (binding [dynfoo 2] ; rebound in electic context -;; ((fn [] -;; (tap dynfoo) ; injected dynamic context -;; (binding [dynfoo 3] ; rebound in clojure context -;; (tap dynfoo) ; read clojure context -;; ))) -;; (tap dynfoo)) ; cc/fn scope doesn't alter electric scope -;; (catch #?(:clj Throwable, :cljs js/Error) t (prn t)))) tap tap) -;; % := 1 -;; % := 2 -;; % := 3 -;; % := 2)) - -;; (tests "In Clojure, unqualified names first resolves to lexical scope" -;; (def ^:dynamic foo 1) -;; foo := 1 ; no lexical binding shadowing -> resolve to foo var -;; (let [foo 2] ; lexical shadowing -;; foo := 2 ; resolve to lexical scope -;; (binding [#?(:clj foo, :cljs hyperfiddle.electric-test/foo) 3] ; always rebind var in clojure. Cljs requires fully qualified name. -;; foo := 2 ; unqualified name resolves to lexical scope -;; hyperfiddle.electric-test/foo := 3))) ; qualified name resolves to the var - -;; #?(:clj -;; (tests "cc/fn args shadow l/def injections" -;; (l/def ^:dynamic dynfoo 1) -;; (with ((l/single {} -;; (try -;; (tap dynfoo) ; electric dynamic context -;; ((fn [dynfoo] ; dynvar shadowed by argument -;; (tap dynfoo) -;; (binding [dynfoo 2] ; rebinds the vars -;; (tap dynfoo) ; still resolves to argument in lexical scope -;; (tap hyperfiddle.electric-test/dynfoo))) -;; :argument) -;; (catch #?(:clj Throwable, :cljs js/Error) t (prn t)))) tap tap) -;; % := 1 -;; % := :argument -;; % := :argument -;; % := 2))) - -;; #?(:clj -;; (tests "Injected lexical scope respects precedence over injected dynamic scope" -;; (l/def ^:dynamic dynfoo 1) -;; (with ((l/single {} -;; (try -;; (tap dynfoo) -;; (let [dynfoo :shadowed] -;; ((fn [] -;; (tap dynfoo) -;; (binding [dynfoo 2] -;; (tap dynfoo) -;; (tap hyperfiddle.electric-test/dynfoo))) -;; )) -;; (catch #?(:clj Throwable, :cljs js/Error) t (prn t)))) tap tap) -;; % := 1 -;; % := :shadowed -;; % := :shadowed -;; % := 2))) - -;; #?(:clj -;; (tests "Shadowing injected dynamic scope in cc context respects clojure shadowing rules" -;; (l/def ^:dynamic dynfoo 1) -;; (with ((l/single {} -;; (try -;; (tap dynfoo) -;; ((fn [] -;; (tap dynfoo) -;; (let [dynfoo :shadowed] -;; (tap dynfoo) -;; (binding [dynfoo 2] -;; (tap dynfoo) -;; (tap hyperfiddle.electric-test/dynfoo))))) -;; (catch #?(:clj Throwable, :cljs js/Error) t (prn t)))) tap tap) -;; % := 1 -;; % := 1 -;; % := :shadowed -;; % := :shadowed -;; % := 2))) - -;; (tests "snapshot" -;; (def flow (e/-snapshot (m/observe (fn [!] (def ! !) #())))) -;; "1 2 -> 1" -;; (def it (flow #(tap :notified) #(tap :terminated))) -;; (! 1), % := :notified, @it := 1 -;; (! 2) -;; (it), % := :terminated -;; "Pending 1 2 -> Pending 1" -;; (def it (flow #(tap :notified) #(tap :terminated))) -;; (! r/pending), % := :notified, @it := r/pending -;; (! 1), % := :notified, @it := 1 -;; (! 2) -;; (it), % := :terminated -;; "Pending Pending 1 2 -> Pending Pending 1" -;; (def it (flow #(tap :notified) #(tap :terminated))) -;; (! r/pending), % := :notified, @it := r/pending -;; (! r/pending), % := :notified, @it := r/pending -;; (! 1), % := :notified, @it := 1 -;; (! 2) -;; (it), % := :terminated -;; "ex-info 1 2 -> ex-info" -;; (def it (flow #(tap :notified) #(tap :terminated))) -;; (def boom (Failure. (ex-info "boom" {}))) -;; (! boom), % := :notified, @it := boom -;; (! 1) -;; (! 2) -;; (it), % := :terminated -;; "1 Pending 2 -> 1" -;; (def it (flow #(tap :notified) #(tap :terminated))) -;; (! 1), % := :notified, @it := 1 -;; (! r/pending) -;; (! 2) -;; (it), % := :terminated -;; "Pending ex-info 1 -> Pending ex-info" -;; (def it (flow #(tap :notified) #(tap :terminated))) -;; (def boom (Failure. (ex-info "boom" {}))) -;; (! r/pending), % := :notified, @it := r/pending -;; (! boom), % := :notified, @it := boom -;; (! 1) -;; (it), % := :terminated - -;; (tap ::done), % := ::done, (println " ok")) - -;; (tests "for-event" -;; (def ! (atom nil)) -;; (def !resolvers (atom {})) -;; (defn !! [k v] (reset! (@!resolvers k) v)) -;; (with ((l/single {} (tap (try (e/for-event [e (m/observe (fn [!!] (reset! ! !!) #(do)))] -;; (let [!v (atom :pending)] -;; (swap! !resolvers assoc e !v) -;; (try (let [v (e/watch !v)] -;; (case v -;; :pending (throw (Pending.)) -;; :caught (throw (ex-info "caught" {})) -;; :uncaught (throw (ex-info "uncaught" {})) -;; #_else v)) -;; (catch Pending _ :pending) -;; (catch #?(:clj Throwable :cljs :default) e -;; (case (ex-message e) -;; "caught" (reduced nil) -;; #_else (throw e)))))) -;; (catch #?(:clj Throwable :cljs :default) e [(type e) (ex-message e)])))) tap tap) -;; #_init % := [] -;; (@! 0), % := [:pending] -;; (@! 1), % := [:pending :pending] -;; (!! 1 (reduced nil)), % := [:pending nil], % := [:pending] -;; (!! 0 (reduced true)), % := [nil], % := [] -;; (@! 2), % := [:pending] -;; (!! 2 :caught), % := [nil], % := [] -;; (@! 99), % := [:pending] -;; (!! 99 :uncaught), % := [ExceptionInfo "uncaught"] -;; (!! 99 :alive), % := [:alive] -;; (!! 99 (reduced nil)), % := [nil], % := [])) - -;; (tests "for-event-pending" -;; (def ! (atom nil)) -;; (def !resolvers (atom {})) -;; (defn !! [k v] (reset! (@!resolvers k) v)) -;; (def fail (ex-info "i fail" {})) -;; (with ((l/single {} (tap (e/for-event-pending [e (m/observe (fn [!!] (reset! ! !!) #(do)))] -;; (let [!v (atom :pending)] -;; (swap! !resolvers assoc e !v) -;; (let [v (e/watch !v)] -;; (case v -;; :pending (throw (Pending.)) -;; :fail (throw fail) -;; #_else v)))))) tap tap) -;; #_init % := [::e/init] -;; (@! 0), % := [::e/pending e/pending] -;; (@! 1) ;; work skipped -;; (!! 1 nil) ;; work skipped, 0 still pending -;; (!! 0 false) % := [::e/ok false] -;; (@! 2), % := [::e/pending e/pending] -;; (!! 2 :fail), % := [::e/failed fail])) - -;; (tests "for-event-pending-switch" -;; (def ! (atom nil)) -;; (def !resolvers (atom {})) -;; (defn !! [k v] (reset! (@!resolvers k) v)) -;; (def fail (ex-info "i fail" {})) -;; (with ((l/single {} (tap (e/for-event-pending-switch [e (m/observe (fn [!!] (reset! ! !!) #(do)))] -;; (let [!v (atom :pending)] -;; (swap! !resolvers assoc e !v) -;; (e/on-unmount #(tap [:unmounted e])) -;; (let [v (e/watch !v)] -;; (case v -;; :pending (throw (Pending.)) -;; :fail (throw fail) -;; #_else v)))))) tap tap) - -;; #_init % := [::e/init] -;; (@! 0), % := [::e/pending e/pending] -;; (@! 1), % := [:unmounted 0] -;; (@! 2), % := [:unmounted 1] -;; (!! 2 nil), % := [:unmounted 2], % := [::e/ok nil] -;; (@! 3), % := [::e/pending e/pending] -;; (!! 3 :fail), % := [:unmounted 3], % := [::e/failed fail])) - -;; (tests "do-event" -;; (def ! (atom nil)) -;; (def !resolvers (atom {})) -;; (defn !! [k v] (reset! (@!resolvers k) v)) -;; (with ((l/single {} (tap (try (e/do-event [e (m/observe (fn [!!] (reset! ! !!) #(do)))] -;; (tap [:mount e]) -;; (let [!v (atom :pending)] -;; (swap! !resolvers assoc e !v) -;; (try (let [v (e/watch !v)] -;; (case v -;; :pending (throw (Pending.)) -;; :caught (throw (ex-info "caught" {})) -;; :uncaught (throw (ex-info "uncaught" {})) -;; #_else v)) -;; (catch Pending _ :pending) -;; (catch #?(:clj Throwable :cljs :default) e -;; (case (ex-message e) -;; "caught" (reduced nil) -;; #_else (throw e)))))) -;; (catch #?(:clj Throwable :cljs :default) e [(type e) (ex-message e)])))) tap tap) -;; #_init % := nil -;; (@! 0), % := [:mount 0], % := :pending -;; (@! 1) ; skipped, previous still running -;; (!! 0 (reduced false)), % := nil -;; (@! 2), % := [:mount 2], % := :pending -;; (!! 2 :caught), % := nil -;; (@! 9), % := [:mount 9], % := :pending -;; (!! 9 :uncaught), % := [ExceptionInfo "uncaught"] -;; (!! 9 :alive), % := :alive -;; (!! 9 (reduced true)), % := nil)) - -;; (tests "do-event-pending" -;; (def ! (atom nil)) -;; (def !resolvers (atom {})) -;; (defn !! [k v] (reset! (@!resolvers k) v)) -;; (def fail (ex-info "i fail" {})) -;; (with ((l/single {} (tap (e/do-event-pending [e (m/observe (fn [!!] (reset! ! !!) #(do)))] -;; (tap [:mount e]) -;; (let [!v (atom :pending)] -;; (swap! !resolvers assoc e !v) -;; (let [v (e/watch !v)] -;; (case v -;; :pending (throw (Pending.)) -;; :fail (throw fail) -;; #_else v)))))) tap tap) -;; #_init % := [::e/init] -;; (@! 0), % := [:mount 0], % := [::e/pending e/pending] -;; (@! 1) ;; skipped -;; (!! 0 false) % := [::e/ok false] -;; (@! 2), % := [:mount 2], % := [::e/pending e/pending] -;; (!! 2 :fail), % := [::e/failed fail])) - -;; #?(:clj -;; (tests "e/offload starts Pending" -;; (def dfv (m/dfv)) -;; (with ((l/single {} (tap (try (e/offload #(m/? dfv)) -;; (catch Pending ex ex) -;; (catch Throwable ex (prn ex))))) tap tap) -;; % := e/pending -;; (dfv 1) -;; % := 1))) - -;; #?(:clj -;; (tests "e/offload doesn't throw Pending subsequently" -;; (def !dfv (atom (m/dfv))) -;; (with ((l/single {} (tap (try (let [dfv (e/watch !dfv)] -;; (e/offload #(m/? dfv))) -;; (catch Pending ex ex) -;; (catch Throwable ex (prn ex))))) tap tap) -;; % := e/pending -;; (@!dfv 1) -;; % := 1 -;; (reset! !dfv (m/dfv)) -;; (@!dfv 2) -;; % := 2))) - -;; #?(:clj -;; (tests "e/offload on overlap uses latest value and discards previous" -;; (def d1 (m/dfv)) -;; (def !dfv (atom d1)) -;; (with ((l/single {} (try (let [dfv (e/watch !dfv)] -;; (tap (e/offload #(m/? dfv)))) -;; (catch Pending _) -;; (catch Throwable ex (prn [(type ex) (ex-message ex)])))) tap tap) - -;; (def d2 (reset! !dfv (m/dfv))) -;; (d2 2) -;; % := 2 -;; (d1 1)))) - -;; #?(:clj -;; (tests "e/offload thunk is running on another thread" -;; (defn get-thread [] (Thread/currentThread)) -;; (with ((l/single {} (try (tap (e/offload get-thread)) -;; (catch Pending _) -;; (catch Throwable ex (prn ex)))) tap tap) -;; (count (hash-set % (get-thread))) := 2))) - -;; #?(:cljs -;; (do-browser -;; (tests "goog module calls don't trigger warnings" -;; ;; this includes a goog test namespace, so if there are warnings the CI will blow up. -;; ;; The blow up is configured as a shadow build hook in `hyperfiddle.browser-test-setup` -;; (with ((l/single {} (tap (try (hyperfiddle.goog-calls-test/Main.) :ok -;; (catch :default ex (ex-message ex))))) tap tap) -;; % := :ok)))) - -;; (tests -;; (with ((l/single {} (tap (try (new nil) (catch #?(:clj Throwable :cljs :default) e e)))) tap tap) -;; (ex-message %) := "called `new` on nil")) - -;; (tests -;; (with ((l/single {} (tap (try (e/watch :foo) (throw (ex-info "nope" {})) -;; (catch ExceptionInfo e e)))) tap tap) -;; (str/includes? (ex-message %) ":foo") := true)) - -;; (tests "l/def initialized to `nil` works in cc/fn" -;; (l/def foo nil) -;; (with ((l/single {} (binding [foo "foo"] (let [f foo] (#(tap [f foo]))))) tap tap) -;; % := ["foo" "foo"])) - -;; (tests "e/fn varargs" -;; (with ((l/single+ {} (new (e/fn [x & xs] (tap [x xs])) 1 2 3 4)) tap tap) -;; % := [1 [2 3 4]])) -;; (tests "e/fn varargs recursion with recur" -;; (with ((l/single+ {} (new (e/fn [x & xs] (tap [x xs])) 1 2 3 4)) tap tap) -;; % := [1 [2 3 4]])) -;; (tests "e/fn varargs recur is arity-checked" -;; (with ((l/single+ {} (tap (try (new (e/fn [x & xs] (recur)) 1 2 3) -;; (catch ExceptionInfo e e)))) tap tap) -;; (ex-message %) := "You `recur`d in with 0 arguments but it has 2 positional arguments")) +(skip "Y-Combinator" + (let [!n (atom 5)] + (with ((l/single {} (tap (new (Y. Factorial-gen) (e/watch !n)))) tap tap) + % := 120 + (reset! !n 20) + % := 2432902008176640000))) + +(skip "clojure def inside electric code" + (def !x (atom 0)) + (with ((l/single {} (def --foo (tap (e/watch !x)))) tap tap) + % := 0, --foo := 0 + (swap! !x inc) % := 1, --foo := 1)) + +(skip "catch handlers are work skipped" + (def !x (atom 0)) + (with ((l/single {} (try (e/watch !x) + (throw (ex-info "hy" {})) + (catch ExceptionInfo e (tap e)) + (catch Cancelled _ (tap :cancelled)))) tap tap) + (ex-message %) := "hy" ; exception tapped by `ExceptionInfo` catch block + (swap! !x inc)) ; same exception, so work skipped + % := :cancelled) + +(skip "pendings don't enter cc/fn's" + (with ((l/single {} (try (let [v (new (m/observe (fn [!] (! r/pending) (def ! !) #(do))))] + (#(tap [:v %]) v)) + (catch Pending _ (tap :pending)) + (catch #?(:clj Throwable :cljs :default) e (prn [(type e) (ex-message e)])))) tap tap) + % := :pending + (! 1) + % := [:v 1])) + +(skip "catch code reacts to changes" + (def !x (atom 0)) + (with ((l/single {} (tap (try (throw (ex-info "boom" {})) + (catch Throwable _ (e/watch !x))))) tap tap) + % := 0 + (swap! !x inc) + % := 1)) + +(skip "Electric dynamic scope is available in cc/fn" + (l/def ^:dynamic dynfoo 1) + (with ((l/single {} + (try + ((fn [] + (tap dynfoo))) + (binding [dynfoo 2] + ((fn [] (tap dynfoo)))) + (catch #?(:clj Throwable, :cljs js/Error) t (prn t)))) tap tap) + % := 1 + % := 2)) + +#?(:clj ; fail to compile in cljs: `Can't set! local var or non-mutable field` (foo177584 is not dynamic) + (skip "l/def are not dynamic by default in cc/fn" + (l/def foo177584 1) + (with ((l/single {} + (try + ((fn [] (binding [foo177584 2] (tap foo177584)))) ; foo177584 is not ^:dynamic + (catch #?(:clj Throwable, :cljs js/Error) t (tap (ex-message t))))) tap tap) + % := "Can't dynamically bind non-dynamic var: hyperfiddle.electric-test/foo177584"))) + +(skip "Injecting an l/def binding in cc/fn respects dynamic scope rules" + (l/def ^:dynamic dynfoo 1) + (with ((l/single {} + (try + (tap dynfoo) ; electric dynamic context + (binding [dynfoo 2] ; rebound in electic context + ((fn [] + (tap dynfoo) ; injected dynamic context + (binding [dynfoo 3] ; rebound in clojure context + (tap dynfoo) ; read clojure context + ))) + (tap dynfoo)) ; cc/fn scope doesn't alter electric scope + (catch #?(:clj Throwable, :cljs js/Error) t (prn t)))) tap tap) + % := 1 + % := 2 + % := 3 + % := 2)) + +(skip "In Clojure, unqualified names first resolves to lexical scope" + (def ^:dynamic foo 1) + foo := 1 ; no lexical binding shadowing -> resolve to foo var + (let [foo 2] ; lexical shadowing + foo := 2 ; resolve to lexical scope + (binding [#?(:clj foo, :cljs hyperfiddle.electric-test/foo) 3] ; always rebind var in clojure. Cljs requires fully qualified name. + foo := 2 ; unqualified name resolves to lexical scope + hyperfiddle.electric-test/foo := 3))) ; qualified name resolves to the var + +#?(:clj + (skip "cc/fn args shadow l/def injections" + (l/def ^:dynamic dynfoo 1) + (with ((l/single {} + (try + (tap dynfoo) ; electric dynamic context + ((fn [dynfoo] ; dynvar shadowed by argument + (tap dynfoo) + (binding [dynfoo 2] ; rebinds the vars + (tap dynfoo) ; still resolves to argument in lexical scope + (tap hyperfiddle.electric-test/dynfoo))) + :argument) + (catch #?(:clj Throwable, :cljs js/Error) t (prn t)))) tap tap) + % := 1 + % := :argument + % := :argument + % := 2))) + +#?(:clj + (skip "Injected lexical scope respects precedence over injected dynamic scope" + (l/def ^:dynamic dynfoo 1) + (with ((l/single {} + (try + (tap dynfoo) + (let [dynfoo :shadowed] + ((fn [] + (tap dynfoo) + (binding [dynfoo 2] + (tap dynfoo) + (tap hyperfiddle.electric-test/dynfoo))) + )) + (catch #?(:clj Throwable, :cljs js/Error) t (prn t)))) tap tap) + % := 1 + % := :shadowed + % := :shadowed + % := 2))) + +#?(:clj + (skip "Shadowing injected dynamic scope in cc context respects clojure shadowing rules" + (l/def ^:dynamic dynfoo 1) + (with ((l/single {} + (try + (tap dynfoo) + ((fn [] + (tap dynfoo) + (let [dynfoo :shadowed] + (tap dynfoo) + (binding [dynfoo 2] + (tap dynfoo) + (tap hyperfiddle.electric-test/dynfoo))))) + (catch #?(:clj Throwable, :cljs js/Error) t (prn t)))) tap tap) + % := 1 + % := 1 + % := :shadowed + % := :shadowed + % := 2))) + +(skip "snapshot" + (def flow (e/-snapshot (m/observe (fn [!] (def ! !) #())))) + "1 2 -> 1" + (def it (flow #(tap :notified) #(tap :terminated))) + (! 1), % := :notified, @it := 1 + (! 2) + (it), % := :terminated + "Pending 1 2 -> Pending 1" + (def it (flow #(tap :notified) #(tap :terminated))) + (! r/pending), % := :notified, @it := r/pending + (! 1), % := :notified, @it := 1 + (! 2) + (it), % := :terminated + "Pending Pending 1 2 -> Pending Pending 1" + (def it (flow #(tap :notified) #(tap :terminated))) + (! r/pending), % := :notified, @it := r/pending + (! r/pending), % := :notified, @it := r/pending + (! 1), % := :notified, @it := 1 + (! 2) + (it), % := :terminated + "ex-info 1 2 -> ex-info" + (def it (flow #(tap :notified) #(tap :terminated))) + (def boom (Failure. (ex-info "boom" {}))) + (! boom), % := :notified, @it := boom + (! 1) + (! 2) + (it), % := :terminated + "1 Pending 2 -> 1" + (def it (flow #(tap :notified) #(tap :terminated))) + (! 1), % := :notified, @it := 1 + (! r/pending) + (! 2) + (it), % := :terminated + "Pending ex-info 1 -> Pending ex-info" + (def it (flow #(tap :notified) #(tap :terminated))) + (def boom (Failure. (ex-info "boom" {}))) + (! r/pending), % := :notified, @it := r/pending + (! boom), % := :notified, @it := boom + (! 1) + (it), % := :terminated + + (tap ::done), % := ::done, (println " ok")) + +(skip "for-event" + (def ! (atom nil)) + (def !resolvers (atom {})) + (defn !! [k v] (reset! (@!resolvers k) v)) + (with ((l/single {} (tap (try (e/for-event [e (m/observe (fn [!!] (reset! ! !!) #(do)))] + (let [!v (atom :pending)] + (swap! !resolvers assoc e !v) + (try (let [v (e/watch !v)] + (case v + :pending (throw (Pending.)) + :caught (throw (ex-info "caught" {})) + :uncaught (throw (ex-info "uncaught" {})) + #_else v)) + (catch Pending _ :pending) + (catch #?(:clj Throwable :cljs :default) e + (case (ex-message e) + "caught" (reduced nil) + #_else (throw e)))))) + (catch #?(:clj Throwable :cljs :default) e [(type e) (ex-message e)])))) tap tap) + #_init % := [] + (@! 0), % := [:pending] + (@! 1), % := [:pending :pending] + (!! 1 (reduced nil)), % := [:pending nil], % := [:pending] + (!! 0 (reduced true)), % := [nil], % := [] + (@! 2), % := [:pending] + (!! 2 :caught), % := [nil], % := [] + (@! 99), % := [:pending] + (!! 99 :uncaught), % := [ExceptionInfo "uncaught"] + (!! 99 :alive), % := [:alive] + (!! 99 (reduced nil)), % := [nil], % := [])) + +(skip "for-event-pending" + (def ! (atom nil)) + (def !resolvers (atom {})) + (defn !! [k v] (reset! (@!resolvers k) v)) + (def fail (ex-info "i fail" {})) + (with ((l/single {} (tap (e/for-event-pending [e (m/observe (fn [!!] (reset! ! !!) #(do)))] + (let [!v (atom :pending)] + (swap! !resolvers assoc e !v) + (let [v (e/watch !v)] + (case v + :pending (throw (Pending.)) + :fail (throw fail) + #_else v)))))) tap tap) + #_init % := [::e/init] + (@! 0), % := [::e/pending e/pending] + (@! 1) ;; work skipped + (!! 1 nil) ;; work skipped, 0 still pending + (!! 0 false) % := [::e/ok false] + (@! 2), % := [::e/pending e/pending] + (!! 2 :fail), % := [::e/failed fail])) + +(skip "for-event-pending-switch" + (def ! (atom nil)) + (def !resolvers (atom {})) + (defn !! [k v] (reset! (@!resolvers k) v)) + (def fail (ex-info "i fail" {})) + (with ((l/single {} (tap (e/for-event-pending-switch [e (m/observe (fn [!!] (reset! ! !!) #(do)))] + (let [!v (atom :pending)] + (swap! !resolvers assoc e !v) + (e/on-unmount #(tap [:unmounted e])) + (let [v (e/watch !v)] + (case v + :pending (throw (Pending.)) + :fail (throw fail) + #_else v)))))) tap tap) + + #_init % := [::e/init] + (@! 0), % := [::e/pending e/pending] + (@! 1), % := [:unmounted 0] + (@! 2), % := [:unmounted 1] + (!! 2 nil), % := [:unmounted 2], % := [::e/ok nil] + (@! 3), % := [::e/pending e/pending] + (!! 3 :fail), % := [:unmounted 3], % := [::e/failed fail])) + +(skip "do-event" + (def ! (atom nil)) + (def !resolvers (atom {})) + (defn !! [k v] (reset! (@!resolvers k) v)) + (with ((l/single {} (tap (try (e/do-event [e (m/observe (fn [!!] (reset! ! !!) #(do)))] + (tap [:mount e]) + (let [!v (atom :pending)] + (swap! !resolvers assoc e !v) + (try (let [v (e/watch !v)] + (case v + :pending (throw (Pending.)) + :caught (throw (ex-info "caught" {})) + :uncaught (throw (ex-info "uncaught" {})) + #_else v)) + (catch Pending _ :pending) + (catch #?(:clj Throwable :cljs :default) e + (case (ex-message e) + "caught" (reduced nil) + #_else (throw e)))))) + (catch #?(:clj Throwable :cljs :default) e [(type e) (ex-message e)])))) tap tap) + #_init % := nil + (@! 0), % := [:mount 0], % := :pending + (@! 1) ; skipped, previous still running + (!! 0 (reduced false)), % := nil + (@! 2), % := [:mount 2], % := :pending + (!! 2 :caught), % := nil + (@! 9), % := [:mount 9], % := :pending + (!! 9 :uncaught), % := [ExceptionInfo "uncaught"] + (!! 9 :alive), % := :alive + (!! 9 (reduced true)), % := nil)) + +(skip "do-event-pending" + (def ! (atom nil)) + (def !resolvers (atom {})) + (defn !! [k v] (reset! (@!resolvers k) v)) + (def fail (ex-info "i fail" {})) + (with ((l/single {} (tap (e/do-event-pending [e (m/observe (fn [!!] (reset! ! !!) #(do)))] + (tap [:mount e]) + (let [!v (atom :pending)] + (swap! !resolvers assoc e !v) + (let [v (e/watch !v)] + (case v + :pending (throw (Pending.)) + :fail (throw fail) + #_else v)))))) tap tap) + #_init % := [::e/init] + (@! 0), % := [:mount 0], % := [::e/pending e/pending] + (@! 1) ;; skipped + (!! 0 false) % := [::e/ok false] + (@! 2), % := [:mount 2], % := [::e/pending e/pending] + (!! 2 :fail), % := [::e/failed fail])) + +#?(:clj + (skip "e/offload starts Pending" + (def dfv (m/dfv)) + (with ((l/single {} (tap (try (e/offload #(m/? dfv)) + (catch Pending ex ex) + (catch Throwable ex (prn ex))))) tap tap) + % := e/pending + (dfv 1) + % := 1))) + +#?(:clj + (skip "e/offload doesn't throw Pending subsequently" + (def !dfv (atom (m/dfv))) + (with ((l/single {} (tap (try (let [dfv (e/watch !dfv)] + (e/offload #(m/? dfv))) + (catch Pending ex ex) + (catch Throwable ex (prn ex))))) tap tap) + % := e/pending + (@!dfv 1) + % := 1 + (reset! !dfv (m/dfv)) + (@!dfv 2) + % := 2))) + +#?(:clj + (skip "e/offload on overlap uses latest value and discards previous" + (def d1 (m/dfv)) + (def !dfv (atom d1)) + (with ((l/single {} (try (let [dfv (e/watch !dfv)] + (tap (e/offload #(m/? dfv)))) + (catch Pending _) + (catch Throwable ex (prn [(type ex) (ex-message ex)])))) tap tap) + + (def d2 (reset! !dfv (m/dfv))) + (d2 2) + % := 2 + (d1 1)))) + +#?(:clj + (skip "e/offload thunk is running on another thread" + (defn get-thread [] (Thread/currentThread)) + (with ((l/single {} (try (tap (e/offload get-thread)) + (catch Pending _) + (catch Throwable ex (prn ex)))) tap tap) + (count (hash-set % (get-thread))) := 2))) + +#?(:cljs + (do-browser + (skip "goog module calls don't trigger warnings" + ;; this includes a goog test namespace, so if there are warnings the CI will blow up. + ;; The blow up is configured as a shadow build hook in `hyperfiddle.browser-test-setup` + (with ((l/single {} (tap (try (hyperfiddle.goog-calls-test/Main.) :ok + (catch :default ex (ex-message ex))))) tap tap) + % := :ok)))) + +(skip + (with ((l/single {} (tap (try (new nil) (catch #?(:clj Throwable :cljs :default) e e)))) tap tap) + (ex-message %) := "called `new` on nil")) + +(skip + (with ((l/single {} (tap (try (e/watch :foo) (throw (ex-info "nope" {})) + (catch ExceptionInfo e e)))) tap tap) + (str/includes? (ex-message %) ":foo") := true)) + +(skip "l/def initialized to `nil` works in cc/fn" + (l/def foo nil) + (with ((l/single {} (binding [foo "foo"] (let [f foo] (#(tap [f foo]))))) tap tap) + % := ["foo" "foo"])) + +(skip "e/fn varargs" + (with ((l/single+ {} (new (e/fn [x & xs] (tap [x xs])) 1 2 3 4)) tap tap) + % := [1 [2 3 4]])) +(skip "e/fn varargs recursion with recur" + (with ((l/single+ {} (new (e/fn [x & xs] (tap [x xs])) 1 2 3 4)) tap tap) + % := [1 [2 3 4]])) +(skip "e/fn varargs recur is arity-checked" + (with ((l/single+ {} (tap (try (new (e/fn [x & xs] (recur)) 1 2 3) + (catch ExceptionInfo e e)))) tap tap) + (ex-message %) := "You `recur`d in with 0 arguments but it has 2 positional arguments")) ;; (l/defn MapVararg [& {:keys [x] :or {x 1} :as mp}] [x mp]) -;; (tests "map vararg with no args is nil" -;; (with ((l/single+ {} (tap (MapVararg.))) tap tap) -;; % := [1 nil])) -;; (tests "map vararg with kw args" -;; (with ((l/single+ {} (tap (MapVararg. :x 2))) tap tap) -;; % := [2 {:x 2}])) -;; (tests "map vararg with map arg" -;; (with ((l/single+ {} (tap (MapVararg. {:x 2}))) tap tap) -;; % := [2 {:x 2}])) -;; (tests "map vararg with mixture" -;; (with ((l/single+ {} (tap (MapVararg. :y 3 {:x 2}))) tap tap) -;; % := [2 {:x 2, :y 3}])) -;; (tests "map vararg trailing map takes precedence" -;; (with ((l/single+ {} (tap (MapVararg. :x 3 {:x 2}))) tap tap) -;; % := [2 {:x 2}])) -;; (tests "map vararg with positional arguments" -;; (with ((l/single+ {} (tap (new (e/fn [a & {:keys [x]}] [a x]) 1 :x 2))) tap tap) -;; % := [1 2])) - -;; (tests "e/fn recur is arity checked" -;; (with ((l/single {} (tap (try (new (e/fn X [x] (recur x x)) 1) -;; (catch ExceptionInfo e e)))) tap tap) -;; (ex-message %) := "You `recur`d in X with 2 arguments but it has 1 positional argument")) +(skip "map vararg with no args is nil" + (with ((l/single+ {} (tap (MapVararg.))) tap tap) + % := [1 nil])) +(skip "map vararg with kw args" + (with ((l/single+ {} (tap (MapVararg. :x 2))) tap tap) + % := [2 {:x 2}])) +(skip "map vararg with map arg" + (with ((l/single+ {} (tap (MapVararg. {:x 2}))) tap tap) + % := [2 {:x 2}])) +(skip "map vararg with mixture" + (with ((l/single+ {} (tap (MapVararg. :y 3 {:x 2}))) tap tap) + % := [2 {:x 2, :y 3}])) +(skip "map vararg trailing map takes precedence" + (with ((l/single+ {} (tap (MapVararg. :x 3 {:x 2}))) tap tap) + % := [2 {:x 2}])) +(skip "map vararg with positional arguments" + (with ((l/single+ {} (tap (new (e/fn [a & {:keys [x]}] [a x]) 1 :x 2))) tap tap) + % := [1 2])) + +(skip "e/fn recur is arity checked" + (with ((l/single {} (tap (try (new (e/fn X [x] (recur x x)) 1) + (catch ExceptionInfo e e)))) tap tap) + (ex-message %) := "You `recur`d in X with 2 arguments but it has 1 positional argument")) ;; (l/defn One [x] x) ;; (l/defn Two [x y] [x y]) ;; (l/defn VarArgs [x & xs] [x xs]) -;; (tests "(new One 1)" -;; (with ((l/single {} (tap (new One 1))) tap tap) -;; % := 1)) -;; (tests "(new VarArgs 1 2 3)" -;; (with ((l/single {} (tap (new VarArgs 1 2 3))) tap tap) -;; % := [1 [2 3]])) -;; (tests "varargs arity is checked" -;; (with ((l/single {} (tap (try (new VarArgs) -;; (catch ExceptionInfo e e)))) tap tap) -;; (ex-message %) := "You called VarArgs with 0 arguments but it only supports 1")) - -;; (tests "e/apply" -;; (with ((l/single+ {} (tap (e/apply VarArgs [1 2 3]))) tap tap) -;; % := [1 [2 3]])) -;; (tests "e/apply" -;; (with ((l/single+ {} (tap (e/apply Two 1 [2]))) tap tap) -;; % := [1 2])) -;; (tests "e/apply" -;; (with ((l/single+ {} (tap (e/apply Two [1 2]))) tap tap) -;; % := [1 2])) -;; (tests "e/apply" -;; (with ((l/single+ {} (tap (e/apply Two [1 (inc 1)]))) tap tap) -;; % := [1 2])) -;; (tests "e/apply" -;; (with ((l/single+ {} (tap (try (e/apply Two [1 2 3]) (throw (ex-info "boo" {})) -;; (catch ExceptionInfo e e)))) tap tap) -;; (ex-message %) := "You called Two with 3 arguments but it only supports 2")) - -;; (tests "multi-arity e/fn" -;; (with ((l/single {} (tap (new (e/fn ([_] :one) ([_ _] :two)) 1))) tap tap) -;; % := :one)) -;; (tests "multi-arity e/fn" -;; (with ((l/single {} (tap (new (e/fn ([_] :one) ([_ _] :two)) 1 2))) tap tap) -;; % := :two)) -;; (tests "multi-arity e/fn" -;; (with ((l/single {} (tap (new (e/fn ([_]) ([_ & xs] (mapv inc xs))) 1 2 3 4))) tap tap) -;; % := [3 4 5])) -;; (tests "multi-arity e/fn" -;; (with ((l/single+ {} (tap (e/apply (e/fn ([_] :one) ([_ _] :two)) 1 [2]))) tap tap) -;; % := :two)) -;; (tests "multi-arity e/fn" -;; (with ((l/single+ {} (tap (e/apply (e/fn ([_]) ([_ & xs] (mapv inc xs))) 1 2 [3 4]))) tap tap) -;; % := [3 4 5])) - -;; (tests "self-recur by name, e/fn" -;; (with ((l/single {} (tap (new (e/fn fib [n] (case n 0 0 1 1 (+ (fib. (- n 1)) (fib. (- n 2))))) 6))) tap tap) -;; % := 8)) -;; (tests "self-recur by name, l/defn" -;; (l/defn Fib [n] (case n 0 0 1 1 (+ (Fib. (- n 1)) (Fib. (- n 2))))) -;; (with ((l/single {} (tap (Fib. 7))) tap tap) -;; % := 13)) -;; (tests "self-recur by name, e/fn thunk" -;; (def !x (atom 2)) -;; (with ((l/single {} (new (e/fn X [] (if (pos-int? (tap (swap! !x dec))) (X.) (tap :done))))) tap tap) -;; % := 1 -;; % := 0 -;; % := :done)) -;; (tests "self-recur by name, to different arity" -;; (with ((l/single {} (tap (new (e/fn X ([] (X. 0)) ([n] (inc n)))))) tap tap) -;; % := 1)) -;; (tests "self-recur by name, varargs" -;; (with ((l/single {} (new (e/fn Chomp [& xs] (if (tap (seq xs)) (Chomp.) (tap :done))) 0 1 2)) tap tap) -;; % := [0 1 2] -;; % := nil -;; % := :done)) - -;; #?(:clj -;; (tests "e/fn multi-arity mistakes" -;; (binding [expand/*electric* true] -;; (try (expand/all {} '(e/fn Named ([x] x) ([y] y))) -;; (catch Throwable e (tap e))) -;; (ex-message (ex-cause %)) := "Conflicting arity definitions in Named: [x] and [y]" - -;; (try (expand/all {} '(e/fn Named ([x] x) ([& ys] ys))) -;; (catch Throwable e (tap e))) -;; (ex-message (ex-cause %)) := "Conflicting arity definitions in Named: [x] and [& ys]" - -;; (try (expand/all {} '(e/fn ([x & ys] x) ([x y & zs] ys))) -;; (catch Throwable e (tap e))) -;; (ex-message (ex-cause %)) := "Conflicting arity definitions: [x & ys] and [x y & zs]"))) - -;; #?(:cljs -;; (tests "#js" -;; (def !x (atom 0)) -;; (with ((l/single {} (let [x (e/watch !x)] -;; (tap #js {:x x}) -;; (tap #js [:x x]))) tap tap) -;; (.-x %) := 0 -;; (aget % 1) := 0 -;; (swap! !x inc) -;; (.-x %) := 1 -;; (aget % 1) := 1))) - -;; #?(:clj -;; (tests "jvm interop" -;; (with ((l/single {} -;; (let [f (java.io.File. "src") -;; pt (java.awt.Point. 1 2)] -;; (tap [(.getName f) ; instance method -;; (.-x pt) ; field access -;; (java.awt.geom.Point2D/distance 0 0 1 0) ; static method -;; ]))) tap tap) -;; % := ["src" 1 1.0]))) - -;; #?(:cljs -;; (tests "js interop" -;; (with ((l/single {} -;; (let [^js o #js {:a 1 :aPlus (fn [n] (inc n))}] -;; (tap [(.aPlus o 1) ; instance method -;; (.-a o) ; field access -;; ]))) tap tap) -;; % := [2 1]))) - -;; #?(:clj -;; (tests "we capture invalid calls" -;; (binding [expand/*electric* true] -;; (try (lang/analyze (assoc (l/->local-config {}) ::lang/current :server ::lang/me :server) '(jjj 1)) -;; (throw (Throwable. "shouldn't")) -;; (catch ExceptionInfo e -;; (ex-message e) := "in: (jjj 1)\nI cannot resolve `jjj`, maybe it's defined only on the client?\nIf `jjj` is supposed to be a macro, you might need to :refer it in the :require-macros clause." -;; (:form (ex-data e)) := 'jjj)) - -;; "in cc/fn" -;; (try (lang/analyze (assoc (l/->local-config {}) ::lang/current :server ::lang/me :server) '(fn [] (jjj 1))) -;; (throw (Throwable. "shouldn't")) -;; (catch ExceptionInfo e -;; (ex-message e) := "in: (jjj 1)\nI cannot resolve `jjj`, maybe it's defined only on the client?\nIf `jjj` is supposed to be a macro, you might need to :refer it in the :require-macros clause." -;; (:form (ex-data e)) := 'jjj)) - -;; "named cc/fn" -;; (try (lang/analyze (assoc (l/->local-config {}) ::lang/current :server ::lang/me :server) '(fn foo [] (jjj 1))) -;; (throw (Throwable. "shouldn't")) -;; (catch ExceptionInfo e -;; (ex-message e) := "in: (jjj 1)\nI cannot resolve `jjj`, maybe it's defined only on the client?\nIf `jjj` is supposed to be a macro, you might need to :refer it in the :require-macros clause." -;; (:form (ex-data e)) := 'jjj)) - -;; "in letfn" -;; (try (lang/analyze (assoc (l/->local-config {}) ::lang/current :server ::lang/me :server) '(letfn [(foo [] (jjj 1))])) -;; (throw (Throwable. "shouldn't")) -;; (catch ExceptionInfo e -;; (ex-message e) := "in: (jjj 1)\nI cannot resolve `jjj`, maybe it's defined only on the client?\nIf `jjj` is supposed to be a macro, you might need to :refer it in the :require-macros clause." -;; (:form (ex-data e)) := 'jjj)) - -;; "arbitrary symbols" -;; (try (lang/analyze (assoc (l/->local-config {}) ::lang/current :server ::lang/me :server) -;; '(let [x js/document.body])) -;; (catch ExceptionInfo e -;; (ex-message e) := "in: (let* [x js/document.body])\nI cannot resolve `js/document.body`, maybe it's defined only on the client?\nIf `js/document.body` is supposed to be a macro, you might need to :refer it in the :require-macros clause." -;; (:form (ex-data e)) := 'js/document.body)) - -;; "clj static field works" -;; (lang/analyze (assoc (l/->local-config {}) ::lang/current :server ::lang/me :server) 'clojure.lang.PersistentArrayMap/EMPTY)))) - -;; (tests "e/server e/client body" -;; (with ((l/single {} (tap (e/client 1 2))) tap tap) -;; % := 2)) +(skip "(new One 1)" + (with ((l/single {} (tap (new One 1))) tap tap) + % := 1)) +(skip "(new VarArgs 1 2 3)" + (with ((l/single {} (tap (new VarArgs 1 2 3))) tap tap) + % := [1 [2 3]])) +(skip "varargs arity is checked" + (with ((l/single {} (tap (try (new VarArgs) + (catch ExceptionInfo e e)))) tap tap) + (ex-message %) := "You called VarArgs with 0 arguments but it only supports 1")) + +(skip "e/apply" + (with ((l/single+ {} (tap (e/apply VarArgs [1 2 3]))) tap tap) + % := [1 [2 3]])) +(skip "e/apply" + (with ((l/single+ {} (tap (e/apply Two 1 [2]))) tap tap) + % := [1 2])) +(skip "e/apply" + (with ((l/single+ {} (tap (e/apply Two [1 2]))) tap tap) + % := [1 2])) +(skip "e/apply" + (with ((l/single+ {} (tap (e/apply Two [1 (inc 1)]))) tap tap) + % := [1 2])) +(skip "e/apply" + (with ((l/single+ {} (tap (try (e/apply Two [1 2 3]) (throw (ex-info "boo" {})) + (catch ExceptionInfo e e)))) tap tap) + (ex-message %) := "You called Two with 3 arguments but it only supports 2")) + +(skip "multi-arity e/fn" + (with ((l/single {} (tap (new (e/fn ([_] :one) ([_ _] :two)) 1))) tap tap) + % := :one)) +(skip "multi-arity e/fn" + (with ((l/single {} (tap (new (e/fn ([_] :one) ([_ _] :two)) 1 2))) tap tap) + % := :two)) +(skip "multi-arity e/fn" + (with ((l/single {} (tap (new (e/fn ([_]) ([_ & xs] (mapv inc xs))) 1 2 3 4))) tap tap) + % := [3 4 5])) +(skip "multi-arity e/fn" + (with ((l/single+ {} (tap (e/apply (e/fn ([_] :one) ([_ _] :two)) 1 [2]))) tap tap) + % := :two)) +(skip "multi-arity e/fn" + (with ((l/single+ {} (tap (e/apply (e/fn ([_]) ([_ & xs] (mapv inc xs))) 1 2 [3 4]))) tap tap) + % := [3 4 5])) + +(skip "self-recur by name, e/fn" + (with ((l/single {} (tap (new (e/fn fib [n] (case n 0 0 1 1 (+ (fib. (- n 1)) (fib. (- n 2))))) 6))) tap tap) + % := 8)) +(skip "self-recur by name, l/defn" + (l/defn Fib [n] (case n 0 0 1 1 (+ (Fib. (- n 1)) (Fib. (- n 2))))) + (with ((l/single {} (tap (Fib. 7))) tap tap) + % := 13)) +(skip "self-recur by name, e/fn thunk" + (def !x (atom 2)) + (with ((l/single {} (new (e/fn X [] (if (pos-int? (tap (swap! !x dec))) (X.) (tap :done))))) tap tap) + % := 1 + % := 0 + % := :done)) +(skip "self-recur by name, to different arity" + (with ((l/single {} (tap (new (e/fn X ([] (X. 0)) ([n] (inc n)))))) tap tap) + % := 1)) +(skip "self-recur by name, varargs" + (with ((l/single {} (new (e/fn Chomp [& xs] (if (tap (seq xs)) (Chomp.) (tap :done))) 0 1 2)) tap tap) + % := [0 1 2] + % := nil + % := :done)) + +#?(:clj + (skip "e/fn multi-arity mistakes" + (binding [expand/*electric* true] + (try (expand/all {} '(e/fn Named ([x] x) ([y] y))) + (catch Throwable e (tap e))) + (ex-message (ex-cause %)) := "Conflicting arity definitions in Named: [x] and [y]" + + (try (expand/all {} '(e/fn Named ([x] x) ([& ys] ys))) + (catch Throwable e (tap e))) + (ex-message (ex-cause %)) := "Conflicting arity definitions in Named: [x] and [& ys]" + + (try (expand/all {} '(e/fn ([x & ys] x) ([x y & zs] ys))) + (catch Throwable e (tap e))) + (ex-message (ex-cause %)) := "Conflicting arity definitions: [x & ys] and [x y & zs]"))) + +#?(:cljs + (skip "#js" + (def !x (atom 0)) + (with ((l/single {} (let [x (e/watch !x)] + (tap #js {:x x}) + (tap #js [:x x]))) tap tap) + (.-x %) := 0 + (aget % 1) := 0 + (swap! !x inc) + (.-x %) := 1 + (aget % 1) := 1))) + +#?(:clj + (skip "jvm interop" + (with ((l/single {} + (let [f (java.io.File. "src") + pt (java.awt.Point. 1 2)] + (tap [(.getName f) ; instance method + (.-x pt) ; field access + (java.awt.geom.Point2D/distance 0 0 1 0) ; static method + ]))) tap tap) + % := ["src" 1 1.0]))) + +#?(:cljs + (skip "js interop" + (with ((l/single {} + (let [^js o #js {:a 1 :aPlus (fn [n] (inc n))}] + (tap [(.aPlus o 1) ; instance method + (.-a o) ; field access + ]))) tap tap) + % := [2 1]))) + +#?(:clj + (skip "we capture invalid calls" + (binding [expand/*electric* true] + (try (lang/analyze (assoc (l/->local-config {}) ::lang/current :server ::lang/me :server) '(jjj 1)) + (throw (Throwable. "shouldn't")) + (catch ExceptionInfo e + (ex-message e) := "in: (jjj 1)\nI cannot resolve `jjj`, maybe it's defined only on the client?\nIf `jjj` is supposed to be a macro, you might need to :refer it in the :require-macros clause." + (:form (ex-data e)) := 'jjj)) + + "in cc/fn" + (try (lang/analyze (assoc (l/->local-config {}) ::lang/current :server ::lang/me :server) '(fn [] (jjj 1))) + (throw (Throwable. "shouldn't")) + (catch ExceptionInfo e + (ex-message e) := "in: (jjj 1)\nI cannot resolve `jjj`, maybe it's defined only on the client?\nIf `jjj` is supposed to be a macro, you might need to :refer it in the :require-macros clause." + (:form (ex-data e)) := 'jjj)) + + "named cc/fn" + (try (lang/analyze (assoc (l/->local-config {}) ::lang/current :server ::lang/me :server) '(fn foo [] (jjj 1))) + (throw (Throwable. "shouldn't")) + (catch ExceptionInfo e + (ex-message e) := "in: (jjj 1)\nI cannot resolve `jjj`, maybe it's defined only on the client?\nIf `jjj` is supposed to be a macro, you might need to :refer it in the :require-macros clause." + (:form (ex-data e)) := 'jjj)) + + "in letfn" + (try (lang/analyze (assoc (l/->local-config {}) ::lang/current :server ::lang/me :server) '(letfn [(foo [] (jjj 1))])) + (throw (Throwable. "shouldn't")) + (catch ExceptionInfo e + (ex-message e) := "in: (jjj 1)\nI cannot resolve `jjj`, maybe it's defined only on the client?\nIf `jjj` is supposed to be a macro, you might need to :refer it in the :require-macros clause." + (:form (ex-data e)) := 'jjj)) + + "arbitrary symbols" + (try (lang/analyze (assoc (l/->local-config {}) ::lang/current :server ::lang/me :server) + '(let [x js/document.body])) + (catch ExceptionInfo e + (ex-message e) := "in: (let* [x js/document.body])\nI cannot resolve `js/document.body`, maybe it's defined only on the client?\nIf `js/document.body` is supposed to be a macro, you might need to :refer it in the :require-macros clause." + (:form (ex-data e)) := 'js/document.body)) + + "clj static field works" + (lang/analyze (assoc (l/->local-config {}) ::lang/current :server ::lang/me :server) 'clojure.lang.PersistentArrayMap/EMPTY)))) + +(skip "e/server e/client body" + (with ((l/single {} (tap (e/client 1 2))) tap tap) + % := 2)) ;; (defn signify [node] (symbol (str/replace (str node) #"_hf_.*" ""))) -;; #?(:clj -;; (tests "we keep node order" -;; (l/def A 1) -;; (l/def B 2) -;; (l/def C 3) -;; ;; (require '[hyperfiddle.electric.impl.ir-utils :as ir-utils]) - -;; (->> (lang/analyze (assoc (l/->local-config {}) ::lang/current :client ::lang/me :client) -;; '[A (e/server B) C]) -;; ;; ir-utils/unwrite -;; r/find-nodes (mapv signify)) -;; := -;; (->> (lang/analyze (assoc (l/->local-config {}) ::lang/current :client ::lang/me :server) -;; '[A (e/server B) C]) -;; r/find-nodes (mapv signify)))) - -;; #?(:clj -;; (tests "l/def marks the namespace" -;; (l/def Foo 1) -;; (-> *ns* meta ::lang/has-edef?) := true)) - -;; #?(:clj -;; (tests "cljs macroexpansion regression" -;; (binding [expand/*electric* true] -;; (-> (expand/all {::lang/peers {:server :clj, :client :cljs}, ::lang/current :client, ::lang/me :server, :ns 'hyperfiddle.electric-test} -;; '(e/fn Foo [])) -;; first) := ::lang/closure))) - -;; (tests "set literal" -;; (def !v (atom 1)) -;; (with ((l/single {} (tap #{(e/watch !v)})) tap tap) -;; % := #{1} -;; (swap! !v inc) -;; % := #{2})) - -;; (tests "calling an electric defn in a clojure defn as a clojure defn" -;; (l/defn ElectricFn [] 1) -;; (defn clj-fn2 [] (inc (ElectricFn))) -;; (try (clj-fn2) (throw (ex-info "unreachable" {})) -;; (catch ExceptionInfo e (ex-message e) := "I'm an electric value and you called me outside of electric."))) - -;; (tests "let over e/def" -;; (let [x 1] (l/def XX [x x])) -;; (with ((l/single {} (tap XX)) tap tap) -;; % := [1 1])) - -;; #?(:clj -;; (tests "::lang/only filters e/def compilation" -;; (l/def ^{::lang/only #{:server}} ServerOnly 1) -;; (some? (find-var `ServerOnly_hf_server_server)) := true -;; (some? (find-var `ServerOnly_hf_client_server)) := true -;; (not (find-var `ServerOnly_hf_server_client)) := true -;; (not (find-var `ServerOnly_hf_client_client)) := true)) - -;; (deftype FieldAccess [x]) -;; (tests "non-static first arg to . or .. works" -;; (with ((l/single {} (tap (.. (FieldAccess. 1) -x))) tap tap) -;; % := 1)) - -;; (tests "lexical first arg to . or .. works" -;; (with ((l/single {} (let [fa (FieldAccess. 1)] (tap (.. fa -x)))) tap tap) -;; % := 1)) - -;; (tests "()" -;; (with ((l/single {}+ {} (tap ())) tap tap) -;; % := ())) - -;; (tests "(#())" -;; (with ((l/single {}+ {} (tap (#()))) tap tap) -;; % := ())) - -;; (tests "((fn []))" -;; (with ((l/single {}+ {} (tap ((fn [])))) tap tap) -;; % := nil)) - -;; (tests "::lang/non-causal removes causality in `let`" -;; (l/defn ^::lang/non-causal NonCausalLet [tap] -;; (let [_ (tap 1)] (tap 2))) -;; (with ((l/single {} (NonCausalLet. tap)) tap tap) -;; ;; % := 1 -;; % := 2)) - -;; (tests "::lang/non-causal removes causality in `binding`" -;; (l/def NonCausalEDef) -;; (l/defn ^::lang/non-causal NonCausalBinding [tap] -;; (binding [NonCausalEDef (tap 1)] (tap 2))) -;; (with ((l/single {} (NonCausalBinding. tap)) tap tap) -;; ;; % := 1 -;; % := 2)) - -;; (tests "binding in interop fn" -;; (with ((l/single {} (tap ((fn [] (binding [*out* nil] 1))))) tap tap) -;; % := 1)) +#?(:clj + (skip "we keep node order" + (l/def A 1) + (l/def B 2) + (l/def C 3) + ;; (require '[hyperfiddle.electric.impl.ir-utils :as ir-utils]) + + (->> (lang/analyze (assoc (l/->local-config {}) ::lang/current :client ::lang/me :client) + '[A (e/server B) C]) + ;; ir-utils/unwrite + r/find-nodes (mapv signify)) + := + (->> (lang/analyze (assoc (l/->local-config {}) ::lang/current :client ::lang/me :server) + '[A (e/server B) C]) + r/find-nodes (mapv signify)))) + +#?(:clj + (skip "l/def marks the namespace" + (l/def Foo 1) + (-> *ns* meta ::lang/has-edef?) := true)) + +#?(:clj + (skip "cljs macroexpansion regression" + (binding [expand/*electric* true] + (-> (expand/all {::lang/peers {:server :clj, :client :cljs}, ::lang/current :client, ::lang/me :server, :ns 'hyperfiddle.electric-test} + '(e/fn Foo [])) + first) := ::lang/closure))) + +(skip "set literal" + (def !v (atom 1)) + (with ((l/single {} (tap #{(e/watch !v)})) tap tap) + % := #{1} + (swap! !v inc) + % := #{2})) + +(skip "calling an electric defn in a clojure defn as a clojure defn" + (l/defn ElectricFn [] 1) + (defn clj-fn2 [] (inc (ElectricFn))) + (try (clj-fn2) (throw (ex-info "unreachable" {})) + (catch ExceptionInfo e (ex-message e) := "I'm an electric value and you called me outside of electric."))) + +(skip "let over e/def" + (let [x 1] (l/def XX [x x])) + (with ((l/single {} (tap XX)) tap tap) + % := [1 1])) + +#?(:clj + (skip "::lang/only filters e/def compilation" + (l/def ^{::lang/only #{:server}} ServerOnly 1) + (some? (find-var `ServerOnly_hf_server_server)) := true + (some? (find-var `ServerOnly_hf_client_server)) := true + (not (find-var `ServerOnly_hf_server_client)) := true + (not (find-var `ServerOnly_hf_client_client)) := true)) + +(deftype FieldAccess [x]) +(skip "non-static first arg to . or .. works" + (with ((l/single {} (tap (.. (FieldAccess. 1) -x))) tap tap) + % := 1)) + +(skip "lexical first arg to . or .. works" + (with ((l/single {} (let [fa (FieldAccess. 1)] (tap (.. fa -x)))) tap tap) + % := 1)) + +(skip "()" + (with ((l/single {}+ {} (tap ())) tap tap) + % := ())) + +(skip "(#())" + (with ((l/single {}+ {} (tap (#()))) tap tap) + % := ())) + +(skip "((fn []))" + (with ((l/single {}+ {} (tap ((fn [])))) tap tap) + % := nil)) + +(skip "::lang/non-causal removes causality in `let`" + (l/defn ^::lang/non-causal NonCausalLet [tap] + (let [_ (tap 1)] (tap 2))) + (with ((l/single {} (NonCausalLet. tap)) tap tap) + ;; % := 1 + % := 2)) + +(skip "::lang/non-causal removes causality in `binding`" + (l/def NonCausalEDef) + (l/defn ^::lang/non-causal NonCausalBinding [tap] + (binding [NonCausalEDef (tap 1)] (tap 2))) + (with ((l/single {} (NonCausalBinding. tap)) tap tap) + ;; % := 1 + % := 2)) + +(skip "binding in interop fn" + (with ((l/single {} (tap ((fn [] (binding [*out* nil] 1))))) tap tap) + % := 1)) From 551701bd25c297765f67234935bb13d5734e0835 Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 5 Feb 2024 15:20:55 +0100 Subject: [PATCH 084/428] compiler: cc/fn --- test/hyperfiddle/electric_de_test.cljc | 65 +++----------------------- 1 file changed, 7 insertions(+), 58 deletions(-) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 30b2f466c..6d28224a9 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -48,8 +48,7 @@ (with ((l/single {} (tap (js* "~{}+1" 1))) tap tap) % := 2))) -;; TODO cc/fn -(skip "clj fn" +(tests "clj fn" (with ((l/single {::lang/print-source true} (let [x 1] (tap (#(inc x))))) tap tap) % := 2)) @@ -493,68 +492,18 @@ (comment (def !x (atom 1)) - (def !y (atom 10)) - (def it ((l/single {} - (let [x (e/watch !x), y (e/watch !y)] - (tap ($ (if (odd? x) - (e/fn [x] (prn :x1 x) (* y x)) - (e/fn [x] (prn :x2 x) (* y x))) - x)))) prn prn)) + (def it ((l/single {::lang/print-source true} + (let [x (e/watch !x)] + (tap (if (odd? x) + (prn :x1 x) + (prn :x2 x))))) + prn prn)) ;; :x1 1 - ;; 10 (swap! !x inc) ;; :x1 2 - ;; 20 ;; :x2 2 - ;; 20 ) -#_[(r/cdef 0 [nil nil] [nil] nil - (fn [frame] - (r/define-node frame 0 (r/join (r/ap (r/lookup frame :r/fixed-signals (r/pure r/fixed-signals)) - (r/ap (r/lookup frame ::m/watch (r/pure m/watch)) - (r/lookup frame ::!y (r/pure !y)))))) - (r/define-node frame 1 (r/join (r/ap (r/lookup frame :r/fixed-signals (r/pure r/fixed-signals)) - (r/ap (r/lookup frame ::m/watch (r/pure m/watch)) - (r/lookup frame ::!x (r/pure !x)))))) - (r/define-call frame 0 (r/pure (r/bind (doto (r/make-ctor frame ::l/Main 1) - (r/define-free 0 (r/node frame 0)) - (r/define-free 1 (r/node frame 1))) - 0 (r/node frame 1)))) - (r/ap (r/pure RCF__tap) - (r/join (r/call frame 0))))) - (r/cdef 2 [nil] [nil nil] nil - (fn [frame] - (r/define-node frame 0 (r/pure (doto (r/make-ctor frame ::l/Main 2) - (r/define-free 0 (r/free frame 0))))) - (r/define-call frame 0 (r/join (r/call frame 1))) - (r/define-call frame 1 (r/ap (r/ap (r/pure hash-map) - (r/pure (quote nil)) (r/node frame 0) - (r/pure (quote false)) (r/node frame 0)) - (r/ap (r/lookup frame :odd? (r/pure odd?)) - (r/free frame 1)) - (r/pure (doto (r/make-ctor frame ::l/Main 4) - (r/define-free 0 (r/free frame 0)))))) - (r/join (r/call frame 0)))) - (r/cdef 1 [] [] nil - (fn [frame] - (r/pure (doto (r/make-ctor frame ::l/Main 3) - (r/define-free 0 (r/free frame 0)))))) - (r/cdef 1 [] [] nil - (fn [frame] - (r/ap (r/lookup frame :* (r/pure *)) - (r/free frame 0) - (r/lookup frame 0)))) - (r/cdef 1 [] [] nil - (fn [frame] - (r/pure (doto (r/make-ctor frame ::l/Main 5) - (r/define-free 0 (r/free frame 0)))))) - (r/cdef 1 [] [] nil - (fn [frame] - (r/ap (r/lookup frame :* (r/pure *)) - (r/free frame 0) - (r/lookup frame 0))))] - (skip "reactive closures 2" (def !x (atom 0)) (def !y (atom 0)) From 3f7335e8fe76dd9a607974209d8e37d0839eb55e Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 5 Feb 2024 16:45:40 +0100 Subject: [PATCH 085/428] compiler: . --- src/hyperfiddle/electric/impl/lang_de2.clj | 54 ++++++++++++++++++++++ test/hyperfiddle/electric_de_test.cljc | 7 ++- 2 files changed, 57 insertions(+), 4 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 66620f476..fb90bfdd2 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -519,6 +519,28 @@ #_else (keyword sym))) sym)) +(declare analyze) + +(defn ->class-method-call [clazz method method-args pe env {{::keys [->id]} :o :as ts}] + (let [e (->id), ce (->id)] + (reduce (fn [ts form] (analyze form e env ts)) + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) + (ts/add {:db/id ce, ::parent e, ::type ::pure}) + (ts/add {:db/id (->id), ::parent ce, ::type ::literal, + ::v (let [margs (repeatedly (count method-args) gensym)] + `(fn [~@margs] (. ~clazz ~method ~@margs)))})) + method-args))) + +(defn ->obj-method-call [o method method-args pe env {{::keys [->id]} :o :as ts}] + (let [e (->id), ce (->id)] + (reduce (fn [ts form] (analyze form e env ts)) + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) + (ts/add {:db/id ce, ::parent e, ::type ::pure}) + (ts/add {:db/id (->id), ::parent ce, ::type ::literal, + ::v (let [oo (gensym "o"), margs (repeatedly (count method-args) gensym)] + `(fn [~@margs] (. ~oo ~method ~@margs)))})) + (cons o method-args)))) + (defn analyze [form pe env {{::keys [->id]} :o :as ts}] (cond (and (seq? form) (seq form)) @@ -558,6 +580,38 @@ ::v (let [gs (repeatedly (count args) gensym)] `(fn [~@gs] (new ~f ~@gs)))})) args)) + ;; (. java.time.Instant now) + ;; (. java.time.Instant ofEpochMilli 1) + ;; (. java.time.Instant (ofEpochMilli 1)) + ;; (. java.time.Instant EPOCH) + ;; (. java.time.Instant -EPOCH) + ;; (. i1 isAfter i2) + ;; (. i1 (isAfter i2)) + ;; (. pt x) + ;; (. pt -x) + (.) (if (and (= :clj (get (::peers env) (::current env))) + (symbol? (second form)) (class? (resolve env (second form)))) + (if (seq? (nth form 2)) ; (. java.time.Instant (ofEpochMilli 1)) + (let [[_ clazz [method & method-args]] form] + (->class-method-call clazz method method-args pe env ts)) + (let [[_ clazz x & xs] form] + (if (seq xs) ; (. java.time.Instant ofEpochMilli 1) + (->class-method-call clazz x xs pe env ts) + (let [e (->id)] ; (. java.time.Instant now) + (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) + (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form})))))) + (if (seq? (nth form 2)) ; (. i1 (isAfter i2)) + (let [[_ o [method & method-args]] form] + (->obj-method-call o method method-args pe env ts)) + (let [[_ o x & xs] form] + (if (seq xs) ; (. i1 isAfter i2) + (->obj-method-call o x xs pe env ts) + (let [e (->id), ce (->id)] ; (. pt x) + (recur o e env + (-> ts + (ts/add {:db/id e, ::parent pe, ::type ::ap}) + (ts/add {:db/id ce, ::parent e, ::type ::pure}) + (ts/add {:db/id (->id) , ::parent ce, ::type ::literal, ::v `(fn [oo#] (. oo# ~x))})))))))) (binding clojure.core/binding) (let [[_ bs bform] form, gs (repeatedly (/ (count bs) 2) gensym)] (recur (if (seq bs) `(let* [~@(interleave gs (take-nth 2 (next bs)))] diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 6d28224a9..0ad9e8f4d 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -49,13 +49,12 @@ % := 2))) (tests "clj fn" - (with ((l/single {::lang/print-source true} (let [x 1] (tap (#(inc x))))) tap tap) + (with ((l/single {} (let [x 1] (tap (#(inc x))))) tap tap) % := 2)) -;; TODO `.` #?(:clj - (skip "." - (with ((l/single {} (tap (. java.time.Instant EPOCH))) tap tap) + (tests "." + (with ((l/single {} (e/server (tap (. java.time.Instant EPOCH)))) tap tap) % := java.time.Instant/EPOCH))) ;; TODO loop recur From 0e18f603ba58c9da1aedde7a6c25eb8902caf8d2 Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 5 Feb 2024 17:04:54 +0100 Subject: [PATCH 086/428] compiler: loop/recur --- src/hyperfiddle/electric/impl/lang_de2.clj | 11 ++++++++--- src/hyperfiddle/electric/impl/runtime_de.cljc | 2 -- test/hyperfiddle/electric_de_test.cljc | 3 +-- 3 files changed, 9 insertions(+), 7 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index fb90bfdd2..fda4f6ce3 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -198,9 +198,14 @@ [(conj bs sym (-expand-all v env)) (add-local env sym)]) [[] env] (partition-all 2 bs))] - (recur (?meta o `(binding [r/rec (::closure (let [~@(interleave (take-nth 2 bs2) r/arg-sym)] - ~@body))] - (new r/rec ~@(take-nth 2 (next bs2))))) env2)) + (recur (?meta o `(binding [::rec (::ctor (let* [~@(interleave (take-nth 2 bs2) (range))] ~@body))] + (binding [~@(interleave (range) (take-nth 2 (next bs2)))] + (::call (::lookup ::rec))))) + env2)) + + (recur) (recur (?meta o `(binding [~@(interleave (range) (next o))] + (::call (::lookup ::rec)))) + env) (case clojure.core/case) (let [[_ v & clauses] o diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 5de286e85..6bea2fcc9 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -274,8 +274,6 @@ Returns a peer definition from given definitions and main key. (make-frame nil 0) (m/signal i/combine))) -(def ^{::type ::node, :doc "for loop/recur impl"} rec) - #?(:clj (def arg-sym (map (comp symbol diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 0ad9e8f4d..d8f0d816e 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -57,8 +57,7 @@ (with ((l/single {} (e/server (tap (. java.time.Instant EPOCH)))) tap tap) % := java.time.Instant/EPOCH))) -;; TODO loop recur -(skip "loop/recur" +(tests "loop/recur" (with ((l/single {} (tap (loop [x 1] (if (odd? x) (recur (dec x)) x)))) tap tap) % := 0)) From 8c58e4c03d2c16794931fd58253e93bccca6000c Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 6 Feb 2024 10:19:20 +0100 Subject: [PATCH 087/428] compiler: def --- src/hyperfiddle/electric/impl/lang_de2.clj | 28 +++++++++++++--------- test/hyperfiddle/electric_de_test.cljc | 3 +-- 2 files changed, 18 insertions(+), 13 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index fda4f6ce3..6c9119a14 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -546,6 +546,10 @@ `(fn [~@margs] (. ~oo ~method ~@margs)))})) (cons o method-args)))) +(defn def-sym-in-cljs-compiler! [sym ns] + (swap! @(requiring-resolve 'cljs.env/*compiler*) + assoc-in [:cljs.analyzer/namespaces ns :defs sym] {:name sym})) + (defn analyze [form pe env {{::keys [->id]} :o :as ts}] (cond (and (seq? form) (seq form)) @@ -626,6 +630,11 @@ (mapv #(list ::pure %) gs))))) bform) pe env ts)) + (def) (let [[_ sym v] form] + (case (->env-type env) + :clj (recur `((fn* ([x#] (def ~sym x#))) ~v) pe env ts) + :cljs (do (def-sym-in-cljs-compiler! sym (get-ns env)) + (recur `(set! ~sym ~v) pe env ts)))) (::ctor) (let [e (->id), ce (->id)] (recur (list ::site nil (second form)) ce env (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) @@ -780,19 +789,16 @@ #_else (throw (ex-info (str "cannot mark-used-calls on " (::type nd)) (or nd {})))))) change-parent (fn change-parent [ts e pe] (ts/asc ts e ::parent pe)) orphan (fn orphan [ts e] (change-parent ts e nil)) - collapse-ap-with-only-pures (fn collapse-ap-with-only-pures [ts] ; (r/ap (r/pure .)+ ) => (r/pure (. . .)) + collapse-ap-with-only-pures (fn collapse-ap-with-only-pures [ts] ; (r/ap (r/pure .)+ ) => (r/pure (::comp . . .)) (reduce (fn [ts ap-e] - (let [ap-nd (ts/->node ts ap-e) - children-e (get-children-e ts ap-e)] + (let [[f-e & args-e :as children-e] (get-children-e ts ap-e)] (if (every? #(= ::pure (::type (ts/->node ts %))) children-e) - (let [e (->id), ce (->id)] - (reduce (fn [ts e] - (-> ts (change-parent (get-child-e ts e) ce) - (orphan e))) - (-> ts (ts/add {:db/id e, ::parent (::parent ap-nd), ::type ::pure}) - (ts/add {:db/id ce, ::parent e, ::type ::comp}) - (orphan ap-e)) - children-e)) + (reduce (fn [ts e] + (-> ts (change-parent (get-child-e ts e) f-e) + (orphan e))) + ;; reuse nodes, otherwise node ordering messes up + (-> ts (ts/asc ap-e ::type ::pure) (ts/asc f-e ::type ::comp)) + args-e) ts))) ts (reverse (ts/find ts ::type ::ap)))) ts (-> ts (handle-let-refs 0) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index d8f0d816e..fd116ff02 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -61,8 +61,7 @@ (with ((l/single {} (tap (loop [x 1] (if (odd? x) (recur (dec x)) x)))) tap tap) % := 0)) -;; TODO def -(skip "def" +(tests "def" (with ((l/single {} (def DEFD 1)) tap tap)) DEFD := 1) From f93d915a1024d9311135d1017a6b41ebd0e63342 Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 6 Feb 2024 10:32:03 +0100 Subject: [PATCH 088/428] compiler: set! --- src/hyperfiddle/electric/impl/lang_de2.clj | 1 + test/hyperfiddle/electric_de_test.cljc | 10 +++++----- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 6c9119a14..81aa54c7f 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -635,6 +635,7 @@ :clj (recur `((fn* ([x#] (def ~sym x#))) ~v) pe env ts) :cljs (do (def-sym-in-cljs-compiler! sym (get-ns env)) (recur `(set! ~sym ~v) pe env ts)))) + (set!) (let [[_ target v] form] (recur `((fn* ([v#] (set! ~target v#))) ~v) pe env ts)) (::ctor) (let [e (->id), ce (->id)] (recur (list ::site nil (second form)) ce env (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index fd116ff02..991947608 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -1308,7 +1308,7 @@ ))) #?(:clj - (skip "set!" + (tests "set!" (def !y (atom 8)) (with ((l/single {} (let [pt (java.awt.Point. 1 2) y (e/watch !y)] @@ -1321,7 +1321,7 @@ #?(:cljs (do-browser - (skip "set!" + (tests "set!" ;; https://www.notion.so/hyperfiddle/RCF-implicit-do-rewrite-rule-does-not-account-for-let-bindings-61b1ad82771c407198c1f678683bf443 (defn bypass-rcf-bug [[href a]] [href (str/replace (.-href a) #".*/" "")]) (def !href (atom "href1")) @@ -1333,12 +1333,12 @@ (reset! !href "href2") (bypass-rcf-bug %) := ["href2" "href2"])))) -#?(:clj (skip "set! with electric value" +#?(:clj (tests "set! with electric value" (with ((l/single {} (tap (let [pt (java.awt.Point. 1 2)] - (set! (.-y pt) (new (e/fn [] 0)))))) tap tap) + (set! (.-y pt) ($ (e/fn [] 0)))))) tap tap) % := 0))) -#?(:cljs (skip "set! with electric value" +#?(:cljs (tests "set! with electric value" (with ((l/single {} (tap (let [o (js/Object.)] (set! (.-x o) (new (e/fn [] 0)))))) tap tap) % := 0))) From 8acc18f033c84b4b8fe699e5b37bc07c232d85cb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Tue, 6 Feb 2024 13:29:52 +0100 Subject: [PATCH 089/428] update missionary --- deps.edn | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/deps.edn b/deps.edn index 8eed964a8..c46823b3b 100644 --- a/deps.edn +++ b/deps.edn @@ -4,7 +4,7 @@ :deps {com.cognitect/transit-clj {:mvn/version "1.0.329"} com.cognitect/transit-cljs {:mvn/version "0.8.269"} com.hyperfiddle/rcf {:mvn/version "20220926-202227"} - missionary/missionary {:mvn/version "b.33"} + missionary/missionary {:mvn/version "b.34"} dom-top/dom-top {:mvn/version "1.0.9"} fipp/fipp {:mvn/version "0.6.26"} org.clojure/clojure {:mvn/version "1.12.0-alpha4"} From 1c994e45beb7feef8bc866379e4de7ed7e0a7f02 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Wed, 7 Feb 2024 11:25:31 +0100 Subject: [PATCH 090/428] restore e/for-by test --- test/hyperfiddle/electric_de_test.cljc | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 991947608..527791b99 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -308,10 +308,9 @@ (def foo 1) (def bar 2) -;; TODO waiting for Leo's fix -(skip "reactive for" +(tests "reactive for" (def !xs (atom [1 2 3])) - (with ((l/single {} (tap (e/for-by identity [x (e/watch !xs)] (prn x) (inc x)))) tap tap) + (with ((l/single {} (tap (e/for-by identity [x (e/watch !xs)] (inc x)))) tap tap) % := [2 3 4] (swap! !xs conj 4) % := [2 3 4 5])) From bf06263da0cf09971fcda601f1ba56f64b1945d3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Fri, 9 Feb 2024 11:27:25 +0100 Subject: [PATCH 091/428] new compiler test - successive calls --- test/hyperfiddle/electric/impl/compiler_test.cljc | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index 27dd9bbb3..2ee5143e3 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -466,6 +466,20 @@ (fn [~'frame] (r/pure (clojure.core/vector 1 2))))])) +(tests "successive calls" + (match (l/test-compile ::Main (::lang/call (::lang/call (::lang/ctor (::lang/ctor :foo))))) + `[(r/cdef 0 [] [nil nil] nil + (fn [~'frame] + (r/define-call ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) + (r/define-call ~'frame 1 (r/join (r/call ~'frame 0))) + (r/join (r/call ~'frame 1)))) + (r/cdef 0 [] [] nil + (fn [~'frame] + (r/pure (r/make-ctor ~'frame ::Main 2)))) + (r/cdef 0 [] [] nil + (fn [~'frame] + (r/pure :foo)))])) + (comment (l/test-compile ::Main (let [fizz "fizz", buzz "buzz"] (e/ctor (str fizz buzz))))) From ff1b5cc33254ae80258f119c96566c3c2b9e2984 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Fri, 9 Feb 2024 12:05:01 +0100 Subject: [PATCH 092/428] fix latest-concat - prioritize outer flow --- src/hyperfiddle/incseq.cljc | 244 +++++++++++++++++++----------------- 1 file changed, 126 insertions(+), 118 deletions(-) diff --git a/src/hyperfiddle/incseq.cljc b/src/hyperfiddle/incseq.cljc index f6c53707d..76336baa4 100644 --- a/src/hyperfiddle/incseq.cljc +++ b/src/hyperfiddle/incseq.cljc @@ -839,12 +839,36 @@ sequence. slot-ready 5 slot-push 6 slot-live 7 - slot-value 8 - slots 9 + slot-busy 8 + slot-value 9 + slots 10 inner-slot-process 0 inner-slot-index 1 inner-slots 2] - (letfn [(ready [^objects state ^objects input] + (letfn [(flush [^objects state] + (loop [i 0] + (if (aget state slot-busy) + (do (aset state slot-busy false) + (try @(aget state slot-process) + (catch #?(:clj Throwable :cljs :default) _)) + (recur i)) + (let [^objects q (aget state slot-ready)] + (if-some [^objects input (aget q i)] + (do (aset q i nil) + (try @(aget input inner-slot-process) + (catch #?(:clj Throwable :cljs :default) _)) + (recur (rem (unchecked-inc-int i) (alength q)))) + (do (aset state slot-push nil) + (if (zero? (aget state slot-live)) + (aget state slot-terminator) nop))))))) + (outer-ready [^objects state] + ((locking state + (aset state slot-busy true) + (if (nil? (aget state slot-push)) + (do (aset state slot-push 0) + (if-some [cb (aget state slot-notifier)] + cb (flush state))) nop)))) + (inner-ready [^objects state ^objects input] ((locking state (let [^objects q (aget state slot-ready) c (alength q)] @@ -864,21 +888,9 @@ sequence. (aset a p input) (rem (unchecked-inc-int p) n)))))) nop) (do (aset state slot-push (identity (rem 1 c))) + (aset q 0 input) (if-some [cb (aget state slot-notifier)] - (do (aset q 0 input) cb) - (loop [input input - i (rem 1 c)] - (try @(if (identical? state input) - (aget state slot-process) - (aget input inner-slot-process)) - (catch #?(:clj Throwable :cljs :default) _)) - (let [^objects q (aget state slot-ready)] - (if-some [^objects input (aget q i)] - (do (aset q i nil) - (recur input (rem (unchecked-inc-int i) (alength q)))) - (do (aset state slot-push nil) - (if (zero? (aget state slot-live)) - (aget state slot-terminator) nop)))))))))))) + cb (flush state)))))))) (terminated [^objects state] ((locking state (if (zero? (aset state slot-live (dec (aget state slot-live)))) @@ -945,106 +957,101 @@ sequence. (aset buffer j xi))) (transfer [^objects state] ((locking state - (let [^objects q (aget state slot-ready) - input (aget q 0)] - (aset q 0 nil) - (loop [^objects input input - i (rem 1 (alength q))] - (if (nil? (aget state slot-notifier)) - (try @(if (identical? state input) - (aget state slot-process) - (aget input inner-slot-process)) - (catch #?(:clj Throwable :cljs :default) _)) - (try (if (identical? state input) - (let [{:keys [grow degree shrink permutation change]} @(aget state slot-process)] - (ensure-capacity state grow degree shrink) - (let [^objects buffer (aget state slot-buffer) - ^ints counts (aget state slot-counts) - global-degree (aget counts 1) - perm (loop [p permutation - q {}] - (case p - {} (reduce - (fn [q index] - (let [^objects inner (aget buffer index) - ^objects inner (if-some [ps (aget inner inner-slot-process)] - (let [clone (object-array inner-slots)] - (aset clone inner-slot-index index) - (aset inner inner-slot-index nil) - (aset buffer index clone) - (ps) clone) inner)] - (aset state slot-live (inc (aget state slot-live))) - (aset inner inner-slot-process - ((change index) #(ready state inner) #(terminated state))) - (let [k (index-in-counts counts index) - l (aget counts k) - o (compute-offset counts k 0) - s (aget counts 1)] - (compose (->> (range o (unchecked-add-int o l)) - (eduction (map (fn [i] (cycle i (unchecked-add-int s i))))) - (reduce compose {})) q)))) - q (sort (keys change))) - (let [[i j] (first p) - k2 (index-in-counts counts (max i j)) - k1 (index-in-counts counts (min i j)) - l2 (aget counts k2) - l1 (aget counts k1) - o2 (compute-offset counts k2 l1) - o1 (compute-offset counts k1 l2)] - (swap-buffer buffer i j) - (recur (compose p (cycle i j)) - (compose (split-long-swap o1 l1 - (unchecked-subtract-int - (unchecked-subtract-int o2 o1) - l1) l2) q)))))] - (dotimes [i shrink] - (let [index (unchecked-dec-int (unchecked-subtract-int degree i)) - ^objects inner (aget buffer index)] - (aset buffer index nil) - (aset inner inner-slot-index nil) - ((aget inner inner-slot-process)) - (compute-offset counts (index-in-counts counts index) 0))) - (aset state slot-value - (combine (aget state slot-value) - {:grow 0 - :degree global-degree - :permutation perm - :shrink (unchecked-subtract global-degree (aget counts 1)) - :change {} - :freeze #{}})))) - (if-some [index (aget input inner-slot-index)] - (let [{:keys [grow degree shrink permutation change freeze]} @(aget input inner-slot-process) - ^ints counts (aget state slot-counts) - global-degree (unchecked-add-int (aget counts 1) grow) - size-before (unchecked-subtract-int degree grow) - size-after (unchecked-subtract-int degree shrink) - offset (compute-offset counts (index-in-counts counts index) size-after) - shift (unchecked-subtract-int global-degree (unchecked-add-int degree offset)) - +offset (partial + offset)] - (aset state slot-value - (combine (aget state slot-value) - {:grow grow - :shrink shrink - :degree global-degree - :permutation (compose - (split-swap (unchecked-add-int offset size-after) shift shrink) - (into {} (map (juxt (comp +offset key) (comp +offset val))) permutation) - (split-swap (unchecked-add-int offset size-before) shift grow)) - :change (into {} (map (juxt (comp +offset key) val)) change) - :freeze (into #{} (map +offset) freeze)}))) - (try @(aget input inner-slot-process) - (catch #?(:clj Throwable :cljs :default) _)))) - (catch #?(:clj Throwable :cljs :default) e - (aset state slot-notifier nil) - (aset state slot-value e) - (cancel state)))) - (let [^objects q (aget state slot-ready)] - (if-some [input (aget q i)] - (do (aset q i nil) - (recur input (rem (unchecked-inc-int i) (alength q)))) - (do (aset state slot-push nil) - (if (zero? (aget state slot-live)) - (aget state slot-terminator) nop)))))))) + (try + (loop [i 0] + (if (aget state slot-busy) + (do (aset state slot-busy false) + (let [{:keys [grow degree shrink permutation change]} @(aget state slot-process)] + (ensure-capacity state grow degree shrink) + (let [^objects buffer (aget state slot-buffer) + ^ints counts (aget state slot-counts) + global-degree (aget counts 1) + perm (loop [p permutation + q {}] + (case p + {} (reduce + (fn [q index] + (let [^objects inner (aget buffer index) + ^objects inner (if-some [ps (aget inner inner-slot-process)] + (let [clone (object-array inner-slots)] + (aset clone inner-slot-index index) + (aset inner inner-slot-index nil) + (aset buffer index clone) + (ps) clone) inner)] + (aset state slot-live (inc (aget state slot-live))) + (aset inner inner-slot-process + ((change index) #(inner-ready state inner) #(terminated state))) + (let [k (index-in-counts counts index) + l (aget counts k) + o (compute-offset counts k 0) + s (aget counts 1)] + (compose (->> (range o (unchecked-add-int o l)) + (eduction (map (fn [i] (cycle i (unchecked-add-int s i))))) + (reduce compose {})) q)))) + q (sort (keys change))) + (let [[i j] (first p) + k2 (index-in-counts counts (max i j)) + k1 (index-in-counts counts (min i j)) + l2 (aget counts k2) + l1 (aget counts k1) + o2 (compute-offset counts k2 l1) + o1 (compute-offset counts k1 l2)] + (swap-buffer buffer i j) + (recur (compose p (cycle i j)) + (compose (split-long-swap o1 l1 + (unchecked-subtract-int + (unchecked-subtract-int o2 o1) + l1) l2) q)))))] + (dotimes [i shrink] + (let [index (unchecked-dec-int (unchecked-subtract-int degree i)) + ^objects inner (aget buffer index)] + (aset buffer index nil) + (aset inner inner-slot-index nil) + ((aget inner inner-slot-process)) + (compute-offset counts (index-in-counts counts index) 0))) + (aset state slot-value + (combine (aget state slot-value) + {:grow 0 + :degree global-degree + :permutation perm + :shrink (unchecked-subtract global-degree (aget counts 1)) + :change {} + :freeze #{}})))) + (recur i)) + (let [^objects q (aget state slot-ready)] + (if-some [^objects input (aget q i)] + (do (aset q i nil) + (if-some [index (aget input inner-slot-index)] + (let [{:keys [grow degree shrink permutation change freeze]} @(aget input inner-slot-process) + ^ints counts (aget state slot-counts) + global-degree (unchecked-add-int (aget counts 1) grow) + size-before (unchecked-subtract-int degree grow) + size-after (unchecked-subtract-int degree shrink) + offset (compute-offset counts (index-in-counts counts index) size-after) + shift (unchecked-subtract-int global-degree (unchecked-add-int degree offset)) + +offset (partial + offset)] + (aset state slot-value + (combine (aget state slot-value) + {:grow grow + :shrink shrink + :degree global-degree + :permutation (compose + (split-swap (unchecked-add-int offset size-after) shift shrink) + (into {} (map (juxt (comp +offset key) (comp +offset val))) permutation) + (split-swap (unchecked-add-int offset size-before) shift grow)) + :change (into {} (map (juxt (comp +offset key) val)) change) + :freeze (into #{} (map +offset) freeze)}))) + (try @(aget input inner-slot-process) + (catch #?(:clj Throwable :cljs :default) _))) + (recur (rem (unchecked-inc-int i) (alength q)))) + (do (aset state slot-push nil) + (if (zero? (aget state slot-live)) + (aget state slot-terminator) nop)))))) + (catch #?(:clj Throwable :cljs :default) e + (aset state slot-notifier nil) + (aset state slot-value e) + (cancel state) + (flush state))))) (let [x (aget state slot-value)] (aset state slot-value (empty-diff (aget ^ints (aget state slot-counts) 1))) (if (nil? (aget state slot-notifier)) (throw x) x)))] @@ -1057,8 +1064,9 @@ sequence. (aset state slot-counts (int-array 2)) (aset state slot-ready (object-array 1)) (aset state slot-live (identity 1)) + (aset state slot-busy false) (aset state slot-value (empty-diff 0)) - (aset state slot-process (input #(ready state state) #(terminated state))) + (aset state slot-process (input #(outer-ready state) #(terminated state))) (->Ps state cancel transfer))))))) (def ^{:arglists '([] [sentinel] [sentinel compare]) From 5733d31036b0358851a7802ed8f10fcdc33f79d8 Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 7 Feb 2024 11:08:10 +0100 Subject: [PATCH 093/428] compiler: e/defn --- ci/run_tests_jvm.sh | 5 +- src/hyperfiddle/electric/impl/lang_de2.clj | 216 ++++++++++-------- src/hyperfiddle/electric/impl/runtime_de.cljc | 5 +- src/hyperfiddle/electric_de.cljc | 30 ++- src/hyperfiddle/electric_local_def_de.cljc | 16 +- test/hyperfiddle/electric_de_test.cljc | 9 +- 6 files changed, 180 insertions(+), 101 deletions(-) diff --git a/ci/run_tests_jvm.sh b/ci/run_tests_jvm.sh index cbe77defb..c4ca16ae9 100755 --- a/ci/run_tests_jvm.sh +++ b/ci/run_tests_jvm.sh @@ -4,8 +4,9 @@ echo "Running JVM tests" clojure -X:test \ :dirs "[\"src\" \"src-docs\" \"test\"]" \ :patterns \ - "[\"hyperfiddle.electric.impl.*\" \ - \"hyperfiddle.electric-test\" \ + "[\"hyperfiddle.electric.impl.*\" \ + \"hyperfiddle.electric-test\" \ + \"hyperfiddle.electric-de-test\" \ \"hyperfiddle.zero\" \ \"hyperfiddle.missionary-test\" \ \"contrib.missionary-contrib-test\" \ diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 81aa54c7f..895d5fb01 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -449,7 +449,15 @@ (untwin 'a) := 'a (untwin 'cljs.core/not-in-clj) := 'cljs.core/not-in-clj) -(defn resolve-node [sym]) +(defn node? [mt] (::deps mt)) +(defn resolve-node [sym env] + (case (->env-type env) + :clj (when-some [^clojure.lang.Var vr (resolve env sym)] + (when (-> vr meta node?) + (symbol (-> vr .ns str) (-> vr .sym str)))) + :cljs (when-some [vr (resolve-cljs env sym)] + (when (-> vr :meta node?) + (symbol (-> vr :name str)))))) (defn analyze-clj-symbol [sym] (if (resolve-static-field sym) @@ -473,7 +481,7 @@ (if-some [ref (::electric-let local)] {::lang nil, ::type ::let-ref, ::sym sym, ::ref ref} {::lang nil, ::type ::local, ::sym sym}) - (if-some [nd (resolve-node sym)] + (if-some [nd (resolve-node sym env)] {::lang nil, ::type ::node, ::node nd} (case (get (::peers env) (::current env)) :clj (let [v (analyze-clj-symbol sym)] (case v nil (cannot-resolve! env sym) #_else (assoc v ::lang :clj))) @@ -556,20 +564,20 @@ (case (first form) (let*) (let [[_ bs bform] form] (loopr [ts ts, pe pe, env env] - [[s v] (eduction (partition-all 2) bs)] - (let [e (->id), env (update-in env [:locals s] assoc ::electric-let e)] - (recur (analyze v e env - (-> (ts/add ts {:db/id e, ::parent pe, ::type ::let, ::sym s}) - (?add-source-map e form))) e env)) - (analyze bform pe env ts))) + [[s v] (eduction (partition-all 2) bs)] + (let [e (->id), env (update-in env [:locals s] assoc ::electric-let e)] + (recur (analyze v e env + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::let, ::sym s}) + (?add-source-map e form))) e env)) + (analyze bform pe env ts))) (case) (let [[_ test & brs] form [default brs2] (if (odd? (count brs)) [(last brs) (butlast brs)] [:TODO brs])] (loopr [bs [], mp {}] - [[v br] (partition 2 brs2)] - (let [b (gensym "case-val")] - (recur (conj bs b `(::ctor ~br)) - (reduce (fn [ac nx] (assoc ac (list 'quote nx) b)) mp (if (seq? v) v [v])))) - (recur (?meta form `(let* ~bs (::call (~mp ~test (::ctor ~default))))) pe env ts))) + [[v br] (partition 2 brs2)] + (let [b (gensym "case-val")] + (recur (conj bs b `(::ctor ~br)) + (reduce (fn [ac nx] (assoc ac (list 'quote nx) b)) mp (if (seq? v) v [v])))) + (recur (?meta form `(let* ~bs (::call (~mp ~test (::ctor ~default))))) pe env ts))) (quote) (let [e (->id)] (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form}))) @@ -672,7 +680,8 @@ (ts/add ts (cond-> {:db/id e, ::parent pe, ::type ::var ::var form, ::qualified-var (::sym ret)} (::lang ret) (assoc ::resolved-in (::lang ret))))) - (::node) (throw (ex-info "node todo" {}))) + (::node) (ts/add ts {:db/id e, ::parent pe, ::type ::node, ::node (::node ret)}) + #_else (throw (ex-info (str "unknown symbol type " (::type ret)) (or ret {})))) (?add-source-map e form))) :else @@ -687,18 +696,96 @@ (let [pe (::parent (get (:eav ts) e))] (if (or (nil? pe) (= ::ctor (::type (get (:eav ts) pe)))) pe (recur ts pe)))) -(defn compile [nm form env] +(defn get-node-idx [ts ctor-e ref-e] + (->> (ts/find ts ::ctor-node ctor-e, ::ctor-ref ref-e) first (ts/->node ts) ::node-idx)) + +(defn emit [ts e ctor-e env nm] + ((fn rec [e] + (let [nd (get (:eav ts) e)] + (case (::type nd) + ::literal (::v nd) + ::ap (list* `r/ap (mapv rec (get-children-e ts e))) + ::var (let [in (::resolved-in nd)] + (list* `r/lookup 'frame (keyword (::qualified-var nd)) + (when (or (nil? in) (= in (->env-type env))) [(list `r/pure (::qualified-var nd))]))) + ::node (list `r/lookup 'frame (keyword (::node nd)) (list `r/pure (list `r/make-ctor 'frame (keyword (::node nd)) 0))) + ::join (list `r/join (rec (get-child-e ts e))) + ::pure (list `r/pure (rec (get-child-e ts e))) + ::comp (doall (map rec (get-children-e ts e))) + ::site (recur (get-child-e ts e)) + ::ctor (let [ctor (list `r/make-ctor 'frame nm (::ctor-idx nd)) + frees-e (-> ts :ave ::ctor-free (get e))] + (if (seq frees-e) + (list* `doto ctor + (mapv (fn [e] + (let [nd (ts/->node ts e)] + (list `r/define-free (::free-idx nd) + (case (::closed-over nd) + ::node (list `r/node 'frame (get-node-idx ts (find-ctor-e ts (::ctor-free nd)) (::closed-ref nd))) + ::free (list `r/free 'frame (->> (ts/find ts ::ctor-free (find-ctor-e ts (::ctor-free nd)) + ::closed-ref (::closed-ref nd)) + first (ts/->node ts) ::free-idx)))))) + frees-e)) + ctor)) + ::call (list `r/join (list `r/call 'frame (::call-idx (ts/->node ts e)))) + ::lookup (list `r/lookup 'frame (::sym nd)) + ::let (recur (get-ret-e ts (->let-body-e ts e))) + ::let-ref + (if-some [node-e (first (ts/find ts ::ctor-node ctor-e, ::ctor-ref (::ref nd)))] + (list `r/node 'frame (::node-idx (get (:eav ts) node-e))) + (if-some [free-e (first (ts/find ts ::ctor-free ctor-e, ::closed-ref (::ref nd)))] + (list `r/free 'frame (::free-idx (ts/->node ts free-e))) + (recur (get-ret-e ts (->let-val-e ts (::ref nd)))))) + #_else (throw (ex-info (str "cannot emit on " (pr-str (::type nd))) (or nd {})))))) + e)) + +(defn emit-node-init [ts ctor-e node-e env nm] + (let [nd (get (:eav ts) node-e)] + (list `r/define-node 'frame (::node-idx nd) + (emit ts (get-ret-e ts (->let-val-e ts (::ctor-ref nd))) ctor-e env nm)))) + +(defn emit-call-init [ts ctor-e e env nm] + (list `r/define-call 'frame (::call-idx (ts/->node ts e)) + (emit ts (get-ret-e ts (get-child-e ts e)) ctor-e env nm))) + +(defn get-ordered-ctors-e [ts] + (into [] (map (comp first second)) (->> ts :ave ::ctor-idx (sort-by first)))) + +(defn emit-ctor [ts ctor-e env nm] + (let [ret-e (get-ret-e ts (get-child-e ts ctor-e)) + nodes-e (ts/find ts ::ctor-node ctor-e) + calls-e (ts/find ts ::ctor-call ctor-e)] + `(r/cdef ~(count (ts/find ts ::ctor-free ctor-e)) + ~(mapv #(get-site ts (->> (ts/->node ts %) ::ctor-ref (->let-val-e ts) (get-ret-e ts))) + nodes-e) + ~(mapv #(get-site ts %) calls-e) + ~(get-site ts ret-e) + (fn [~'frame] + ~@(mapv #(emit-node-init ts ctor-e % env nm) nodes-e) + ~@(mapv #(emit-call-init ts ctor-e % env nm) calls-e) + ~(emit ts ret-e ctor-e env nm))))) + +(defn emit-deps [ts e] + (let [mark (fn mark [ts e] + (let [nd (ts/->node ts e)] + (case (::type nd) + (::literal ::var ::lookup) ts + (::ap ::comp) (reduce mark ts (get-children-e ts e)) + (::site ::join ::pure ::call ::ctor) (recur ts (get-child-e ts e)) + (::let) (recur ts (->let-body-e ts e)) + (::let-ref) (recur ts (get-ret-e ts (->let-val-e ts (::ref nd)))) + (::node) (ts/asc ts e ::node-used true) + #_else (throw (ex-info (str "cannot emit-deps/mark on " (pr-str (::type nd))) (or nd {})))))) + es (ts/find (mark ts e) ::node-used true)] + (into #{} (map #(::node (ts/->node ts %))) es))) + +(defn analyze-electric [env {{::keys [->id]} :o :as ts}] (ensure-cljs-compiler - (let [->id (->->id), ->ctor-idx (->->id) - expanded (expand-all env form) - _ (when (::print-expansion env) (fipp.edn/pprint expanded)) - ts (analyze expanded 0 (ensure-cljs-env env) - (ts/add (ts/->ts {::->id ->id}) {:db/id (->id), ::type ::ctor, ::parent '_})) - _ (when (::print-analysis env) (run! prn (->> ts :eav vals (sort-by :db/id)))) + (let [->ctor-idx (->->id) mark-used-ctors (fn mark-used-ctors [ts e] (let [nd (get (:eav ts) e)] (case (::type nd) - (::literal ::var ::lookup) ts + (::literal ::var ::lookup ::node) ts (::ap) (reduce mark-used-ctors ts (get-children-e ts e)) (::site ::join ::pure ::call) (recur ts (get-child-e ts e)) (::ctor) (if (::ctor-idx nd) @@ -708,7 +795,7 @@ (::let-ref) (recur ts (get-ret-e ts (->let-val-e ts (::ref nd)))) #_else (throw (ex-info (str "cannot mark-used-ctors on " (pr-str (::type nd))) (or nd {})))))) ts (mark-used-ctors ts 0) - ctors-e (into [] (map (comp first second)) (->> ts :ave ::ctor-idx (sort-by first))) + ctors-e (get-ordered-ctors-e ts) ->node-idx (let [mp (zipmap ctors-e (repeatedly ->->id))] (fn ->node-idx [ctor-e] ((get mp ctor-e)))) ->free-idx (let [mp (zipmap ctors-e (repeatedly ->->id))] @@ -718,10 +805,6 @@ (cond-> ts (-> ts :ave ::ctor-ref (get ref-e) empty?) (ts/add {:db/id (->id), ::node-idx (->node-idx ctor-e) ::ctor-node ctor-e, ::ctor-ref ref-e})))) - ->node-idx (fn ->node-idx [ts ctor-e ref-e] - (::node-idx (get (:eav ts) - (first (set/intersection (-> ts :ave ::ctor-node (get ctor-e)) - (-> ts :ave ::ctor-ref (get ref-e))))))) ensure-free-node (fn ensure-free-node [ts ref-e ctor-e] (cond-> ts (empty? (set/intersection (-> ts :ave ::ctor-free (get ctor-e)) (-> ts :ave ::closed-ref (get ref-e)))) @@ -744,7 +827,7 @@ handle-let-refs (fn handle-let-refs [ts e] ; nodes and frees (closed over) (let [nd (ts/->node ts e)] (case (::type nd) - (::literal ::var ::lookup) ts + (::literal ::var ::lookup ::node) ts (::ap) (reduce handle-let-refs ts (get-children-e ts e)) (::site ::join ::pure ::ctor ::call) (recur ts (get-child-e ts e)) (::let) (recur ts (->let-body-e ts e)) @@ -775,7 +858,7 @@ mark-used-calls (fn mark-used-calls [ts ctor-e e] (let [nd (ts/->node ts e)] (case (::type nd) - (::literal ::var ::lookup) ts + (::literal ::var ::lookup ::node) ts (::ap) (reduce #(mark-used-calls % ctor-e %2) ts (get-children-e ts e)) (::site ::join ::pure) (recur ts ctor-e (get-child-e ts e)) (::ctor) (recur ts e (get-child-e ts e)) @@ -804,64 +887,19 @@ ts (reverse (ts/find ts ::type ::ap)))) ts (-> ts (handle-let-refs 0) (mark-used-calls 0 (get-ret-e ts (get-child-e ts 0))) - collapse-ap-with-only-pures) - gen (fn gen [ts ctor-e e] - (let [nd (get (:eav ts) e)] - (case (::type nd) - ::literal (::v nd) - ::ap (list* `r/ap (mapv #(gen ts ctor-e %) (get-children-e ts e))) - ::var (let [in (::resolved-in nd)] - (list* `r/lookup 'frame (keyword (::qualified-var nd)) - (when (or (nil? in) (= in (->env-type env))) [(list `r/pure (::qualified-var nd))]))) - ::join (list `r/join (gen ts ctor-e (get-child-e ts e))) - ::pure (list `r/pure (gen ts ctor-e (get-child-e ts e))) - ::comp (doall (map #(gen ts ctor-e %) (get-children-e ts e))) - ::site (recur ts ctor-e (get-child-e ts e)) - ::ctor (let [ctor (list `r/make-ctor 'frame nm (::ctor-idx nd)) - frees-e (-> ts :ave ::ctor-free (get e))] - (if (seq frees-e) - (list* `doto ctor - (mapv (fn [e] - (let [nd (ts/->node ts e)] - (list `r/define-free (::free-idx nd) - (case (::closed-over nd) - ::node (list `r/node 'frame (->node-idx ts (find-ctor-e ts (::ctor-free nd)) (::closed-ref nd))) - ::free (list `r/free 'frame (->> (ts/find ts ::ctor-free (find-ctor-e ts (::ctor-free nd)) - ::closed-ref (::closed-ref nd)) - first (ts/->node ts) ::free-idx)))))) - frees-e)) - ctor)) - ::call (list `r/join (list `r/call 'frame (::call-idx (ts/->node ts e)))) - ::lookup (list `r/lookup 'frame (::sym nd)) - ::let (recur ts ctor-e (get-ret-e ts (->let-body-e ts e))) - ::let-ref - (if-some [node-e (first (ts/find ts ::ctor-node ctor-e, ::ctor-ref (::ref nd)))] - (list `r/node 'frame (::node-idx (get (:eav ts) node-e))) - (if-some [free-e (first (ts/find ts ::ctor-free ctor-e, ::closed-ref (::ref nd)))] - (list `r/free 'frame (::free-idx (ts/->node ts free-e))) - (recur ts ctor-e (get-ret-e ts (->let-val-e ts (::ref nd)))))) - #_else (throw (ex-info (str "cannot gen on " (pr-str (::type nd))) (or nd {})))))) - gen-node-init (fn gen-node-init [ts ctor-e node-e] - (let [nd (get (:eav ts) node-e)] - (list `r/define-node 'frame (::node-idx nd) - (gen ts ctor-e (get-ret-e ts (->let-val-e ts (::ctor-ref nd))))))) - gen-call-init (fn gen-call-init [ts ctor-e e] - (list `r/define-call 'frame (::call-idx (ts/->node ts e)) - (gen ts ctor-e (get-ret-e ts (get-child-e ts e)))))] + collapse-ap-with-only-pures)] (when (::print-db env) (run! prn (->> ts :eav vals (sort-by :db/id)))) - (let [ret (->> ctors-e - (mapv (fn [ctor-e] - (let [ret-e (get-ret-e ts (get-child-e ts ctor-e)) - nodes-e (ts/find ts ::ctor-node ctor-e) - calls-e (ts/find ts ::ctor-call ctor-e)] - `(r/cdef ~(count (ts/find ts ::ctor-free ctor-e)) - ~(mapv #(get-site ts (->> (ts/->node ts %) ::ctor-ref (->let-val-e ts) (get-ret-e ts))) - nodes-e) - ~(mapv #(get-site ts %) calls-e) - ~(get-site ts ret-e) - (fn [~'frame] - ~@(mapv #(gen-node-init ts ctor-e %) nodes-e) - ~@(mapv #(gen-call-init ts ctor-e %) calls-e) - ~(gen ts ctor-e ret-e)))))))] - (when (::print-source env) (fipp.edn/pprint ret)) - ret)))) + ts))) + +(defn compile* [nm env ts] + (ensure-cljs-compiler + (let [ts (analyze-electric env ts) + ret (->> (get-ordered-ctors-e ts) (mapv #(emit-ctor ts % env nm)))] + (when (::print-source env) (fipp.edn/pprint ret)) + ret))) + +(defn compile [nm form env] + (ensure-cljs-compiler + (compile* nm env + (analyze (expand-all env `(::ctor ~form)) + '_ (ensure-cljs-env env) (ts/->ts {::->id (->->id)}))))) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 6bea2fcc9..72b6c4fff 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -1,6 +1,7 @@ (ns hyperfiddle.electric.impl.runtime-de (:require [hyperfiddle.incseq :as i] - [missionary.core :as m]) + [missionary.core :as m] + [contrib.assert :as ca]) #?(:clj (:import (clojure.lang IFn IDeref)))) (deftype Peer [step done defs ^objects state] @@ -218,7 +219,7 @@ "Returns a fresh constructor for cdef coordinates key and idx." [^Frame frame key idx] (let [^Peer peer (ctor-peer (frame-ctor frame)) - ^Cdef cdef (((.-defs peer) key) idx)] + ^Cdef cdef ((ca/check some? ((.-defs peer) key) {:key key}) idx)] (->Ctor peer key idx (object-array (.-frees cdef)) {}))) (defn node diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 95078985a..9e51f516c 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -1,8 +1,12 @@ (ns hyperfiddle.electric-de - (:refer-clojure :exclude [fn]) + (:refer-clojure :exclude [fn defn]) (:require [hyperfiddle.electric.impl.lang-de2 :as lang] [hyperfiddle.electric.impl.runtime-de :as r] [hyperfiddle.incseq :as i] + [clojure.core :as cc] + [hyperfiddle.rcf :as rcf :refer [tests]] + #?(:clj [contrib.triple-store :as ts]) + #?(:clj [fipp.edn]) [missionary.core :as m] [hyperfiddle.electric-local-def-de :as l]) #?(:cljs (:require-macros hyperfiddle.electric-de))) @@ -31,6 +35,30 @@ Returns the successive states of items described by `incseq`. (let [~@(interleave bs (eduction (map #(list ::lang/lookup %)) (range)))] ~@body))) +(cc/defn ns-qualify [sym] (if (namespace sym) sym (symbol (str *ns*) (str sym)))) + +(tests + (ns-qualify 'foo) := `foo + (ns-qualify 'a/b) := 'a/b) + +(defmacro defn [nm bs & body] + (lang/ensure-cljs-compiler + (let [env (merge (meta nm) (lang/ensure-cljs-env (lang/normalize-env &env)) l/web-config) + expanded (lang/expand-all env `(fn ~bs ~@body)) + ts (lang/analyze expanded '_ env (ts/->ts {::lang/->id (lang/->->id)})) + ts (lang/analyze-electric env ts) + ctors (mapv #(lang/emit-ctor ts % env (-> nm ns-qualify keyword)) (lang/get-ordered-ctors-e ts)) + nm (with-meta nm {::lang/deps []})] + (when (::lang/print-source env) (fipp.edn/pprint ctors)) + `(def ~nm ~ctors)))) + +#_(defmacro defn [nm bs & body] + ;; TODO cleanup env setup + (let [env (merge (lang/normalize-env &env) l/web-config) + ts (lang/analyze* env `(hyperfiddle.electric-de/fn ~bs ~@body)) + nm2 (vary-meta nm assoc ::lang/deps (lang/->deps ts))] + `(def ~nm2 ~(lang/compile* ts)))) + (defmacro amb " Syntax : ```clojure diff --git a/src/hyperfiddle/electric_local_def_de.cljc b/src/hyperfiddle/electric_local_def_de.cljc index f83427083..1d5c51b7d 100644 --- a/src/hyperfiddle/electric_local_def_de.cljc +++ b/src/hyperfiddle/electric_local_def_de.cljc @@ -3,9 +3,11 @@ #?(:cljs (:require-macros hyperfiddle.electric-local-def-de)) (:require [clojure.core :as cc] [contrib.assert :as ca] + #?(:clj [fipp.edn]) [contrib.cljs-target] [hyperfiddle.electric.impl.lang-de2 :as lang] [hyperfiddle.electric.impl.runtime-de :as r] + #?(:clj [contrib.triple-store :as ts]) #?(:clj [hyperfiddle.rcf.analyzer :as ana]) ; todo remove [missionary.core :as m])) @@ -27,5 +29,15 @@ (defn run-single [frame] (m/reduce #(do %2) nil frame)) #?(:clj (defmacro single {:style/indent 1} [conf & body] (ca/check map? conf) - (let [env (merge (->local-config &env) (lang/normalize-env &env) conf)] - `(run-single (r/root-frame {::Main ~(lang/compile ::Main `(do ~@body) env)} ::Main))))) + (lang/ensure-cljs-compiler + (let [env (merge (->local-config &env) (lang/normalize-env &env) conf) + expanded (lang/expand-all env `(::lang/ctor (do ~@body))) + ts (lang/analyze expanded '_ env (ts/->ts {::lang/->id (lang/->->id)})) + ts (lang/analyze-electric env ts) + ctors (mapv #(lang/emit-ctor ts % env ::Main) (lang/get-ordered-ctors-e ts)) + ret-e (lang/get-ret-e ts (lang/get-child-e ts 0)) + deps (lang/emit-deps ts ret-e) + defs (into {} (map (fn [dep] [(keyword dep) dep])) deps) + defs (assoc defs ::Main ctors)] + (when (::lang/print-defs env) (fipp.edn/pprint defs)) + `(run-single (r/root-frame ~defs ::Main)))))) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 527791b99..b75983c19 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -182,10 +182,9 @@ (with ((l/single {} (tap ($ (e/fn [x] (inc x)) 1))) tap tap) % := 2)) -;; TODO defn -;; (l/defn My-inc [x] (inc x)) -(skip "reactive defn" - (with ((l/single {} (tap (My-inc. 1))) tap tap) +(e/defn My-inc [x] (inc x)) +(tests "reactive defn" + (with ((l/single {} (tap ($ My-inc 1))) tap tap) % := 2)) ;; TODO defn @@ -464,7 +463,7 @@ (new (e/fn [x] x) x)]))) tap tap) % := [0 0 0 0 0])) -(tests "reactive closures" +#_(tests "reactive closures" (def !x (atom 1)) (def !y (atom 10)) (with ((l/single {::lang/print-source true} From 036fc71bb5be7a84dafdd7ea515047d4c64a98c2 Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 12 Feb 2024 10:12:21 +0100 Subject: [PATCH 094/428] compiler: fix in-call check --- src/hyperfiddle/electric/impl/lang_de2.clj | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 895d5fb01..2300193fa 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -840,7 +840,8 @@ (::parent (ts/->node ts e))))) ts (ts/asc ts (::ref nd) ::walked-val true) ; only walk binding once ts (cond-> ts (in-a-call? ts e) - (ts/upd (::ref nd) ::in-call #(conj (or % #{}) e))) + (-> (ts/upd (::ref nd) ::in-call #(conj (or % #{}) e)) + (ensure-node (::ref nd)))) ts (if (seq ctors-e) ; closed over (-> ts (ensure-node (::ref nd)) (ensure-free-node (::ref nd) (first ctors-e)) From a6d467a0a85a72911269ef6acfb350b5492ac59f Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 12 Feb 2024 10:12:57 +0100 Subject: [PATCH 095/428] compiler: ordered calls --- src/hyperfiddle/electric/impl/lang_de2.clj | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 2300193fa..254a085b2 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -751,10 +751,13 @@ (defn get-ordered-ctors-e [ts] (into [] (map (comp first second)) (->> ts :ave ::ctor-idx (sort-by first)))) +(defn get-ordered-calls-e [ts ctor-e] + (->> (ts/find ts ::ctor-call ctor-e) (sort-by #(::call-idx (ts/->node ts %))))) + (defn emit-ctor [ts ctor-e env nm] (let [ret-e (get-ret-e ts (get-child-e ts ctor-e)) nodes-e (ts/find ts ::ctor-node ctor-e) - calls-e (ts/find ts ::ctor-call ctor-e)] + calls-e (get-ordered-calls-e ts ctor-e) #_ (ts/find ts ::ctor-call ctor-e)] `(r/cdef ~(count (ts/find ts ::ctor-free ctor-e)) ~(mapv #(get-site ts (->> (ts/->node ts %) ::ctor-ref (->let-val-e ts) (get-ret-e ts))) nodes-e) @@ -865,9 +868,9 @@ (::ctor) (recur ts e (get-child-e ts e)) (::call) (if (::call-idx nd) ts - (recur (-> ts (ts/asc e ::call-idx (->call-idx ctor-e)) - (ts/asc e ::ctor-call ctor-e)) - ctor-e (get-child-e ts e))) + (-> (mark-used-calls ts ctor-e (get-child-e ts e)) + (ts/asc e ::call-idx (->call-idx ctor-e)) + (ts/asc e ::ctor-call ctor-e))) (::let) (recur ts ctor-e (->let-body-e ts e)) (::let-ref) (let [nx-e (get-ret-e ts (->let-val-e ts (::ref nd)))] (recur ts (find-ctor-e ts nx-e) nx-e)) From 3aa7313e5db6ff30086ca5fbc388e70f8aca9fd8 Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 12 Feb 2024 17:06:04 +0100 Subject: [PATCH 096/428] compiler: ordered effects --- src/hyperfiddle/electric/impl/lang_de2.clj | 112 +++++++++++------- .../electric/impl/compiler_test.cljc | 27 ++++- test/hyperfiddle/electric_de_test.cljc | 37 +++--- 3 files changed, 114 insertions(+), 62 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 254a085b2..f844bd1f5 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -754,18 +754,42 @@ (defn get-ordered-calls-e [ts ctor-e] (->> (ts/find ts ::ctor-call ctor-e) (sort-by #(::call-idx (ts/->node ts %))))) +(defn get-ordered-nodes-e [ts ctor-e] + (->> (ts/find ts ::ctor-node ctor-e) (sort-by #(::node-idx (ts/->node ts %))))) + +(defn compute-effect-order [ts e] + (let [->order (->->id), ord (fn [ts e] (ts/upd ts e ::fx-order #(or % (->order))))] + ((fn rec [ts e] + (let [nd (ts/->node ts e)] + (if (::fx-order nd) + ts + (case (::type nd) + (::literal ::var ::lookup ::node) (ord ts e) + (::ap ::comp) (ord (reduce rec ts (get-children-e ts e)) e) + (::site ::join ::pure ::call ::ctor) (ord (rec ts (get-child-e ts e)) e) + (::let) (recur ts (->let-body-e ts e)) + (::let-ref) (ord (rec ts (->let-val-e ts (::ref nd))) (::ref nd)) + #_else (throw (ex-info (str "cannot compure-effect-order on " (pr-str (::type nd))) (or nd {}))) + )))) + ts e))) + (defn emit-ctor [ts ctor-e env nm] (let [ret-e (get-ret-e ts (get-child-e ts ctor-e)) - nodes-e (ts/find ts ::ctor-node ctor-e) - calls-e (get-ordered-calls-e ts ctor-e) #_ (ts/find ts ::ctor-call ctor-e)] + nodes-e (get-ordered-nodes-e ts ctor-e) + calls-e (get-ordered-calls-e ts ctor-e)] `(r/cdef ~(count (ts/find ts ::ctor-free ctor-e)) ~(mapv #(get-site ts (->> (ts/->node ts %) ::ctor-ref (->let-val-e ts) (get-ret-e ts))) nodes-e) ~(mapv #(get-site ts %) calls-e) ~(get-site ts ret-e) (fn [~'frame] - ~@(mapv #(emit-node-init ts ctor-e % env nm) nodes-e) - ~@(mapv #(emit-call-init ts ctor-e % env nm) calls-e) + ~@(let [node-inits (->> nodes-e (mapv (fn [e] [(->> e (ts/->node ts) ::ctor-ref (ts/->node ts) ::fx-order) + (emit-node-init ts ctor-e e env nm)]))) + call-inits (->> calls-e (mapv (fn [e] [(->> e (ts/->node ts) ::fx-order) + (emit-call-init ts ctor-e e env nm)])))] + ;; with xforms would be + ;; (into [] (comp cat (x/sort-by first) (map second)) [node-inits call-inits]) + (->> (concat node-inits call-inits) (sort-by first) (eduction (map second)))) ~(emit ts ret-e ctor-e env nm))))) (defn emit-deps [ts e] @@ -784,12 +808,26 @@ (defn analyze-electric [env {{::keys [->id]} :o :as ts}] (ensure-cljs-compiler - (let [->ctor-idx (->->id) + (let [change-parent (fn change-parent [ts e pe] (ts/asc ts e ::parent pe)) + orphan (fn orphan [ts e] (change-parent ts e nil)) + collapse-ap-with-only-pures (fn collapse-ap-with-only-pures [ts] ; (r/ap (r/pure .)+ ) => (r/pure (::comp . . .)) + (reduce (fn [ts ap-e] + (let [[f-e & args-e :as children-e] (get-children-e ts ap-e)] + (if (every? #(= ::pure (::type (ts/->node ts %))) children-e) + (reduce (fn [ts e] + (-> ts (change-parent (get-child-e ts e) f-e) + (orphan e))) + ;; reuse nodes, otherwise node ordering messes up + (-> ts (ts/asc ap-e ::type ::pure) (ts/asc f-e ::type ::comp)) + args-e) + ts))) + ts (reverse (ts/find ts ::type ::ap)))) + ->ctor-idx (->->id) mark-used-ctors (fn mark-used-ctors [ts e] (let [nd (get (:eav ts) e)] (case (::type nd) (::literal ::var ::lookup ::node) ts - (::ap) (reduce mark-used-ctors ts (get-children-e ts e)) + (::ap ::comp) (reduce mark-used-ctors ts (get-children-e ts e)) (::site ::join ::pure ::call) (recur ts (get-child-e ts e)) (::ctor) (if (::ctor-idx nd) ts @@ -797,29 +835,35 @@ (::let) (recur ts (->let-body-e ts e)) (::let-ref) (recur ts (get-ret-e ts (->let-val-e ts (::ref nd)))) #_else (throw (ex-info (str "cannot mark-used-ctors on " (pr-str (::type nd))) (or nd {})))))) - ts (mark-used-ctors ts 0) + ts (-> ts collapse-ap-with-only-pures + (compute-effect-order 0) + (mark-used-ctors 0)) ctors-e (get-ordered-ctors-e ts) - ->node-idx (let [mp (zipmap ctors-e (repeatedly ->->id))] - (fn ->node-idx [ctor-e] ((get mp ctor-e)))) - ->free-idx (let [mp (zipmap ctors-e (repeatedly ->->id))] - (fn ->free-idx [ctor-e] ((get mp ctor-e)))) ensure-node (fn ensure-node [ts ref-e] (let [ctor-e (find-ctor-e ts ref-e)] - (cond-> ts (-> ts :ave ::ctor-ref (get ref-e) empty?) - (ts/add {:db/id (->id), ::node-idx (->node-idx ctor-e) - ::ctor-node ctor-e, ::ctor-ref ref-e})))) + (cond-> ts (empty? (ts/find ts ::ctor-ref ref-e)) + (ts/add {:db/id (->id) ::ctor-node ctor-e, ::ctor-ref ref-e})))) ensure-free-node (fn ensure-free-node [ts ref-e ctor-e] - (cond-> ts (empty? (set/intersection (-> ts :ave ::ctor-free (get ctor-e)) - (-> ts :ave ::closed-ref (get ref-e)))) - (ts/add {:db/id (->id), ::free-idx (->free-idx ctor-e) ::ctor-free ctor-e - ::closed-ref ref-e, ::closed-over ::node}))) + (cond-> ts (empty? (ts/find ts ::ctor-free ctor-e, ::closed-ref ref-e)) + (ts/add {:db/id (->id) ::ctor-free ctor-e, ::closed-ref ref-e, ::closed-over ::node}))) ensure-free-free (fn ensure-free-free [ts ref-e ctor-e] - (cond-> ts (empty? (set/intersection (-> ts :ave ::ctor-free (get ctor-e)) - (-> ts :ave ::closed-ref (get ref-e)))) - (ts/add {:db/id (->id), ::free-idx (->free-idx ctor-e) ::ctor-free ctor-e - ::closed-ref ref-e, ::closed-over ::free}))) + (cond-> ts (empty? (ts/find ts ::ctor-free ctor-e, ::closed-ref ref-e)) + (ts/add {:db/id (->id) ::ctor-free ctor-e, ::closed-ref ref-e, ::closed-over ::free}))) ensure-free-frees (fn ensure-free-frees [ts ref-e ctors-e] (reduce (fn [ts ctor-e] (ensure-free-free ts ref-e ctor-e)) ts ctors-e)) + order-nodes (fn order-nodes [ts] + (reduce (fn [ts nodes-e] + (let [->idx (->->id)] + (reduce (fn [ts e] (ts/asc ts e ::node-idx (->idx))) + ts (sort-by #(->> % (ts/->node ts) ::ctor-ref (ts/->node ts) ::fx-order) + nodes-e)))) + ts (-> ts :ave ::ctor-node vals))) + order-frees (fn order-frees [ts] + (reduce (fn [ts frees-e] + (let [->idx (->->id)] + (reduce (fn [ts e] (ts/asc ts e ::free-idx (->idx))) + ts (sort-by #(::fx-order (ts/->node ts %)) frees-e) #_(sort-by-fx-order ts frees-e)))) + ts (-> ts :ave ::ctor-free vals))) in-a-call? (fn in-a-call? [ts e] (loop [e (::parent (ts/->node ts e))] (when-let [nd (ts/->node ts e)] @@ -831,7 +875,7 @@ (let [nd (ts/->node ts e)] (case (::type nd) (::literal ::var ::lookup ::node) ts - (::ap) (reduce handle-let-refs ts (get-children-e ts e)) + (::ap ::comp) (reduce handle-let-refs ts (get-children-e ts e)) (::site ::join ::pure ::ctor ::call) (recur ts (get-child-e ts e)) (::let) (recur ts (->let-body-e ts e)) (::let-ref) @@ -842,6 +886,7 @@ (recur (cond-> ac (= ::ctor (::type (ts/->node ts e))) (conj e)) (::parent (ts/->node ts e))))) ts (ts/asc ts (::ref nd) ::walked-val true) ; only walk binding once + ;; TODO is this necessary? If not we could inline more ts (cond-> ts (in-a-call? ts e) (-> (ts/upd (::ref nd) ::in-call #(conj (or % #{}) e)) (ensure-node (::ref nd)))) @@ -863,7 +908,7 @@ (let [nd (ts/->node ts e)] (case (::type nd) (::literal ::var ::lookup ::node) ts - (::ap) (reduce #(mark-used-calls % ctor-e %2) ts (get-children-e ts e)) + (::ap ::comp) (reduce #(mark-used-calls % ctor-e %2) ts (get-children-e ts e)) (::site ::join ::pure) (recur ts ctor-e (get-child-e ts e)) (::ctor) (recur ts e (get-child-e ts e)) (::call) (if (::call-idx nd) @@ -875,23 +920,8 @@ (::let-ref) (let [nx-e (get-ret-e ts (->let-val-e ts (::ref nd)))] (recur ts (find-ctor-e ts nx-e) nx-e)) #_else (throw (ex-info (str "cannot mark-used-calls on " (::type nd)) (or nd {})))))) - change-parent (fn change-parent [ts e pe] (ts/asc ts e ::parent pe)) - orphan (fn orphan [ts e] (change-parent ts e nil)) - collapse-ap-with-only-pures (fn collapse-ap-with-only-pures [ts] ; (r/ap (r/pure .)+ ) => (r/pure (::comp . . .)) - (reduce (fn [ts ap-e] - (let [[f-e & args-e :as children-e] (get-children-e ts ap-e)] - (if (every? #(= ::pure (::type (ts/->node ts %))) children-e) - (reduce (fn [ts e] - (-> ts (change-parent (get-child-e ts e) f-e) - (orphan e))) - ;; reuse nodes, otherwise node ordering messes up - (-> ts (ts/asc ap-e ::type ::pure) (ts/asc f-e ::type ::comp)) - args-e) - ts))) - ts (reverse (ts/find ts ::type ::ap)))) - ts (-> ts (handle-let-refs 0) - (mark-used-calls 0 (get-ret-e ts (get-child-e ts 0))) - collapse-ap-with-only-pures)] + ts (-> ts (handle-let-refs 0) order-nodes order-frees + (mark-used-calls 0 (get-ret-e ts (get-child-e ts 0))))] (when (::print-db env) (run! prn (->> ts :eav vals (sort-by :db/id)))) ts))) diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index 2ee5143e3..b5018ad58 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -466,11 +466,11 @@ (fn [~'frame] (r/pure (clojure.core/vector 1 2))))])) -(tests "successive calls" +(tests "ordering" (match (l/test-compile ::Main (::lang/call (::lang/call (::lang/ctor (::lang/ctor :foo))))) `[(r/cdef 0 [] [nil nil] nil (fn [~'frame] - (r/define-call ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) + (r/define-call ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) ; must come first (r/define-call ~'frame 1 (r/join (r/call ~'frame 0))) (r/join (r/call ~'frame 1)))) (r/cdef 0 [] [] nil @@ -478,7 +478,28 @@ (r/pure (r/make-ctor ~'frame ::Main 2)))) (r/cdef 0 [] [] nil (fn [~'frame] - (r/pure :foo)))])) + (r/pure :foo)))]) + (match (l/test-compile ::Main (let [x 1, y 2] [y x x y])) + `[(r/cdef 0 [nil nil] [] nil + (fn [~'frame] + (r/define-node ~'frame 0 (r/pure 2)) + (r/define-node ~'frame 1 (r/pure 1)) + (r/ap (r/pure clojure.core/vector) + (r/node ~'frame 0) (r/node ~'frame 1) (r/node ~'frame 1) (r/node ~'frame 0))))]) + (match (l/test-compile ::Main (let [x 1] [(::lang/call (::lang/ctor 1)) x x (::lang/call (::lang/ctor 2))])) + `[(r/cdef 0 [nil] [nil nil] nil + (fn [~'frame] + (r/define-call ~'frame 0 (r/pure (r/make-ctor ~'frame :hyperfiddle.electric.impl.compiler-test/Main 1))) + (r/define-node ~'frame 0 (r/pure 1)) + (r/define-call ~'frame 1 (r/pure (r/make-ctor ~'frame :hyperfiddle.electric.impl.compiler-test/Main 2))) + (r/ap (r/pure clojure.core/vector) + (r/join (r/call ~'frame 0)) + (r/node ~'frame 0) + (r/node ~'frame 0) + (r/join (r/call ~'frame 1))))) + (r/cdef 0 [] [] nil (fn [~'frame] (r/pure 1))) + (r/cdef 0 [] [] nil (fn [~'frame] (r/pure 2)))]) + ) (comment (l/test-compile ::Main (let [fizz "fizz", buzz "buzz"] diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index b75983c19..e779ef1a0 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -187,26 +187,28 @@ (with ((l/single {} (tap ($ My-inc 1))) tap tap) % := 2)) -;; TODO defn -(skip "control flow implemented with lazy signals" - (l/defn If2 [x a b] ; Key question - how lazy are the parameters? +(tests "control flow implemented with lazy signals" + (e/defn If2 [x a b] ; Key question - how lazy are the parameters? (->> (boolean x) (get {true (e/fn [] a) false (e/fn [] b)}) - (new))) + ($))) (def !x (atom false)) (def !a (atom :a)) (def !b (atom :b)) (with ((l/single {} (let [x (e/watch !x) - a (tap (e/watch !a)) ; lazy - b (tap (e/watch !b))] ; lazy - (tap (If2. x a b)))) tap tap) - % := :a + a (tap (e/watch !a)) ; lazy + b (tap (e/watch !b))] ; lazy + (tap ($ If2 x a b)))) tap tap) % := :b % := :b (swap! !x not) - % := :a)) + % := :a + % := :a + (swap! !x not) + % := :b + % := :b)) (tests "lazy let" (def !x (atom false)) @@ -314,7 +316,7 @@ (swap! !xs conj 4) % := [2 3 4 5])) -(skip "reactive for is differential (diff/patch)" +(tests "reactive for is differential (diff/patch)" (def !xs (atom [1 2 3])) (with ((l/single {} (tap (e/for-by identity [x (e/watch !xs)] (tap x)))) tap tap) (hash-set % % %) := #{1 2 3} ; concurrent, order undefined @@ -328,11 +330,11 @@ % := :b % := [1 :b 3])) -;; (l/def foo 0) -(skip "Reactive for with bindings" +(def foo 0) +(tests "Reactive for with bindings" (def !items (atom ["a"])) (with ((l/single {} (binding [foo 1] - (e/for [item (e/watch !items)] + (e/for-by identity [item (e/watch !items)] (tap foo) item))) tap tap) @@ -340,7 +342,7 @@ (swap! !items conj "b") % := 1)) ; If 0 -> foo’s binding vanished -(skip "reactive for with keyfn" +(tests "reactive for with keyfn" (def !xs (atom [{:id 1 :name "alice"} {:id 2 :name "bob"}])) (with ((l/single {} (tap (e/for-by :id [x (e/watch !xs)] (tap x)))) tap tap) (hash-set % %) := #{{:id 1 :name "alice"} {:id 2 :name "bob"}} @@ -420,14 +422,13 @@ % := 1))) ; mutable map is clojure.core/=, therefore skipped (def trace!) -;; (l/defn Div [child] (trace! child) [:div child]) -;; (l/defn Widget [x] (Div. [(Div. x) (Div. :a)])) +(e/defn Div [child] (trace! child) [:div child]) +(e/defn Widget [x] ($ Div [($ Div x) ($ Div :a)])) -;; TODO defn (skip "reactive defn" ; best example of this is hiccup incremental maintenance (def !x (atom 0)) - (with ((l/single {} (tap (binding [trace! tap] (Widget. (e/watch !x))))) tap tap) + (with ((l/single {} (tap (binding [trace! tap] ($ Widget (e/watch !x))))) tap tap) % := 0 % := :a % := [[:div 0] [:div :a]] From 8afbaabb9cf448d5d9c7f4a8cb718c1da4161f87 Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 12 Feb 2024 17:48:40 +0100 Subject: [PATCH 097/428] checkpoint --- src/hyperfiddle/electric/impl/lang_de2.clj | 4 +- src/hyperfiddle/electric_de.cljc | 3 +- src/hyperfiddle/electric_local_def_de.cljc | 10 ++ test/hyperfiddle/electric_de_test.cljc | 119 ++++++++++----------- 4 files changed, 71 insertions(+), 65 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index f844bd1f5..45bf0cc11 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -804,7 +804,9 @@ (::node) (ts/asc ts e ::node-used true) #_else (throw (ex-info (str "cannot emit-deps/mark on " (pr-str (::type nd))) (or nd {})))))) es (ts/find (mark ts e) ::node-used true)] - (into #{} (map #(::node (ts/->node ts %))) es))) + (into (sorted-set) (map #(::node (ts/->node ts %))) es))) + +(defn get-deps [sym] (-> sym resolve meta ::deps)) (defn analyze-electric [env {{::keys [->id]} :o :as ts}] (ensure-cljs-compiler diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 9e51f516c..8fac1ea2b 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -48,7 +48,8 @@ Returns the successive states of items described by `incseq`. ts (lang/analyze expanded '_ env (ts/->ts {::lang/->id (lang/->->id)})) ts (lang/analyze-electric env ts) ctors (mapv #(lang/emit-ctor ts % env (-> nm ns-qualify keyword)) (lang/get-ordered-ctors-e ts)) - nm (with-meta nm {::lang/deps []})] + deps (lang/emit-deps ts 0) + nm (with-meta nm `{::lang/deps '~deps})] (when (::lang/print-source env) (fipp.edn/pprint ctors)) `(def ~nm ~ctors)))) diff --git a/src/hyperfiddle/electric_local_def_de.cljc b/src/hyperfiddle/electric_local_def_de.cljc index 1d5c51b7d..d1d06dd3e 100644 --- a/src/hyperfiddle/electric_local_def_de.cljc +++ b/src/hyperfiddle/electric_local_def_de.cljc @@ -26,6 +26,15 @@ ([nm form] `(test-compile ~nm {} ~form)) ([nm env form] `(lang/compile ~nm '~form (merge web-config (lang/normalize-env ~env)))))) +(defn collect-deps [deps] + (loop [ret (sorted-set) deps deps] + (if-some [d (first deps)] + (if (ret d) + (recur ret (disj deps d)) + (let [dds (lang/get-deps d)] + (recur (conj ret d) (into deps dds)))) + ret))) + (defn run-single [frame] (m/reduce #(do %2) nil frame)) #?(:clj (defmacro single {:style/indent 1} [conf & body] (ca/check map? conf) @@ -37,6 +46,7 @@ ctors (mapv #(lang/emit-ctor ts % env ::Main) (lang/get-ordered-ctors-e ts)) ret-e (lang/get-ret-e ts (lang/get-child-e ts 0)) deps (lang/emit-deps ts ret-e) + deps (collect-deps deps) defs (into {} (map (fn [dep] [(keyword dep) dep])) deps) defs (assoc defs ::Main ctors)] (when (::lang/print-defs env) (fipp.edn/pprint defs)) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index e779ef1a0..b5de83360 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -5,7 +5,7 @@ [hyperfiddle.electric.impl.lang-de2 :as lang] [missionary.core :as m])) -(defmacro skip [& _body] +(defmacro skip {:style/indent 0} [& _body] `(pr '~'-)) (tests "call on local electric ctor" @@ -425,7 +425,7 @@ (e/defn Div [child] (trace! child) [:div child]) (e/defn Widget [x] ($ Div [($ Div x) ($ Div :a)])) -(skip "reactive defn" +(tests "reactive defn" ; best example of this is hiccup incremental maintenance (def !x (atom 0)) (with ((l/single {} (tap (binding [trace! tap] ($ Widget (e/watch !x))))) tap tap) @@ -439,17 +439,15 @@ % := [[:div 1] [:div :a]] % := [:div [[:div 1] [:div :a]]])) -;; (l/def G (e/fn [x] x)) ; reactive fn (DAG). Compiler marks dag with meta -;; TODO defn -(skip "node call vs fn call" +(e/defn G [x] x) ; reactive fn (DAG). Compiler marks dag with meta +(tests "node call vs fn call" (defn f [x] x) ; This var is not marked with meta (def !x (atom 0)) - (with ((l/single {} (tap (let [x (e/watch !x)] [(f x) (G. x)]))) tap tap) + (with ((l/single {} (tap (let [x (e/watch !x)] [(f x) ($ G x)]))) tap tap) % := [0 0])) -;; (l/def G (e/fn [x] x)) -;; TODO defn -(skip "higher order dags" +(e/defn G [x] x) +(tests "higher order dags" (def !x (atom 0)) (defn f [x] x) (with @@ -458,20 +456,20 @@ Gg (e/fn [x] x) ; but you almost always want reactive lambda, not cc/fn x (e/watch !x)] [(f x) ; var marked - (G. x) ; var says node + ($ G x) ; var says node (ff x) ; Must assume interop, for compat with clojure macros - (Gg. x) ; Must mark reactive-call - (new (e/fn [x] x) x)]))) tap tap) + ($ Gg x) ; Must mark reactive-call + ($ (e/fn [x] x) x)]))) tap tap) % := [0 0 0 0 0])) -#_(tests "reactive closures" +(tests "reactive closures" (def !x (atom 1)) (def !y (atom 10)) (with ((l/single {::lang/print-source true} (let [x (e/watch !x), y (e/watch !y)] (tap ($ (if (odd? x) - (e/fn [x] (prn :x1 x) (* y x)) - (e/fn [x] (prn :x2 x) (* y x))) + (e/fn [x] (* y x)) + (e/fn [x] (* y x))) x)))) tap tap) % := 10 (swap! !x inc) @@ -481,26 +479,9 @@ (swap! !y inc) % := 33 (swap! !y inc) - % := 36 - % := :foo - % := :bar - )) - -(comment - (def !x (atom 1)) - (def it ((l/single {::lang/print-source true} - (let [x (e/watch !x)] - (tap (if (odd? x) - (prn :x1 x) - (prn :x2 x))))) - prn prn)) - ;; :x1 1 - (swap! !x inc) - ;; :x1 2 - ;; :x2 2 - ) + % := 36)) -(skip "reactive closures 2" +(tests "reactive closures 2" (def !x (atom 0)) (def !y (atom 0)) (with @@ -509,13 +490,13 @@ F (e/fn [x] (+ y x)) ; constant signal G (if (odd? x) (e/fn [x] (+ y x)) (e/fn [x] (+ y x))) - H (new (m/seed [(e/fn [x] (+ y x))]))] - [(F. x) - (G. x) - (H. x)]))) tap tap) + H (e/input (m/seed [(e/fn [x] (+ y x))]))] + [($ F x) + ($ G x) + ($ H x)]))) tap tap) % := [0 0 0])) -(skip "reactive clojure.core/fn" +(tests "reactive clojure.core/fn" (def !x (atom 0)) (def !y (atom 0)) (with @@ -535,7 +516,7 @@ (swap! !x inc) % := 2)) -(skip "For reference, Clojure exceptions have dynamic scope" +(tests "For reference, Clojure exceptions have dynamic scope" (try (let [f (try (fn [] (throw (ex-info "boom" {}))) ; this exception will escape (catch #?(:clj Exception, :cljs :default) _ ::inner))] ; the lambda doesn't know it was constructed in a try/catch block @@ -543,6 +524,7 @@ (catch #?(:clj Exception, :cljs :default) _ ::outer)) := ::outer) +;; TODO throw (skip "Reactor crashes on uncaugh exceptions" (def !x (atom true)) (with ((l/single {} (tap (assert (e/watch !x)))) tap tap) @@ -553,6 +535,7 @@ (swap! !x not) ; reactor will not come back. (tap ::nope), % := ::nope)) +;; TODO try/catch/throw ;; (l/defn Boom [] (assert false)) (skip "reactive exceptions" (with ((l/single {} (tap (try @@ -562,6 +545,7 @@ #?(:clj (instance? AssertionError %) :cljs (instance? js/Error %)) := true)) +;; TODO try/catch/throw (skip (with ((l/single {} (tap (try (let [Nf (try (e/fn [] (Boom.)) ; reactive exception uncaught (catch #?(:clj AssertionError, :cljs :default) _ ::inner))] @@ -569,46 +553,50 @@ (catch #?(:clj AssertionError, :cljs :default) _ ::outer)))) tap tap) % := ::outer)) -;; (l/def inner) -;; (l/def Outer (e/fn [] inner)) +(def inner) +(e/defn Outer [] inner) -(skip "dynamic scope (note that try/catch has the same structure)" - (with ((l/single {} (tap (binding [inner ::inner] (Outer.)))) tap tap) +(tests "dynamic scope (note that try/catch has the same structure)" + (with ((l/single {} (tap (binding [inner ::inner] ($ Outer)))) tap tap) % := ::inner)) -(skip "dynamic scope (note that try/catch has the same structure)" +(tests "dynamic scope (note that try/catch has the same structure)" (with ((l/single {} (tap (binding [inner ::outer] (let [Nf (binding [inner ::inner] - (e/fn [] (Outer.)))] ; binding out of scope - (Nf.))))) tap tap) + (e/fn [] ($ Outer)))] ; binding out of scope + ($ Nf))))) tap tap) % := ::outer)) -(skip "lazy parameters. Flows are not run unless sampled" - (with ((l/single {} (new (e/fn [_]) (tap :boom))) tap tap) +(tests "lazy parameters. Flows are not run unless sampled" + (with ((l/single {} ($ (e/fn [_]) (tap :boom))) tap tap) % := :boom)) -(skip "lazy parameters. Flows are not run unless sampled" - (with ((l/single {} (let [_ (tap :bang)])) tap tap) ; todo, cc/let should sequence effects for cc compat +(tests "lazy parameters. Flows are not run unless sampled" + (with ((l/single {} (let [_ (tap :not)] (tap :bang))) tap tap) % := :bang)) +;; TODO network (skip "client/server transfer" ; Pending state is an error state. ; Pending errors will crash the reactor if not caugh (with ((l/single {} (try (tap (e/server (e/client 1))) (catch Pending _))) tap tap) % := 1)) +;; TODO network ;; (l/def foo nil) (skip (with ((l/single {} (try (tap (binding [foo 1] (e/server (e/client foo)))) (catch Pending _))) tap tap) % := 1)) +;; TODO network ;; (l/def foo nil) (skip (with ((l/single {} (try (tap (binding [foo 1] (e/server (new (e/fn [] (e/client foo)))))) (catch Pending _))) tap tap) % := 1)) +;; TODO try/catch ;; (l/def foo1 nil) ;; (l/def Bar1 (e/fn [] (e/client foo1))) (skip @@ -616,16 +604,19 @@ (catch Pending _))) tap tap) % := 1)) +;; TODO try/catch (skip "reactive pending states" ;~(m/reductions {} hyperfiddle.electric.impl.runtime/pending m/none) (with ((l/single {} (tap (try true (catch Pending _ ::pending)))) tap tap) % := true)) +;; TODO try/catch (skip (with ((l/single {} (tap (try (e/server 1) (catch Pending _ ::pending)))) tap tap) % := ::pending ; Use try/catch to intercept special pending state % := 1)) +;; TODO try/catch (skip (with ((l/single {} (tap (try [(tap 1) (tap (e/server 2))] (catch Pending _ ::pending)))) tap tap) % := 1 @@ -634,6 +625,7 @@ % := 2 % := [1 2])) +;; TODO try/catch (skip "the same exception is thrown from two places!" (l/defn InputController1 [tap controlled-value] (try controlled-value (catch Pending _ (tap :pending-inner)))) @@ -644,7 +636,7 @@ % := :pending-inner % := :pending-outer) -(skip "object lifecycle" +(tests "object lifecycle" (def !x (atom 0)) (let [hook (fn [mount! unmount!] (m/observe (fn [!] @@ -655,8 +647,8 @@ ((l/single {} (tap (let [x (e/watch !x)] (when (even? x) - (new (e/fn [x] - (new (hook (partial tap 'mount) (partial tap 'unmount))) + ($ (e/fn [x] + (e/input (hook (partial tap 'mount) (partial tap 'unmount))) x) x))))) tap tap)] @@ -670,14 +662,14 @@ (dispose!) % := 'unmount)) -(skip "object lifecycle 3" +(tests "object lifecycle 3" (defn observer [x] (fn mount [f] (f (tap [:up x])) (fn unmount [] (tap [:down x])))) (def !state (atom [1])) - (with ((l/single {} (e/for [x (e/watch !state)] (new (m/observe (observer x))))) tap tap) + (with ((l/single {} (e/for-by identity [x (e/watch !state)] (e/input (m/observe (observer x))))) tap tap) % := [:up 1] (swap! !state conj 2) % := [:up 2] @@ -685,6 +677,7 @@ (hash-set % % %) := #{[:up 3] [:down 1] [:down 2]}) % := [:down 3]) +;; TODO try/catch (skip "object lifecycle 3 with pending state" (def !state (atom [1])) @@ -695,7 +688,7 @@ (fn unmount [] (tap [::unmount x])))) (let [dispose ((l/single {} (try - (e/for [x (e/watch !state)] ; pending state should not trash e/for branches + (e/for-by identity [x (e/watch !state)] ; pending state should not trash e/for branches (new (m/observe (observer tap x)))) ; depends on x, which is pending (catch Pending _))) tap tap)] % := [::mount 1] @@ -708,20 +701,20 @@ (dispose) % := [::unmount 2])) -;; (l/def x2 1) -(skip "object lifecycle 4" +(def x2 1) +(tests "object lifecycle 4" (def !input (atom [1 2])) (defn up-down [x trace!] (m/observe (fn [!] (trace! :up) (! x) #(trace! :down)))) (with ((l/single {} - (tap (e/for [id (new (m/watch !input))] + (tap (e/for-by identity [id (e/watch !input)] (binding [x2 (do id x2)] - (new (up-down x2 tap)))))) tap tap) + (e/input (up-down x2 tap)))))) tap tap) [% %] := [:up :up] % := [1 1] (swap! !input pop) - % := :down - % := [1]) + % := [1] + % := :down) % := :down) (skip "reactive metadata" From 20003c2eadc9629b64b0deea5877a7f4823a62ee Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 12 Feb 2024 18:33:30 +0100 Subject: [PATCH 098/428] 1st pass of main electric test suite 55% passing 45% skipped due to missing compiler or runtime functionality --- src/contrib/debug.cljc | 7 + src/hyperfiddle/electric/impl/lang_de2.clj | 119 +++--- src/hyperfiddle/electric_de.cljc | 50 ++- src/hyperfiddle/electric_local_def_de.cljc | 3 + test/hyperfiddle/electric_de_test.cljc | 444 +++++++++++---------- 5 files changed, 343 insertions(+), 280 deletions(-) diff --git a/src/contrib/debug.cljc b/src/contrib/debug.cljc index 477fb33d2..ac57a0bd1 100644 --- a/src/contrib/debug.cljc +++ b/src/contrib/debug.cljc @@ -33,6 +33,13 @@ (defmacro do-traced [& body] `(do ~@(for [form body] `(dbg ~form)))) +(defn ->nprn [n] + (let [prns (long-array [0])] + (fn [& args] + (when (< (aget prns (int 0)) n) + (aset prns 0 (unchecked-inc (aget prns (int 0)))) + (apply prn args))))) + (def !id (atom 0)) (defn instrument* [nm flow] diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 45bf0cc11..92b3542f8 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -163,7 +163,7 @@ (defn find-local-entry [env sym] (find (:locals env) sym)) (defn add-local [env sym] (update env :locals assoc sym ::unknown)) -(def ^:dynamic *electric* true) +(def ^:dynamic *electric* false) (defn ?meta [metao o] (if (instance? clojure.lang.IObj o) @@ -198,7 +198,7 @@ [(conj bs sym (-expand-all v env)) (add-local env sym)]) [[] env] (partition-all 2 bs))] - (recur (?meta o `(binding [::rec (::ctor (let* [~@(interleave (take-nth 2 bs2) (range))] ~@body))] + (recur (?meta o `(binding [::rec (::ctor (let* [~@(interleave (take-nth 2 bs2) (map #(list ::lookup %) (range)))] ~@body))] (binding [~@(interleave (range) (take-nth 2 (next bs2)))] (::call (::lookup ::rec))))) env2)) @@ -283,7 +283,7 @@ ;; if ::current = :cljs expand with cljs environment -(defn expand-all [env o] (ensure-cljs-compiler (-expand-all o (ensure-cljs-env env)))) +(defn expand-all [env o] (ensure-cljs-compiler (binding [*electric* true] (-expand-all o (ensure-cljs-env env))))) ;;;;;;;;;;;;;;;; ;;; COMPILER ;;; @@ -565,10 +565,10 @@ (let*) (let [[_ bs bform] form] (loopr [ts ts, pe pe, env env] [[s v] (eduction (partition-all 2) bs)] - (let [e (->id), env (update-in env [:locals s] assoc ::electric-let e)] + (let [e (->id)] (recur (analyze v e env (-> (ts/add ts {:db/id e, ::parent pe, ::type ::let, ::sym s}) - (?add-source-map e form))) e env)) + (?add-source-map e form))) e (update-in env [:locals s] assoc ::electric-let e))) (analyze bform pe env ts))) (case) (let [[_ test & brs] form [default brs2] (if (odd? (count brs)) [(last brs) (butlast brs)] [:TODO brs])] @@ -606,8 +606,7 @@ ;; (. i1 (isAfter i2)) ;; (. pt x) ;; (. pt -x) - (.) (if (and (= :clj (get (::peers env) (::current env))) - (symbol? (second form)) (class? (resolve env (second form)))) + (.) (if (and (symbol? (second form)) (class? (resolve env (second form)))) (if (seq? (nth form 2)) ; (. java.time.Instant (ofEpochMilli 1)) (let [[_ clazz [method & method-args]] form] (->class-method-call clazz method method-args pe env ts)) @@ -667,6 +666,7 @@ (vector? form) (recur (?meta form (cons `(::static-vars vector) form)) pe env ts) (map? form) (recur (?meta form (cons `(::static-vars hash-map) (eduction cat form))) pe env ts) + (set? form) (recur (?meta form (cons `(::static-vars hash-set) form)) pe env ts) (symbol? form) (let [e (->id), ret (resolve-symbol form env)] @@ -758,19 +758,20 @@ (->> (ts/find ts ::ctor-node ctor-e) (sort-by #(::node-idx (ts/->node ts %))))) (defn compute-effect-order [ts e] - (let [->order (->->id), ord (fn [ts e] (ts/upd ts e ::fx-order #(or % (->order))))] + (let [->order (->->id), ord (fn [ts e] (ts/upd ts e ::fx-order #(or % (->order)))), seen (volatile! #{})] ((fn rec [ts e] (let [nd (ts/->node ts e)] - (if (::fx-order nd) + (if (@seen e) ts - (case (::type nd) - (::literal ::var ::lookup ::node) (ord ts e) - (::ap ::comp) (ord (reduce rec ts (get-children-e ts e)) e) - (::site ::join ::pure ::call ::ctor) (ord (rec ts (get-child-e ts e)) e) - (::let) (recur ts (->let-body-e ts e)) - (::let-ref) (ord (rec ts (->let-val-e ts (::ref nd))) (::ref nd)) - #_else (throw (ex-info (str "cannot compure-effect-order on " (pr-str (::type nd))) (or nd {}))) - )))) + (do (vswap! seen conj e) + (case (::type nd) + (::literal ::var ::lookup ::node) (ord ts e) + (::ap ::comp) (ord (reduce rec ts (get-children-e ts e)) e) + (::site ::join ::pure ::call ::ctor) (ord (rec ts (get-child-e ts e)) e) + (::let) (recur ts (->let-body-e ts e)) + (::let-ref) (ord (rec ts (->let-val-e ts (::ref nd))) (::ref nd)) + #_else (throw (ex-info (str "cannot compure-effect-order on " (pr-str (::type nd))) (or nd {}))) + ))))) ts e))) (defn emit-ctor [ts ctor-e env nm] @@ -793,16 +794,20 @@ ~(emit ts ret-e ctor-e env nm))))) (defn emit-deps [ts e] - (let [mark (fn mark [ts e] - (let [nd (ts/->node ts e)] - (case (::type nd) - (::literal ::var ::lookup) ts - (::ap ::comp) (reduce mark ts (get-children-e ts e)) - (::site ::join ::pure ::call ::ctor) (recur ts (get-child-e ts e)) - (::let) (recur ts (->let-body-e ts e)) - (::let-ref) (recur ts (get-ret-e ts (->let-val-e ts (::ref nd)))) - (::node) (ts/asc ts e ::node-used true) - #_else (throw (ex-info (str "cannot emit-deps/mark on " (pr-str (::type nd))) (or nd {})))))) + (let [seen (volatile! #{}) + mark (fn mark [ts e] + (if (@seen e) + ts + (let [nd (ts/->node ts e)] + (vswap! seen conj e) + (case (::type nd) + (::literal ::var ::lookup) ts + (::ap ::comp) (reduce mark ts (get-children-e ts e)) + (::site ::join ::pure ::call ::ctor) (recur ts (get-child-e ts e)) + (::let) (recur ts (->let-body-e ts e)) + (::let-ref) (recur ts (get-ret-e ts (->let-val-e ts (::ref nd)))) + (::node) (ts/asc ts e ::node-used true) + #_else (throw (ex-info (str "cannot emit-deps/mark on " (pr-str (::type nd))) (or nd {}))))))) es (ts/find (mark ts e) ::node-used true)] (into (sorted-set) (map #(::node (ts/->node ts %))) es))) @@ -825,18 +830,22 @@ ts))) ts (reverse (ts/find ts ::type ::ap)))) ->ctor-idx (->->id) + seen (volatile! #{}) mark-used-ctors (fn mark-used-ctors [ts e] - (let [nd (get (:eav ts) e)] - (case (::type nd) - (::literal ::var ::lookup ::node) ts - (::ap ::comp) (reduce mark-used-ctors ts (get-children-e ts e)) - (::site ::join ::pure ::call) (recur ts (get-child-e ts e)) - (::ctor) (if (::ctor-idx nd) - ts - (recur (ts/asc ts e ::ctor-idx (->ctor-idx)) (get-child-e ts e))) - (::let) (recur ts (->let-body-e ts e)) - (::let-ref) (recur ts (get-ret-e ts (->let-val-e ts (::ref nd)))) - #_else (throw (ex-info (str "cannot mark-used-ctors on " (pr-str (::type nd))) (or nd {})))))) + (if (@seen e) + ts + (let [nd (get (:eav ts) e)] + (vswap! seen conj e) + (case (::type nd) + (::literal ::var ::lookup ::node) ts + (::ap ::comp) (reduce mark-used-ctors ts (get-children-e ts e)) + (::site ::join ::pure ::call) (recur ts (get-child-e ts e)) + (::ctor) (if (::ctor-idx nd) + ts + (recur (ts/asc ts e ::ctor-idx (->ctor-idx)) (get-child-e ts e))) + (::let) (recur ts (->let-body-e ts e)) + (::let-ref) (recur ts (get-ret-e ts (->let-val-e ts (::ref nd)))) + #_else (throw (ex-info (str "cannot mark-used-ctors on " (pr-str (::type nd))) (or nd {}))))))) ts (-> ts collapse-ap-with-only-pures (compute-effect-order 0) (mark-used-ctors 0)) @@ -906,22 +915,26 @@ #_else (throw (ex-info (str "cannot handle-let-refs on " (::type nd)) (or nd {})))))) ->call-idx (let [mp (zipmap ctors-e (repeatedly ->->id))] (fn ->call-idx [ctor-e] ((get mp ctor-e)))) + seen (volatile! #{}) mark-used-calls (fn mark-used-calls [ts ctor-e e] - (let [nd (ts/->node ts e)] - (case (::type nd) - (::literal ::var ::lookup ::node) ts - (::ap ::comp) (reduce #(mark-used-calls % ctor-e %2) ts (get-children-e ts e)) - (::site ::join ::pure) (recur ts ctor-e (get-child-e ts e)) - (::ctor) (recur ts e (get-child-e ts e)) - (::call) (if (::call-idx nd) - ts - (-> (mark-used-calls ts ctor-e (get-child-e ts e)) - (ts/asc e ::call-idx (->call-idx ctor-e)) - (ts/asc e ::ctor-call ctor-e))) - (::let) (recur ts ctor-e (->let-body-e ts e)) - (::let-ref) (let [nx-e (get-ret-e ts (->let-val-e ts (::ref nd)))] - (recur ts (find-ctor-e ts nx-e) nx-e)) - #_else (throw (ex-info (str "cannot mark-used-calls on " (::type nd)) (or nd {})))))) + (if (@seen e) + ts + (let [nd (ts/->node ts e)] + (vswap! seen conj e) + (case (::type nd) + (::literal ::var ::lookup ::node) ts + (::ap ::comp) (reduce #(mark-used-calls % ctor-e %2) ts (get-children-e ts e)) + (::site ::join ::pure) (recur ts ctor-e (get-child-e ts e)) + (::ctor) (recur ts e (get-child-e ts e)) + (::call) (if (::call-idx nd) + ts + (-> (mark-used-calls ts ctor-e (get-child-e ts e)) + (ts/asc e ::call-idx (->call-idx ctor-e)) + (ts/asc e ::ctor-call ctor-e))) + (::let) (recur ts ctor-e (->let-body-e ts e)) + (::let-ref) (let [nx-e (get-ret-e ts (->let-val-e ts (::ref nd)))] + (recur ts (find-ctor-e ts nx-e) nx-e)) + #_else (throw (ex-info (str "cannot mark-used-calls on " (::type nd)) (or nd {}))))))) ts (-> ts (handle-let-refs 0) order-nodes order-frees (mark-used-calls 0 (get-ret-e ts (get-child-e ts 0))))] (when (::print-db env) (run! prn (->> ts :eav vals (sort-by :db/id)))) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 8fac1ea2b..f998f48bc 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -1,5 +1,5 @@ (ns hyperfiddle.electric-de - (:refer-clojure :exclude [fn defn]) + (:refer-clojure :exclude [fn defn apply]) (:require [hyperfiddle.electric.impl.lang-de2 :as lang] [hyperfiddle.electric.impl.runtime-de :as r] [hyperfiddle.incseq :as i] @@ -30,10 +30,16 @@ Syntax : Returns the successive states of items described by `incseq`. " [flow] `(::lang/join ~flow)) +(defmacro check-electric [fn form] + (if lang/*electric* + form + (throw (ex-info (str "Electric code (" fn ") inside a Clojure function") (into {:electric-fn fn} (meta &form)))))) + (defmacro fn [bs & body] - `(ctor - (let [~@(interleave bs (eduction (map #(list ::lang/lookup %)) (range)))] - ~@body))) + `(check-electric fn + (ctor + (let [~@(interleave bs (eduction (map #(list ::lang/lookup %)) (range)))] + ~@body)))) (cc/defn ns-qualify [sym] (if (namespace sym) sym (symbol (str *ns*) (str sym)))) @@ -45,6 +51,7 @@ Returns the successive states of items described by `incseq`. (lang/ensure-cljs-compiler (let [env (merge (meta nm) (lang/ensure-cljs-env (lang/normalize-env &env)) l/web-config) expanded (lang/expand-all env `(fn ~bs ~@body)) + _ (when (::lang/print-expansion env) (fipp.edn/pprint expanded)) ts (lang/analyze expanded '_ env (ts/->ts {::lang/->id (lang/->->id)})) ts (lang/analyze-electric env ts) ctors (mapv #(lang/emit-ctor ts % env (-> nm ns-qualify keyword)) (lang/get-ordered-ctors-e ts)) @@ -82,7 +89,7 @@ Syntax : (watch !ref) ``` Returns the current state of current reference `!ref`. -" [ref] `(input (m/watch ~ref))) +" [ref] `(check-electric watch (input (m/watch ~ref)))) (defmacro diff-by " Syntax : @@ -100,8 +107,8 @@ Syntax : Samples and discards `expr` synchronously with changes. Returns nothing. " [expr] `(join (r/drain (pure ~expr)))) -(defmacro client [& body] `(::lang/site :client ~@body)) -(defmacro server [& body] `(::lang/site :server ~@body)) +(defmacro client [& body] `(check-electric client (::lang/site :client ~@body))) +(defmacro server [& body] `(check-electric server (::lang/site :server ~@body))) (defmacro cursor " Syntax : @@ -117,7 +124,7 @@ For each tuple in the cartesian product of `table1 table2 ,,, tableN`, calls bod " [bindings & body] (case bindings [] `(do ~@body) - (let [[args exprs] (apply map vector (partition-all 2 bindings))] + (let [[args exprs] (cc/apply map vector (partition-all 2 bindings))] `($ (r/bind-args (fn ~args ~@body) ~@(map (clojure.core/fn [expr] `(r/fixed-signals (join (i/items (pure ~expr))))) @@ -150,3 +157,30 @@ this tuple. Returns the concatenation of all body results as a single vector. `(cursor [~sym (diff-by ~kf ~expr)] ~(rec bindings)) `(do ~@body))) (seq bindings)))) + +(cc/defn- -splicev [args] (into [] cat [(pop args) (peek args)])) +(hyperfiddle.electric-de/defn ^::lang/static-vars Apply* [F args] + (let [spliced (-splicev args)] + (case (count spliced) + 0 ($ F) + 1 ($ F (nth spliced 0)) + 2 ($ F (nth spliced 0) (nth spliced 1)) + 3 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2)) + 4 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3)) + 5 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4)) + 6 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5)) + 7 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6)) + 8 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6) (nth spliced 7)) + 9 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6) (nth spliced 7) (nth spliced 8)) + 10 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6) (nth spliced 7) (nth spliced 8) (nth spliced 9)) + 11 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6) (nth spliced 7) (nth spliced 8) (nth spliced 9) (nth spliced 10)) + 12 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6) (nth spliced 7) (nth spliced 8) (nth spliced 9) (nth spliced 10) (nth spliced 11)) + 13 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6) (nth spliced 7) (nth spliced 8) (nth spliced 9) (nth spliced 10) (nth spliced 11) (nth spliced 12)) + 14 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6) (nth spliced 7) (nth spliced 8) (nth spliced 9) (nth spliced 10) (nth spliced 11) (nth spliced 12) (nth spliced 13)) + 15 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6) (nth spliced 7) (nth spliced 8) (nth spliced 9) (nth spliced 10) (nth spliced 11) (nth spliced 12) (nth spliced 13) (nth spliced 14)) + 16 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6) (nth spliced 7) (nth spliced 8) (nth spliced 9) (nth spliced 10) (nth spliced 11) (nth spliced 12) (nth spliced 13) (nth spliced 14) (nth spliced 15)) + 17 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6) (nth spliced 7) (nth spliced 8) (nth spliced 9) (nth spliced 10) (nth spliced 11) (nth spliced 12) (nth spliced 13) (nth spliced 14) (nth spliced 15) (nth spliced 16)) + 18 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6) (nth spliced 7) (nth spliced 8) (nth spliced 9) (nth spliced 10) (nth spliced 11) (nth spliced 12) (nth spliced 13) (nth spliced 14) (nth spliced 15) (nth spliced 16) (nth spliced 17)) + 19 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6) (nth spliced 7) (nth spliced 8) (nth spliced 9) (nth spliced 10) (nth spliced 11) (nth spliced 12) (nth spliced 13) (nth spliced 14) (nth spliced 15) (nth spliced 16) (nth spliced 17) (nth spliced 18)) + 20 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6) (nth spliced 7) (nth spliced 8) (nth spliced 9) (nth spliced 10) (nth spliced 11) (nth spliced 12) (nth spliced 13) (nth spliced 14) (nth spliced 15) (nth spliced 16) (nth spliced 17) (nth spliced 18) (nth spliced 19))))) +(defmacro apply [F & args] `($ Apply* ~F [~@args])) diff --git a/src/hyperfiddle/electric_local_def_de.cljc b/src/hyperfiddle/electric_local_def_de.cljc index d1d06dd3e..5326b269e 100644 --- a/src/hyperfiddle/electric_local_def_de.cljc +++ b/src/hyperfiddle/electric_local_def_de.cljc @@ -41,7 +41,9 @@ (lang/ensure-cljs-compiler (let [env (merge (->local-config &env) (lang/normalize-env &env) conf) expanded (lang/expand-all env `(::lang/ctor (do ~@body))) + _ (when (::lang/print-expansion env) (fipp.edn/pprint expanded)) ts (lang/analyze expanded '_ env (ts/->ts {::lang/->id (lang/->->id)})) + _ (when (::lang/print-analysis env) (run! prn (->> ts :eav vals (sort-by :db/id)))) ts (lang/analyze-electric env ts) ctors (mapv #(lang/emit-ctor ts % env ::Main) (lang/get-ordered-ctors-e ts)) ret-e (lang/get-ret-e ts (lang/get-child-e ts 0)) @@ -49,5 +51,6 @@ deps (collect-deps deps) defs (into {} (map (fn [dep] [(keyword dep) dep])) deps) defs (assoc defs ::Main ctors)] + (when (::lang/print-source env) (fipp.edn/pprint ctors)) (when (::lang/print-defs env) (fipp.edn/pprint defs)) `(run-single (r/root-frame ~defs ::Main)))))) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index b5de83360..e71b4645a 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -1,12 +1,24 @@ (ns hyperfiddle.electric-de-test - (:require [hyperfiddle.rcf :as rcf :refer [tests tap with %]] + (:require [hyperfiddle.rcf :as rcf :refer [tap with %]] [hyperfiddle.electric-de :as e :refer [$]] [hyperfiddle.electric-local-def-de :as l] + [hyperfiddle.electric.impl.io :as electric-io] [hyperfiddle.electric.impl.lang-de2 :as lang] - [missionary.core :as m])) + [missionary.core :as m]) + (:import [hyperfiddle.electric Pending Failure] + [missionary Cancelled] + #?(:clj [clojure.lang ExceptionInfo]))) + +(def stats (atom {:skipped 0, :tbd 0, :tested 0})) (defmacro skip {:style/indent 0} [& _body] - `(pr '~'-)) + `(do (swap! stats update :skipped inc) (pr '~'-))) + +(defmacro tbd {:style/indent 0} [& _body] + `(do (swap! stats update :tbd inc) (pr '~'?))) + +(defmacro tests {:style/indent 0} [& body] + `(do (swap! stats update :tested inc) (rcf/tests ~@body))) (tests "call on local electric ctor" (with ((l/single {} (let [x (e/ctor 1)] (tap ($ x)))) tap tap) @@ -465,7 +477,7 @@ (tests "reactive closures" (def !x (atom 1)) (def !y (atom 10)) - (with ((l/single {::lang/print-source true} + (with ((l/single {} (let [x (e/watch !x), y (e/watch !y)] (tap ($ (if (odd? x) (e/fn [x] (* y x)) @@ -717,18 +729,20 @@ % := :down) % := :down) -(skip "reactive metadata" +(tests "reactive metadata" (def !x (atom 0)) (with ((l/single {} (tap (meta (let [x (with-meta [] {:foo (e/watch !x)})] x)))) tap tap) % := {:foo 0} (swap! !x inc) (tap ::hi) % := ::hi)) +;; TODO shows Cannot invoke \"java.lang.Character.charValue()\" because \"x\" is null (skip "undefined continuous flow, flow is not defined for the first 10ms" (let [flow (m/ap (m/? (m/sleep 10 :foo)))] - (with ((l/single {} (tap (new (new (e/fn [] (let [a (new flow)] (e/fn [] a))))))) tap tap) + (with ((l/single {} (tap ($ ($ (e/fn [] (let [a (e/input flow)] (e/fn [] a))))))) tap tap) (ex-message %) := "Undefined continuous flow."))) +;; TODO try/catch (skip (def !x (atom 0)) (with ((l/single {} (tap (try (-> (e/watch !x) @@ -741,6 +755,7 @@ (swap! !x inc) % := 1)) +;; TODO try/catch (skip (def !x (atom 0)) (def !f (atom "hello")) @@ -758,14 +773,14 @@ (swap! !x inc) % := :ok)) -;; (l/def unbound1) -;; (l/def unbound2) -(skip - (with ((l/single {} (tap (new (e/fn [] (binding [unbound1 1 unbound2 2] (+ unbound1 unbound2)))))) tap tap) +(def unbound1) +(def unbound2) +(tests + (with ((l/single {} (tap ($ (e/fn [] (binding [unbound1 1 unbound2 2] (+ unbound1 unbound2)))))) tap tap) % := 3)) #?(:clj -(skip +(tests "understand how Clojure handles unbound vars" ; In Clojure, ; Is unbound var defined or undefined behavior? @@ -784,40 +799,26 @@ (instance? clojure.lang.Var$Unbound *1) := true) ) +;; TODO (skip "In Electric, accessing an unbound var throws a userland exception" ;; An unbound var is either: ;; - an uninitialized p/def, ;; - an unsatisfied reactive fn parameter (reactive fn called with too few arguments). - (l/def x) + (def x) (with ((l/single {} x) prn tap) (ex-message %) := "Unbound electric var `hyperfiddle.electric-test/x`")) -(skip "Initial p/def binding is readily available in p/run" - (def !x (atom 0)) - (l/def X (m/watch !x)) - (with ((l/single {} (tap (X.))) tap tap) - % := 0 - (swap! !x inc) - % := 1)) - +;; TODO e/defn docstring #?(:clj (skip ; GG: IDE doc on hover support - "Vars created with p/def have the same metas as created with cc/def" - (l/def Documented "p/def" :init) - (select-keys (meta (var Documented)) [:name :doc]) - := {:name 'Documented - :doc "p/def"})) - -#?(:clj - (skip ; GG: IDE doc on hover support - "Vars created with p/defn have the same metas as created with cc/defn" - (l/defn Documented "doc" [a b c]) + "Vars created with e/defn have the same metas as created with cc/defn" + (e/defn Documented "doc" [a b c]) (select-keys (meta (var Documented)) [:name :doc :arglists]) := {:name 'Documented :doc "doc" :arglists '([a b c])})) -(skip "pentagram of death - via Kenny Tilton" +(tests "pentagram of death - via Kenny Tilton" ; Key elements: ; - two dependency chains from some property P leading back to one property X; and ; - branching code in the derivation of P that will not travel the second dependency chain until a @@ -847,39 +848,38 @@ (swap! !aa inc) % := 420073)) -(skip "pentagram of death reduced" - ; the essence of the problem is: - ; 1. if/case switch/change the DAG (imagine a railroad switch between two train tracks) - ; 2. to have a conditional where the predicate and the consequent have a common dependency +(tests "pentagram of death reduced" + ;; the essence of the problem is: + ;; 1. if/case switch/change the DAG (imagine a railroad switch between two train tracks) + ;; 2. to have a conditional where the predicate and the consequent have a common dependency (def !x (atom 1)) - (with ((l/single {} (tap (let [p (e/watch !x) - q (tap (str p)) - control (- p)] - (case control -1 p -2 q q)))) tap tap) - % := "1" ; cc/let sequences effects - % := 1 ; cross + (with ((l/single {} (tap (let [p (e/watch !x) + q (tap (str p)) + control (- p)] + (case control -1 p -2 q q)))) tap tap) + % := 1 ; cross (swap! !x inc) - % := "2" ; q first touched + % := "2" ; q first touched % := "2")) -(skip "for with literal input" - (with ((l/single {} (tap (e/for [x [1 2 3]] (tap x)))) tap tap) +(tests "for with literal input" + (with ((l/single {} (tap (e/for-by identity [x [1 2 3]] (tap x)))) tap tap) (hash-set % % %) := #{1 2 3} % := [1 2 3])) -(skip "for with literal input, nested" +(tests "for with literal input, nested" (def !x (atom 0)) (with ((l/single {} (tap (when (even? (e/watch !x)) - (e/for [x [1 2 3]] + (e/for-by identity [x [1 2 3]] (tap x))))) tap tap) (hash-set % % %) := #{1 2 3} % := [1 2 3] (swap! !x inc) % := nil)) -(skip "nested closure" +(tests "nested closure" (def !x (atom 0)) - (with ((l/single {} (tap (new (let [x (e/watch !x)] + (with ((l/single {} (tap ($ (let [x (e/watch !x)] (if (even? x) (e/fn [] :even) (e/fn [] :odd)))))) tap tap) @@ -887,6 +887,7 @@ (swap! !x inc) % := :odd)) +;; TODO e/hook? (skip "simultaneous add and remove in a for with a nested hook" (def !xs (atom [1])) (defn hook @@ -909,6 +910,7 @@ % := [2] % := [0]) +;; TODO try/catch (skip (def !t (atom true)) (with ((l/single {} @@ -921,16 +923,16 @@ (swap! !t not) % := nil)) -(skip +(tests (def !state (atom true)) (with ((l/single {} (when (e/watch !state) (tap :touch))) tap tap) % := :touch (reset! !state true) (tap ::nope) % := ::nope)) -(skip "e/for in a conditional" +(tests "e/for in a conditional" (def !state (atom true)) - (with ((l/single {} (tap (if (e/watch !state) 1 (e/for [_ []])))) tap tap) + (with ((l/single {} (tap (if (e/watch !state) 1 (e/for-by identity [_ []])))) tap tap) % := 1 (swap! !state not) % := [] @@ -940,7 +942,7 @@ (comment ; we are not sure if this test has value. It is not minimized. - (skip "Hack for e/for in a conditional. Passes by accident" ; PASS + (tests "Hack for e/for in a conditional. Passes by accident" ; PASS (def !state (atom true)) (with ((l/single {} (tap (if (e/watch !state) 1 (try (e/for [_ []]) (catch Throwable t (throw t)))))) tap tap) % := 1 @@ -949,6 +951,7 @@ (swap! !state not) % := 1))) +;; TODO transfer try/catch (skip "Nested e/for with transfer" (def !state (atom [1])) (l/def state (e/watch !state)) @@ -961,28 +964,28 @@ (reset! !state [3]) % := [3 3])) -(skip +(tests "Static call" (with ((l/single {} (tap (Math/abs -1))) tap tap) % := 1)) #?(:clj - (skip "Dot syntax works (clj only)" + (tests "Dot syntax works (clj only)" (with ((l/single {} (tap (. Math abs -1))) tap tap) % := 1))) -(skip "Sequential destructuring" +(tests "Sequential destructuring" (with ((l/single {} (tap (let [[x y & zs :as coll] [:a :b :c :d]] [x y zs coll]))) tap tap) % := [:a :b '(:c :d) [:a :b :c :d]])) -(skip "Associative destructuring" +(tests "Associative destructuring" (with ((l/single {} (tap (let [{:keys [a ns/b d] :as m :or {d 4}} {:a 1, :ns/b 2 :c 3}] [a b d m]))) tap tap) % := [1 2 4 {:a 1, :ns/b 2, :c 3}])) -(skip "Associative destructuring with various keys" +(tests "Associative destructuring with various keys" (with ((l/single {} (tap (let [{:keys [a] :ns/keys [b] :syms [c] @@ -992,6 +995,7 @@ [a b c d e]))) tap tap) % := [1 2 3 4 5])) +;; TODO transfer try/catch (skip "fn destructuring" (with ((l/single {} (try @@ -1001,6 +1005,7 @@ % := [::client 1 2] % := [::server 1 2]) +;; TODO try/catch (skip (def !xs (atom [false])) (with @@ -1012,10 +1017,10 @@ (reset! !xs []) % := [])) -(skip "All Pending instances are equal" +(tests "All Pending instances are equal" (= (Pending.) (Pending.)) := true) -(skip +(tests "Failure instances are equal if the errors they convey are equal" (= (Failure. (Pending.)) (Failure. (Pending.))) := true @@ -1025,7 +1030,7 @@ (= (ex-info "a" {}) (ex-info "a" {})) := false (= (Failure. (ex-info "err" {})) (Failure. (ex-info "err" {}))) := false)) -(skip ; temporary test because p/run does not serilize to transit. +(tests ; temporary test because p/run does not serilize to transit. "Electric transit layer serializes unserializable values to nil" (electric-io/decode (electric-io/encode 1)) := 1 (electric-io/decode (electric-io/encode (type 1))) := nil) @@ -1034,6 +1039,7 @@ ;; Ticket: https://www.notion.so/hyperfiddle/cljs-test-suite-can-produce-false-failures-0b3799f6d2104d698eb6a956b6c51e48 #?(:cljs (t/use-fixtures :each {:after #(t/async done (js/setTimeout done 1))})) +;; TODO transfer try/catch (skip (def !x (atom true)) (with ((l/single {} @@ -1047,6 +1053,7 @@ ; the remote tap on the switch has been removed % := [:client false])) +;; TODO transfer try/catch (skip (def !x (atom true)) (l/def x (e/server (e/watch !x))) @@ -1063,6 +1070,7 @@ ; current behavior - Dustin likes, Leo does not like ) +;; TODO transfer try/catch ;; https://www.notion.so/hyperfiddle/distribution-glitch-stale-local-cache-of-remote-value-should-be-invalidated-pending-47f5e425d6cf43fd9a37981c9d80d2af (skip "glitch - stale local cache of remote value should be invalidated/pending" (def !x (atom 0)) @@ -1096,6 +1104,7 @@ ; increases compile times ) +;; TODO transfer try/catch (skip (with ((l/single {} (try (e/server (let [foo 1] @@ -1105,6 +1114,7 @@ % := 1 % := 1)) +;; TODO transfer try/catch (skip "Today, bindings fail to transfer, resulting in unbound var exception. This will be fixed" ; https://www.notion.so/hyperfiddle/photon-binding-transfer-unification-of-client-server-binding-7e56d9329d224433a1ee3057e96541d1 (l/def foo) @@ -1120,15 +1130,17 @@ ; % := 1 -- target future behavior (type %) := #?(:clj Error :cljs js/Error))) -(skip "static method call" +(tests "static method call" (with ((l/single {} (tap (Math/max 2 1))) tap tap) % := 2)) +;; TODO transfer try/catch (skip "static method call in e/server" (with ((l/single {} (try (tap (e/server (Math/max 2 1))) (catch Pending _))) tap tap) % := 2)) +;; TODO transfer try/catch (skip "static method call in e/client" (with ((l/single {} (try (tap (e/server (subvec (vec (range 10)) (Math/min 1 1) @@ -1136,18 +1148,19 @@ (catch Pending _))) tap tap) % := [1 2])) +;; TODO cc/fn doesn't convey electric bindings because there are no more e/defs (skip "Inline cc/fn support" (def !state (atom 0)) - (l/def global) + (def global) (with ((l/single {} (let [state (e/watch !state) - local [:local state] - f (binding [global [:global state]] - (fn ([a] [a local hyperfiddle.electric-test/global]) - ([a b] [a b local global]) - ([a b & cs] [a b cs local global])))] - (tap (f state)) - (tap (f state :b)) - (tap (f state :b :c :d)))) tap tap) + local [:local state] + f (binding [global [:global state]] + (fn ([a] [a local hyperfiddle.electric-de-test/global]) + ([a b] [a b local global]) + ([a b & cs] [a b cs local global])))] + (tap (f state)) + (tap (f state :b)) + (tap (f state :b :c :d)))) tap tap) % := [0 [:local 0] [:global 0]] % := [0 :b [:local 0] [:global 0]] % := [0 :b '(:c :d) [:local 0] [:global 0]] @@ -1156,34 +1169,35 @@ % := [1 :b [:local 1] [:global 1]] % := [1 :b '(:c :d) [:local 1] [:global 1]])) -(skip "cc/fn lexical bindings are untouched" +(tests "cc/fn lexical bindings are untouched" (with ((l/single {} (let [a 1 b 2 f (fn [a] (let [b 3] [a b]))] (tap (f 2)))) tap tap) % := [2 3])) -(skip "Inline cc/fn shorthand support" +(tests "Inline cc/fn shorthand support" (with ((l/single {} (tap (#(inc %) 1))) tap tap) % := 2)) -(skip "inline m/observe support" +(tests "inline m/observe support" (let [!state (atom 0)] (with ((l/single {} (let [state (e/watch !state) - lifecycle (m/observe (fn [push] - (tap :up) - (push state) - #(tap :down))) - val (new lifecycle)] - (tap val))) tap tap) + lifecycle (m/observe (fn [push] + (tap :up) + (push state) + #(tap :down))) + val (e/input lifecycle)] + (tap val))) tap tap) % := :up % := 0 (swap! !state inc) - % := :down % := :up % := 1) - % := :down)) + (instance? Cancelled %) := true + (tap ::done), % := ::done)) +;; TODO cc/letfn (skip "Inline letfn support" (with ((l/single {} (tap (letfn [(descent [x] (cond (pos? x) (dec x) (neg? x) (inc x) @@ -1196,12 +1210,14 @@ % := [false false true true] % := [false false true true])) +;; TODO cc/letfn (skip (with ((l/single {} (try (letfn [(foo [])] (tap (e/watch (atom 1)))) (catch Throwable t (prn t)))) tap tap) % := 1)) +;; TODO cc/letfn, electric binding conveyance (skip "Inline letfn support" (def !state (atom 0)) (l/def global) @@ -1223,42 +1239,42 @@ % := [1 :b '(:c :d) [:local 1] [:global 1]])) #?(:clj - (skip "e/fn is undefined in clojure-land" - (tap (try (lang/analyze {} `(fn [] (e/fn []))) (catch Throwable e (ex-message (ex-cause e))))) - % := "Electric code (hyperfiddle.electric/fn) inside a Clojure function")) + (tests "e/fn is undefined in clojure-land" + (tap (try (lang/expand-all {} `(fn [] (e/fn []))) (catch Throwable e (ex-message (ex-cause e))))) + % := "Electric code (hyperfiddle.electric-de/fn) inside a Clojure function")) #?(:clj - (skip "e/client is undefined in clojure-land" - (tap (try (lang/analyze {} `(fn [] (e/client []))) (catch Throwable e (ex-message (ex-cause e))))) - % := "Electric code (hyperfiddle.electric/client) inside a Clojure function")) + (tests "e/client is undefined in clojure-land" + (tap (try (lang/expand-all {} `(fn [] (e/client []))) (catch Throwable e (ex-message (ex-cause e))))) + % := "Electric code (hyperfiddle.electric-de/client) inside a Clojure function")) #?(:clj - (skip "e/server is undefined in clojure-land" - (tap (try (lang/analyze {} `(fn [] (e/server []))) (catch Throwable e (ex-message (ex-cause e))))) - % := "Electric code (hyperfiddle.electric/server) inside a Clojure function")) + (tests "e/server is undefined in clojure-land" + (tap (try (lang/expand-all {} `(fn [] (e/server []))) (catch Throwable e (ex-message (ex-cause e))))) + % := "Electric code (hyperfiddle.electric-de/server) inside a Clojure function")) #?(:clj - (skip "e/server is undefined in clojure-land" - (tap (try (lang/analyze {} `(fn [] (e/watch (atom :nomatter)))) (catch Throwable e (ex-message (ex-cause e))))) - % := "Electric code (hyperfiddle.electric/watch) inside a Clojure function")) + (tests "e/watch is undefined in clojure-land" + (tap (try (lang/expand-all {} `(fn [] (e/watch (atom :nomatter)))) (catch Throwable e (ex-message (ex-cause e))))) + % := "Electric code (hyperfiddle.electric-de/watch) inside a Clojure function")) -(skip "cycle" +(tests "cycle" (with ((l/single {} (let [!F (atom (e/fn [] 0))] - (tap (new (new (m/watch !F)))) + (tap ($ (e/watch !F))) (let [y 1] (reset! !F (e/fn [] y))))) tap tap) % := 0 % := 1)) #?(:clj ; test broken in cljs, not sure why - (skip "loop/recur" - (l/defn fib [n] (loop [n n] (if (<= n 2) 1 (+ (recur (dec n)) (recur (- n 2)))))) - (with ((l/single {} (tap (e/for [i (range 1 11)] (fib. i)))) tap tap) + (tests "loop/recur" + (e/defn fib [n] (loop [n n] (if (<= n 2) 1 (+ (recur (dec n)) (recur (- n 2)))))) + (with ((l/single {} (tap (e/for-by identity [i (range 1 11)] ($ fib i)))) tap tap) % := [1 1 2 3 5 8 13 21 34 55]))) ;; currently broken https://www.notion.so/hyperfiddle/cr-macro-internal-mutation-violates-photon-purity-requirement-119c18755ddd466384beb15f1e2317c5 #_ -(skip +(comment "inline m/cp support" (let [!state (atom 0)] (with (p/run (let [state (p/watch !state)] @@ -1278,6 +1294,7 @@ % := 2 % := 2))) +;; TODO cc/letfn (skip "letfn body is electric" (l/def z 3) (def !x (atom 4)) @@ -1288,7 +1305,7 @@ ;; currently broken https://www.notion.so/hyperfiddle/cr-macro-internal-mutation-violates-photon-purity-requirement-119c18755ddd466384beb15f1e2317c5 #_ -(skip +(comment "inline m/sp support" (let [!state (atom 0)] (with (p/run (let [val (p/watch !state) @@ -1335,6 +1352,7 @@ (set! (.-x o) (new (e/fn [] 0)))))) tap tap) % := 0))) +;; TODO e/fn arity check, try/catch (skip "e/fn arity check" (with ((l/single {} (try (new (e/fn [x y z] (throw (ex-info "nope" {}))) 100 200 300 400) (catch ExceptionInfo e (tap e)) @@ -1342,6 +1360,7 @@ (catch Throwable t (prn t)))) tap tap) (ex-message %) := "You called with 4 arguments but it only supports 3")) +;; TODO e/fn arity check, try/catch ;; (l/defn ThreeThrow [_ _ _] (throw (ex-info "nope"))) (skip "e/fn arity check" (with ((l/single {} (try (new ThreeThrow 100 200 300 400) @@ -1350,6 +1369,7 @@ (catch Throwable t (prn t)))) tap tap) (ex-message %) := "You called ThreeThrow with 4 arguments but it only supports 3")) +;; TODO e/fn arity check, try/catch (skip "e/fn arity check" (with ((l/single {} (try (new (e/fn Named [x y] (throw (ex-info "nope" {}))) 100) (catch ExceptionInfo e (tap e)) @@ -1357,6 +1377,7 @@ (catch Throwable t (prn t)))) tap tap) (ex-message %) := "You called Named with 1 argument but it only supports 2")) +;; TODO e/partial (skip "Partial application" (with ((l/single {} (tap (new (e/partial 0 (e/fn [] :a)) )) @@ -1368,31 +1389,31 @@ % := [:a :b] % := [:a :b :c :d])) -;; (l/def Factorial-gen (e/fn [Rec] -;; (e/fn [n] -;; (if (zero? n) -;; 1 -;; (* n (new Rec (dec n))))))) +(e/defn Factorial-gen [Rec] + (e/fn [n] + (if (zero? n) + 1 + (* n ($ Rec (dec n)))))) -;; (l/def Y "Y-Combinator" -;; (e/fn [f] -;; (new -;; (e/fn [x] (new x x)) -;; (e/fn [x] (new f (e/fn [y] (new (new x x) y))))))) +(e/defn Y [f] + ($ + (e/fn [x] ($ x x)) + (e/fn [x] ($ f (e/fn [y] ($ ($ x x) y)))))) -(skip "Y-Combinator" +(tests "Y-Combinator" (let [!n (atom 5)] - (with ((l/single {} (tap (new (Y. Factorial-gen) (e/watch !n)))) tap tap) + (with ((l/single {} (tap ($ ($ Y Factorial-gen) (e/watch !n)))) tap tap) % := 120 (reset! !n 20) % := 2432902008176640000))) -(skip "clojure def inside electric code" +(tests "clojure def inside electric code" (def !x (atom 0)) (with ((l/single {} (def --foo (tap (e/watch !x)))) tap tap) % := 0, --foo := 0 (swap! !x inc) % := 1, --foo := 1)) +;; TODO try/catch (skip "catch handlers are work skipped" (def !x (atom 0)) (with ((l/single {} (try (e/watch !x) @@ -1403,6 +1424,7 @@ (swap! !x inc)) ; same exception, so work skipped % := :cancelled) +;; TODO try/catch (skip "pendings don't enter cc/fn's" (with ((l/single {} (try (let [v (new (m/observe (fn [!] (! r/pending) (def ! !) #(do))))] (#(tap [:v %]) v)) @@ -1412,6 +1434,7 @@ (! 1) % := [:v 1])) +;; TODO try/catch (skip "catch code reacts to changes" (def !x (atom 0)) (with ((l/single {} (tap (try (throw (ex-info "boom" {})) @@ -1420,6 +1443,7 @@ (swap! !x inc) % := 1)) +;; TODO try/catch, electric binding conveyance (skip "Electric dynamic scope is available in cc/fn" (l/def ^:dynamic dynfoo 1) (with ((l/single {} @@ -1433,7 +1457,7 @@ % := 2)) #?(:clj ; fail to compile in cljs: `Can't set! local var or non-mutable field` (foo177584 is not dynamic) - (skip "l/def are not dynamic by default in cc/fn" + (comment "l/def are not dynamic by default in cc/fn" (l/def foo177584 1) (with ((l/single {} (try @@ -1441,8 +1465,9 @@ (catch #?(:clj Throwable, :cljs js/Error) t (tap (ex-message t))))) tap tap) % := "Can't dynamically bind non-dynamic var: hyperfiddle.electric-test/foo177584"))) +;; TODO try/catch, electric binding conveyance (skip "Injecting an l/def binding in cc/fn respects dynamic scope rules" - (l/def ^:dynamic dynfoo 1) + (def ^:dynamic dynfoo 1) (with ((l/single {} (try (tap dynfoo) ; electric dynamic context @@ -1459,18 +1484,19 @@ % := 3 % := 2)) -(skip "In Clojure, unqualified names first resolves to lexical scope" +(tests "In Clojure, unqualified names first resolves to lexical scope" (def ^:dynamic foo 1) foo := 1 ; no lexical binding shadowing -> resolve to foo var (let [foo 2] ; lexical shadowing foo := 2 ; resolve to lexical scope - (binding [#?(:clj foo, :cljs hyperfiddle.electric-test/foo) 3] ; always rebind var in clojure. Cljs requires fully qualified name. + (binding [#?(:clj foo, :cljs hyperfiddle.electric-de-test/foo) 3] ; always rebind var in clojure. Cljs requires fully qualified name. foo := 2 ; unqualified name resolves to lexical scope - hyperfiddle.electric-test/foo := 3))) ; qualified name resolves to the var + hyperfiddle.electric-de-test/foo := 3))) ; qualified name resolves to the var +;; TODO try/catch, electric binding conveyance #?(:clj (skip "cc/fn args shadow l/def injections" - (l/def ^:dynamic dynfoo 1) + (def ^:dynamic dynfoo 1) (with ((l/single {} (try (tap dynfoo) ; electric dynamic context @@ -1486,9 +1512,10 @@ % := :argument % := 2))) +;; TODO try/catch, electric binding conveyance #?(:clj (skip "Injected lexical scope respects precedence over injected dynamic scope" - (l/def ^:dynamic dynfoo 1) + (def ^:dynamic dynfoo 1) (with ((l/single {} (try (tap dynfoo) @@ -1505,9 +1532,10 @@ % := :shadowed % := 2))) +;; TODO try/catch, electric binding conveyance #?(:clj (skip "Shadowing injected dynamic scope in cc context respects clojure shadowing rules" - (l/def ^:dynamic dynfoo 1) + (def ^:dynamic dynfoo 1) (with ((l/single {} (try (tap dynfoo) @@ -1525,6 +1553,7 @@ % := :shadowed % := 2))) +;; TODO e/snapshot - is this still a thing? (skip "snapshot" (def flow (e/-snapshot (m/observe (fn [!] (def ! !) #())))) "1 2 -> 1" @@ -1568,6 +1597,7 @@ (tap ::done), % := ::done, (println " ok")) +;; TODO e/for-event, is this still a thing? (skip "for-event" (def ! (atom nil)) (def !resolvers (atom {})) @@ -1599,6 +1629,7 @@ (!! 99 :alive), % := [:alive] (!! 99 (reduced nil)), % := [nil], % := [])) +;; TODO e/for-event-pending, is this still a thing? (skip "for-event-pending" (def ! (atom nil)) (def !resolvers (atom {})) @@ -1620,6 +1651,7 @@ (@! 2), % := [::e/pending e/pending] (!! 2 :fail), % := [::e/failed fail])) +;; TODO e/for-event-pending-switch, is this still a thing? (skip "for-event-pending-switch" (def ! (atom nil)) (def !resolvers (atom {})) @@ -1643,6 +1675,7 @@ (@! 3), % := [::e/pending e/pending] (!! 3 :fail), % := [:unmounted 3], % := [::e/failed fail])) +;; TODO e/do-event, is this still a thing? (skip "do-event" (def ! (atom nil)) (def !resolvers (atom {})) @@ -1674,6 +1707,7 @@ (!! 9 :alive), % := :alive (!! 9 (reduced true)), % := nil)) +;; TODO e/do-event-pending, is this still a thing? (skip "do-event-pending" (def ! (atom nil)) (def !resolvers (atom {})) @@ -1695,6 +1729,7 @@ (@! 2), % := [:mount 2], % := [::e/pending e/pending] (!! 2 :fail), % := [::e/failed fail])) +;; TODO try/catch, e/offload, requires Pending #?(:clj (skip "e/offload starts Pending" (def dfv (m/dfv)) @@ -1705,6 +1740,7 @@ (dfv 1) % := 1))) +;; TODO try/catch, e/offload, requires Pending #?(:clj (skip "e/offload doesn't throw Pending subsequently" (def !dfv (atom (m/dfv))) @@ -1719,6 +1755,7 @@ (@!dfv 2) % := 2))) +;; TODO try/catch, e/offload, requires Pending #?(:clj (skip "e/offload on overlap uses latest value and discards previous" (def d1 (m/dfv)) @@ -1733,6 +1770,7 @@ % := 2 (d1 1)))) +;; TODO try/catch, e/offload, requires Pending #?(:clj (skip "e/offload thunk is running on another thread" (defn get-thread [] (Thread/currentThread)) @@ -1741,6 +1779,7 @@ (catch Throwable ex (prn ex)))) tap tap) (count (hash-set % (get-thread))) := 2))) +;; TODO cljs #?(:cljs (do-browser (skip "goog module calls don't trigger warnings" @@ -1750,87 +1789,91 @@ (catch :default ex (ex-message ex))))) tap tap) % := :ok)))) +;; TODO try/catch (skip - (with ((l/single {} (tap (try (new nil) (catch #?(:clj Throwable :cljs :default) e e)))) tap tap) + (with ((l/single {} (tap (try ($ nil) (catch #?(:clj Throwable :cljs :default) e e)))) tap tap) (ex-message %) := "called `new` on nil")) +;; TODO try/catch (skip (with ((l/single {} (tap (try (e/watch :foo) (throw (ex-info "nope" {})) (catch ExceptionInfo e e)))) tap tap) (str/includes? (ex-message %) ":foo") := true)) -(skip "l/def initialized to `nil` works in cc/fn" - (l/def foo nil) - (with ((l/single {} (binding [foo "foo"] (let [f foo] (#(tap [f foo]))))) tap tap) - % := ["foo" "foo"])) - +;; TODO e/fn varargs (skip "e/fn varargs" - (with ((l/single+ {} (new (e/fn [x & xs] (tap [x xs])) 1 2 3 4)) tap tap) + (with ((l/single {} (new (e/fn [x & xs] (tap [x xs])) 1 2 3 4)) tap tap) % := [1 [2 3 4]])) (skip "e/fn varargs recursion with recur" - (with ((l/single+ {} (new (e/fn [x & xs] (tap [x xs])) 1 2 3 4)) tap tap) + (with ((l/single {} (new (e/fn [x & xs] (tap [x xs])) 1 2 3 4)) tap tap) % := [1 [2 3 4]])) (skip "e/fn varargs recur is arity-checked" - (with ((l/single+ {} (tap (try (new (e/fn [x & xs] (recur)) 1 2 3) + (with ((l/single {} (tap (try (new (e/fn [x & xs] (recur)) 1 2 3) (catch ExceptionInfo e e)))) tap tap) (ex-message %) := "You `recur`d in with 0 arguments but it has 2 positional arguments")) +;; TODO e/fn map vararg ;; (l/defn MapVararg [& {:keys [x] :or {x 1} :as mp}] [x mp]) (skip "map vararg with no args is nil" - (with ((l/single+ {} (tap (MapVararg.))) tap tap) + (with ((l/single {} (tap (MapVararg.))) tap tap) % := [1 nil])) (skip "map vararg with kw args" - (with ((l/single+ {} (tap (MapVararg. :x 2))) tap tap) + (with ((l/single {} (tap (MapVararg. :x 2))) tap tap) % := [2 {:x 2}])) (skip "map vararg with map arg" - (with ((l/single+ {} (tap (MapVararg. {:x 2}))) tap tap) + (with ((l/single {} (tap (MapVararg. {:x 2}))) tap tap) % := [2 {:x 2}])) (skip "map vararg with mixture" - (with ((l/single+ {} (tap (MapVararg. :y 3 {:x 2}))) tap tap) + (with ((l/single {} (tap (MapVararg. :y 3 {:x 2}))) tap tap) % := [2 {:x 2, :y 3}])) (skip "map vararg trailing map takes precedence" - (with ((l/single+ {} (tap (MapVararg. :x 3 {:x 2}))) tap tap) + (with ((l/single {} (tap (MapVararg. :x 3 {:x 2}))) tap tap) % := [2 {:x 2}])) (skip "map vararg with positional arguments" - (with ((l/single+ {} (tap (new (e/fn [a & {:keys [x]}] [a x]) 1 :x 2))) tap tap) + (with ((l/single {} (tap (new (e/fn [a & {:keys [x]}] [a x]) 1 :x 2))) tap tap) % := [1 2])) +;; TODO try/catch (skip "e/fn recur is arity checked" (with ((l/single {} (tap (try (new (e/fn X [x] (recur x x)) 1) (catch ExceptionInfo e e)))) tap tap) (ex-message %) := "You `recur`d in X with 2 arguments but it has 1 positional argument")) -;; (l/defn One [x] x) -;; (l/defn Two [x y] [x y]) +(e/defn One [x] x) +(e/defn Two [x y] [x y]) ;; (l/defn VarArgs [x & xs] [x xs]) -(skip "(new One 1)" - (with ((l/single {} (tap (new One 1))) tap tap) +(tests "($ One 1)" + (with ((l/single {} (tap ($ One 1))) tap tap) % := 1)) -(skip "(new VarArgs 1 2 3)" - (with ((l/single {} (tap (new VarArgs 1 2 3))) tap tap) +;; TODO e/fn varargs +(skip "($ VarArgs 1 2 3)" + (with ((l/single {} (tap ($ VarArgs 1 2 3))) tap tap) % := [1 [2 3]])) (skip "varargs arity is checked" (with ((l/single {} (tap (try (new VarArgs) (catch ExceptionInfo e e)))) tap tap) (ex-message %) := "You called VarArgs with 0 arguments but it only supports 1")) +;; TODO e/fn varargs (skip "e/apply" - (with ((l/single+ {} (tap (e/apply VarArgs [1 2 3]))) tap tap) + (with ((l/single {} (tap (e/apply VarArgs [1 2 3]))) tap tap) % := [1 [2 3]])) -(skip "e/apply" - (with ((l/single+ {} (tap (e/apply Two 1 [2]))) tap tap) +(tests "e/apply" + (with ((l/single {} (tap (e/apply Two 1 [2]))) tap tap) % := [1 2])) -(skip "e/apply" - (with ((l/single+ {} (tap (e/apply Two [1 2]))) tap tap) +(tests "e/apply" + (with ((l/single {} (tap (e/apply Two [1 2]))) tap tap) % := [1 2])) -(skip "e/apply" - (with ((l/single+ {} (tap (e/apply Two [1 (inc 1)]))) tap tap) +(tests "e/apply" + (with ((l/single {} (tap (e/apply Two [1 (inc 1)]))) tap tap) % := [1 2])) +;; TODO try/catch (skip "e/apply" - (with ((l/single+ {} (tap (try (e/apply Two [1 2 3]) (throw (ex-info "boo" {})) + (with ((l/single {} (tap (try (e/apply Two [1 2 3]) (throw (ex-info "boo" {})) (catch ExceptionInfo e e)))) tap tap) (ex-message %) := "You called Two with 3 arguments but it only supports 2")) +;; TODO e/fn multi-arity (skip "multi-arity e/fn" (with ((l/single {} (tap (new (e/fn ([_] :one) ([_ _] :two)) 1))) tap tap) % := :one)) @@ -1841,16 +1884,17 @@ (with ((l/single {} (tap (new (e/fn ([_]) ([_ & xs] (mapv inc xs))) 1 2 3 4))) tap tap) % := [3 4 5])) (skip "multi-arity e/fn" - (with ((l/single+ {} (tap (e/apply (e/fn ([_] :one) ([_ _] :two)) 1 [2]))) tap tap) + (with ((l/single {} (tap (e/apply (e/fn ([_] :one) ([_ _] :two)) 1 [2]))) tap tap) % := :two)) (skip "multi-arity e/fn" - (with ((l/single+ {} (tap (e/apply (e/fn ([_]) ([_ & xs] (mapv inc xs))) 1 2 [3 4]))) tap tap) + (with ((l/single {} (tap (e/apply (e/fn ([_]) ([_ & xs] (mapv inc xs))) 1 2 [3 4]))) tap tap) % := [3 4 5])) +;; TODO e/fn self-recur (skip "self-recur by name, e/fn" (with ((l/single {} (tap (new (e/fn fib [n] (case n 0 0 1 1 (+ (fib. (- n 1)) (fib. (- n 2))))) 6))) tap tap) % := 8)) -(skip "self-recur by name, l/defn" +(skip "self-recur by name, e/defn" (l/defn Fib [n] (case n 0 0 1 1 (+ (Fib. (- n 1)) (Fib. (- n 2))))) (with ((l/single {} (tap (Fib. 7))) tap tap) % := 13)) @@ -1869,6 +1913,7 @@ % := nil % := :done)) +;; TODO e/fn multi-arity #?(:clj (skip "e/fn multi-arity mistakes" (binding [expand/*electric* true] @@ -1885,7 +1930,7 @@ (ex-message (ex-cause %)) := "Conflicting arity definitions: [x & ys] and [x y & zs]"))) #?(:cljs - (skip "#js" + (tests "#js" (def !x (atom 0)) (with ((l/single {} (let [x (e/watch !x)] (tap #js {:x x}) @@ -1897,7 +1942,7 @@ (aget % 1) := 1))) #?(:clj - (skip "jvm interop" + (tests "jvm interop" (with ((l/single {} (let [f (java.io.File. "src") pt (java.awt.Point. 1 2)] @@ -1908,7 +1953,7 @@ % := ["src" 1 1.0]))) #?(:cljs - (skip "js interop" + (tests "js interop" (with ((l/single {} (let [^js o #js {:a 1 :aPlus (fn [n] (inc n))}] (tap [(.aPlus o 1) ; instance method @@ -1916,6 +1961,7 @@ ]))) tap tap) % := [2 1]))) +;; TODO cljs #?(:clj (skip "we capture invalid calls" (binding [expand/*electric* true] @@ -1956,102 +2002,62 @@ "clj static field works" (lang/analyze (assoc (l/->local-config {}) ::lang/current :server ::lang/me :server) 'clojure.lang.PersistentArrayMap/EMPTY)))) -(skip "e/server e/client body" +(tests "e/server e/client body" (with ((l/single {} (tap (e/client 1 2))) tap tap) % := 2)) -;; (defn signify [node] (symbol (str/replace (str node) #"_hf_.*" ""))) - -#?(:clj - (skip "we keep node order" - (l/def A 1) - (l/def B 2) - (l/def C 3) - ;; (require '[hyperfiddle.electric.impl.ir-utils :as ir-utils]) - - (->> (lang/analyze (assoc (l/->local-config {}) ::lang/current :client ::lang/me :client) - '[A (e/server B) C]) - ;; ir-utils/unwrite - r/find-nodes (mapv signify)) - := - (->> (lang/analyze (assoc (l/->local-config {}) ::lang/current :client ::lang/me :server) - '[A (e/server B) C]) - r/find-nodes (mapv signify)))) - +;; TODO #?(:clj (skip "l/def marks the namespace" - (l/def Foo 1) + (e/defn Foo [] 1) (-> *ns* meta ::lang/has-edef?) := true)) +;; TODO #?(:clj (skip "cljs macroexpansion regression" - (binding [expand/*electric* true] - (-> (expand/all {::lang/peers {:server :clj, :client :cljs}, ::lang/current :client, ::lang/me :server, :ns 'hyperfiddle.electric-test} - '(e/fn Foo [])) - first) := ::lang/closure))) + (-> (lang/expand-all {::lang/peers {:server :clj, :client :cljs}, ::lang/current :client, ::lang/me :server, :ns 'hyperfiddle.electric-test} + '(e/fn Foo [])) + first) := ::lang/ctor)) -(skip "set literal" +(tests "set literal" (def !v (atom 1)) (with ((l/single {} (tap #{(e/watch !v)})) tap tap) % := #{1} (swap! !v inc) % := #{2})) -(skip "calling an electric defn in a clojure defn as a clojure defn" - (l/defn ElectricFn [] 1) - (defn clj-fn2 [] (inc (ElectricFn))) - (try (clj-fn2) (throw (ex-info "unreachable" {})) - (catch ExceptionInfo e (ex-message e) := "I'm an electric value and you called me outside of electric."))) - -(skip "let over e/def" - (let [x 1] (l/def XX [x x])) - (with ((l/single {} (tap XX)) tap tap) +(tests "let over e/def" + (let [x 1] (e/defn XX [] [x x])) + (with ((l/single {} (tap ($ XX))) tap tap) % := [1 1])) -#?(:clj - (skip "::lang/only filters e/def compilation" - (l/def ^{::lang/only #{:server}} ServerOnly 1) - (some? (find-var `ServerOnly_hf_server_server)) := true - (some? (find-var `ServerOnly_hf_client_server)) := true - (not (find-var `ServerOnly_hf_server_client)) := true - (not (find-var `ServerOnly_hf_client_client)) := true)) - (deftype FieldAccess [x]) -(skip "non-static first arg to . or .. works" +(tests "non-static first arg to . or .. works" (with ((l/single {} (tap (.. (FieldAccess. 1) -x))) tap tap) % := 1)) -(skip "lexical first arg to . or .. works" +(tests "lexical first arg to . or .. works" (with ((l/single {} (let [fa (FieldAccess. 1)] (tap (.. fa -x)))) tap tap) % := 1)) -(skip "()" +(tests "()" (with ((l/single {}+ {} (tap ())) tap tap) % := ())) -(skip "(#())" +(tests "(#())" (with ((l/single {}+ {} (tap (#()))) tap tap) % := ())) -(skip "((fn []))" +(tests "((fn []))" (with ((l/single {}+ {} (tap ((fn [])))) tap tap) % := nil)) -(skip "::lang/non-causal removes causality in `let`" - (l/defn ^::lang/non-causal NonCausalLet [tap] - (let [_ (tap 1)] (tap 2))) - (with ((l/single {} (NonCausalLet. tap)) tap tap) - ;; % := 1 - % := 2)) - -(skip "::lang/non-causal removes causality in `binding`" - (l/def NonCausalEDef) - (l/defn ^::lang/non-causal NonCausalBinding [tap] - (binding [NonCausalEDef (tap 1)] (tap 2))) - (with ((l/single {} (NonCausalBinding. tap)) tap tap) - ;; % := 1 - % := 2)) - -(skip "binding in interop fn" +(tests "binding in interop fn" (with ((l/single {} (tap ((fn [] (binding [*out* nil] 1))))) tap tap) % := 1)) + +(let [{:keys [tested skipped tbd]} @stats, all (+ tested skipped tbd)] + (prn '===) + (println 'tested_ tested (format "%.0f%%" (double (* (/ tested all) 100)))) + (println 'skipped skipped (format "%.0f%%" (double (* (/ skipped all) 100)))) + (println 'missing tbd (format "%.0f%%" (double (* (/ tbd all) 100))))) From 7713f39fb7f278a62c589737accdd3b658d0a044 Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 13 Feb 2024 15:33:18 +0100 Subject: [PATCH 099/428] cleanup --- test/hyperfiddle/electric_de_test.cljc | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index e71b4645a..c30a82b9a 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -9,14 +9,11 @@ [missionary Cancelled] #?(:clj [clojure.lang ExceptionInfo]))) -(def stats (atom {:skipped 0, :tbd 0, :tested 0})) +(def stats (atom {:skipped 0, :tested 0})) (defmacro skip {:style/indent 0} [& _body] `(do (swap! stats update :skipped inc) (pr '~'-))) -(defmacro tbd {:style/indent 0} [& _body] - `(do (swap! stats update :tbd inc) (pr '~'?))) - (defmacro tests {:style/indent 0} [& body] `(do (swap! stats update :tested inc) (rcf/tests ~@body))) @@ -2056,8 +2053,7 @@ (with ((l/single {} (tap ((fn [] (binding [*out* nil] 1))))) tap tap) % := 1)) -(let [{:keys [tested skipped tbd]} @stats, all (+ tested skipped tbd)] +(let [{:keys [tested skipped]} @stats, all (+ tested skipped)] (prn '===) - (println 'tested_ tested (format "%.0f%%" (double (* (/ tested all) 100)))) - (println 'skipped skipped (format "%.0f%%" (double (* (/ skipped all) 100)))) - (println 'missing tbd (format "%.0f%%" (double (* (/ tbd all) 100))))) + (println 'tested tested (format "%.0f%%" (double (* (/ tested all) 100)))) + (println 'skipped skipped (format "%.0f%%" (double (* (/ skipped all) 100))))) From cc9ff94a905122aee7cd9783f929ce7e2c2ebf5c Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 14 Feb 2024 13:52:38 +0100 Subject: [PATCH 100/428] compiler: fix expansion in cc/fn and cc/letfn --- src/hyperfiddle/electric/impl/lang_de2.clj | 49 +++++++++++++--------- src/hyperfiddle/electric_de.cljc | 2 +- test/hyperfiddle/electric_de_test.cljc | 45 +++++++++++++------- 3 files changed, 59 insertions(+), 37 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 92b3542f8..7c5f3e8fc 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -130,7 +130,11 @@ (ensure-cljs-compiler (cljs-ana/parse 'ns (->cljs-env) '(ns foo (:require [hyperfiddle.electric :as e])) 'ns {})) ) -(defn macroexpand-clj [o] (serialized-require (ns-name *ns*)) (macroexpand-1 o)) +(defn macroexpand-clj [o env] + (serialized-require (ns-name *ns*)) + (if-some [mac (when-some [mac (resolve env (first o))] (when (.isMacro ^clojure.lang.Var mac) mac))] + (apply mac o env (next o)) + (macroexpand-1 o))) ; e.g. (Math/abs 1) will expand to (. Math abs 1) (defn expand-referred-or-local-macros [o cljs-macro-env] ;; (:require [some.ns :refer [some-macro]]) @@ -158,23 +162,38 @@ (if-some [expander (cljs-ana/get-expander f cljs-macro-env)] (apply expander o cljs-macro-env args) (expand-referred-or-local-macros o cljs-macro-env))))) - (macroexpand-clj o))))))) + (macroexpand-clj o env))))))) (defn find-local-entry [env sym] (find (:locals env) sym)) (defn add-local [env sym] (update env :locals assoc sym ::unknown)) -(def ^:dynamic *electric* false) - (defn ?meta [metao o] (if (instance? clojure.lang.IObj o) (cond-> o (meta metao) (vary-meta #(merge (meta metao) %))) o)) +(declare -expand-all) + +(defn ?expand-macro [o env caller] + (if (symbol? (first o)) + (let [o2 (expand-macro env o)] + (if (identical? o o2) + (?meta o (list* (first o) (mapv (fn-> caller env) (rest o)))) + (caller o2 env))) + (?meta o (list* (caller (first o) env) (mapv (fn-> caller env) (next o)))))) + +(defn -expand-all-non-electric [o env] + (if (and (seq? o) (seq o)) + (if (find-local-entry env (first o)) + (?meta o (list* (first o) (mapv (fn-> -expand-all env) (rest o)))) + (?expand-macro o (assoc env ::electric false) -expand-all-non-electric)) + o)) + (defn -expand-all [o env] (cond (and (seq? o) (seq o)) (if (find-local-entry env (first o)) - (list* (first o) (mapv (fn-> -expand-all env) (rest o))) + (?meta o (list* (first o) (mapv (fn-> -expand-all env) (rest o)))) (case (first o) ;; (ns ns* deftype* defrecord* var) @@ -227,15 +246,13 @@ (?meta o (apply list (into (if ?name ['fn* ?name] ['fn*]) (map (fn [[syms & body]] - (binding [*electric* false] - (list syms (-expand-all (cons 'do body) (reduce add-local env syms)))))) + (list syms (-expand-all-non-electric (cons 'do body) (reduce add-local env syms))))) arities)))) (letfn*) (let [[_ bs & body] o env2 (reduce add-local env (take-nth 2 bs)) - xpand (fn-> -expand-all env2) bs2 (into [] (comp (partition-all 2) - (mapcat (fn [[sym v]] [sym (binding [*electric* false] (xpand v))]))) + (mapcat (fn [[sym v]] [sym (-expand-all-non-electric v env2)]))) bs)] (?meta o `(let* [~(vec (take-nth 2 bs2)) (::letfn ~bs2)] ~(-expand-all (cons 'do body) env2)))) @@ -247,20 +264,12 @@ (?meta o (list 'binding (into [] (comp (partition-all 2) (mapcat (fn [[sym v]] [sym (-expand-all v env)]))) bs) (-expand-all (cons 'do body) env)))) - (set!) (if *electric* - (recur (?meta o `((fn* [v#] (set! ~(nth o 1) v#)) ~(nth o 2))) env) - (?meta o (list 'set! (-expand-all (nth o 1) env) (-expand-all (nth o 2) env)))) + (set!) (recur (?meta o `((fn* [v#] (set! ~(nth o 1) v#)) ~(nth o 2))) env) (::site) (?meta o (seq (conj (into [] (take 2) o) (-expand-all (cons 'do (drop 2 o)) (assoc env ::current (second o)))))) - #_else - (if (symbol? (first o)) - (let [o2 (expand-macro env o)] - (if (identical? o o2) - (?meta o (list* (first o) (mapv (fn-> -expand-all env) (rest o)))) - (recur (?meta o o2) env))) - (?meta o (list* (-expand-all (first o) env) (mapv (fn-> -expand-all env) (next o))))))) + #_else (?expand-macro o env -expand-all))) (map-entry? o) (clojure.lang.MapEntry. (-expand-all (key o) env) (-expand-all (val o) env)) (coll? o) (?meta (meta o) (into (empty o) (map (fn-> -expand-all env)) o)) @@ -283,7 +292,7 @@ ;; if ::current = :cljs expand with cljs environment -(defn expand-all [env o] (ensure-cljs-compiler (binding [*electric* true] (-expand-all o (ensure-cljs-env env))))) +(defn expand-all [env o] (ensure-cljs-compiler (-expand-all o (ensure-cljs-env (assoc env ::electric true))))) ;;;;;;;;;;;;;;;; ;;; COMPILER ;;; diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index f998f48bc..fd24e46e0 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -31,7 +31,7 @@ Returns the successive states of items described by `incseq`. " [flow] `(::lang/join ~flow)) (defmacro check-electric [fn form] - (if lang/*electric* + (if (::lang/electric &env) form (throw (ex-info (str "Electric code (" fn ") inside a Clojure function") (into {:electric-fn fn} (meta &form)))))) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index c30a82b9a..47867bcb3 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -1177,6 +1177,17 @@ (with ((l/single {} (tap (#(inc %) 1))) tap tap) % := 2)) +(tests "inline m/observe support" + (with ((l/single {} + (tap (e/input (m/observe (fn [!] + (tap :up) + (! :observe) + #(tap :down)))))) tap tap) + % := :up + % := :observe) + % := :down + (instance? Cancelled %) := true) + (tests "inline m/observe support" (let [!state (atom 0)] (with ((l/single {} (let [state (e/watch !state) @@ -1191,21 +1202,23 @@ (swap! !state inc) % := :up % := 1) - (instance? Cancelled %) := true - (tap ::done), % := ::done)) + % := :down + % := :down + (instance? Cancelled %) := true)) + ;; TODO cc/letfn (skip "Inline letfn support" - (with ((l/single {} (tap (letfn [(descent [x] (cond (pos? x) (dec x) - (neg? x) (inc x) - :else x)) - (is-even? [x] (if (zero? x) true (is-odd? (descent x)))) - (is-odd? [x] (if (zero? x) false (is-even? (descent x))))] - (tap [(is-even? 0) (is-even? 1) (is-even? 2) (is-even? -2)]) - (tap [(is-odd? 0) (is-odd? 2) (is-odd? 3) (is-odd? -3)])))) tap tap) - % := [true false true true] - % := [false false true true] - % := [false false true true])) + (with ((l/single {} (tap (letfn [(descent [x] (cond (pos? x) (dec x) + (neg? x) (inc x) + :else x)) + (is-even? [x] (if (zero? x) true (is-odd? (descent x)))) + (is-odd? [x] (if (zero? x) false (is-even? (descent x))))] + (tap [(is-even? 0) (is-even? 1) (is-even? 2) (is-even? -2)]) + (tap [(is-odd? 0) (is-odd? 2) (is-odd? 3) (is-odd? -3)])))) tap tap) + % := [true false true true] + % := [false false true true] + % := [false false true true])) ;; TODO cc/letfn (skip @@ -1237,22 +1250,22 @@ #?(:clj (tests "e/fn is undefined in clojure-land" - (tap (try (lang/expand-all {} `(fn [] (e/fn []))) (catch Throwable e (ex-message (ex-cause e))))) + (tap (try (lang/expand-all {} `(fn [] (e/fn []))) (catch Throwable e (ex-message e)))) % := "Electric code (hyperfiddle.electric-de/fn) inside a Clojure function")) #?(:clj (tests "e/client is undefined in clojure-land" - (tap (try (lang/expand-all {} `(fn [] (e/client []))) (catch Throwable e (ex-message (ex-cause e))))) + (tap (try (lang/expand-all {} `(fn [] (e/client []))) (catch Throwable e (ex-message e)))) % := "Electric code (hyperfiddle.electric-de/client) inside a Clojure function")) #?(:clj (tests "e/server is undefined in clojure-land" - (tap (try (lang/expand-all {} `(fn [] (e/server []))) (catch Throwable e (ex-message (ex-cause e))))) + (tap (try (lang/expand-all {} `(fn [] (e/server []))) (catch Throwable e (ex-message e)))) % := "Electric code (hyperfiddle.electric-de/server) inside a Clojure function")) #?(:clj (tests "e/watch is undefined in clojure-land" - (tap (try (lang/expand-all {} `(fn [] (e/watch (atom :nomatter)))) (catch Throwable e (ex-message (ex-cause e))))) + (tap (try (lang/expand-all {} `(fn [] (e/watch (atom :nomatter)))) (catch Throwable e (ex-message e)))) % := "Electric code (hyperfiddle.electric-de/watch) inside a Clojure function")) (tests "cycle" From ae3a46461e596995aaba5f88f68bb97190861cc6 Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 14 Feb 2024 14:42:19 +0100 Subject: [PATCH 101/428] more exact test --- test/hyperfiddle/electric_de_test.cljc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 47867bcb3..de951396c 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -1201,8 +1201,8 @@ % := 0 (swap! !state inc) % := :up - % := 1) - % := :down + % := 1 + % := :down) % := :down (instance? Cancelled %) := true)) From 6dee6aefc664d86101cd4d4a8245777bfd18234f Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 15 Feb 2024 17:39:49 +0100 Subject: [PATCH 102/428] cljs analyzer checkpoint macros from :require and :require-macros work --- deps.edn | 1 + src/contrib/debug.cljc | 18 +- .../electric/impl/cljs_analyzer.clj | 238 ++++++++++++++++++ .../electric/impl/cljs_analyzer_test.clj | 25 ++ .../electric/impl/cljs_file_to_analyze.cljs | 23 ++ .../impl/cljs_file_to_analyze/include.cljc | 3 + .../impl/cljs_file_to_analyze/macro_ns.clj | 5 + .../cljs_file_to_analyze/refer_macros.cljc | 3 + .../impl/cljs_file_to_analyze/require.cljc | 6 + 9 files changed, 312 insertions(+), 10 deletions(-) create mode 100644 src/hyperfiddle/electric/impl/cljs_analyzer.clj create mode 100644 test/hyperfiddle/electric/impl/cljs_analyzer_test.clj create mode 100644 test/hyperfiddle/electric/impl/cljs_file_to_analyze.cljs create mode 100644 test/hyperfiddle/electric/impl/cljs_file_to_analyze/include.cljc create mode 100644 test/hyperfiddle/electric/impl/cljs_file_to_analyze/macro_ns.clj create mode 100644 test/hyperfiddle/electric/impl/cljs_file_to_analyze/refer_macros.cljc create mode 100644 test/hyperfiddle/electric/impl/cljs_file_to_analyze/require.cljc diff --git a/deps.edn b/deps.edn index c46823b3b..0459330f6 100644 --- a/deps.edn +++ b/deps.edn @@ -11,6 +11,7 @@ org.clojure/clojurescript {:mvn/version "1.11.60"} org.clojure/tools.analyzer.jvm {:mvn/version "1.2.2"} ;; used by Electric org.clojure/tools.logging {:mvn/version "1.2.4"} + borkdude/edamame {:mvn/version "1.4.25"} } :aliases {:dev {:extra-paths ["src-dev" "src-docs" "test" "scratch" "resources-demo"] ; for clj command diff --git a/src/contrib/debug.cljc b/src/contrib/debug.cljc index ac57a0bd1..12a4bb4fb 100644 --- a/src/contrib/debug.cljc +++ b/src/contrib/debug.cljc @@ -4,21 +4,19 @@ (:import #?(:clj [clojure.lang IFn IDeref]) [hyperfiddle.electric Failure])) +(def ^:dynamic *dbg* true) + (defmacro dbg ([form] `(dbg '~form ~form)) ([label form] (let [[label form] (if (keyword? form) [form label] [label form])] - `(let [[st# v#] (try [:ok ~form] (catch ~(if (:js-globals &env) :default 'Throwable) ex# [:ex ex#]))] - (prn ~label st# '~'==> v#) - (if (= st# :ok) v# (throw v#)))))) + `(if *dbg* + (let [[st# v#] (try [:ok ~form] (catch ~(if (:js-globals &env) :default 'Throwable) ex# [:ex ex#]))] + (prn ~label st# '~'==> v#) + (if (= st# :ok) v# (throw v#))) + ~form)))) -(defmacro dbg-when - ([pred form] `(dbg-when '~form ~pred ~form)) - ([label pred form] - (let [[label form] (if (keyword? form) [form label] [label form])] - `(let [[st# v#] (try [:ok ~form] (catch ~(if (:js-globals &env) :default 'Throwable) ex# [:ex ex#]))] - (when (~pred v#) (prn ~label st# '~'==> v#)) - (if (= st# :ok) v# (throw v#)))))) +(defmacro dbg-when [form & body] `(binding [*dbg* ~form] ~@body)) (defmacro dbgv [form] `(let [args# [~@form], v# ~form] (prn '~form '~'==> (cons '~(first form) (rest args#)) '~'==> v#) v#)) diff --git a/src/hyperfiddle/electric/impl/cljs_analyzer.clj b/src/hyperfiddle/electric/impl/cljs_analyzer.clj new file mode 100644 index 000000000..ddcf2bcd5 --- /dev/null +++ b/src/hyperfiddle/electric/impl/cljs_analyzer.clj @@ -0,0 +1,238 @@ +(ns hyperfiddle.electric.impl.cljs-analyzer + (:refer-clojure :exclude [find-var]) + (:require [edamame.core :as ed] + [clojure.core :as cc] + [clojure.tools.reader.reader-types :as rt] + [clojure.java.io :as io] + [cljs.tagged-literals] + [missionary.core :as m] + [contrib.debug] + [cljs.core] ; for cljs macroexpansion + [cljs.env] + [cljs.repl])) ; for cljs macroexpansion + +#_ +(defn get-expander-ns [env ^String nstr] + ;; first check for clojure.* -> cljs.* cases + (let [res (or (resolve-macro-ns-alias env nstr nil) + (resolve-ns-alias env nstr nil)) + nstr (if res (str res) nstr)] + (cond (= "clojure.core" nstr) (find-ns 'cljs.core) + (= "clojure.repl" nstr) (find-ns 'cljs.repl) + (.contains nstr ".") (find-ns (symbol nstr)) + :else (some-> env :ns :require-macros (get (symbol nstr)) find-ns)))) + +(defn ns->basename [ns$] (-> ns$ name (.replace \- \_) (.replace \. \/))) + +(defn ns->resource [ns$] + (let [base (ns->basename ns$)] + (or (io/resource (str base ".cljs")) + (io/resource (str base ".cljc"))))) + +(let [parse-opts (ed/normalize-opts {:all true + :row-key :line + :col-key :column + :end-location false + :readers cljs.tagged-literals/*cljs-data-readers* + :auto-resolve name + :eof ::done})] + (defn ns-forms> [ns$] + (->> (m/ap + (let [rdr (m/?> (m/observe (fn [!] + (let [rdr (rt/source-logging-push-back-reader (io/reader (ns->resource ns$)))] + (! rdr) #(.close ^java.io.Reader rdr)))))] + (m/? (m/?> (m/seed (repeat (m/via m/blk (ed/parse-next rdr parse-opts)))))))) + (m/eduction (take-while (complement #{::done})))))) + +(comment + (m/? (m/reduce conj (ns-forms> 'hyperfiddle.electric.impl.cljs-file-to-analyze))) + ) + +(declare analyze-ns) +(defn ->a [ns$] (assoc (analyze-ns {} 'cljs.core) ::current-ns ns$)) + +(defn safe-require [sym] + ;; we might be expanding clj code before the ns got loaded (during cljs compilation) + ;; to correctly lookup vars the ns needs to be loaded + ;; since shadow-cljs compiles in parallel we need to serialize the requires + (when-not (get (loaded-libs) sym) + (try (#'clojure.core/serialized-require sym) ; try bc it can be cljs file + (catch java.io.FileNotFoundException _)))) + +(defn find-ns-var [^clojure.lang.Namespace nso sym] (.findInternedVar nso sym)) +(declare find-var) + +(defn runtime-var? [f a] (or (find-var f a) (find-var f (assoc a ::current-ns 'cljs.core)))) + +(defn mksym [& xs] (symbol (apply str (mapv #((if (or (keyword? %) (symbol? %)) name str) %) xs)))) + +(defmacro my-deftype [nm & _] `(do (def ~nm) (def ~(mksym '-> nm)))) +(let [blacklisted (into #{} (map cc/find-var) '[cljs.core/exists? cljs.core/str cljs.core/aget cljs.core/* cljs.core/+ cljs.core// cljs.core/let cljs.core/nil? cljs.core/aset clojure.core/gen-interface cljs.core/extend-type]) + from-clj {#'cljs.core/defn #'clojure.core/defn + #'cljs.core/defn- #'clojure.core/defn- + #'cljs.core/declare #'clojure.core/declare + #'cljs.core/defprotocol #'clojure.core/defprotocol + #'cljs.core/deftype #'my-deftype}] + (defn ?expand [ns$ name$ o] + (safe-require ns$) + (let [vr (some-> (find-ns ns$) (find-ns-var name$))] + (if (and vr (.isMacro ^clojure.lang.Var vr)) + (if-some [clj (from-clj vr)] + (apply clj o {} (next o)) + (if (blacklisted vr) + o + (apply vr o {} (next o)))) + o)))) + +(def special? '#{if def fn* do let* loop* letfn* throw try catch finally + recur new set! ns deftype* defrecord* . js* & quote case* var ns*}) + +(defn qualified->parts [qs a] + (let [ns$ (-> qs namespace symbol)] + [(or (-> a ::nses (get (::current-ns a)) ::requires (get ns$)) + (-> a ::nses (get (::current-ns a)) ::require-macros (get ns$)) + ns$) (-> qs name symbol)])) + +(defn simple->parts [s a] + (let [s (or (-> a ::nses (get (::current-ns a)) ::refers (get s)) + (-> a ::nses (get (::current-ns a)) ::refer-macros (get s)) + (mksym (::current-ns a) '/ s))] + [(-> s namespace symbol) (-> s name symbol)])) + +(defn expand [[f :as o] a] + ;; TODO locals, refers + (if (symbol? f) + (cond + (special? f) o + (qualified-symbol? f) (let [[ns$ name$] (qualified->parts f a)] + (?expand ns$ name$ o)) + (runtime-var? f a) o + :else (let [[ns$ name$] (simple->parts f a) + o2 (?expand ns$ name$ o)] + (if (identical? o o2) + (?expand 'cljs.core f o) + o2))) + o)) + +(defn ->def-info [[_def sym _v :as o]] {::name sym, ::meta (merge (meta sym) (meta o))}) + +(defn add-require [a ns$ reqk from$ to$] (assoc-in a [::nses ns$ reqk from$] to$)) + +(defn add-refers [a ns$ refk o req$] + (reduce (fn [a nx] (assoc-in a [::nses ns$ refk (or (get (:rename o) nx) nx)] (mksym req$ '/ nx))) + a (:refer o))) + +(defn -add-require [a ns$ reqk refk r] + (if (or (symbol? r) (string? r)) + (add-require a ns$ reqk r r) + (let [[req$ & o] r, a (add-require a ns$ reqk req$ req$), o (apply hash-map o)] + (cond-> a + (:as o) (add-require ns$ reqk (:as o) req$) + (:refer o) (add-refers ns$ refk o req$) + (:refer-macros o) (recur ns$ reqk refk (into [req$] cat (-> (select-keys o [:as]) (assoc :refer (:refer-macros o))))))))) + +(defn -add-requires [a ns$ rs reqk refk] (reduce #(-add-require % ns$ reqk refk %2) a rs)) + +(defn add-require-macros [a ns$ rs] (-add-requires a ns$ rs ::require-macros ::refer-macros)) +(defn add-requires [a ns$ rs] (-add-requires a ns$ rs ::requires ::refers)) + +(comment + (ns foo + "docstring?" ; TODO + '{attr map?} ; TODO + (:refer-clojure :exclude [str]) ; TODO + (:refer-clojure :rename {str sstr}) ; TODO + (:require x ; DONE + [x] ; DONE + [x :as xy] ; DONE + [x :refer [y]] ; DONE + [x :refer [y] :rename {y yy}] ; DONE + [x :include-macros true] ; DONE + [x :refer-macros [y]]) ; DONE + (:require-macros x ; DONE + [x] ; DONE + [x :as xy] ; DONE + [x :refer [y]] ; DONE + [x :refer [y] :rename {y yy}]) ; DONE + (:use x ; TODO + [x] ; TODO + [x :only [y]] ; TODO + [x :exclude [z]] ; TODO + [x :rename {y z}]) ; TODO + (:use-macros x ; TODO + [x] ; TODO + [x :only [y]] ; TODO + [x :exclude [z]] ; TODO + [x :rename {y z}]) ; TODO + ) + ) +(defn add-ns-info [a [_ns ns$ & args]] + (reduce (fn [a [typ & args]] + (case typ + (:require) (add-requires a ns$ args) + (:require-macros) (add-require-macros a ns$ args) + #_else a)) a args )) + +(defn collect-defs [a o] + (if (and (seq? o) (seq o)) + (case (first o) + (def) (assoc-in a [::nses (::current-ns a) ::defs (second o)] (->def-info o)) + (ns) (add-ns-info a o) + ;; (fn* foo [x] x) (fn* foo ([x] x) ([x y] x)) (fn* [x] x) (fn* ([x] x) ([x y] x)) + (fn*) (let [body (if (symbol? (second o)) (nnext o) (next o)) + arities (if (vector? (first body)) (list body) body)] + (transduce (map #(expand (next %) a)) (completing collect-defs) a arities)) + #_else (let [o2 (expand o a)] + (if (identical? o o2) + (reduce collect-defs a (expand o a)) + (collect-defs a o2)))) + a)) + +;;;;;;;;;;;;;;;;;; +;;; PUBLIC API ;;; +;;;;;;;;;;;;;;;;;; + +(defn analyze-ns + ([ns$] (analyze-ns (->a ns$) ns$)) + ([a ns$] (->> (ns-forms> ns$) (m/reduce collect-defs (assoc a ::current-ns ns$)) m/?))) + +(defn find-var [sym a] + (or (-> a ::nses (get (::current-ns a)) ::defs (get sym)) + (-> a ::nses (get 'cljs.core) ::defs (get sym)))) + + + + + + + +;; probably trash + + +#_(defn ?expand [ns$ name$ o] + (safe-require ns$) + (let [vr (some-> (find-ns ns$) (find-ns-var name$))] + (if (and vr (.isMacro ^clojure.lang.Var vr)) + (apply vr o {} (next o)) + o))) + +#_(defn ?expand [ns$ name$ o] + (safe-require ns$) + (let [vr (some-> (find-ns ns$) (find-ns-var name$))] + (if (and vr (.isMacro ^clojure.lang.Var vr)) + (apply vr o {} (next o)) + o))) + +#_(defn expand [[f :as o] a] + ;; TODO locals, refers + (cond + (qualified-symbol? f) (if (and (= 'cljs.core (::current-ns a)) (= "cljs.core" (namespace f))) + o + (let [sym (unalias f a), ns$ (-> sym namespace symbol), name$ (-> sym name symbol)] + (?expand ns$ name$ o))) + (runtime-var? f a) o + (= 'cljs.core (::current-ns a)) o + :else (let [o2 (?expand (::current-ns a) f o)] + (if (identical? o o2) + (?expand 'cljs.core f o) + o)))) diff --git a/test/hyperfiddle/electric/impl/cljs_analyzer_test.clj b/test/hyperfiddle/electric/impl/cljs_analyzer_test.clj new file mode 100644 index 000000000..6d550a073 --- /dev/null +++ b/test/hyperfiddle/electric/impl/cljs_analyzer_test.clj @@ -0,0 +1,25 @@ +(ns hyperfiddle.electric.impl.cljs-analyzer-test + (:require [clojure.test :as t] + [hyperfiddle.electric.impl.cljs-analyzer :as ana])) + +(t/deftest all + (let [a (ana/analyze-ns 'hyperfiddle.electric.impl.cljs-file-to-analyze)] + (t/is (nil? (ana/find-var 'non a))) + (t/are [x] (some? (ana/find-var x a)) + 'foo + 'bar + 'baz + 'an-fn + 'behind-require + 'str + 'behind-alias + 'behind-require-macros + 'behind-require-macro-alias + 'behind-required-refer + 'behind-required-rename + 'behind-require-macro-refer + 'behind-require-macro-rename + 'behind-include-macros + 'behind-refer-macros + ;; 'refnonmacro ; TODO + ))) diff --git a/test/hyperfiddle/electric/impl/cljs_file_to_analyze.cljs b/test/hyperfiddle/electric/impl/cljs_file_to_analyze.cljs new file mode 100644 index 000000000..be10662a8 --- /dev/null +++ b/test/hyperfiddle/electric/impl/cljs_file_to_analyze.cljs @@ -0,0 +1,23 @@ +(ns hyperfiddle.electric.impl.cljs-file-to-analyze + (:require + [hyperfiddle.electric.impl.cljs-file-to-analyze.require :as req :refer [refdef renameme] :rename {renameme renamed}] + [hyperfiddle.electric.impl.cljs-file-to-analyze.include :as inc :include-macros true] + [hyperfiddle.electric.impl.cljs-file-to-analyze.refer-macros :refer-macros [refmac]]) + (:require-macros [hyperfiddle.electric.impl.cljs-file-to-analyze.macro-ns :as reqmac :refer [reqmacrefer reqmacrename] :rename {reqmacrename reqmacrenamed}])) + +(def foo 1) + +(do (def bar 2) (def baz 3)) + +(do (defn an-fn [])) + +(hyperfiddle.electric.impl.cljs-file-to-analyze.require/macrodef behind-require) +(req/macrodef behind-alias) +(hyperfiddle.electric.impl.cljs-file-to-analyze.macro-ns/reqmacrodef behind-require-macros) +(reqmac/reqmacrodef behind-require-macro-alias) +(refdef behind-required-refer) +(renamed behind-required-rename) +(reqmacrefer behind-require-macro-refer) +(reqmacrenamed behind-require-macro-rename) +(inc/include behind-include-macros) +(refmac behind-refer-macros) diff --git a/test/hyperfiddle/electric/impl/cljs_file_to_analyze/include.cljc b/test/hyperfiddle/electric/impl/cljs_file_to_analyze/include.cljc new file mode 100644 index 000000000..2b47c3681 --- /dev/null +++ b/test/hyperfiddle/electric/impl/cljs_file_to_analyze/include.cljc @@ -0,0 +1,3 @@ +(ns hyperfiddle.electric.impl.cljs-file-to-analyze.include) + +(defmacro include [v] `(def ~v)) diff --git a/test/hyperfiddle/electric/impl/cljs_file_to_analyze/macro_ns.clj b/test/hyperfiddle/electric/impl/cljs_file_to_analyze/macro_ns.clj new file mode 100644 index 000000000..e7166bfb8 --- /dev/null +++ b/test/hyperfiddle/electric/impl/cljs_file_to_analyze/macro_ns.clj @@ -0,0 +1,5 @@ +(ns hyperfiddle.electric.impl.cljs-file-to-analyze.macro-ns) + +(defmacro reqmacrodef [v] `(def ~v)) +(defmacro reqmacrefer [v] `(def ~v)) +(defmacro reqmacrename [v] `(def ~v)) diff --git a/test/hyperfiddle/electric/impl/cljs_file_to_analyze/refer_macros.cljc b/test/hyperfiddle/electric/impl/cljs_file_to_analyze/refer_macros.cljc new file mode 100644 index 000000000..fefa7fa9b --- /dev/null +++ b/test/hyperfiddle/electric/impl/cljs_file_to_analyze/refer_macros.cljc @@ -0,0 +1,3 @@ +(ns hyperfiddle.electric.impl.cljs-file-to-analyze.refer-macros) + +(defmacro refmac [v] `(def ~v)) diff --git a/test/hyperfiddle/electric/impl/cljs_file_to_analyze/require.cljc b/test/hyperfiddle/electric/impl/cljs_file_to_analyze/require.cljc new file mode 100644 index 000000000..3a3392851 --- /dev/null +++ b/test/hyperfiddle/electric/impl/cljs_file_to_analyze/require.cljc @@ -0,0 +1,6 @@ +(ns hyperfiddle.electric.impl.cljs-file-to-analyze.require + #?(:cljs (:require-macros hyperfiddle.electric.impl.cljs-file-to-analyze.require))) + +(defmacro macrodef [sym] `(def ~sym)) +(defmacro refdef [sym] `(def ~sym)) +(defmacro renameme [sym] `(def ~sym)) From 1d157300dd78e3a1c7f75202566c1cd8fc2e4cd5 Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 15 Feb 2024 22:03:56 +0100 Subject: [PATCH 103/428] cljs analyzer: all ns references --- .../electric/impl/cljs_analyzer.clj | 59 ++++++++++++------- .../electric/impl/cljs_analyzer_test.clj | 6 ++ .../electric/impl/cljs_file_to_analyze.cljs | 10 +++- .../impl/cljs_file_to_analyze/use.clj | 4 ++ .../impl/cljs_file_to_analyze/use_macros.cljc | 4 ++ 5 files changed, 60 insertions(+), 23 deletions(-) create mode 100644 test/hyperfiddle/electric/impl/cljs_file_to_analyze/use.clj create mode 100644 test/hyperfiddle/electric/impl/cljs_file_to_analyze/use_macros.cljc diff --git a/src/hyperfiddle/electric/impl/cljs_analyzer.clj b/src/hyperfiddle/electric/impl/cljs_analyzer.clj index ddcf2bcd5..f8fd9bcd2 100644 --- a/src/hyperfiddle/electric/impl/cljs_analyzer.clj +++ b/src/hyperfiddle/electric/impl/cljs_analyzer.clj @@ -135,13 +135,22 @@ (defn add-require-macros [a ns$ rs] (-add-requires a ns$ rs ::require-macros ::refer-macros)) (defn add-requires [a ns$ rs] (-add-requires a ns$ rs ::requires ::refers)) +(defn reverse-map [m] (persistent! (reduce-kv (fn [m k v] (assoc! m v k)) (transient {}) m))) +(defn add-refer-clojure [a ns$ ov] + (let [o (apply hash-map ov)] + (cond-> a + (:exclude o) (assoc-in [::nses ns$ ::excludes] (set (:exclude o))) + (:rename o) (assoc-in [::nses ns$ ::renames] (reverse-map (:rename o)))))) +(defn use->require [args] + (let [o (apply hash-map (next args))] + (into [(first args)] cat (cond-> (select-keys o [:rename]) (:only o) (assoc :refer (:only o)))))) (comment - (ns foo - "docstring?" ; TODO - '{attr map?} ; TODO - (:refer-clojure :exclude [str]) ; TODO - (:refer-clojure :rename {str sstr}) ; TODO + (a-ns foo + "docstring?" ; DONE + '{attr map?} ; DONE + (:refer-clojure :exclude [str]) ; DONE + (:refer-clojure :rename {str sstr}) ; DONE (:require x ; DONE [x] ; DONE [x :as xy] ; DONE @@ -154,24 +163,28 @@ [x :as xy] ; DONE [x :refer [y]] ; DONE [x :refer [y] :rename {y yy}]) ; DONE - (:use x ; TODO - [x] ; TODO - [x :only [y]] ; TODO - [x :exclude [z]] ; TODO - [x :rename {y z}]) ; TODO - (:use-macros x ; TODO - [x] ; TODO - [x :only [y]] ; TODO - [x :exclude [z]] ; TODO - [x :rename {y z}]) ; TODO + (:use x ; + [x] ; + [x :only [y]] ; DONE + [x :only [y] :rename {y z}]) ; DONE + (:use-macros x ; + [x] ; + [x :only [y]] ; DONE + [x :only [y] :rename {y z}]) ; DONE ) ) +(defn skip-docstring [args] (cond-> args (string? (first args)) next)) +(defn skip-attr-map [args] (cond-> args (map? (first args)) next)) (defn add-ns-info [a [_ns ns$ & args]] - (reduce (fn [a [typ & args]] - (case typ - (:require) (add-requires a ns$ args) - (:require-macros) (add-require-macros a ns$ args) - #_else a)) a args )) + (let [args (-> args skip-docstring skip-attr-map)] + (reduce (fn [a [typ & args]] + (case typ + (:require) (add-requires a ns$ args) + (:require-macros) (add-require-macros a ns$ args) + (:use) (add-requires a ns$ (mapv use->require args)) + (:use-macros) (add-require-macros a ns$ (mapv use->require args)) + (:refer-clojure) (add-refer-clojure a ns$ args) + #_else a)) a args ))) (defn collect-defs [a o] (if (and (seq? o) (seq o)) @@ -197,8 +210,10 @@ ([a ns$] (->> (ns-forms> ns$) (m/reduce collect-defs (assoc a ::current-ns ns$)) m/?))) (defn find-var [sym a] - (or (-> a ::nses (get (::current-ns a)) ::defs (get sym)) - (-> a ::nses (get 'cljs.core) ::defs (get sym)))) + (let [nsa (-> a ::nses (get (::current-ns a))), cljs-defs (-> a ::nses (get 'cljs.core) ::defs)] + (or (-> nsa ::defs (get sym)) + (when-not (get (-> nsa ::excludes) sym) (get cljs-defs sym)) + (when-some [renamed (get (-> nsa ::renames) sym)] (get cljs-defs renamed))))) diff --git a/test/hyperfiddle/electric/impl/cljs_analyzer_test.clj b/test/hyperfiddle/electric/impl/cljs_analyzer_test.clj index 6d550a073..44dc926ef 100644 --- a/test/hyperfiddle/electric/impl/cljs_analyzer_test.clj +++ b/test/hyperfiddle/electric/impl/cljs_analyzer_test.clj @@ -5,6 +5,7 @@ (t/deftest all (let [a (ana/analyze-ns 'hyperfiddle.electric.impl.cljs-file-to-analyze)] (t/is (nil? (ana/find-var 'non a))) + (t/is (nil? (ana/find-var 'first a))) (t/are [x] (some? (ana/find-var x a)) 'foo 'bar @@ -21,5 +22,10 @@ 'behind-require-macro-rename 'behind-include-macros 'behind-refer-macros + 'behind-use + 'behind-use-renamed + 'behind-use-macro + 'behind-use-macro-renamed + 'nxt ;; 'refnonmacro ; TODO ))) diff --git a/test/hyperfiddle/electric/impl/cljs_file_to_analyze.cljs b/test/hyperfiddle/electric/impl/cljs_file_to_analyze.cljs index be10662a8..eb6874319 100644 --- a/test/hyperfiddle/electric/impl/cljs_file_to_analyze.cljs +++ b/test/hyperfiddle/electric/impl/cljs_file_to_analyze.cljs @@ -1,9 +1,13 @@ (ns hyperfiddle.electric.impl.cljs-file-to-analyze + "docstring" {:attr :map} (:require [hyperfiddle.electric.impl.cljs-file-to-analyze.require :as req :refer [refdef renameme] :rename {renameme renamed}] [hyperfiddle.electric.impl.cljs-file-to-analyze.include :as inc :include-macros true] [hyperfiddle.electric.impl.cljs-file-to-analyze.refer-macros :refer-macros [refmac]]) - (:require-macros [hyperfiddle.electric.impl.cljs-file-to-analyze.macro-ns :as reqmac :refer [reqmacrefer reqmacrename] :rename {reqmacrename reqmacrenamed}])) + (:require-macros [hyperfiddle.electric.impl.cljs-file-to-analyze.macro-ns :as reqmac :refer [reqmacrefer reqmacrename] :rename {reqmacrename reqmacrenamed}]) + (:use [hyperfiddle.electric.impl.cljs-file-to-analyze.use :only [useme renameme] :rename {renameme use-renamed}]) + (:use-macros [hyperfiddle.electric.impl.cljs-file-to-analyze.use-macros :only [useme-mac renameme-mac] :rename {renameme-mac use-renamed-mac}]) + (:refer-clojure :exclude [first] :rename {next nxt})) (def foo 1) @@ -21,3 +25,7 @@ (reqmacrenamed behind-require-macro-rename) (inc/include behind-include-macros) (refmac behind-refer-macros) +(useme behind-use) +(use-renamed behind-use-renamed) +(useme-mac behind-use-macro) +(use-renamed-mac behind-use-macro-renamed) diff --git a/test/hyperfiddle/electric/impl/cljs_file_to_analyze/use.clj b/test/hyperfiddle/electric/impl/cljs_file_to_analyze/use.clj new file mode 100644 index 000000000..73e3cc588 --- /dev/null +++ b/test/hyperfiddle/electric/impl/cljs_file_to_analyze/use.clj @@ -0,0 +1,4 @@ +(ns hyperfiddle.electric.impl.cljs-file-to-analyze.use) + +(defmacro useme [x] `(def ~x)) +(defmacro renameme [x] `(def ~x)) diff --git a/test/hyperfiddle/electric/impl/cljs_file_to_analyze/use_macros.cljc b/test/hyperfiddle/electric/impl/cljs_file_to_analyze/use_macros.cljc new file mode 100644 index 000000000..cd81c676d --- /dev/null +++ b/test/hyperfiddle/electric/impl/cljs_file_to_analyze/use_macros.cljc @@ -0,0 +1,4 @@ +(ns hyperfiddle.electric.impl.cljs-file-to-analyze.use-macros) + +(defmacro useme-mac [x] `(def ~x)) +(defmacro renameme-mac [x] `(def ~x)) From bd66d0a034f88310ee845925cac474340d8d6b02 Mon Sep 17 00:00:00 2001 From: xificurC Date: Fri, 16 Feb 2024 17:35:13 +0100 Subject: [PATCH 104/428] cljs analyzer: checkpoint --- .../electric/impl/cljs_analyzer.clj | 194 +++++++++++------- test/cljs/analyzer_testing_auto_alias.cljc | 3 + .../electric/impl/cljs_analyzer_test.clj | 41 +++- .../electric/impl/cljs_file_to_analyze.cljs | 7 +- .../impl/cljs_file_to_analyze/runtime.clj | 4 + .../impl/cljs_file_to_analyze/runtime.cljs | 5 + 6 files changed, 170 insertions(+), 84 deletions(-) create mode 100644 test/cljs/analyzer_testing_auto_alias.cljc create mode 100644 test/hyperfiddle/electric/impl/cljs_file_to_analyze/runtime.clj create mode 100644 test/hyperfiddle/electric/impl/cljs_file_to_analyze/runtime.cljs diff --git a/src/hyperfiddle/electric/impl/cljs_analyzer.clj b/src/hyperfiddle/electric/impl/cljs_analyzer.clj index f8fd9bcd2..9e9fc482e 100644 --- a/src/hyperfiddle/electric/impl/cljs_analyzer.clj +++ b/src/hyperfiddle/electric/impl/cljs_analyzer.clj @@ -2,6 +2,7 @@ (:refer-clojure :exclude [find-var]) (:require [edamame.core :as ed] [clojure.core :as cc] + [clojure.string :as str] [clojure.tools.reader.reader-types :as rt] [clojure.java.io :as io] [cljs.tagged-literals] @@ -35,21 +36,20 @@ :end-location false :readers cljs.tagged-literals/*cljs-data-readers* :auto-resolve name + :features #{:cljs} + :read-cond :allow :eof ::done})] - (defn ns-forms> [ns$] + (defn resource-forms> [rs] (->> (m/ap (let [rdr (m/?> (m/observe (fn [!] - (let [rdr (rt/source-logging-push-back-reader (io/reader (ns->resource ns$)))] + (let [rdr (rt/source-logging-push-back-reader (io/reader rs))] (! rdr) #(.close ^java.io.Reader rdr)))))] (m/? (m/?> (m/seed (repeat (m/via m/blk (ed/parse-next rdr parse-opts)))))))) (m/eduction (take-while (complement #{::done})))))) -(comment - (m/? (m/reduce conj (ns-forms> 'hyperfiddle.electric.impl.cljs-file-to-analyze))) - ) - (declare analyze-ns) -(defn ->a [ns$] (assoc (analyze-ns {} 'cljs.core) ::current-ns ns$)) +(defn -->a [] (analyze-ns {} 'cljs.core)) +(def ->a (memoize -->a)) (defn safe-require [sym] ;; we might be expanding clj code before the ns got loaded (during cljs compilation) @@ -62,7 +62,7 @@ (defn find-ns-var [^clojure.lang.Namespace nso sym] (.findInternedVar nso sym)) (declare find-var) -(defn runtime-var? [f a] (or (find-var f a) (find-var f (assoc a ::current-ns 'cljs.core)))) +(defn runtime-var? [a f ns$] (or (find-var a f ns$) (find-var a f 'cljs.core))) (defn mksym [& xs] (symbol (apply str (mapv #((if (or (keyword? %) (symbol? %)) name str) %) xs)))) @@ -87,34 +87,34 @@ (def special? '#{if def fn* do let* loop* letfn* throw try catch finally recur new set! ns deftype* defrecord* . js* & quote case* var ns*}) -(defn qualified->parts [qs a] - (let [ns$ (-> qs namespace symbol)] - [(or (-> a ::nses (get (::current-ns a)) ::requires (get ns$)) - (-> a ::nses (get (::current-ns a)) ::require-macros (get ns$)) - ns$) (-> qs name symbol)])) +(defn qualified->parts [a ns$ qs] + (let [qs-ns$ (-> qs namespace symbol)] + [(or (-> a ::nses (get ns$) ::requires (get qs-ns$)) + (-> a ::nses (get ns$) ::require-macros (get qs-ns$)) + qs-ns$) (-> qs name symbol)])) -(defn simple->parts [s a] - (let [s (or (-> a ::nses (get (::current-ns a)) ::refers (get s)) - (-> a ::nses (get (::current-ns a)) ::refer-macros (get s)) - (mksym (::current-ns a) '/ s))] - [(-> s namespace symbol) (-> s name symbol)])) +(defn simple->parts [a ns$ s$] + (let [s$ (or (-> a ::nses (get ns$) ::refers (get s$)) + (-> a ::nses (get ns$) ::refer-macros (get s$)) + (mksym ns$ '/ s$))] + [(-> s$ namespace symbol) (-> s$ name symbol)])) -(defn expand [[f :as o] a] - ;; TODO locals, refers +(defn expand [a ns$ [f :as o]] + ;; TODO locals (if (symbol? f) (cond (special? f) o - (qualified-symbol? f) (let [[ns$ name$] (qualified->parts f a)] - (?expand ns$ name$ o)) - (runtime-var? f a) o - :else (let [[ns$ name$] (simple->parts f a) - o2 (?expand ns$ name$ o)] + (qualified-symbol? f) (let [[f-ns$ name$] (qualified->parts a ns$ f)] + (?expand f-ns$ name$ o)) + (runtime-var? a f ns$) o + :else (let [[f-ns$ name$] (simple->parts a ns$ f) + o2 (?expand f-ns$ name$ o)] (if (identical? o o2) (?expand 'cljs.core f o) o2))) o)) -(defn ->def-info [[_def sym _v :as o]] {::name sym, ::meta (merge (meta sym) (meta o))}) +(defn ->def-info [ns$ [_def sym _v :as o]] {::name (symbol (str ns$) (str sym)), ::meta (merge (meta sym) (meta o))}) (defn add-require [a ns$ reqk from$ to$] (assoc-in a [::nses ns$ reqk from$] to$)) @@ -122,25 +122,40 @@ (reduce (fn [a nx] (assoc-in a [::nses ns$ refk (or (get (:rename o) nx) nx)] (mksym req$ '/ nx))) a (:refer o))) +(declare -add-require) + +(defn ?auto-alias-clojure [a ns$ reqk refk req$] + (if (ns->resource req$) + [a nil] + (let [cljs (str/replace-first (str req$) #"^clojure\." "cljs."), cljs$ (symbol cljs)] + (if (= req$ cljs$) + [a nil] + (if (ns->resource cljs$) + [(-add-require a ns$ reqk refk [cljs$ :as req$]) cljs$] + [a nil]))))) + (defn -add-require [a ns$ reqk refk r] - (if (or (symbol? r) (string? r)) - (add-require a ns$ reqk r r) - (let [[req$ & o] r, a (add-require a ns$ reqk req$ req$), o (apply hash-map o)] - (cond-> a - (:as o) (add-require ns$ reqk (:as o) req$) - (:refer o) (add-refers ns$ refk o req$) - (:refer-macros o) (recur ns$ reqk refk (into [req$] cat (-> (select-keys o [:as]) (assoc :refer (:refer-macros o))))))))) + (let [r (if (or (symbol? r) (string? r)) [r] r) + [req$ & o] r, o (apply hash-map o) + [a rewrite$] (?auto-alias-clojure a ns$ reqk refk req$) + req$ (or rewrite$ req$) + a (add-require a ns$ reqk req$ req$)] + (cond-> (analyze-ns a req$) + (:as o) (add-require ns$ reqk (:as o) req$) + (:refer o) (add-refers ns$ refk o req$) + (:refer-macros o) (recur ns$ reqk refk (into [req$] cat (-> (select-keys o [:as]) (assoc :refer (:refer-macros o)))))))) (defn -add-requires [a ns$ rs reqk refk] (reduce #(-add-require % ns$ reqk refk %2) a rs)) (defn add-require-macros [a ns$ rs] (-add-requires a ns$ rs ::require-macros ::refer-macros)) (defn add-requires [a ns$ rs] (-add-requires a ns$ rs ::requires ::refers)) -(defn reverse-map [m] (persistent! (reduce-kv (fn [m k v] (assoc! m v k)) (transient {}) m))) (defn add-refer-clojure [a ns$ ov] (let [o (apply hash-map ov)] (cond-> a (:exclude o) (assoc-in [::nses ns$ ::excludes] (set (:exclude o))) - (:rename o) (assoc-in [::nses ns$ ::renames] (reverse-map (:rename o)))))) + (:rename o) (-> (update-in [::nses ns$ ::refers] merge + (reduce-kv (fn [m k v] (assoc m v (symbol "cljs.core" (name k)))) {} (:rename o))) + (update-in [::nses ns$ ::excludes] into (keys (:rename o))))))) (defn use->require [args] (let [o (apply hash-map (next args))] (into [(first args)] cat (cond-> (select-keys o [:rename]) (:only o) (assoc :refer (:only o)))))) @@ -186,35 +201,64 @@ (:refer-clojure) (add-refer-clojure a ns$ args) #_else a)) a args ))) -(defn collect-defs [a o] - (if (and (seq? o) (seq o)) - (case (first o) - (def) (assoc-in a [::nses (::current-ns a) ::defs (second o)] (->def-info o)) - (ns) (add-ns-info a o) - ;; (fn* foo [x] x) (fn* foo ([x] x) ([x y] x)) (fn* [x] x) (fn* ([x] x) ([x y] x)) - (fn*) (let [body (if (symbol? (second o)) (nnext o) (next o)) - arities (if (vector? (first body)) (list body) body)] - (transduce (map #(expand (next %) a)) (completing collect-defs) a arities)) - #_else (let [o2 (expand o a)] - (if (identical? o o2) - (reduce collect-defs a (expand o a)) - (collect-defs a o2)))) - a)) +(defn collect-defs [a ns$ o] + ((fn rec [a o] + (if (and (seq? o) (seq o)) + (case (first o) + (def) (assoc-in a [::nses ns$ ::defs (second o)] (->def-info ns$ o)) + (ns) (add-ns-info a o) + ;; (fn* foo [x] x) (fn* foo ([x] x) ([x y] x)) (fn* [x] x) (fn* ([x] x) ([x y] x)) + (fn*) (let [body (if (symbol? (second o)) (nnext o) (next o)) + arities (if (vector? (first body)) (list body) body)] + (transduce (map #(expand a ns$ (next %))) (completing rec) a arities)) + #_else (let [o2 (expand a ns$ o)] + (if (identical? o o2) + (reduce rec a (expand a ns$ o)) + (rec a o2)))) + a)) a o)) ;;;;;;;;;;;;;;;;;; ;;; PUBLIC API ;;; ;;;;;;;;;;;;;;;;;; (defn analyze-ns - ([ns$] (analyze-ns (->a ns$) ns$)) - ([a ns$] (->> (ns-forms> ns$) (m/reduce collect-defs (assoc a ::current-ns ns$)) m/?))) - -(defn find-var [sym a] - (let [nsa (-> a ::nses (get (::current-ns a))), cljs-defs (-> a ::nses (get 'cljs.core) ::defs)] - (or (-> nsa ::defs (get sym)) - (when-not (get (-> nsa ::excludes) sym) (get cljs-defs sym)) - (when-some [renamed (get (-> nsa ::renames) sym)] (get cljs-defs renamed))))) - + ([ns$] (analyze-ns (->a) ns$)) + ([a ns$] (if (contains? (::nses a) ns$) + a + (if-some [rs (ns->resource ns$)] + (let [a (assoc-in a [::nses ns$] {})] + (->> (resource-forms> rs) (m/reduce #(collect-defs % ns$ %2) a) m/?)) + a)))) + +(defn find-var [a sym ns$] + (let [nsa (-> a ::nses (get ns$))] + (if (simple-symbol? sym) + (or (-> nsa ::defs (get sym)) + (when-not (get (::excludes nsa) sym) + (-> a ::nses (get 'cljs.core) ::defs (get sym))) + (when-some [renamed (get (::refers nsa) sym)] + (-> a ::nses (get (symbol (namespace renamed))) ::defs (get (symbol (name renamed)))))) + (when-some [sym-ns$ (-> nsa ::requires (get (symbol (namespace sym))))] + (find-var a (symbol (name sym)) sym-ns$))))) + +(defn keep-if [v pred] (when (pred v) v)) +(defn macro-var? [vr] (and (instance? clojure.lang.Var vr) (.isMacro ^clojure.lang.Var vr))) + +;; TODO try to use this in expand +;; TODO clojure.core -> cljs.core, clojure.repl -> cljs.repl +(defn find-macro-var [a sym ns$] + (when-not (find-var a sym ns$) + (-> (if (simple-symbol? sym) + (or (do (safe-require ns$) (some-> (find-ns ns$) (find-ns-var sym))) + (when-some [ref (-> a ::nses (get ns$) ::refers (get sym))] (resolve ref)) + (when-some [ref (-> a ::nses (get ns$) ::refer-macros (get sym))] (resolve ref)) + (when-not (get (-> a ::nses (get ns$) ::excludes) sym) (find-ns-var (find-ns 'clojure.core) sym))) + (let [sym-ns$ (-> sym namespace symbol), sym-base$ (-> sym name symbol)] + (or (when-some [sym-ns$ (-> a ::nses (get ns$) ::requires (get sym-ns$))] + (some-> (find-ns sym-ns$) (find-ns-var sym-base$))) + (when-some [sym-ns$ (-> a ::nses (get ns$) ::require-macros (get sym-ns$))] + (some-> (find-ns sym-ns$) (find-ns-var sym-base$)))))) + (keep-if macro-var?)))) @@ -232,22 +276,22 @@ o))) #_(defn ?expand [ns$ name$ o] - (safe-require ns$) - (let [vr (some-> (find-ns ns$) (find-ns-var name$))] - (if (and vr (.isMacro ^clojure.lang.Var vr)) - (apply vr o {} (next o)) - o))) + (safe-require ns$) + (let [vr (some-> (find-ns ns$) (find-ns-var name$))] + (if (and vr (.isMacro ^clojure.lang.Var vr)) + (apply vr o {} (next o)) + o))) #_(defn expand [[f :as o] a] - ;; TODO locals, refers - (cond - (qualified-symbol? f) (if (and (= 'cljs.core (::current-ns a)) (= "cljs.core" (namespace f))) - o - (let [sym (unalias f a), ns$ (-> sym namespace symbol), name$ (-> sym name symbol)] - (?expand ns$ name$ o))) - (runtime-var? f a) o - (= 'cljs.core (::current-ns a)) o - :else (let [o2 (?expand (::current-ns a) f o)] - (if (identical? o o2) - (?expand 'cljs.core f o) - o)))) + ;; TODO locals, refers + (cond + (qualified-symbol? f) (if (and (= 'cljs.core (::current-ns a)) (= "cljs.core" (namespace f))) + o + (let [sym (unalias f a), ns$ (-> sym namespace symbol), name$ (-> sym name symbol)] + (?expand ns$ name$ o))) + (runtime-var? f a) o + (= 'cljs.core (::current-ns a)) o + :else (let [o2 (?expand (::current-ns a) f o)] + (if (identical? o o2) + (?expand 'cljs.core f o) + o)))) diff --git a/test/cljs/analyzer_testing_auto_alias.cljc b/test/cljs/analyzer_testing_auto_alias.cljc new file mode 100644 index 000000000..442ba7210 --- /dev/null +++ b/test/cljs/analyzer_testing_auto_alias.cljc @@ -0,0 +1,3 @@ +(ns cljs.analyzer-testing-auto-alias) + +(defmacro auto-aliased [x] `(def ~x)) diff --git a/test/hyperfiddle/electric/impl/cljs_analyzer_test.clj b/test/hyperfiddle/electric/impl/cljs_analyzer_test.clj index 44dc926ef..2cab5ac67 100644 --- a/test/hyperfiddle/electric/impl/cljs_analyzer_test.clj +++ b/test/hyperfiddle/electric/impl/cljs_analyzer_test.clj @@ -2,11 +2,19 @@ (:require [clojure.test :as t] [hyperfiddle.electric.impl.cljs-analyzer :as ana])) -(t/deftest all - (let [a (ana/analyze-ns 'hyperfiddle.electric.impl.cljs-file-to-analyze)] - (t/is (nil? (ana/find-var 'non a))) - (t/is (nil? (ana/find-var 'first a))) - (t/are [x] (some? (ana/find-var x a)) +(comment + (def a (ana/analyze-ns 'hyperfiddle.electric.impl.cljs-file-to-analyze)) + (-> a ::ana/nses (get 'hyperfiddle.electric.impl.cljs-file-to-analyze) ::ana/refers) + (ana/find-var a 'next 'hyperfiddle.electric.impl.cljs-file-to-analyze) + ) + +(t/deftest ns-expansion + (let [ns$ 'hyperfiddle.electric.impl.cljs-file-to-analyze + a (ana/analyze-ns ns$)] + (t/is (nil? (ana/find-var a 'non ns$))) + (t/is (nil? (ana/find-var a 'first ns$))) + (t/is (= 'cljs.core/next (::ana/name (ana/find-var a 'nxt ns$)))) + (t/are [x] (some? (ana/find-var a x ns$)) 'foo 'bar 'baz @@ -26,6 +34,23 @@ 'behind-use-renamed 'behind-use-macro 'behind-use-macro-renamed - 'nxt - ;; 'refnonmacro ; TODO - ))) + 'behind-auto-alias + 'behind-auto-alias-alias + 'behind-auto-alias-refer + 'nxt))) + +(t/deftest runtime-vars + (let [ns$ 'hyperfiddle.electric.impl.cljs-file-to-analyze, + a (ana/analyze-ns ns$)] + (t/are [x] (nil? (ana/find-var a x ns$)) + 'hyperfiddle.electric.impl.cljs-file-to-analyze.runtime/only-macro + 'run/only-macro + 'only-macro + 'next) ; renamed in :refer-clojure + (t/are [x] (some? (ana/find-var a x ns$)) + 'hyperfiddle.electric.impl.cljs-file-to-analyze.runtime/macro-and-runtime + 'run/macro-and-runtime + 'macro-and-runtime + 'hyperfiddle.electric.impl.cljs-file-to-analyze.runtime/only-runtime + 'run/only-runtime + 'only-runtime))) diff --git a/test/hyperfiddle/electric/impl/cljs_file_to_analyze.cljs b/test/hyperfiddle/electric/impl/cljs_file_to_analyze.cljs index eb6874319..74b96e360 100644 --- a/test/hyperfiddle/electric/impl/cljs_file_to_analyze.cljs +++ b/test/hyperfiddle/electric/impl/cljs_file_to_analyze.cljs @@ -3,7 +3,9 @@ (:require [hyperfiddle.electric.impl.cljs-file-to-analyze.require :as req :refer [refdef renameme] :rename {renameme renamed}] [hyperfiddle.electric.impl.cljs-file-to-analyze.include :as inc :include-macros true] - [hyperfiddle.electric.impl.cljs-file-to-analyze.refer-macros :refer-macros [refmac]]) + [hyperfiddle.electric.impl.cljs-file-to-analyze.refer-macros :refer-macros [refmac]] + [hyperfiddle.electric.impl.cljs-file-to-analyze.runtime :as run :refer [only-macro only-runtime macro-and-runtime]] + [clojure.analyzer-testing-auto-alias :as auto-alias :refer [auto-aliased]]) (:require-macros [hyperfiddle.electric.impl.cljs-file-to-analyze.macro-ns :as reqmac :refer [reqmacrefer reqmacrename] :rename {reqmacrename reqmacrenamed}]) (:use [hyperfiddle.electric.impl.cljs-file-to-analyze.use :only [useme renameme] :rename {renameme use-renamed}]) (:use-macros [hyperfiddle.electric.impl.cljs-file-to-analyze.use-macros :only [useme-mac renameme-mac] :rename {renameme-mac use-renamed-mac}]) @@ -29,3 +31,6 @@ (use-renamed behind-use-renamed) (useme-mac behind-use-macro) (use-renamed-mac behind-use-macro-renamed) +(clojure.analyzer-testing-auto-alias/auto-aliased behind-auto-alias) +(auto-alias/auto-aliased behind-auto-alias-alias) +(auto-aliased behind-auto-alias-refer) diff --git a/test/hyperfiddle/electric/impl/cljs_file_to_analyze/runtime.clj b/test/hyperfiddle/electric/impl/cljs_file_to_analyze/runtime.clj new file mode 100644 index 000000000..4b9e53e52 --- /dev/null +++ b/test/hyperfiddle/electric/impl/cljs_file_to_analyze/runtime.clj @@ -0,0 +1,4 @@ +(ns hyperfiddle.electric.impl.cljs-file-to-analyze.runtime) + +(defmacro only-macro []) +(defmacro macro-and-runtime []) diff --git a/test/hyperfiddle/electric/impl/cljs_file_to_analyze/runtime.cljs b/test/hyperfiddle/electric/impl/cljs_file_to_analyze/runtime.cljs new file mode 100644 index 000000000..bdfecc04a --- /dev/null +++ b/test/hyperfiddle/electric/impl/cljs_file_to_analyze/runtime.cljs @@ -0,0 +1,5 @@ +(ns hyperfiddle.electric.impl.cljs-file-to-analyze.runtime + (:require-macros hyperfiddle.electric.impl.cljs-file-to-analyze.runtime)) + +(defn macro-and-runtime []) +(defn only-runtime []) From a5c91bb0d785f0d3a2120443388f7d354c963484 Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 19 Feb 2024 10:54:20 +0100 Subject: [PATCH 105/428] cljs analyzer: refactor, cleanup --- .../electric/impl/cljs_analyzer.clj | 110 ++++-------------- 1 file changed, 25 insertions(+), 85 deletions(-) diff --git a/src/hyperfiddle/electric/impl/cljs_analyzer.clj b/src/hyperfiddle/electric/impl/cljs_analyzer.clj index 9e9fc482e..16f3d6879 100644 --- a/src/hyperfiddle/electric/impl/cljs_analyzer.clj +++ b/src/hyperfiddle/electric/impl/cljs_analyzer.clj @@ -60,59 +60,35 @@ (catch java.io.FileNotFoundException _)))) (defn find-ns-var [^clojure.lang.Namespace nso sym] (.findInternedVar nso sym)) -(declare find-var) - -(defn runtime-var? [a f ns$] (or (find-var a f ns$) (find-var a f 'cljs.core))) +(declare find-var find-macro-var) (defn mksym [& xs] (symbol (apply str (mapv #((if (or (keyword? %) (symbol? %)) name str) %) xs)))) (defmacro my-deftype [nm & _] `(do (def ~nm) (def ~(mksym '-> nm)))) -(let [blacklisted (into #{} (map cc/find-var) '[cljs.core/exists? cljs.core/str cljs.core/aget cljs.core/* cljs.core/+ cljs.core// cljs.core/let cljs.core/nil? cljs.core/aset clojure.core/gen-interface cljs.core/extend-type]) + +(def special? '#{if def fn* do let* loop* letfn* throw try catch finally + recur new set! ns deftype* defrecord* . js* & quote case* var ns*}) + +(let [blacklisted (into #{} (map cc/find-var) + '[cljs.core/exists? cljs.core/str cljs.core/aget cljs.core/* cljs.core/+ cljs.core// + cljs.core/let cljs.core/nil? cljs.core/aset clojure.core/gen-interface cljs.core/extend-type + cljs.core/implements? cljs.core/satisfies?]) from-clj {#'cljs.core/defn #'clojure.core/defn #'cljs.core/defn- #'clojure.core/defn- #'cljs.core/declare #'clojure.core/declare #'cljs.core/defprotocol #'clojure.core/defprotocol #'cljs.core/deftype #'my-deftype}] - (defn ?expand [ns$ name$ o] - (safe-require ns$) - (let [vr (some-> (find-ns ns$) (find-ns-var name$))] - (if (and vr (.isMacro ^clojure.lang.Var vr)) - (if-some [clj (from-clj vr)] - (apply clj o {} (next o)) - (if (blacklisted vr) + (defn expand [a ns$ [f & args :as o]] + ;; TODO locals + (if (symbol? f) + (if (special? f) + o + (if-some [mac (find-macro-var a f ns$)] + (if (blacklisted mac) o - (apply vr o {} (next o)))) - o)))) - -(def special? '#{if def fn* do let* loop* letfn* throw try catch finally - recur new set! ns deftype* defrecord* . js* & quote case* var ns*}) - -(defn qualified->parts [a ns$ qs] - (let [qs-ns$ (-> qs namespace symbol)] - [(or (-> a ::nses (get ns$) ::requires (get qs-ns$)) - (-> a ::nses (get ns$) ::require-macros (get qs-ns$)) - qs-ns$) (-> qs name symbol)])) - -(defn simple->parts [a ns$ s$] - (let [s$ (or (-> a ::nses (get ns$) ::refers (get s$)) - (-> a ::nses (get ns$) ::refer-macros (get s$)) - (mksym ns$ '/ s$))] - [(-> s$ namespace symbol) (-> s$ name symbol)])) - -(defn expand [a ns$ [f :as o]] - ;; TODO locals - (if (symbol? f) - (cond - (special? f) o - (qualified-symbol? f) (let [[f-ns$ name$] (qualified->parts a ns$ f)] - (?expand f-ns$ name$ o)) - (runtime-var? a f ns$) o - :else (let [[f-ns$ name$] (simple->parts a ns$ f) - o2 (?expand f-ns$ name$ o)] - (if (identical? o o2) - (?expand 'cljs.core f o) - o2))) - o)) + (apply (or (from-clj mac) mac) o {} args)) + o)) + o))) (defn ->def-info [ns$ [_def sym _v :as o]] {::name (symbol (str ns$) (str sym)), ::meta (merge (meta sym) (meta o))}) @@ -217,6 +193,9 @@ (rec a o2)))) a)) a o)) +(defn keep-if [v pred] (when (pred v) v)) +(defn macro-var? [vr] (and (instance? clojure.lang.Var vr) (.isMacro ^clojure.lang.Var vr))) + ;;;;;;;;;;;;;;;;;; ;;; PUBLIC API ;;; ;;;;;;;;;;;;;;;;;; @@ -241,57 +220,18 @@ (when-some [sym-ns$ (-> nsa ::requires (get (symbol (namespace sym))))] (find-var a (symbol (name sym)) sym-ns$))))) -(defn keep-if [v pred] (when (pred v) v)) -(defn macro-var? [vr] (and (instance? clojure.lang.Var vr) (.isMacro ^clojure.lang.Var vr))) - -;; TODO try to use this in expand ;; TODO clojure.core -> cljs.core, clojure.repl -> cljs.repl (defn find-macro-var [a sym ns$] (when-not (find-var a sym ns$) (-> (if (simple-symbol? sym) (or (do (safe-require ns$) (some-> (find-ns ns$) (find-ns-var sym))) - (when-some [ref (-> a ::nses (get ns$) ::refers (get sym))] (resolve ref)) - (when-some [ref (-> a ::nses (get ns$) ::refer-macros (get sym))] (resolve ref)) + (when-some [ref (-> a ::nses (get ns$) ::refers (get sym))] (requiring-resolve ref)) + (when-some [ref (-> a ::nses (get ns$) ::refer-macros (get sym))] (requiring-resolve ref)) (when-not (get (-> a ::nses (get ns$) ::excludes) sym) (find-ns-var (find-ns 'clojure.core) sym))) (let [sym-ns$ (-> sym namespace symbol), sym-base$ (-> sym name symbol)] (or (when-some [sym-ns$ (-> a ::nses (get ns$) ::requires (get sym-ns$))] (some-> (find-ns sym-ns$) (find-ns-var sym-base$))) (when-some [sym-ns$ (-> a ::nses (get ns$) ::require-macros (get sym-ns$))] + (safe-require sym-ns$) (some-> (find-ns sym-ns$) (find-ns-var sym-base$)))))) (keep-if macro-var?)))) - - - - - - -;; probably trash - - -#_(defn ?expand [ns$ name$ o] - (safe-require ns$) - (let [vr (some-> (find-ns ns$) (find-ns-var name$))] - (if (and vr (.isMacro ^clojure.lang.Var vr)) - (apply vr o {} (next o)) - o))) - -#_(defn ?expand [ns$ name$ o] - (safe-require ns$) - (let [vr (some-> (find-ns ns$) (find-ns-var name$))] - (if (and vr (.isMacro ^clojure.lang.Var vr)) - (apply vr o {} (next o)) - o))) - -#_(defn expand [[f :as o] a] - ;; TODO locals, refers - (cond - (qualified-symbol? f) (if (and (= 'cljs.core (::current-ns a)) (= "cljs.core" (namespace f))) - o - (let [sym (unalias f a), ns$ (-> sym namespace symbol), name$ (-> sym name symbol)] - (?expand ns$ name$ o))) - (runtime-var? f a) o - (= 'cljs.core (::current-ns a)) o - :else (let [o2 (?expand (::current-ns a) f o)] - (if (identical? o o2) - (?expand 'cljs.core f o) - o)))) From 406a4a7820b36d743efd6756b33d19107e7c6cc3 Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 19 Feb 2024 21:06:58 +0100 Subject: [PATCH 106/428] cljs analyzer: initial impl done --- .../electric/impl/cljs_analyzer.clj | 44 ++++++++++++++----- .../electric/impl/cljs_analyzer_test.clj | 32 ++++++++++++++ .../electric/impl/cljs_file_to_analyze.cljs | 8 ++++ .../{use.clj => use.cljc} | 0 4 files changed, 72 insertions(+), 12 deletions(-) rename test/hyperfiddle/electric/impl/cljs_file_to_analyze/{use.clj => use.cljc} (100%) diff --git a/src/hyperfiddle/electric/impl/cljs_analyzer.clj b/src/hyperfiddle/electric/impl/cljs_analyzer.clj index 16f3d6879..83e269f77 100644 --- a/src/hyperfiddle/electric/impl/cljs_analyzer.clj +++ b/src/hyperfiddle/electric/impl/cljs_analyzer.clj @@ -78,10 +78,9 @@ #'cljs.core/declare #'clojure.core/declare #'cljs.core/defprotocol #'clojure.core/defprotocol #'cljs.core/deftype #'my-deftype}] - (defn expand [a ns$ [f & args :as o]] - ;; TODO locals + (defn expand [a ns$ ls [f & args :as o]] (if (symbol? f) - (if (special? f) + (if (or (special? f) (ls f)) o (if-some [mac (find-macro-var a f ns$)] (if (blacklisted mac) @@ -90,7 +89,7 @@ o)) o))) -(defn ->def-info [ns$ [_def sym _v :as o]] {::name (symbol (str ns$) (str sym)), ::meta (merge (meta sym) (meta o))}) +(defn ->def-info [ns$ sym] {::name (with-meta (symbol (str ns$) (str sym)) (meta sym)), ::meta (meta sym)}) (defn add-require [a ns$ reqk from$ to$] (assoc-in a [::nses ns$ reqk from$] to$)) @@ -177,21 +176,36 @@ (:refer-clojure) (add-refer-clojure a ns$ args) #_else a)) a args ))) +(defn add-def [a ns$ sym] (assoc-in a [::nses ns$ ::defs sym] (->def-info ns$ sym))) + (defn collect-defs [a ns$ o] - ((fn rec [a o] + ((fn rec [ls a o] (if (and (seq? o) (seq o)) (case (first o) - (def) (assoc-in a [::nses ns$ ::defs (second o)] (->def-info ns$ o)) + (defmacro clojure.core/defmacro cljs.core/defmacro) a + + (defprotocol clojure.core/defprotocl cljs.core/defprotocol) + (let [[_ nm & args] o, fns (cond-> args (string? (first args)) next)] + (reduce (fn [a sym] (add-def a ns$ sym)) a (cons nm (eduction (map first fns))))) + + (def) (add-def a ns$ (second o)) + (ns) (add-ns-info a o) ;; (fn* foo [x] x) (fn* foo ([x] x) ([x y] x)) (fn* [x] x) (fn* ([x] x) ([x y] x)) (fn*) (let [body (if (symbol? (second o)) (nnext o) (next o)) arities (if (vector? (first body)) (list body) body)] - (transduce (map #(expand a ns$ (next %))) (completing rec) a arities)) - #_else (let [o2 (expand a ns$ o)] + (reduce (fn [a [bs & body]] (rec (into ls bs) a (cons 'do body))) a arities)) + + (let*) (let [[_ bs & body] o + [a ls] (transduce (partition-all 2) (completing (fn [[a ls] [k v]] [(rec ls a v) (conj ls k)])) + [a ls] bs)] + (recur ls a (cons 'do body))) + + #_else (let [o2 (expand a ns$ ls o)] (if (identical? o o2) - (reduce rec a (expand a ns$ o)) - (rec a o2)))) - a)) a o)) + (reduce (partial rec ls) a (expand a ns$ ls o)) + (rec ls a o2)))) + a)) #{} a o)) (defn keep-if [v pred] (when (pred v) v)) (defn macro-var? [vr] (and (instance? clojure.lang.Var vr) (.isMacro ^clojure.lang.Var vr))) @@ -223,11 +237,17 @@ ;; TODO clojure.core -> cljs.core, clojure.repl -> cljs.repl (defn find-macro-var [a sym ns$] (when-not (find-var a sym ns$) - (-> (if (simple-symbol? sym) + (-> (cond + (simple-symbol? sym) (or (do (safe-require ns$) (some-> (find-ns ns$) (find-ns-var sym))) (when-some [ref (-> a ::nses (get ns$) ::refers (get sym))] (requiring-resolve ref)) (when-some [ref (-> a ::nses (get ns$) ::refer-macros (get sym))] (requiring-resolve ref)) (when-not (get (-> a ::nses (get ns$) ::excludes) sym) (find-ns-var (find-ns 'clojure.core) sym))) + + (#{"cljs.core" "clojure.core"} (namespace sym)) + (requiring-resolve sym) + + :else (let [sym-ns$ (-> sym namespace symbol), sym-base$ (-> sym name symbol)] (or (when-some [sym-ns$ (-> a ::nses (get ns$) ::requires (get sym-ns$))] (some-> (find-ns sym-ns$) (find-ns-var sym-base$))) diff --git a/test/hyperfiddle/electric/impl/cljs_analyzer_test.clj b/test/hyperfiddle/electric/impl/cljs_analyzer_test.clj index 2cab5ac67..545952b72 100644 --- a/test/hyperfiddle/electric/impl/cljs_analyzer_test.clj +++ b/test/hyperfiddle/electric/impl/cljs_analyzer_test.clj @@ -1,11 +1,18 @@ (ns hyperfiddle.electric.impl.cljs-analyzer-test (:require [clojure.test :as t] + [cljs.env] + [cljs.analyzer] [hyperfiddle.electric.impl.cljs-analyzer :as ana])) (comment (def a (ana/analyze-ns 'hyperfiddle.electric.impl.cljs-file-to-analyze)) (-> a ::ana/nses (get 'hyperfiddle.electric.impl.cljs-file-to-analyze) ::ana/refers) (ana/find-var a 'next 'hyperfiddle.electric.impl.cljs-file-to-analyze) + (ana/expand (ana/->a) 'cljs.core #{} '(defmacro macrodef [sym] `(def ~sym))) + (-> (ana/collect-defs (ana/->a) 'foo '(defmacro macrodef [sym] `(def ~sym))) + ::ana/nses (get 'foo)) + (-> (ana/collect-defs (ana/->a) 'foo '(fn [] (def x 1))) + ::ana/nses (get 'foo)) ) (t/deftest ns-expansion @@ -54,3 +61,28 @@ 'hyperfiddle.electric.impl.cljs-file-to-analyze.runtime/only-runtime 'run/only-runtime 'only-runtime))) + +(t/deftest local-shadowing + (let [ns$ 'hyperfiddle.electric.impl.cljs-file-to-analyze + a (ana/analyze-ns ns$)] + (t/are [x] (nil? (ana/find-var a x ns$)) + 'shadowed-by-let + 'shadowed-by-let-destructure + 'shadowed-by-fn + 'shadowed-by-fn-destructure + 'shadowed-by-letfn-fn-name + 'shadowed-by-letfn-other-fn-name + 'shadowed-by-letfn-local))) + +(t/deftest defs-match-official-cljs-analyzer + (let [ns$ 'cljs.analyzer + a (ana/analyze-ns ns$) + c (cljs.env/ensure + (cljs.analyzer/analyze-file "cljs/core.cljs") + (cljs.analyzer/analyze-file "cljs/analyzer.cljc") + @cljs.env/*compiler*)] + (t/are [ns$] (= (into #{} (keep (fn [[k v]] (when-not (:anonymous v) k))) + (-> c :cljs.analyzer/namespaces (get ns$) :defs)) + (set (-> a ::ana/nses (get ns$) ::ana/defs keys))) + 'cljs.core + 'cljs.analyzer))) diff --git a/test/hyperfiddle/electric/impl/cljs_file_to_analyze.cljs b/test/hyperfiddle/electric/impl/cljs_file_to_analyze.cljs index 74b96e360..98083da91 100644 --- a/test/hyperfiddle/electric/impl/cljs_file_to_analyze.cljs +++ b/test/hyperfiddle/electric/impl/cljs_file_to_analyze.cljs @@ -34,3 +34,11 @@ (clojure.analyzer-testing-auto-alias/auto-aliased behind-auto-alias) (auto-alias/auto-aliased behind-auto-alias-alias) (auto-aliased behind-auto-alias-refer) + +(let [useme inc] (useme shadowed-by-let)) +(let [{:keys [useme]} {:useme inc}] (useme shadowed-by-let-destructure)) +(fn [useme] (useme shadowed-by-fn)) +(fn [{:keys [useme]}] (useme shadowed-by-fn-destructure)) +(letfn [(useme [] (useme shadowed-by-letfn-fn-name)) + (foooo [] (useme shadowed-by-letfn-other-fn-name))]) +(letfn [(foo [useme] (useme shadowed-by-letfn-local))]) diff --git a/test/hyperfiddle/electric/impl/cljs_file_to_analyze/use.clj b/test/hyperfiddle/electric/impl/cljs_file_to_analyze/use.cljc similarity index 100% rename from test/hyperfiddle/electric/impl/cljs_file_to_analyze/use.clj rename to test/hyperfiddle/electric/impl/cljs_file_to_analyze/use.cljc From bc520af9a40fae31152401d7710fbed739a77630 Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 22 Feb 2024 13:30:53 +0100 Subject: [PATCH 107/428] compiler: initial cljs support --- deps.edn | 1 + .../electric/impl/cljs_analyzer.clj | 5 +- .../electric/impl/cljs_analyzer2.clj | 297 ++++++++ .../electric/impl/destructure.cljc | 107 +++ src/hyperfiddle/electric/impl/lang.clj | 7 +- src/hyperfiddle/electric/impl/lang_de2.clj | 665 +++++++++--------- src/hyperfiddle/electric/impl/runtime_de.cljc | 7 + src/hyperfiddle/electric_de.cljc | 27 +- src/hyperfiddle/electric_local_def_de.cljc | 48 +- .../electric/impl/cljs_analyzer2_test.clj | 107 +++ .../electric/impl/cljs_analyzer_test.clj | 156 ++-- .../electric/impl/compiler_test.cljc | 8 +- .../electric/impl/expand_de_test.cljc | 37 +- test/hyperfiddle/electric_de_test.cljc | 18 +- 14 files changed, 1021 insertions(+), 469 deletions(-) create mode 100644 src/hyperfiddle/electric/impl/cljs_analyzer2.clj create mode 100644 src/hyperfiddle/electric/impl/destructure.cljc create mode 100644 test/hyperfiddle/electric/impl/cljs_analyzer2_test.clj diff --git a/deps.edn b/deps.edn index 0459330f6..bb61e45c7 100644 --- a/deps.edn +++ b/deps.edn @@ -12,6 +12,7 @@ org.clojure/tools.analyzer.jvm {:mvn/version "1.2.2"} ;; used by Electric org.clojure/tools.logging {:mvn/version "1.2.4"} borkdude/edamame {:mvn/version "1.4.25"} + net.cgrand/xforms {:mvn/version "0.19.6"} } :aliases {:dev {:extra-paths ["src-dev" "src-docs" "test" "scratch" "resources-demo"] ; for clj command diff --git a/src/hyperfiddle/electric/impl/cljs_analyzer.clj b/src/hyperfiddle/electric/impl/cljs_analyzer.clj index 83e269f77..0aed7834e 100644 --- a/src/hyperfiddle/electric/impl/cljs_analyzer.clj +++ b/src/hyperfiddle/electric/impl/cljs_analyzer.clj @@ -44,7 +44,7 @@ (let [rdr (m/?> (m/observe (fn [!] (let [rdr (rt/source-logging-push-back-reader (io/reader rs))] (! rdr) #(.close ^java.io.Reader rdr)))))] - (m/? (m/?> (m/seed (repeat (m/via m/blk (ed/parse-next rdr parse-opts)))))))) + (m/? (m/?> (m/seed (repeat (m/sp (ed/parse-next rdr parse-opts)))))))) (m/eduction (take-while (complement #{::done})))))) (declare analyze-ns) @@ -203,7 +203,7 @@ #_else (let [o2 (expand a ns$ ls o)] (if (identical? o o2) - (reduce (partial rec ls) a (expand a ns$ ls o)) + (reduce (partial rec ls) a o) (rec ls a o2)))) a)) #{} a o)) @@ -250,6 +250,7 @@ :else (let [sym-ns$ (-> sym namespace symbol), sym-base$ (-> sym name symbol)] (or (when-some [sym-ns$ (-> a ::nses (get ns$) ::requires (get sym-ns$))] + (safe-require sym-ns$) (some-> (find-ns sym-ns$) (find-ns-var sym-base$))) (when-some [sym-ns$ (-> a ::nses (get ns$) ::require-macros (get sym-ns$))] (safe-require sym-ns$) diff --git a/src/hyperfiddle/electric/impl/cljs_analyzer2.clj b/src/hyperfiddle/electric/impl/cljs_analyzer2.clj new file mode 100644 index 000000000..211784cce --- /dev/null +++ b/src/hyperfiddle/electric/impl/cljs_analyzer2.clj @@ -0,0 +1,297 @@ +(ns hyperfiddle.electric.impl.cljs-analyzer2 + (:refer-clojure :exclude [find-var]) + (:require [edamame.core :as ed] + [clojure.core :as cc] + [clojure.string :as str] + [clojure.tools.reader.reader-types :as rt] + [clojure.java.io :as io] + [cljs.tagged-literals] + [missionary.core :as m] + [contrib.debug] + [cljs.core] ; for cljs macroexpansion + [cljs.env] + [cljs.analyzer] + [cljs.repl])) ; for cljs macroexpansion + +#_ +(defn get-expander-ns [env ^String nstr] + ;; first check for clojure.* -> cljs.* cases + (let [res (or (resolve-macro-ns-alias env nstr nil) + (resolve-ns-alias env nstr nil)) + nstr (if res (str res) nstr)] + (cond (= "clojure.core" nstr) (find-ns 'cljs.core) + (= "clojure.repl" nstr) (find-ns 'cljs.repl) + (.contains nstr ".") (find-ns (symbol nstr)) + :else (some-> env :ns :require-macros (get (symbol nstr)) find-ns)))) + +(defn ns->basename [ns$] (-> ns$ name (.replace \- \_) (.replace \. \/))) + +(defn ns->resource [ns$] + (let [base (ns->basename ns$)] + (or (io/resource (str base ".cljs")) + (io/resource (str base ".cljc"))))) + +(let [parse-opts + (ed/normalize-opts {:all true, :row-key :line, :col-key :column, :end-location false + :readers cljs.tagged-literals/*cljs-data-readers* :auto-resolve name + :features #{:cljs}, :read-cond :allow, :eof ::done})] + (defn resource-forms> [rs] + (->> (m/ap + (let [rdr (m/?> (m/observe (fn [!] + (let [rdr (rt/source-logging-push-back-reader (io/reader rs))] + (! rdr) #(.close ^java.io.Reader rdr)))))] + (m/? (m/?> (m/seed (repeat (m/sp (ed/parse-next rdr parse-opts)))))))) + (m/eduction (take-while (complement #{::done})))))) + +(defn safe-require [sym] + ;; we might be expanding clj code before the ns got loaded (during cljs compilation) + ;; to correctly lookup vars the ns needs to be loaded + ;; since shadow-cljs compiles in parallel we need to serialize the requires + (when-not (get (loaded-libs) sym) + (try (#'clojure.core/serialized-require sym) ; try bc it can be cljs file + (catch java.io.FileNotFoundException _)))) + +(defn find-ns-var [^clojure.lang.Namespace nso sym] (.findInternedVar nso sym)) +(declare find-var find-macro-var) + +(defn mksym [& xs] (symbol (apply str (mapv #((if (or (keyword? %) (symbol? %)) name str) %) xs)))) + +(defmacro my-deftype [nm & _] `(do (def ~nm) (def ~(mksym '-> nm)))) + +(let [-base-cljs-env {:context :statement + :locals {} + :fn-scope [] + :js-globals (into {} + (map #(vector % {:op :js-var :name % :ns 'js}) + '(alert window document console escape unescape + screen location navigator history location + global process require module exports)))}] + (defn ->cljs-env + ([] (->cljs-env (ns-name *ns*))) + ([nssym] (cond-> -base-cljs-env nssym (assoc :ns {:name nssym}))))) + +(def special? '#{if def fn* do let* loop* letfn* throw try catch finally + recur new set! ns deftype* defrecord* . js* & quote case* var ns*}) + +(let [blacklisted (into #{} (map cc/find-var) + '[cljs.core/exists? cljs.core/str cljs.core/aget cljs.core/* cljs.core/+ cljs.core// + #_cljs.core/let cljs.core/nil? cljs.core/aset clojure.core/gen-interface cljs.core/extend-type + cljs.core/implements? cljs.core/satisfies?]) + from-clj {#'cljs.core/defn #'clojure.core/defn + #'cljs.core/defn- #'clojure.core/defn- + #'cljs.core/declare #'clojure.core/declare + #'cljs.core/defprotocol #'clojure.core/defprotocol + #'clojure.core/deftype #'my-deftype + #'cljs.core/deftype #'my-deftype}] + (defn expand [a ns$ ls env [f & args :as o]] + (if (symbol? f) + (if (or (special? f) (ls f)) + o + (if-some [mac (find-macro-var a f ns$)] + (cond (= 'hyperfiddle.rcf/tests (symbol mac)) nil + (= 'hyperfiddle.electric-de/defn (symbol mac)) `(def ~(first args)) + (blacklisted mac) o + :else (apply (or (from-clj mac) mac) o env args)) + o)) + o))) + +(defn ->def-info [ns$ sym] {::name (with-meta (symbol (str ns$) (str sym)) (meta sym)), ::meta (meta sym)}) + +(defn add-require [!a ns$ reqk from$ to$] (swap! !a assoc-in [::nses ns$ reqk from$] to$)) + +(defn add-refers [!a ns$ refk o req$] + (reduce (fn [_ nx] (swap! !a assoc-in [::nses ns$ refk (or (get (:rename o) nx) nx)] (mksym req$ '/ nx))) + nil (:refer o))) + +(declare add-requireT analyze-nsT) + +(defn noneT [s _f] (s nil) #()) + +(defn ?auto-alias-clojureT [!a ns$ reqk refk req$] + (or (when-not (ns->resource req$) + (let [cljs (str/replace-first (str req$) #"^clojure\." "cljs."), cljs$ (symbol cljs)] + (when-not (= req$ cljs$) + (when (ns->resource cljs$) + (m/sp (m/? (add-requireT !a ns$ reqk refk [cljs$ :as req$])) cljs$))))) + noneT)) + +(defn add-requireT [!a ns$ reqk refk r] + (let [r (if (or (symbol? r) (string? r)) [r] r) + [req$ & o] r, o (apply hash-map o)] + (if (= ns$ req$) + noneT + (m/sp + (let [req$ (or (m/? (?auto-alias-clojureT !a ns$ reqk refk req$)) req$)] + (add-require !a ns$ reqk req$ req$) + (when (:as o) (add-require !a ns$ reqk (:as o) req$)) + (when (:refer o) (add-refers !a ns$ refk o req$)) + (m/? (m/join (fn [& _]) + (analyze-nsT !a (->cljs-env ns$) req$) + (if (:refer-macros o) + (add-requireT !a ns$ reqk refk + (into [req$] cat (-> (select-keys o [:as]) (assoc :refer (:refer-macros o))))) + noneT)))))))) + +(defn -add-requiresT [!a ns$ rs reqk refk] + (apply m/join (fn [& _]) (eduction (map #(add-requireT !a ns$ reqk refk %)) rs))) + +(defn add-require-macrosT [!a ns$ rs] (-add-requiresT !a ns$ rs ::require-macros ::refer-macros)) +(defn add-requiresT [!a ns$ rs] (-add-requiresT !a ns$ rs ::requires ::refers)) +(defn add-refer-clojure [!a ns$ ov] + (let [o (apply hash-map ov)] + (when (:exclude o) + (swap! !a assoc-in [::nses ns$ ::excludes] (set (:exclude o)))) + (when (:rename o) + (swap! !a + (fn [a] + (-> a (update-in [::nses ns$ ::refers] merge + (reduce-kv (fn [m k v] (assoc m v (symbol "cljs.core" (name k)))) {} (:rename o))) + (update-in [::nses ns$ ::excludes] into (keys (:rename o))))))))) +(defn use->require [args] + (let [o (apply hash-map (next args))] + (into [(first args)] cat (cond-> (select-keys o [:rename]) (:only o) (assoc :refer (:only o)))))) + +(comment + (a-ns foo + "docstring?" ; DONE + '{attr map?} ; DONE + (:refer-clojure :exclude [str]) ; DONE + (:refer-clojure :rename {str sstr}) ; DONE + (:require x ; DONE + [x] ; DONE + [x :as xy] ; DONE + [x :refer [y]] ; DONE + [x :refer [y] :rename {y yy}] ; DONE + [x :include-macros true] ; DONE + [x :refer-macros [y]]) ; DONE + (:require-macros x ; DONE + [x] ; DONE + [x :as xy] ; DONE + [x :refer [y]] ; DONE + [x :refer [y] :rename {y yy}]) ; DONE + (:use x ; + [x] ; + [x :only [y]] ; DONE + [x :only [y] :rename {y z}]) ; DONE + (:use-macros x ; + [x] ; + [x :only [y]] ; DONE + [x :only [y] :rename {y z}]) ; DONE + ) + ) +(defn skip-docstring [args] (cond-> args (string? (first args)) next)) +(defn skip-attr-map [args] (cond-> args (map? (first args)) next)) +(defn skip-inline-opts [args] (cond-> args (keyword? (first args)) (-> nnext recur))) +(defn add-ns-infoT [!a [_ns ns$ & args]] + (let [args (-> args skip-docstring skip-attr-map)] + (apply m/join (fn [& _]) + (eduction (map (fn [[typ & args]] + (case typ + (:require) (add-requiresT !a ns$ args) + (:require-macros) (add-require-macrosT !a ns$ args) + (:use) (add-requiresT !a ns$ (mapv use->require args)) + (:use-macros) (add-require-macrosT !a ns$ (mapv use->require args)) + (:refer-clojure) (m/sp (add-refer-clojure !a ns$ args)) + #_else noneT))) + args)))) + +(defn add-def [!a ns$ sym] (swap! !a assoc-in [::nses ns$ ::defs sym] (->def-info ns$ sym))) + +(defn collect-defsT [!a ns$ env o] + ;; (prn :defs (-> @!a ::nses (get ns$) ::defs keys sort)) + ;; (prn :collect-defs o) + ((fn recT [ls !a o] + (if (and (seq? o) (seq o)) + (case (first o) + (defmacro clojure.core/defmacro cljs.core/defmacro) noneT + + (defprotocol clojure.core/defprotocol cljs.core/defprotocol) + (let [[_ nm & args] o, fns (-> args skip-docstring skip-inline-opts)] + (m/sp (run! #(add-def !a ns$ %) (cons nm (eduction (map first fns)))))) + + (def) (m/sp (add-def !a ns$ (second o))) + + (deftype clojure.core/deftype cljs.core/deftype) + (let [[_ nm] o] (m/sp (add-def !a ns$ nm) (add-def !a ns$ (mksym '-> nm)))) + + (ns) (add-ns-infoT !a o) + + (fn*) (let [body (if (symbol? (second o)) (nnext o) (next o)) + arities (if (vector? (first body)) (list body) body)] + (apply m/join (fn [& _]) + (eduction (map (fn [[bs & body]] (recT (into ls bs) !a (cons 'do body)))) arities))) + + (let*) (let [[_ bs & body] o + [Ts ls] (transduce (partition-all 2) + (completing (fn [[Ts ls] [k v]] [(conj Ts (recT ls !a v)) (conj ls k)])) + [[] ls] bs)] + (apply m/join (fn [& _]) (conj Ts (recT ls !a (cons 'do body))))) + + #_else (let [o2 (expand @!a ns$ ls env o)] + (if (identical? o o2) + (apply m/join (fn [& _]) (eduction (map #(recT ls !a %)) o)) + (recur ls !a o2)))) + noneT)) + #{} !a o)) + +(defn keep-if [v pred] (when (pred v) v)) +(defn macro-var? [vr] (and (instance? clojure.lang.Var vr) (.isMacro ^clojure.lang.Var vr))) + +;;;;;;;;;;;;;;;;;; +;;; PUBLIC API ;;; +;;;;;;;;;;;;;;;;;; + +(defn analyze-nsT [!a env ns$] + (if-some [rs (some-> ns$ ns->resource)] + (loop [a @!a] + (or (-> a ::ns-tasks (get ns$)) + (let [T (->> (m/ap (let [o (m/?> (resource-forms> rs))] + (m/? (collect-defsT !a ns$ env o)))) + (m/reduce (fn [_ _]) nil)) + T (m/memo (m/via m/blk (m/? T)))] + (if (compare-and-set! !a a (assoc-in a [::ns-tasks ns$] T)) + T + (recur @!a))))) + noneT)) + +(defn purge-ns [!a ns$] (swap! !a (fn [a] (-> a (update ::ns-tasks dissoc ns$) (update ::nses dissoc ns$)))) nil) + +(defn find-var [a sym ns$] + (let [nsa (-> a ::nses (get ns$))] + (if (simple-symbol? sym) + (or (-> nsa ::defs (get sym)) + (when-not (get (::excludes nsa) sym) + (-> a ::nses (get 'cljs.core) ::defs (get sym))) + (when-some [renamed (get (::refers nsa) sym)] + (-> a ::nses (get (symbol (namespace renamed))) ::defs (get (symbol (name renamed)))))) + (or (when-some [sym-ns$ (-> nsa ::requires (get (symbol (namespace sym))))] + (find-var a (symbol (name sym)) sym-ns$)) + (when (= "clojure.core" (namespace sym)) + (-> a ::nses (get 'cljs.core) ::defs (get (-> sym name symbol)))) + (-> a ::nses (get (-> sym namespace symbol)) ::defs (get (-> sym name symbol))))))) + +;; TODO clojure.core -> cljs.core, clojure.repl -> cljs.repl +(defn find-macro-var [a sym ns$] + (when-not (find-var a sym ns$) + (-> (cond + (simple-symbol? sym) + (or (do (safe-require ns$) (some-> (find-ns ns$) (find-ns-var sym))) + (when-some [ref (-> a ::nses (get ns$) ::refers (get sym))] (requiring-resolve ref)) + (when-some [ref (-> a ::nses (get ns$) ::refer-macros (get sym))] (requiring-resolve ref)) + (when-not (get (-> a ::nses (get ns$) ::excludes) sym) (find-ns-var (find-ns 'clojure.core) sym))) + + (#{"cljs.core" "clojure.core"} (namespace sym)) + (requiring-resolve sym) + + :else + (let [sym-ns$ (-> sym namespace symbol), sym-base$ (-> sym name symbol)] + (or (when-some [sym-ns$ (-> a ::nses (get ns$) ::requires (get sym-ns$))] + (safe-require sym-ns$) + (some-> (find-ns sym-ns$) (find-ns-var sym-base$))) + (when-some [sym-ns$ (-> a ::nses (get ns$) ::require-macros (get sym-ns$))] + (safe-require sym-ns$) + (some-> (find-ns sym-ns$) (find-ns-var sym-base$))) + (some-> (find-ns sym-ns$) (find-ns-var sym-base$))))) + (keep-if macro-var?)))) + +(defn ->!a [] (let [!a (atom {})] (m/? (analyze-nsT !a (->cljs-env 'cljs.core) 'cljs.core)) !a)) diff --git a/src/hyperfiddle/electric/impl/destructure.cljc b/src/hyperfiddle/electric/impl/destructure.cljc new file mode 100644 index 000000000..7ca295ebe --- /dev/null +++ b/src/hyperfiddle/electric/impl/destructure.cljc @@ -0,0 +1,107 @@ +(ns hyperfiddle.electric.impl.destructure + "Cross-platform (clj/cljs) destructuring. Adapted from clojurescript codebase" + (:require [cljs.core] + [hyperfiddle.electric.impl.runtime-de :as r])) + +(defn destructure* [bindings] + (let [bents (partition 2 bindings) + pb (fn pb [bvec b v] + (let [pvec + (fn [bvec b val] + (let [gvec (gensym "vec__") + gseq (gensym "seq__") + gfirst (gensym "first__") + has-rest (some #{'&} b)] + (loop [ret (let [ret (conj bvec gvec val)] + (if has-rest + (conj ret gseq (list `seq gvec)) + ret)) + n 0 + bs b + seen-rest? false] + (if (seq bs) + (let [firstb (first bs)] + (cond + (= firstb '&) (recur (pb ret (second bs) gseq) + n + (nnext bs) + true) + (= firstb :as) (pb ret (second bs) gvec) + :else (if seen-rest? + (throw #?(:clj (new Exception "Unsupported binding form, only :as can follow & parameter") + :cljs (new js/Error "Unsupported binding form, only :as can follow & parameter"))) + (recur (pb (if has-rest + (conj ret + gfirst `(first ~gseq) + gseq `(next ~gseq)) + ret) + firstb + (if has-rest + gfirst + (list `nth gvec n nil))) + (inc n) + (next bs) + seen-rest?)))) + ret)))) + pmap + (fn [bvec b v] + (let [gmap (gensym "map__") + defaults (:or b)] + (loop [ret (-> bvec (conj gmap) (conj v) + (conj gmap) (conj `(r/get-destructure-map ~gmap)) + ((fn [ret] + (if (:as b) + (conj ret (:as b) gmap) + ret)))) + bes (let [transforms + (reduce + (fn [transforms mk] + (if (keyword? mk) + (let [mkns (namespace mk) + mkn (name mk)] + (cond (= mkn "keys") (assoc transforms mk #(keyword (or mkns (namespace %)) (name %))) + (= mkn "syms") (assoc transforms mk #(list `quote (symbol (or mkns (namespace %)) (name %)))) + (= mkn "strs") (assoc transforms mk str) + :else transforms)) + transforms)) + {} + (keys b))] + (reduce + (fn [bes entry] + (reduce #(assoc %1 %2 ((val entry) %2)) + (dissoc bes (key entry)) + ((key entry) bes))) + (dissoc b :as :or) + transforms))] + (if (seq bes) + (let [bb (key (first bes)) + bk (val (first bes)) + local (if #?(:clj (instance? clojure.lang.Named bb) + :cljs (cljs.core/implements? INamed bb)) + (with-meta (symbol nil (name bb)) (meta bb)) + bb) + bv (if (contains? defaults local) + (list 'get gmap bk (defaults local)) + (list 'get gmap bk))] + (recur + (if (or (keyword? bb) (symbol? bb)) ;(ident? bb) + (-> ret (conj local bv)) + (pb ret bb bv)) + (next bes))) + ret))))] + (cond + (symbol? b) (-> bvec (conj (if (namespace b) (symbol (name b)) b)) (conj v)) + (keyword? b) (-> bvec (conj (symbol (name b))) (conj v)) + (vector? b) (pvec bvec b v) + (map? b) (pmap bvec b v) + :else (throw + #?(:clj (new Exception (str "Unsupported binding form: " b)) + :cljs (new js/Error (str "Unsupported binding form: " b))))))) + process-entry (fn [bvec b] (pb bvec (first b) (second b)))] + (if (every? symbol? (map first bents)) + bindings + (if-let [kwbs (seq (filter #(keyword? (first %)) bents))] + (throw + #?(:clj (new Exception (str "Unsupported binding key: " (ffirst kwbs))) + :cljs (new js/Error (str "Unsupported binding key: " (ffirst kwbs))))) + (reduce process-entry [] bents))))) diff --git a/src/hyperfiddle/electric/impl/lang.clj b/src/hyperfiddle/electric/impl/lang.clj index f512a386e..0efa45b4a 100644 --- a/src/hyperfiddle/electric/impl/lang.clj +++ b/src/hyperfiddle/electric/impl/lang.clj @@ -386,8 +386,13 @@ (update env ::last #(conj (pop %) form)) (assoc env ::last (conj (clojure.lang.PersistentQueue/EMPTY) nil form)))) +(defn pr-str-short [o] + (if (and (seq? o) (seq o)) + (apply str `("(" ~@(interpose " " (take 2 o)) " .. )")) + (str o))) + (defn analyze-me [env form] - (when (::trace env) (prn :analyze (if (and (seq? form) (seq form)) (first form) form))) + (when (::trace env) (prn :analyze (if (and (seq? form) (seq form)) (pr-str-short form) form))) (let [env (store env form)] (cond (and (seq? form) (seq form)) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 7c5f3e8fc..cc5fff078 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -1,7 +1,6 @@ (ns hyperfiddle.electric.impl.lang-de2 (:refer-clojure :exclude [compile]) - (:require [cljs.analyzer :as cljs-ana] - [cljs.core] + (:require [cljs.analyzer] [cljs.env] [clojure.string :as str] [contrib.assert :as ca] @@ -10,8 +9,11 @@ [contrib.triple-store :as ts] [dom-top.core :refer [loopr]] [fipp.edn] + [missionary.core :as m] [hyperfiddle.electric-de :as-alias e] [hyperfiddle.electric.impl.analyzer :as ana] + [hyperfiddle.electric.impl.cljs-analyzer2 :as cljs-ana] + [hyperfiddle.electric.impl.destructure :as dst] [hyperfiddle.electric.impl.runtime-de :as r] [hyperfiddle.rcf :as rcf :refer [tests]])) @@ -37,7 +39,7 @@ ;; the ns cache relies on external eviction in shadow-cljs reload hook (def !cljs-ns-cache (atom {})) -(defn enrich-for-require-macros-lookup [cljs-env nssym] +#_(defn enrich-for-require-macros-lookup [cljs-env nssym] (if-some [ast (get @!cljs-ns-cache nssym)] (assoc cljs-env :ns ast) (if-some [src (cljs-ana/locate-src nssym)] @@ -51,7 +53,7 @@ (assoc cljs-env :ns ast)) cljs-env))) -(tests "enrich of clj source file is noop" +#_(tests "enrich of clj source file is noop" (cljs.env/ensure (enrich-for-require-macros-lookup {:a 1} 'clojure.core)) := {:a 1}) (let [-base-cljs-env {:context :statement @@ -69,7 +71,7 @@ (def !default-cljs-compiler-env (delay (cljs.env/ensure - (cljs-ana/analyze-file "cljs/core.cljs") ; needed in general, to resolve cljs.core vars + (cljs.analyzer/analyze-file "cljs/core.cljs") ; needed in general, to resolve cljs.core vars cljs.env/*compiler*))) ;; adapted from cljs.env @@ -85,7 +87,7 @@ (if (nil? val#) (pop-thread-bindings)))))) -(defn ensure-cljs-env [env] +#_(defn ensure-cljs-env [env] (if (::cljs-env env) env (assoc env ::cljs-env @@ -102,7 +104,7 @@ (declare -expand-all-in-try) -(defn resolve-cljs [env sym] +#_(defn resolve-cljs [env sym] (when (not= '. sym) (let [!found? (volatile! true) resolved (binding [cljs-ana/*cljs-warnings* (assoc cljs-ana/*cljs-warnings* :undeclared-ns false)] @@ -121,13 +123,12 @@ (recur env (ca/check qualified-symbol? (:name resolved) {:sym sym, :resolved resolved})) resolved))))) -(comment +#_(comment (cljs.env/ensure (cljs-ana/resolve-var (cljs-ana/empty-env) 'prn nil nil)) (->cljs-env) (cljs-ana/empty-env) (require '[hyperfiddle.electric.impl.expand :as expand]) (cljs.env/ensure (resolve-cljs (cljs-ana/empty-env) 'prn)) - (ensure-cljs-compiler (cljs-ana/parse 'ns (->cljs-env) '(ns foo (:require [hyperfiddle.electric :as e])) 'ns {})) ) (defn macroexpand-clj [o env] @@ -136,7 +137,7 @@ (apply mac o env (next o)) (macroexpand-1 o))) ; e.g. (Math/abs 1) will expand to (. Math abs 1) -(defn expand-referred-or-local-macros [o cljs-macro-env] +#_(defn expand-referred-or-local-macros [o cljs-macro-env] ;; (:require [some.ns :refer [some-macro]]) ;; `some-macro` might be a macro and cljs expander lookup fails to find it ;; another case is when a cljc file :require-macros itself without refering the macros @@ -146,6 +147,12 @@ o) o)) +(def !a (cljs-ana/->!a)) + +(comment + (cljs-ana/purge-ns !a 'hyperfiddle.electric-de-test) + ) + (defn expand-macro [env o] (let [[f & args] o, n (name f), e (dec (count n))] (if (= "." n) @@ -155,16 +162,19 @@ (if (some? (re-find #"^\.[^.]" n)) (list* '. (first args) (symbol (subs n 1)) (rest args)) (if (= :cljs (get (::peers env) (::current env))) - (let [cljs-env (::cljs-env env)] - (if (resolve-cljs cljs-env f) - o - (let [cljs-macro-env (cond-> cljs-env (::ns cljs-env) (assoc :ns (::ns cljs-env)))] - (if-some [expander (cljs-ana/get-expander f cljs-macro-env)] - (apply expander o cljs-macro-env args) - (expand-referred-or-local-macros o cljs-macro-env))))) + (if-some [mac (cljs-ana/find-macro-var @!a f (get-ns env))] + (apply mac o (merge (->cljs-env (get-ns env)) env) args) + o) + #_(let [cljs-env (::cljs-env env)] + (if (resolve-cljs cljs-env f) + o + (let [cljs-macro-env (cond-> cljs-env (::ns cljs-env) (assoc :ns (::ns cljs-env)))] + (if-some [expander (cljs-ana/get-expander f cljs-macro-env)] + (apply expander o cljs-macro-env args) + (expand-referred-or-local-macros o cljs-macro-env))))) (macroexpand-clj o env))))))) -(defn find-local-entry [env sym] (find (:locals env) sym)) +(defn find-local-entry [env sym] (contains? (:locals env) sym)) (defn add-local [env sym] (update env :locals assoc sym ::unknown)) (defn ?meta [metao o] @@ -176,13 +186,13 @@ (defn ?expand-macro [o env caller] (if (symbol? (first o)) - (let [o2 (expand-macro env o)] + (let [o2 (?meta o (expand-macro env o))] (if (identical? o o2) (?meta o (list* (first o) (mapv (fn-> caller env) (rest o)))) (caller o2 env))) (?meta o (list* (caller (first o) env) (mapv (fn-> caller env) (next o)))))) -(defn -expand-all-non-electric [o env] +#_(defn -expand-all-non-electric [o env] (if (and (seq? o) (seq o)) (if (find-local-entry env (first o)) (?meta o (list* (first o) (mapv (fn-> -expand-all env) (rest o)))) @@ -203,6 +213,9 @@ (recur (?meta o (cons `e/amb body)) env)) (recur (?meta o (second o)) env)) + (let clojure.core/let cljs.core/let) + (let [[_ bs & body] o] (recur (?meta o (list* 'let* (dst/destructure* bs) body)) env)) + (let*) (let [[_ bs & body] o [bs2 env2] (reduce (fn [[bs env] [sym v]] @@ -243,22 +256,22 @@ (fn*) (let [[?name more] (if (symbol? (second o)) [(second o) (nnext o)] [nil (next o)]) arities (cond-> more (vector? (first more)) list)] - (?meta o (apply list - (into (if ?name ['fn* ?name] ['fn*]) - (map (fn [[syms & body]] - (list syms (-expand-all-non-electric (cons 'do body) (reduce add-local env syms))))) - arities)))) + (?meta o (apply list (into (if ?name ['fn* ?name] ['fn*]) arities)))) (letfn*) (let [[_ bs & body] o env2 (reduce add-local env (take-nth 2 bs)) bs2 (into [] (comp (partition-all 2) - (mapcat (fn [[sym v]] [sym (-expand-all-non-electric v env2)]))) - bs)] + (mapcat (fn [[sym v]] [sym (-expand-all v env2)]))) + bs) + ] (?meta o `(let* [~(vec (take-nth 2 bs2)) (::letfn ~bs2)] ~(-expand-all (cons 'do body) env2)))) ;; TODO expand `do` (try) (throw (ex-info "try is TODO" {:o o})) #_(list* 'try (mapv (fn-> -all-in-try env) (rest o))) + (js*) (let [[_ s & args] o, gs (repeatedly (count args) gensym)] + (recur (?meta o `((fn* ([~@gs] (~'js* ~s ~@gs))) ~@args)) env)) + (binding clojure.core/binding) (let [[_ bs & body] o] (?meta o (list 'binding (into [] (comp (partition-all 2) (mapcat (fn [[sym v]] [sym (-expand-all v env)]))) bs) @@ -271,6 +284,9 @@ #_else (?expand-macro o env -expand-all))) + (instance? cljs.tagged_literals.JSValue o) + (cljs.tagged_literals.JSValue. (-expand-all (.-val o) env)) + (map-entry? o) (clojure.lang.MapEntry. (-expand-all (key o) env) (-expand-all (val o) env)) (coll? o) (?meta (meta o) (into (empty o) (map (fn-> -expand-all env)) o)) :else o)) @@ -291,8 +307,9 @@ ;; if ::current = :clj expand with clj environment ;; if ::current = :cljs expand with cljs environment - -(defn expand-all [env o] (ensure-cljs-compiler (-expand-all o (ensure-cljs-env (assoc env ::electric true))))) +(defn expand-all [env o] + (m/? (cljs-ana/analyze-nsT !a env (get-ns env))) + (-expand-all o (assoc env ::electric true))) ;;;;;;;;;;;;;;;; ;;; COMPILER ;;; @@ -313,8 +330,10 @@ \newline "If `" form "` is supposed to be a macro, you might need to :refer it in the :require-macros clause.")))) {:locals (keys (:locals env))})) -(defn ambiguous-resolve! [env sym] - (fail! env (str "Unsited symbol `" sym "` resolves to different vars on different peers. Please resolve ambiguity by siting the expression using it."))) +(defn ambiguous-resolve! [env sym vs] + (fail! env + (str "Unsited symbol `" sym "` resolves to different vars on different peers. Please resolve ambiguity by siting the expression using it.") + {:resolves vs})) (defn ns-qualify [node] (if (namespace node) node (symbol (str *ns*) (str node)))) @@ -431,6 +450,10 @@ (when (class? cls) (clojure.lang.Reflector/getField cls (name sym) true))))) +(defn resolve-static-method [sym] + (when (and (qualified-symbol? sym) (class? (resolve (-> sym namespace symbol)))) + sym)) + (defn get-children-e [ts e] (-> ts :ave ::parent (get e))) (defn get-child-e [ts e] (first (get-children-e ts e))) @@ -464,26 +487,29 @@ :clj (when-some [^clojure.lang.Var vr (resolve env sym)] (when (-> vr meta node?) (symbol (-> vr .ns str) (-> vr .sym str)))) - :cljs (when-some [vr (resolve-cljs env sym)] - (when (-> vr :meta node?) + :cljs (when-some [vr (cljs-ana/find-var @!a sym (get-ns env)) #_(resolve-cljs env sym)] + (when (-> vr ::cljs-ana/meta node?) (symbol (-> vr :name str)))))) -(defn analyze-clj-symbol [sym] +(defn analyze-clj-symbol [sym ns$] (if (resolve-static-field sym) {::type ::static, ::sym sym} - (when-some [v (resolve sym)] + (when-some [v (ns-resolve (find-ns ns$) sym)] (if (var? v) {::type ::var, ::sym (symbol v)} {::type ::static, ::sym sym})))) +(def implicit-cljs-nses '#{goog goog.object goog.string goog.array Math String}) + (defn analyze-cljs-symbol [sym env] - (when-some [v (resolve-cljs (::cljs-env env) sym)] - (if (= :var (:op v)) {::type ::var, ::sym (untwin (:name v))} {::type ::static, ::sym sym}))) + (if-some [v (cljs-ana/find-var @!a sym (get-ns env))] + {::type ::var, ::sym (untwin (::cljs-ana/name v))} + {::type ::static, ::sym sym})) -(defn resolve-cljs-alias [env sym] - (if (simple-symbol? sym) - (symbol (-> env :ns :name str) (name sym)) - (or (cljs-ana/resolve-ns-alias env sym) (cljs-ana/resolve-macro-ns-alias env sym)))) +#_(defn resolve-cljs-alias [env sym] + (if (simple-symbol? sym) + (symbol (-> env :ns :name str) (name sym)) + (or (cljs-ana/resolve-ns-alias env sym) (cljs-ana/resolve-macro-ns-alias env sym)))) -(defn assume-cljs-var [sym env] {::type ::var, ::sym (untwin (resolve-cljs-alias env sym))}) +#_(defn assume-cljs-var [sym env] {::type ::var, ::sym (untwin (resolve-cljs-alias env sym))}) (defn resolve-symbol [sym env] (if-some [local (-> env :locals (get sym))] @@ -493,20 +519,15 @@ (if-some [nd (resolve-node sym env)] {::lang nil, ::type ::node, ::node nd} (case (get (::peers env) (::current env)) - :clj (let [v (analyze-clj-symbol sym)] (case v nil (cannot-resolve! env sym) #_else (assoc v ::lang :clj))) - :cljs (assoc (or (analyze-cljs-symbol sym env) - ;; optimistically resolve on cljs - ;; we don't load the whole ns file so we cannot resolve all vars - ;; loading the whole ns would undermine previous work - (assume-cljs-var sym env)) + :clj (let [v (analyze-clj-symbol sym (get-ns env))] (case v nil (cannot-resolve! env sym) #_else (assoc v ::lang :clj))) + :cljs (assoc (analyze-cljs-symbol sym env) ::lang :cljs) #_unsited (let [langs (set (vals (::peers env))) vs (->> langs (into #{} (map #(case % - :clj (analyze-clj-symbol sym) - :cljs (or (analyze-cljs-symbol sym env) - (assume-cljs-var sym env))))))] + :clj (analyze-clj-symbol sym (get-ns env)) + :cljs (analyze-cljs-symbol sym env)))))] (cond (contains? vs nil) (cannot-resolve! env sym) - (> (count vs) 1) (ambiguous-resolve! env sym) + (> (count vs) 1) (ambiguous-resolve! env sym vs) :else (assoc (first vs) ::lang nil))))))) (defn ->let-val-e [ts e] (first (get-children-e ts e))) @@ -543,15 +564,19 @@ (declare analyze) -(defn ->class-method-call [clazz method method-args pe env {{::keys [->id]} :o :as ts}] - (let [e (->id), ce (->id)] - (reduce (fn [ts form] (analyze form e env ts)) - (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) - (ts/add {:db/id ce, ::parent e, ::type ::pure}) - (ts/add {:db/id (->id), ::parent ce, ::type ::literal, - ::v (let [margs (repeatedly (count method-args) gensym)] - `(fn [~@margs] (. ~clazz ~method ~@margs)))})) - method-args))) +(defn ->class-method-call [clazz method method-args pe env form {{::keys [->id]} :o :as ts}] + (if (seq method-args) + (let [e (->id), ce (->id)] + (reduce (fn [ts form] (analyze form e env ts)) + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) + (ts/add {:db/id ce, ::parent e, ::type ::pure}) + (ts/add {:db/id (->id), ::parent ce, ::type ::literal, + ::v (let [margs (repeatedly (count method-args) gensym), meth (symbol (str clazz) (str method))] + `(fn [~@margs] (~meth ~@margs)))})) + method-args)) + (let [e (->id)] ; (. java.time.Instant now) + (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) + (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form}))))) (defn ->obj-method-call [o method method-args pe env {{::keys [->id]} :o :as ts}] (let [e (->id), ce (->id)] @@ -560,74 +585,84 @@ (ts/add {:db/id ce, ::parent e, ::type ::pure}) (ts/add {:db/id (->id), ::parent ce, ::type ::literal, ::v (let [oo (gensym "o"), margs (repeatedly (count method-args) gensym)] - `(fn [~@margs] (. ~oo ~method ~@margs)))})) + `(fn [~oo ~@margs] (. ~oo ~method ~@margs)))})) (cons o method-args)))) (defn def-sym-in-cljs-compiler! [sym ns] (swap! @(requiring-resolve 'cljs.env/*compiler*) assoc-in [:cljs.analyzer/namespaces ns :defs sym] {:name sym})) +(defn store [env form] + (if (::last env) + (update env ::last #(conj (pop %) form)) + (assoc env ::last (conj (clojure.lang.PersistentQueue/EMPTY) nil form)))) + (defn analyze [form pe env {{::keys [->id]} :o :as ts}] - (cond - (and (seq? form) (seq form)) - (case (first form) - (let*) (let [[_ bs bform] form] - (loopr [ts ts, pe pe, env env] - [[s v] (eduction (partition-all 2) bs)] - (let [e (->id)] - (recur (analyze v e env - (-> (ts/add ts {:db/id e, ::parent pe, ::type ::let, ::sym s}) - (?add-source-map e form))) e (update-in env [:locals s] assoc ::electric-let e))) - (analyze bform pe env ts))) - (case) (let [[_ test & brs] form - [default brs2] (if (odd? (count brs)) [(last brs) (butlast brs)] [:TODO brs])] - (loopr [bs [], mp {}] - [[v br] (partition 2 brs2)] - (let [b (gensym "case-val")] - (recur (conj bs b `(::ctor ~br)) - (reduce (fn [ac nx] (assoc ac (list 'quote nx) b)) mp (if (seq? v) v [v])))) - (recur (?meta form `(let* ~bs (::call (~mp ~test (::ctor ~default))))) pe env ts))) - (quote) (let [e (->id)] - (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) - (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form}))) - (fn*) (let [e (->id), ce (->id) - [form refs] (closure env form) - ts2 (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) - (ts/add {:db/id ce, ::parent e, ::type ::pure}) - (ts/add {:db/id (->id), ::parent ce, ::type ::literal, ::v form}) - (?add-source-map e form))] - (reduce (fn [ts nx] (analyze nx e env ts)) ts2 refs)) - (new) (let [[_ f & args] form, e (->id), ce (->id), cce (->id)] - (reduce (fn [ts arg] (analyze arg e env ts)) - (-> ts - (ts/add {:db/id e, ::parent pe, ::type ::ap}) - (ts/add {:db/id ce, ::parent e, ::type ::pure}) - (ts/add {:db/id cce, ::parent ce, ::type ::literal, - ::v (let [gs (repeatedly (count args) gensym)] - `(fn [~@gs] (new ~f ~@gs)))})) - args)) - ;; (. java.time.Instant now) - ;; (. java.time.Instant ofEpochMilli 1) - ;; (. java.time.Instant (ofEpochMilli 1)) - ;; (. java.time.Instant EPOCH) - ;; (. java.time.Instant -EPOCH) - ;; (. i1 isAfter i2) - ;; (. i1 (isAfter i2)) - ;; (. pt x) - ;; (. pt -x) - (.) (if (and (symbol? (second form)) (class? (resolve env (second form)))) - (if (seq? (nth form 2)) ; (. java.time.Instant (ofEpochMilli 1)) - (let [[_ clazz [method & method-args]] form] - (->class-method-call clazz method method-args pe env ts)) - (let [[_ clazz x & xs] form] - (if (seq xs) ; (. java.time.Instant ofEpochMilli 1) - (->class-method-call clazz x xs pe env ts) - (let [e (->id)] ; (. java.time.Instant now) - (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) - (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form})))))) - (if (seq? (nth form 2)) ; (. i1 (isAfter i2)) + (let [env (store env form)] + (cond + (and (seq? form) (seq form)) + (case (first form) + (let*) (let [[_ bs bform] form] + (loopr [ts ts, pe pe, env env] + [[s v] (eduction (partition-all 2) bs)] + (let [e (->id)] + (recur (analyze v e env + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::let, ::sym s}) + (?add-source-map e form))) e (update-in env [:locals s] assoc ::electric-let e))) + (analyze bform pe env ts))) + (case) (let [[_ test & brs] form + [default brs2] (if (odd? (count brs)) [(last brs) (butlast brs)] [:TODO brs])] + (loopr [bs [], mp {}] + [[v br] (partition 2 brs2)] + (let [b (gensym "case-val")] + (recur (conj bs b `(::ctor ~br)) + (reduce (fn [ac nx] (assoc ac (list 'quote nx) b)) mp (if (seq? v) v [v])))) + (recur (?meta form `(let* ~bs (::call (~mp ~test (::ctor ~default))))) pe env ts))) + (quote) (let [e (->id)] + (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) + (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form}))) + (fn*) (let [e (->id), ce (->id) + [form refs] (closure env form) + ts2 (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) + (ts/add {:db/id ce, ::parent e, ::type ::pure}) + (ts/add {:db/id (->id), ::parent ce, ::type ::literal, ::v form}) + (?add-source-map e form))] + (reduce (fn [ts nx] (analyze nx e env ts)) ts2 refs)) + (new) (let [[_ f & args] form, e (->id), ce (->id), cce (->id)] + (reduce (fn [ts arg] (analyze arg e env ts)) + (-> ts + (ts/add {:db/id e, ::parent pe, ::type ::ap}) + (ts/add {:db/id ce, ::parent e, ::type ::pure}) + (ts/add {:db/id cce, ::parent ce, ::type ::literal, + ::v (let [gs (repeatedly (count args) gensym)] + `(fn [~@gs] (new ~f ~@gs)))})) + args)) + ;; (. java.time.Instant now) + ;; (. java.time.Instant ofEpochMilli 1) + ;; (. java.time.Instant (ofEpochMilli 1)) + ;; (. java.time.Instant EPOCH) + ;; (. java.time.Instant -EPOCH) + ;; (. i1 isAfter i2) + ;; (. i1 (isAfter i2)) + ;; (. pt x) + ;; (. pt -x) + (.) (cond + (implicit-cljs-nses (second form)) ; (Math/abs -1) expanded to (. Math abs -1) + (let [[_ clazz method & method-args] form] ; cljs fails on dot form, so we compile as class call + (->class-method-call clazz method method-args pe env form ts)) + + (and (symbol? (second form)) (class? (resolve env (second form)))) + (if (seq? (nth form 2)) ; (. java.time.Instant (ofEpochMilli 1)) + (let [[_ clazz [method & method-args]] form] + (->class-method-call clazz method method-args pe env form ts)) + (let [[_ clazz x & xs] form] + (->class-method-call clazz x xs pe env form ts))) + + (seq? (nth form 2)) ; (. i1 (isAfter i2)) (let [[_ o [method & method-args]] form] (->obj-method-call o method method-args pe env ts)) + + :else (let [[_ o x & xs] form] (if (seq xs) ; (. i1 isAfter i2) (->obj-method-call o x xs pe env ts) @@ -636,68 +671,75 @@ (-> ts (ts/add {:db/id e, ::parent pe, ::type ::ap}) (ts/add {:db/id ce, ::parent e, ::type ::pure}) - (ts/add {:db/id (->id) , ::parent ce, ::type ::literal, ::v `(fn [oo#] (. oo# ~x))})))))))) - (binding clojure.core/binding) (let [[_ bs bform] form, gs (repeatedly (/ (count bs) 2) gensym)] - (recur (if (seq bs) - `(let* [~@(interleave gs (take-nth 2 (next bs)))] - (::call ((::static-vars r/bind) (::ctor ~bform) - ~@(interleave - (mapv #(get-lookup-key % env) (take-nth 2 bs)) - (mapv #(list ::pure %) gs))))) - bform) - pe env ts)) - (def) (let [[_ sym v] form] - (case (->env-type env) - :clj (recur `((fn* ([x#] (def ~sym x#))) ~v) pe env ts) - :cljs (do (def-sym-in-cljs-compiler! sym (get-ns env)) - (recur `(set! ~sym ~v) pe env ts)))) - (set!) (let [[_ target v] form] (recur `((fn* ([v#] (set! ~target v#))) ~v) pe env ts)) - (::ctor) (let [e (->id), ce (->id)] - (recur (list ::site nil (second form)) - ce env (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) - (ts/add {:db/id ce, ::parent e, ::type ::ctor}) - (?add-source-map e form)))) - (::call) (let [e (->id)] (recur (second form) e env (-> (ts/add ts {:db/id e, ::parent pe, ::type ::call}) - (?add-source-map e form)))) - (::pure) (let [e (->id)] (recur (second form) e env (-> (ts/add ts {:db/id e, ::parent pe, ::type ::pure}) - (?add-source-map e form)))) - (::join) (let [e (->id)] (recur (second form) e env (-> (ts/add ts {:db/id e, ::parent pe, ::type ::join}) - (?add-source-map e form)))) - (::site) (let [[_ site bform] form, e (->id)] - (recur bform e (assoc env ::current site) - (-> (ts/add ts {:db/id e, ::parent pe, ::type ::site, ::site site}) - (?add-source-map e form)))) - (::lookup) (let [[_ sym] form] (ts/add ts {:db/id (->id), ::parent pe, ::type ::lookup, ::sym sym})) - (::static-vars) (recur (second form) pe (assoc env ::static-vars true) ts) - #_else (let [e (->id)] - (reduce (fn [ts nx] (analyze nx e env ts)) (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) - (?add-source-map e form)) form))) - - (vector? form) (recur (?meta form (cons `(::static-vars vector) form)) pe env ts) - (map? form) (recur (?meta form (cons `(::static-vars hash-map) (eduction cat form))) pe env ts) - (set? form) (recur (?meta form (cons `(::static-vars hash-set) form)) pe env ts) - - (symbol? form) - (let [e (->id), ret (resolve-symbol form env)] - (-> (case (::type ret) - (::let-ref) (ts/add ts {:db/id e, ::parent pe, ::type ::let-ref, ::ref (::ref ret), ::sym form}) - (::local) (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) - (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form})) - (::static ::var) (if (::static-vars env) - (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) - (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form})) - (ts/add ts (cond-> {:db/id e, ::parent pe, ::type ::var - ::var form, ::qualified-var (::sym ret)} - (::lang ret) (assoc ::resolved-in (::lang ret))))) - (::node) (ts/add ts {:db/id e, ::parent pe, ::type ::node, ::node (::node ret)}) - #_else (throw (ex-info (str "unknown symbol type " (::type ret)) (or ret {})))) - (?add-source-map e form))) - - :else - (let [e (->id)] - (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) - (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form}) - (?add-source-map e form))))) + (ts/add {:db/id (->id) , ::parent ce, ::type ::literal, ::v `(fn [oo#] (. oo# ~x))}))))))) + (binding clojure.core/binding) (let [[_ bs bform] form, gs (repeatedly (/ (count bs) 2) gensym)] + (recur (if (seq bs) + `(let* [~@(interleave gs (take-nth 2 (next bs)))] + (::call ((::static-vars r/bind) (::ctor ~bform) + ~@(interleave + (mapv #(get-lookup-key % env) (take-nth 2 bs)) + (mapv #(list ::pure %) gs))))) + bform) + pe env ts)) + (def) (let [[_ sym v] form] + (case (->env-type env) + :clj (recur `((fn* ([x#] (def ~sym x#))) ~v) pe env ts) + :cljs (do (def-sym-in-cljs-compiler! sym (get-ns env)) + (recur `(set! ~sym ~v) pe env ts)))) + (set!) (let [[_ target v] form] (recur `((fn* ([v#] (set! ~target v#))) ~v) pe env ts)) + (::ctor) (let [e (->id), ce (->id)] + (recur (list ::site nil (second form)) + ce env (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) + (ts/add {:db/id ce, ::parent e, ::type ::ctor}) + (?add-source-map e form)))) + (::call) (let [e (->id)] (recur (second form) e env (-> (ts/add ts {:db/id e, ::parent pe, ::type ::call}) + (?add-source-map e form)))) + (::pure) (let [e (->id)] (recur (second form) e env (-> (ts/add ts {:db/id e, ::parent pe, ::type ::pure}) + (?add-source-map e form)))) + (::join) (let [e (->id)] (recur (second form) e env (-> (ts/add ts {:db/id e, ::parent pe, ::type ::join}) + (?add-source-map e form)))) + (::site) (let [[_ site bform] form, e (->id)] + (recur bform e (assoc env ::current site) + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::site, ::site site}) + (?add-source-map e form)))) + (::lookup) (let [[_ sym] form] (ts/add ts {:db/id (->id), ::parent pe, ::type ::lookup, ::sym sym})) + (::static-vars) (recur (second form) pe (assoc env ::static-vars true) ts) + #_else (let [e (->id)] + (reduce (fn [ts nx] (analyze nx e env ts)) (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) + (?add-source-map e form)) form))) + + (instance? cljs.tagged_literals.JSValue form) + (let [o (.-val ^cljs.tagged_literals.JSValue form)] + (if (map? o) + (recur (?meta form (cons `(::static-vars cljs.core/js-obj) (into [] (mapcat (fn [[k v]] [(name k) v])) o))) + pe env ts) + (recur (?meta form (cons `(::static-vars cljs.core/array) o)) pe env ts))) + + (vector? form) (recur (?meta form (cons `(::static-vars vector) form)) pe env ts) + (map? form) (recur (?meta form (cons `(::static-vars hash-map) (eduction cat form))) pe env ts) + (set? form) (recur (?meta form (cons `(::static-vars hash-set) form)) pe env ts) + + (symbol? form) + (let [e (->id), ret (resolve-symbol form env)] + (-> (case (::type ret) + (::let-ref) (ts/add ts {:db/id e, ::parent pe, ::type ::let-ref, ::ref (::ref ret), ::sym form}) + (::local) (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) + (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form})) + (::static ::var) (if (::static-vars env) + (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) + (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form})) + (ts/add ts (cond-> {:db/id e, ::parent pe, ::type ::var + ::var form, ::qualified-var (::sym ret)} + (::lang ret) (assoc ::resolved-in (::lang ret))))) + (::node) (ts/add ts {:db/id e, ::parent pe, ::type ::node, ::node (::node ret)}) + #_else (throw (ex-info (str "unknown symbol type " (::type ret)) (or ret {})))) + (?add-source-map e form))) + + :else + (let [e (->id)] + (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) + (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form}) + (?add-source-map e form)))))) (defn ->->id [] (let [!i (long-array [-1])] (fn [] (aset !i 0 (unchecked-inc (aget !i 0)))))) @@ -823,141 +865,138 @@ (defn get-deps [sym] (-> sym resolve meta ::deps)) (defn analyze-electric [env {{::keys [->id]} :o :as ts}] - (ensure-cljs-compiler - (let [change-parent (fn change-parent [ts e pe] (ts/asc ts e ::parent pe)) - orphan (fn orphan [ts e] (change-parent ts e nil)) - collapse-ap-with-only-pures (fn collapse-ap-with-only-pures [ts] ; (r/ap (r/pure .)+ ) => (r/pure (::comp . . .)) - (reduce (fn [ts ap-e] - (let [[f-e & args-e :as children-e] (get-children-e ts ap-e)] - (if (every? #(= ::pure (::type (ts/->node ts %))) children-e) - (reduce (fn [ts e] - (-> ts (change-parent (get-child-e ts e) f-e) - (orphan e))) - ;; reuse nodes, otherwise node ordering messes up - (-> ts (ts/asc ap-e ::type ::pure) (ts/asc f-e ::type ::comp)) - args-e) - ts))) - ts (reverse (ts/find ts ::type ::ap)))) - ->ctor-idx (->->id) - seen (volatile! #{}) - mark-used-ctors (fn mark-used-ctors [ts e] - (if (@seen e) - ts - (let [nd (get (:eav ts) e)] - (vswap! seen conj e) - (case (::type nd) - (::literal ::var ::lookup ::node) ts - (::ap ::comp) (reduce mark-used-ctors ts (get-children-e ts e)) - (::site ::join ::pure ::call) (recur ts (get-child-e ts e)) - (::ctor) (if (::ctor-idx nd) - ts - (recur (ts/asc ts e ::ctor-idx (->ctor-idx)) (get-child-e ts e))) - (::let) (recur ts (->let-body-e ts e)) - (::let-ref) (recur ts (get-ret-e ts (->let-val-e ts (::ref nd)))) - #_else (throw (ex-info (str "cannot mark-used-ctors on " (pr-str (::type nd))) (or nd {}))))))) - ts (-> ts collapse-ap-with-only-pures - (compute-effect-order 0) - (mark-used-ctors 0)) - ctors-e (get-ordered-ctors-e ts) - ensure-node (fn ensure-node [ts ref-e] - (let [ctor-e (find-ctor-e ts ref-e)] - (cond-> ts (empty? (ts/find ts ::ctor-ref ref-e)) - (ts/add {:db/id (->id) ::ctor-node ctor-e, ::ctor-ref ref-e})))) - ensure-free-node (fn ensure-free-node [ts ref-e ctor-e] - (cond-> ts (empty? (ts/find ts ::ctor-free ctor-e, ::closed-ref ref-e)) - (ts/add {:db/id (->id) ::ctor-free ctor-e, ::closed-ref ref-e, ::closed-over ::node}))) - ensure-free-free (fn ensure-free-free [ts ref-e ctor-e] - (cond-> ts (empty? (ts/find ts ::ctor-free ctor-e, ::closed-ref ref-e)) - (ts/add {:db/id (->id) ::ctor-free ctor-e, ::closed-ref ref-e, ::closed-over ::free}))) - ensure-free-frees (fn ensure-free-frees [ts ref-e ctors-e] - (reduce (fn [ts ctor-e] (ensure-free-free ts ref-e ctor-e)) ts ctors-e)) - order-nodes (fn order-nodes [ts] - (reduce (fn [ts nodes-e] - (let [->idx (->->id)] - (reduce (fn [ts e] (ts/asc ts e ::node-idx (->idx))) - ts (sort-by #(->> % (ts/->node ts) ::ctor-ref (ts/->node ts) ::fx-order) - nodes-e)))) - ts (-> ts :ave ::ctor-node vals))) - order-frees (fn order-frees [ts] - (reduce (fn [ts frees-e] - (let [->idx (->->id)] - (reduce (fn [ts e] (ts/asc ts e ::free-idx (->idx))) - ts (sort-by #(::fx-order (ts/->node ts %)) frees-e) #_(sort-by-fx-order ts frees-e)))) - ts (-> ts :ave ::ctor-free vals))) - in-a-call? (fn in-a-call? [ts e] - (loop [e (::parent (ts/->node ts e))] - (when-let [nd (ts/->node ts e)] - (case (::type nd) - ::call true - ::ctor false - #_else (recur (::parent nd)))))) - handle-let-refs (fn handle-let-refs [ts e] ; nodes and frees (closed over) - (let [nd (ts/->node ts e)] + (let [change-parent (fn change-parent [ts e pe] (ts/asc ts e ::parent pe)) + orphan (fn orphan [ts e] (change-parent ts e nil)) + collapse-ap-with-only-pures (fn collapse-ap-with-only-pures [ts] ; (r/ap (r/pure .)+ ) => (r/pure (::comp . . .)) + (reduce (fn [ts ap-e] + (let [[f-e & args-e :as children-e] (get-children-e ts ap-e)] + (if (every? #(= ::pure (::type (ts/->node ts %))) children-e) + (reduce (fn [ts e] + (-> ts (change-parent (get-child-e ts e) f-e) + (orphan e))) + ;; reuse nodes, otherwise node ordering messes up + (-> ts (ts/asc ap-e ::type ::pure) (ts/asc f-e ::type ::comp)) + args-e) + ts))) + ts (reverse (ts/find ts ::type ::ap)))) + ->ctor-idx (->->id) + seen (volatile! #{}) + mark-used-ctors (fn mark-used-ctors [ts e] + (if (@seen e) + ts + (let [nd (get (:eav ts) e)] + (vswap! seen conj e) (case (::type nd) (::literal ::var ::lookup ::node) ts - (::ap ::comp) (reduce handle-let-refs ts (get-children-e ts e)) - (::site ::join ::pure ::ctor ::call) (recur ts (get-child-e ts e)) + (::ap ::comp) (reduce mark-used-ctors ts (get-children-e ts e)) + (::site ::join ::pure ::call) (recur ts (get-child-e ts e)) + (::ctor) (if (::ctor-idx nd) + ts + (recur (ts/asc ts e ::ctor-idx (->ctor-idx)) (get-child-e ts e))) (::let) (recur ts (->let-body-e ts e)) - (::let-ref) - (let [ref-nd (ts/->node ts (::ref nd)) - ctors-e (loop [ac '(), e (::parent (ts/->node ts e))] - (if (= (::ref nd) e) - ac - (recur (cond-> ac (= ::ctor (::type (ts/->node ts e))) (conj e)) - (::parent (ts/->node ts e))))) - ts (ts/asc ts (::ref nd) ::walked-val true) ; only walk binding once - ;; TODO is this necessary? If not we could inline more - ts (cond-> ts (in-a-call? ts e) - (-> (ts/upd (::ref nd) ::in-call #(conj (or % #{}) e)) - (ensure-node (::ref nd)))) - ts (if (seq ctors-e) ; closed over - (-> ts (ensure-node (::ref nd)) - (ensure-free-node (::ref nd) (first ctors-e)) - (ensure-free-frees (::ref nd) (rest ctors-e))) - (cond-> (ts/upd ts (::ref nd) ::refcnt (fnil inc 0)) - (or (= 1 (::refcnt ref-nd)) - (not= (get-site ts (find-sitable-parent ts e)) - (get-site ts (->let-val-e ts (::ref nd))))) - (ensure-node (::ref nd))))] - (cond-> ts - (not (::walked-val ref-nd)) (recur (get-ret-e ts (->let-val-e ts (::ref nd)))))) - #_else (throw (ex-info (str "cannot handle-let-refs on " (::type nd)) (or nd {})))))) - ->call-idx (let [mp (zipmap ctors-e (repeatedly ->->id))] - (fn ->call-idx [ctor-e] ((get mp ctor-e)))) - seen (volatile! #{}) - mark-used-calls (fn mark-used-calls [ts ctor-e e] - (if (@seen e) - ts - (let [nd (ts/->node ts e)] - (vswap! seen conj e) - (case (::type nd) - (::literal ::var ::lookup ::node) ts - (::ap ::comp) (reduce #(mark-used-calls % ctor-e %2) ts (get-children-e ts e)) - (::site ::join ::pure) (recur ts ctor-e (get-child-e ts e)) - (::ctor) (recur ts e (get-child-e ts e)) - (::call) (if (::call-idx nd) - ts - (-> (mark-used-calls ts ctor-e (get-child-e ts e)) - (ts/asc e ::call-idx (->call-idx ctor-e)) - (ts/asc e ::ctor-call ctor-e))) - (::let) (recur ts ctor-e (->let-body-e ts e)) - (::let-ref) (let [nx-e (get-ret-e ts (->let-val-e ts (::ref nd)))] - (recur ts (find-ctor-e ts nx-e) nx-e)) - #_else (throw (ex-info (str "cannot mark-used-calls on " (::type nd)) (or nd {}))))))) - ts (-> ts (handle-let-refs 0) order-nodes order-frees - (mark-used-calls 0 (get-ret-e ts (get-child-e ts 0))))] - (when (::print-db env) (run! prn (->> ts :eav vals (sort-by :db/id)))) - ts))) + (::let-ref) (recur ts (get-ret-e ts (->let-val-e ts (::ref nd)))) + #_else (throw (ex-info (str "cannot mark-used-ctors on " (pr-str (::type nd))) (or nd {}))))))) + ts (-> ts collapse-ap-with-only-pures + (compute-effect-order 0) + (mark-used-ctors 0)) + ctors-e (get-ordered-ctors-e ts) + ensure-node (fn ensure-node [ts ref-e] + (let [ctor-e (find-ctor-e ts ref-e)] + (cond-> ts (empty? (ts/find ts ::ctor-ref ref-e)) + (ts/add {:db/id (->id) ::ctor-node ctor-e, ::ctor-ref ref-e})))) + ensure-free-node (fn ensure-free-node [ts ref-e ctor-e] + (cond-> ts (empty? (ts/find ts ::ctor-free ctor-e, ::closed-ref ref-e)) + (ts/add {:db/id (->id) ::ctor-free ctor-e, ::closed-ref ref-e, ::closed-over ::node}))) + ensure-free-free (fn ensure-free-free [ts ref-e ctor-e] + (cond-> ts (empty? (ts/find ts ::ctor-free ctor-e, ::closed-ref ref-e)) + (ts/add {:db/id (->id) ::ctor-free ctor-e, ::closed-ref ref-e, ::closed-over ::free}))) + ensure-free-frees (fn ensure-free-frees [ts ref-e ctors-e] + (reduce (fn [ts ctor-e] (ensure-free-free ts ref-e ctor-e)) ts ctors-e)) + order-nodes (fn order-nodes [ts] + (reduce (fn [ts nodes-e] + (let [->idx (->->id)] + (reduce (fn [ts e] (ts/asc ts e ::node-idx (->idx))) + ts (sort-by #(->> % (ts/->node ts) ::ctor-ref (ts/->node ts) ::fx-order) + nodes-e)))) + ts (-> ts :ave ::ctor-node vals))) + order-frees (fn order-frees [ts] + (reduce (fn [ts frees-e] + (let [->idx (->->id)] + (reduce (fn [ts e] (ts/asc ts e ::free-idx (->idx))) + ts (sort-by #(::fx-order (ts/->node ts %)) frees-e) #_(sort-by-fx-order ts frees-e)))) + ts (-> ts :ave ::ctor-free vals))) + in-a-call? (fn in-a-call? [ts e] + (loop [e (::parent (ts/->node ts e))] + (when-let [nd (ts/->node ts e)] + (case (::type nd) + ::call true + ::ctor false + #_else (recur (::parent nd)))))) + handle-let-refs (fn handle-let-refs [ts e] ; nodes and frees (closed over) + (let [nd (ts/->node ts e)] + (case (::type nd) + (::literal ::var ::lookup ::node) ts + (::ap ::comp) (reduce handle-let-refs ts (get-children-e ts e)) + (::site ::join ::pure ::ctor ::call) (recur ts (get-child-e ts e)) + (::let) (recur ts (->let-body-e ts e)) + (::let-ref) + (let [ref-nd (ts/->node ts (::ref nd)) + ctors-e (loop [ac '(), e (::parent (ts/->node ts e))] + (if (= (::ref nd) e) + ac + (recur (cond-> ac (= ::ctor (::type (ts/->node ts e))) (conj e)) + (::parent (ts/->node ts e))))) + ts (ts/asc ts (::ref nd) ::walked-val true) ; only walk binding once + ;; TODO is this necessary? If not we could inline more + ts (cond-> ts (in-a-call? ts e) + (-> (ts/upd (::ref nd) ::in-call #(conj (or % #{}) e)) + (ensure-node (::ref nd)))) + ts (if (seq ctors-e) ; closed over + (-> ts (ensure-node (::ref nd)) + (ensure-free-node (::ref nd) (first ctors-e)) + (ensure-free-frees (::ref nd) (rest ctors-e))) + (cond-> (ts/upd ts (::ref nd) ::refcnt (fnil inc 0)) + (or (= 1 (::refcnt ref-nd)) + (not= (get-site ts (find-sitable-parent ts e)) + (get-site ts (->let-val-e ts (::ref nd))))) + (ensure-node (::ref nd))))] + (cond-> ts + (not (::walked-val ref-nd)) (recur (get-ret-e ts (->let-val-e ts (::ref nd)))))) + #_else (throw (ex-info (str "cannot handle-let-refs on " (::type nd)) (or nd {})))))) + ->call-idx (let [mp (zipmap ctors-e (repeatedly ->->id))] + (fn ->call-idx [ctor-e] ((get mp ctor-e)))) + seen (volatile! #{}) + mark-used-calls (fn mark-used-calls [ts ctor-e e] + (if (@seen e) + ts + (let [nd (ts/->node ts e)] + (vswap! seen conj e) + (case (::type nd) + (::literal ::var ::lookup ::node) ts + (::ap ::comp) (reduce #(mark-used-calls % ctor-e %2) ts (get-children-e ts e)) + (::site ::join ::pure) (recur ts ctor-e (get-child-e ts e)) + (::ctor) (recur ts e (get-child-e ts e)) + (::call) (if (::call-idx nd) + ts + (-> (mark-used-calls ts ctor-e (get-child-e ts e)) + (ts/asc e ::call-idx (->call-idx ctor-e)) + (ts/asc e ::ctor-call ctor-e))) + (::let) (recur ts ctor-e (->let-body-e ts e)) + (::let-ref) (let [nx-e (get-ret-e ts (->let-val-e ts (::ref nd)))] + (recur ts (find-ctor-e ts nx-e) nx-e)) + #_else (throw (ex-info (str "cannot mark-used-calls on " (::type nd)) (or nd {}))))))) + ts (-> ts (handle-let-refs 0) order-nodes order-frees + (mark-used-calls 0 (get-ret-e ts (get-child-e ts 0))))] + (when (::print-db env) (run! prn (->> ts :eav vals (sort-by :db/id)))) + ts)) (defn compile* [nm env ts] - (ensure-cljs-compiler - (let [ts (analyze-electric env ts) - ret (->> (get-ordered-ctors-e ts) (mapv #(emit-ctor ts % env nm)))] - (when (::print-source env) (fipp.edn/pprint ret)) - ret))) + (let [ts (analyze-electric env ts) + ret (->> (get-ordered-ctors-e ts) (mapv #(emit-ctor ts % env nm)))] + (when (::print-source env) (fipp.edn/pprint ret)) + ret)) (defn compile [nm form env] - (ensure-cljs-compiler - (compile* nm env - (analyze (expand-all env `(::ctor ~form)) - '_ (ensure-cljs-env env) (ts/->ts {::->id (->->id)}))))) + (compile* nm env + (analyze (expand-all env `(::ctor ~form)) + '_ env (ts/->ts {::->id (->->id)})))) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 72b6c4fff..5824e9fef 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -283,3 +283,10 @@ Returns a peer definition from given definitions and main key. (with-meta (symbol (str "%" i)) {::type ::node}))) (range)))) + +(defn get-destructure-map [gmap] + (if (seq? gmap) + (if (next gmap) + (apply array-map gmap) + (if (seq gmap) (first gmap) {})) + gmap)) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index fd24e46e0..3844c8c2a 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -43,22 +43,21 @@ Returns the successive states of items described by `incseq`. (cc/defn ns-qualify [sym] (if (namespace sym) sym (symbol (str *ns*) (str sym)))) -(tests - (ns-qualify 'foo) := `foo - (ns-qualify 'a/b) := 'a/b) +#?(:clj (tests + (ns-qualify 'foo) := `foo + (ns-qualify 'a/b) := 'a/b)) (defmacro defn [nm bs & body] - (lang/ensure-cljs-compiler - (let [env (merge (meta nm) (lang/ensure-cljs-env (lang/normalize-env &env)) l/web-config) - expanded (lang/expand-all env `(fn ~bs ~@body)) - _ (when (::lang/print-expansion env) (fipp.edn/pprint expanded)) - ts (lang/analyze expanded '_ env (ts/->ts {::lang/->id (lang/->->id)})) - ts (lang/analyze-electric env ts) - ctors (mapv #(lang/emit-ctor ts % env (-> nm ns-qualify keyword)) (lang/get-ordered-ctors-e ts)) - deps (lang/emit-deps ts 0) - nm (with-meta nm `{::lang/deps '~deps})] - (when (::lang/print-source env) (fipp.edn/pprint ctors)) - `(def ~nm ~ctors)))) + (let [env (merge (meta nm) (lang/normalize-env &env) l/web-config) + expanded (lang/expand-all env `(fn ~bs ~@body)) + _ (when (::lang/print-expansion env) (fipp.edn/pprint expanded)) + ts (lang/analyze expanded '_ env (ts/->ts {::lang/->id (lang/->->id)})) + ts (lang/analyze-electric env ts) + ctors (mapv #(lang/emit-ctor ts % env (-> nm ns-qualify keyword)) (lang/get-ordered-ctors-e ts)) + deps (lang/emit-deps ts 0) + nm (with-meta nm `{::lang/deps '~deps})] + (when (::lang/print-source env) (fipp.edn/pprint ctors)) + `(def ~nm ~ctors))) #_(defmacro defn [nm bs & body] ;; TODO cleanup env setup diff --git a/src/hyperfiddle/electric_local_def_de.cljc b/src/hyperfiddle/electric_local_def_de.cljc index 5326b269e..bab4f656b 100644 --- a/src/hyperfiddle/electric_local_def_de.cljc +++ b/src/hyperfiddle/electric_local_def_de.cljc @@ -26,31 +26,31 @@ ([nm form] `(test-compile ~nm {} ~form)) ([nm env form] `(lang/compile ~nm '~form (merge web-config (lang/normalize-env ~env)))))) -(defn collect-deps [deps] - (loop [ret (sorted-set) deps deps] - (if-some [d (first deps)] - (if (ret d) - (recur ret (disj deps d)) - (let [dds (lang/get-deps d)] - (recur (conj ret d) (into deps dds)))) - ret))) +#?(:clj + (defn collect-deps [deps] + (loop [ret (sorted-set) deps deps] + (if-some [d (first deps)] + (if (ret d) + (recur ret (disj deps d)) + (let [dds (lang/get-deps d)] + (recur (conj ret d) (into deps dds)))) + ret)))) (defn run-single [frame] (m/reduce #(do %2) nil frame)) #?(:clj (defmacro single {:style/indent 1} [conf & body] (ca/check map? conf) - (lang/ensure-cljs-compiler - (let [env (merge (->local-config &env) (lang/normalize-env &env) conf) - expanded (lang/expand-all env `(::lang/ctor (do ~@body))) - _ (when (::lang/print-expansion env) (fipp.edn/pprint expanded)) - ts (lang/analyze expanded '_ env (ts/->ts {::lang/->id (lang/->->id)})) - _ (when (::lang/print-analysis env) (run! prn (->> ts :eav vals (sort-by :db/id)))) - ts (lang/analyze-electric env ts) - ctors (mapv #(lang/emit-ctor ts % env ::Main) (lang/get-ordered-ctors-e ts)) - ret-e (lang/get-ret-e ts (lang/get-child-e ts 0)) - deps (lang/emit-deps ts ret-e) - deps (collect-deps deps) - defs (into {} (map (fn [dep] [(keyword dep) dep])) deps) - defs (assoc defs ::Main ctors)] - (when (::lang/print-source env) (fipp.edn/pprint ctors)) - (when (::lang/print-defs env) (fipp.edn/pprint defs)) - `(run-single (r/root-frame ~defs ::Main)))))) + (let [env (merge (->local-config &env) (lang/normalize-env &env) conf) + expanded (lang/expand-all env `(::lang/ctor (do ~@body))) + _ (when (::lang/print-expansion env) (fipp.edn/pprint expanded)) + ts (lang/analyze expanded '_ env (ts/->ts {::lang/->id (lang/->->id)})) + _ (when (::lang/print-analysis env) (run! prn (->> ts :eav vals (sort-by :db/id)))) + ts (lang/analyze-electric env ts) + ctors (mapv #(lang/emit-ctor ts % env ::Main) (lang/get-ordered-ctors-e ts)) + ret-e (lang/get-ret-e ts (lang/get-child-e ts 0)) + deps (lang/emit-deps ts ret-e) + deps (collect-deps deps) + defs (into {} (map (fn [dep] [(keyword dep) dep])) deps) + defs (assoc defs ::Main ctors)] + (when (::lang/print-source env) (fipp.edn/pprint ctors)) + (when (::lang/print-defs env) (fipp.edn/pprint defs)) + `(run-single (r/root-frame ~defs ::Main))))) diff --git a/test/hyperfiddle/electric/impl/cljs_analyzer2_test.clj b/test/hyperfiddle/electric/impl/cljs_analyzer2_test.clj new file mode 100644 index 000000000..c12654f36 --- /dev/null +++ b/test/hyperfiddle/electric/impl/cljs_analyzer2_test.clj @@ -0,0 +1,107 @@ +(ns hyperfiddle.electric.impl.cljs-analyzer2-test + (:require [clojure.test :as t] + [cljs.env] + [cljs.analyzer] + [missionary.core :as m] + [hyperfiddle.electric.impl.cljs-analyzer2 :as ana])) + +(comment + (def !a (atom {})) + (m/? (ana/analyze-nsT !a {} 'cljs.core)) + (-> @!a ::ana/nses (get 'cljs.core) ::ana/defs count) + ) + +(t/deftest ns-expansion + (let [ns$ 'hyperfiddle.electric.impl.cljs-file-to-analyze + !a (ana/->!a) + _ (m/? (ana/analyze-nsT !a {} ns$)) + a @!a] + (t/is (= 1 1)) + (t/is (nil? (ana/find-var a 'non ns$))) + (t/is (nil? (ana/find-var a 'first ns$))) + (t/is (= 'cljs.core/next (::ana/name (ana/find-var a 'nxt ns$)))) + (t/are [x] (some? (ana/find-var a x ns$)) + 'foo + 'bar + 'baz + 'an-fn + 'behind-require + 'str + 'behind-alias + 'behind-require-macros + 'behind-require-macro-alias + 'behind-required-refer + 'behind-required-rename + 'behind-require-macro-refer + 'behind-require-macro-rename + 'behind-include-macros + 'behind-refer-macros + 'behind-use + 'behind-use-renamed + 'behind-use-macro + 'behind-use-macro-renamed + 'behind-auto-alias + 'behind-auto-alias-alias + 'behind-auto-alias-refer + 'nxt))) + +(t/deftest runtime-vars + (let [ns$ 'hyperfiddle.electric.impl.cljs-file-to-analyze, + !a (ana/->!a) + _ (m/? (ana/analyze-nsT !a {} ns$)) + a @!a] + (t/are [x] (nil? (ana/find-var a x ns$)) + 'hyperfiddle.electric.impl.cljs-file-to-analyze.runtime/only-macro + 'run/only-macro + 'only-macro + 'next) ; renamed in :refer-clojure + (t/are [x] (some? (ana/find-var a x ns$)) + 'hyperfiddle.electric.impl.cljs-file-to-analyze.runtime/macro-and-runtime + 'run/macro-and-runtime + 'macro-and-runtime + 'hyperfiddle.electric.impl.cljs-file-to-analyze.runtime/only-runtime + 'run/only-runtime + 'only-runtime))) + +(t/deftest local-shadowing + (let [ns$ 'hyperfiddle.electric.impl.cljs-file-to-analyze + !a (ana/->!a) + _ (m/? (ana/analyze-nsT !a {} ns$)) + a @!a] + (t/are [x] (nil? (ana/find-var a x ns$)) + 'shadowed-by-let + 'shadowed-by-let-destructure + 'shadowed-by-fn + 'shadowed-by-fn-destructure + 'shadowed-by-letfn-fn-name + 'shadowed-by-letfn-other-fn-name + 'shadowed-by-letfn-local))) + +(t/deftest defs-match-official-cljs-analyzer + (let [ns$ 'cljs.analyzer + !a (ana/->!a) + _ (m/? (ana/analyze-nsT !a {} ns$)) + a @!a + c (cljs.env/ensure + (cljs.analyzer/analyze-file "cljs/core.cljs") + (cljs.analyzer/analyze-file "cljs/analyzer.cljc") + @cljs.env/*compiler*)] + (t/are [ns$] (= (into #{} (keep (fn [[k v]] (when-not (:anonymous v) k))) + (-> c :cljs.analyzer/namespaces (get ns$) :defs)) + (set (-> a ::ana/nses (get ns$) ::ana/defs keys))) + 'cljs.core + 'cljs.analyzer))) + +(t/deftest clojure-core-var-found-as-cljs-core-var + (let [ns$ 'cljs.analyzer + !a (ana/->!a) + _ (m/? (ana/analyze-nsT !a {} ns$)) + a @!a] + (t/is (some? (ana/find-var a 'clojure.core/vector ns$))))) + +(t/deftest non-required-var-can-be-found ; e.g. a macro from another ns might have expanded to it + (let [ns$ 'cljs.source-map + !a (ana/->!a) + _ (m/? (ana/analyze-nsT !a {} ns$)) + a @!a] + (t/is (some? (ana/find-var a 'cljs.source-map/encode 'cljs.core))))) diff --git a/test/hyperfiddle/electric/impl/cljs_analyzer_test.clj b/test/hyperfiddle/electric/impl/cljs_analyzer_test.clj index 545952b72..eb544b22a 100644 --- a/test/hyperfiddle/electric/impl/cljs_analyzer_test.clj +++ b/test/hyperfiddle/electric/impl/cljs_analyzer_test.clj @@ -4,85 +4,85 @@ [cljs.analyzer] [hyperfiddle.electric.impl.cljs-analyzer :as ana])) -(comment - (def a (ana/analyze-ns 'hyperfiddle.electric.impl.cljs-file-to-analyze)) - (-> a ::ana/nses (get 'hyperfiddle.electric.impl.cljs-file-to-analyze) ::ana/refers) - (ana/find-var a 'next 'hyperfiddle.electric.impl.cljs-file-to-analyze) - (ana/expand (ana/->a) 'cljs.core #{} '(defmacro macrodef [sym] `(def ~sym))) - (-> (ana/collect-defs (ana/->a) 'foo '(defmacro macrodef [sym] `(def ~sym))) - ::ana/nses (get 'foo)) - (-> (ana/collect-defs (ana/->a) 'foo '(fn [] (def x 1))) - ::ana/nses (get 'foo)) - ) +;; (comment +;; (def a (ana/analyze-ns 'hyperfiddle.electric.impl.cljs-file-to-analyze)) +;; (-> a ::ana/nses (get 'hyperfiddle.electric.impl.cljs-file-to-analyze) ::ana/refers) +;; (ana/find-var a 'next 'hyperfiddle.electric.impl.cljs-file-to-analyze) +;; (ana/expand (ana/->a) 'cljs.core #{} '(defmacro macrodef [sym] `(def ~sym))) +;; (-> (ana/collect-defs (ana/->a) 'foo '(defmacro macrodef [sym] `(def ~sym))) +;; ::ana/nses (get 'foo)) +;; (-> (ana/collect-defs (ana/->a) 'foo '(fn [] (def x 1))) +;; ::ana/nses (get 'foo)) +;; ) -(t/deftest ns-expansion - (let [ns$ 'hyperfiddle.electric.impl.cljs-file-to-analyze - a (ana/analyze-ns ns$)] - (t/is (nil? (ana/find-var a 'non ns$))) - (t/is (nil? (ana/find-var a 'first ns$))) - (t/is (= 'cljs.core/next (::ana/name (ana/find-var a 'nxt ns$)))) - (t/are [x] (some? (ana/find-var a x ns$)) - 'foo - 'bar - 'baz - 'an-fn - 'behind-require - 'str - 'behind-alias - 'behind-require-macros - 'behind-require-macro-alias - 'behind-required-refer - 'behind-required-rename - 'behind-require-macro-refer - 'behind-require-macro-rename - 'behind-include-macros - 'behind-refer-macros - 'behind-use - 'behind-use-renamed - 'behind-use-macro - 'behind-use-macro-renamed - 'behind-auto-alias - 'behind-auto-alias-alias - 'behind-auto-alias-refer - 'nxt))) +;; (t/deftest ns-expansion +;; (let [ns$ 'hyperfiddle.electric.impl.cljs-file-to-analyze +;; a (ana/analyze-ns ns$)] +;; (t/is (nil? (ana/find-var a 'non ns$))) +;; (t/is (nil? (ana/find-var a 'first ns$))) +;; (t/is (= 'cljs.core/next (::ana/name (ana/find-var a 'nxt ns$)))) +;; (t/are [x] (some? (ana/find-var a x ns$)) +;; 'foo +;; 'bar +;; 'baz +;; 'an-fn +;; 'behind-require +;; 'str +;; 'behind-alias +;; 'behind-require-macros +;; 'behind-require-macro-alias +;; 'behind-required-refer +;; 'behind-required-rename +;; 'behind-require-macro-refer +;; 'behind-require-macro-rename +;; 'behind-include-macros +;; 'behind-refer-macros +;; 'behind-use +;; 'behind-use-renamed +;; 'behind-use-macro +;; 'behind-use-macro-renamed +;; 'behind-auto-alias +;; 'behind-auto-alias-alias +;; 'behind-auto-alias-refer +;; 'nxt))) -(t/deftest runtime-vars - (let [ns$ 'hyperfiddle.electric.impl.cljs-file-to-analyze, - a (ana/analyze-ns ns$)] - (t/are [x] (nil? (ana/find-var a x ns$)) - 'hyperfiddle.electric.impl.cljs-file-to-analyze.runtime/only-macro - 'run/only-macro - 'only-macro - 'next) ; renamed in :refer-clojure - (t/are [x] (some? (ana/find-var a x ns$)) - 'hyperfiddle.electric.impl.cljs-file-to-analyze.runtime/macro-and-runtime - 'run/macro-and-runtime - 'macro-and-runtime - 'hyperfiddle.electric.impl.cljs-file-to-analyze.runtime/only-runtime - 'run/only-runtime - 'only-runtime))) +;; (t/deftest runtime-vars +;; (let [ns$ 'hyperfiddle.electric.impl.cljs-file-to-analyze, +;; a (ana/analyze-ns ns$)] +;; (t/are [x] (nil? (ana/find-var a x ns$)) +;; 'hyperfiddle.electric.impl.cljs-file-to-analyze.runtime/only-macro +;; 'run/only-macro +;; 'only-macro +;; 'next) ; renamed in :refer-clojure +;; (t/are [x] (some? (ana/find-var a x ns$)) +;; 'hyperfiddle.electric.impl.cljs-file-to-analyze.runtime/macro-and-runtime +;; 'run/macro-and-runtime +;; 'macro-and-runtime +;; 'hyperfiddle.electric.impl.cljs-file-to-analyze.runtime/only-runtime +;; 'run/only-runtime +;; 'only-runtime))) -(t/deftest local-shadowing - (let [ns$ 'hyperfiddle.electric.impl.cljs-file-to-analyze - a (ana/analyze-ns ns$)] - (t/are [x] (nil? (ana/find-var a x ns$)) - 'shadowed-by-let - 'shadowed-by-let-destructure - 'shadowed-by-fn - 'shadowed-by-fn-destructure - 'shadowed-by-letfn-fn-name - 'shadowed-by-letfn-other-fn-name - 'shadowed-by-letfn-local))) +;; (t/deftest local-shadowing +;; (let [ns$ 'hyperfiddle.electric.impl.cljs-file-to-analyze +;; a (ana/analyze-ns ns$)] +;; (t/are [x] (nil? (ana/find-var a x ns$)) +;; 'shadowed-by-let +;; 'shadowed-by-let-destructure +;; 'shadowed-by-fn +;; 'shadowed-by-fn-destructure +;; 'shadowed-by-letfn-fn-name +;; 'shadowed-by-letfn-other-fn-name +;; 'shadowed-by-letfn-local))) -(t/deftest defs-match-official-cljs-analyzer - (let [ns$ 'cljs.analyzer - a (ana/analyze-ns ns$) - c (cljs.env/ensure - (cljs.analyzer/analyze-file "cljs/core.cljs") - (cljs.analyzer/analyze-file "cljs/analyzer.cljc") - @cljs.env/*compiler*)] - (t/are [ns$] (= (into #{} (keep (fn [[k v]] (when-not (:anonymous v) k))) - (-> c :cljs.analyzer/namespaces (get ns$) :defs)) - (set (-> a ::ana/nses (get ns$) ::ana/defs keys))) - 'cljs.core - 'cljs.analyzer))) +;; (t/deftest defs-match-official-cljs-analyzer +;; (let [ns$ 'cljs.analyzer +;; a (ana/analyze-ns ns$) +;; c (cljs.env/ensure +;; (cljs.analyzer/analyze-file "cljs/core.cljs") +;; (cljs.analyzer/analyze-file "cljs/analyzer.cljc") +;; @cljs.env/*compiler*)] +;; (t/are [ns$] (= (into #{} (keep (fn [[k v]] (when-not (:anonymous v) k))) +;; (-> c :cljs.analyzer/namespaces (get ns$) :defs)) +;; (set (-> a ::ana/nses (get ns$) ::ana/defs keys))) +;; 'cljs.core +;; 'cljs.analyzer))) diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index b5018ad58..22177b1bf 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -35,9 +35,9 @@ match#)) ;; no `:=`, these just need to compile -(tests (l/test-compile ::Main (lang/->cljs-env) referred-fn)) -(tests (l/test-compile ::Main (lang/->cljs-env) ref/referred-fn)) -(tests (l/test-compile ::Main (lang/->cljs-env) hyperfiddle.electric.impl.expand-require-referred/referred-fn)) +(l/test-compile ::Main (lang/->cljs-env) referred-fn) +(l/test-compile ::Main (lang/->cljs-env) ref/referred-fn) +(l/test-compile ::Main (lang/->cljs-env) hyperfiddle.electric.impl.expand-require-referred/referred-fn) (tests "test-simplest" (match (l/test-compile ::Main 1) @@ -665,3 +665,5 @@ (r/pure frame)))] ) + +(prn :ok) diff --git a/test/hyperfiddle/electric/impl/expand_de_test.cljc b/test/hyperfiddle/electric/impl/expand_de_test.cljc index c77c61de7..2c26054da 100644 --- a/test/hyperfiddle/electric/impl/expand_de_test.cljc +++ b/test/hyperfiddle/electric/impl/expand_de_test.cljc @@ -44,8 +44,6 @@ "implicit `do`s expand. Electric is pure" (all '(let [] 1 2)) := (all '(let [] (do 1 2))) (all '(loop [] 1 2)) := (all '(loop [] (do 1 2))) - (all '(fn [] 1 2)) := (all '(fn [] (do 1 2))) - (all '(letfn [] 1 2)) := (all '(letfn [] (do 1 2))) (all '(binding [] 1 2)) := (all '(binding [] (do 1 2))) @@ -67,27 +65,26 @@ (all '(fn foo [x] 1)) := '(fn* foo ([x] 1)) (all '(fn foo ([x] 1))) := '(fn* foo ([x] 1)) (all '(fn [with-open] (with-open 1))) := '(fn* ([with-open] (with-open 1))) - (all '(fn [x] (-> x inc))) := '(fn* ([x] (inc x))) + (all '(fn [x] (-> x inc))) := '(fn* ([x] (-> x inc))) (all '(fn* [x] x)) := '(fn* ([x] x)) ; fn* can come from elsewhere with a non-wrapped single arity (has-line-meta? (all '(fn* [x] x))) := true - (let [x (all '(letfn [(foo [with-open] (with-open 1)) ; don't expand with-open - (bar [x] (-> x inc)) ; expand -> - (baz [x] (->> x)) ; don't expand ->>, it is shadowed in letfn scope + (let [x (all '(letfn [(foo [with-open] (with-open 1)) + (bar [x] (-> x inc)) + (baz [x] (->> x)) (->> [x] x)] (-> (->> x) inc)))] x := '(let* [[foo bar baz ->>] (::l/letfn [foo (fn* foo ([with-open] (with-open 1))) - bar (fn* bar ([x] (inc x))) + bar (fn* bar ([x] (-> x inc))) baz (fn* baz ([x] (->> x))) ->> (fn* ->> ([x] x))])] (inc (->> x))) (has-line-meta? x) := true) - (let [[f v :as x] (all '(set! (.-x (-> [(java.awt.Point. (-> 0 inc) 2)] first)) (-> 2 inc))) - fnbody (-> f second second butlast)] ; to extract (fn* ([gensym] -this-> (set! .. gensym))) - fnbody := '(set! (. (first [(new java.awt.Point (inc 0) 2)]) -x)) + (let [[f v :as x] (all '(set! (.-x (-> [(java.awt.Point. (-> 0 inc) 2)] first)) (-> 2 inc)))] + (first f) := 'fn* v := '(inc 2) (has-line-meta? x) := true) @@ -111,11 +108,7 @@ ;; (all '(catch (-> 1 inc))) := '(catch (inc 1)) (let [x (all '(loop [with-open inc, x 2] (-> x with-open)))] - x := `(~'binding [r/rec - (::l/closure - (let* [~'with-open r/%0, ~'x r/%1] - (~'with-open ~'x)))] - (new r/rec ~'inc 2)) + (first x) := 'binding (has-line-meta? x) := true) (let [x (all '(binding [x (-> 1 inc)] (-> x inc)))] @@ -130,20 +123,10 @@ (all '(hyperfiddle.impl.expand-test/X.)) := '(new hyperfiddle.impl.expand-test/X) - (l/-expand-all '(#{:ok} 1) {:js-globals {}}) - - "cljs var lookup doesn't produce undeclared-ns warnings" - (let [!warns (atom [])] - (cljs.env/ensure - (cljs.analyzer/with-warning-handlers [(fn [typ env extra] - (when (typ cljs.analyzer/*cljs-warnings*) - (swap! !warns conj [typ env extra])))] - (binding [*err* *out*] - (with-out-str (l/-expand-all '(r/reflect 1) {::l/peers {:client :cljs, :server :clj} ::l/current :client}))))) - @!warns := []) + (l/-expand-all '(#{:ok} 1) {:js-globals {}}) := '(#{:ok} 1) "expansion is peer-aware" - (l/expand-all {::l/peers {:client :cljs, :server :clj}, ::l/current :server} + (l/expand-all {::l/peers {:client :cljs, :server :clj}, ::l/current :server, :ns {:name (ns-name *ns*)}} `[(test-peer-expansion) (::l/site :client (test-peer-expansion))]) := `[:clj (::l/site :client :cljs)] diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index de951396c..6d0f145f0 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -4,7 +4,10 @@ [hyperfiddle.electric-local-def-de :as l] [hyperfiddle.electric.impl.io :as electric-io] [hyperfiddle.electric.impl.lang-de2 :as lang] + [contrib.cljs-target :refer [do-browser]] + [clojure.string :as str] [missionary.core :as m]) + #?(:cljs (:require-macros [hyperfiddle.electric-de-test :refer [skip tests]])) (:import [hyperfiddle.electric Pending Failure] [missionary Cancelled] #?(:clj [clojure.lang ExceptionInfo]))) @@ -28,7 +31,7 @@ ;; TODO `m/ap` has `try` in expansion (skip "new on missionary flow" - (with ((l/single {::lang/print-expansion true} (tap (e/input (m/ap 1)))) tap tap) + (with ((l/single {} (tap (e/input (m/ap 1)))) tap tap) % := 1)) (tests "join missionary flow" @@ -1034,7 +1037,7 @@ ;; HACK sequences cljs async tests. Symptomatic of an RCF issue. ;; Ticket: https://www.notion.so/hyperfiddle/cljs-test-suite-can-produce-false-failures-0b3799f6d2104d698eb6a956b6c51e48 -#?(:cljs (t/use-fixtures :each {:after #(t/async done (js/setTimeout done 1))})) +;; #?(:cljs (t/use-fixtures :each {:after #(t/async done (js/setTimeout done 1))})) ;; TODO transfer try/catch (skip @@ -1943,8 +1946,8 @@ (tests "#js" (def !x (atom 0)) (with ((l/single {} (let [x (e/watch !x)] - (tap #js {:x x}) - (tap #js [:x x]))) tap tap) + (tap #js {:x x}) + (tap #js [:x x]))) tap tap) (.-x %) := 0 (aget % 1) := 0 (swap! !x inc) @@ -1962,8 +1965,9 @@ ]))) tap tap) % := ["src" 1 1.0]))) +;; TODO type hint propagation #?(:cljs - (tests "js interop" + (skip "js interop" (with ((l/single {} (let [^js o #js {:a 1 :aPlus (fn [n] (inc n))}] (tap [(.aPlus o 1) ; instance method @@ -2068,5 +2072,5 @@ (let [{:keys [tested skipped]} @stats, all (+ tested skipped)] (prn '===) - (println 'tested tested (format "%.0f%%" (double (* (/ tested all) 100)))) - (println 'skipped skipped (format "%.0f%%" (double (* (/ skipped all) 100))))) + (println 'tested tested (str (* (/ tested all) 100) "%")) + (println 'skipped skipped (str (long (* (/ skipped all) 100)) "%"))) From 1b9fc4299fd515a2017112a5cc60b14711a49c5f Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 22 Feb 2024 15:57:46 +0100 Subject: [PATCH 108/428] compiler: cleanup --- .../electric/impl/cljs_analyzer.clj | 287 ++++++++--------- .../electric/impl/cljs_analyzer2.clj | 297 ------------------ src/hyperfiddle/electric/impl/lang_de2.clj | 143 +-------- .../electric/impl/cljs_analyzer2_test.clj | 107 ------- .../electric/impl/cljs_analyzer_test.clj | 173 +++++----- test/hyperfiddle/electric_de_test.cljc | 2 +- 6 files changed, 234 insertions(+), 775 deletions(-) delete mode 100644 src/hyperfiddle/electric/impl/cljs_analyzer2.clj delete mode 100644 test/hyperfiddle/electric/impl/cljs_analyzer2_test.clj diff --git a/src/hyperfiddle/electric/impl/cljs_analyzer.clj b/src/hyperfiddle/electric/impl/cljs_analyzer.clj index 0aed7834e..78fc4c6ff 100644 --- a/src/hyperfiddle/electric/impl/cljs_analyzer.clj +++ b/src/hyperfiddle/electric/impl/cljs_analyzer.clj @@ -10,19 +10,9 @@ [contrib.debug] [cljs.core] ; for cljs macroexpansion [cljs.env] + [cljs.analyzer] [cljs.repl])) ; for cljs macroexpansion -#_ -(defn get-expander-ns [env ^String nstr] - ;; first check for clojure.* -> cljs.* cases - (let [res (or (resolve-macro-ns-alias env nstr nil) - (resolve-ns-alias env nstr nil)) - nstr (if res (str res) nstr)] - (cond (= "clojure.core" nstr) (find-ns 'cljs.core) - (= "clojure.repl" nstr) (find-ns 'cljs.repl) - (.contains nstr ".") (find-ns (symbol nstr)) - :else (some-> env :ns :require-macros (get (symbol nstr)) find-ns)))) - (defn ns->basename [ns$] (-> ns$ name (.replace \- \_) (.replace \. \/))) (defn ns->resource [ns$] @@ -30,15 +20,10 @@ (or (io/resource (str base ".cljs")) (io/resource (str base ".cljc"))))) -(let [parse-opts (ed/normalize-opts {:all true - :row-key :line - :col-key :column - :end-location false - :readers cljs.tagged-literals/*cljs-data-readers* - :auto-resolve name - :features #{:cljs} - :read-cond :allow - :eof ::done})] +(let [parse-opts + (ed/normalize-opts {:all true, :row-key :line, :col-key :column, :end-location false + :readers cljs.tagged-literals/*cljs-data-readers* :auto-resolve name + :features #{:cljs}, :read-cond :allow, :eof ::done})] (defn resource-forms> [rs] (->> (m/ap (let [rdr (m/?> (m/observe (fn [!] @@ -47,10 +32,6 @@ (m/? (m/?> (m/seed (repeat (m/sp (ed/parse-next rdr parse-opts)))))))) (m/eduction (take-while (complement #{::done})))))) -(declare analyze-ns) -(defn -->a [] (analyze-ns {} 'cljs.core)) -(def ->a (memoize -->a)) - (defn safe-require [sym] ;; we might be expanding clj code before the ns got loaded (during cljs compilation) ;; to correctly lookup vars the ns needs to be loaded @@ -64,148 +45,138 @@ (defn mksym [& xs] (symbol (apply str (mapv #((if (or (keyword? %) (symbol? %)) name str) %) xs)))) -(defmacro my-deftype [nm & _] `(do (def ~nm) (def ~(mksym '-> nm)))) +(let [-base-cljs-env {:context :statement + :locals {} + :fn-scope [] + :js-globals (into {} + (map #(vector % {:op :js-var :name % :ns 'js}) + '(alert window document console escape unescape + screen location navigator history location + global process require module exports)))}] + (defn ->cljs-env + ([] (->cljs-env (ns-name *ns*))) + ([nssym] (cond-> -base-cljs-env nssym (assoc :ns {:name nssym}))))) (def special? '#{if def fn* do let* loop* letfn* throw try catch finally recur new set! ns deftype* defrecord* . js* & quote case* var ns*}) -(let [blacklisted (into #{} (map cc/find-var) - '[cljs.core/exists? cljs.core/str cljs.core/aget cljs.core/* cljs.core/+ cljs.core// - cljs.core/let cljs.core/nil? cljs.core/aset clojure.core/gen-interface cljs.core/extend-type - cljs.core/implements? cljs.core/satisfies?]) - from-clj {#'cljs.core/defn #'clojure.core/defn - #'cljs.core/defn- #'clojure.core/defn- - #'cljs.core/declare #'clojure.core/declare - #'cljs.core/defprotocol #'clojure.core/defprotocol - #'cljs.core/deftype #'my-deftype}] - (defn expand [a ns$ ls [f & args :as o]] +(defn skip-docstring [args] (cond-> args (string? (first args)) next)) +(defn skip-attr-map [args] (cond-> args (map? (first args)) next)) +(defn skip-inline-opts [args] (cond-> args (keyword? (first args)) (-> nnext recur))) + +(let [blacklisted '#{cljs.core/exists? cljs.core/str cljs.core/extend-type} + short-circuit-def '#{clojure.core/defn, cljs.core/defn, clojure.core/defn-, cljs.core/defn-} + declare? '#{clojure.core/declare cljs.core/declare} + deftype? '#{clojure.core/deftype cljs.core/deftype} + defrecord? '#{clojure.core/defrecord cljs.core/defrecord} + defmacro? '#{clojure.core/defmacro cljs.core/defmacro} + defprotocol? '#{clojure.core/defprotocol cljs.core/defprotocol}] + (defn expand [a ns$ ls env [f & args :as o]] (if (symbol? f) (if (or (special? f) (ls f)) o (if-some [mac (find-macro-var a f ns$)] - (if (blacklisted mac) - o - (apply (or (from-clj mac) mac) o {} args)) + (let [sym (symbol mac)] + (cond (= 'hyperfiddle.rcf/tests sym) nil ; circular, we can skip rcf tests + (= 'hyperfiddle.electric-de/defn sym) `(def ~(first args)) ; circular, don't go deeper + (short-circuit-def sym) `(def ~(first args)) + (declare? sym) `(do ~@(mapv #(list 'def %) args)) + (deftype? sym) (let [[nm] args] `(declare ~nm ~(mksym '-> nm))) + (defrecord? sym) (let [[nm] args] `(declare ~nm ~(mksym '-> nm) ~(mksym 'map-> nm))) + (defmacro? sym) nil + (defprotocol? sym) (let [[_ nm & args] o, fns (-> args skip-docstring skip-inline-opts)] + `(declare ~nm ~@(mapv first fns))) + (blacklisted sym) o ; reading compiler atom *during macroexpansion* + :else (apply mac o env args))) o)) o))) (defn ->def-info [ns$ sym] {::name (with-meta (symbol (str ns$) (str sym)) (meta sym)), ::meta (meta sym)}) -(defn add-require [a ns$ reqk from$ to$] (assoc-in a [::nses ns$ reqk from$] to$)) - -(defn add-refers [a ns$ refk o req$] - (reduce (fn [a nx] (assoc-in a [::nses ns$ refk (or (get (:rename o) nx) nx)] (mksym req$ '/ nx))) - a (:refer o))) +(defn add-require [!a ns$ reqk from$ to$] (swap! !a assoc-in [::nses ns$ reqk from$] to$)) -(declare -add-require) +(defn add-refers [!a ns$ refk o req$] + (reduce (fn [_ nx] (swap! !a assoc-in [::nses ns$ refk (or (get (:rename o) nx) nx)] (mksym req$ '/ nx))) + nil (:refer o))) -(defn ?auto-alias-clojure [a ns$ reqk refk req$] - (if (ns->resource req$) - [a nil] - (let [cljs (str/replace-first (str req$) #"^clojure\." "cljs."), cljs$ (symbol cljs)] - (if (= req$ cljs$) - [a nil] - (if (ns->resource cljs$) - [(-add-require a ns$ reqk refk [cljs$ :as req$]) cljs$] - [a nil]))))) +(declare add-requireT analyze-nsT) -(defn -add-require [a ns$ reqk refk r] - (let [r (if (or (symbol? r) (string? r)) [r] r) - [req$ & o] r, o (apply hash-map o) - [a rewrite$] (?auto-alias-clojure a ns$ reqk refk req$) - req$ (or rewrite$ req$) - a (add-require a ns$ reqk req$ req$)] - (cond-> (analyze-ns a req$) - (:as o) (add-require ns$ reqk (:as o) req$) - (:refer o) (add-refers ns$ refk o req$) - (:refer-macros o) (recur ns$ reqk refk (into [req$] cat (-> (select-keys o [:as]) (assoc :refer (:refer-macros o)))))))) +(defn noneT [s _f] (s nil) #()) -(defn -add-requires [a ns$ rs reqk refk] (reduce #(-add-require % ns$ reqk refk %2) a rs)) +(defn ?auto-alias-clojureT [!a ns$ reqk refk req$] + (or (when-not (ns->resource req$) + (let [cljs (str/replace-first (str req$) #"^clojure\." "cljs."), cljs$ (symbol cljs)] + (when-not (= req$ cljs$) + (when (ns->resource cljs$) + (m/sp (m/? (add-requireT !a ns$ reqk refk [cljs$ :as req$])) cljs$))))) + noneT)) -(defn add-require-macros [a ns$ rs] (-add-requires a ns$ rs ::require-macros ::refer-macros)) -(defn add-requires [a ns$ rs] (-add-requires a ns$ rs ::requires ::refers)) -(defn add-refer-clojure [a ns$ ov] +(defn add-requireT [!a ns$ reqk refk r] + (let [r (if (or (symbol? r) (string? r)) [r] r) + [req$ & o] r, o (apply hash-map o)] + (if (= ns$ req$) + noneT + (m/sp + (let [req$ (or (m/? (?auto-alias-clojureT !a ns$ reqk refk req$)) req$)] + (add-require !a ns$ reqk req$ req$) + (when (:as o) (add-require !a ns$ reqk (:as o) req$)) + (when (:refer o) (add-refers !a ns$ refk o req$)) + (m/? (m/join (fn [& _]) + (analyze-nsT !a (->cljs-env ns$) req$) + (if (:refer-macros o) + (add-requireT !a ns$ reqk refk + (into [req$] cat (-> (select-keys o [:as]) (assoc :refer (:refer-macros o))))) + noneT)))))))) + +(defn -add-requiresT [!a ns$ rs reqk refk] + (apply m/join (fn [& _]) (eduction (map #(add-requireT !a ns$ reqk refk %)) rs))) + +(defn add-require-macrosT [!a ns$ rs] (-add-requiresT !a ns$ rs ::require-macros ::refer-macros)) +(defn add-requiresT [!a ns$ rs] (-add-requiresT !a ns$ rs ::requires ::refers)) +(defn add-refer-clojure [!a ns$ ov] (let [o (apply hash-map ov)] - (cond-> a - (:exclude o) (assoc-in [::nses ns$ ::excludes] (set (:exclude o))) - (:rename o) (-> (update-in [::nses ns$ ::refers] merge - (reduce-kv (fn [m k v] (assoc m v (symbol "cljs.core" (name k)))) {} (:rename o))) - (update-in [::nses ns$ ::excludes] into (keys (:rename o))))))) + (when (:exclude o) + (swap! !a assoc-in [::nses ns$ ::excludes] (set (:exclude o)))) + (when (:rename o) + (swap! !a + (fn [a] + (-> a (update-in [::nses ns$ ::refers] merge + (reduce-kv (fn [m k v] (assoc m v (symbol "cljs.core" (name k)))) {} (:rename o))) + (update-in [::nses ns$ ::excludes] into (keys (:rename o))))))))) (defn use->require [args] (let [o (apply hash-map (next args))] (into [(first args)] cat (cond-> (select-keys o [:rename]) (:only o) (assoc :refer (:only o)))))) -(comment - (a-ns foo - "docstring?" ; DONE - '{attr map?} ; DONE - (:refer-clojure :exclude [str]) ; DONE - (:refer-clojure :rename {str sstr}) ; DONE - (:require x ; DONE - [x] ; DONE - [x :as xy] ; DONE - [x :refer [y]] ; DONE - [x :refer [y] :rename {y yy}] ; DONE - [x :include-macros true] ; DONE - [x :refer-macros [y]]) ; DONE - (:require-macros x ; DONE - [x] ; DONE - [x :as xy] ; DONE - [x :refer [y]] ; DONE - [x :refer [y] :rename {y yy}]) ; DONE - (:use x ; - [x] ; - [x :only [y]] ; DONE - [x :only [y] :rename {y z}]) ; DONE - (:use-macros x ; - [x] ; - [x :only [y]] ; DONE - [x :only [y] :rename {y z}]) ; DONE - ) - ) -(defn skip-docstring [args] (cond-> args (string? (first args)) next)) -(defn skip-attr-map [args] (cond-> args (map? (first args)) next)) -(defn add-ns-info [a [_ns ns$ & args]] +(defn add-ns-infoT [!a [_ns ns$ & args]] (let [args (-> args skip-docstring skip-attr-map)] - (reduce (fn [a [typ & args]] - (case typ - (:require) (add-requires a ns$ args) - (:require-macros) (add-require-macros a ns$ args) - (:use) (add-requires a ns$ (mapv use->require args)) - (:use-macros) (add-require-macros a ns$ (mapv use->require args)) - (:refer-clojure) (add-refer-clojure a ns$ args) - #_else a)) a args ))) - -(defn add-def [a ns$ sym] (assoc-in a [::nses ns$ ::defs sym] (->def-info ns$ sym))) - -(defn collect-defs [a ns$ o] - ((fn rec [ls a o] - (if (and (seq? o) (seq o)) + (apply m/join (fn [& _]) + (eduction (map (fn [[typ & args]] + (case typ + (:require) (add-requiresT !a ns$ args) + (:require-macros) (add-require-macrosT !a ns$ args) + (:use) (add-requiresT !a ns$ (mapv use->require args)) + (:use-macros) (add-require-macrosT !a ns$ (mapv use->require args)) + (:refer-clojure) (m/sp (add-refer-clojure !a ns$ args)) + #_else noneT))) + args)))) + +(defn add-def [!a ns$ sym] (swap! !a assoc-in [::nses ns$ ::defs sym] (->def-info ns$ sym))) + +(defn collect-defs [!a ns$ env o] + ((fn rec [ls !a o] + (when (and (seq? o) (seq o)) (case (first o) - (defmacro clojure.core/defmacro cljs.core/defmacro) a - - (defprotocol clojure.core/defprotocl cljs.core/defprotocol) - (let [[_ nm & args] o, fns (cond-> args (string? (first args)) next)] - (reduce (fn [a sym] (add-def a ns$ sym)) a (cons nm (eduction (map first fns))))) - - (def) (add-def a ns$ (second o)) - - (ns) (add-ns-info a o) - ;; (fn* foo [x] x) (fn* foo ([x] x) ([x y] x)) (fn* [x] x) (fn* ([x] x) ([x y] x)) - (fn*) (let [body (if (symbol? (second o)) (nnext o) (next o)) - arities (if (vector? (first body)) (list body) body)] - (reduce (fn [a [bs & body]] (rec (into ls bs) a (cons 'do body))) a arities)) - + (def) (add-def !a ns$ (second o)) + (ns) (m/? (add-ns-infoT !a o)) + (fn*) nil (let*) (let [[_ bs & body] o - [a ls] (transduce (partition-all 2) (completing (fn [[a ls] [k v]] [(rec ls a v) (conj ls k)])) - [a ls] bs)] - (recur ls a (cons 'do body))) - - #_else (let [o2 (expand a ns$ ls o)] + ls (transduce (partition-all 2) (completing (fn [ls [k v]] (rec ls !a v) (conj ls k))) ls bs)] + (rec ls !a (cons 'do body))) + #_else (let [o2 (expand @!a ns$ ls env o)] (if (identical? o o2) - (reduce (partial rec ls) a o) - (rec ls a o2)))) - a)) #{} a o)) + (run! #(rec ls !a %) o) + (recur ls !a o2)))))) + #{} !a o)) (defn keep-if [v pred] (when (pred v) v)) (defn macro-var? [vr] (and (instance? clojure.lang.Var vr) (.isMacro ^clojure.lang.Var vr))) @@ -214,14 +185,18 @@ ;;; PUBLIC API ;;; ;;;;;;;;;;;;;;;;;; -(defn analyze-ns - ([ns$] (analyze-ns (->a) ns$)) - ([a ns$] (if (contains? (::nses a) ns$) - a - (if-some [rs (ns->resource ns$)] - (let [a (assoc-in a [::nses ns$] {})] - (->> (resource-forms> rs) (m/reduce #(collect-defs % ns$ %2) a) m/?)) - a)))) +(defn analyze-nsT [!a env ns$] + (if-some [rs (some-> ns$ ns->resource)] + (loop [a @!a] + (or (-> a ::ns-tasks (get ns$)) + (let [T (->> (resource-forms> rs) (m/reduce #(collect-defs !a ns$ env %2) nil)) + T (m/memo (m/via m/blk (m/? T)))] + (if (compare-and-set! !a a (assoc-in a [::ns-tasks ns$] T)) + T + (recur @!a))))) + noneT)) + +(defn purge-ns [!a ns$] (swap! !a (fn [a] (-> a (update ::ns-tasks dissoc ns$) (update ::nses dissoc ns$)))) nil) (defn find-var [a sym ns$] (let [nsa (-> a ::nses (get ns$))] @@ -231,10 +206,13 @@ (-> a ::nses (get 'cljs.core) ::defs (get sym))) (when-some [renamed (get (::refers nsa) sym)] (-> a ::nses (get (symbol (namespace renamed))) ::defs (get (symbol (name renamed)))))) - (when-some [sym-ns$ (-> nsa ::requires (get (symbol (namespace sym))))] - (find-var a (symbol (name sym)) sym-ns$))))) + (or (-> a ::nses (get (-> sym namespace symbol)) ::defs (get (-> sym name symbol))) + (when-some [sym-ns$ (-> nsa ::requires (get (symbol (namespace sym))))] + (find-var a (symbol (name sym)) sym-ns$)) + (when (= "clojure.core" (namespace sym)) + (-> a ::nses (get 'cljs.core) ::defs (get (-> sym name symbol)))))))) -;; TODO clojure.core -> cljs.core, clojure.repl -> cljs.repl +;; cljs analyzer has extra, clojure.core -> cljs.core, clojure.repl -> cljs.repl, do we need it? (defn find-macro-var [a sym ns$] (when-not (find-var a sym ns$) (-> (cond @@ -250,9 +228,12 @@ :else (let [sym-ns$ (-> sym namespace symbol), sym-base$ (-> sym name symbol)] (or (when-some [sym-ns$ (-> a ::nses (get ns$) ::requires (get sym-ns$))] - (safe-require sym-ns$) - (some-> (find-ns sym-ns$) (find-ns-var sym-base$))) + (safe-require sym-ns$) + (some-> (find-ns sym-ns$) (find-ns-var sym-base$))) (when-some [sym-ns$ (-> a ::nses (get ns$) ::require-macros (get sym-ns$))] (safe-require sym-ns$) - (some-> (find-ns sym-ns$) (find-ns-var sym-base$)))))) + (some-> (find-ns sym-ns$) (find-ns-var sym-base$))) + (some-> (find-ns sym-ns$) (find-ns-var sym-base$))))) (keep-if macro-var?)))) + +(defn ->!a [] (let [!a (atom {})] (m/? (analyze-nsT !a (->cljs-env 'cljs.core) 'cljs.core)) !a)) diff --git a/src/hyperfiddle/electric/impl/cljs_analyzer2.clj b/src/hyperfiddle/electric/impl/cljs_analyzer2.clj deleted file mode 100644 index 211784cce..000000000 --- a/src/hyperfiddle/electric/impl/cljs_analyzer2.clj +++ /dev/null @@ -1,297 +0,0 @@ -(ns hyperfiddle.electric.impl.cljs-analyzer2 - (:refer-clojure :exclude [find-var]) - (:require [edamame.core :as ed] - [clojure.core :as cc] - [clojure.string :as str] - [clojure.tools.reader.reader-types :as rt] - [clojure.java.io :as io] - [cljs.tagged-literals] - [missionary.core :as m] - [contrib.debug] - [cljs.core] ; for cljs macroexpansion - [cljs.env] - [cljs.analyzer] - [cljs.repl])) ; for cljs macroexpansion - -#_ -(defn get-expander-ns [env ^String nstr] - ;; first check for clojure.* -> cljs.* cases - (let [res (or (resolve-macro-ns-alias env nstr nil) - (resolve-ns-alias env nstr nil)) - nstr (if res (str res) nstr)] - (cond (= "clojure.core" nstr) (find-ns 'cljs.core) - (= "clojure.repl" nstr) (find-ns 'cljs.repl) - (.contains nstr ".") (find-ns (symbol nstr)) - :else (some-> env :ns :require-macros (get (symbol nstr)) find-ns)))) - -(defn ns->basename [ns$] (-> ns$ name (.replace \- \_) (.replace \. \/))) - -(defn ns->resource [ns$] - (let [base (ns->basename ns$)] - (or (io/resource (str base ".cljs")) - (io/resource (str base ".cljc"))))) - -(let [parse-opts - (ed/normalize-opts {:all true, :row-key :line, :col-key :column, :end-location false - :readers cljs.tagged-literals/*cljs-data-readers* :auto-resolve name - :features #{:cljs}, :read-cond :allow, :eof ::done})] - (defn resource-forms> [rs] - (->> (m/ap - (let [rdr (m/?> (m/observe (fn [!] - (let [rdr (rt/source-logging-push-back-reader (io/reader rs))] - (! rdr) #(.close ^java.io.Reader rdr)))))] - (m/? (m/?> (m/seed (repeat (m/sp (ed/parse-next rdr parse-opts)))))))) - (m/eduction (take-while (complement #{::done})))))) - -(defn safe-require [sym] - ;; we might be expanding clj code before the ns got loaded (during cljs compilation) - ;; to correctly lookup vars the ns needs to be loaded - ;; since shadow-cljs compiles in parallel we need to serialize the requires - (when-not (get (loaded-libs) sym) - (try (#'clojure.core/serialized-require sym) ; try bc it can be cljs file - (catch java.io.FileNotFoundException _)))) - -(defn find-ns-var [^clojure.lang.Namespace nso sym] (.findInternedVar nso sym)) -(declare find-var find-macro-var) - -(defn mksym [& xs] (symbol (apply str (mapv #((if (or (keyword? %) (symbol? %)) name str) %) xs)))) - -(defmacro my-deftype [nm & _] `(do (def ~nm) (def ~(mksym '-> nm)))) - -(let [-base-cljs-env {:context :statement - :locals {} - :fn-scope [] - :js-globals (into {} - (map #(vector % {:op :js-var :name % :ns 'js}) - '(alert window document console escape unescape - screen location navigator history location - global process require module exports)))}] - (defn ->cljs-env - ([] (->cljs-env (ns-name *ns*))) - ([nssym] (cond-> -base-cljs-env nssym (assoc :ns {:name nssym}))))) - -(def special? '#{if def fn* do let* loop* letfn* throw try catch finally - recur new set! ns deftype* defrecord* . js* & quote case* var ns*}) - -(let [blacklisted (into #{} (map cc/find-var) - '[cljs.core/exists? cljs.core/str cljs.core/aget cljs.core/* cljs.core/+ cljs.core// - #_cljs.core/let cljs.core/nil? cljs.core/aset clojure.core/gen-interface cljs.core/extend-type - cljs.core/implements? cljs.core/satisfies?]) - from-clj {#'cljs.core/defn #'clojure.core/defn - #'cljs.core/defn- #'clojure.core/defn- - #'cljs.core/declare #'clojure.core/declare - #'cljs.core/defprotocol #'clojure.core/defprotocol - #'clojure.core/deftype #'my-deftype - #'cljs.core/deftype #'my-deftype}] - (defn expand [a ns$ ls env [f & args :as o]] - (if (symbol? f) - (if (or (special? f) (ls f)) - o - (if-some [mac (find-macro-var a f ns$)] - (cond (= 'hyperfiddle.rcf/tests (symbol mac)) nil - (= 'hyperfiddle.electric-de/defn (symbol mac)) `(def ~(first args)) - (blacklisted mac) o - :else (apply (or (from-clj mac) mac) o env args)) - o)) - o))) - -(defn ->def-info [ns$ sym] {::name (with-meta (symbol (str ns$) (str sym)) (meta sym)), ::meta (meta sym)}) - -(defn add-require [!a ns$ reqk from$ to$] (swap! !a assoc-in [::nses ns$ reqk from$] to$)) - -(defn add-refers [!a ns$ refk o req$] - (reduce (fn [_ nx] (swap! !a assoc-in [::nses ns$ refk (or (get (:rename o) nx) nx)] (mksym req$ '/ nx))) - nil (:refer o))) - -(declare add-requireT analyze-nsT) - -(defn noneT [s _f] (s nil) #()) - -(defn ?auto-alias-clojureT [!a ns$ reqk refk req$] - (or (when-not (ns->resource req$) - (let [cljs (str/replace-first (str req$) #"^clojure\." "cljs."), cljs$ (symbol cljs)] - (when-not (= req$ cljs$) - (when (ns->resource cljs$) - (m/sp (m/? (add-requireT !a ns$ reqk refk [cljs$ :as req$])) cljs$))))) - noneT)) - -(defn add-requireT [!a ns$ reqk refk r] - (let [r (if (or (symbol? r) (string? r)) [r] r) - [req$ & o] r, o (apply hash-map o)] - (if (= ns$ req$) - noneT - (m/sp - (let [req$ (or (m/? (?auto-alias-clojureT !a ns$ reqk refk req$)) req$)] - (add-require !a ns$ reqk req$ req$) - (when (:as o) (add-require !a ns$ reqk (:as o) req$)) - (when (:refer o) (add-refers !a ns$ refk o req$)) - (m/? (m/join (fn [& _]) - (analyze-nsT !a (->cljs-env ns$) req$) - (if (:refer-macros o) - (add-requireT !a ns$ reqk refk - (into [req$] cat (-> (select-keys o [:as]) (assoc :refer (:refer-macros o))))) - noneT)))))))) - -(defn -add-requiresT [!a ns$ rs reqk refk] - (apply m/join (fn [& _]) (eduction (map #(add-requireT !a ns$ reqk refk %)) rs))) - -(defn add-require-macrosT [!a ns$ rs] (-add-requiresT !a ns$ rs ::require-macros ::refer-macros)) -(defn add-requiresT [!a ns$ rs] (-add-requiresT !a ns$ rs ::requires ::refers)) -(defn add-refer-clojure [!a ns$ ov] - (let [o (apply hash-map ov)] - (when (:exclude o) - (swap! !a assoc-in [::nses ns$ ::excludes] (set (:exclude o)))) - (when (:rename o) - (swap! !a - (fn [a] - (-> a (update-in [::nses ns$ ::refers] merge - (reduce-kv (fn [m k v] (assoc m v (symbol "cljs.core" (name k)))) {} (:rename o))) - (update-in [::nses ns$ ::excludes] into (keys (:rename o))))))))) -(defn use->require [args] - (let [o (apply hash-map (next args))] - (into [(first args)] cat (cond-> (select-keys o [:rename]) (:only o) (assoc :refer (:only o)))))) - -(comment - (a-ns foo - "docstring?" ; DONE - '{attr map?} ; DONE - (:refer-clojure :exclude [str]) ; DONE - (:refer-clojure :rename {str sstr}) ; DONE - (:require x ; DONE - [x] ; DONE - [x :as xy] ; DONE - [x :refer [y]] ; DONE - [x :refer [y] :rename {y yy}] ; DONE - [x :include-macros true] ; DONE - [x :refer-macros [y]]) ; DONE - (:require-macros x ; DONE - [x] ; DONE - [x :as xy] ; DONE - [x :refer [y]] ; DONE - [x :refer [y] :rename {y yy}]) ; DONE - (:use x ; - [x] ; - [x :only [y]] ; DONE - [x :only [y] :rename {y z}]) ; DONE - (:use-macros x ; - [x] ; - [x :only [y]] ; DONE - [x :only [y] :rename {y z}]) ; DONE - ) - ) -(defn skip-docstring [args] (cond-> args (string? (first args)) next)) -(defn skip-attr-map [args] (cond-> args (map? (first args)) next)) -(defn skip-inline-opts [args] (cond-> args (keyword? (first args)) (-> nnext recur))) -(defn add-ns-infoT [!a [_ns ns$ & args]] - (let [args (-> args skip-docstring skip-attr-map)] - (apply m/join (fn [& _]) - (eduction (map (fn [[typ & args]] - (case typ - (:require) (add-requiresT !a ns$ args) - (:require-macros) (add-require-macrosT !a ns$ args) - (:use) (add-requiresT !a ns$ (mapv use->require args)) - (:use-macros) (add-require-macrosT !a ns$ (mapv use->require args)) - (:refer-clojure) (m/sp (add-refer-clojure !a ns$ args)) - #_else noneT))) - args)))) - -(defn add-def [!a ns$ sym] (swap! !a assoc-in [::nses ns$ ::defs sym] (->def-info ns$ sym))) - -(defn collect-defsT [!a ns$ env o] - ;; (prn :defs (-> @!a ::nses (get ns$) ::defs keys sort)) - ;; (prn :collect-defs o) - ((fn recT [ls !a o] - (if (and (seq? o) (seq o)) - (case (first o) - (defmacro clojure.core/defmacro cljs.core/defmacro) noneT - - (defprotocol clojure.core/defprotocol cljs.core/defprotocol) - (let [[_ nm & args] o, fns (-> args skip-docstring skip-inline-opts)] - (m/sp (run! #(add-def !a ns$ %) (cons nm (eduction (map first fns)))))) - - (def) (m/sp (add-def !a ns$ (second o))) - - (deftype clojure.core/deftype cljs.core/deftype) - (let [[_ nm] o] (m/sp (add-def !a ns$ nm) (add-def !a ns$ (mksym '-> nm)))) - - (ns) (add-ns-infoT !a o) - - (fn*) (let [body (if (symbol? (second o)) (nnext o) (next o)) - arities (if (vector? (first body)) (list body) body)] - (apply m/join (fn [& _]) - (eduction (map (fn [[bs & body]] (recT (into ls bs) !a (cons 'do body)))) arities))) - - (let*) (let [[_ bs & body] o - [Ts ls] (transduce (partition-all 2) - (completing (fn [[Ts ls] [k v]] [(conj Ts (recT ls !a v)) (conj ls k)])) - [[] ls] bs)] - (apply m/join (fn [& _]) (conj Ts (recT ls !a (cons 'do body))))) - - #_else (let [o2 (expand @!a ns$ ls env o)] - (if (identical? o o2) - (apply m/join (fn [& _]) (eduction (map #(recT ls !a %)) o)) - (recur ls !a o2)))) - noneT)) - #{} !a o)) - -(defn keep-if [v pred] (when (pred v) v)) -(defn macro-var? [vr] (and (instance? clojure.lang.Var vr) (.isMacro ^clojure.lang.Var vr))) - -;;;;;;;;;;;;;;;;;; -;;; PUBLIC API ;;; -;;;;;;;;;;;;;;;;;; - -(defn analyze-nsT [!a env ns$] - (if-some [rs (some-> ns$ ns->resource)] - (loop [a @!a] - (or (-> a ::ns-tasks (get ns$)) - (let [T (->> (m/ap (let [o (m/?> (resource-forms> rs))] - (m/? (collect-defsT !a ns$ env o)))) - (m/reduce (fn [_ _]) nil)) - T (m/memo (m/via m/blk (m/? T)))] - (if (compare-and-set! !a a (assoc-in a [::ns-tasks ns$] T)) - T - (recur @!a))))) - noneT)) - -(defn purge-ns [!a ns$] (swap! !a (fn [a] (-> a (update ::ns-tasks dissoc ns$) (update ::nses dissoc ns$)))) nil) - -(defn find-var [a sym ns$] - (let [nsa (-> a ::nses (get ns$))] - (if (simple-symbol? sym) - (or (-> nsa ::defs (get sym)) - (when-not (get (::excludes nsa) sym) - (-> a ::nses (get 'cljs.core) ::defs (get sym))) - (when-some [renamed (get (::refers nsa) sym)] - (-> a ::nses (get (symbol (namespace renamed))) ::defs (get (symbol (name renamed)))))) - (or (when-some [sym-ns$ (-> nsa ::requires (get (symbol (namespace sym))))] - (find-var a (symbol (name sym)) sym-ns$)) - (when (= "clojure.core" (namespace sym)) - (-> a ::nses (get 'cljs.core) ::defs (get (-> sym name symbol)))) - (-> a ::nses (get (-> sym namespace symbol)) ::defs (get (-> sym name symbol))))))) - -;; TODO clojure.core -> cljs.core, clojure.repl -> cljs.repl -(defn find-macro-var [a sym ns$] - (when-not (find-var a sym ns$) - (-> (cond - (simple-symbol? sym) - (or (do (safe-require ns$) (some-> (find-ns ns$) (find-ns-var sym))) - (when-some [ref (-> a ::nses (get ns$) ::refers (get sym))] (requiring-resolve ref)) - (when-some [ref (-> a ::nses (get ns$) ::refer-macros (get sym))] (requiring-resolve ref)) - (when-not (get (-> a ::nses (get ns$) ::excludes) sym) (find-ns-var (find-ns 'clojure.core) sym))) - - (#{"cljs.core" "clojure.core"} (namespace sym)) - (requiring-resolve sym) - - :else - (let [sym-ns$ (-> sym namespace symbol), sym-base$ (-> sym name symbol)] - (or (when-some [sym-ns$ (-> a ::nses (get ns$) ::requires (get sym-ns$))] - (safe-require sym-ns$) - (some-> (find-ns sym-ns$) (find-ns-var sym-base$))) - (when-some [sym-ns$ (-> a ::nses (get ns$) ::require-macros (get sym-ns$))] - (safe-require sym-ns$) - (some-> (find-ns sym-ns$) (find-ns-var sym-base$))) - (some-> (find-ns sym-ns$) (find-ns-var sym-base$))))) - (keep-if macro-var?)))) - -(defn ->!a [] (let [!a (atom {})] (m/? (analyze-nsT !a (->cljs-env 'cljs.core) 'cljs.core)) !a)) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index cc5fff078..97239dd5f 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -12,7 +12,7 @@ [missionary.core :as m] [hyperfiddle.electric-de :as-alias e] [hyperfiddle.electric.impl.analyzer :as ana] - [hyperfiddle.electric.impl.cljs-analyzer2 :as cljs-ana] + [hyperfiddle.electric.impl.cljs-analyzer :as cljs-ana] [hyperfiddle.electric.impl.destructure :as dst] [hyperfiddle.electric.impl.runtime-de :as r] [hyperfiddle.rcf :as rcf :refer [tests]])) @@ -36,26 +36,6 @@ (try (#'clojure.core/serialized-require sym) ; try bc it can be cljs file (catch java.io.FileNotFoundException _)))) -;; the ns cache relies on external eviction in shadow-cljs reload hook -(def !cljs-ns-cache (atom {})) - -#_(defn enrich-for-require-macros-lookup [cljs-env nssym] - (if-some [ast (get @!cljs-ns-cache nssym)] - (assoc cljs-env :ns ast) - (if-some [src (cljs-ana/locate-src nssym)] - (let [ast (:ast (with-redefs [cljs-ana/missing-use-macro? (constantly nil)] - (binding [cljs-ana/*passes* [cljs-ana/ns-side-effects]] - (cljs-ana/parse-ns src {:load-macros true, :analyze-deps true, :restore false}))))] - ;; we parsed the ns form without `ns-side-effects` because it triggers weird bugs - ;; this means the macro nss from `:require-macros` might not be loaded - (run! serialized-require (-> ast :require-macros vals set)) - (swap! !cljs-ns-cache assoc nssym ast) - (assoc cljs-env :ns ast)) - cljs-env))) - -#_(tests "enrich of clj source file is noop" - (cljs.env/ensure (enrich-for-require-macros-lookup {:a 1} 'clojure.core)) := {:a 1}) - (let [-base-cljs-env {:context :statement :locals {} :fn-scope [] @@ -68,34 +48,6 @@ ([] (->cljs-env (ns-name *ns*))) ([nssym] (cond-> -base-cljs-env nssym (assoc :ns {:name nssym}))))) -(def !default-cljs-compiler-env - (delay - (cljs.env/ensure - (cljs.analyzer/analyze-file "cljs/core.cljs") ; needed in general, to resolve cljs.core vars - cljs.env/*compiler*))) - -;; adapted from cljs.env -(defmacro ensure-cljs-compiler - [& body] - `(let [val# cljs.env/*compiler*] - (if (nil? val#) - (push-thread-bindings - (hash-map (var cljs.env/*compiler*) @!default-cljs-compiler-env))) - (try - ~@body - (finally - (if (nil? val#) - (pop-thread-bindings)))))) - -#_(defn ensure-cljs-env [env] - (if (::cljs-env env) - env - (assoc env ::cljs-env - (if (contains? (:ns env) :requires) - env - (let [nssym (get-ns env)] - (cond-> (->cljs-env nssym) nssym (enrich-for-require-macros-lookup nssym))))))) - ;;;;;;;;;;;;;;;; ;;; EXPANDER ;;; ;;;;;;;;;;;;;;;; @@ -104,49 +56,12 @@ (declare -expand-all-in-try) -#_(defn resolve-cljs [env sym] - (when (not= '. sym) - (let [!found? (volatile! true) - resolved (binding [cljs-ana/*cljs-warnings* (assoc cljs-ana/*cljs-warnings* :undeclared-ns false)] - (let [res (cljs-ana/resolve-var env sym nil nil)] - (when (and (not= :js-var (:op res)) (:name res) (namespace (:name res))) - (cljs-ana/confirm-var-exists env (-> res :name namespace symbol) (-> res :name name symbol) - (fn [_ _ _] (vreset! !found? false)))) - res))] - (when (and resolved @!found? (not (:macro resolved))) - ;; If the symbol is unqualified and is from a different ns (through e.g. :refer) - ;; cljs returns only :name and :ns. We cannot tell if it resolved to a macro. - ;; We recurse with the fully qualified symbol to get all the information. - ;; The symbol can also resolve to a local in which case we're done. - ;; TODO how to trigger these in tests? - (if (and (simple-symbol? sym) (not= (get-ns env) (:ns resolved)) (not= :local (:op resolved))) - (recur env (ca/check qualified-symbol? (:name resolved) {:sym sym, :resolved resolved})) - resolved))))) - -#_(comment - (cljs.env/ensure (cljs-ana/resolve-var (cljs-ana/empty-env) 'prn nil nil)) - (->cljs-env) - (cljs-ana/empty-env) - (require '[hyperfiddle.electric.impl.expand :as expand]) - (cljs.env/ensure (resolve-cljs (cljs-ana/empty-env) 'prn)) - ) - (defn macroexpand-clj [o env] (serialized-require (ns-name *ns*)) (if-some [mac (when-some [mac (resolve env (first o))] (when (.isMacro ^clojure.lang.Var mac) mac))] (apply mac o env (next o)) (macroexpand-1 o))) ; e.g. (Math/abs 1) will expand to (. Math abs 1) -#_(defn expand-referred-or-local-macros [o cljs-macro-env] - ;; (:require [some.ns :refer [some-macro]]) - ;; `some-macro` might be a macro and cljs expander lookup fails to find it - ;; another case is when a cljc file :require-macros itself without refering the macros - (if-some [vr (when (simple-symbol? (first o)) (resolve (first o)))] - (if (and (not (class? vr)) (.isMacro ^clojure.lang.Var vr)) - (apply vr o cljs-macro-env (rest o)) - o) - o)) - (def !a (cljs-ana/->!a)) (comment @@ -165,13 +80,6 @@ (if-some [mac (cljs-ana/find-macro-var @!a f (get-ns env))] (apply mac o (merge (->cljs-env (get-ns env)) env) args) o) - #_(let [cljs-env (::cljs-env env)] - (if (resolve-cljs cljs-env f) - o - (let [cljs-macro-env (cond-> cljs-env (::ns cljs-env) (assoc :ns (::ns cljs-env)))] - (if-some [expander (cljs-ana/get-expander f cljs-macro-env)] - (apply expander o cljs-macro-env args) - (expand-referred-or-local-macros o cljs-macro-env))))) (macroexpand-clj o env))))))) (defn find-local-entry [env sym] (contains? (:locals env) sym)) @@ -192,13 +100,6 @@ (caller o2 env))) (?meta o (list* (caller (first o) env) (mapv (fn-> caller env) (next o)))))) -#_(defn -expand-all-non-electric [o env] - (if (and (seq? o) (seq o)) - (if (find-local-entry env (first o)) - (?meta o (list* (first o) (mapv (fn-> -expand-all env) (rest o)))) - (?expand-macro o (assoc env ::electric false) -expand-all-non-electric)) - o)) - (defn -expand-all [o env] (cond (and (seq? o) (seq o)) @@ -260,13 +161,10 @@ (letfn*) (let [[_ bs & body] o env2 (reduce add-local env (take-nth 2 bs)) - bs2 (into [] (comp (partition-all 2) - (mapcat (fn [[sym v]] [sym (-expand-all v env2)]))) - bs) - ] + bs2 (->> bs (into [] (comp (partition-all 2) + (mapcat (fn [[sym v]] [sym (-expand-all v env2)])))))] (?meta o `(let* [~(vec (take-nth 2 bs2)) (::letfn ~bs2)] ~(-expand-all (cons 'do body) env2)))) - ;; TODO expand `do` (try) (throw (ex-info "try is TODO" {:o o})) #_(list* 'try (mapv (fn-> -all-in-try env) (rest o))) (js*) (let [[_ s & args] o, gs (repeatedly (count args) gensym)] @@ -301,12 +199,6 @@ #_else (-expand-all o env))) (-expand-all o env))) -;; :js-globals -> cljs env -;; :locals -> cljs or electric env -;; ::lang/peers -> electric env -;; if ::current = :clj expand with clj environment -;; if ::current = :cljs expand with cljs environment - (defn expand-all [env o] (m/? (cljs-ana/analyze-nsT !a env (get-ns env))) (-expand-all o (assoc env ::electric true))) @@ -348,11 +240,6 @@ :cljs (:name (:info ast)))) ast)) -(defn find-local [f env] "TODO" nil) -(defn find-electric-local [o env] "TODO" nil) - -(defn ->meta [o env] (merge (::meta (find-electric-local o env)) (meta o))) - (defn closure "Analyze a cc/fn form, looking for electric defs and electric lexical bindings references. Rewrites the cc/fn form into a closure over electric dynamic and lexical scopes. @@ -387,7 +274,7 @@ (symbol (str/replace (str (munge sym)) #"\." "_")) sym)) record-lexical! (fn [{:keys [form]}] - (swap! refered-lexical assoc (with-meta form (->meta form env)) + (swap! refered-lexical assoc form (gensym (name form)))) record-edef! (fn [{:keys [form] :as ast}] (if (dynamic? ast) @@ -441,30 +328,15 @@ (str/join (interpose '. (butlast fields))) "globalThis"))))) -(defn class-constructor-call? [env f] (and (symbol? f) (not (find-local f env)))) -(defn with-interop-locals [env syms] (update env :locals merge (zipmap syms (repeat {})))) - (defn resolve-static-field [sym] (when-some [ns (some-> (namespace sym) symbol)] (when-some [cls (resolve ns)] (when (class? cls) (clojure.lang.Reflector/getField cls (name sym) true))))) -(defn resolve-static-method [sym] - (when (and (qualified-symbol? sym) (class? (resolve (-> sym namespace symbol)))) - sym)) - (defn get-children-e [ts e] (-> ts :ave ::parent (get e))) (defn get-child-e [ts e] (first (get-children-e ts e))) -(defn find-let-ref [sym pe ts] - (loop [pe pe] - (when pe - (let [p (ts/get-entity ts pe)] - (if (and (= ::let (::type p)) (= sym (::sym p))) - pe - (recur (::parent p))))))) - (defn ?add-source-map [{{::keys [->id]} :o :as ts} pe form] (let [mt (meta form)] (cond-> ts (:line mt) (ts/add {:db/id (->id), ::source-map-of pe, ::line (:line mt), ::column (:column mt)})))) @@ -504,13 +376,6 @@ {::type ::var, ::sym (untwin (::cljs-ana/name v))} {::type ::static, ::sym sym})) -#_(defn resolve-cljs-alias [env sym] - (if (simple-symbol? sym) - (symbol (-> env :ns :name str) (name sym)) - (or (cljs-ana/resolve-ns-alias env sym) (cljs-ana/resolve-macro-ns-alias env sym)))) - -#_(defn assume-cljs-var [sym env] {::type ::var, ::sym (untwin (resolve-cljs-alias env sym))}) - (defn resolve-symbol [sym env] (if-some [local (-> env :locals (get sym))] (if-some [ref (::electric-let local)] diff --git a/test/hyperfiddle/electric/impl/cljs_analyzer2_test.clj b/test/hyperfiddle/electric/impl/cljs_analyzer2_test.clj deleted file mode 100644 index c12654f36..000000000 --- a/test/hyperfiddle/electric/impl/cljs_analyzer2_test.clj +++ /dev/null @@ -1,107 +0,0 @@ -(ns hyperfiddle.electric.impl.cljs-analyzer2-test - (:require [clojure.test :as t] - [cljs.env] - [cljs.analyzer] - [missionary.core :as m] - [hyperfiddle.electric.impl.cljs-analyzer2 :as ana])) - -(comment - (def !a (atom {})) - (m/? (ana/analyze-nsT !a {} 'cljs.core)) - (-> @!a ::ana/nses (get 'cljs.core) ::ana/defs count) - ) - -(t/deftest ns-expansion - (let [ns$ 'hyperfiddle.electric.impl.cljs-file-to-analyze - !a (ana/->!a) - _ (m/? (ana/analyze-nsT !a {} ns$)) - a @!a] - (t/is (= 1 1)) - (t/is (nil? (ana/find-var a 'non ns$))) - (t/is (nil? (ana/find-var a 'first ns$))) - (t/is (= 'cljs.core/next (::ana/name (ana/find-var a 'nxt ns$)))) - (t/are [x] (some? (ana/find-var a x ns$)) - 'foo - 'bar - 'baz - 'an-fn - 'behind-require - 'str - 'behind-alias - 'behind-require-macros - 'behind-require-macro-alias - 'behind-required-refer - 'behind-required-rename - 'behind-require-macro-refer - 'behind-require-macro-rename - 'behind-include-macros - 'behind-refer-macros - 'behind-use - 'behind-use-renamed - 'behind-use-macro - 'behind-use-macro-renamed - 'behind-auto-alias - 'behind-auto-alias-alias - 'behind-auto-alias-refer - 'nxt))) - -(t/deftest runtime-vars - (let [ns$ 'hyperfiddle.electric.impl.cljs-file-to-analyze, - !a (ana/->!a) - _ (m/? (ana/analyze-nsT !a {} ns$)) - a @!a] - (t/are [x] (nil? (ana/find-var a x ns$)) - 'hyperfiddle.electric.impl.cljs-file-to-analyze.runtime/only-macro - 'run/only-macro - 'only-macro - 'next) ; renamed in :refer-clojure - (t/are [x] (some? (ana/find-var a x ns$)) - 'hyperfiddle.electric.impl.cljs-file-to-analyze.runtime/macro-and-runtime - 'run/macro-and-runtime - 'macro-and-runtime - 'hyperfiddle.electric.impl.cljs-file-to-analyze.runtime/only-runtime - 'run/only-runtime - 'only-runtime))) - -(t/deftest local-shadowing - (let [ns$ 'hyperfiddle.electric.impl.cljs-file-to-analyze - !a (ana/->!a) - _ (m/? (ana/analyze-nsT !a {} ns$)) - a @!a] - (t/are [x] (nil? (ana/find-var a x ns$)) - 'shadowed-by-let - 'shadowed-by-let-destructure - 'shadowed-by-fn - 'shadowed-by-fn-destructure - 'shadowed-by-letfn-fn-name - 'shadowed-by-letfn-other-fn-name - 'shadowed-by-letfn-local))) - -(t/deftest defs-match-official-cljs-analyzer - (let [ns$ 'cljs.analyzer - !a (ana/->!a) - _ (m/? (ana/analyze-nsT !a {} ns$)) - a @!a - c (cljs.env/ensure - (cljs.analyzer/analyze-file "cljs/core.cljs") - (cljs.analyzer/analyze-file "cljs/analyzer.cljc") - @cljs.env/*compiler*)] - (t/are [ns$] (= (into #{} (keep (fn [[k v]] (when-not (:anonymous v) k))) - (-> c :cljs.analyzer/namespaces (get ns$) :defs)) - (set (-> a ::ana/nses (get ns$) ::ana/defs keys))) - 'cljs.core - 'cljs.analyzer))) - -(t/deftest clojure-core-var-found-as-cljs-core-var - (let [ns$ 'cljs.analyzer - !a (ana/->!a) - _ (m/? (ana/analyze-nsT !a {} ns$)) - a @!a] - (t/is (some? (ana/find-var a 'clojure.core/vector ns$))))) - -(t/deftest non-required-var-can-be-found ; e.g. a macro from another ns might have expanded to it - (let [ns$ 'cljs.source-map - !a (ana/->!a) - _ (m/? (ana/analyze-nsT !a {} ns$)) - a @!a] - (t/is (some? (ana/find-var a 'cljs.source-map/encode 'cljs.core))))) diff --git a/test/hyperfiddle/electric/impl/cljs_analyzer_test.clj b/test/hyperfiddle/electric/impl/cljs_analyzer_test.clj index eb544b22a..c452ac53b 100644 --- a/test/hyperfiddle/electric/impl/cljs_analyzer_test.clj +++ b/test/hyperfiddle/electric/impl/cljs_analyzer_test.clj @@ -2,87 +2,104 @@ (:require [clojure.test :as t] [cljs.env] [cljs.analyzer] + [missionary.core :as m] [hyperfiddle.electric.impl.cljs-analyzer :as ana])) -;; (comment -;; (def a (ana/analyze-ns 'hyperfiddle.electric.impl.cljs-file-to-analyze)) -;; (-> a ::ana/nses (get 'hyperfiddle.electric.impl.cljs-file-to-analyze) ::ana/refers) -;; (ana/find-var a 'next 'hyperfiddle.electric.impl.cljs-file-to-analyze) -;; (ana/expand (ana/->a) 'cljs.core #{} '(defmacro macrodef [sym] `(def ~sym))) -;; (-> (ana/collect-defs (ana/->a) 'foo '(defmacro macrodef [sym] `(def ~sym))) -;; ::ana/nses (get 'foo)) -;; (-> (ana/collect-defs (ana/->a) 'foo '(fn [] (def x 1))) -;; ::ana/nses (get 'foo)) -;; ) +(comment + (time (let [!a (atom {})] (m/? (ana/analyze-nsT !a {} 'cljs.core)))) + (-> @!a ::ana/nses (get 'cljs.core) ::ana/defs count) + ) -;; (t/deftest ns-expansion -;; (let [ns$ 'hyperfiddle.electric.impl.cljs-file-to-analyze -;; a (ana/analyze-ns ns$)] -;; (t/is (nil? (ana/find-var a 'non ns$))) -;; (t/is (nil? (ana/find-var a 'first ns$))) -;; (t/is (= 'cljs.core/next (::ana/name (ana/find-var a 'nxt ns$)))) -;; (t/are [x] (some? (ana/find-var a x ns$)) -;; 'foo -;; 'bar -;; 'baz -;; 'an-fn -;; 'behind-require -;; 'str -;; 'behind-alias -;; 'behind-require-macros -;; 'behind-require-macro-alias -;; 'behind-required-refer -;; 'behind-required-rename -;; 'behind-require-macro-refer -;; 'behind-require-macro-rename -;; 'behind-include-macros -;; 'behind-refer-macros -;; 'behind-use -;; 'behind-use-renamed -;; 'behind-use-macro -;; 'behind-use-macro-renamed -;; 'behind-auto-alias -;; 'behind-auto-alias-alias -;; 'behind-auto-alias-refer -;; 'nxt))) +(t/deftest ns-expansion + (let [ns$ 'hyperfiddle.electric.impl.cljs-file-to-analyze + !a (ana/->!a) + _ (m/? (ana/analyze-nsT !a {} ns$)) + a @!a] + (t/is (nil? (ana/find-var a 'non ns$))) + (t/is (nil? (ana/find-var a 'first ns$))) + (t/is (= 'cljs.core/next (::ana/name (ana/find-var a 'nxt ns$)))) + (t/are [x] (some? (ana/find-var a x ns$)) + 'foo + 'bar + 'baz + 'an-fn + 'behind-require + 'str + 'behind-alias + 'behind-require-macros + 'behind-require-macro-alias + 'behind-required-refer + 'behind-required-rename + 'behind-require-macro-refer + 'behind-require-macro-rename + 'behind-include-macros + 'behind-refer-macros + 'behind-use + 'behind-use-renamed + 'behind-use-macro + 'behind-use-macro-renamed + 'behind-auto-alias + 'behind-auto-alias-alias + 'behind-auto-alias-refer + 'nxt))) -;; (t/deftest runtime-vars -;; (let [ns$ 'hyperfiddle.electric.impl.cljs-file-to-analyze, -;; a (ana/analyze-ns ns$)] -;; (t/are [x] (nil? (ana/find-var a x ns$)) -;; 'hyperfiddle.electric.impl.cljs-file-to-analyze.runtime/only-macro -;; 'run/only-macro -;; 'only-macro -;; 'next) ; renamed in :refer-clojure -;; (t/are [x] (some? (ana/find-var a x ns$)) -;; 'hyperfiddle.electric.impl.cljs-file-to-analyze.runtime/macro-and-runtime -;; 'run/macro-and-runtime -;; 'macro-and-runtime -;; 'hyperfiddle.electric.impl.cljs-file-to-analyze.runtime/only-runtime -;; 'run/only-runtime -;; 'only-runtime))) +(t/deftest runtime-vars + (let [ns$ 'hyperfiddle.electric.impl.cljs-file-to-analyze, + !a (ana/->!a) + _ (m/? (ana/analyze-nsT !a {} ns$)) + a @!a] + (t/are [x] (nil? (ana/find-var a x ns$)) + 'hyperfiddle.electric.impl.cljs-file-to-analyze.runtime/only-macro + 'run/only-macro + 'only-macro + 'next) ; renamed in :refer-clojure + (t/are [x] (some? (ana/find-var a x ns$)) + 'hyperfiddle.electric.impl.cljs-file-to-analyze.runtime/macro-and-runtime + 'run/macro-and-runtime + 'macro-and-runtime + 'hyperfiddle.electric.impl.cljs-file-to-analyze.runtime/only-runtime + 'run/only-runtime + 'only-runtime))) -;; (t/deftest local-shadowing -;; (let [ns$ 'hyperfiddle.electric.impl.cljs-file-to-analyze -;; a (ana/analyze-ns ns$)] -;; (t/are [x] (nil? (ana/find-var a x ns$)) -;; 'shadowed-by-let -;; 'shadowed-by-let-destructure -;; 'shadowed-by-fn -;; 'shadowed-by-fn-destructure -;; 'shadowed-by-letfn-fn-name -;; 'shadowed-by-letfn-other-fn-name -;; 'shadowed-by-letfn-local))) +(t/deftest local-shadowing + (let [ns$ 'hyperfiddle.electric.impl.cljs-file-to-analyze + !a (ana/->!a) + _ (m/? (ana/analyze-nsT !a {} ns$)) + a @!a] + (t/are [x] (nil? (ana/find-var a x ns$)) + 'shadowed-by-let + 'shadowed-by-let-destructure + 'shadowed-by-fn + 'shadowed-by-fn-destructure + 'shadowed-by-letfn-fn-name + 'shadowed-by-letfn-other-fn-name + 'shadowed-by-letfn-local))) -;; (t/deftest defs-match-official-cljs-analyzer -;; (let [ns$ 'cljs.analyzer -;; a (ana/analyze-ns ns$) -;; c (cljs.env/ensure -;; (cljs.analyzer/analyze-file "cljs/core.cljs") -;; (cljs.analyzer/analyze-file "cljs/analyzer.cljc") -;; @cljs.env/*compiler*)] -;; (t/are [ns$] (= (into #{} (keep (fn [[k v]] (when-not (:anonymous v) k))) -;; (-> c :cljs.analyzer/namespaces (get ns$) :defs)) -;; (set (-> a ::ana/nses (get ns$) ::ana/defs keys))) -;; 'cljs.core -;; 'cljs.analyzer))) +(t/deftest defs-match-official-cljs-analyzer + (let [ns$ 'cljs.analyzer + !a (ana/->!a) + _ (m/? (ana/analyze-nsT !a {} ns$)) + a @!a + c (cljs.env/ensure + (cljs.analyzer/analyze-file "cljs/core.cljs") + (cljs.analyzer/analyze-file "cljs/analyzer.cljc") + @cljs.env/*compiler*)] + (t/are [ns$] (= (into #{} (keep (fn [[k v]] (when-not (:anonymous v) k))) + (-> c :cljs.analyzer/namespaces (get ns$) :defs)) + (set (-> a ::ana/nses (get ns$) ::ana/defs keys))) + 'cljs.core + 'cljs.analyzer))) + +(t/deftest clojure-core-var-found-as-cljs-core-var + (let [ns$ 'cljs.analyzer + !a (ana/->!a) + _ (m/? (ana/analyze-nsT !a {} ns$)) + a @!a] + (t/is (some? (ana/find-var a 'clojure.core/vector ns$))))) + +(t/deftest non-required-var-can-be-found ; e.g. a macro from another ns might have expanded to it + (let [ns$ 'cljs.source-map + !a (ana/->!a) + _ (m/? (ana/analyze-nsT !a {} ns$)) + a @!a] + (t/is (some? (ana/find-var a 'cljs.source-map/encode 'cljs.core))))) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 6d0f145f0..bbb9b9b66 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -2072,5 +2072,5 @@ (let [{:keys [tested skipped]} @stats, all (+ tested skipped)] (prn '===) - (println 'tested tested (str (* (/ tested all) 100) "%")) + (println 'tested tested (str (long (* (/ tested all) 100)) "%")) (println 'skipped skipped (str (long (* (/ skipped all) 100)) "%"))) From 626a2afc140d84b475631036167c4f848666be3f Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 22 Feb 2024 17:10:46 +0100 Subject: [PATCH 109/428] fix tests for an unknown reason the previous tests failed at REPL but worked in CLI/CI. --- test/hyperfiddle/electric_de_test.cljc | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index bbb9b9b66..6fd517863 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -1253,22 +1253,23 @@ #?(:clj (tests "e/fn is undefined in clojure-land" - (tap (try (lang/expand-all {} `(fn [] (e/fn []))) (catch Throwable e (ex-message e)))) + (tap (try (eval '(l/single {} (fn [] (e/fn [])))) + (catch Throwable e (ex-message (ex-cause e))))) % := "Electric code (hyperfiddle.electric-de/fn) inside a Clojure function")) #?(:clj (tests "e/client is undefined in clojure-land" - (tap (try (lang/expand-all {} `(fn [] (e/client []))) (catch Throwable e (ex-message e)))) + (tap (try (eval '(l/single {} (fn [] (e/client [])))) (catch Throwable e (ex-message (ex-cause e))))) % := "Electric code (hyperfiddle.electric-de/client) inside a Clojure function")) #?(:clj (tests "e/server is undefined in clojure-land" - (tap (try (lang/expand-all {} `(fn [] (e/server []))) (catch Throwable e (ex-message e)))) + (tap (try (eval '(l/single {} (fn [] (e/server [])))) (catch Throwable e (ex-message (ex-cause e))))) % := "Electric code (hyperfiddle.electric-de/server) inside a Clojure function")) #?(:clj (tests "e/watch is undefined in clojure-land" - (tap (try (lang/expand-all {} `(fn [] (e/watch (atom :nomatter)))) (catch Throwable e (ex-message e)))) + (tap (try (eval '(l/single {} (fn [] (e/watch (atom :nomatter))))) (catch Throwable e (ex-message (ex-cause e))))) % := "Electric code (hyperfiddle.electric-de/watch) inside a Clojure function")) (tests "cycle" From cc2767c1198cc24f606a8bb3e24952889a265495 Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 22 Feb 2024 17:11:29 +0100 Subject: [PATCH 110/428] compiler: inline more (experimental) --- src/hyperfiddle/electric/impl/lang_de2.clj | 6 +++--- .../electric/impl/compiler_test.cljc | 18 +++++++----------- 2 files changed, 10 insertions(+), 14 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 97239dd5f..1f70b899f 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -813,9 +813,9 @@ (::parent (ts/->node ts e))))) ts (ts/asc ts (::ref nd) ::walked-val true) ; only walk binding once ;; TODO is this necessary? If not we could inline more - ts (cond-> ts (in-a-call? ts e) - (-> (ts/upd (::ref nd) ::in-call #(conj (or % #{}) e)) - (ensure-node (::ref nd)))) + ;; ts (cond-> ts (in-a-call? ts e) + ;; (-> (ts/upd (::ref nd) ::in-call #(conj (or % #{}) e)) + ;; (ensure-node (::ref nd)))) ts (if (seq ctors-e) ; closed over (-> ts (ensure-node (::ref nd)) (ensure-free-node (::ref nd) (first ctors-e)) diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index 22177b1bf..f332b8bac 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -302,10 +302,9 @@ (r/pure :foo)))]) (match (l/test-compile ::Main (let [x (::lang/ctor :foo), y x] (::lang/call y))) - `[(r/cdef 0 [nil] [nil] nil + `[(r/cdef 0 [] [nil] nil (fn [~'frame] - (r/define-node ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) - (r/define-call ~'frame 0 (r/node ~'frame 0)) + (r/define-call ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) (r/join (r/call ~'frame 0)))) (r/cdef 0 [] [] nil (fn [~'frame] @@ -366,11 +365,10 @@ (tests "test-conditionals" ;; ({nil (ctor :y)} :x (ctor :z)) (match (l/test-compile ::Main (case :x nil :y :z)) - `[(r/cdef 0 [nil] [nil] nil + `[(r/cdef 0 [] [nil] nil (fn [~'frame] - (r/define-node ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) (r/define-call ~'frame 0 (r/ap (r/ap (r/pure clojure.core/hash-map) - (r/pure 'nil) (r/node ~'frame 0)) + (r/pure 'nil) (r/pure (r/make-ctor ~'frame ::Main 1))) (r/pure :x) (r/pure (r/make-ctor ~'frame ::Main 2)))) (r/join (r/call ~'frame 0)))) @@ -446,13 +444,11 @@ (match (l/test-compile ::Main (binding [inc dec, dec inc] (inc (dec 0)))) - `[(r/cdef 0 [nil nil] [nil] nil + `[(r/cdef 0 [] [nil] nil (fn [~'frame] - (r/define-node ~'frame 0 (r/lookup ~'frame :clojure.core/dec (r/pure dec))) - (r/define-node ~'frame 1 (r/lookup ~'frame :clojure.core/inc (r/pure inc))) (r/define-call ~'frame 0 (r/pure (r/bind (r/make-ctor ~'frame ::Main 1) - :clojure.core/inc (r/node ~'frame 0) - :clojure.core/dec (r/node ~'frame 1)))) + :clojure.core/inc (r/lookup ~'frame :clojure.core/dec (r/pure dec)) + :clojure.core/dec (r/lookup ~'frame :clojure.core/inc (r/pure inc))))) (r/join (r/call ~'frame 0)))) (r/cdef 0 [] [] nil (fn [~'frame] From 90c5d42f67495b74ec06e57f0b8eaae1fe443828 Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 22 Feb 2024 17:44:09 +0100 Subject: [PATCH 111/428] compiler: cc/letfn --- src/hyperfiddle/electric/impl/lang_de2.clj | 10 +++++++++- test/hyperfiddle/electric_de_test.cljc | 2 +- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 1f70b899f..239671961 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -163,7 +163,8 @@ env2 (reduce add-local env (take-nth 2 bs)) bs2 (->> bs (into [] (comp (partition-all 2) (mapcat (fn [[sym v]] [sym (-expand-all v env2)])))))] - (?meta o `(let* [~(vec (take-nth 2 bs2)) (::letfn ~bs2)] ~(-expand-all (cons 'do body) env2)))) + (recur (?meta o `(let [~(vec (take-nth 2 bs2)) (::letfn ~bs2)] ~(-expand-all (cons 'do body) env2))) + env)) (try) (throw (ex-info "try is TODO" {:o o})) #_(list* 'try (mapv (fn-> -all-in-try env) (rest o))) @@ -493,6 +494,13 @@ (ts/add {:db/id (->id), ::parent ce, ::type ::literal, ::v form}) (?add-source-map e form))] (reduce (fn [ts nx] (analyze nx e env ts)) ts2 refs)) + (::letfn) (let [[_ bs] form, [form refs] (closure env `(letfn* ~bs ~(vec (take-nth 2 bs)))) + e (->id), ce (->id) + ts2 (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) + (ts/add {:db/id ce, ::parent e, ::type ::pure}) + (ts/add {:db/id (->id), ::parent ce, ::type ::literal, ::v form}) + (?add-source-map e form))] + (reduce (fn [ts nx] (analyze nx e env ts)) ts2 refs)) (new) (let [[_ f & args] form, e (->id), ce (->id), cce (->id)] (reduce (fn [ts arg] (analyze arg e env ts)) (-> ts diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 6fd517863..d302e33ae 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -1211,7 +1211,7 @@ ;; TODO cc/letfn -(skip "Inline letfn support" +(tests "Inline letfn support" (with ((l/single {} (tap (letfn [(descent [x] (cond (pos? x) (dec x) (neg? x) (inc x) :else x)) From 1a82675589d3aea7b5304ca2f0fc188394aad77d Mon Sep 17 00:00:00 2001 From: xificurC Date: Fri, 23 Feb 2024 21:48:19 +0100 Subject: [PATCH 112/428] compiler: e/fn multi arity & varargs --- src/hyperfiddle/electric/impl/lang_de2.clj | 7 ++- src/hyperfiddle/electric/impl/runtime_de.cljc | 3 + src/hyperfiddle/electric_de.cljc | 57 +++++++++++++++++-- test/hyperfiddle/electric_de_test.cljc | 57 +++++++++---------- 4 files changed, 87 insertions(+), 37 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 239671961..f40559d1e 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -390,12 +390,13 @@ ::lang :cljs) #_unsited (let [langs (set (vals (::peers env))) vs (->> langs (into #{} (map #(case % - :clj (analyze-clj-symbol sym (get-ns env)) - :cljs (analyze-cljs-symbol sym env)))))] + :clj (assoc (analyze-clj-symbol sym (get-ns env)) ::lang :clj) + :cljs (assoc (analyze-cljs-symbol sym env) ::lang :cljs)))))] (cond (contains? vs nil) (cannot-resolve! env sym) - (> (count vs) 1) (ambiguous-resolve! env sym vs) + (> (count (sequence (comp (map #(select-keys % [::type ::sym])) (distinct)) vs)) 1) (ambiguous-resolve! env sym vs) :else (assoc (first vs) ::lang nil))))))) + (defn ->let-val-e [ts e] (first (get-children-e ts e))) (defn ->let-body-e [ts e] (second (get-children-e ts e))) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 5824e9fef..e63aa8229 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -290,3 +290,6 @@ Returns a peer definition from given definitions and main key. (apply array-map gmap) (if (seq gmap) (first gmap) {})) gmap)) + +(def %arity nil) +(def %argv nil) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 3844c8c2a..af8249215 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -11,8 +11,14 @@ [hyperfiddle.electric-local-def-de :as l]) #?(:cljs (:require-macros hyperfiddle.electric-de))) +#?(:clj (cc/defn dget [v] `(::lang/lookup ~v))) +#?(:clj (cc/defn ->pos-args [n] (eduction (take n) (map dget) (range)))) + (defmacro ctor [expr] `(::lang/ctor ~expr)) -(defmacro $ [F & args] `(binding [~@(interleave (range) args)] (::lang/call ~F))) +(defmacro $ [F & args] + `(binding [~@(interleave (range) args), r/%arity ~(count args)] + (binding [r/%argv [~@(->pos-args (count args))]] + (::lang/call ~F)))) (defmacro pure " Syntax : @@ -35,12 +41,51 @@ Returns the successive states of items described by `incseq`. form (throw (ex-info (str "Electric code (" fn ") inside a Clojure function") (into {:electric-fn fn} (meta &form)))))) -(defmacro fn [bs & body] +(defmacro fn* [bs & body] `(check-electric fn (ctor - (let [~@(interleave bs (eduction (map #(list ::lang/lookup %)) (range)))] + (let [~@(interleave bs (->pos-args (count bs)))] ~@body)))) +#?(:clj (cc/defn- varargs? [args] (boolean (and (seq args) (= '& (-> args pop peek)))))) + +#?(:clj (cc/defn- -build-fn-arity [_?name args body] + [(count args) + `(binding [::lang/rec (ctor (let [~@(interleave args (->pos-args (count args)))] ~@body))] + ($ ~(dget ::lang/rec) ~@(->pos-args (count args))))])) + +#?(:clj (cc/defn- -build-vararg-arity [_?name args body] + (let [npos (-> args count (- 2)), unvarargd (-> args pop pop (conj (peek args))), v (gensym "varargs")] + `(binding [::lang/rec (ctor (let [~@(interleave unvarargd (->pos-args (count unvarargd)))] ~@body))] + ($ ~(dget ::lang/rec) ~@(->pos-args npos) + (let [~v (into [] (drop ~npos) r/%argv)] + (when (seq ~v) ; varargs value is `nil` when no args provided + ~(if (map? (peek args)) + `(if (even? (count ~v)) + (cc/apply hash-map ~v) ; (MapVararg. :x 1) + (merge (cc/apply hash-map (pop ~v)) (peek ~v))) ; (MapVararg. :x 1 {:y 2}) + v)))))))) + +#?(:clj (cc/defn ->narity-set [arities] + (into (sorted-set) (comp (map #(take-while (complement #{'&}) %)) (map count)) arities))) +#?(:clj (cc/defn arity-holes [arity-set] + (remove arity-set (range (reduce max arity-set))))) + +(defmacro fn [& args] + (let [[?name args2] (if (symbol? (first args)) [(first args) (rest args)] [nil args]) + arities (cond-> args2 (vector? (first args2)) list) + arity-set (->narity-set (map first arities)) + {positionals false, varargs true} (group-by (comp varargs? first) arities) + positional-branches (into [] (map (cc/fn [[args & body]] (-build-fn-arity ?name args body))) positionals)] + (list `check-electric `fn + (list ::lang/ctor + `(case r/%arity + ~@(into [] (comp cat cat) [positional-branches]) + ~@(if (seq varargs) + (conj [(arity-holes arity-set) [:arity-mismatch r/%arity]] + (-build-vararg-arity ?name (ffirst varargs) (nfirst varargs))) + [[:arity-mismatch r/%arity]])))))) + (cc/defn ns-qualify [sym] (if (namespace sym) sym (symbol (str *ns*) (str sym)))) #?(:clj (tests @@ -124,7 +169,9 @@ For each tuple in the cartesian product of `table1 table2 ,,, tableN`, calls bod (case bindings [] `(do ~@body) (let [[args exprs] (cc/apply map vector (partition-all 2 bindings))] - `($ (r/bind-args (fn ~args ~@body) + #_`($ (hyperfiddle.electric-de/fn* ~args (do ~@body)) + ~@(mapv (cc/fn [expr] `(join (r/fixed-signals (join (i/items (pure ~expr)))))) exprs)) + `($ (r/bind-args (hyperfiddle.electric-de/fn* ~args ~@body) ~@(map (clojure.core/fn [expr] `(r/fixed-signals (join (i/items (pure ~expr))))) exprs)))))) @@ -158,7 +205,7 @@ this tuple. Returns the concatenation of all body results as a single vector. (seq bindings)))) (cc/defn- -splicev [args] (into [] cat [(pop args) (peek args)])) -(hyperfiddle.electric-de/defn ^::lang/static-vars Apply* [F args] +(hyperfiddle.electric-de/defn Apply* [F args] (let [spliced (-splicev args)] (case (count spliced) 0 ($ F) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index d302e33ae..757122cf7 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -1814,37 +1814,37 @@ (catch ExceptionInfo e e)))) tap tap) (str/includes? (ex-message %) ":foo") := true)) -;; TODO e/fn varargs -(skip "e/fn varargs" - (with ((l/single {} (new (e/fn [x & xs] (tap [x xs])) 1 2 3 4)) tap tap) +(tests "e/fn varargs" + (with ((l/single {} ($ (e/fn [x & xs] (tap [x xs])) 1 2 3 4)) tap tap) % := [1 [2 3 4]])) +;; TODO use recur (skip "e/fn varargs recursion with recur" - (with ((l/single {} (new (e/fn [x & xs] (tap [x xs])) 1 2 3 4)) tap tap) + (with ((l/single {} ($ (e/fn [x & xs] (tap [x xs])) 1 2 3 4)) tap tap) % := [1 [2 3 4]])) +;; TODO try/catch (skip "e/fn varargs recur is arity-checked" (with ((l/single {} (tap (try (new (e/fn [x & xs] (recur)) 1 2 3) (catch ExceptionInfo e e)))) tap tap) (ex-message %) := "You `recur`d in with 0 arguments but it has 2 positional arguments")) -;; TODO e/fn map vararg -;; (l/defn MapVararg [& {:keys [x] :or {x 1} :as mp}] [x mp]) -(skip "map vararg with no args is nil" - (with ((l/single {} (tap (MapVararg.))) tap tap) +(e/defn MapVararg [& {:keys [x] :or {x 1} :as mp}] [x mp]) +(tests "map vararg with no args is nil" + (with ((l/single {} (tap ($ MapVararg))) tap tap) % := [1 nil])) -(skip "map vararg with kw args" - (with ((l/single {} (tap (MapVararg. :x 2))) tap tap) +(tests "map vararg with kw args" + (with ((l/single {} (tap ($ MapVararg :x 2))) tap tap) % := [2 {:x 2}])) -(skip "map vararg with map arg" - (with ((l/single {} (tap (MapVararg. {:x 2}))) tap tap) +(tests "map vararg with map arg" + (with ((l/single {} (tap ($ MapVararg {:x 2}))) tap tap) % := [2 {:x 2}])) -(skip "map vararg with mixture" - (with ((l/single {} (tap (MapVararg. :y 3 {:x 2}))) tap tap) +(tests "map vararg with mixture" + (with ((l/single {} (tap ($ MapVararg :y 3 {:x 2}))) tap tap) % := [2 {:x 2, :y 3}])) -(skip "map vararg trailing map takes precedence" - (with ((l/single {} (tap (MapVararg. :x 3 {:x 2}))) tap tap) +(tests "map vararg trailing map takes precedence" + (with ((l/single {} (tap ($ MapVararg :x 3 {:x 2}))) tap tap) % := [2 {:x 2}])) -(skip "map vararg with positional arguments" - (with ((l/single {} (tap (new (e/fn [a & {:keys [x]}] [a x]) 1 :x 2))) tap tap) +(tests "map vararg with positional arguments" + (with ((l/single {} (tap ($ (e/fn [a & {:keys [x]}] [a x]) 1 :x 2))) tap tap) % := [1 2])) ;; TODO try/catch @@ -1855,12 +1855,11 @@ (e/defn One [x] x) (e/defn Two [x y] [x y]) -;; (l/defn VarArgs [x & xs] [x xs]) +(e/defn VarArgs [x & xs] [x xs]) (tests "($ One 1)" (with ((l/single {} (tap ($ One 1))) tap tap) % := 1)) -;; TODO e/fn varargs -(skip "($ VarArgs 1 2 3)" +(tests "($ VarArgs 1 2 3)" (with ((l/single {} (tap ($ VarArgs 1 2 3))) tap tap) % := [1 [2 3]])) (skip "varargs arity is checked" @@ -1888,19 +1887,19 @@ (ex-message %) := "You called Two with 3 arguments but it only supports 2")) ;; TODO e/fn multi-arity -(skip "multi-arity e/fn" - (with ((l/single {} (tap (new (e/fn ([_] :one) ([_ _] :two)) 1))) tap tap) +(tests "multi-arity e/fn" + (with ((l/single {} (tap ($ (e/fn ([_] :one) ([_ _] :two)) 1))) tap tap) % := :one)) -(skip "multi-arity e/fn" - (with ((l/single {} (tap (new (e/fn ([_] :one) ([_ _] :two)) 1 2))) tap tap) +(tests "multi-arity e/fn" + (with ((l/single {} (tap ($ (e/fn ([_] :one) ([_ _] :two)) 1 2))) tap tap) % := :two)) -(skip "multi-arity e/fn" - (with ((l/single {} (tap (new (e/fn ([_]) ([_ & xs] (mapv inc xs))) 1 2 3 4))) tap tap) +(tests "multi-arity e/fn" + (with ((l/single {} (tap ($ (e/fn ([_]) ([_ & xs] (mapv inc xs))) 1 2 3 4))) tap tap) % := [3 4 5])) -(skip "multi-arity e/fn" +(tests "multi-arity e/fn" (with ((l/single {} (tap (e/apply (e/fn ([_] :one) ([_ _] :two)) 1 [2]))) tap tap) % := :two)) -(skip "multi-arity e/fn" +(tests "multi-arity e/fn" (with ((l/single {} (tap (e/apply (e/fn ([_]) ([_ & xs] (mapv inc xs))) 1 2 [3 4]))) tap tap) % := [3 4 5])) From 1be79552e61973c28faf3931de13c301f5ca3b70 Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 26 Feb 2024 09:14:43 +0100 Subject: [PATCH 113/428] fix tests --- .../electric/impl/expand_de_test.cljc | 17 +++++------------ test/hyperfiddle/electric_de_test.cljc | 4 ++-- 2 files changed, 7 insertions(+), 14 deletions(-) diff --git a/test/hyperfiddle/electric/impl/expand_de_test.cljc b/test/hyperfiddle/electric/impl/expand_de_test.cljc index 2c26054da..2a5c3061d 100644 --- a/test/hyperfiddle/electric/impl/expand_de_test.cljc +++ b/test/hyperfiddle/electric/impl/expand_de_test.cljc @@ -70,18 +70,11 @@ (all '(fn* [x] x)) := '(fn* ([x] x)) ; fn* can come from elsewhere with a non-wrapped single arity (has-line-meta? (all '(fn* [x] x))) := true - (let [x (all '(letfn [(foo [with-open] (with-open 1)) - (bar [x] (-> x inc)) - (baz [x] (->> x)) - (->> [x] x)] - (-> (->> x) inc)))] - x := '(let* [[foo bar baz ->>] - (::l/letfn [foo (fn* foo ([with-open] (with-open 1))) - bar (fn* bar ([x] (-> x inc))) - baz (fn* baz ([x] (->> x))) - ->> (fn* ->> ([x] x))])] - (inc (->> x))) - (has-line-meta? x) := true) + (has-line-meta? (all '(letfn [(foo [with-open] (with-open 1)) + (bar [x] (-> x inc)) + (baz [x] (->> x)) + (->> [x] x)] + (-> (->> x) inc)))) := true (let [[f v :as x] (all '(set! (.-x (-> [(java.awt.Point. (-> 0 inc) 2)] first)) (-> 2 inc)))] (first f) := 'fn* diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 757122cf7..c856085a3 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -1362,8 +1362,8 @@ % := 0))) #?(:cljs (tests "set! with electric value" - (with ((l/single {} (tap (let [o (js/Object.)] - (set! (.-x o) (new (e/fn [] 0)))))) tap tap) + (with ((l/single {::lang/print-source true} (tap (let [o (js/Object.)] + (set! (.-x o) ($ (e/fn [] 0)))))) tap tap) % := 0))) ;; TODO e/fn arity check, try/catch From d2a6c02d6f871850395da5e54643f40206c1bcc0 Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 26 Feb 2024 09:41:39 +0100 Subject: [PATCH 114/428] e/defn: support docstring, carry meta --- src/hyperfiddle/electric_de.cljc | 19 +++++++------------ test/hyperfiddle/electric_de_test.cljc | 4 ++-- 2 files changed, 9 insertions(+), 14 deletions(-) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index af8249215..f748dde83 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -92,24 +92,19 @@ Returns the successive states of items described by `incseq`. (ns-qualify 'foo) := `foo (ns-qualify 'a/b) := 'a/b)) -(defmacro defn [nm bs & body] - (let [env (merge (meta nm) (lang/normalize-env &env) l/web-config) - expanded (lang/expand-all env `(fn ~bs ~@body)) +(defmacro defn [nm & fdecl] + (let [[_defn sym] (macroexpand `(cc/defn ~nm ~@fdecl)) + env (merge (meta nm) (lang/normalize-env &env) l/web-config) + nm2 (vary-meta nm merge (meta sym)) + expanded (lang/expand-all env `(fn ~nm2 ~@(cond-> fdecl (string? (first fdecl)) next))) _ (when (::lang/print-expansion env) (fipp.edn/pprint expanded)) ts (lang/analyze expanded '_ env (ts/->ts {::lang/->id (lang/->->id)})) ts (lang/analyze-electric env ts) ctors (mapv #(lang/emit-ctor ts % env (-> nm ns-qualify keyword)) (lang/get-ordered-ctors-e ts)) deps (lang/emit-deps ts 0) - nm (with-meta nm `{::lang/deps '~deps})] + nm3 (vary-meta nm2 assoc ::lang/deps `'~deps)] (when (::lang/print-source env) (fipp.edn/pprint ctors)) - `(def ~nm ~ctors))) - -#_(defmacro defn [nm bs & body] - ;; TODO cleanup env setup - (let [env (merge (lang/normalize-env &env) l/web-config) - ts (lang/analyze* env `(hyperfiddle.electric-de/fn ~bs ~@body)) - nm2 (vary-meta nm assoc ::lang/deps (lang/->deps ts))] - `(def ~nm2 ~(lang/compile* ts)))) + `(def ~nm3 ~ctors))) (defmacro amb " Syntax : diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index c856085a3..b9679dd63 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -799,7 +799,7 @@ (instance? clojure.lang.Var$Unbound *1) := true) ) -;; TODO +;; TODO try/catch (skip "In Electric, accessing an unbound var throws a userland exception" ;; An unbound var is either: ;; - an uninitialized p/def, @@ -810,7 +810,7 @@ ;; TODO e/defn docstring #?(:clj - (skip ; GG: IDE doc on hover support + (tests ; GG: IDE doc on hover support "Vars created with e/defn have the same metas as created with cc/defn" (e/defn Documented "doc" [a b c]) (select-keys (meta (var Documented)) [:name :doc :arglists]) From 4e6b532a8c35236f74ac85aefb9e7e307203c82c Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 26 Feb 2024 10:08:39 +0100 Subject: [PATCH 115/428] tests cleanup --- test/hyperfiddle/electric_de_test.cljc | 18 ++++-------------- 1 file changed, 4 insertions(+), 14 deletions(-) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index b9679dd63..a920744a1 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -1210,7 +1210,6 @@ (instance? Cancelled %) := true)) -;; TODO cc/letfn (tests "Inline letfn support" (with ((l/single {} (tap (letfn [(descent [x] (cond (pos? x) (dec x) (neg? x) (inc x) @@ -1223,14 +1222,7 @@ % := [false false true true] % := [false false true true])) -;; TODO cc/letfn -(skip - (with ((l/single {} (try (letfn [(foo [])] - (tap (e/watch (atom 1)))) - (catch Throwable t (prn t)))) tap tap) - % := 1)) - -;; TODO cc/letfn, electric binding conveyance +;; TODO electric binding conveyance (skip "Inline letfn support" (def !state (atom 0)) (l/def global) @@ -1308,9 +1300,8 @@ % := 2 % := 2))) -;; TODO cc/letfn -(skip "letfn body is electric" - (l/def z 3) +(tests "letfn body is electric" + (def z 3) (def !x (atom 4)) (with ((l/single {} (let [y 2] (letfn [(f [x] (g x)) (g [x] [x y z])] (tap (f (e/watch !x)))))) tap tap) % := [4 2 3] @@ -1867,8 +1858,7 @@ (catch ExceptionInfo e e)))) tap tap) (ex-message %) := "You called VarArgs with 0 arguments but it only supports 1")) -;; TODO e/fn varargs -(skip "e/apply" +(tests "e/apply" (with ((l/single {} (tap (e/apply VarArgs [1 2 3]))) tap tap) % := [1 [2 3]])) (tests "e/apply" From adb4f589395638a0af5780e39dc630f1e2dbf5ea Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 26 Feb 2024 11:54:25 +0100 Subject: [PATCH 116/428] cc/fn binding conveyance wip, glitch test --- src/hyperfiddle/electric/impl/lang_de2.clj | 3 +- test/hyperfiddle/electric_de_test.cljc | 52 ++++++++++++++++++++-- 2 files changed, 49 insertions(+), 6 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index f40559d1e..283fd3b49 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -262,8 +262,7 @@ [env form] (let [refered-evars (atom {}) refered-lexical (atom {}) - edef? (fn [ast] (or (#{::node ::node-signifier} (-> ast :meta ::type)) - (#{::node ::node-signifier} (-> ast :info :meta ::type)))) + edef? (fn [ast] (and (= :var (:op ast)) (not (-> ast :env :def-var)))) dynamic? (fn [ast] (or (:assignable? ast) ; clj (:dynamic (:meta (:info ast))) ; cljs )) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index a920744a1..32f9b7c3b 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -4,6 +4,7 @@ [hyperfiddle.electric-local-def-de :as l] [hyperfiddle.electric.impl.io :as electric-io] [hyperfiddle.electric.impl.lang-de2 :as lang] + [hyperfiddle.electric.impl.runtime-de :as r] [contrib.cljs-target :refer [do-browser]] [clojure.string :as str] [missionary.core :as m]) @@ -73,8 +74,9 @@ (with ((l/single {} (tap (loop [x 1] (if (odd? x) (recur (dec x)) x)))) tap tap) % := 0)) -(tests "def" - (with ((l/single {} (def DEFD 1)) tap tap)) +;; TODO cljs def expands to set! which expands to cc/fn which passes DEFD as argument and breaks +#_(tests "def" + (with ((l/single {::lang/print-source true} (def DEFD 1)) tap tap)) DEFD := 1) ;;; MAIN ELECTRIC TEST SUITE @@ -1169,6 +1171,47 @@ % := [1 :b [:local 1] [:global 1]] % := [1 :b '(:c :d) [:local 1] [:global 1]])) +(comment + (tests + (def !state (atom 0)) + (def global) + (with ((l/single {::lang/print-source true} + (let [state (e/watch !state)] + (tap [state state]) + (tap [state state]))) + tap tap) + % := [0 0] + % := [0 0] + (swap! !state inc) + % := [1 0] ; glitch + % := [1 1] + % := [1 1])) + ;; compiles to + [(r/cdef 0 [nil] [nil] nil + (fn [frame] + (r/define-node frame 0 (r/join (r/ap (r/lookup frame ::r/fixed-signals (r/pure r/fixed-signals)) + (r/ap (r/lookup frame ::m/watch (r/pure m/watch)) + (r/lookup frame ::!state (r/pure !state)))))) + (r/define-call frame 0 (r/join (r/ap (r/lookup frame ::r/pure (r/pure r/pure)) + (r/pure (doto (r/make-ctor frame ::l/Main 1) + (r/define-free 0 (r/node frame 0)))) + (r/pure (doto (r/make-ctor frame ::l/Main 2) + (r/define-free 0 (r/node frame 0))))))) + (r/join (r/call frame 0)))) + (r/cdef 1 [] [] nil + (fn [frame] + (r/join (r/ap (r/lookup frame ::r/drain (r/pure r/drain)) + (r/pure (r/ap (r/pure RCF__tap) + (r/ap (r/pure vector) + (r/free frame 0) + (r/free frame 0)))))))) + (r/cdef 1 [] [] nil + (fn [frame] + (r/ap (r/pure RCF__tap) + (r/ap (r/pure vector) + (r/free frame 0) + (r/free frame 0)))))]) + (tests "cc/fn lexical bindings are untouched" (with ((l/single {} (let [a 1 b 2 @@ -1353,7 +1396,7 @@ % := 0))) #?(:cljs (tests "set! with electric value" - (with ((l/single {::lang/print-source true} (tap (let [o (js/Object.)] + (with ((l/single {} (tap (let [o (js/Object.)] (set! (.-x o) ($ (e/fn [] 0)))))) tap tap) % := 0))) @@ -1412,7 +1455,8 @@ (reset! !n 20) % := 2432902008176640000))) -(tests "clojure def inside electric code" +;; TODO cljs def expands to set! which expands to cc/fn which passes --foo as argument and breaks +#_(tests "clojure def inside electric code" (def !x (atom 0)) (with ((l/single {} (def --foo (tap (e/watch !x)))) tap tap) % := 0, --foo := 0 From 32c7c6f553f17ce6152ac78ee6076001f9134489 Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 27 Feb 2024 14:47:46 +0100 Subject: [PATCH 117/428] compiler: def, failing test for `(set! a-root 1)` in cljs --- src/hyperfiddle/electric/impl/lang_de2.clj | 8 ++++++-- test/hyperfiddle/electric_de_test.cljc | 17 ++++++++++++----- 2 files changed, 18 insertions(+), 7 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 283fd3b49..2611e68cc 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -557,8 +557,12 @@ (def) (let [[_ sym v] form] (case (->env-type env) :clj (recur `((fn* ([x#] (def ~sym x#))) ~v) pe env ts) - :cljs (do (def-sym-in-cljs-compiler! sym (get-ns env)) - (recur `(set! ~sym ~v) pe env ts)))) + :cljs (let [e (->id), ce (->id)] + (def-sym-in-cljs-compiler! sym (get-ns env)) + (recur v e env + (-> ts (ts/add {:db/id e, ::parent pe, ::type ::ap}) + (ts/add {:db/id ce, ::parent e, ::type ::pure}) + (ts/add {:db/id (->id), ::parent ce, ::type ::literal, ::v `(fn [v#] (set! ~sym v#))})))))) (set!) (let [[_ target v] form] (recur `((fn* ([v#] (set! ~target v#))) ~v) pe env ts)) (::ctor) (let [e (->id), ce (->id)] (recur (list ::site nil (second form)) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 32f9b7c3b..2cd7f5143 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -74,9 +74,8 @@ (with ((l/single {} (tap (loop [x 1] (if (odd? x) (recur (dec x)) x)))) tap tap) % := 0)) -;; TODO cljs def expands to set! which expands to cc/fn which passes DEFD as argument and breaks -#_(tests "def" - (with ((l/single {::lang/print-source true} (def DEFD 1)) tap tap)) +(tests "def" + (with ((l/single {} (def DEFD 1)) tap tap)) DEFD := 1) ;;; MAIN ELECTRIC TEST SUITE @@ -1400,6 +1399,15 @@ (set! (.-x o) ($ (e/fn [] 0)))))) tap tap) % := 0))) +;; TODO `set!` expands to cc/fn which tries to convey `a-root` +;; note: transitively the same applies to `(cc/fn [] (set! a-root 2))` +#?(:cljs + (skip "set! to alter root binding" + (def a-root 1) + (with ((l/single {} (set! a-root 2)) tap tap)) + (instance? Cancelled %) := true + a-root := 2)) + ;; TODO e/fn arity check, try/catch (skip "e/fn arity check" (with ((l/single {} (try (new (e/fn [x y z] (throw (ex-info "nope" {}))) 100 200 300 400) @@ -1455,8 +1463,7 @@ (reset! !n 20) % := 2432902008176640000))) -;; TODO cljs def expands to set! which expands to cc/fn which passes --foo as argument and breaks -#_(tests "clojure def inside electric code" +(tests "clojure def inside electric code" (def !x (atom 0)) (with ((l/single {} (def --foo (tap (e/watch !x)))) tap tap) % := 0, --foo := 0 From 1acf7bd6ed39f6a167463c2a3d98ebc280f00d46 Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 27 Feb 2024 16:56:20 +0100 Subject: [PATCH 118/428] compiler: goog calls, peer-safe new --- .../electric/impl/cljs_analyzer.clj | 8 +++-- src/hyperfiddle/electric/impl/lang_de2.clj | 32 +++++++++++-------- test/hyperfiddle/electric_de_test.cljc | 6 ++-- test/hyperfiddle/goog_calls_test_de.cljc | 20 ++++++++++++ 4 files changed, 47 insertions(+), 19 deletions(-) create mode 100644 test/hyperfiddle/goog_calls_test_de.cljc diff --git a/src/hyperfiddle/electric/impl/cljs_analyzer.clj b/src/hyperfiddle/electric/impl/cljs_analyzer.clj index 78fc4c6ff..c27195413 100644 --- a/src/hyperfiddle/electric/impl/cljs_analyzer.clj +++ b/src/hyperfiddle/electric/impl/cljs_analyzer.clj @@ -181,6 +181,8 @@ (defn keep-if [v pred] (when (pred v) v)) (defn macro-var? [vr] (and (instance? clojure.lang.Var vr) (.isMacro ^clojure.lang.Var vr))) +(defn safe-requiring-resolve [sym] (try (requiring-resolve sym) (catch java.io.FileNotFoundException _))) + ;;;;;;;;;;;;;;;;;; ;;; PUBLIC API ;;; ;;;;;;;;;;;;;;;;;; @@ -218,12 +220,12 @@ (-> (cond (simple-symbol? sym) (or (do (safe-require ns$) (some-> (find-ns ns$) (find-ns-var sym))) - (when-some [ref (-> a ::nses (get ns$) ::refers (get sym))] (requiring-resolve ref)) - (when-some [ref (-> a ::nses (get ns$) ::refer-macros (get sym))] (requiring-resolve ref)) + (when-some [ref (-> a ::nses (get ns$) ::refers (get sym))] (safe-requiring-resolve ref)) + (when-some [ref (-> a ::nses (get ns$) ::refer-macros (get sym))] (safe-requiring-resolve ref)) (when-not (get (-> a ::nses (get ns$) ::excludes) sym) (find-ns-var (find-ns 'clojure.core) sym))) (#{"cljs.core" "clojure.core"} (namespace sym)) - (requiring-resolve sym) + (safe-requiring-resolve sym) :else (let [sym-ns$ (-> sym namespace symbol), sym-base$ (-> sym name symbol)] diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 2611e68cc..70b2352a9 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -60,7 +60,8 @@ (serialized-require (ns-name *ns*)) (if-some [mac (when-some [mac (resolve env (first o))] (when (.isMacro ^clojure.lang.Var mac) mac))] (apply mac o env (next o)) - (macroexpand-1 o))) ; e.g. (Math/abs 1) will expand to (. Math abs 1) + (try (macroexpand-1 o) ; e.g. (Math/abs 1) will expand to (. Math abs 1) + (catch ClassNotFoundException _ o)))) ; e.g. (goog.color/hslToHex ..) won't expand on clj (def !a (cljs-ana/->!a)) @@ -388,9 +389,11 @@ :cljs (assoc (analyze-cljs-symbol sym env) ::lang :cljs) #_unsited (let [langs (set (vals (::peers env))) - vs (->> langs (into #{} (map #(case % - :clj (assoc (analyze-clj-symbol sym (get-ns env)) ::lang :clj) - :cljs (assoc (analyze-cljs-symbol sym env) ::lang :cljs)))))] + vs (->> langs + (into #{} + (map #(case % + :clj (some-> (analyze-clj-symbol sym (get-ns env)) (assoc ::lang :clj)) + :cljs (some-> (analyze-cljs-symbol sym env) (assoc ::lang :cljs))))))] (cond (contains? vs nil) (cannot-resolve! env sym) (> (count (sequence (comp (map #(select-keys % [::type ::sym])) (distinct)) vs)) 1) (ambiguous-resolve! env sym vs) :else (assoc (first vs) ::lang nil))))))) @@ -501,15 +504,18 @@ (ts/add {:db/id (->id), ::parent ce, ::type ::literal, ::v form}) (?add-source-map e form))] (reduce (fn [ts nx] (analyze nx e env ts)) ts2 refs)) - (new) (let [[_ f & args] form, e (->id), ce (->id), cce (->id)] - (reduce (fn [ts arg] (analyze arg e env ts)) - (-> ts - (ts/add {:db/id e, ::parent pe, ::type ::ap}) - (ts/add {:db/id ce, ::parent e, ::type ::pure}) - (ts/add {:db/id cce, ::parent ce, ::type ::literal, - ::v (let [gs (repeatedly (count args) gensym)] - `(fn [~@gs] (new ~f ~@gs)))})) - args)) + (new) (let [[_ f & args] form, current (get (::peers env) (::current env))] + (if (or (nil? current) (= (->env-type env) current)) + (let [e (->id), ce (->id), cce (->id),] + (reduce (fn [ts arg] (analyze arg e env ts)) + (-> ts + (ts/add {:db/id e, ::parent pe, ::type ::ap}) + (ts/add {:db/id ce, ::parent e, ::type ::pure}) + (ts/add {:db/id cce, ::parent ce, ::type ::literal, + ::v (let [gs (repeatedly (count args) gensym)] + `(fn [~@gs] (new ~f ~@gs)))})) + args)) + (recur `[~@args] pe env ts))) ;; (. java.time.Instant now) ;; (. java.time.Instant ofEpochMilli 1) ;; (. java.time.Instant (ofEpochMilli 1)) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 2cd7f5143..bb735b873 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -6,6 +6,7 @@ [hyperfiddle.electric.impl.lang-de2 :as lang] [hyperfiddle.electric.impl.runtime-de :as r] [contrib.cljs-target :refer [do-browser]] + #?(:cljs [hyperfiddle.goog-calls-test-de]) [clojure.string :as str] [missionary.core :as m]) #?(:cljs (:require-macros [hyperfiddle.electric-de-test :refer [skip tests]])) @@ -1838,11 +1839,10 @@ ;; TODO cljs #?(:cljs (do-browser - (skip "goog module calls don't trigger warnings" + (tests "goog module calls don't trigger warnings" ;; this includes a goog test namespace, so if there are warnings the CI will blow up. ;; The blow up is configured as a shadow build hook in `hyperfiddle.browser-test-setup` - (with ((l/single {} (tap (try (hyperfiddle.goog-calls-test/Main.) :ok - (catch :default ex (ex-message ex))))) tap tap) + (with ((l/single {} (tap (case ($ hyperfiddle.goog-calls-test-de/Main) :ok))) tap tap) % := :ok)))) ;; TODO try/catch diff --git a/test/hyperfiddle/goog_calls_test_de.cljc b/test/hyperfiddle/goog_calls_test_de.cljc new file mode 100644 index 000000000..e0c19c066 --- /dev/null +++ b/test/hyperfiddle/goog_calls_test_de.cljc @@ -0,0 +1,20 @@ +(ns hyperfiddle.goog-calls-test-de + (:require [hyperfiddle.electric-de :as e] + [hyperfiddle.electric.impl.lang-de2 :as lang] + #?(:cljs [goog.color]) + #?(:cljs [goog.math :as gm]) + #?(:cljs [goog.string.format]) + #?(:cljs [goog.string :refer (format)])) + #?(:cljs (:import [goog Uri] + [goog.events EventType]))) + +(e/defn Main [] + (e/client + (list + (goog.color/hslToHex 0.5 0.5 0.5) + (Uri. "http://example.com") + EventType.CLICK + goog.events.EventType.CLICK + (gm/clamp -1 0 5) + (format "%4d" 12) + (js/matchMedia (e/watch (atom "(max-width: 600px)")))))) From 867abd8a8cc7146ae6f87bcecdac577f9602f351 Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 28 Feb 2024 11:00:23 +0100 Subject: [PATCH 119/428] compiler: type hint propagation in `.` calls --- src/contrib/debug.cljc | 4 +++- src/hyperfiddle/electric/impl/lang_de2.clj | 7 ++++++- test/hyperfiddle/electric_de_test.cljc | 7 ++----- 3 files changed, 11 insertions(+), 7 deletions(-) diff --git a/src/contrib/debug.cljc b/src/contrib/debug.cljc index 12a4bb4fb..2bab4be84 100644 --- a/src/contrib/debug.cljc +++ b/src/contrib/debug.cljc @@ -19,7 +19,9 @@ (defmacro dbg-when [form & body] `(binding [*dbg* ~form] ~@body)) (defmacro dbgv [form] - `(let [args# [~@form], v# ~form] (prn '~form '~'==> (cons '~(first form) (rest args#)) '~'==> v#) v#)) + `(if *dbg* + (let [args# [~@form], v# ~form] (prn '~form '~'==> (cons '~(first form) (rest args#)) '~'==> v#) v#) + ~form)) (defmacro dbgc [[op & args :as form]] `(let [op# ~op, args# ~args, ret# (apply op# args#)] diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 70b2352a9..836657dfc 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -447,13 +447,18 @@ (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form}))))) +(defn meta-of-key [mp k] (-> mp keys set (get k) meta)) +(defn gensym-with-local-meta [env k] + (let [g (gensym (if (instance? clojure.lang.Named k) (name k) "o")), mt (meta-of-key (:locals env) k)] + (with-meta g (merge mt (meta k))))) + (defn ->obj-method-call [o method method-args pe env {{::keys [->id]} :o :as ts}] (let [e (->id), ce (->id)] (reduce (fn [ts form] (analyze form e env ts)) (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) (ts/add {:db/id ce, ::parent e, ::type ::pure}) (ts/add {:db/id (->id), ::parent ce, ::type ::literal, - ::v (let [oo (gensym "o"), margs (repeatedly (count method-args) gensym)] + ::v (let [[oo & margs] (mapv #(gensym-with-local-meta env %) (cons o method-args))] `(fn [~oo ~@margs] (. ~oo ~method ~@margs)))})) (cons o method-args)))) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index bb735b873..41596f9a2 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -2006,14 +2006,11 @@ ]))) tap tap) % := ["src" 1 1.0]))) -;; TODO type hint propagation #?(:cljs - (skip "js interop" + (tests "js interop" (with ((l/single {} (let [^js o #js {:a 1 :aPlus (fn [n] (inc n))}] - (tap [(.aPlus o 1) ; instance method - (.-a o) ; field access - ]))) tap tap) + (tap [(.aPlus o 1) (.-a o)]))) tap tap) % := [2 1]))) ;; TODO cljs From d90c252c22080e920cbc41ab4cedc11300ce201a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Wed, 28 Feb 2024 16:41:07 +0100 Subject: [PATCH 120/428] e/fn equality --- src/hyperfiddle/electric/impl/runtime_de.cljc | 639 ++++++++++++++---- src/hyperfiddle/electric_de.cljc | 2 +- .../electric/impl/runtime_test.cljc | 20 +- 3 files changed, 538 insertions(+), 123 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index e63aa8229..302791c79 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -2,33 +2,66 @@ (:require [hyperfiddle.incseq :as i] [missionary.core :as m] [contrib.assert :as ca]) - #?(:clj (:import (clojure.lang IFn IDeref)))) + (:import #?(:clj (clojure.lang IFn IDeref)) + missionary.Cancelled)) -(deftype Peer [step done defs ^objects state] - IFn - (#?(:clj invoke :cljs -invoke) [_] - (prn :cancel-peer) +(set! *warn-on-reflection* true) + +(defn pst [e] + #?(:clj (.printStackTrace ^Throwable e) + :cljs (.error js/console e))) + +(def peer-slot-root 0) +(def peer-slot-input-process 1) +(def peer-slot-input-busy 2) +(def peer-slot-output-pending 9) +(def peer-slot-result 10) +(def peer-slots 11) - ) +(declare peer-cancel peer-transfer) + +(deftype Peer [site defs step done queues pushes state] + IFn + (#?(:clj invoke :cljs -invoke) [this] + (peer-cancel this)) IDeref - (#?(:clj deref :cljs -deref) [_] - (prn :transfer-peer) + (#?(:clj deref :cljs -deref) [this] + (peer-transfer this))) - )) +;; Pure | Ap | Effect | Join | Port +(defprotocol Expr + (deps [_]) ;; returns #{Port} + (flow [_])) ;; returns incseq (defn invariant [x] (m/cp x)) -(deftype Pure [values] +(deftype Pure [values + ^:unsynchronized-mutable ^:mutable hash-memo] + #?(:clj Object) + #?(:cljs IHash) + (#?(:clj hashCode :cljs -hash) [_] + (if-some [h hash-memo] + h (set! hash-memo + (hash-combine (hash Pure) + (hash-ordered-coll values))))) + #?(:cljs IEquiv) + (#?(:clj equals :cljs -equiv) [_ other] + (and (instance? Pure other) + (= values (.-values ^Pure other)))) + Expr + (deps [_] #{}) + (flow [_] (apply i/fixed (map invariant values))) IFn - (#?(:clj invoke :cljs -invoke) [_ step done] - ((apply i/fixed (map invariant values)) step done))) + (#?(:clj invoke :cljs -invoke) [this step done] + ((flow this) step done))) -(def pure " +(defn pure " (FN (IS VOID)) (FN (IS T) T) (FN (IS T) T T) (FN (IS T) T T T) -" (comp ->Pure vector)) +" [& values] + (->Pure values nil)) (defn invoke ([f] (f)) @@ -38,21 +71,59 @@ ([f a b c d] (f a b c d)) ([f a b c d & es] (apply f a b c d es))) -(deftype Ap [inputs] +(deftype Ap [inputs + ^:unsynchronized-mutable ^:mutable hash-memo] + #?(:clj Object) + #?(:cljs IHash) + (#?(:clj hashCode :cljs -hash) [_] + (if-some [h hash-memo] + h (set! hash-memo + (hash-combine (hash Ap) + (hash-ordered-coll inputs))))) + #?(:cljs IEquiv) + (#?(:clj equals :cljs -equiv) [_ other] + (and (instance? Ap other) + (= inputs (.-inputs ^Ap other)))) + Expr + (deps [_] (into #{} (mapcat deps) inputs)) + (flow [_] (apply i/latest-product invoke (map flow inputs))) IFn - (#?(:clj invoke :cljs -invoke) [_ step done] - ((apply i/latest-product invoke inputs) step done))) + (#?(:clj invoke :cljs -invoke) [this step done] + ((flow this) step done))) -(def ap " +(defn ap " (FN (IS T) (IS (FN T))) (FN (IS T) (IS (FN T A)) (IS A)) (FN (IS T) (IS (FN T A B)) (IS A) (IS B)) (FN (IS T) (IS (FN T A B C)) (IS A) (IS B) (IS C)) -" (comp ->Ap vector)) +" [& inputs] + (->Ap inputs nil)) + +(deftype Join [input ^:unsynchronized-mutable ^:mutable hash-memo] + #?(:clj Object) + #?(:cljs IHash) + (#?(:clj hashCode :cljs -hash) [_] + (if-some [h hash-memo] + h (set! hash-memo + (hash-combine (hash Join) + (hash input))))) + #?(:cljs IEquiv) + (#?(:clj equals :cljs -equiv) [_ other] + (and (instance? Join other) + (= input (.-input ^Join other)))) + Expr + (deps [_] (deps input)) + (flow [_] (i/latest-concat (flow input))) + IFn + (#?(:clj invoke :cljs -invoke) [this step done] + ((flow this) step done))) -(def join " +(defn join " (FN (IS T) (IS (IS T))) -" i/latest-concat) +" [input] (->Join input nil)) + +(defn effect [incseq] + (join (pure incseq))) (def fixed-signals " (FN (IS VOID)) @@ -88,7 +159,35 @@ (def cdef ->Cdef) -(deftype Ctor [^Peer peer key idx ^objects free env]) +(deftype Ctor [peer key idx ^objects free env + ^:unsynchronized-mutable ^:mutable hash-memo] + #?(:clj Object) + #?(:cljs IHash) + (#?(:clj hashCode :cljs -hash) [_] + (if-some [h hash-memo] + h (loop [h (-> (hash peer) + (hash-combine (hash key)) + (hash-combine (hash idx)) + (hash-combine (hash env))) + i 0] + (if (== i (alength free)) + (set! hash-memo h) + (recur (hash-combine h (hash (aget free i))) + (inc i)))))) + #?(:cljs IEquiv) + (#?(:clj equals :cljs -equiv) [_ other] + (and (instance? Ctor other) + (= peer (.-peer ^Ctor other)) + (= key (.-key ^Ctor other)) + (= idx (.-idx ^Ctor other)) + (= env (.-env ^Ctor other)) + (let [n (alength free) + ^objects f (.-free ^Ctor other)] + (if (== n (alength f)) + (loop [i 0] + (if (== i n) + true (if (= (aget free i) (aget f i)) + (recur (inc i)) false))) false))))) (defn bind " (FN (CTOR T) (CTOR T)) @@ -98,10 +197,10 @@ " ([^Ctor ctor] ctor) ([^Ctor ctor k v] (->Ctor (.-peer ctor) (.-key ctor) (.-idx ctor) (.-free ctor) - (assoc (.-env ctor) k v))) + (assoc (.-env ctor) k v) nil)) ([^Ctor ctor k v & kvs] (->Ctor (.-peer ctor) (.-key ctor) (.-idx ctor) (.-free ctor) - (apply assoc (.-env ctor) k v kvs)))) + (apply assoc (.-env ctor) k v kvs) nil))) (defn bind-args [^Ctor ctor & args] (reduce (partial apply bind) ctor (eduction (map-indexed vector) args))) @@ -118,15 +217,28 @@ [^Ctor ctor] (((.-defs (ctor-peer ctor)) (.-key ctor)) (.-idx ctor))) -;; TODO local? -(deftype Frame [parent call-id ^Ctor ctor ^objects signals] +(declare result) + +(deftype Frame [parent call-id rank site ctor + ^ints ranks ^objects children ^objects ports + ^:unsynchronized-mutable ^:mutable hash-memo] + #?(:clj Object) + #?(:cljs IHash) + (#?(:clj hashCode :cljs -hash) [_] + (if-some [h hash-memo] + h (set! hash-memo + (-> (hash parent) + (hash-combine (hash call-id)) + (hash-combine (hash rank)))))) + #?(:cljs IEquiv) + (#?(:clj equals :cljs -equiv) [_ other] + (and (instance? Frame other) + (= parent (.-parent ^Frame other)) + (= call-id (.-call-id ^Frame other)) + (= rank (.-rank ^Frame other)))) IFn - (#?(:clj invoke :cljs -invoke) [_ step done] - (let [cdef (ctor-cdef ctor)] - ((aget signals - (+ (count (.-nodes cdef)) - (count (.-calls cdef)))) - step done)))) + (#?(:clj invoke :cljs -invoke) [this step done] + ((flow (result this)) step done))) (defn frame-ctor "Returns the constructor of given frame." @@ -134,77 +246,361 @@ [^Frame frame] (.-ctor frame)) -(deftype Node [^Frame frame id] +(defn frame-peer + "Returns the peer of given frame." + {:tag Peer} + [^Frame frame] + (ctor-peer (frame-ctor frame))) + +(defn frame-cdef + "Returns the cdef of given frame." + {:tag Cdef} + [^Frame frame] + (ctor-cdef (frame-ctor frame))) + +(defn frame-parent + "Returns the parent frame of given frame if not root, nil otherwise." + {:tag Frame} + [^Frame frame] + (.-parent frame)) + +(defn frame-call-id + "Returns the call id of given frame." + [^Frame frame] + (.-call-id frame)) + +(defn frame-call-count + "Returns the call count of given frame." + [^Frame frame] + (count (.-calls (frame-cdef frame)))) + +(defn frame-site + "Returns the site of given frame." + [^Frame frame] + (.-site frame)) + +(defn node-site + "Returns the site of given node." + [^Frame frame id] + (if-some [site (nth (.-nodes (frame-cdef frame)) id)] + site (frame-site frame))) + +(defn call-site + "Returns the site of given call." + [^Frame frame id] + (if-some [site (nth (.-calls (frame-cdef frame)) id)] + site (frame-site frame))) + +(defn result-site + "Returns the site of result." + [^Frame frame] + (if-some [site (.-result (frame-cdef frame))] + site (frame-site frame))) + +(def port-slot-deps 0) +(def port-slot-flow 1) +(def port-slot-refcount 2) +(def port-slot-process 3) +(def port-slot-frozen 4) +(def port-slots 5) + +(deftype Port [frame id ^objects state + ^:unsynchronized-mutable ^:mutable hash-memo] + #?(:clj Object) + #?(:cljs IHash) + (#?(:clj hashCode :cljs -hash) [_] + (if-some [h hash-memo] + h (set! hash-memo + (hash-combine (hash frame) (hash id))))) + #?(:cljs IEquiv) + (#?(:clj equals :cljs -equiv) [_ other] + (and (instance? Port other) + (= frame (.-frame ^Port other)) + (= id (.-id ^Port other)))) + Expr + (deps [_] (aget state port-slot-deps)) + (flow [_] (aget state port-slot-flow)) IFn - (#?(:clj invoke :cljs -invoke) [_ step done] - ((aget (.-signals frame) id) step done))) + (#?(:clj invoke :cljs -invoke) [this step done] + ((flow this) step done))) + +(declare port-detach) -(deftype Call [^Frame frame id] +(deftype Remote [^Port port step done ^:unsynchronized-mutable ^:mutable diff] IFn - (#?(:clj invoke :cljs -invoke) [_ step done] - (let [cdef (ctor-cdef (frame-ctor frame))] - ((aget (.-signals frame) - (+ (count (.-nodes cdef)) id)) - step done)))) - -(defn make-frame [^Frame frame call-id ctor] - (let [cdef (ctor-cdef ctor) - length (+ (count (.-nodes cdef)) - (count (.-calls cdef))) - signals (object-array (inc length)) - frame (->Frame frame call-id ctor signals)] - (aset signals length ((.-build cdef) frame)) frame)) + (#?(:clj invoke :cljs -invoke) [_] + (port-detach port) + (if (nil? diff) + (step) (set! diff nil))) + (#?(:clj invoke :cljs -invoke) [_ value] + (if (nil? value) + (do (port-detach port) + (when (nil? diff) (done))) + (set! diff + (if-some [prev diff] + (i/combine prev value) + (do (step) value))))) + IDeref + (#?(:clj deref :cljs -deref) [this] + (if-some [value diff] + (do (set! diff nil) + (when (identical? this + (aget ^objects (.-state port) port-slot-process)) + (done)) value) + (do (done) (throw (Cancelled. "Input cancelled.")))))) + +(defn deregister-from-parent [^Frame frame] + (when-some [^Frame parent (.-parent frame)] + (let [^objects children (.-children parent) + call-id (.-call-id frame) + siblings (dissoc (aget children call-id) (.-rank frame))] + (case siblings + {} (let [^ints ranks (.-ranks parent) + callc (frame-call-count parent) + refcount (aget ranks callc)] + (aset ranks callc (unchecked-dec-int refcount)) + (aset children call-id nil) + (when (zero? refcount) (recur parent))) + (aset children call-id siblings))))) + +(defn register-to-parent [^Frame frame] + (when-some [^Frame parent (.-parent frame)] + (let [^objects children (.-children parent) + call-id (.-call-id frame) + siblings (aget children call-id)] + (case siblings + nil (let [^ints ranks (.-ranks parent) + callc (frame-call-count parent) + refcount (aget ranks callc)] + (aset ranks callc (unchecked-inc-int refcount)) + (aset children call-id {(.-rank frame) frame}) + (when (zero? refcount) (recur parent))) + (aset children call-id (assoc siblings (.-rank frame) frame)))))) + +(defn peer-push [^Peer peer offset item] + (let [^objects state (.-state peer) + ^objects queues (.-queues peer) + ^ints pushes (.-pushes peer) + ^objects queue (aget queues offset) + push (aget pushes offset) + cap (alength queue) + step (.-step peer)] + (aset pushes offset + (if (nil? (aget queue push)) + (do (aset queue push item) + (rem (unchecked-inc-int push) cap)) + (let [c (bit-shift-left cap 1) + q (object-array c)] + (aset queues offset q) + (i/acopy queue push q push + (unchecked-subtract-int cap push)) + (i/acopy queue 0 q cap push) + (let [p (unchecked-add-int push cap)] + (aset q p item) + (rem (unchecked-inc-int p) c))))) + (when (aget state peer-slot-output-pending) + (aset state peer-slot-output-pending false) + (step)))) + +(defn peer-tap [^Peer peer port] + (peer-push peer 0 port) peer) + +(defn port-attach [^Port port ps] + (aset ^objects (.-state port) port-slot-process ps) + (let [^Frame frame (.-frame port) + ^ints ranks (.-ranks frame) + callc (frame-call-count frame) + refcount (aget ranks callc)] + (aset ranks callc (unchecked-inc-int refcount)) + (when (zero? refcount) (register-to-parent frame)) + (reduce peer-tap (frame-peer frame) (deps port)))) + +(defn peer-untap [^Peer peer port] + (peer-push peer 1 port) peer) + +(defn port-detach [^Port port] + (aset ^objects (.-state port) port-slot-process nil) + (let [^Frame frame (.-frame port) + ^ints ranks (.-ranks frame) + callc (frame-call-count frame) + refcount (unchecked-dec-int (aget ranks callc))] + (aset ranks callc refcount) + (when (zero? refcount) (deregister-from-parent frame)) + (reduce peer-untap (frame-peer frame) (deps port)))) + +(defn port-ready [^Port port] + (peer-push (frame-peer (.-frame port)) 2 port)) + +(defn port-tap [^Port port] + (let [^objects state (.-state port) + prev (aget state port-slot-refcount)] + (aset state port-slot-refcount (inc prev)) + (when (zero? prev) + (aset state port-slot-process + ((flow port) + #(port-ready port) + #(do (aset state port-slot-frozen true) + (port-ready port))))))) + +(defn port-untap [^Port port] + (let [^objects state (.-state port) + curr (dec (aget state port-slot-refcount))] + (aset state port-slot-refcount curr) + (when (zero? curr) + ((aget state port-slot-process))))) + +(defn make-local [frame id incseq] + (let [state (object-array port-slots) + port (->Port frame id state nil)] + (aset state port-slot-deps #{port}) + (aset state port-slot-flow incseq) + (aset state port-slot-refcount (identity 0)) + port)) + +(defn make-remote [frame id deps] + (let [state (object-array port-slots) + port (->Port frame id state nil)] + (aset state port-slot-deps deps) + (aset state port-slot-flow + (m/signal i/combine + (fn [step done] + (let [ps (->Remote port step done (i/empty-diff 0))] + (port-attach port ps) (step) ps)))) port)) + +(defn make-frame [^Frame parent call-id rank site ctor] + (let [peer (ctor-peer ctor) + cdef (ctor-cdef ctor) + callc (count (.-calls cdef)) + result (+ (count (.-nodes cdef)) callc) + ports (object-array (inc result)) + frame (->Frame parent call-id rank site ctor + (int-array (inc callc)) (object-array callc) ports nil) + expr ((.-build cdef) frame)] + (aset ports result + (if (instance? Port expr) + expr (if (= (.-site peer) (result-site frame)) + (make-local frame nil (flow expr)) + (make-remote frame nil (deps expr))))) frame)) + +(defn peer-cancel [^Peer peer] + (prn :TODO-cancel)) + +(defn peer-transfer [^Peer peer] + (let [^objects peer-state (.-state peer) + ^objects queues (.-queues peer) + ^ints pushes (.-pushes peer)] + (loop [insts [] + tap-pull 0 + untap-pull 0 + ready-pull 0] + (let [^objects tap-queue (aget queues 0) + ^objects untap-queue (aget queues 1) + ^objects ready-queue (aget queues 2)] + (if-some [port (aget tap-queue tap-pull)] + (do (aset tap-queue tap-pull nil) + (port-tap port) + (recur insts + (rem (unchecked-inc-int tap-pull) + (alength tap-queue)) untap-pull ready-pull)) + (if-some [port (aget untap-queue untap-pull)] + (do (aset untap-queue untap-pull nil) + (port-untap port) + (recur insts tap-pull + (rem (unchecked-inc-int untap-pull) + (alength untap-queue)) ready-pull)) + (if-some [^Port port (aget ready-queue ready-pull)] + (do (aset ready-queue ready-pull nil) + (recur (conj insts + (loop [^Frame frame (.-frame port) + path ()] + (if-some [parent (.-parent frame)] + (recur parent (conj path [(.-call-id frame) (.-rank frame)])) + [path (.-id port) @(aget ^objects (.-state port) port-slot-process)]))) + tap-pull untap-pull + (rem (unchecked-inc-int ready-pull) + (alength ready-queue)))) + (do (aset peer-state peer-slot-output-pending true) + (aset pushes 0 0) + (aset pushes 1 0) + (aset pushes 2 0) + insts)))))))) + +(defn child-at [^Frame frame [call-id rank]] + (let [^objects children (.-children frame)] + (get (aget children call-id) rank))) + +(defn peer-apply-change [^Peer peer [path id diff]] + (let [^objects state (.-state peer) + ^Frame frame (reduce child-at (aget state peer-slot-root) path) + ^objects ports (.-ports frame)] + ((aget ports id) diff) peer)) + +(defn peer-input-ready [^Peer peer] + (let [^objects state (.-state peer)] + (loop [] + (when (aset state peer-slot-input-busy + (not (aget state peer-slot-input-busy))) + (try (reduce peer-apply-change peer + @(aget state peer-slot-input-process)) + (catch #?(:clj Throwable :cljs :default) e + (pst e) + ;; TODO + )) + (recur))))) + +(defn peer-result-diff [^Peer peer diff] + (prn :TODO-result-diff diff) + peer) + +(defn peer-result-success [^Peer peer] + (prn :TODO-result-success)) (defn define-node "Defines signals node id for given frame." - [^Frame frame id incseq] - (let [signals (.-signals frame)] - (when-not (nil? (aget signals id)) + [^Frame frame id expr] + (let [^objects ports (.-ports frame) + site (node-site frame id)] + (when-not (nil? (aget ports id)) (throw (error "Can't redefine signal node."))) - (aset signals id (m/signal i/combine incseq)) nil)) + (aset ports id + (if (instance? Port expr) + expr (if (= site (.-site (frame-peer frame))) + (make-local frame id (m/signal i/combine (flow expr))) + (make-remote frame id (deps expr))))) nil)) (defn define-call "Defines call site id for given frame." - [^Frame frame id incseq] - (let [signals (.-signals frame) - slot (-> (.-nodes (ctor-cdef (frame-ctor frame))) - (count) (+ id))] - (when-not (nil? (aget signals slot)) + [^Frame frame id expr] + (let [^objects ports (.-ports frame) + slot (+ id (count (.-nodes (frame-cdef frame)))) + site (call-site frame id)] + (when-not (nil? (aget ports slot)) (throw (error "Can't redefine call site."))) - (aset signals slot - (m/signal i/combine - (i/latest-product - (fn [ctor] - (when-not (instance? Ctor ctor) - (throw (error (str "Not a constructor - " (pr-str ctor))))) - (when-not (identical? (ctor-peer (frame-ctor frame)) (ctor-peer ctor)) - (throw (error "Can't call foreign constructor."))) - (make-frame frame id ctor)) incseq))) nil)) + (aset ports slot + (if (= site (.-site (frame-peer frame))) + (make-local frame id + (m/signal i/combine + (i/latest-product + (fn [ctor] + (when-not (instance? Ctor ctor) + (throw (error (str "Not a constructor - " (pr-str ctor))))) + (when-not (identical? (frame-peer frame) (ctor-peer ctor)) + (throw (error "Can't call foreign constructor."))) + (let [^ints ranks (.-ranks frame) + rank (aget ranks id)] + (aset ranks id (inc rank)) + (make-frame frame id rank site ctor))) + (flow expr)))) + (make-remote frame id (deps expr)))) nil)) (defn define-free "Defines free variable id for given constructor." [^Ctor ctor id incseq] - (let [free (.-free ctor)] + (let [^objects free (.-free ctor)] (when-not (nil? (aget free id)) (throw (error "Can't redefine free variable."))) (aset free id incseq) nil)) -(defn frame-parent - "Returns the parent frame of given frame if not root, nil otherwise." - {:tag Frame} - [^Frame frame] - (.-parent frame)) - -(defn frame-call-id - "Returns the call id of given frame." - [^Frame frame] - (.-call-id frame)) - -(defn frame-call-count - "Returns the call count of given frame." - [^Frame frame] - (.-calls (ctor-cdef (frame-ctor frame)))) - (defn lookup "Returns the value associated with given key in the dynamic environment of given frame." ([^Frame frame key] @@ -218,61 +614,70 @@ (defn make-ctor "Returns a fresh constructor for cdef coordinates key and idx." [^Frame frame key idx] - (let [^Peer peer (ctor-peer (frame-ctor frame)) + (let [^Peer peer (frame-peer frame) ^Cdef cdef ((ca/check some? ((.-defs peer) key) {:key key}) idx)] - (->Ctor peer key idx (object-array (.-frees cdef)) {}))) + (->Ctor peer key idx (object-array (.-frees cdef)) {} nil))) (defn node "Returns the signal node id for given frame." [^Frame frame id] - (->Node frame id)) + (let [^objects ports (.-ports frame)] + (aget ports id))) (defn free "Returns the free variable id for given frame." [^Frame frame id] - (aget (.-free (frame-ctor frame)) id)) + (let [^objects free (.-free (frame-ctor frame))] + (aget free id))) (defn call "Returns the call site id for given frame." [^Frame frame id] - (->Call frame id)) + (let [^objects ports (.-ports frame) + ^Cdef cdef (frame-cdef frame)] + (aget ports (+ (count (.-nodes cdef)) id)))) -(def peer-slot-input 0) -(def peer-slot-store 1) -(def peer-slots 2) - -(defn context-input-notify [^Peer peer done?] - ;; TODO - ) +(defn result + "Returns the result of given frame." + [^Frame frame] + (let [^objects ports (.-ports frame) + ^Cdef cdef (frame-cdef frame)] + (aget ports (+ (count (.-nodes cdef)) (count (.-calls cdef)))))) (defn peer " Returns a peer definition from given definitions and main key. -" [defs main & args] - (fn [msgs] +" [site defs main & args] + (fn [events] (fn [step done] (let [state (object-array peer-slots) - peer (->Peer step done defs state)] - (aset state peer-slot-store {}) - (aset state peer-slot-input - ((m/stream (m/observe msgs)) - #(context-input-notify peer false) - #(context-input-notify peer true))) - - ((->> args - (into {} (map-indexed (fn [i arg] [i (pure arg)]))) - (->Ctor peer main 0 (object-array 0)) - (make-frame nil 0) - (m/signal i/combine) - (m/reduce (fn [_ x] (prn :output x)) nil)) - #(prn :success %) #(prn :failure %)) - - peer)))) + peer (->Peer site defs step done + (doto (object-array 3) + (aset 0 (object-array 1)) + (aset 1 (object-array 1)) + (aset 2 (object-array 1))) + (int-array 3) state) + input (m/stream (m/observe events)) + root (->> args + (apply bind-args (->Ctor peer main 0 (object-array 0) {} nil)) + (make-frame nil 0 0 :client))] + (aset state peer-slot-output-pending true) + (aset state peer-slot-input-busy true) + (aset state peer-slot-input-process + (input #(peer-input-ready peer) done)) + (aset state peer-slot-root root) + (case site + :client (aset state peer-slot-result + ((m/reduce peer-result-diff peer + (m/signal i/combine (flow (result root)))) + peer-result-success pst)) + :server (reduce peer-tap peer (deps (result root)))) + (peer-input-ready peer) peer)))) ;; local only (defn root-frame [defs main] - (->> (->Ctor (->Peer nil nil defs nil) - main 0 (object-array 0) {}) - (make-frame nil 0) + (->> (bind-args (->Ctor (->Peer :client defs nil nil nil nil nil) + main 0 (object-array 0) {} nil)) + (make-frame nil 0 0 :client) (m/signal i/combine))) #?(:clj diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index f748dde83..51080a526 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -168,7 +168,7 @@ For each tuple in the cartesian product of `table1 table2 ,,, tableN`, calls bod ~@(mapv (cc/fn [expr] `(join (r/fixed-signals (join (i/items (pure ~expr)))))) exprs)) `($ (r/bind-args (hyperfiddle.electric-de/fn* ~args ~@body) ~@(map (clojure.core/fn [expr] - `(r/fixed-signals (join (i/items (pure ~expr))))) + `(r/effect (r/fixed-signals (join (i/items (pure ~expr)))))) exprs)))))) (defmacro as-vec " diff --git a/test/hyperfiddle/electric/impl/runtime_test.cljc b/test/hyperfiddle/electric/impl/runtime_test.cljc index ed429dd06..7efcaaf3c 100644 --- a/test/hyperfiddle/electric/impl/runtime_test.cljc +++ b/test/hyperfiddle/electric/impl/runtime_test.cljc @@ -1,8 +1,7 @@ (ns hyperfiddle.electric.impl.runtime-test - (:require [hyperfiddle.incseq :as i] - [missionary.core :as m] + (:require [missionary.core :as m] [hyperfiddle.electric-de :as e] - #?(:clj [hyperfiddle.electric.impl.lang-de2 :as l]) + [hyperfiddle.electric.impl.lang-de2 :as l] [hyperfiddle.electric.impl.runtime-de :as r] [hyperfiddle.rcf :as rcf :refer [tests %]])) @@ -63,7 +62,7 @@ (def !n (atom 20)) (def !fizz (atom "Fizz")) (def !buzz (atom "Buzz")) - (on-diff! rcf/tap (root-frame (e/server (let [fizz (e/watch !fizz) ; i/fixed + m/watch + e/join + (on-diff! rcf/tap (root-frame (e/client (let [fizz (e/watch !fizz) ; i/fixed + m/watch + e/join buzz (e/watch !buzz) is (e/diff-by identity (range 1 (inc (e/watch !n))))] ; variable in time and space (e/cursor [i is] @@ -129,4 +128,15 @@ % := 0 % := {:degree 0, :permutation {}, :grow 0, :shrink 0, :change {}, :freeze #{}} (swap! !x inc) - % := 1) \ No newline at end of file + % := 1) + +(tests + (def !x (atom 0)) + (on-diff! rcf/tap + (root-frame + (let [Foo (e/fn [x] (e/fn [] x)) + x (e/watch !x)] + (= (e/$ Foo x) (e/$ Foo x))))) + % := {:degree 1, :permutation {}, :grow 1, :shrink 0, :change {0 true}, :freeze #{0}} + % := nil + ) \ No newline at end of file From c72f68207f34962e6f9aaec7e64851bcc21937da Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Wed, 28 Feb 2024 16:57:27 +0100 Subject: [PATCH 121/428] fixed drain glitch --- src/hyperfiddle/electric/impl/runtime_de.cljc | 7 +-- test/hyperfiddle/electric_de_test.cljc | 53 +++++-------------- 2 files changed, 17 insertions(+), 43 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 302791c79..042ec344d 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -135,9 +135,10 @@ (defn drain " (FN (IS VOID) (IS T)) " [incseq] - (m/ap - (m/amb (i/empty-diff 0) - (do (m/?> incseq) (m/amb))))) + (let [signal (m/signal i/combine incseq)] + (m/ap + (m/amb (i/empty-diff 0) + (do (m/?> signal) (m/amb)))))) (defn error [^String msg] #?(:clj (Error. msg) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 41596f9a2..1ab142884 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -1171,46 +1171,19 @@ % := [1 :b [:local 1] [:global 1]] % := [1 :b '(:c :d) [:local 1] [:global 1]])) -(comment - (tests - (def !state (atom 0)) - (def global) - (with ((l/single {::lang/print-source true} - (let [state (e/watch !state)] - (tap [state state]) - (tap [state state]))) - tap tap) - % := [0 0] - % := [0 0] - (swap! !state inc) - % := [1 0] ; glitch - % := [1 1] - % := [1 1])) - ;; compiles to - [(r/cdef 0 [nil] [nil] nil - (fn [frame] - (r/define-node frame 0 (r/join (r/ap (r/lookup frame ::r/fixed-signals (r/pure r/fixed-signals)) - (r/ap (r/lookup frame ::m/watch (r/pure m/watch)) - (r/lookup frame ::!state (r/pure !state)))))) - (r/define-call frame 0 (r/join (r/ap (r/lookup frame ::r/pure (r/pure r/pure)) - (r/pure (doto (r/make-ctor frame ::l/Main 1) - (r/define-free 0 (r/node frame 0)))) - (r/pure (doto (r/make-ctor frame ::l/Main 2) - (r/define-free 0 (r/node frame 0))))))) - (r/join (r/call frame 0)))) - (r/cdef 1 [] [] nil - (fn [frame] - (r/join (r/ap (r/lookup frame ::r/drain (r/pure r/drain)) - (r/pure (r/ap (r/pure RCF__tap) - (r/ap (r/pure vector) - (r/free frame 0) - (r/free frame 0)))))))) - (r/cdef 1 [] [] nil - (fn [frame] - (r/ap (r/pure RCF__tap) - (r/ap (r/pure vector) - (r/free frame 0) - (r/free frame 0)))))]) +(tests + (def !state (atom 0)) + (def global) + (with ((l/single {} + (let [state (e/watch !state)] + (tap [state state]) + (tap [state state]))) + tap tap) + % := [0 0] + % := [0 0] + (swap! !state inc) + % := [1 1] + % := [1 1])) (tests "cc/fn lexical bindings are untouched" (with ((l/single {} (let [a 1 From d99cb71f0d9d39b14430ab61aa77a05a7ef2f173 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Wed, 28 Feb 2024 17:29:25 +0100 Subject: [PATCH 122/428] update type info --- src/hyperfiddle/electric/impl/runtime_de.cljc | 50 +++++++++++-------- 1 file changed, 29 insertions(+), 21 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 042ec344d..be52c99b0 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -28,13 +28,17 @@ (#?(:clj deref :cljs -deref) [this] (peer-transfer this))) -;; Pure | Ap | Effect | Join | Port +;; Pure | Ap | Join | Port (defprotocol Expr (deps [_]) ;; returns #{Port} (flow [_])) ;; returns incseq (defn invariant [x] (m/cp x)) +(defn incseq " +(EXPR T) -> (IS T) +" [expr] (flow expr)) + (deftype Pure [values ^:unsynchronized-mutable ^:mutable hash-memo] #?(:clj Object) @@ -56,10 +60,10 @@ ((flow this) step done))) (defn pure " -(FN (IS VOID)) -(FN (IS T) T) -(FN (IS T) T T) -(FN (IS T) T T T) +-> (EXPR VOID) +T -> (EXPR T) +T T -> (EXPR T) +T T T -> (EXPR T) " [& values] (->Pure values nil)) @@ -92,10 +96,10 @@ ((flow this) step done))) (defn ap " -(FN (IS T) (IS (FN T))) -(FN (IS T) (IS (FN T A)) (IS A)) -(FN (IS T) (IS (FN T A B)) (IS A) (IS B)) -(FN (IS T) (IS (FN T A B C)) (IS A) (IS B) (IS C)) +(EXPR (-> T)) -> (EXPR T) +(EXPR (A -> T)) (EXPR A) -> (EXPR T) +(EXPR (A B -> T)) (EXPR A) (EXPR B) -> (EXPR T) +(EXPR (A B C -> T)) (EXPR A) (EXPR B) (EXPR C) -> (EXPR T) " [& inputs] (->Ap inputs nil)) @@ -119,21 +123,25 @@ ((flow this) step done))) (defn join " -(FN (IS T) (IS (IS T))) +(EXPR (IS T)) -> (EXPR T) " [input] (->Join input nil)) -(defn effect [incseq] - (join (pure incseq))) +(def effect " +-> (EXPR VOID) +(IS T) -> (EXPR T) +(IS T) (IS T) -> (EXPR T) +(IS T) (IS T) (IS T) -> (EXPR T) +" (comp join pure)) (def fixed-signals " -(FN (IS VOID)) -(FN (IS T) (CF T)) -(FN (IS T) (CF T) (CF T)) -(FN (IS T) (CF T) (CF T) (CF T)) +-> (IS VOID) +(CF T) -> (IS T) +(CF T) (CF T) -> (IS T) +(CF T) (CF T) (CF T) -> (IS T) " (comp (partial m/signal i/combine) i/fixed)) (defn drain " -(FN (IS VOID) (IS T)) +(IS T) -> (IS VOID) " [incseq] (let [signal (m/signal i/combine incseq)] (m/ap @@ -191,10 +199,10 @@ (recur (inc i)) false))) false))))) (defn bind " -(FN (CTOR T) (CTOR T)) -(FN (CTOR T) (CTOR T) (VAR A) (IS A)) -(FN (CTOR T) (CTOR T) (VAR A) (IS A) (VAR B) (IS B)) -(FN (CTOR T) (CTOR T) (VAR A) (IS A) (VAR B) (IS B) (VAR C) (IS C)) +(CTOR T) -> (CTOR T) +(CTOR T) (VAR A) (EXPR A) -> (CTOR T) +(CTOR T) (VAR A) (EXPR A) (VAR B) (EXPR B) -> (CTOR T) +(CTOR T) (VAR A) (EXPR A) (VAR B) (EXPR B) (VAR C) (EXPR C) -> (CTOR T) " ([^Ctor ctor] ctor) ([^Ctor ctor k v] (->Ctor (.-peer ctor) (.-key ctor) (.-idx ctor) (.-free ctor) From 7f7d8b7c21557705db04fc07e34286373650cc8b Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 28 Feb 2024 16:49:43 +0100 Subject: [PATCH 123/428] compiler: fix cljs set! on var, fixes cc/fn binding conveyance --- src/hyperfiddle/electric/impl/lang_de2.clj | 17 ++++++++++++++++- test/hyperfiddle/electric_de_test.cljc | 2 +- 2 files changed, 17 insertions(+), 2 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 836657dfc..b51666b6c 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -290,6 +290,21 @@ :else ast)) (lexical? ast) (do (record-lexical! ast) ast) :else (qualify-sym-in-var-node env ast))) + var-set? (fn [ast] (and (= :set! (:op ast)) (= :var (:op (:target ast))))) + rewrite-cljs-ast (fn walk [ast] + (cond + (var-set? ast) (update ast :val walk) + (edef? ast) (do (record-edef! ast) + (cond (dynamic? ast) (qualify-sym-in-var-node env ast) + (namespaced? ast) (update ast :form safe-let-name) + :else ast)) + (lexical? ast) (do (record-lexical! ast) ast) + :else (let [quald-ast (qualify-sym-in-var-node env ast)] + (if-some [cs (:children quald-ast)] + (reduce (fn [ast k] + (update ast k #(if (vector? %) (mapv walk %) (walk %)))) + quald-ast cs) + quald-ast)))) form (case (or (get (::peers env) (::current env)) (->env-type env)) :clj (-> (ana/analyze-clj (update env :ns :name) form) (ana/walk-clj rewrite-ast) @@ -297,7 +312,7 @@ :cljs (-> (binding [cljs.analyzer/*cljs-warning-handlers* [(fn [_warning-type _env _extra])]] (ana/analyze-cljs env form)) - (ana/walk-cljs rewrite-ast) + (rewrite-cljs-ast) (ana/emit-cljs))) rest-args-sym (gensym "rest-args") all-syms (merge @refered-evars @refered-lexical) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 1ab142884..16f1fbc97 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -1376,7 +1376,7 @@ ;; TODO `set!` expands to cc/fn which tries to convey `a-root` ;; note: transitively the same applies to `(cc/fn [] (set! a-root 2))` #?(:cljs - (skip "set! to alter root binding" + (tests "set! to alter root binding" (def a-root 1) (with ((l/single {} (set! a-root 2)) tap tap)) (instance? Cancelled %) := true From 07f523672148b870acdae27ddcdeaf76590441f3 Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 28 Feb 2024 17:28:15 +0100 Subject: [PATCH 124/428] fix browser build --- src/hyperfiddle/electric/impl/runtime_de.cljc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index be52c99b0..ef61dc3ca 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -5,7 +5,7 @@ (:import #?(:clj (clojure.lang IFn IDeref)) missionary.Cancelled)) -(set! *warn-on-reflection* true) +#?(:clj (set! *warn-on-reflection* true)) (defn pst [e] #?(:clj (.printStackTrace ^Throwable e) @@ -523,7 +523,7 @@ T T T -> (EXPR T) (loop [^Frame frame (.-frame port) path ()] (if-some [parent (.-parent frame)] - (recur parent (conj path [(.-call-id frame) (.-rank frame)])) + (recur parent (conj path [(.-call-id ^Frame frame) (.-rank ^Frame frame)])) [path (.-id port) @(aget ^objects (.-state port) port-slot-process)]))) tap-pull untap-pull (rem (unchecked-inc-int ready-pull) From bca03445641f73d257aa418ad997d5bb94b4f4e3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Thu, 29 Feb 2024 18:20:47 +0100 Subject: [PATCH 125/428] simple remote diff apply --- src/hyperfiddle/electric/impl/runtime_de.cljc | 70 +++++++++---------- .../electric/impl/runtime_test.cljc | 25 ++++++- 2 files changed, 56 insertions(+), 39 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index ef61dc3ca..da4179dec 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -345,18 +345,16 @@ T T T -> (EXPR T) (if (nil? value) (do (port-detach port) (when (nil? diff) (done))) - (set! diff - (if-some [prev diff] - (i/combine prev value) - (do (step) value))))) + (if-some [prev diff] + (set! diff (i/combine prev value)) + (do (set! diff value) (step))))) IDeref (#?(:clj deref :cljs -deref) [this] (if-some [value diff] (do (set! diff nil) - (when (identical? this - (aget ^objects (.-state port) port-slot-process)) + (when-not (identical? this (aget ^objects (.-state port) port-slot-process)) (done)) value) - (do (done) (throw (Cancelled. "Input cancelled.")))))) + (do (done) (throw (Cancelled. "Remote port cancelled.")))))) (defn deregister-from-parent [^Frame frame] (when-some [^Frame parent (.-parent frame)] @@ -539,10 +537,9 @@ T T T -> (EXPR T) (get (aget children call-id) rank))) (defn peer-apply-change [^Peer peer [path id diff]] - (let [^objects state (.-state peer) - ^Frame frame (reduce child-at (aget state peer-slot-root) path) - ^objects ports (.-ports frame)] - ((aget ports id) diff) peer)) + (let [^Frame frame (reduce child-at (aget ^objects (.-state peer) peer-slot-root) path) + ^Port port (aget ^objects (.-ports frame) id)] + ((aget ^objects (.-state port) port-slot-process) diff) peer)) (defn peer-input-ready [^Peer peer] (let [^objects state (.-state peer)] @@ -655,32 +652,31 @@ T T T -> (EXPR T) (defn peer " Returns a peer definition from given definitions and main key. -" [site defs main & args] - (fn [events] - (fn [step done] - (let [state (object-array peer-slots) - peer (->Peer site defs step done - (doto (object-array 3) - (aset 0 (object-array 1)) - (aset 1 (object-array 1)) - (aset 2 (object-array 1))) - (int-array 3) state) - input (m/stream (m/observe events)) - root (->> args - (apply bind-args (->Ctor peer main 0 (object-array 0) {} nil)) - (make-frame nil 0 0 :client))] - (aset state peer-slot-output-pending true) - (aset state peer-slot-input-busy true) - (aset state peer-slot-input-process - (input #(peer-input-ready peer) done)) - (aset state peer-slot-root root) - (case site - :client (aset state peer-slot-result - ((m/reduce peer-result-diff peer - (m/signal i/combine (flow (result root)))) - peer-result-success pst)) - :server (reduce peer-tap peer (deps (result root)))) - (peer-input-ready peer) peer)))) +" [events site defs main & args] + (fn [step done] + (let [state (object-array peer-slots) + peer (->Peer site defs step done + (doto (object-array 3) + (aset 0 (object-array 1)) + (aset 1 (object-array 1)) + (aset 2 (object-array 1))) + (int-array 3) state) + input (m/stream (m/observe events)) + root (->> args + (apply bind-args (->Ctor peer main 0 (object-array 0) {} nil)) + (make-frame nil 0 0 :client))] + (aset state peer-slot-output-pending true) + (aset state peer-slot-input-busy true) + (aset state peer-slot-input-process + (input #(peer-input-ready peer) done)) + (aset state peer-slot-root root) + (case site + :client (aset state peer-slot-result + ((m/reduce peer-result-diff peer + (m/signal i/combine (flow (result root)))) + peer-result-success pst)) + :server (reduce peer-tap peer (deps (result root)))) + (peer-input-ready peer) peer))) ;; local only (defn root-frame [defs main] diff --git a/test/hyperfiddle/electric/impl/runtime_test.cljc b/test/hyperfiddle/electric/impl/runtime_test.cljc index 7efcaaf3c..bc61785bc 100644 --- a/test/hyperfiddle/electric/impl/runtime_test.cljc +++ b/test/hyperfiddle/electric/impl/runtime_test.cljc @@ -16,6 +16,13 @@ ::l/peers {:client :clj, :server :clj}))} ::Main)) +(defmacro peers [form] + (let [main (l/compile ::Main form + (assoc (l/normalize-env &env) + ::l/peers {:client :clj, :server :clj}))] + `{:client #(r/peer % :client {::Main ~main} ::Main) + :server #(r/peer % :server {::Main ~main} ::Main)})) + (tests (on-diff! rcf/tap (root-frame "hello electric")) % := {:grow 1, :degree 1, :shrink 0, :permutation {}, :change {0 "hello electric"}, :freeze #{0}} @@ -138,5 +145,19 @@ x (e/watch !x)] (= (e/$ Foo x) (e/$ Foo x))))) % := {:degree 1, :permutation {}, :grow 1, :shrink 0, :change {0 true}, :freeze #{0}} - % := nil - ) \ No newline at end of file + % := nil) + +(tests + (def c-ps + ((r/peer + (fn [!] + (def s->c !) + #(prn :dispose)) + :client + {::Main [(r/cdef 0 [:server] [] nil + (fn [frame] + (r/define-node frame 0 (r/pure :foo)) + (r/ap (r/pure rcf/tap) (r/node frame 0))))]} ::Main) + #(prn :step) #(prn :done))) + (s->c [[() 0 {:degree 1, :grow 1, :shrink 0, :permutation {}, :change {0 :foo}, :freeze #{}}]]) + % := :foo) \ No newline at end of file From 3f64fe7b013917153eb2b2126c7df340dacc49fe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Fri, 1 Mar 2024 12:29:43 +0100 Subject: [PATCH 126/428] simple local diff emit --- src/hyperfiddle/electric/impl/runtime_de.cljc | 32 +++++++++---------- .../electric/impl/runtime_test.cljc | 19 ++++++++++- 2 files changed, 34 insertions(+), 17 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index da4179dec..cefc85e0b 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -14,9 +14,9 @@ (def peer-slot-root 0) (def peer-slot-input-process 1) (def peer-slot-input-busy 2) -(def peer-slot-output-pending 9) -(def peer-slot-result 10) -(def peer-slots 11) +(def peer-slot-output-pending 3) +(def peer-slot-result 4) +(def peer-slots 5) (declare peer-cancel peer-transfer) @@ -310,8 +310,7 @@ T T T -> (EXPR T) (def port-slot-flow 1) (def port-slot-refcount 2) (def port-slot-process 3) -(def port-slot-frozen 4) -(def port-slots 5) +(def port-slots 4) (deftype Port [frame id ^objects state ^:unsynchronized-mutable ^:mutable hash-memo] @@ -446,7 +445,7 @@ T T T -> (EXPR T) (aset state port-slot-process ((flow port) #(port-ready port) - #(do (aset state port-slot-frozen true) + #(do (aset state port-slot-process nil) (port-ready port))))))) (defn port-untap [^Port port] @@ -516,16 +515,17 @@ T T T -> (EXPR T) (rem (unchecked-inc-int untap-pull) (alength untap-queue)) ready-pull)) (if-some [^Port port (aget ready-queue ready-pull)] - (do (aset ready-queue ready-pull nil) - (recur (conj insts - (loop [^Frame frame (.-frame port) - path ()] - (if-some [parent (.-parent frame)] - (recur parent (conj path [(.-call-id ^Frame frame) (.-rank ^Frame frame)])) - [path (.-id port) @(aget ^objects (.-state port) port-slot-process)]))) - tap-pull untap-pull - (rem (unchecked-inc-int ready-pull) - (alength ready-queue)))) + (let [^objects state (.-state port)] + (aset ready-queue ready-pull nil) + (recur (conj insts + (loop [^Frame frame (.-frame port) + path ()] + (if-some [parent (.-parent frame)] + (recur parent (conj path [(.-call-id ^Frame frame) (.-rank ^Frame frame)])) + [path (.-id port) (when-some [ps (aget state port-slot-process)] @ps)]))) + tap-pull untap-pull + (rem (unchecked-inc-int ready-pull) + (alength ready-queue)))) (do (aset peer-state peer-slot-output-pending true) (aset pushes 0 0) (aset pushes 1 0) diff --git a/test/hyperfiddle/electric/impl/runtime_test.cljc b/test/hyperfiddle/electric/impl/runtime_test.cljc index bc61785bc..25e69e9f4 100644 --- a/test/hyperfiddle/electric/impl/runtime_test.cljc +++ b/test/hyperfiddle/electric/impl/runtime_test.cljc @@ -160,4 +160,21 @@ (r/ap (r/pure rcf/tap) (r/node frame 0))))]} ::Main) #(prn :step) #(prn :done))) (s->c [[() 0 {:degree 1, :grow 1, :shrink 0, :permutation {}, :change {0 :foo}, :freeze #{}}]]) - % := :foo) \ No newline at end of file + % := :foo) + +(tests + (def s-ps + ((r/peer + (fn [!] + (def c->s !) + #(prn :dispose)) + :server + {::Main [(r/cdef 0 [:server] [] nil + (fn [frame] + (r/define-node frame 0 (r/pure :foo)) + (r/ap (r/pure rcf/tap) (r/node frame 0))))]} + ::Main) + #(rcf/tap :step) #(prn :done))) + % := :step + @s-ps := [[() 0 {:grow 1, :degree 1, :shrink 0, :permutation {}, :change {0 :foo}, :freeze #{0}}] + [() 0 nil]]) \ No newline at end of file From 10cebfb4a22b38ff99eb53017b460d25fa624873 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Fri, 1 Mar 2024 17:35:15 +0100 Subject: [PATCH 127/428] lambda transfer --- src/hyperfiddle/electric/impl/runtime_de.cljc | 57 ++++++++++++++----- .../electric/impl/runtime_test.cljc | 53 +++++++++++------ 2 files changed, 79 insertions(+), 31 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index cefc85e0b..9425ab118 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -1,9 +1,11 @@ (ns hyperfiddle.electric.impl.runtime-de (:require [hyperfiddle.incseq :as i] [missionary.core :as m] + [cognitect.transit :as t] [contrib.assert :as ca]) - (:import #?(:clj (clojure.lang IFn IDeref)) - missionary.Cancelled)) + (:import missionary.Cancelled + #?(:clj (clojure.lang IFn IDeref)) + #?(:clj (java.io ByteArrayInputStream ByteArrayOutputStream)))) #?(:clj (set! *warn-on-reflection* true)) @@ -12,11 +14,13 @@ :cljs (.error js/console e))) (def peer-slot-root 0) -(def peer-slot-input-process 1) -(def peer-slot-input-busy 2) -(def peer-slot-output-pending 3) -(def peer-slot-result 4) -(def peer-slots 5) +(def peer-slot-reader-opts 1) +(def peer-slot-writer-opts 2) +(def peer-slot-input-process 3) +(def peer-slot-input-busy 4) +(def peer-slot-output-pending 5) +(def peer-slot-result 6) +(def peer-slots 7) (declare peer-cancel peer-transfer) @@ -491,8 +495,21 @@ T T T -> (EXPR T) (defn peer-cancel [^Peer peer] (prn :TODO-cancel)) +(defn decode [^String s opts] + #?(:clj (t/read (t/reader (ByteArrayInputStream. (.getBytes s)) :json opts)) + :cljs (t/read (t/reader :json opts) s))) + +(defn encode [value opts] + #?(:clj + (let [out (ByteArrayOutputStream.) + writer (t/writer out :json opts)] + (t/write writer value) + (.toString out)) + :cljs + (t/write (t/writer :json opts) value))) + (defn peer-transfer [^Peer peer] - (let [^objects peer-state (.-state peer) + (let [^objects state (.-state peer) ^objects queues (.-queues peer) ^ints pushes (.-pushes peer)] (loop [insts [] @@ -526,11 +543,11 @@ T T T -> (EXPR T) tap-pull untap-pull (rem (unchecked-inc-int ready-pull) (alength ready-queue)))) - (do (aset peer-state peer-slot-output-pending true) + (do (aset state peer-slot-output-pending true) (aset pushes 0 0) (aset pushes 1 0) (aset pushes 2 0) - insts)))))))) + (encode insts (aget state peer-slot-writer-opts)))))))))) (defn child-at [^Frame frame [call-id rank]] (let [^objects children (.-children frame)] @@ -547,7 +564,8 @@ T T T -> (EXPR T) (when (aset state peer-slot-input-busy (not (aget state peer-slot-input-busy))) (try (reduce peer-apply-change peer - @(aget state peer-slot-input-process)) + (decode @(aget state peer-slot-input-process) + (aget state peer-slot-reader-opts))) (catch #?(:clj Throwable :cljs :default) e (pst e) ;; TODO @@ -619,10 +637,13 @@ T T T -> (EXPR T) (defn make-ctor "Returns a fresh constructor for cdef coordinates key and idx." - [^Frame frame key idx] + [^Frame frame key idx & frees] (let [^Peer peer (frame-peer frame) - ^Cdef cdef ((ca/check some? ((.-defs peer) key) {:key key}) idx)] - (->Ctor peer key idx (object-array (.-frees cdef)) {} nil))) + ^Cdef cdef ((ca/check some? ((.-defs peer) key) {:key key}) idx) + ctor (->Ctor peer key idx (object-array (.-frees cdef)) {} nil)] + (run! (partial apply define-free ctor) + (eduction (map-indexed vector) frees)) + ctor)) (defn node "Returns the signal node id for given frame." @@ -665,6 +686,14 @@ Returns a peer definition from given definitions and main key. root (->> args (apply bind-args (->Ctor peer main 0 (object-array 0) {} nil)) (make-frame nil 0 0 :client))] + (aset state peer-slot-writer-opts + {:handlers {Ctor (t/write-handler + (fn [_] "ctor") + (fn [^Ctor ctor] + (assert (identical? peer (.-peer ctor))) + (list* (.-key ctor) (.-idx ctor) (.-free ctor) (.-env ctor))))}}) + (aset state peer-slot-reader-opts + {:handlers {"ctor" (t/read-handler (fn [[k i f e]] (->Ctor peer k i (object-array f) e nil)))}}) (aset state peer-slot-output-pending true) (aset state peer-slot-input-busy true) (aset state peer-slot-input-process diff --git a/test/hyperfiddle/electric/impl/runtime_test.cljc b/test/hyperfiddle/electric/impl/runtime_test.cljc index 25e69e9f4..779df68ff 100644 --- a/test/hyperfiddle/electric/impl/runtime_test.cljc +++ b/test/hyperfiddle/electric/impl/runtime_test.cljc @@ -148,33 +148,52 @@ % := nil) (tests + (def cdefs + [(r/cdef 0 [:server] [] nil + (fn [frame] + (r/define-node frame 0 (r/pure :foo)) + (r/ap (r/pure rcf/tap) (r/node frame 0))))]) (def c-ps ((r/peer (fn [!] (def s->c !) #(prn :dispose)) - :client - {::Main [(r/cdef 0 [:server] [] nil - (fn [frame] - (r/define-node frame 0 (r/pure :foo)) - (r/ap (r/pure rcf/tap) (r/node frame 0))))]} ::Main) - #(prn :step) #(prn :done))) - (s->c [[() 0 {:degree 1, :grow 1, :shrink 0, :permutation {}, :change {0 :foo}, :freeze #{}}]]) + :client {::Main cdefs} ::Main) + #(prn :step-c) #(prn :done-c))) + (def s-ps + ((r/peer + (fn [!] + (def c->s !) + #(prn :dispose)) + :server {::Main cdefs} ::Main) + #(rcf/tap :step-s) #(prn :done-s))) + % := :step-s + (s->c @s-ps) % := :foo) (tests + (def cdefs + [(r/cdef 0 [:server] [:client] nil + (fn [frame] + (r/define-node frame 0 (r/pure (r/make-ctor frame ::Main 1))) + (r/define-call frame 0 (r/node frame 0)) + (r/ap (r/pure rcf/tap) (r/join (r/call frame 0))))) + (r/cdef 0 [] [] nil + (fn [frame] (r/pure :foo)))]) + (def c-ps + ((r/peer + (fn [!] + (def s->c !) + #(prn :dispose)) + :client {::Main cdefs} ::Main) + #(prn :step-c) #(prn :done-c))) (def s-ps ((r/peer (fn [!] (def c->s !) #(prn :dispose)) - :server - {::Main [(r/cdef 0 [:server] [] nil - (fn [frame] - (r/define-node frame 0 (r/pure :foo)) - (r/ap (r/pure rcf/tap) (r/node frame 0))))]} - ::Main) - #(rcf/tap :step) #(prn :done))) - % := :step - @s-ps := [[() 0 {:grow 1, :degree 1, :shrink 0, :permutation {}, :change {0 :foo}, :freeze #{0}}] - [() 0 nil]]) \ No newline at end of file + :server {::Main cdefs} ::Main) + #(rcf/tap :step-s) #(prn :done-s))) + % := :step-s + (s->c @s-ps) + % := :foo) \ No newline at end of file From 0a167ae1c83210aef1f6eb2e0ce706a1c217d125 Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 29 Feb 2024 10:15:38 +0100 Subject: [PATCH 128/428] compiler: refactor --- src/hyperfiddle/electric/impl/lang_de2.clj | 74 +++++++--------------- 1 file changed, 23 insertions(+), 51 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index b51666b6c..fd4f40247 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -448,16 +448,19 @@ (declare analyze) +(defn ap-literal [f args pe e env {{::keys [->id]} :o :as ts}] + (let [ce (->id)] + (reduce (fn [ts form] (analyze form e env ts)) + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) + (ts/add {:db/id ce, ::parent e, ::type ::pure}) + (ts/add {:db/id (->id), ::parent ce, ::type ::literal, ::v f})) + args))) + (defn ->class-method-call [clazz method method-args pe env form {{::keys [->id]} :o :as ts}] (if (seq method-args) - (let [e (->id), ce (->id)] - (reduce (fn [ts form] (analyze form e env ts)) - (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) - (ts/add {:db/id ce, ::parent e, ::type ::pure}) - (ts/add {:db/id (->id), ::parent ce, ::type ::literal, - ::v (let [margs (repeatedly (count method-args) gensym), meth (symbol (str clazz) (str method))] - `(fn [~@margs] (~meth ~@margs)))})) - method-args)) + (let [f (let [margs (repeatedly (count method-args) gensym), meth (symbol (str clazz) (str method))] + `(fn [~@margs] (~meth ~@margs)))] + (ap-literal f method-args pe (->id) env ts)) (let [e (->id)] ; (. java.time.Instant now) (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form}))))) @@ -468,14 +471,9 @@ (with-meta g (merge mt (meta k))))) (defn ->obj-method-call [o method method-args pe env {{::keys [->id]} :o :as ts}] - (let [e (->id), ce (->id)] - (reduce (fn [ts form] (analyze form e env ts)) - (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) - (ts/add {:db/id ce, ::parent e, ::type ::pure}) - (ts/add {:db/id (->id), ::parent ce, ::type ::literal, - ::v (let [[oo & margs] (mapv #(gensym-with-local-meta env %) (cons o method-args))] - `(fn [~oo ~@margs] (. ~oo ~method ~@margs)))})) - (cons o method-args)))) + (let [f (let [[oo & margs] (mapv #(gensym-with-local-meta env %) (cons o method-args))] + `(fn [~oo ~@margs] (. ~oo ~method ~@margs)))] + (ap-literal f (cons o method-args) pe (->id) env ts))) (defn def-sym-in-cljs-compiler! [sym ns] (swap! @(requiring-resolve 'cljs.env/*compiler*) @@ -510,31 +508,14 @@ (quote) (let [e (->id)] (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form}))) - (fn*) (let [e (->id), ce (->id) - [form refs] (closure env form) - ts2 (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) - (ts/add {:db/id ce, ::parent e, ::type ::pure}) - (ts/add {:db/id (->id), ::parent ce, ::type ::literal, ::v form}) - (?add-source-map e form))] - (reduce (fn [ts nx] (analyze nx e env ts)) ts2 refs)) - (::letfn) (let [[_ bs] form, [form refs] (closure env `(letfn* ~bs ~(vec (take-nth 2 bs)))) - e (->id), ce (->id) - ts2 (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) - (ts/add {:db/id ce, ::parent e, ::type ::pure}) - (ts/add {:db/id (->id), ::parent ce, ::type ::literal, ::v form}) - (?add-source-map e form))] - (reduce (fn [ts nx] (analyze nx e env ts)) ts2 refs)) + (fn*) (let [e (->id), [form refs] (closure env form)] + (ap-literal form refs pe e env (?add-source-map ts e form))) + (::letfn) (let [[_ bs] form, [form refs] (closure env `(letfn* ~bs ~(vec (take-nth 2 bs)))), e (->id)] + (ap-literal form refs pe e env (?add-source-map ts e form))) (new) (let [[_ f & args] form, current (get (::peers env) (::current env))] (if (or (nil? current) (= (->env-type env) current)) - (let [e (->id), ce (->id), cce (->id),] - (reduce (fn [ts arg] (analyze arg e env ts)) - (-> ts - (ts/add {:db/id e, ::parent pe, ::type ::ap}) - (ts/add {:db/id ce, ::parent e, ::type ::pure}) - (ts/add {:db/id cce, ::parent ce, ::type ::literal, - ::v (let [gs (repeatedly (count args) gensym)] - `(fn [~@gs] (new ~f ~@gs)))})) - args)) + (let [f (let [gs (repeatedly (count args) gensym)] `(fn [~@gs] (new ~f ~@gs)))] + (ap-literal f args pe (->id) env ts)) (recur `[~@args] pe env ts))) ;; (. java.time.Instant now) ;; (. java.time.Instant ofEpochMilli 1) @@ -565,12 +546,7 @@ (let [[_ o x & xs] form] (if (seq xs) ; (. i1 isAfter i2) (->obj-method-call o x xs pe env ts) - (let [e (->id), ce (->id)] ; (. pt x) - (recur o e env - (-> ts - (ts/add {:db/id e, ::parent pe, ::type ::ap}) - (ts/add {:db/id ce, ::parent e, ::type ::pure}) - (ts/add {:db/id (->id) , ::parent ce, ::type ::literal, ::v `(fn [oo#] (. oo# ~x))}))))))) + (ap-literal `(fn [oo#] (. oo# ~x)) [o] pe (->id) env ts)))) ; (. pt x) (binding clojure.core/binding) (let [[_ bs bform] form, gs (repeatedly (/ (count bs) 2) gensym)] (recur (if (seq bs) `(let* [~@(interleave gs (take-nth 2 (next bs)))] @@ -583,12 +559,8 @@ (def) (let [[_ sym v] form] (case (->env-type env) :clj (recur `((fn* ([x#] (def ~sym x#))) ~v) pe env ts) - :cljs (let [e (->id), ce (->id)] - (def-sym-in-cljs-compiler! sym (get-ns env)) - (recur v e env - (-> ts (ts/add {:db/id e, ::parent pe, ::type ::ap}) - (ts/add {:db/id ce, ::parent e, ::type ::pure}) - (ts/add {:db/id (->id), ::parent ce, ::type ::literal, ::v `(fn [v#] (set! ~sym v#))})))))) + :cljs (do (def-sym-in-cljs-compiler! sym (get-ns env)) + (ap-literal `(fn [v#] (set! ~sym v#)) [v] pe (->id) env ts)))) (set!) (let [[_ target v] form] (recur `((fn* ([v#] (set! ~target v#))) ~v) pe env ts)) (::ctor) (let [e (->id), ce (->id)] (recur (list ::site nil (second form)) From caa0ea43ea4567745986124647723024c5d2a80f Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 5 Mar 2024 10:02:22 +0100 Subject: [PATCH 129/428] compiler: lift fn args to nodes when site differs Also changed ap-collapse logic: In some cases (inlining nodes) the collapse logic came before and didn't trigger. Had to refactor a lot of code. We thought we can rewrite (r/ap (r/pure inc) (r/pure 1)) to (r/pure (inc 1)) But in the general case that's not true. If we substitute `inc` for `prn` we get from (r/ap (r/pure prn) (r/pure 1)) to (r/pure (prn 1)) which will run eagerly, whereas the previous version only runs when sampled. An always correct rewrite is (r/ap (r/pure (fn [] (prn 1)))) --- src/contrib/debug.cljc | 2 +- src/contrib/triple_store.clj | 10 +- src/hyperfiddle/electric/impl/lang_de2.clj | 256 +++++++++++------- src/hyperfiddle/electric_de.cljc | 2 +- src/hyperfiddle/electric_local_def_de.cljc | 2 +- test/contrib/triple_store_test.clj | 8 +- .../electric/impl/compiler_test.cljc | 49 ++-- test/hyperfiddle/electric_de_test.cljc | 4 +- 8 files changed, 208 insertions(+), 125 deletions(-) diff --git a/src/contrib/debug.cljc b/src/contrib/debug.cljc index 2bab4be84..7869e1421 100644 --- a/src/contrib/debug.cljc +++ b/src/contrib/debug.cljc @@ -12,7 +12,7 @@ (let [[label form] (if (keyword? form) [form label] [label form])] `(if *dbg* (let [[st# v#] (try [:ok ~form] (catch ~(if (:js-globals &env) :default 'Throwable) ex# [:ex ex#]))] - (prn ~label st# '~'==> v#) + (prn ~label '~'==> v#) (if (= st# :ok) v# (throw v#))) ~form)))) diff --git a/src/contrib/triple_store.clj b/src/contrib/triple_store.clj index 725885db5..7bfabe235 100644 --- a/src/contrib/triple_store.clj +++ b/src/contrib/triple_store.clj @@ -32,6 +32,13 @@ #_(update vea v update e (fnil conj #{}) a)))] (->TripleStore (:o ts) eav ave vea))) +(defn del [ts e] + (let [nd (-> ts :eav (get e)) + {:keys [o eav ave vea]} ts + eav (dissoc eav e) + ave (reduce-kv (fn [ave a v] (update ave a update v disj e)) ave nd)] + (->TripleStore o eav ave vea))) + (defn upd [ts e a f] (let [v0 (-> ts :eav (get e) (get a)) eav (update (:eav ts) e update a f) @@ -63,4 +70,5 @@ (defn ->node [ts e] (get (:eav ts) e)) (defn find [ts & kvs] - (reduce set/intersection (into [] (comp (partition-all 2) (map (fn [[k v]] (-> ts :ave (get k) (get v))))) kvs))) + (let [ret (reduce set/intersection (into [] (comp (partition-all 2) (map (fn [[k v]] (-> ts :ave (get k) (get v))))) kvs))] + (when (seq ret) ret))) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index fd4f40247..ee1ac022c 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -351,7 +351,7 @@ (clojure.lang.Reflector/getField cls (name sym) true))))) (defn get-children-e [ts e] (-> ts :ave ::parent (get e))) -(defn get-child-e [ts e] (first (get-children-e ts e))) +(defn get-child-e [ts e] (ca/check some? (first (get-children-e ts e)) {:e e})) (defn ?add-source-map [{{::keys [->id]} :o :as ts} pe form] (let [mt (meta form)] @@ -394,8 +394,8 @@ (defn resolve-symbol [sym env] (if-some [local (-> env :locals (get sym))] - (if-some [ref (::electric-let local)] - {::lang nil, ::type ::let-ref, ::sym sym, ::ref ref} + (if-some [uid (::electric-let local)] + {::lang nil, ::type ::let-ref, ::sym sym, ::ref uid} {::lang nil, ::type ::local, ::sym sym}) (if-some [nd (resolve-node sym env)] {::lang nil, ::type ::node, ::node nd} @@ -424,17 +424,10 @@ ::site (recur ts (get-child-e ts e)) #_else e))) -(defn find-sitable-parent [ts e] - (when-some [pe (::parent (get (:eav ts) e))] - (case (::type (get (:eav ts) pe)) - ::site (recur ts pe) - #_else pe))) - (defn get-site [ts e] (loop [e e] (when-some [nd (get (:eav ts) e)] (case (::type nd) - ::let-ref (recur (->> nd ::ref (->let-val-e ts) (get-ret-e ts))) ::site (::site nd) #_else (recur (::parent nd)))))) @@ -448,13 +441,23 @@ (declare analyze) +;; Due to an early bad assumption only `let` bound values are considered +;; for nodes (`r/define-node`). But in `(e/client (name (e/server :x)))` +;; `:x` needs to be a node too. For this reason we wrap function arguments +;; in an implicit `let`. This doesn't increase the generated code size +;; because `handle-let-refs` is smart enough to inline wherever possible. +(defn wrap-ap-arg [form] + (if (or (symbol? form) (keyword? form) (number? form)) + form + (let [ap-arg (gensym "ap-arg")] `(let* [~ap-arg ~form] ~ap-arg))) #_form) + (defn ap-literal [f args pe e env {{::keys [->id]} :o :as ts}] (let [ce (->id)] (reduce (fn [ts form] (analyze form e env ts)) (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) (ts/add {:db/id ce, ::parent e, ::type ::pure}) (ts/add {:db/id (->id), ::parent ce, ::type ::literal, ::v f})) - args))) + (mapv wrap-ap-arg args)))) (defn ->class-method-call [clazz method method-args pe env form {{::keys [->id]} :o :as ts}] (if (seq method-args) @@ -484,7 +487,7 @@ (update env ::last #(conj (pop %) form)) (assoc env ::last (conj (clojure.lang.PersistentQueue/EMPTY) nil form)))) -(defn analyze [form pe env {{::keys [->id]} :o :as ts}] +(defn analyze [form pe env {{::keys [->id ->uid]} :o :as ts}] (let [env (store env form)] (cond (and (seq? form) (seq form)) @@ -492,10 +495,10 @@ (let*) (let [[_ bs bform] form] (loopr [ts ts, pe pe, env env] [[s v] (eduction (partition-all 2) bs)] - (let [e (->id)] + (let [e (->id), uid (->uid)] (recur (analyze v e env - (-> (ts/add ts {:db/id e, ::parent pe, ::type ::let, ::sym s}) - (?add-source-map e form))) e (update-in env [:locals s] assoc ::electric-let e))) + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::let, ::sym s, ::uid uid}) + (?add-source-map e form))) e (update-in env [:locals s] assoc ::electric-let uid))) (analyze bform pe env ts))) (case) (let [[_ test & brs] form [default brs2] (if (odd? (count brs)) [(last brs) (butlast brs)] [:TODO brs])] @@ -565,7 +568,7 @@ (::ctor) (let [e (->id), ce (->id)] (recur (list ::site nil (second form)) ce env (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) - (ts/add {:db/id ce, ::parent e, ::type ::ctor}) + (ts/add {:db/id ce, ::parent e, ::type ::ctor, ::uid (->uid)}) (?add-source-map e form)))) (::call) (let [e (->id)] (recur (second form) e env (-> (ts/add ts {:db/id e, ::parent pe, ::type ::call}) (?add-source-map e form)))) @@ -580,8 +583,9 @@ (::lookup) (let [[_ sym] form] (ts/add ts {:db/id (->id), ::parent pe, ::type ::lookup, ::sym sym})) (::static-vars) (recur (second form) pe (assoc env ::static-vars true) ts) #_else (let [e (->id)] - (reduce (fn [ts nx] (analyze nx e env ts)) (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) - (?add-source-map e form)) form))) + (reduce (fn [ts nx] (analyze (wrap-ap-arg nx) e env ts)) + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) + (?add-source-map e form)) form))) (instance? cljs.tagged_literals.JSValue form) (let [o (.-val ^cljs.tagged_literals.JSValue form)] @@ -597,7 +601,8 @@ (symbol? form) (let [e (->id), ret (resolve-symbol form env)] (-> (case (::type ret) - (::let-ref) (ts/add ts {:db/id e, ::parent pe, ::type ::let-ref, ::ref (::ref ret), ::sym form}) + (::let-ref) (ts/add ts {:db/id e, ::parent pe, ::type ::let-ref, ::ref (::ref ret) + ::sym form, ::uid (->uid)}) (::local) (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form})) (::static ::var) (if (::static-vars env) @@ -622,8 +627,25 @@ (let [pe (::parent (get (:eav ts) e))] (if (or (nil? pe) (= ::ctor (::type (get (:eav ts) pe)))) pe (recur ts pe)))) -(defn get-node-idx [ts ctor-e ref-e] - (->> (ts/find ts ::ctor-node ctor-e, ::ctor-ref ref-e) first (ts/->node ts) ::node-idx)) +(defn- ts->reducible* [ts f init] + (loop [ac init, es (cons 0 (set/difference (-> ts :eav keys set) (->> ts :ave ::parent vals (reduce into)))), seen #{}] + (if (or (reduced? ac) (empty? es)) + (unreduced ac) + (let [[e & es] es] + (if (seen e) + (recur ac es seen) + (recur (f ac (ts/->node ts e)) (concat (get-children-e ts e) es) (conj seen e))))))) + +(defn ts->reducible [ts] + (reify clojure.lang.IReduce + (reduce [_ f init] (ts->reducible* ts f init)) + (reduce [_ f] (ts->reducible* ts f (f))))) + +(defn get-node-idx [ts ctor-uid uid] + (->> (ts/find ts ::ctor-node ctor-uid, ::ctor-ref uid) first (ts/->node ts) ::node-idx)) + +(defn e->uid [ts e] (ca/check (::uid (ts/->node ts e)))) +(defn uid->e [ts uid] (first (ca/check #(= 1 (count %)) (ts/find ts ::uid uid)))) (defn emit [ts e ctor-e env nm] ((fn rec [e] @@ -637,38 +659,44 @@ ::node (list `r/lookup 'frame (keyword (::node nd)) (list `r/pure (list `r/make-ctor 'frame (keyword (::node nd)) 0))) ::join (list `r/join (rec (get-child-e ts e))) ::pure (list `r/pure (rec (get-child-e ts e))) - ::comp (doall (map rec (get-children-e ts e))) + ::comp (list 'fn* '[] (doall (map rec (get-children-e ts e)))) ::site (recur (get-child-e ts e)) ::ctor (let [ctor (list `r/make-ctor 'frame nm (::ctor-idx nd)) - frees-e (-> ts :ave ::ctor-free (get e))] + frees-e (ts/find ts ::ctor-free (e->uid ts e))] (if (seq frees-e) (list* `doto ctor (mapv (fn [e] (let [nd (ts/->node ts e)] (list `r/define-free (::free-idx nd) (case (::closed-over nd) - ::node (list `r/node 'frame (get-node-idx ts (find-ctor-e ts (::ctor-free nd)) (::closed-ref nd))) - ::free (list `r/free 'frame (->> (ts/find ts ::ctor-free (find-ctor-e ts (::ctor-free nd)) - ::closed-ref (::closed-ref nd)) - first (ts/->node ts) ::free-idx)))))) + ::node (list `r/node 'frame + (get-node-idx ts + (e->uid ts (find-ctor-e ts (uid->e ts (::ctor-free nd)))) + (::closed-ref nd))) + ::free (list `r/free 'frame + (->> (ts/find ts + ::ctor-free (e->uid ts + (find-ctor-e ts (uid->e ts (::ctor-free nd)))) + ::closed-ref (::closed-ref nd)) + first (ts/->node ts) ::free-idx)))))) frees-e)) ctor)) ::call (list `r/join (list `r/call 'frame (::call-idx (ts/->node ts e)))) ::lookup (list `r/lookup 'frame (::sym nd)) ::let (recur (get-ret-e ts (->let-body-e ts e))) ::let-ref - (if-some [node-e (first (ts/find ts ::ctor-node ctor-e, ::ctor-ref (::ref nd)))] - (list `r/node 'frame (::node-idx (get (:eav ts) node-e))) - (if-some [free-e (first (ts/find ts ::ctor-free ctor-e, ::closed-ref (::ref nd)))] + (if-some [node-e (first (ts/find ts ::ctor-node (e->uid ts ctor-e), ::ctor-ref (::ref nd)))] + (list `r/node 'frame (::node-idx (ts/->node ts node-e))) + (if-some [free-e (first (ts/find ts ::ctor-free (e->uid ts ctor-e), ::closed-ref (::ref nd)))] (list `r/free 'frame (::free-idx (ts/->node ts free-e))) - (recur (get-ret-e ts (->let-val-e ts (::ref nd)))))) + (throw (ex-info "let-ref must be a node or free" nd)))) #_else (throw (ex-info (str "cannot emit on " (pr-str (::type nd))) (or nd {})))))) e)) (defn emit-node-init [ts ctor-e node-e env nm] (let [nd (get (:eav ts) node-e)] (list `r/define-node 'frame (::node-idx nd) - (emit ts (get-ret-e ts (->let-val-e ts (::ctor-ref nd))) ctor-e env nm)))) + (emit ts (->> (::ctor-ref nd) (uid->e ts) (->let-val-e ts) (get-ret-e ts)) ctor-e env nm)))) (defn emit-call-init [ts ctor-e e env nm] (list `r/define-call 'frame (::call-idx (ts/->node ts e)) @@ -677,11 +705,11 @@ (defn get-ordered-ctors-e [ts] (into [] (map (comp first second)) (->> ts :ave ::ctor-idx (sort-by first)))) -(defn get-ordered-calls-e [ts ctor-e] - (->> (ts/find ts ::ctor-call ctor-e) (sort-by #(::call-idx (ts/->node ts %))))) +(defn get-ordered-calls-e [ts ctor-uid] + (->> (ts/find ts ::ctor-call ctor-uid) (sort-by #(::call-idx (ts/->node ts %))))) -(defn get-ordered-nodes-e [ts ctor-e] - (->> (ts/find ts ::ctor-node ctor-e) (sort-by #(::node-idx (ts/->node ts %))))) +(defn get-ordered-nodes-e [ts ctor-uid] + (->> (ts/find ts ::ctor-node ctor-uid) (sort-by #(::node-idx (ts/->node ts %))))) (defn compute-effect-order [ts e] (let [->order (->->id), ord (fn [ts e] (ts/upd ts e ::fx-order #(or % (->order)))), seen (volatile! #{})] @@ -695,25 +723,28 @@ (::ap ::comp) (ord (reduce rec ts (get-children-e ts e)) e) (::site ::join ::pure ::call ::ctor) (ord (rec ts (get-child-e ts e)) e) (::let) (recur ts (->let-body-e ts e)) - (::let-ref) (ord (rec ts (->let-val-e ts (::ref nd))) (::ref nd)) + (::let-ref) (ord (rec ts (->let-val-e ts (uid->e ts (::ref nd)))) (uid->e ts (::ref nd))) #_else (throw (ex-info (str "cannot compure-effect-order on " (pr-str (::type nd))) (or nd {}))) ))))) ts e))) (defn emit-ctor [ts ctor-e env nm] (let [ret-e (get-ret-e ts (get-child-e ts ctor-e)) - nodes-e (get-ordered-nodes-e ts ctor-e) - calls-e (get-ordered-calls-e ts ctor-e)] - `(r/cdef ~(count (ts/find ts ::ctor-free ctor-e)) - ~(mapv #(get-site ts (->> (ts/->node ts %) ::ctor-ref (->let-val-e ts) (get-ret-e ts))) + ctor-uid (::uid (ts/->node ts ctor-e)) + nodes-e (get-ordered-nodes-e ts ctor-uid) + calls-e (get-ordered-calls-e ts ctor-uid)] + `(r/cdef ~(count (ts/find ts ::ctor-free ctor-uid)) + ~(mapv #(get-site ts (->> (ts/->node ts %) ::ctor-ref (uid->e ts) (->let-val-e ts) (get-ret-e ts))) nodes-e) ~(mapv #(get-site ts %) calls-e) ~(get-site ts ret-e) (fn [~'frame] - ~@(let [node-inits (->> nodes-e (mapv (fn [e] [(->> e (ts/->node ts) ::ctor-ref (ts/->node ts) ::fx-order) - (emit-node-init ts ctor-e e env nm)]))) - call-inits (->> calls-e (mapv (fn [e] [(->> e (ts/->node ts) ::fx-order) - (emit-call-init ts ctor-e e env nm)])))] + ~@(let [node-inits (->> nodes-e + (mapv (fn [e] [(->> e (ts/->node ts) ::ctor-ref (uid->e ts) (ts/->node ts) ::fx-order) + (emit-node-init ts ctor-e e env nm)]))) + call-inits (->> calls-e + (mapv (fn [e] [(->> e (ts/->node ts) ::fx-order) + (emit-call-init ts ctor-e e env nm)])))] ;; with xforms would be ;; (into [] (comp cat (x/sort-by first) (map second)) [node-inits call-inits]) (->> (concat node-inits call-inits) (sort-by first) (eduction (map second)))) @@ -731,7 +762,7 @@ (::ap ::comp) (reduce mark ts (get-children-e ts e)) (::site ::join ::pure ::call ::ctor) (recur ts (get-child-e ts e)) (::let) (recur ts (->let-body-e ts e)) - (::let-ref) (recur ts (get-ret-e ts (->let-val-e ts (::ref nd)))) + (::let-ref) (recur ts (get-ret-e ts (->let-val-e ts (uid->e ts (::ref nd))))) (::node) (ts/asc ts e ::node-used true) #_else (throw (ex-info (str "cannot emit-deps/mark on " (pr-str (::type nd))) (or nd {}))))))) es (ts/find (mark ts e) ::node-used true)] @@ -740,20 +771,26 @@ (defn get-deps [sym] (-> sym resolve meta ::deps)) (defn analyze-electric [env {{::keys [->id]} :o :as ts}] - (let [change-parent (fn change-parent [ts e pe] (ts/asc ts e ::parent pe)) - orphan (fn orphan [ts e] (change-parent ts e nil)) - collapse-ap-with-only-pures (fn collapse-ap-with-only-pures [ts] ; (r/ap (r/pure .)+ ) => (r/pure (::comp . . .)) + (when (::print-analysis env) (run! prn (ts->reducible ts))) + (let [reparent-children (fn reparent-children [ts from-e to-e] + (reduce (fn [ts e] (ts/asc ts e ::parent to-e)) ts (ts/find ts ::parent from-e))) + collapse-ap-with-only-pures (fn collapse-ap-with-only-pures [ts] + ;; (ap (pure x) (pure y) (pure z)) -> (ap (pure (comp x y z))) (reduce (fn [ts ap-e] - (let [[f-e & args-e :as children-e] (get-children-e ts ap-e)] - (if (every? #(= ::pure (::type (ts/->node ts %))) children-e) - (reduce (fn [ts e] - (-> ts (change-parent (get-child-e ts e) f-e) - (orphan e))) - ;; reuse nodes, otherwise node ordering messes up - (-> ts (ts/asc ap-e ::type ::pure) (ts/asc f-e ::type ::comp)) - args-e) + (let [ce (get-children-e ts ap-e)] + (if (every? #(= ::pure (::type (ts/->node ts %))) ce) + (let [pure-e (->id), comp-e (->id)] + (reduce (fn [ts e] + (let [ce (get-child-e ts e), cnd (ts/->node ts ce)] + (-> ts (ts/del e) (ts/del ce) + (ts/add (assoc cnd :db/id e, ::parent comp-e)) + (reparent-children ce e)))) + (-> ts + (ts/add {:db/id pure-e, ::parent ap-e, ::type ::pure}) + (ts/add {:db/id comp-e, ::parent pure-e, ::type ::comp})) + ce)) ts))) - ts (reverse (ts/find ts ::type ::ap)))) + ts (ts/find ts ::type ::ap))) ->ctor-idx (->->id) seen (volatile! #{}) mark-used-ctors (fn mark-used-ctors [ts e] @@ -769,37 +806,60 @@ ts (recur (ts/asc ts e ::ctor-idx (->ctor-idx)) (get-child-e ts e))) (::let) (recur ts (->let-body-e ts e)) - (::let-ref) (recur ts (get-ret-e ts (->let-val-e ts (::ref nd)))) + (::let-ref) (recur ts (get-ret-e ts (->let-val-e ts (uid->e ts (::ref nd))))) #_else (throw (ex-info (str "cannot mark-used-ctors on " (pr-str (::type nd))) (or nd {}))))))) - ts (-> ts collapse-ap-with-only-pures - (compute-effect-order 0) - (mark-used-ctors 0)) + ts (-> ts (compute-effect-order 0) (mark-used-ctors 0)) ctors-e (get-ordered-ctors-e ts) - ensure-node (fn ensure-node [ts ref-e] - (let [ctor-e (find-ctor-e ts ref-e)] - (cond-> ts (empty? (ts/find ts ::ctor-ref ref-e)) - (ts/add {:db/id (->id) ::ctor-node ctor-e, ::ctor-ref ref-e})))) - ensure-free-node (fn ensure-free-node [ts ref-e ctor-e] - (cond-> ts (empty? (ts/find ts ::ctor-free ctor-e, ::closed-ref ref-e)) - (ts/add {:db/id (->id) ::ctor-free ctor-e, ::closed-ref ref-e, ::closed-over ::node}))) - ensure-free-free (fn ensure-free-free [ts ref-e ctor-e] - (cond-> ts (empty? (ts/find ts ::ctor-free ctor-e, ::closed-ref ref-e)) - (ts/add {:db/id (->id) ::ctor-free ctor-e, ::closed-ref ref-e, ::closed-over ::free}))) - ensure-free-frees (fn ensure-free-frees [ts ref-e ctors-e] - (reduce (fn [ts ctor-e] (ensure-free-free ts ref-e ctor-e)) ts ctors-e)) + has-node? (fn has-node? [ts uid] (ts/find ts ::ctor-ref uid)) + ensure-node (fn ensure-node [ts uid] + (let [ctor-uid (e->uid ts (find-ctor-e ts (uid->e ts uid)))] + (cond-> ts (not (has-node? ts uid)) + (ts/add {:db/id (->id) ::ctor-node ctor-uid, ::ctor-ref uid})))) + ensure-free-node (fn ensure-free-node [ts uid ctor-uid] + (cond-> ts (not (ts/find ts ::ctor-free ctor-uid, ::closed-ref uid)) + (ts/add {:db/id (->id) ::ctor-free ctor-uid, ::closed-ref uid, ::closed-over ::node}))) + ensure-free-free (fn ensure-free-free [ts uid ctor-uid] + (cond-> ts (not (ts/find ts ::ctor-free ctor-uid, ::closed-ref uid)) + (ts/add {:db/id (->id) ::ctor-free ctor-uid, ::closed-ref uid, ::closed-over ::free}))) + ensure-free-frees (fn ensure-free-frees [ts uid ctors-uid] + (reduce (fn [ts ctor-uid] (ensure-free-free ts uid ctor-uid)) ts ctors-uid)) order-nodes (fn order-nodes [ts] (reduce (fn [ts nodes-e] (let [->idx (->->id)] (reduce (fn [ts e] (ts/asc ts e ::node-idx (->idx))) - ts (sort-by #(->> % (ts/->node ts) ::ctor-ref (ts/->node ts) ::fx-order) + ts (sort-by #(->> % (ts/->node ts) ::ctor-ref (uid->e ts) (ts/->node ts) ::fx-order) nodes-e)))) ts (-> ts :ave ::ctor-node vals))) order-frees (fn order-frees [ts] (reduce (fn [ts frees-e] (let [->idx (->->id)] (reduce (fn [ts e] (ts/asc ts e ::free-idx (->idx))) - ts (sort-by #(::fx-order (ts/->node ts %)) frees-e) #_(sort-by-fx-order ts frees-e)))) + ts (sort-by #(::fx-order (ts/->node ts %)) frees-e)))) ts (-> ts :ave ::ctor-free vals))) + inline-nodes (fn inline-nodes [ts] + (let [lets-e (->> ts :ave ::used-refs vals (reduce into) + (remove #(has-node? ts (::uid (ts/->node ts %)))))] + (if-some [let-e (first lets-e)] + (let [let-nd (ts/->node ts let-e) + let-val-e (->let-val-e ts let-e), let-val-nd (ts/->node ts let-val-e) + let-body-e (->let-body-e ts let-e) + letrefs-e (mapv #(uid->e ts %) (::used-refs let-nd)) + letref-e (first (ca/check #(= 1 (count %)) letrefs-e + {:letrefs letrefs-e})) + letref-nd (ts/->node ts letref-e) + ts ; (inc (let [x (dec 1)] x)) + (-> ts (ts/del let-val-e) ; (inc (let [x _] x)) + (ts/del letref-e) ; (inc (let [x _] _)) + (ts/add (assoc let-val-nd :db/id letref-e, ::parent (::parent letref-nd))) ; (inc (let [x _] (_))) + (reparent-children let-val-e letref-e) ; (inc (let [x _] (dec 1)) + (ts/del let-e)) ; (inc _), (dec 1) floating + let-body-nd (ts/->node ts let-body-e)] + (-> ts + (ts/del let-body-e) ; (inc _) + (ts/add (assoc let-body-nd :db/id let-e, ::parent (::parent let-nd))) ; (inc (_)) + (reparent-children let-body-e let-e) ; (inc (dec 1)) + (recur))) + ts))) in-a-call? (fn in-a-call? [ts e] (loop [e (::parent (ts/->node ts e))] (when-let [nd (ts/->node ts e)] @@ -807,6 +867,7 @@ ::call true ::ctor false #_else (recur (::parent nd)))))) + seen (volatile! #{}) handle-let-refs (fn handle-let-refs [ts e] ; nodes and frees (closed over) (let [nd (ts/->node ts e)] (case (::type nd) @@ -815,28 +876,28 @@ (::site ::join ::pure ::ctor ::call) (recur ts (get-child-e ts e)) (::let) (recur ts (->let-body-e ts e)) (::let-ref) - (let [ref-nd (ts/->node ts (::ref nd)) + (let [uid (::ref nd) let-e (uid->e ts uid) let-nd (ts/->node ts let-e) ctors-e (loop [ac '(), e (::parent (ts/->node ts e))] - (if (= (::ref nd) e) + (if (= let-e e) ac (recur (cond-> ac (= ::ctor (::type (ts/->node ts e))) (conj e)) (::parent (ts/->node ts e))))) - ts (ts/asc ts (::ref nd) ::walked-val true) ; only walk binding once - ;; TODO is this necessary? If not we could inline more + ;; TODO maybe necessary, no proof yet ;; ts (cond-> ts (in-a-call? ts e) ;; (-> (ts/upd (::ref nd) ::in-call #(conj (or % #{}) e)) ;; (ensure-node (::ref nd)))) ts (if (seq ctors-e) ; closed over - (-> ts (ensure-node (::ref nd)) - (ensure-free-node (::ref nd) (first ctors-e)) - (ensure-free-frees (::ref nd) (rest ctors-e))) - (cond-> (ts/upd ts (::ref nd) ::refcnt (fnil inc 0)) - (or (= 1 (::refcnt ref-nd)) - (not= (get-site ts (find-sitable-parent ts e)) - (get-site ts (->let-val-e ts (::ref nd))))) - (ensure-node (::ref nd))))] - (cond-> ts - (not (::walked-val ref-nd)) (recur (get-ret-e ts (->let-val-e ts (::ref nd)))))) + (-> ts (ensure-node uid) + (ensure-free-node uid (e->uid ts (first ctors-e))) + (ensure-free-frees uid (mapv #(e->uid ts %) (next ctors-e)))) + (cond-> (ts/upd ts let-e ::used-refs #(conj (or % #{}) (::uid nd))) + (or (= 1 (count (::used-refs let-nd))) ; before inc above, so now it's 2 + (not= (get-site ts (::parent (ts/->node ts e))) + (get-site ts (get-ret-e ts (->let-val-e ts let-e))))) + (ensure-node uid)))] + (or (and (@seen let-e) ts) + (do (vswap! seen conj let-e) + (recur ts (get-ret-e ts (->let-val-e ts let-e)))))) #_else (throw (ex-info (str "cannot handle-let-refs on " (::type nd)) (or nd {})))))) ->call-idx (let [mp (zipmap ctors-e (repeatedly ->->id))] (fn ->call-idx [ctor-e] ((get mp ctor-e)))) @@ -855,14 +916,15 @@ ts (-> (mark-used-calls ts ctor-e (get-child-e ts e)) (ts/asc e ::call-idx (->call-idx ctor-e)) - (ts/asc e ::ctor-call ctor-e))) + (ts/asc e ::ctor-call (::uid (ts/->node ts ctor-e))))) (::let) (recur ts ctor-e (->let-body-e ts e)) - (::let-ref) (let [nx-e (get-ret-e ts (->let-val-e ts (::ref nd)))] + (::let-ref) (let [nx-e (get-ret-e ts (->let-val-e ts (uid->e ts (::ref nd))))] (recur ts (find-ctor-e ts nx-e) nx-e)) #_else (throw (ex-info (str "cannot mark-used-calls on " (::type nd)) (or nd {}))))))) - ts (-> ts (handle-let-refs 0) order-nodes order-frees - (mark-used-calls 0 (get-ret-e ts (get-child-e ts 0))))] - (when (::print-db env) (run! prn (->> ts :eav vals (sort-by :db/id)))) + ts (-> ts (mark-used-calls 0 (get-ret-e ts (get-child-e ts 0))) + (handle-let-refs 0) inline-nodes order-nodes order-frees + collapse-ap-with-only-pures)] + (when (::print-db env) (run! prn (ts->reducible ts))) ts)) (defn compile* [nm env ts] @@ -871,7 +933,9 @@ (when (::print-source env) (fipp.edn/pprint ret)) ret)) +(defn ->ts [] (ts/->ts {::->id (->->id), ::->uid (->->id)})) + (defn compile [nm form env] (compile* nm env (analyze (expand-all env `(::ctor ~form)) - '_ env (ts/->ts {::->id (->->id)})))) + '_ env (->ts)))) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 51080a526..4d34ec00d 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -98,7 +98,7 @@ Returns the successive states of items described by `incseq`. nm2 (vary-meta nm merge (meta sym)) expanded (lang/expand-all env `(fn ~nm2 ~@(cond-> fdecl (string? (first fdecl)) next))) _ (when (::lang/print-expansion env) (fipp.edn/pprint expanded)) - ts (lang/analyze expanded '_ env (ts/->ts {::lang/->id (lang/->->id)})) + ts (lang/analyze expanded '_ env (lang/->ts)) ts (lang/analyze-electric env ts) ctors (mapv #(lang/emit-ctor ts % env (-> nm ns-qualify keyword)) (lang/get-ordered-ctors-e ts)) deps (lang/emit-deps ts 0) diff --git a/src/hyperfiddle/electric_local_def_de.cljc b/src/hyperfiddle/electric_local_def_de.cljc index bab4f656b..e40e6d0b1 100644 --- a/src/hyperfiddle/electric_local_def_de.cljc +++ b/src/hyperfiddle/electric_local_def_de.cljc @@ -42,7 +42,7 @@ (let [env (merge (->local-config &env) (lang/normalize-env &env) conf) expanded (lang/expand-all env `(::lang/ctor (do ~@body))) _ (when (::lang/print-expansion env) (fipp.edn/pprint expanded)) - ts (lang/analyze expanded '_ env (ts/->ts {::lang/->id (lang/->->id)})) + ts (lang/analyze expanded '_ env (lang/->ts)) _ (when (::lang/print-analysis env) (run! prn (->> ts :eav vals (sort-by :db/id)))) ts (lang/analyze-electric env ts) ctors (mapv #(lang/emit-ctor ts % env ::Main) (lang/get-ordered-ctors-e ts)) diff --git a/test/contrib/triple_store_test.clj b/test/contrib/triple_store_test.clj index a13aeebfc..8fcc0c153 100644 --- a/test/contrib/triple_store_test.clj +++ b/test/contrib/triple_store_test.clj @@ -13,4 +13,10 @@ (-> (ts/->ts) (ts/add {:db/id 1}) (ts/asc 1 :x 2) (ts/asc 1 :x 2) :ave :x (get 2)) := #{1} (-> (ts/->ts) (ts/add {:db/id 1, :foo 1, :bar 1}) (ts/add {:db/id 2, :foo 1, :bar 1}) (ts/find :foo 1 :bar 1)) := #{1 2} - ) + + (let [ts (-> (ts/->ts) (ts/add {:db/id 1, :foo 1}) (ts/add {:db/id 2, :foo 2}))] + (count (->> ts :ave :foo vals (reduce into))) := 2 + (let [ts (ts/del ts 2)] + (ts/->node ts 2) := nil + (count (->> ts :ave :foo vals (reduce into))) := 1 + ))) diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index f332b8bac..7a96cd294 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -48,11 +48,12 @@ `[(r/cdef 0 [] [] nil (fn [~'frame] (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure prn)) (r/pure "Hello world"))))]) - (match (l/test-compile ::Main (prn (::lang/site :client 1))) - `[(r/cdef 0 [] [] nil + (match (l/test-compile ::Main (prn (e/client 1))) + `[(r/cdef 0 [:client] [] nil (fn [~'frame] + (r/define-node ~'frame 0 (r/pure 1)) (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure clojure.core/prn)) - (r/pure 1))))])) + (r/node ~'frame 0))))])) (tests "test-join" (match (l/test-compile ::Main {'!x (atom 0)} (::lang/join (i/fixed (m/watch !x)))) @@ -84,9 +85,18 @@ (fn [~'frame] (r/ap (r/lookup ~'frame :cljs.core/undefined? (r/pure cljs.core/undefined?)))))]) - (match (l/test-compile ::Main (::lang/site :server (let [x 1] (::lang/site :client x)))) - `[(r/cdef 0 [] [] :server - (fn [~'frame] (r/pure 1)))]) + (match (l/test-compile ::Main (e/server (let [x 1] (e/client x)))) + `[(r/cdef 0 [:server] [] :client + (fn [~'frame] + (r/define-node ~'frame 0 (r/pure 1)) + (r/node ~'frame 0)))]) + + (match (l/test-compile ::Main (name (e/server :foo))) + `[(r/cdef 0 [:server] [] nil + (fn [~'frame] + (r/define-node ~'frame 0 (r/pure :foo)) + (r/ap (r/lookup ~'frame :clojure.core/name (r/pure clojure.core/name)) + (r/node ~'frame 0))))]) (let [ex (try (l/test-compile ::Main cannot-be-unsited) (catch ExceptionInfo e e))] (ex-message ex) := "Unsited symbol `cannot-be-unsited` resolves to different vars on different peers. Please resolve ambiguity by siting the expression using it.")) @@ -118,18 +128,17 @@ (match (l/test-compile ::Main (let [a 1] a)) `[(r/cdef 0 [] [] nil (fn [~'frame] (r/pure 1)))]) - (match (l/test-compile ::Main (::lang/site :client (let [a 1] (::lang/site :server (prn a))))) + (match (l/test-compile ::Main (e/client (let [a 1] (e/server (prn a))))) `[(r/cdef 0 [:client] [] :server (fn [~'frame] (r/define-node ~'frame 0 (r/pure 1)) (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure clojure.core/prn)) (r/node ~'frame 0))))]) - (match (l/test-compile ::Main (::lang/site :client (let [x "Hello", y "world"] [x y]))) + (match (l/test-compile ::Main (e/client (let [x "Hello", y "world"] [x y]))) `[(r/cdef 0 [] [] :client (fn [~'frame] - (r/ap (r/pure clojure.core/vector) - (r/pure "Hello") (r/pure "world"))))]) + (r/ap (r/pure (fn* [] (clojure.core/vector "Hello" "world"))))))]) (match (l/test-compile ::Main (::lang/site :client (let [a (::lang/site :server :foo)] (::lang/site :server (prn a))))) `[(r/cdef 0 [] [] :server @@ -367,17 +376,12 @@ (match (l/test-compile ::Main (case :x nil :y :z)) `[(r/cdef 0 [] [nil] nil (fn [~'frame] - (r/define-call ~'frame 0 (r/ap (r/ap (r/pure clojure.core/hash-map) - (r/pure 'nil) (r/pure (r/make-ctor ~'frame ::Main 1))) + (r/define-call ~'frame 0 (r/ap (r/ap (r/pure (fn* [] (hash-map 'nil (r/make-ctor ~'frame ::Main 1))))) (r/pure :x) (r/pure (r/make-ctor ~'frame ::Main 2)))) (r/join (r/call ~'frame 0)))) - (r/cdef 0 [] [] nil - (fn [~'frame] - (r/pure :y))) - (r/cdef 0 [] [] nil - (fn [~'frame] - (r/pure :z)))]) + (r/cdef 0 [] [] nil (fn [~'frame] (r/pure :y))) + (r/cdef 0 [] [] nil (fn [~'frame] (r/pure :z)))]) (match (l/test-compile ::Main (case 'foo (foo bar) :share-this :else)) `[(r/cdef 0 [nil] [nil] nil @@ -446,9 +450,10 @@ (inc (dec 0)))) `[(r/cdef 0 [] [nil] nil (fn [~'frame] - (r/define-call ~'frame 0 (r/pure (r/bind (r/make-ctor ~'frame ::Main 1) - :clojure.core/inc (r/lookup ~'frame :clojure.core/dec (r/pure dec)) - :clojure.core/dec (r/lookup ~'frame :clojure.core/inc (r/pure inc))))) + (r/define-call ~'frame 0 + (r/ap (r/pure (fn* [] (r/bind (r/make-ctor ~'frame ::Main 1) + :clojure.core/inc (r/lookup ~'frame :clojure.core/dec (r/pure dec)) + :clojure.core/dec (r/lookup ~'frame :clojure.core/inc (r/pure inc))))))) (r/join (r/call ~'frame 0)))) (r/cdef 0 [] [] nil (fn [~'frame] @@ -460,7 +465,7 @@ (match (l/test-compile ::Main [1 2]) `[(r/cdef 0 [] [] nil (fn [~'frame] - (r/pure (clojure.core/vector 1 2))))])) + (r/ap (r/pure (fn* [] (clojure.core/vector 1 2))))))])) (tests "ordering" (match (l/test-compile ::Main (::lang/call (::lang/call (::lang/ctor (::lang/ctor :foo))))) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 16f1fbc97..454f72216 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -68,7 +68,7 @@ #?(:clj (tests "." - (with ((l/single {} (e/server (tap (. java.time.Instant EPOCH)))) tap tap) + (with ((l/single {} (tap (. java.time.Instant EPOCH))) tap tap) % := java.time.Instant/EPOCH))) (tests "loop/recur" @@ -582,7 +582,7 @@ % := ::outer)) (tests "lazy parameters. Flows are not run unless sampled" - (with ((l/single {} ($ (e/fn [_]) (tap :boom))) tap tap) + (with ((l/single {} [($ (e/fn* [_]) (tap :not)) (tap :boom)]) tap tap) % := :boom)) (tests "lazy parameters. Flows are not run unless sampled" From 20e93f0ad2b5dddca1e3f30538b5ded1c051d3c5 Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 5 Mar 2024 10:33:30 +0100 Subject: [PATCH 130/428] compiler: reduce compilation time --- src/hyperfiddle/electric/impl/lang_de2.clj | 46 +++++++++++----------- 1 file changed, 23 insertions(+), 23 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index ee1ac022c..b330db287 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -837,29 +837,29 @@ ts (sort-by #(::fx-order (ts/->node ts %)) frees-e)))) ts (-> ts :ave ::ctor-free vals))) inline-nodes (fn inline-nodes [ts] - (let [lets-e (->> ts :ave ::used-refs vals (reduce into) - (remove #(has-node? ts (::uid (ts/->node ts %)))))] - (if-some [let-e (first lets-e)] - (let [let-nd (ts/->node ts let-e) - let-val-e (->let-val-e ts let-e), let-val-nd (ts/->node ts let-val-e) - let-body-e (->let-body-e ts let-e) - letrefs-e (mapv #(uid->e ts %) (::used-refs let-nd)) - letref-e (first (ca/check #(= 1 (count %)) letrefs-e - {:letrefs letrefs-e})) - letref-nd (ts/->node ts letref-e) - ts ; (inc (let [x (dec 1)] x)) - (-> ts (ts/del let-val-e) ; (inc (let [x _] x)) - (ts/del letref-e) ; (inc (let [x _] _)) - (ts/add (assoc let-val-nd :db/id letref-e, ::parent (::parent letref-nd))) ; (inc (let [x _] (_))) - (reparent-children let-val-e letref-e) ; (inc (let [x _] (dec 1)) - (ts/del let-e)) ; (inc _), (dec 1) floating - let-body-nd (ts/->node ts let-body-e)] - (-> ts - (ts/del let-body-e) ; (inc _) - (ts/add (assoc let-body-nd :db/id let-e, ::parent (::parent let-nd))) ; (inc (_)) - (reparent-children let-body-e let-e) ; (inc (dec 1)) - (recur))) - ts))) + (reduce (fn [ts let-uid] + (let [let-e (uid->e ts let-uid) + let-nd (ts/->node ts let-e) + let-val-e (->let-val-e ts let-e), let-val-nd (ts/->node ts let-val-e) + let-body-e (->let-body-e ts let-e) + letrefs-e (mapv #(uid->e ts %) (::used-refs let-nd)) + letref-e (first (ca/check #(= 1 (count %)) letrefs-e + {:letrefs letrefs-e})) + letref-nd (ts/->node ts letref-e) + ts ; (inc (let [x (dec 1)] x)) + (-> ts (ts/del let-val-e) ; (inc (let [x _] x)) + (ts/del letref-e) ; (inc (let [x _] _)) + (ts/add (assoc let-val-nd :db/id letref-e, ::parent (::parent letref-nd))) ; (inc (let [x _] (_))) + (reparent-children let-val-e letref-e) ; (inc (let [x _] (dec 1)) + (ts/del let-e)) ; (inc _), (dec 1) floating + let-body-nd (ts/->node ts let-body-e)] + (-> ts + (ts/del let-body-e) ; (inc _) + (ts/add (assoc let-body-nd :db/id let-e, ::parent (::parent let-nd))) ; (inc (_)) + (reparent-children let-body-e let-e)))) ; (inc (dec 1)) + ts (->> ts :ave ::used-refs vals (reduce into) + (remove #(has-node? ts (::uid (ts/->node ts %)))) + (mapv #(e->uid ts %))))) in-a-call? (fn in-a-call? [ts e] (loop [e (::parent (ts/->node ts e))] (when-let [nd (ts/->node ts e)] From cd041faabfc66f08b17c683342ddeaac480a6ca5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Fri, 8 Mar 2024 13:54:12 +0100 Subject: [PATCH 131/428] runtime self-recursion --- src/hyperfiddle/electric/impl/runtime_de.cljc | 421 ++++++++++-------- 1 file changed, 238 insertions(+), 183 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 9425ab118..cec9ef5bc 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -9,6 +9,13 @@ #?(:clj (set! *warn-on-reflection* true)) +(def reclaim + "Returns a fresh object. When the object is reclaimed by GC, provided function is called with no argument." + #?(:cljs + (let [registry (js/FinalizationRegistry. #(%))] + (fn [f] (let [obj (js-obj)] (.register registry obj f) obj))) + :clj (fn [f] (reify Object (finalize [_] (f)))))) + (defn pst [e] #?(:clj (.printStackTrace ^Throwable e) :cljs (.error js/console e))) @@ -22,6 +29,14 @@ (def peer-slot-result 6) (def peer-slots 7) +(def port-slot-frame 0) +(def port-slot-id 1) +(def port-slot-deps 2) +(def port-slot-flow 3) +(def port-slot-refcount 4) +(def port-slot-process 5) +(def port-slots 6) + (declare peer-cancel peer-transfer) (deftype Peer [site defs step done queues pushes state] @@ -32,7 +47,7 @@ (#?(:clj deref :cljs -deref) [this] (peer-transfer this))) -;; Pure | Ap | Join | Port +;; Pure | Ap | Join | Slot (defprotocol Expr (deps [_]) ;; returns #{Port} (flow [_])) ;; returns incseq @@ -172,6 +187,8 @@ T T T -> (EXPR T) (def cdef ->Cdef) +(declare slot-port) + (deftype Ctor [peer key idx ^objects free env ^:unsynchronized-mutable ^:mutable hash-memo] #?(:clj Object) @@ -185,7 +202,7 @@ T T T -> (EXPR T) i 0] (if (== i (alength free)) (set! hash-memo h) - (recur (hash-combine h (hash (aget free i))) + (recur (hash-combine h (hash (slot-port (aget free i)))) (inc i)))))) #?(:cljs IEquiv) (#?(:clj equals :cljs -equiv) [_ other] @@ -199,7 +216,7 @@ T T T -> (EXPR T) (if (== n (alength f)) (loop [i 0] (if (== i n) - true (if (= (aget free i) (aget f i)) + true (if (= (slot-port (aget free i)) (slot-port (aget f i))) (recur (inc i)) false))) false))))) (defn bind " @@ -232,6 +249,12 @@ T T T -> (EXPR T) (declare result) +(defn port-flow [^objects port] + (aget port port-slot-flow)) + +(defn port-deps [^objects port] + (aget port port-slot-deps)) + (deftype Frame [parent call-id rank site ctor ^ints ranks ^objects children ^objects ports ^:unsynchronized-mutable ^:mutable hash-memo] @@ -251,7 +274,7 @@ T T T -> (EXPR T) (= rank (.-rank ^Frame other)))) IFn (#?(:clj invoke :cljs -invoke) [this step done] - ((flow (result this)) step done))) + ((port-flow (result this)) step done))) (defn frame-ctor "Returns the constructor of given frame." @@ -310,83 +333,6 @@ T T T -> (EXPR T) (if-some [site (.-result (frame-cdef frame))] site (frame-site frame))) -(def port-slot-deps 0) -(def port-slot-flow 1) -(def port-slot-refcount 2) -(def port-slot-process 3) -(def port-slots 4) - -(deftype Port [frame id ^objects state - ^:unsynchronized-mutable ^:mutable hash-memo] - #?(:clj Object) - #?(:cljs IHash) - (#?(:clj hashCode :cljs -hash) [_] - (if-some [h hash-memo] - h (set! hash-memo - (hash-combine (hash frame) (hash id))))) - #?(:cljs IEquiv) - (#?(:clj equals :cljs -equiv) [_ other] - (and (instance? Port other) - (= frame (.-frame ^Port other)) - (= id (.-id ^Port other)))) - Expr - (deps [_] (aget state port-slot-deps)) - (flow [_] (aget state port-slot-flow)) - IFn - (#?(:clj invoke :cljs -invoke) [this step done] - ((flow this) step done))) - -(declare port-detach) - -(deftype Remote [^Port port step done ^:unsynchronized-mutable ^:mutable diff] - IFn - (#?(:clj invoke :cljs -invoke) [_] - (port-detach port) - (if (nil? diff) - (step) (set! diff nil))) - (#?(:clj invoke :cljs -invoke) [_ value] - (if (nil? value) - (do (port-detach port) - (when (nil? diff) (done))) - (if-some [prev diff] - (set! diff (i/combine prev value)) - (do (set! diff value) (step))))) - IDeref - (#?(:clj deref :cljs -deref) [this] - (if-some [value diff] - (do (set! diff nil) - (when-not (identical? this (aget ^objects (.-state port) port-slot-process)) - (done)) value) - (do (done) (throw (Cancelled. "Remote port cancelled.")))))) - -(defn deregister-from-parent [^Frame frame] - (when-some [^Frame parent (.-parent frame)] - (let [^objects children (.-children parent) - call-id (.-call-id frame) - siblings (dissoc (aget children call-id) (.-rank frame))] - (case siblings - {} (let [^ints ranks (.-ranks parent) - callc (frame-call-count parent) - refcount (aget ranks callc)] - (aset ranks callc (unchecked-dec-int refcount)) - (aset children call-id nil) - (when (zero? refcount) (recur parent))) - (aset children call-id siblings))))) - -(defn register-to-parent [^Frame frame] - (when-some [^Frame parent (.-parent frame)] - (let [^objects children (.-children parent) - call-id (.-call-id frame) - siblings (aget children call-id)] - (case siblings - nil (let [^ints ranks (.-ranks parent) - callc (frame-call-count parent) - refcount (aget ranks callc)] - (aset ranks callc (unchecked-inc-int refcount)) - (aset children call-id {(.-rank frame) frame}) - (when (zero? refcount) (recur parent))) - (aset children call-id (assoc siblings (.-rank frame) frame)))))) - (defn peer-push [^Peer peer offset item] (let [^objects state (.-state peer) ^objects queues (.-queues peer) @@ -415,82 +361,136 @@ T T T -> (EXPR T) (defn peer-tap [^Peer peer port] (peer-push peer 0 port) peer) -(defn port-attach [^Port port ps] - (aset ^objects (.-state port) port-slot-process ps) - (let [^Frame frame (.-frame port) - ^ints ranks (.-ranks frame) - callc (frame-call-count frame) - refcount (aget ranks callc)] - (aset ranks callc (unchecked-inc-int refcount)) - (when (zero? refcount) (register-to-parent frame)) - (reduce peer-tap (frame-peer frame) (deps port)))) +(defn port-attach [^objects port ps] + (aset port port-slot-process ps) + (reduce peer-tap (frame-peer (aget port port-slot-frame)) + (aget port port-slot-deps))) (defn peer-untap [^Peer peer port] (peer-push peer 1 port) peer) -(defn port-detach [^Port port] - (aset ^objects (.-state port) port-slot-process nil) - (let [^Frame frame (.-frame port) - ^ints ranks (.-ranks frame) - callc (frame-call-count frame) - refcount (unchecked-dec-int (aget ranks callc))] - (aset ranks callc refcount) - (when (zero? refcount) (deregister-from-parent frame)) - (reduce peer-untap (frame-peer frame) (deps port)))) - -(defn port-ready [^Port port] - (peer-push (frame-peer (.-frame port)) 2 port)) - -(defn port-tap [^Port port] - (let [^objects state (.-state port) - prev (aget state port-slot-refcount)] - (aset state port-slot-refcount (inc prev)) +(defn port-detach [^objects port] + (aset port port-slot-process nil) + (reduce peer-untap (frame-peer (aget port port-slot-frame)) + (aget port port-slot-deps))) + +(defn frame-child + {:tag Frame} + [^Frame frame [call-id rank]] + (let [^objects children (.-children frame)] + (get (aget children call-id) rank))) + +(defn peer-frame + {:tag Frame} + [^Peer peer path] + (let [^objects state (.-state peer)] + (reduce frame-child (aget state peer-slot-root) path))) + +(defn port-process + [^objects port] + (aget port port-slot-process)) + +(deftype Remote [port step done ^:unsynchronized-mutable ^:mutable diff] + IFn + (#?(:clj invoke :cljs -invoke) [_] + (port-detach port) + (if (nil? diff) + (step) (set! diff nil))) + (#?(:clj invoke :cljs -invoke) [_ value] + (if (nil? value) + (do (port-detach port) + (when (nil? diff) (done))) + (if-some [prev diff] + (set! diff (i/combine prev value)) + (do (set! diff value) (step))))) + IDeref + (#?(:clj deref :cljs -deref) [this] + (if-some [value diff] + (do (set! diff nil) + (when-not (identical? this (port-process port)) + (done)) value) + (do (done) (throw (Cancelled. "Remote port cancelled.")))))) + +(deftype Slot [^Frame frame id] + #?(:clj Object) + #?(:cljs IHash) + (#?(:clj hashCode :cljs -hash) [this] + (hash (slot-port this))) + #?(:cljs IEquiv) + (#?(:clj equals :cljs -equiv) [this that] + (and (instance? Slot that) + (= (slot-port this) (slot-port that)))) + Expr + (deps [this] (port-deps (slot-port this))) + (flow [this] (port-flow (slot-port this))) + IFn + (#?(:clj invoke :cljs -invoke) [this step done] + ((flow this) step done))) + +(defn frame-port + {:tag 'objects} + [^Frame frame id] + (let [^objects ports (.-ports frame)] + (aget ports id))) + +(defn slot-port + {:tag 'objects} + [^Slot slot] + (frame-port (.-frame slot) (.-id slot))) + +(defn port-ready [^objects port] + (peer-push (frame-peer (aget port port-slot-frame)) 2 port)) + +(defn port-tap [^objects port] + (let [prev (aget port port-slot-refcount)] + (aset port port-slot-refcount (inc prev)) (when (zero? prev) - (aset state port-slot-process - ((flow port) + (aset port port-slot-process + ((port-flow port) #(port-ready port) - #(do (aset state port-slot-process nil) + #(do (aset port port-slot-process nil) (port-ready port))))))) -(defn port-untap [^Port port] - (let [^objects state (.-state port) - curr (dec (aget state port-slot-refcount))] - (aset state port-slot-refcount curr) - (when (zero? curr) - ((aget state port-slot-process))))) +(defn port-untap [^objects port] + (let [curr (dec (aget port port-slot-refcount))] + (aset port port-slot-refcount curr) + (when (zero? curr) ((port-process port))))) (defn make-local [frame id incseq] - (let [state (object-array port-slots) - port (->Port frame id state nil)] - (aset state port-slot-deps #{port}) - (aset state port-slot-flow incseq) - (aset state port-slot-refcount (identity 0)) + (let [port (object-array port-slots)] + (aset port port-slot-frame frame) + (aset port port-slot-id id) + (aset port port-slot-deps #{port}) + (aset port port-slot-flow incseq) + (aset port port-slot-refcount (identity 0)) port)) (defn make-remote [frame id deps] - (let [state (object-array port-slots) - port (->Port frame id state nil)] - (aset state port-slot-deps deps) - (aset state port-slot-flow + (let [port (object-array port-slots)] + (aset port port-slot-frame frame) + (aset port port-slot-id id) + (aset port port-slot-deps deps) + (aset port port-slot-flow (m/signal i/combine (fn [step done] (let [ps (->Remote port step done (i/empty-diff 0))] (port-attach port ps) (step) ps)))) port)) -(defn make-frame [^Frame parent call-id rank site ctor] +(defn make-frame [^Frame parent call-id rank ctor] (let [peer (ctor-peer ctor) cdef (ctor-cdef ctor) callc (count (.-calls cdef)) result (+ (count (.-nodes cdef)) callc) ports (object-array (inc result)) - frame (->Frame parent call-id rank site ctor + frame (->Frame parent call-id rank (if (nil? parent) :client (frame-site parent)) ctor (int-array (inc callc)) (object-array callc) ports nil) expr ((.-build cdef) frame)] (aset ports result - (if (instance? Port expr) - expr (if (= (.-site peer) (result-site frame)) - (make-local frame nil (flow expr)) - (make-remote frame nil (deps expr))))) frame)) + (if (instance? Slot expr) + (slot-port expr) + (if (= (.-site peer) (result-site frame)) + (make-local frame nil (flow expr)) + (make-remote frame nil (deps expr))))) frame)) (defn peer-cancel [^Peer peer] (prn :TODO-cancel)) @@ -508,6 +508,21 @@ T T T -> (EXPR T) :cljs (t/write (t/writer :json opts) value))) +(defn frame-path [^Frame frame] + (loop [^Frame frame frame + path ()] + (if-some [parent (.-parent frame)] + (recur parent + (conj path + [(.-call-id ^Frame frame) + (.-rank ^Frame frame)])) + path))) + +(defn port-inst [^objects port] + [(frame-path (aget port port-slot-frame)) + (aget port port-slot-id) + (when-some [ps (port-process port)] @ps)]) + (defn peer-transfer [^Peer peer] (let [^objects state (.-state peer) ^objects queues (.-queues peer) @@ -531,39 +546,53 @@ T T T -> (EXPR T) (recur insts tap-pull (rem (unchecked-inc-int untap-pull) (alength untap-queue)) ready-pull)) - (if-some [^Port port (aget ready-queue ready-pull)] - (let [^objects state (.-state port)] - (aset ready-queue ready-pull nil) - (recur (conj insts - (loop [^Frame frame (.-frame port) - path ()] - (if-some [parent (.-parent frame)] - (recur parent (conj path [(.-call-id ^Frame frame) (.-rank ^Frame frame)])) - [path (.-id port) (when-some [ps (aget state port-slot-process)] @ps)]))) - tap-pull untap-pull - (rem (unchecked-inc-int ready-pull) - (alength ready-queue)))) + (if-some [port (aget ready-queue ready-pull)] + (do (aset ready-queue ready-pull nil) + (recur (conj insts (port-inst port)) + tap-pull untap-pull + (rem (unchecked-inc-int ready-pull) + (alength ready-queue)))) (do (aset state peer-slot-output-pending true) (aset pushes 0 0) (aset pushes 1 0) (aset pushes 2 0) (encode insts (aget state peer-slot-writer-opts)))))))))) -(defn child-at [^Frame frame [call-id rank]] - (let [^objects children (.-children frame)] - (get (aget children call-id) rank))) - -(defn peer-apply-change [^Peer peer [path id diff]] - (let [^Frame frame (reduce child-at (aget ^objects (.-state peer) peer-slot-root) path) - ^Port port (aget ^objects (.-ports frame) id)] - ((aget ^objects (.-state port) port-slot-process) diff) peer)) +(defn frame-shared? [^Frame frame] + (let [rank (.-rank frame) + call-id (.-call-id frame) + ^Frame parent (.-parent frame) + ^objects children (.-children parent)] + (contains? (aget children call-id) rank))) + +(defn frame-share [^Frame frame] + (let [rank (.-rank frame) + call-id (.-call-id frame) + ^Frame parent (.-parent frame) + ^objects children (.-children parent)] + (aset children call-id + (assoc (aget children call-id) + rank frame)))) + +(defn frame-unshare [^Frame frame] + (let [rank (.-rank frame) + call-id (.-call-id frame) + ^Frame parent (.-parent frame) + ^objects children (.-children parent)] + (aset children call-id + (dissoc (aget children call-id) + rank frame)))) + +(defn peer-inst [^Peer peer [path id diff]] + ((port-process (frame-port (peer-frame peer path) id)) diff) + peer) (defn peer-input-ready [^Peer peer] (let [^objects state (.-state peer)] (loop [] (when (aset state peer-slot-input-busy (not (aget state peer-slot-input-busy))) - (try (reduce peer-apply-change peer + (try (reduce peer-inst peer (decode @(aget state peer-slot-input-process) (aget state peer-slot-reader-opts))) (catch #?(:clj Throwable :cljs :default) e @@ -582,26 +611,25 @@ T T T -> (EXPR T) (defn define-node "Defines signals node id for given frame." [^Frame frame id expr] - (let [^objects ports (.-ports frame) - site (node-site frame id)] + (let [^objects ports (.-ports frame)] (when-not (nil? (aget ports id)) (throw (error "Can't redefine signal node."))) (aset ports id - (if (instance? Port expr) - expr (if (= site (.-site (frame-peer frame))) - (make-local frame id (m/signal i/combine (flow expr))) - (make-remote frame id (deps expr))))) nil)) + (if (instance? Slot expr) + (slot-port expr) + (if (= (node-site frame id) (.-site (frame-peer frame))) + (make-local frame id (m/signal i/combine (flow expr))) + (make-remote frame id (deps expr))))) nil)) (defn define-call "Defines call site id for given frame." [^Frame frame id expr] (let [^objects ports (.-ports frame) - slot (+ id (count (.-nodes (frame-cdef frame)))) - site (call-site frame id)] + slot (+ id (count (.-nodes (frame-cdef frame))))] (when-not (nil? (aget ports slot)) (throw (error "Can't redefine call site."))) (aset ports slot - (if (= site (.-site (frame-peer frame))) + (if (= (call-site frame id) (.-site (frame-peer frame))) (make-local frame id (m/signal i/combine (i/latest-product @@ -613,20 +641,21 @@ T T T -> (EXPR T) (let [^ints ranks (.-ranks frame) rank (aget ranks id)] (aset ranks id (inc rank)) - (make-frame frame id rank site ctor))) + (make-frame frame id rank ctor))) (flow expr)))) (make-remote frame id (deps expr)))) nil)) (defn define-free "Defines free variable id for given constructor." - [^Ctor ctor id incseq] + [^Ctor ctor id ^Slot slot] (let [^objects free (.-free ctor)] (when-not (nil? (aget free id)) (throw (error "Can't redefine free variable."))) - (aset free id incseq) nil)) + (aset free id slot) nil)) (defn lookup "Returns the value associated with given key in the dynamic environment of given frame." + {:tag Expr} ([^Frame frame key] (lookup frame key (->Unbound key))) ([^Frame frame key nf] @@ -637,6 +666,7 @@ T T T -> (EXPR T) (defn make-ctor "Returns a fresh constructor for cdef coordinates key and idx." + {:tag Ctor} [^Frame frame key idx & frees] (let [^Peer peer (frame-peer frame) ^Cdef cdef ((ca/check some? ((.-defs peer) key) {:key key}) idx) @@ -647,25 +677,26 @@ T T T -> (EXPR T) (defn node "Returns the signal node id for given frame." + {:tag Slot} [^Frame frame id] - (let [^objects ports (.-ports frame)] - (aget ports id))) + (->Slot frame id)) + +(defn call + "Returns the call site id for given frame." + {:tag Slot} + [^Frame frame id] + (->Slot frame (+ (count (.-nodes (frame-cdef frame))) id))) (defn free "Returns the free variable id for given frame." + {:tag Slot} [^Frame frame id] (let [^objects free (.-free (frame-ctor frame))] (aget free id))) -(defn call - "Returns the call site id for given frame." - [^Frame frame id] - (let [^objects ports (.-ports frame) - ^Cdef cdef (frame-cdef frame)] - (aget ports (+ (count (.-nodes cdef)) id)))) - (defn result "Returns the result of given frame." + {:tag 'objects} [^Frame frame] (let [^objects ports (.-ports frame) ^Cdef cdef (frame-cdef frame)] @@ -685,15 +716,39 @@ Returns a peer definition from given definitions and main key. input (m/stream (m/observe events)) root (->> args (apply bind-args (->Ctor peer main 0 (object-array 0) {} nil)) - (make-frame nil 0 0 :client))] + (make-frame nil 0 0))] (aset state peer-slot-writer-opts - {:handlers {Ctor (t/write-handler - (fn [_] "ctor") - (fn [^Ctor ctor] - (assert (identical? peer (.-peer ctor))) - (list* (.-key ctor) (.-idx ctor) (.-free ctor) (.-env ctor))))}}) + {:handlers {Ctor (t/write-handler + (fn [_] "ctor") + (fn [^Ctor ctor] + (assert (identical? peer (.-peer ctor))) + (list* (.-key ctor) (.-idx ctor) (.-env ctor) (.-free ctor)))) + Slot (t/write-handler + (fn [_] "slot") + (fn [^Slot slot] + [(.-frame slot) (.-id slot)])) + Frame (t/write-handler + (fn [_] "frame") + (fn [^Frame frame] + [(frame-path frame) + (when-not (frame-shared? frame) + (frame-share frame) + (.-ctor frame))]))}}) (aset state peer-slot-reader-opts - {:handlers {"ctor" (t/read-handler (fn [[k i f e]] (->Ctor peer k i (object-array f) e nil)))}}) + {:handlers {"ctor" (t/read-handler + (fn [[key idx env & free]] + (->Ctor peer key idx (object-array free) env nil))) + "slot" (t/read-handler + (fn [[frame id]] + (->Slot frame id))) + "frame" (t/read-handler + (fn [[path ctor]] + (if (nil? ctor) + (peer-frame peer path) + (let [[call rank] (peek path) + parent (peer-frame peer (pop path)) + frame (make-frame parent call rank ctor)] + (frame-share frame) frame))))}}) (aset state peer-slot-output-pending true) (aset state peer-slot-input-busy true) (aset state peer-slot-input-process @@ -702,16 +757,16 @@ Returns a peer definition from given definitions and main key. (case site :client (aset state peer-slot-result ((m/reduce peer-result-diff peer - (m/signal i/combine (flow (result root)))) + (m/signal i/combine (port-flow (result root)))) peer-result-success pst)) - :server (reduce peer-tap peer (deps (result root)))) + :server (reduce peer-tap peer (aget (result root) port-slot-deps))) (peer-input-ready peer) peer))) ;; local only (defn root-frame [defs main] (->> (bind-args (->Ctor (->Peer :client defs nil nil nil nil nil) main 0 (object-array 0) {} nil)) - (make-frame nil 0 0 :client) + (make-frame nil 0 0) (m/signal i/combine))) #?(:clj From addc2f87fcbdcfbe44c1910cdd0d56fce35ac7cb Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 6 Mar 2024 12:44:24 +0100 Subject: [PATCH 132/428] refactor, e/letfn scratch --- src/hyperfiddle/electric/impl/lang_de2.clj | 18 ++++---- src/hyperfiddle/electric_de.cljc | 46 +++++++++---------- .../electric/impl/compiler_test.cljc | 26 ++++++++++- test/hyperfiddle/electric_de_test.cljc | 6 +++ 4 files changed, 62 insertions(+), 34 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index b330db287..f7c39eb7c 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -164,7 +164,7 @@ env2 (reduce add-local env (take-nth 2 bs)) bs2 (->> bs (into [] (comp (partition-all 2) (mapcat (fn [[sym v]] [sym (-expand-all v env2)])))))] - (recur (?meta o `(let [~(vec (take-nth 2 bs2)) (::letfn ~bs2)] ~(-expand-all (cons 'do body) env2))) + (recur (?meta o `(let [~(vec (take-nth 2 bs2)) (::cc-letfn ~bs2)] ~(-expand-all (cons 'do body) env2))) env)) (try) (throw (ex-info "try is TODO" {:o o})) #_(list* 'try (mapv (fn-> -all-in-try env) (rest o))) @@ -487,6 +487,11 @@ (update env ::last #(conj (pop %) form)) (assoc env ::last (conj (clojure.lang.PersistentQueue/EMPTY) nil form)))) +(defn e->uid [ts e] (ca/check (::uid (ts/->node ts e)))) +(defn uid->e [ts uid] (first (ca/check #(= 1 (count %)) (ts/find ts ::uid uid)))) +(defn reparent-children [ts from-e to-e] + (reduce (fn [ts e] (ts/asc ts e ::parent to-e)) ts (ts/find ts ::parent from-e))) + (defn analyze [form pe env {{::keys [->id ->uid]} :o :as ts}] (let [env (store env form)] (cond @@ -513,8 +518,8 @@ (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form}))) (fn*) (let [e (->id), [form refs] (closure env form)] (ap-literal form refs pe e env (?add-source-map ts e form))) - (::letfn) (let [[_ bs] form, [form refs] (closure env `(letfn* ~bs ~(vec (take-nth 2 bs)))), e (->id)] - (ap-literal form refs pe e env (?add-source-map ts e form))) + (::cc-letfn) (let [[_ bs] form, [form refs] (closure env `(letfn* ~bs ~(vec (take-nth 2 bs)))), e (->id)] + (ap-literal form refs pe e env (?add-source-map ts e form))) (new) (let [[_ f & args] form, current (get (::peers env) (::current env))] (if (or (nil? current) (= (->env-type env) current)) (let [f (let [gs (repeatedly (count args) gensym)] `(fn [~@gs] (new ~f ~@gs)))] @@ -644,9 +649,6 @@ (defn get-node-idx [ts ctor-uid uid] (->> (ts/find ts ::ctor-node ctor-uid, ::ctor-ref uid) first (ts/->node ts) ::node-idx)) -(defn e->uid [ts e] (ca/check (::uid (ts/->node ts e)))) -(defn uid->e [ts uid] (first (ca/check #(= 1 (count %)) (ts/find ts ::uid uid)))) - (defn emit [ts e ctor-e env nm] ((fn rec [e] (let [nd (get (:eav ts) e)] @@ -772,9 +774,7 @@ (defn analyze-electric [env {{::keys [->id]} :o :as ts}] (when (::print-analysis env) (run! prn (ts->reducible ts))) - (let [reparent-children (fn reparent-children [ts from-e to-e] - (reduce (fn [ts e] (ts/asc ts e ::parent to-e)) ts (ts/find ts ::parent from-e))) - collapse-ap-with-only-pures (fn collapse-ap-with-only-pures [ts] + (let [collapse-ap-with-only-pures (fn collapse-ap-with-only-pures [ts] ;; (ap (pure x) (pure y) (pure z)) -> (ap (pure (comp x y z))) (reduce (fn [ts ap-e] (let [ce (get-children-e ts ap-e)] diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 4d34ec00d..f2a85dfe5 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -1,5 +1,5 @@ (ns hyperfiddle.electric-de - (:refer-clojure :exclude [fn defn apply]) + (:refer-clojure :exclude [fn defn apply letfn]) (:require [hyperfiddle.electric.impl.lang-de2 :as lang] [hyperfiddle.electric.impl.runtime-de :as r] [hyperfiddle.incseq :as i] @@ -201,27 +201,27 @@ this tuple. Returns the concatenation of all body results as a single vector. (cc/defn- -splicev [args] (into [] cat [(pop args) (peek args)])) (hyperfiddle.electric-de/defn Apply* [F args] - (let [spliced (-splicev args)] - (case (count spliced) + (let [s (-splicev args)] + (case (count s) 0 ($ F) - 1 ($ F (nth spliced 0)) - 2 ($ F (nth spliced 0) (nth spliced 1)) - 3 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2)) - 4 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3)) - 5 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4)) - 6 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5)) - 7 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6)) - 8 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6) (nth spliced 7)) - 9 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6) (nth spliced 7) (nth spliced 8)) - 10 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6) (nth spliced 7) (nth spliced 8) (nth spliced 9)) - 11 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6) (nth spliced 7) (nth spliced 8) (nth spliced 9) (nth spliced 10)) - 12 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6) (nth spliced 7) (nth spliced 8) (nth spliced 9) (nth spliced 10) (nth spliced 11)) - 13 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6) (nth spliced 7) (nth spliced 8) (nth spliced 9) (nth spliced 10) (nth spliced 11) (nth spliced 12)) - 14 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6) (nth spliced 7) (nth spliced 8) (nth spliced 9) (nth spliced 10) (nth spliced 11) (nth spliced 12) (nth spliced 13)) - 15 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6) (nth spliced 7) (nth spliced 8) (nth spliced 9) (nth spliced 10) (nth spliced 11) (nth spliced 12) (nth spliced 13) (nth spliced 14)) - 16 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6) (nth spliced 7) (nth spliced 8) (nth spliced 9) (nth spliced 10) (nth spliced 11) (nth spliced 12) (nth spliced 13) (nth spliced 14) (nth spliced 15)) - 17 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6) (nth spliced 7) (nth spliced 8) (nth spliced 9) (nth spliced 10) (nth spliced 11) (nth spliced 12) (nth spliced 13) (nth spliced 14) (nth spliced 15) (nth spliced 16)) - 18 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6) (nth spliced 7) (nth spliced 8) (nth spliced 9) (nth spliced 10) (nth spliced 11) (nth spliced 12) (nth spliced 13) (nth spliced 14) (nth spliced 15) (nth spliced 16) (nth spliced 17)) - 19 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6) (nth spliced 7) (nth spliced 8) (nth spliced 9) (nth spliced 10) (nth spliced 11) (nth spliced 12) (nth spliced 13) (nth spliced 14) (nth spliced 15) (nth spliced 16) (nth spliced 17) (nth spliced 18)) - 20 ($ F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6) (nth spliced 7) (nth spliced 8) (nth spliced 9) (nth spliced 10) (nth spliced 11) (nth spliced 12) (nth spliced 13) (nth spliced 14) (nth spliced 15) (nth spliced 16) (nth spliced 17) (nth spliced 18) (nth spliced 19))))) + 1 ($ F (nth s 0)) + 2 ($ F (nth s 0) (nth s 1)) + 3 ($ F (nth s 0) (nth s 1) (nth s 2)) + 4 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3)) + 5 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4)) + 6 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5)) + 7 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6)) + 8 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6) (nth s 7)) + 9 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6) (nth s 7) (nth s 8)) + 10 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6) (nth s 7) (nth s 8) (nth s 9)) + 11 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6) (nth s 7) (nth s 8) (nth s 9) (nth s 10)) + 12 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6) (nth s 7) (nth s 8) (nth s 9) (nth s 10) (nth s 11)) + 13 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6) (nth s 7) (nth s 8) (nth s 9) (nth s 10) (nth s 11) (nth s 12)) + 14 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6) (nth s 7) (nth s 8) (nth s 9) (nth s 10) (nth s 11) (nth s 12) (nth s 13)) + 15 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6) (nth s 7) (nth s 8) (nth s 9) (nth s 10) (nth s 11) (nth s 12) (nth s 13) (nth s 14)) + 16 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6) (nth s 7) (nth s 8) (nth s 9) (nth s 10) (nth s 11) (nth s 12) (nth s 13) (nth s 14) (nth s 15)) + 17 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6) (nth s 7) (nth s 8) (nth s 9) (nth s 10) (nth s 11) (nth s 12) (nth s 13) (nth s 14) (nth s 15) (nth s 16)) + 18 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6) (nth s 7) (nth s 8) (nth s 9) (nth s 10) (nth s 11) (nth s 12) (nth s 13) (nth s 14) (nth s 15) (nth s 16) (nth s 17)) + 19 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6) (nth s 7) (nth s 8) (nth s 9) (nth s 10) (nth s 11) (nth s 12) (nth s 13) (nth s 14) (nth s 15) (nth s 16) (nth s 17) (nth s 18)) + 20 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6) (nth s 7) (nth s 8) (nth s 9) (nth s 10) (nth s 11) (nth s 12) (nth s 13) (nth s 14) (nth s 15) (nth s 16) (nth s 17) (nth s 18) (nth s 19))))) (defmacro apply [F & args] `($ Apply* ~F [~@args])) diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index 7a96cd294..ed22cf5d1 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -499,10 +499,32 @@ (r/node ~'frame 0) (r/join (r/call ~'frame 1))))) (r/cdef 0 [] [] nil (fn [~'frame] (r/pure 1))) - (r/cdef 0 [] [] nil (fn [~'frame] (r/pure 2)))]) - ) + (r/cdef 0 [] [] nil (fn [~'frame] (r/pure 2)))])) (comment + (tests "test-e-letfn" + (match (l/test-compile ::Main (assoc (lang/normalize-env {}) ::lang/print-analysis true, ::lang/print-db true, ::lang/print-source true) + (e/letfn [(Foo [] Bar) (Bar [] Foo)] Foo)) + `[])) + + (mklet x ; let, ->let-body-e is just get-child-e + (mklet y ; let + (bindlet x y ; bindlet, ->let-val-e finds bindlet value + (bindlet y x + x)))) + (l/test-compile ::Main (assoc (lang/normalize-env {}) ::lang/print-analysis true, ::lang/print-db true) + (::lang/mk-let x (::lang/mk-let y (::lang/bind-let x (e/ctor y) (::lang/bind-let y (e/ctor x) x))))) + `[(r/cdef 0 [nil nil] [] nil + (fn [frame] + (r/define-node frame 0 (r/pure (doto (r/make-ctor frame ::l/Main 1) + (r/define-free 0 (r/node frame 1))))) + (r/define-node frame 1 (r/pure (doto (r/make-ctor frame ::l/Main 2) + (r/define-free 0 (r/node frame 0))))) + (r/node frame 0))) + (r/cdef 1 [] [] nil + (fn [frame] (r/free frame 0))) + (r/cdef 1 [] [] nil + (fn [frame] (r/free frame 0)))] (l/test-compile ::Main (let [fizz "fizz", buzz "buzz"] (e/ctor (str fizz buzz))))) ;; TODO test site is cleared on ctor boundary diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 454f72216..f63b3620f 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -2081,6 +2081,12 @@ (with ((l/single {} (tap ((fn [] (binding [*out* nil] 1))))) tap tap) % := 1)) +#_(tests "e/letfn" + (with ((l/single {} (tap (e/letfn [(Odd? [x] (if (zero? x) false ($ Even? (dec x)))) + (Even? [x] (if (zero? x) true ($ Odd? (dec x))))] + (Even? 2)))) tap tap) + % := true)) + (let [{:keys [tested skipped]} @stats, all (+ tested skipped)] (prn '===) (println 'tested tested (str (long (* (/ tested all) 100)) "%")) From 6400a2574d7a126ce18999415001c475c79b0312 Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 7 Mar 2024 14:51:32 +0100 Subject: [PATCH 133/428] compiler: e/letfn --- deps.edn | 1 + src/hyperfiddle/electric/impl/lang_de2.clj | 217 ++++++++++-------- src/hyperfiddle/electric_de.cljc | 13 +- .../electric/impl/compiler_test.cljc | 10 +- test/hyperfiddle/electric_de_test.cljc | 25 +- 5 files changed, 158 insertions(+), 108 deletions(-) diff --git a/deps.edn b/deps.edn index bb61e45c7..3641ed7ad 100644 --- a/deps.edn +++ b/deps.edn @@ -66,6 +66,7 @@ }} :profile {:extra-deps {criterium/criterium {:mvn/version "0.4.6"} + com.clojure-goes-fast/clj-java-decompiler {:mvn/version "0.3.4"} com.clojure-goes-fast/clj-async-profiler {:mvn/version "1.0.2"}} :jvm-opts ["-Djdk.attach.allowAttachSelf" "-XX:+UnlockDiagnosticVMOptions" diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index f7c39eb7c..28fddcc75 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -395,7 +395,7 @@ (defn resolve-symbol [sym env] (if-some [local (-> env :locals (get sym))] (if-some [uid (::electric-let local)] - {::lang nil, ::type ::let-ref, ::sym sym, ::ref uid} + {::lang nil, ::type ::localref, ::sym sym, ::ref uid} {::lang nil, ::type ::local, ::sym sym}) (if-some [nd (resolve-node sym env)] {::lang nil, ::type ::node, ::node nd} @@ -414,18 +414,29 @@ :else (assoc (first vs) ::lang nil))))))) -(defn ->let-val-e [ts e] (first (get-children-e ts e))) -(defn ->let-body-e [ts e] (second (get-children-e ts e))) +(defn ->bindlocal-body-e [ts e] (second (get-children-e ts e))) +(defn ->localv-e [ts mklocal-uid] + (->> (ts/find ts ::type ::bindlocal, ::ref mklocal-uid) first (get-child-e ts))) + (defn get-ret-e [ts e] (let [nd (get (:eav ts) e)] (case (::type nd) - ::let (recur ts (->let-body-e ts e)) - ::site (recur ts (get-child-e ts e)) + (::bindlocal) (recur ts (->bindlocal-body-e ts e)) + (::site ::mklocal) (recur ts (get-child-e ts e)) #_else e))) -(defn get-site [ts e] +(defn find-sitable-point-e [ts e] (loop [e e] + (let [nd (ts/->node ts e)] + (case (::type nd) + (::literal ::ap ::join ::pure ::comp ::ctor) e + (::site) (when (some? (::site nd)) (recur (::parent nd))) + (::var ::node ::call ::lookup ::mklocal ::bindlocal ::localref) (some-> (::parent nd) recur) + #_else (throw (ex-info (str "can't find-sitable-point-e for " (pr-str (::type nd))) (or nd {}))))))) + +(defn get-site [ts e] + (loop [e (find-sitable-point-e ts e)] (when-some [nd (get (:eav ts) e)] (case (::type nd) ::site (::site nd) @@ -498,13 +509,20 @@ (and (seq? form) (seq form)) (case (first form) (let*) (let [[_ bs bform] form] - (loopr [ts ts, pe pe, env env] - [[s v] (eduction (partition-all 2) bs)] - (let [e (->id), uid (->uid)] - (recur (analyze v e env - (-> (ts/add ts {:db/id e, ::parent pe, ::type ::let, ::sym s, ::uid uid}) - (?add-source-map e form))) e (update-in env [:locals s] assoc ::electric-let uid))) - (analyze bform pe env ts))) + (recur (?meta form + (reduce (fn [ac [k v]] + `(::mklocal k# (::bindlocal k# ~v (::mklocal ~k (::bindlocal ~k k# ~ac))))) + bform (->> bs (partition 2) reverse))) + pe env ts)) + (::mklocal) (let [[_ k bform] form, e (->id), uid (->uid) + ts (-> ts (ts/add {:db/id e, ::parent pe, ::type ::mklocal, ::k k, ::uid uid}) + (?add-source-map e form))] + (recur bform e (update-in env [:locals k] assoc ::electric-let uid) ts)) + (::bindlocal) (let [[_ k v bform] form, e (->id) + ts (ts/add ts {:db/id e, ::parent pe, ::type ::bindlocal ::k k + ::ref (-> env :locals (get k) ::electric-let)}) + ts (analyze v e env ts)] + (recur bform e env ts)) (case) (let [[_ test & brs] form [default brs2] (if (odd? (count brs)) [(last brs) (butlast brs)] [:TODO brs])] (loopr [bs [], mp {}] @@ -606,8 +624,8 @@ (symbol? form) (let [e (->id), ret (resolve-symbol form env)] (-> (case (::type ret) - (::let-ref) (ts/add ts {:db/id e, ::parent pe, ::type ::let-ref, ::ref (::ref ret) - ::sym form, ::uid (->uid)}) + (::localref) (ts/add ts {:db/id e, ::parent pe, ::type ::localref, ::ref (::ref ret) + ::sym form, ::uid (->uid)}) (::local) (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form})) (::static ::var) (if (::static-vars env) @@ -685,20 +703,21 @@ ctor)) ::call (list `r/join (list `r/call 'frame (::call-idx (ts/->node ts e)))) ::lookup (list `r/lookup 'frame (::sym nd)) - ::let (recur (get-ret-e ts (->let-body-e ts e))) - ::let-ref + ::mklocal (recur (get-ret-e ts (get-child-e ts e))) + ::bindlocal (recur (get-ret-e ts (->bindlocal-body-e ts e))) + ::localref (if-some [node-e (first (ts/find ts ::ctor-node (e->uid ts ctor-e), ::ctor-ref (::ref nd)))] (list `r/node 'frame (::node-idx (ts/->node ts node-e))) (if-some [free-e (first (ts/find ts ::ctor-free (e->uid ts ctor-e), ::closed-ref (::ref nd)))] (list `r/free 'frame (::free-idx (ts/->node ts free-e))) - (throw (ex-info "let-ref must be a node or free" nd)))) + (throw (ex-info "localref must be a node or free" nd)))) #_else (throw (ex-info (str "cannot emit on " (pr-str (::type nd))) (or nd {})))))) e)) (defn emit-node-init [ts ctor-e node-e env nm] (let [nd (get (:eav ts) node-e)] (list `r/define-node 'frame (::node-idx nd) - (emit ts (->> (::ctor-ref nd) (uid->e ts) (->let-val-e ts) (get-ret-e ts)) ctor-e env nm)))) + (emit ts (->> (::ctor-ref nd) (->localv-e ts) (get-ret-e ts)) ctor-e env nm)))) (defn emit-call-init [ts ctor-e e env nm] (list `r/define-call 'frame (::call-idx (ts/->node ts e)) @@ -723,9 +742,9 @@ (case (::type nd) (::literal ::var ::lookup ::node) (ord ts e) (::ap ::comp) (ord (reduce rec ts (get-children-e ts e)) e) - (::site ::join ::pure ::call ::ctor) (ord (rec ts (get-child-e ts e)) e) - (::let) (recur ts (->let-body-e ts e)) - (::let-ref) (ord (rec ts (->let-val-e ts (uid->e ts (::ref nd)))) (uid->e ts (::ref nd))) + (::site ::join ::pure ::call ::ctor ::mklocal) (ord (rec ts (get-child-e ts e)) e) + (::bindlocal) (recur ts (->bindlocal-body-e ts e)) + (::localref) (ord (rec ts (->localv-e ts (::ref nd))) (uid->e ts (::ref nd))) #_else (throw (ex-info (str "cannot compure-effect-order on " (pr-str (::type nd))) (or nd {}))) ))))) ts e))) @@ -736,7 +755,7 @@ nodes-e (get-ordered-nodes-e ts ctor-uid) calls-e (get-ordered-calls-e ts ctor-uid)] `(r/cdef ~(count (ts/find ts ::ctor-free ctor-uid)) - ~(mapv #(get-site ts (->> (ts/->node ts %) ::ctor-ref (uid->e ts) (->let-val-e ts) (get-ret-e ts))) + ~(mapv #(get-site ts (->> (ts/->node ts %) ::ctor-ref (->localv-e ts) (get-ret-e ts))) nodes-e) ~(mapv #(get-site ts %) calls-e) ~(get-site ts ret-e) @@ -762,9 +781,9 @@ (case (::type nd) (::literal ::var ::lookup) ts (::ap ::comp) (reduce mark ts (get-children-e ts e)) - (::site ::join ::pure ::call ::ctor) (recur ts (get-child-e ts e)) - (::let) (recur ts (->let-body-e ts e)) - (::let-ref) (recur ts (get-ret-e ts (->let-val-e ts (uid->e ts (::ref nd))))) + (::site ::join ::pure ::call ::ctor ::mklocal) (recur ts (get-child-e ts e)) + (::bindlocal) (recur ts (->bindlocal-body-e ts e)) + (::localref) (recur ts (->> (::ref nd) (->localv-e ts) (get-ret-e ts))) (::node) (ts/asc ts e ::node-used true) #_else (throw (ex-info (str "cannot emit-deps/mark on " (pr-str (::type nd))) (or nd {}))))))) es (ts/find (mark ts e) ::node-used true)] @@ -772,25 +791,34 @@ (defn get-deps [sym] (-> sym resolve meta ::deps)) +(defn delete-point-recursively [ts e] + (let [ts (ts/del ts e)] + (if-some [ce (get-children-e ts e)] + (reduce delete-point-recursively ts ce) + ts))) + (defn analyze-electric [env {{::keys [->id]} :o :as ts}] (when (::print-analysis env) (run! prn (ts->reducible ts))) - (let [collapse-ap-with-only-pures (fn collapse-ap-with-only-pures [ts] - ;; (ap (pure x) (pure y) (pure z)) -> (ap (pure (comp x y z))) - (reduce (fn [ts ap-e] - (let [ce (get-children-e ts ap-e)] - (if (every? #(= ::pure (::type (ts/->node ts %))) ce) - (let [pure-e (->id), comp-e (->id)] - (reduce (fn [ts e] - (let [ce (get-child-e ts e), cnd (ts/->node ts ce)] - (-> ts (ts/del e) (ts/del ce) - (ts/add (assoc cnd :db/id e, ::parent comp-e)) - (reparent-children ce e)))) - (-> ts - (ts/add {:db/id pure-e, ::parent ap-e, ::type ::pure}) - (ts/add {:db/id comp-e, ::parent pure-e, ::type ::comp})) - ce)) - ts))) - ts (ts/find ts ::type ::ap))) + (let [collapse-ap-with-only-pures + (fn collapse-ap-with-only-pures [ts] + ;; (ap (pure x) (pure y) (pure z)) -> (ap (pure (comp x y z))) + (reduce (fn [ts ap-e] + (let [ce (get-children-e ts ap-e)] + (if (every? #(= ::pure (::type (ts/->node ts (get-ret-e ts %)))) ce) + (let [pure-e (->id), comp-e (->id)] + (reduce (fn [ts e] + (let [ce (->> e (get-ret-e ts) (get-child-e ts)) + cnd (ts/->node ts ce), newe (->id)] + (-> ts + (ts/add (assoc cnd :db/id newe, ::parent comp-e)) + (reparent-children ce newe) + (delete-point-recursively e)))) + (-> ts + (ts/add {:db/id pure-e, ::parent ap-e, ::type ::pure}) + (ts/add {:db/id comp-e, ::parent pure-e, ::type ::comp})) + ce)) + ts))) + ts (ts/find ts ::type ::ap))) ->ctor-idx (->->id) seen (volatile! #{}) mark-used-ctors (fn mark-used-ctors [ts e] @@ -801,12 +829,12 @@ (case (::type nd) (::literal ::var ::lookup ::node) ts (::ap ::comp) (reduce mark-used-ctors ts (get-children-e ts e)) - (::site ::join ::pure ::call) (recur ts (get-child-e ts e)) + (::site ::join ::pure ::call ::mklocal) (recur ts (get-child-e ts e)) + (::bindlocal) (recur ts (->bindlocal-body-e ts e)) (::ctor) (if (::ctor-idx nd) ts (recur (ts/asc ts e ::ctor-idx (->ctor-idx)) (get-child-e ts e))) - (::let) (recur ts (->let-body-e ts e)) - (::let-ref) (recur ts (get-ret-e ts (->let-val-e ts (uid->e ts (::ref nd))))) + (::localref) (recur ts (->> (::ref nd) (->localv-e ts) (get-ret-e ts))) #_else (throw (ex-info (str "cannot mark-used-ctors on " (pr-str (::type nd))) (or nd {}))))))) ts (-> ts (compute-effect-order 0) (mark-used-ctors 0)) ctors-e (get-ordered-ctors-e ts) @@ -836,30 +864,24 @@ (reduce (fn [ts e] (ts/asc ts e ::free-idx (->idx))) ts (sort-by #(::fx-order (ts/->node ts %)) frees-e)))) ts (-> ts :ave ::ctor-free vals))) + unlink (fn [ts e] + (-> ts (reparent-children e (::parent (ts/->node ts e))) (ts/del e))) inline-nodes (fn inline-nodes [ts] - (reduce (fn [ts let-uid] - (let [let-e (uid->e ts let-uid) - let-nd (ts/->node ts let-e) - let-val-e (->let-val-e ts let-e), let-val-nd (ts/->node ts let-val-e) - let-body-e (->let-body-e ts let-e) - letrefs-e (mapv #(uid->e ts %) (::used-refs let-nd)) - letref-e (first (ca/check #(= 1 (count %)) letrefs-e - {:letrefs letrefs-e})) - letref-nd (ts/->node ts letref-e) - ts ; (inc (let [x (dec 1)] x)) - (-> ts (ts/del let-val-e) ; (inc (let [x _] x)) - (ts/del letref-e) ; (inc (let [x _] _)) - (ts/add (assoc let-val-nd :db/id letref-e, ::parent (::parent letref-nd))) ; (inc (let [x _] (_))) - (reparent-children let-val-e letref-e) ; (inc (let [x _] (dec 1)) - (ts/del let-e)) ; (inc _), (dec 1) floating - let-body-nd (ts/->node ts let-body-e)] + (reduce (fn [ts mklocal-uid] + (let [mklocal-nd (ts/->node ts (uid->e ts mklocal-uid)) + localrefs-e (mapv #(uid->e ts %) (::used-refs mklocal-nd)) + localref-e (first (ca/check #(= 1 (count %)) localrefs-e {:refs localrefs-e})) + localv-e (->localv-e ts mklocal-uid), localv-nd (ts/->node ts localv-e) + site (get-site ts (get-ret-e ts localv-e))] (-> ts - (ts/del let-body-e) ; (inc _) - (ts/add (assoc let-body-nd :db/id let-e, ::parent (::parent let-nd))) ; (inc (_)) - (reparent-children let-body-e let-e)))) ; (inc (dec 1)) + (ts/asc localref-e ::type ::site) + (ts/asc localref-e ::site site) + (ts/asc localv-e ::parent localref-e) + (unlink (:db/id mklocal-nd)) + (unlink (::parent localv-nd))))) ts (->> ts :ave ::used-refs vals (reduce into) - (remove #(has-node? ts (::uid (ts/->node ts %)))) - (mapv #(e->uid ts %))))) + (mapv #(e->uid ts %)) + (remove #(has-node? ts %))))) in-a-call? (fn in-a-call? [ts e] (loop [e (::parent (ts/->node ts e))] (when-let [nd (ts/->node ts e)] @@ -868,36 +890,50 @@ ::ctor false #_else (recur (::parent nd)))))) seen (volatile! #{}) + reroute-local-aliases (fn reroute-local-aliases [ts] + (reduce (fn [ts bl-e] + (let [v-e (get-child-e ts bl-e), v-nd (ts/->node ts v-e)] + (if (= ::localref (::type v-nd)) + (let [bl-nd (ts/->node ts bl-e)] + (reduce (fn [ts lr-e] (ts/asc ts lr-e ::ref (::ref v-nd))) + ts + (ts/find ts ::type ::localref, ::ref (::ref bl-nd)))) + ts))) + ts (ts/find ts ::type ::bindlocal))) handle-let-refs (fn handle-let-refs [ts e] ; nodes and frees (closed over) (let [nd (ts/->node ts e)] (case (::type nd) (::literal ::var ::lookup ::node) ts (::ap ::comp) (reduce handle-let-refs ts (get-children-e ts e)) - (::site ::join ::pure ::ctor ::call) (recur ts (get-child-e ts e)) - (::let) (recur ts (->let-body-e ts e)) - (::let-ref) - (let [uid (::ref nd) let-e (uid->e ts uid) let-nd (ts/->node ts let-e) + (::site ::join ::pure ::ctor ::call ::mklocal) (recur ts (get-child-e ts e)) + (::bindlocal) (recur ts (->bindlocal-body-e ts e)) + (::localref) + (let [mklocal-uid (::ref nd), mklocal-e (uid->e ts mklocal-uid) + mklocal-nd (ts/->node ts mklocal-e) ctors-e (loop [ac '(), e (::parent (ts/->node ts e))] - (if (= let-e e) + (if (= mklocal-e e) ac - (recur (cond-> ac (= ::ctor (::type (ts/->node ts e))) (conj e)) - (::parent (ts/->node ts e))))) + (let [nd (ts/->node ts e)] + (recur (cond-> ac (= ::ctor (::type nd)) (conj e)) (::parent nd))))) + ctors-uid (mapv #(e->uid ts %) ctors-e) + localv-e (->localv-e ts mklocal-uid) ;; TODO maybe necessary, no proof yet ;; ts (cond-> ts (in-a-call? ts e) ;; (-> (ts/upd (::ref nd) ::in-call #(conj (or % #{}) e)) ;; (ensure-node (::ref nd)))) ts (if (seq ctors-e) ; closed over - (-> ts (ensure-node uid) - (ensure-free-node uid (e->uid ts (first ctors-e))) - (ensure-free-frees uid (mapv #(e->uid ts %) (next ctors-e)))) - (cond-> (ts/upd ts let-e ::used-refs #(conj (or % #{}) (::uid nd))) - (or (= 1 (count (::used-refs let-nd))) ; before inc above, so now it's 2 - (not= (get-site ts (::parent (ts/->node ts e))) - (get-site ts (get-ret-e ts (->let-val-e ts let-e))))) - (ensure-node uid)))] - (or (and (@seen let-e) ts) - (do (vswap! seen conj let-e) - (recur ts (get-ret-e ts (->let-val-e ts let-e)))))) + (-> ts (ensure-node mklocal-uid) + (ensure-free-node mklocal-uid (first ctors-uid)) + (ensure-free-frees mklocal-uid (next ctors-uid))) + (cond-> (ts/upd ts mklocal-e ::used-refs #(conj (or % #{}) (::uid nd))) + (or (= 1 (count (::used-refs mklocal-nd))) ; before inc, now it's 2 + (when-some [pt-e (find-sitable-point-e ts e)] + (not= (get-site ts pt-e) + (get-site ts (get-ret-e ts localv-e))))) + (ensure-node mklocal-uid)))] + (or (and (@seen mklocal-uid) ts) + (do (vswap! seen conj mklocal-uid) + (recur ts (get-ret-e ts localv-e))))) #_else (throw (ex-info (str "cannot handle-let-refs on " (::type nd)) (or nd {})))))) ->call-idx (let [mp (zipmap ctors-e (repeatedly ->->id))] (fn ->call-idx [ctor-e] ((get mp ctor-e)))) @@ -910,19 +946,20 @@ (case (::type nd) (::literal ::var ::lookup ::node) ts (::ap ::comp) (reduce #(mark-used-calls % ctor-e %2) ts (get-children-e ts e)) - (::site ::join ::pure) (recur ts ctor-e (get-child-e ts e)) + (::site ::join ::pure ::mklocal) (recur ts ctor-e (get-child-e ts e)) + (::bindlocal) (recur ts ctor-e (->bindlocal-body-e ts e)) (::ctor) (recur ts e (get-child-e ts e)) (::call) (if (::call-idx nd) ts (-> (mark-used-calls ts ctor-e (get-child-e ts e)) (ts/asc e ::call-idx (->call-idx ctor-e)) (ts/asc e ::ctor-call (::uid (ts/->node ts ctor-e))))) - (::let) (recur ts ctor-e (->let-body-e ts e)) - (::let-ref) (let [nx-e (get-ret-e ts (->let-val-e ts (uid->e ts (::ref nd))))] - (recur ts (find-ctor-e ts nx-e) nx-e)) + (::let) (recur ts ctor-e (->bindlocal-body-e ts e)) + (::localref) (let [nx-e (->> (::ref nd) (->localv-e ts) (get-ret-e ts))] + (recur ts (find-ctor-e ts nx-e) nx-e)) #_else (throw (ex-info (str "cannot mark-used-calls on " (::type nd)) (or nd {}))))))) ts (-> ts (mark-used-calls 0 (get-ret-e ts (get-child-e ts 0))) - (handle-let-refs 0) inline-nodes order-nodes order-frees + reroute-local-aliases (handle-let-refs 0) inline-nodes order-nodes order-frees collapse-ap-with-only-pures)] (when (::print-db env) (run! prn (ts->reducible ts))) ts)) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index f2a85dfe5..3e23733fe 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -16,9 +16,10 @@ (defmacro ctor [expr] `(::lang/ctor ~expr)) (defmacro $ [F & args] - `(binding [~@(interleave (range) args), r/%arity ~(count args)] - (binding [r/%argv [~@(->pos-args (count args))]] - (::lang/call ~F)))) + (let [cnt (count args), gs (repeatedly cnt gensym)] + `(let* [~@(interleave gs args)] + (binding [~@(interleave (range) gs), r/%arity ~cnt, r/%argv [~@gs]] + (::lang/call ~F))))) (defmacro pure " Syntax : @@ -199,6 +200,12 @@ this tuple. Returns the concatenation of all body results as a single vector. ~(rec bindings)) `(do ~@body))) (seq bindings)))) +(defmacro letfn [bs & body] + (let [sb (reverse bs)] + (reduce (cc/fn [ac [nm]] `(::lang/mklocal ~nm ~ac)) + (reduce (cc/fn [ac [nm & fargs]] `(::lang/bindlocal ~nm (hyperfiddle.electric-de/fn ~@fargs) ~ac)) (cons 'do body) sb) + sb))) + (cc/defn- -splicev [args] (into [] cat [(pop args) (peek args)])) (hyperfiddle.electric-de/defn Apply* [F args] (let [s (-splicev args)] diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index ed22cf5d1..02fd7dbd0 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -86,10 +86,8 @@ (r/ap (r/lookup ~'frame :cljs.core/undefined? (r/pure cljs.core/undefined?)))))]) (match (l/test-compile ::Main (e/server (let [x 1] (e/client x)))) - `[(r/cdef 0 [:server] [] :client - (fn [~'frame] - (r/define-node ~'frame 0 (r/pure 1)) - (r/node ~'frame 0)))]) + `[(r/cdef 0 [] [] :server + (fn [~'frame] (r/pure 1)))]) (match (l/test-compile ::Main (name (e/server :foo))) `[(r/cdef 0 [:server] [] nil @@ -140,9 +138,9 @@ (fn [~'frame] (r/ap (r/pure (fn* [] (clojure.core/vector "Hello" "world"))))))]) - (match (l/test-compile ::Main (::lang/site :client (let [a (::lang/site :server :foo)] (::lang/site :server (prn a))))) + (match (l/test-compile ::Main (e/client (let [a (e/server :foo)] (e/server (prn a))))) `[(r/cdef 0 [] [] :server - (clojure.core/fn [~'frame] + (fn [~'frame] (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure clojure.core/prn)) (r/pure :foo))))]) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index f63b3620f..2a0b80b8a 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -981,11 +981,11 @@ % := [:a :b '(:c :d) [:a :b :c :d]])) (tests "Associative destructuring" - (with ((l/single {} (tap (let [{:keys [a ns/b d] - :as m - :or {d 4}} - {:a 1, :ns/b 2 :c 3}] [a b d m]))) tap tap) - % := [1 2 4 {:a 1, :ns/b 2, :c 3}])) + (with ((l/single {} (tap (let [{:keys [a ns/b d] + :as m + :or {d 4}} + {:a 1, :ns/b 2 :c 3}] [a b d m]))) tap tap) + % := [1 2 4 {:a 1, :ns/b 2, :c 3}])) (tests "Associative destructuring with various keys" (with ((l/single {} (tap (let [{:keys [a] @@ -2081,10 +2081,17 @@ (with ((l/single {} (tap ((fn [] (binding [*out* nil] 1))))) tap tap) % := 1)) -#_(tests "e/letfn" - (with ((l/single {} (tap (e/letfn [(Odd? [x] (if (zero? x) false ($ Even? (dec x)))) - (Even? [x] (if (zero? x) true ($ Odd? (dec x))))] - (Even? 2)))) tap tap) +(tests "e/letfn" + (with ((l/single {} + (tap (e/letfn [(Odd? [x] (or (zero? x) ($ Even? (dec x)))) + (Even? [x] (or (zero? x) ($ Odd? (dec x))))] + ($ Even? 2)))) tap tap) + % := true)) + +(tests "e/letfn" + (with ((l/single {} + (tap (e/letfn [(Even? [x] (if (zero? x) true ($ Even? (dec x))))] + ($ Even? 2)))) tap tap) % := true)) (let [{:keys [tested skipped]} @stats, all (+ tested skipped)] From c7afef7328a3af32cf811a8bddbcb6a4c1170d8a Mon Sep 17 00:00:00 2001 From: xificurC Date: Fri, 8 Mar 2024 16:36:55 +0100 Subject: [PATCH 134/428] compiler: e/fn self recur --- src/hyperfiddle/electric/impl/lang_de2.clj | 11 +++++---- src/hyperfiddle/electric/impl/runtime_de.cljc | 1 + src/hyperfiddle/electric_de.cljc | 22 ++++++++++-------- test/hyperfiddle/electric_de_test.cljc | 23 +++++++++---------- 4 files changed, 30 insertions(+), 27 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 28fddcc75..e8f0ec876 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -352,6 +352,7 @@ (defn get-children-e [ts e] (-> ts :ave ::parent (get e))) (defn get-child-e [ts e] (ca/check some? (first (get-children-e ts e)) {:e e})) +(defn get-root-e [ts] (get-child-e ts '_)) (defn ?add-source-map [{{::keys [->id]} :o :as ts} pe form] (let [mt (meta form)] @@ -428,7 +429,7 @@ (defn find-sitable-point-e [ts e] (loop [e e] - (let [nd (ts/->node ts e)] + (when-some [nd (ts/->node ts e)] (case (::type nd) (::literal ::ap ::join ::pure ::comp ::ctor) e (::site) (when (some? (::site nd)) (recur (::parent nd))) @@ -651,7 +652,7 @@ (if (or (nil? pe) (= ::ctor (::type (get (:eav ts) pe)))) pe (recur ts pe)))) (defn- ts->reducible* [ts f init] - (loop [ac init, es (cons 0 (set/difference (-> ts :eav keys set) (->> ts :ave ::parent vals (reduce into)))), seen #{}] + (loop [ac init, es (cons (get-root-e ts) (set/difference (-> ts :eav keys set) (->> ts :ave ::parent vals (reduce into)))), seen #{}] (if (or (reduced? ac) (empty? es)) (unreduced ac) (let [[e & es] es] @@ -836,7 +837,7 @@ (recur (ts/asc ts e ::ctor-idx (->ctor-idx)) (get-child-e ts e))) (::localref) (recur ts (->> (::ref nd) (->localv-e ts) (get-ret-e ts))) #_else (throw (ex-info (str "cannot mark-used-ctors on " (pr-str (::type nd))) (or nd {}))))))) - ts (-> ts (compute-effect-order 0) (mark-used-ctors 0)) + ts (-> ts (compute-effect-order (get-root-e ts)) (mark-used-ctors (get-root-e ts))) ctors-e (get-ordered-ctors-e ts) has-node? (fn has-node? [ts uid] (ts/find ts ::ctor-ref uid)) ensure-node (fn ensure-node [ts uid] @@ -958,8 +959,8 @@ (::localref) (let [nx-e (->> (::ref nd) (->localv-e ts) (get-ret-e ts))] (recur ts (find-ctor-e ts nx-e) nx-e)) #_else (throw (ex-info (str "cannot mark-used-calls on " (::type nd)) (or nd {}))))))) - ts (-> ts (mark-used-calls 0 (get-ret-e ts (get-child-e ts 0))) - reroute-local-aliases (handle-let-refs 0) inline-nodes order-nodes order-frees + ts (-> ts (mark-used-calls (get-root-e ts) (get-ret-e ts (get-child-e ts (get-root-e ts)))) + reroute-local-aliases (handle-let-refs (get-root-e ts)) inline-nodes order-nodes order-frees collapse-ap-with-only-pures)] (when (::print-db env) (run! prn (ts->reducible ts))) ts)) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index cec9ef5bc..c8cdf73c3 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -787,3 +787,4 @@ Returns a peer definition from given definitions and main key. (def %arity nil) (def %argv nil) +(def %fn nil) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 3e23733fe..9de4fcaef 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -18,7 +18,7 @@ (defmacro $ [F & args] (let [cnt (count args), gs (repeatedly cnt gensym)] `(let* [~@(interleave gs args)] - (binding [~@(interleave (range) gs), r/%arity ~cnt, r/%argv [~@gs]] + (binding [~@(interleave (range) gs), r/%arity ~cnt, r/%argv [~@gs], r/%fn ~F] (::lang/call ~F))))) (defmacro pure " @@ -71,6 +71,7 @@ Returns the successive states of items described by `incseq`. (into (sorted-set) (comp (map #(take-while (complement #{'&}) %)) (map count)) arities))) #?(:clj (cc/defn arity-holes [arity-set] (remove arity-set (range (reduce max arity-set))))) +#?(:clj (cc/defn- ?bind-self [code ?name] (cond->> code ?name (list 'let* [?name `r/%fn])))) (defmacro fn [& args] (let [[?name args2] (if (symbol? (first args)) [(first args) (rest args)] [nil args]) @@ -78,14 +79,15 @@ Returns the successive states of items described by `incseq`. arity-set (->narity-set (map first arities)) {positionals false, varargs true} (group-by (comp varargs? first) arities) positional-branches (into [] (map (cc/fn [[args & body]] (-build-fn-arity ?name args body))) positionals)] - (list `check-electric `fn - (list ::lang/ctor - `(case r/%arity - ~@(into [] (comp cat cat) [positional-branches]) - ~@(if (seq varargs) - (conj [(arity-holes arity-set) [:arity-mismatch r/%arity]] - (-build-vararg-arity ?name (ffirst varargs) (nfirst varargs))) - [[:arity-mismatch r/%arity]])))))) + `(check-electric fn + (ctor + ~(-> `(case r/%arity + ~@(into [] (comp cat cat) [positional-branches]) + ~@(if (seq varargs) + (conj [(arity-holes arity-set) [:arity-mismatch r/%arity]] + (-build-vararg-arity ?name (ffirst varargs) (nfirst varargs))) + [[:arity-mismatch r/%arity]])) + (?bind-self ?name)))))) (cc/defn ns-qualify [sym] (if (namespace sym) sym (symbol (str *ns*) (str sym)))) @@ -102,7 +104,7 @@ Returns the successive states of items described by `incseq`. ts (lang/analyze expanded '_ env (lang/->ts)) ts (lang/analyze-electric env ts) ctors (mapv #(lang/emit-ctor ts % env (-> nm ns-qualify keyword)) (lang/get-ordered-ctors-e ts)) - deps (lang/emit-deps ts 0) + deps (lang/emit-deps ts (lang/get-root-e ts)) nm3 (vary-meta nm2 assoc ::lang/deps `'~deps)] (when (::lang/print-source env) (fipp.edn/pprint ctors)) `(def ~nm3 ~ctors))) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 2a0b80b8a..e8c023cfc 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -1917,25 +1917,24 @@ (with ((l/single {} (tap (e/apply (e/fn ([_]) ([_ & xs] (mapv inc xs))) 1 2 [3 4]))) tap tap) % := [3 4 5])) -;; TODO e/fn self-recur -(skip "self-recur by name, e/fn" - (with ((l/single {} (tap (new (e/fn fib [n] (case n 0 0 1 1 (+ (fib. (- n 1)) (fib. (- n 2))))) 6))) tap tap) +(tests "self-recur by name, e/fn" + (with ((l/single {} (tap ($ (e/fn fib [n] (case n 0 0 1 1 (+ ($ fib (- n 1)) ($ fib (- n 2))))) 6))) tap tap) % := 8)) -(skip "self-recur by name, e/defn" - (l/defn Fib [n] (case n 0 0 1 1 (+ (Fib. (- n 1)) (Fib. (- n 2))))) - (with ((l/single {} (tap (Fib. 7))) tap tap) +(tests "self-recur by name, e/defn" + (e/defn Fib [n] (case n 0 0 1 1 (+ ($ Fib (- n 1)) ($ Fib (- n 2))))) + (with ((l/single {} (tap ($ Fib 7))) tap tap) % := 13)) -(skip "self-recur by name, e/fn thunk" +(tests "self-recur by name, e/fn thunk" (def !x (atom 2)) - (with ((l/single {} (new (e/fn X [] (if (pos-int? (tap (swap! !x dec))) (X.) (tap :done))))) tap tap) + (with ((l/single {} ($ (e/fn X [] (if (pos-int? (tap (swap! !x dec))) ($ X) (tap :done))))) tap tap) % := 1 % := 0 % := :done)) -(skip "self-recur by name, to different arity" - (with ((l/single {} (tap (new (e/fn X ([] (X. 0)) ([n] (inc n)))))) tap tap) +(tests "self-recur by name, to different arity" + (with ((l/single {} (tap ($ (e/fn X ([] ($ X 0)) ([n] (inc n)))))) tap tap) % := 1)) -(skip "self-recur by name, varargs" - (with ((l/single {} (new (e/fn Chomp [& xs] (if (tap (seq xs)) (Chomp.) (tap :done))) 0 1 2)) tap tap) +(tests "self-recur by name, varargs" + (with ((l/single {} ($ (e/fn Chomp [& xs] (if (tap (seq xs)) ($ Chomp) (tap :done))) 0 1 2)) tap tap) % := [0 1 2] % := nil % := :done)) From decab3faf20d4755eb994abede2f8a493da271ed Mon Sep 17 00:00:00 2001 From: xificurC Date: Fri, 8 Mar 2024 16:57:01 +0100 Subject: [PATCH 135/428] compiler: pass frees as positional arguments --- src/hyperfiddle/electric/impl/lang_de2.clj | 35 ++-- .../electric/impl/compiler_test.cljc | 191 ++---------------- 2 files changed, 30 insertions(+), 196 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index e8f0ec876..544a7ed9e 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -682,26 +682,21 @@ ::pure (list `r/pure (rec (get-child-e ts e))) ::comp (list 'fn* '[] (doall (map rec (get-children-e ts e)))) ::site (recur (get-child-e ts e)) - ::ctor (let [ctor (list `r/make-ctor 'frame nm (::ctor-idx nd)) - frees-e (ts/find ts ::ctor-free (e->uid ts e))] - (if (seq frees-e) - (list* `doto ctor - (mapv (fn [e] - (let [nd (ts/->node ts e)] - (list `r/define-free (::free-idx nd) - (case (::closed-over nd) - ::node (list `r/node 'frame - (get-node-idx ts - (e->uid ts (find-ctor-e ts (uid->e ts (::ctor-free nd)))) - (::closed-ref nd))) - ::free (list `r/free 'frame - (->> (ts/find ts - ::ctor-free (e->uid ts - (find-ctor-e ts (uid->e ts (::ctor-free nd)))) - ::closed-ref (::closed-ref nd)) - first (ts/->node ts) ::free-idx)))))) - frees-e)) - ctor)) + ::ctor (list* `r/make-ctor 'frame nm (::ctor-idx nd) + (mapv (fn [e] + (let [nd (ts/->node ts e)] + (case (::closed-over nd) + ::node (list `r/node 'frame + (get-node-idx ts + (e->uid ts (find-ctor-e ts (uid->e ts (::ctor-free nd)))) + (::closed-ref nd))) + ::free (list `r/free 'frame + (->> (ts/find ts + ::ctor-free (e->uid ts + (find-ctor-e ts (uid->e ts (::ctor-free nd)))) + ::closed-ref (::closed-ref nd)) + first (ts/->node ts) ::free-idx))))) + (ts/find ts ::ctor-free (e->uid ts e)))) ::call (list `r/join (list `r/call 'frame (::call-idx (ts/->node ts e)))) ::lookup (list `r/lookup 'frame (::sym nd)) ::mklocal (recur (get-ret-e ts (get-child-e ts e))) diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index 02fd7dbd0..81e019cd7 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -176,8 +176,7 @@ `[(r/cdef 0 [nil] [] nil (fn [~'frame] (r/define-node ~'frame 0 (r/pure 1)) - (r/pure (doto (r/make-ctor ~'frame ::Main 1) - (r/define-free 0 (r/node ~'frame 0)))))) + (r/pure (r/make-ctor ~'frame ::Main 1 (r/node ~'frame 0))))) (r/cdef 1 [] [] nil (fn [~'frame] (r/free ~'frame 0)))]) @@ -194,12 +193,10 @@ `[(r/cdef 0 [nil] [] nil (fn [~'frame] (r/define-node ~'frame 0 (r/pure 1)) - (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 1) - (r/define-free 0 (r/node ~'frame 0)))))) + (r/pure (r/make-ctor ~'frame ::Main 1 (r/node ~'frame 0))))) (r/cdef 1 [] [] nil (fn [~'frame] - (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 2) - (r/define-free 0 (r/free ~'frame 0)))))) + (r/pure (r/make-ctor ~'frame ::Main 2 (r/free ~'frame 0))))) (r/cdef 1 [] [] nil (fn [~'frame] (r/free ~'frame 0)))]) @@ -208,15 +205,13 @@ `[(r/cdef 0 [nil] [] nil (fn [~'frame] (r/define-node ~'frame 0 (r/pure 1)) - (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 1) - (r/define-free 0 (r/node ~'frame 0)))))) + (r/pure (r/make-ctor ~'frame ::Main 1 (r/node ~'frame 0))))) (r/cdef 1 [nil] [] nil (fn [~'frame] (r/define-node ~'frame 0 (r/pure 2)) (r/ap (r/pure clojure.core/vector) (r/free ~'frame 0) - (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 2) - (r/define-free 0 (r/node ~'frame 0))))))) + (r/pure (r/make-ctor ~'frame ::Main 2 (r/node ~'frame 0)))))) (r/cdef 1 [] [] nil (fn [~'frame] (r/free ~'frame 0)))]) @@ -225,16 +220,13 @@ `[(r/cdef 0 [nil] [] nil (fn [~'frame] (r/define-node ~'frame 0 (r/pure 1)) - (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 1) - (r/define-free 0 (r/node ~'frame 0)))))) + (r/pure (r/make-ctor ~'frame ::Main 1 (r/node ~'frame 0))))) (r/cdef 1 [] [] nil (fn [~'frame] - (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 2) - (r/define-free 0 (r/free ~'frame 0)))))) + (r/pure (r/make-ctor ~'frame ::Main 2 (r/free ~'frame 0))))) (r/cdef 1 [] [] nil (fn [~'frame] - (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 3) - (r/define-free 0 (r/free ~'frame 0)))))) + (r/pure (r/make-ctor ~'frame ::Main 3 (r/free ~'frame 0))))) (r/cdef 1 [] [] nil (fn [~'frame] (r/free ~'frame 0)))]) @@ -244,15 +236,12 @@ (fn [~'frame] (r/define-node ~'frame 0 (r/pure 1)) (r/define-node ~'frame 1 (r/pure 2)) - (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 1) - (r/define-free 0 (r/node ~'frame 0)) - (r/define-free 1 (r/node ~'frame 1)))))) + (r/pure (r/make-ctor ~'frame ::Main 1 (r/node ~'frame 0) (r/node ~'frame 1))))) (r/cdef 2 [] [] nil (fn [~'frame] (r/ap (r/pure clojure.core/vector) (r/free ~'frame 0) - (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 2) - (r/define-free 0 (r/free ~'frame 1))))))) + (r/pure (r/make-ctor ~'frame ::Main 2 (r/free ~'frame 1)))))) (r/cdef 1 [] [] nil (fn [~'frame] (r/free ~'frame 0)))]) @@ -262,15 +251,12 @@ (fn [~'frame] (r/define-node ~'frame 0 (r/pure 2)) (r/define-node ~'frame 1 (r/pure 1)) - (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 1) - (r/define-free 0 (r/node ~'frame 0)) - (r/define-free 1 (r/node ~'frame 1)))))) + (r/pure (r/make-ctor ~'frame ::Main 1 (r/node ~'frame 0) (r/node ~'frame 1))))) (r/cdef 2 [] [] nil (fn [~'frame] (r/ap (r/pure clojure.core/vector) (r/free ~'frame 0) - (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 2) - (r/define-free 0 (r/free ~'frame 1))))))) + (r/pure (r/make-ctor ~'frame ::Main 2 (r/free ~'frame 1)))))) (r/cdef 1 [] [] nil (fn [~'frame] (r/free ~'frame 0)))]) @@ -289,9 +275,7 @@ (fn [~'frame] (r/define-node ~'frame 0 (r/pure "fizz")) (r/define-node ~'frame 1 (r/pure "buzz")) - (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 1) - (r/define-free 0 (r/node ~'frame 0)) - (r/define-free 1 (r/node ~'frame 1)))))) + (r/pure (r/make-ctor ~'frame ::Main 1 (r/node ~'frame 0) (r/node ~'frame 1))))) (r/cdef 2 [] [] nil (fn [~'frame] (r/ap (r/lookup ~'frame :clojure.core/str (r/pure clojure.core/str)) @@ -358,13 +342,11 @@ `[(r/cdef 0 [nil] [nil] nil (fn [~'frame] (r/define-node ~'frame 0 (r/pure :foo)) - (r/define-call ~'frame 0 (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 1) - (r/define-free 0 (r/node ~'frame 0))))) + (r/define-call ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1 (r/node ~'frame 0)))) (r/join (r/call ~'frame 0)))) (r/cdef 1 [] [] nil (fn [~'frame] - (r/pure (clojure.core/doto (r/make-ctor ~'frame ::Main 2) - (r/define-free 0 (r/free ~'frame 0)))))) + (r/pure (r/make-ctor ~'frame ::Main 2 (r/free ~'frame 0))))) (r/cdef 1 [] [] nil (fn [~'frame] (r/free ~'frame 0)))])) @@ -499,62 +481,6 @@ (r/cdef 0 [] [] nil (fn [~'frame] (r/pure 1))) (r/cdef 0 [] [] nil (fn [~'frame] (r/pure 2)))])) -(comment - (tests "test-e-letfn" - (match (l/test-compile ::Main (assoc (lang/normalize-env {}) ::lang/print-analysis true, ::lang/print-db true, ::lang/print-source true) - (e/letfn [(Foo [] Bar) (Bar [] Foo)] Foo)) - `[])) - - (mklet x ; let, ->let-body-e is just get-child-e - (mklet y ; let - (bindlet x y ; bindlet, ->let-val-e finds bindlet value - (bindlet y x - x)))) - (l/test-compile ::Main (assoc (lang/normalize-env {}) ::lang/print-analysis true, ::lang/print-db true) - (::lang/mk-let x (::lang/mk-let y (::lang/bind-let x (e/ctor y) (::lang/bind-let y (e/ctor x) x))))) - `[(r/cdef 0 [nil nil] [] nil - (fn [frame] - (r/define-node frame 0 (r/pure (doto (r/make-ctor frame ::l/Main 1) - (r/define-free 0 (r/node frame 1))))) - (r/define-node frame 1 (r/pure (doto (r/make-ctor frame ::l/Main 2) - (r/define-free 0 (r/node frame 0))))) - (r/node frame 0))) - (r/cdef 1 [] [] nil - (fn [frame] (r/free frame 0))) - (r/cdef 1 [] [] nil - (fn [frame] (r/free frame 0)))] - (l/test-compile ::Main (let [fizz "fizz", buzz "buzz"] - (e/ctor (str fizz buzz))))) -;; TODO test site is cleared on ctor boundary - -;; TODO rewrite or remove -(comment - (l/compile-client ((fn [] 1))) - ;; ;; rest-args gensym breaks testability - ;; ;; also, testing this deep is counter-productive, we're testing the implementation (internals) - ;; := `(r/peer - ;; (lang/r-defs - ;; (lang/r-ap - ;; (lang/r-ap - ;; (lang/r-static - ;; (clojure.core/fn [] - ;; (clojure.core/fn [& rest-args32938] - ;; (clojure.core/apply (fn* ([] 1)) rest-args32938))))))) - ;; [] 0) - - (l/compile-client (let [x 1] (fn [] x))) - ;; := `(r/peer - ;; (lang/r-defs - ;; (lang/r-static 1) - ;; (lang/r-ap (lang/r-static - ;; (clojure.core/fn [x32133] - ;; (clojure.core/fn [& rest-args32134] - ;; (clojure.core/let [x x32133] - ;; (clojure.core/apply (fn* ([] x)) rest-args32134))))) - ;; (lang/r-local 0))) - ;; [] 1) - ) - (comment ; TODO rewrite for new iteration ;; ( ) ;; source-map => ::line ::column @@ -600,91 +526,4 @@ ;; (let [sm (l/compile-client-with-source-map (set! (.-x (Object.)) 1))]) ) -;; cdef = definition of the static structure of an e/ctor -;; args : -;; * free variable count -;; * a vector of node sites -;; * a vector of call sites -;; * the result site -(comment - - (l/compile ::Main (new (e/fn Foo [] (Foo.)))) - := `[(r/cdef 0 [] [nil] nil - (fn [frame] - (r/define-call frame 0 - (let [ctor (r/make-ctor frame ::Main 1)] - (r/define-free ctor 0 (r/pure ctor)) - (r/pure ctor))) - (r/join (r/call frame 0)))) - (r/cdef 1 [] [nil] nil - (fn [frame] - (r/define-call frame 0 (r/free frame 0)) - (r/join (r/call frame 0))))] - - (l/compile ::Main (e/letfn [(Foo [] (Bar.)) - (Bar [] (Foo.))] - (Foo.))) - := `[(r/cdef 0 [] [nil] nil - (fn [frame] - (let [ctor-foo (r/make-ctor frame ::Main 1) - ctor-bar (r/make-ctor frame ::Main 2)] - (r/define-free ctor-foo 0 (r/pure ctor-foo)) - (r/define-free ctor-foo 1 (r/pure ctor-bar)) - (r/define-free ctor-bar 0 (r/pure ctor-bar)) - (r/define-free ctor-bar 1 (r/pure ctor-foo)) - (r/define-call frame 0 (r/pure ctor-foo)) - (r/join (r/call frame 0))))) - (r/cdef 2 [] [nil] nil - (fn [frame] - (r/define-call frame 0 (r/free frame 1)) - (r/join (r/call frame 0)))) - (r/cdef 2 [] [nil] nil - (fn [frame] - (r/define-call frame 0 (r/free frame 1)) - (r/join (r/call frame 0))))] - - (l/compile ::Main (let [a :foo, b :bar, c :baz] - [(e/ctor [a b]) (e/ctor [b c])])) - := `[(r/cdef 0 [nil nil nil] [] nil - (fn [frame] - (r/define-node frame 0 (r/pure :foo)) - (r/define-node frame 1 (r/pure :bar)) - (r/define-node frame 2 (r/pure :baz)) - (r/ap (r/lookup frame :clojure.core/vector (r/pure clojure.core/vector)) - (let [ctor (r/make-ctor frame ::Main 1)] - (r/define-free ctor 0 (r/node frame 0)) - (r/define-free ctor 1 (r/node frame 1)) - (r/pure ctor)) - (let [ctor (r/make-ctor frame ::Main 2)] - (r/define-free ctor 0 (r/node frame 1)) - (r/define-free ctor 1 (r/node frame 2)) - (r/pure ctor))))) - (r/cdef 2 [] [] nil - (fn [frame] - (r/ap (r/lookup frame :clojure.core/vector (r/pure clojure.core/vector)) - (r/free frame 0) - (r/free frame 1)))) - (r/cdef 2 [] [] nil - (fn [frame] - (r/ap (r/lookup frame :clojure.core/vector (r/pure clojure.core/vector)) - (r/free frame 0) - (r/free frame 1))))] - - #_(e/defn Foo []) - (l/compile ::Main `(e/ctor (e/call Foo))) := - `[(r/cdef 0 [] [] nil - (fn [frame] - (r/pure (r/make-ctor frame ::Main 1)))) - (r/cdef 0 [] [nil] nil - (fn [frame] - (r/define-call frame 0 (r/lookup frame ::Foo (r/pure (r/make-ctor frame ::Foo 0)))) - (r/join (r/call frame 0))))] - - (l/compile ::Main `e/frame) := - `[(r/cdef 0 [] [] nil - (fn [frame] - (r/pure frame)))] - - ) - (prn :ok) From 8d0690d6936abfdf73777a77a68325a5dc4bc030 Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 11 Mar 2024 09:19:55 +0100 Subject: [PATCH 136/428] compiler: fix call siting --- src/hyperfiddle/electric/impl/lang_de2.clj | 4 ++-- test/hyperfiddle/electric/impl/compiler_test.cljc | 10 ++++++++++ 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 544a7ed9e..540c30b54 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -431,9 +431,9 @@ (loop [e e] (when-some [nd (ts/->node ts e)] (case (::type nd) - (::literal ::ap ::join ::pure ::comp ::ctor) e + (::literal ::ap ::join ::pure ::comp ::ctor ::call) e (::site) (when (some? (::site nd)) (recur (::parent nd))) - (::var ::node ::call ::lookup ::mklocal ::bindlocal ::localref) (some-> (::parent nd) recur) + (::var ::node ::lookup ::mklocal ::bindlocal ::localref) (some-> (::parent nd) recur) #_else (throw (ex-info (str "can't find-sitable-point-e for " (pr-str (::type nd))) (or nd {}))))))) (defn get-site [ts e] diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index 81e019cd7..6fbb6d807 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -96,6 +96,16 @@ (r/ap (r/lookup ~'frame :clojure.core/name (r/pure clojure.core/name)) (r/node ~'frame 0))))]) + (match (l/test-compile ::Main (prn (e/client (::lang/call (e/server (::lang/ctor)))))) + `[(r/cdef 0 [:client] [:client] nil + (fn [~'frame] + (r/define-call ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) + (r/define-node ~'frame 0 (r/join (r/call ~'frame 0))) + (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure prn)) + (r/node ~'frame 0)))) + (r/cdef 0 [] [] nil + (fn [~'frame] (r/pure nil)))]) + (let [ex (try (l/test-compile ::Main cannot-be-unsited) (catch ExceptionInfo e e))] (ex-message ex) := "Unsited symbol `cannot-be-unsited` resolves to different vars on different peers. Please resolve ambiguity by siting the expression using it.")) From 7af802a50f14e3f3089cf2ce6af524a41e6a04e3 Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 12 Mar 2024 14:27:52 +0100 Subject: [PATCH 137/428] compiler: tighter e/fn impl --- src/hyperfiddle/electric/impl/lang_de2.clj | 14 ++-- src/hyperfiddle/electric_de.cljc | 74 ++++++++++------------ test/hyperfiddle/electric_de_test.cljc | 17 +++++ 3 files changed, 58 insertions(+), 47 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 540c30b54..dad5e24bc 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -101,6 +101,12 @@ (caller o2 env))) (?meta o (list* (caller (first o) env) (mapv (fn-> caller env) (next o)))))) +(defmacro $ [F & args] + (let [cnt (count args), gs (repeatedly cnt gensym)] + `(let* [~@(interleave gs args), F# ~F] + (binding [~@(interleave (range) gs), r/%arity ~cnt, r/%argv [~@gs], r/%fn F#] + (::call F#))))) + (defn -expand-all [o env] (cond (and (seq? o) (seq o)) @@ -132,14 +138,12 @@ [(conj bs sym (-expand-all v env)) (add-local env sym)]) [[] env] (partition-all 2 bs))] - (recur (?meta o `(binding [::rec (::ctor (let* [~@(interleave (take-nth 2 bs2) (map #(list ::lookup %) (range)))] ~@body))] + (recur (?meta o `(binding [r/%fn (::ctor (let* [~@(interleave (take-nth 2 bs2) (map #(list ::lookup %) (range)))] ~@body))] (binding [~@(interleave (range) (take-nth 2 (next bs2)))] - (::call (::lookup ::rec))))) + (::call r/%fn)))) env2)) - (recur) (recur (?meta o `(binding [~@(interleave (range) (next o))] - (::call (::lookup ::rec)))) - env) + (recur) (recur (?meta o `($ r/%fn ~@(next o))) env) (case clojure.core/case) (let [[_ v & clauses] o diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 9de4fcaef..3a9851632 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -15,11 +15,7 @@ #?(:clj (cc/defn ->pos-args [n] (eduction (take n) (map dget) (range)))) (defmacro ctor [expr] `(::lang/ctor ~expr)) -(defmacro $ [F & args] - (let [cnt (count args), gs (repeatedly cnt gensym)] - `(let* [~@(interleave gs args)] - (binding [~@(interleave (range) gs), r/%arity ~cnt, r/%argv [~@gs], r/%fn ~F] - (::lang/call ~F))))) +(defmacro $ [F & args] `(lang/$ ~F ~@args)) (defmacro pure " Syntax : @@ -43,50 +39,45 @@ Returns the successive states of items described by `incseq`. (throw (ex-info (str "Electric code (" fn ") inside a Clojure function") (into {:electric-fn fn} (meta &form)))))) (defmacro fn* [bs & body] - `(check-electric fn + `(check-electric fn* (ctor (let [~@(interleave bs (->pos-args (count bs)))] ~@body)))) #?(:clj (cc/defn- varargs? [args] (boolean (and (seq args) (= '& (-> args pop peek)))))) -#?(:clj (cc/defn- -build-fn-arity [_?name args body] - [(count args) - `(binding [::lang/rec (ctor (let [~@(interleave args (->pos-args (count args)))] ~@body))] - ($ ~(dget ::lang/rec) ~@(->pos-args (count args))))])) - -#?(:clj (cc/defn- -build-vararg-arity [_?name args body] - (let [npos (-> args count (- 2)), unvarargd (-> args pop pop (conj (peek args))), v (gensym "varargs")] - `(binding [::lang/rec (ctor (let [~@(interleave unvarargd (->pos-args (count unvarargd)))] ~@body))] - ($ ~(dget ::lang/rec) ~@(->pos-args npos) - (let [~v (into [] (drop ~npos) r/%argv)] - (when (seq ~v) ; varargs value is `nil` when no args provided - ~(if (map? (peek args)) - `(if (even? (count ~v)) - (cc/apply hash-map ~v) ; (MapVararg. :x 1) - (merge (cc/apply hash-map (pop ~v)) (peek ~v))) ; (MapVararg. :x 1 {:y 2}) - v)))))))) - -#?(:clj (cc/defn ->narity-set [arities] - (into (sorted-set) (comp (map #(take-while (complement #{'&}) %)) (map count)) arities))) -#?(:clj (cc/defn arity-holes [arity-set] - (remove arity-set (range (reduce max arity-set))))) #?(:clj (cc/defn- ?bind-self [code ?name] (cond->> code ?name (list 'let* [?name `r/%fn])))) +(cc/defn -prep-varargs [n argv map-vararg?] + (let [v (into [] (drop n) argv)] + (when (seq v) ; varargs value is `nil` when no args provided + (if map-vararg? ; [x y & {:keys [z]}] <- vararg map destructuring + (if (even? (count v)) + (cc/apply array-map v) ; ($ MapVararg :x 1) + (merge (cc/apply array-map (pop v)) (peek v))) ; ($ MapVararg :x 1 {:y 2}) + v)))) + (defmacro fn [& args] (let [[?name args2] (if (symbol? (first args)) [(first args) (rest args)] [nil args]) arities (cond-> args2 (vector? (first args2)) list) - arity-set (->narity-set (map first arities)) {positionals false, varargs true} (group-by (comp varargs? first) arities) - positional-branches (into [] (map (cc/fn [[args & body]] (-build-fn-arity ?name args body))) positionals)] + [?vararg npos map-vararg?] (when-some [va (first varargs)] + (let [[args & body] va + npos (-> args count (- 2)) + unvarargd (-> args pop pop (conj (peek args)))] + `[(hyperfiddle.electric-de/fn* ~unvarargd ~@body) ~npos ~(map? (peek args))])) + dpch (gensym "dispatch") + dpchv (into {} (map (cc/fn [[args :as fargs]] [(count args) `(hyperfiddle.electric-de/fn* ~@fargs)])) + positionals)] `(check-electric fn (ctor - ~(-> `(case r/%arity - ~@(into [] (comp cat cat) [positional-branches]) - ~@(if (seq varargs) - (conj [(arity-holes arity-set) [:arity-mismatch r/%arity]] - (-build-vararg-arity ?name (ffirst varargs) (nfirst varargs))) - [[:arity-mismatch r/%arity]])) + ~(-> (if ?vararg + (let [code `(binding [~npos (-prep-varargs ~npos r/%argv ~map-vararg?)] (::lang/call ~?vararg))] + (if (seq positionals) + `(let [~dpch ~dpchv] (if-some [F# (get ~dpch r/%arity)] (::lang/call F#) ~code)) + code)) + `(let [~dpch ~dpchv] + (::lang/call (get ~dpch r/%arity)))) (?bind-self ?name)))))) (cc/defn ns-qualify [sym] (if (namespace sym) sym (symbol (str *ns*) (str sym)))) @@ -115,7 +106,7 @@ Syntax : (amb table1 table2 ,,, tableN) ``` Returns the concatenation of `table1 table2 ,,, tableN`. -" [& exprs] `($ (join (r/pure ~@(mapv #(list `ctor %) exprs))))) +" [& exprs] `(::lang/call (join (r/pure ~@(mapv #(list `ctor %) exprs))))) (defmacro input " Syntax : @@ -167,12 +158,11 @@ For each tuple in the cartesian product of `table1 table2 ,,, tableN`, calls bod (case bindings [] `(do ~@body) (let [[args exprs] (cc/apply map vector (partition-all 2 bindings))] - #_`($ (hyperfiddle.electric-de/fn* ~args (do ~@body)) - ~@(mapv (cc/fn [expr] `(join (r/fixed-signals (join (i/items (pure ~expr)))))) exprs)) - `($ (r/bind-args (hyperfiddle.electric-de/fn* ~args ~@body) - ~@(map (clojure.core/fn [expr] - `(r/effect (r/fixed-signals (join (i/items (pure ~expr)))))) - exprs)))))) + `(::lang/call + (r/bind-args (hyperfiddle.electric-de/fn* ~args ~@body) + ~@(map (clojure.core/fn [expr] + `(r/effect (r/fixed-signals (join (i/items (pure ~expr)))))) + exprs)))))) (defmacro as-vec " Syntax : diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index e8c023cfc..150171824 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -1920,6 +1920,9 @@ (tests "self-recur by name, e/fn" (with ((l/single {} (tap ($ (e/fn fib [n] (case n 0 0 1 1 (+ ($ fib (- n 1)) ($ fib (- n 2))))) 6))) tap tap) % := 8)) +(tests "self-recur by recur, e/fn" + (with ((l/single {} (tap ($ (e/fn fib [n] (case n 0 0 1 1 (+ (recur (- n 1)) (recur (- n 2))))) 6))) tap tap) + % := 8)) (tests "self-recur by name, e/defn" (e/defn Fib [n] (case n 0 0 1 1 (+ ($ Fib (- n 1)) ($ Fib (- n 2))))) (with ((l/single {} (tap ($ Fib 7))) tap tap) @@ -1938,6 +1941,20 @@ % := [0 1 2] % := nil % := :done)) +(tests "self-recur by recur, varargs" + (with ((l/single {} ($ (e/fn [& xs] (if (tap (seq xs)) (recur) (tap :done))) 0 1 2)) tap tap) + % := [0 1 2] + % := nil + % := :done)) + +(tests "self-recur by recur, varargs & multi-arity" + ;; Note this differs from clojure where varargs recur doesn't take variadic args anymore but a collection. + ;; In electric there's no tail recursion so `recur` is used as an anonymous self-call. + ;; This means a multi-arity fn can recur to other arities. + ;; As a side effect we have to keep varargs as varargs on recur. + (with ((l/single {} ($ (e/fn ([] (tap :done)) ([& xs] (if (tap (seq xs)) (recur) (tap :no)))) 0 1 2)) tap tap) + % := '(0 1 2) + % := :done)) ;; TODO e/fn multi-arity #?(:clj From 3c573c1b8c01dcff19bd57463071f3f817bb6bed Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 12 Mar 2024 14:39:18 +0100 Subject: [PATCH 138/428] refactor --- src/hyperfiddle/electric_de.cljc | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 3a9851632..63be8ffe3 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -66,18 +66,16 @@ Returns the successive states of items described by `incseq`. npos (-> args count (- 2)) unvarargd (-> args pop pop (conj (peek args)))] `[(hyperfiddle.electric-de/fn* ~unvarargd ~@body) ~npos ~(map? (peek args))])) - dpch (gensym "dispatch") - dpchv (into {} (map (cc/fn [[args :as fargs]] [(count args) `(hyperfiddle.electric-de/fn* ~@fargs)])) - positionals)] + dispatch-map (into {} (map (cc/fn [[args :as fargs]] [(count args) `(hyperfiddle.electric-de/fn* ~@fargs)])) + positionals)] `(check-electric fn (ctor ~(-> (if ?vararg (let [code `(binding [~npos (-prep-varargs ~npos r/%argv ~map-vararg?)] (::lang/call ~?vararg))] (if (seq positionals) - `(let [~dpch ~dpchv] (if-some [F# (get ~dpch r/%arity)] (::lang/call F#) ~code)) + `(if-some [F# (~dispatch-map r/%arity)] (::lang/call F#) ~code) code)) - `(let [~dpch ~dpchv] - (::lang/call (get ~dpch r/%arity)))) + `(::lang/call (~dispatch-map r/%arity))) (?bind-self ?name)))))) (cc/defn ns-qualify [sym] (if (namespace sym) sym (symbol (str *ns*) (str sym)))) From ef2f170119d51cbc1214dd39b05a568309bcadd3 Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 12 Mar 2024 15:06:13 +0100 Subject: [PATCH 139/428] refactor: remove runtime vars --- src/hyperfiddle/electric/impl/lang_de2.clj | 8 ++++---- src/hyperfiddle/electric/impl/runtime_de.cljc | 4 ---- src/hyperfiddle/electric_de.cljc | 8 ++++---- 3 files changed, 8 insertions(+), 12 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index dad5e24bc..13328aa1a 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -104,7 +104,7 @@ (defmacro $ [F & args] (let [cnt (count args), gs (repeatedly cnt gensym)] `(let* [~@(interleave gs args), F# ~F] - (binding [~@(interleave (range) gs), r/%arity ~cnt, r/%argv [~@gs], r/%fn F#] + (binding [~@(interleave (range) gs), ::r/arity ~cnt, ::r/argv [~@gs], ::r/fn F#] (::call F#))))) (defn -expand-all [o env] @@ -138,12 +138,12 @@ [(conj bs sym (-expand-all v env)) (add-local env sym)]) [[] env] (partition-all 2 bs))] - (recur (?meta o `(binding [r/%fn (::ctor (let* [~@(interleave (take-nth 2 bs2) (map #(list ::lookup %) (range)))] ~@body))] + (recur (?meta o `(binding [::r/fn (::ctor (let* [~@(interleave (take-nth 2 bs2) (map #(list ::lookup %) (range)))] ~@body))] (binding [~@(interleave (range) (take-nth 2 (next bs2)))] - (::call r/%fn)))) + (::call (::lookup ::r/fn))))) env2)) - (recur) (recur (?meta o `($ r/%fn ~@(next o))) env) + (recur) (recur (?meta o `($ (::lookup ::r/fn) ~@(next o))) env) (case clojure.core/case) (let [[_ v & clauses] o diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index c8cdf73c3..d8be3a5e3 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -784,7 +784,3 @@ Returns a peer definition from given definitions and main key. (apply array-map gmap) (if (seq gmap) (first gmap) {})) gmap)) - -(def %arity nil) -(def %argv nil) -(def %fn nil) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 63be8ffe3..56574e6c7 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -46,7 +46,7 @@ Returns the successive states of items described by `incseq`. #?(:clj (cc/defn- varargs? [args] (boolean (and (seq args) (= '& (-> args pop peek)))))) -#?(:clj (cc/defn- ?bind-self [code ?name] (cond->> code ?name (list 'let* [?name `r/%fn])))) +#?(:clj (cc/defn- ?bind-self [code ?name] (cond->> code ?name (list 'let* [?name `(::lang/lookup ::r/fn)])))) (cc/defn -prep-varargs [n argv map-vararg?] (let [v (into [] (drop n) argv)] @@ -71,11 +71,11 @@ Returns the successive states of items described by `incseq`. `(check-electric fn (ctor ~(-> (if ?vararg - (let [code `(binding [~npos (-prep-varargs ~npos r/%argv ~map-vararg?)] (::lang/call ~?vararg))] + (let [code `(binding [~npos (-prep-varargs ~npos (::lang/lookup ::r/argv) ~map-vararg?)] (::lang/call ~?vararg))] (if (seq positionals) - `(if-some [F# (~dispatch-map r/%arity)] (::lang/call F#) ~code) + `(if-some [F# (~dispatch-map (::lang/lookup ::r/arity))] (::lang/call F#) ~code) code)) - `(::lang/call (~dispatch-map r/%arity))) + `(::lang/call (~dispatch-map (::lang/lookup ::r/arity)))) (?bind-self ?name)))))) (cc/defn ns-qualify [sym] (if (namespace sym) sym (symbol (str *ns*) (str sym)))) From 9956fca6aa51052a972a390c58a22648fcb1772e Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 12 Mar 2024 15:21:28 +0100 Subject: [PATCH 140/428] tests cleanup --- test/hyperfiddle/electric_de_test.cljc | 27 ++++++++------------------ 1 file changed, 8 insertions(+), 19 deletions(-) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 150171824..b7ad3b69d 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -810,7 +810,6 @@ (with ((l/single {} x) prn tap) (ex-message %) := "Unbound electric var `hyperfiddle.electric-test/x`")) -;; TODO e/defn docstring #?(:clj (tests ; GG: IDE doc on hover support "Vars created with e/defn have the same metas as created with cc/defn" @@ -1150,10 +1149,9 @@ (catch Pending _))) tap tap) % := [1 2])) -;; TODO cc/fn doesn't convey electric bindings because there are no more e/defs -(skip "Inline cc/fn support" - (def !state (atom 0)) - (def global) +(def !state (atom 0)) +(def global) +(tests "Inline cc/fn support" (with ((l/single {} (let [state (e/watch !state) local [:local state] f (binding [global [:global state]] @@ -1171,9 +1169,9 @@ % := [1 :b [:local 1] [:global 1]] % := [1 :b '(:c :d) [:local 1] [:global 1]])) +(def !state (atom 0)) +(def global) (tests - (def !state (atom 0)) - (def global) (with ((l/single {} (let [state (e/watch !state)] (tap [state state]) @@ -1238,14 +1236,13 @@ % := [false false true true] % := [false false true true])) -;; TODO electric binding conveyance -(skip "Inline letfn support" +(tests "Inline letfn support" (def !state (atom 0)) - (l/def global) + (def global) (with ((l/single {} (let [state (e/watch !state) local [:local state]] (binding [global [:global state]] - (letfn [(f ([a] [a local hyperfiddle.electric-test/global]) + (letfn [(f ([a] [a local hyperfiddle.electric-de-test/global]) ([a b] [a b local global]) ([a b & cs] [a b cs local global]))] (tap (f state)) @@ -1373,8 +1370,6 @@ (set! (.-x o) ($ (e/fn [] 0)))))) tap tap) % := 0))) -;; TODO `set!` expands to cc/fn which tries to convey `a-root` -;; note: transitively the same applies to `(cc/fn [] (set! a-root 2))` #?(:cljs (tests "set! to alter root binding" (def a-root 1) @@ -1809,7 +1804,6 @@ (catch Throwable ex (prn ex)))) tap tap) (count (hash-set % (get-thread))) := 2))) -;; TODO cljs #?(:cljs (do-browser (tests "goog module calls don't trigger warnings" @@ -1832,10 +1826,6 @@ (tests "e/fn varargs" (with ((l/single {} ($ (e/fn [x & xs] (tap [x xs])) 1 2 3 4)) tap tap) % := [1 [2 3 4]])) -;; TODO use recur -(skip "e/fn varargs recursion with recur" - (with ((l/single {} ($ (e/fn [x & xs] (tap [x xs])) 1 2 3 4)) tap tap) - % := [1 [2 3 4]])) ;; TODO try/catch (skip "e/fn varargs recur is arity-checked" (with ((l/single {} (tap (try (new (e/fn [x & xs] (recur)) 1 2 3) @@ -1900,7 +1890,6 @@ (catch ExceptionInfo e e)))) tap tap) (ex-message %) := "You called Two with 3 arguments but it only supports 2")) -;; TODO e/fn multi-arity (tests "multi-arity e/fn" (with ((l/single {} (tap ($ (e/fn ([_] :one) ([_ _] :two)) 1))) tap tap) % := :one)) From a1b4e10021e339e5f1f4672d920cc1f9b2429169 Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 12 Mar 2024 15:58:28 +0100 Subject: [PATCH 141/428] add e/fn multi arity compilation checks --- src/hyperfiddle/electric_de.cljc | 20 ++++++++++++++++++++ test/hyperfiddle/electric_de_test.cljc | 26 ++++++++++++-------------- 2 files changed, 32 insertions(+), 14 deletions(-) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 56574e6c7..55ea4e8f7 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -4,6 +4,7 @@ [hyperfiddle.electric.impl.runtime-de :as r] [hyperfiddle.incseq :as i] [clojure.core :as cc] + [clojure.string :as str] [hyperfiddle.rcf :as rcf :refer [tests]] #?(:clj [contrib.triple-store :as ts]) #?(:clj [fipp.edn]) @@ -57,10 +58,29 @@ Returns the successive states of items described by `incseq`. (merge (cc/apply array-map (pop v)) (peek v))) ; ($ MapVararg :x 1 {:y 2}) v)))) +#?(:clj (cc/defn- throw-arity-conflict! [?name group] + (throw (ex-info (str "Conflicting arity definitions" (when ?name (str " in " ?name)) ": " + (str/join " and " group)) + {:name ?name})))) + +#?(:clj (cc/defn- check-only-one-vararg! [?name varargs] + (when (> (count varargs) 1) + (throw-arity-conflict! ?name varargs)))) + +#?(:clj (cc/defn- check-arity-conflicts! [?name positionals vararg] + (let [grouped (group-by count positionals)] + (doseq [[_ group] grouped] + (when (> (count group) 1) + (throw-arity-conflict! ?name group))) + (when-some [same (get grouped (-> vararg count dec))] + (throw-arity-conflict! ?name (conj same vararg)))))) + (defmacro fn [& args] (let [[?name args2] (if (symbol? (first args)) [(first args) (rest args)] [nil args]) arities (cond-> args2 (vector? (first args2)) list) {positionals false, varargs true} (group-by (comp varargs? first) arities) + _ (check-only-one-vararg! ?name (mapv first varargs)) + _ (check-arity-conflicts! ?name (mapv first positionals) (ffirst varargs)) [?vararg npos map-vararg?] (when-some [va (first varargs)] (let [[args & body] va npos (-> args count (- 2)) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index b7ad3b69d..299d26153 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -1945,21 +1945,19 @@ % := '(0 1 2) % := :done)) -;; TODO e/fn multi-arity #?(:clj - (skip "e/fn multi-arity mistakes" - (binding [expand/*electric* true] - (try (expand/all {} '(e/fn Named ([x] x) ([y] y))) - (catch Throwable e (tap e))) - (ex-message (ex-cause %)) := "Conflicting arity definitions in Named: [x] and [y]" - - (try (expand/all {} '(e/fn Named ([x] x) ([& ys] ys))) - (catch Throwable e (tap e))) - (ex-message (ex-cause %)) := "Conflicting arity definitions in Named: [x] and [& ys]" - - (try (expand/all {} '(e/fn ([x & ys] x) ([x y & zs] ys))) - (catch Throwable e (tap e))) - (ex-message (ex-cause %)) := "Conflicting arity definitions: [x & ys] and [x y & zs]"))) + (tests "e/fn multi-arity mistakes" + (try (lang/expand-all {} '(e/fn Named ([x] x) ([y] y))) + (catch Throwable e (tap e))) + (ex-message %) := "Conflicting arity definitions in Named: [x] and [y]" + + (try (lang/expand-all {} '(e/fn Named ([x] x) ([& ys] ys))) + (catch Throwable e (tap e))) + (ex-message %) := "Conflicting arity definitions in Named: [x] and [& ys]" + + (try (lang/expand-all {} '(e/fn ([x & ys] x) ([x y & zs] ys))) + (catch Throwable e (tap e))) + (ex-message %) := "Conflicting arity definitions: [x & ys] and [x y & zs]")) #?(:cljs (tests "#js" From 0bdd348c8daef40471ca645edbba19a2f78191af Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 14 Mar 2024 14:37:50 +0100 Subject: [PATCH 142/428] scratch: observable flows --- .../peter/y2024/missionary_observability.cljc | 45 +++++++++++++++++++ 1 file changed, 45 insertions(+) create mode 100644 scratch/peter/y2024/missionary_observability.cljc diff --git a/scratch/peter/y2024/missionary_observability.cljc b/scratch/peter/y2024/missionary_observability.cljc new file mode 100644 index 000000000..82adb1e53 --- /dev/null +++ b/scratch/peter/y2024/missionary_observability.cljc @@ -0,0 +1,45 @@ +(ns peter.y2024.missionary-observability + (:require [missionary.core :as m]) + (:import #?(:clj [clojure.lang IFn IDeref]) + [missionary Cancelled])) + +(defprotocol Observable + (info [_]) + (get-parent [_]) + (set-parent! [_ p])) + +(defn wrap [nm flow] + (let [p (object-array [nil])] + (reify + Observable + (info [_] (prn :in nm)) + (get-parent [_] (aget p (int 0))) + (set-parent! [_ pp] (aset p (int 0) pp)) + + IFn + (#?(:clj invoke :cljs -invoke) [this n t] + (let [p (flow n t)] + (reify + IDeref + (#?(:clj deref :cljs -deref) [_] + (try @p + (catch Cancelled e (throw e)) + (catch #?(:clj Throwable :cljs :default) e + (run! info (eduction (take-while some?) (iterate get-parent this))) + (throw e)))) + IFn + (#?(:clj invoke :cljs -invoke) [_] + (p)))))))) + +(defn latesto [f & flows] + (let [lat (wrap (str "lastesto-" f) (apply m/latest f flows))] + (run! #(set-parent! % lat) flows) + lat)) + +(comment + (def !x (atom 1)) + (def it ((m/reduce #(prn %2) nil (latesto inc (latesto dec (wrap "watch" (m/watch !x))))) #(prn :ok %) #(prn :ex %))) + (swap! !x inc) + (reset! !x nil) + (it) + ) From bfc4c1e137d657ec6274c688ea25f00662f758e7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Thu, 14 Mar 2024 17:38:39 +0100 Subject: [PATCH 143/428] lambda transfer with captured nodes --- src/hyperfiddle/electric/impl/runtime_de.cljc | 517 +++++++++++------- .../electric/impl/runtime_test.cljc | 104 +++- 2 files changed, 389 insertions(+), 232 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index d8be3a5e3..a972575af 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -1,8 +1,7 @@ (ns hyperfiddle.electric.impl.runtime-de (:require [hyperfiddle.incseq :as i] [missionary.core :as m] - [cognitect.transit :as t] - [contrib.assert :as ca]) + [cognitect.transit :as t]) (:import missionary.Cancelled #?(:clj (clojure.lang IFn IDeref)) #?(:clj (java.io ByteArrayInputStream ByteArrayOutputStream)))) @@ -26,16 +25,24 @@ (def peer-slot-input-process 3) (def peer-slot-input-busy 4) (def peer-slot-output-pending 5) -(def peer-slot-result 6) -(def peer-slots 7) - -(def port-slot-frame 0) -(def port-slot-id 1) +(def peer-slot-output-acks 6) +(def peer-slot-result 7) +(def peer-slots 8) + +(def peer-queue-tap 0) +(def peer-queue-untap 1) +(def peer-queue-toggle 2) +(def peer-queue-ready 3) +(def peer-queues 4) + +(def port-slot-slot 0) +(def port-slot-site 1) (def port-slot-deps 2) (def port-slot-flow 3) -(def port-slot-refcount 4) -(def port-slot-process 5) -(def port-slots 6) +(def port-slot-requested 4) +(def port-slot-refcount 5) +(def port-slot-process 6) +(def port-slots 7) (declare peer-cancel peer-transfer) @@ -49,9 +56,17 @@ ;; Pure | Ap | Join | Slot (defprotocol Expr - (deps [_]) ;; returns #{Port} + (deps [_ site]) ;; returns {Port multiplicity} (flow [_])) ;; returns incseq +(deftype Failure [info]) + +(defn failure-info [^Failure f] + (.-info f)) + +(defn failure? [x] + (instance? Failure x)) + (defn invariant [x] (m/cp x)) (defn incseq " @@ -72,8 +87,12 @@ (and (instance? Pure other) (= values (.-values ^Pure other)))) Expr - (deps [_] #{}) - (flow [_] (apply i/fixed (map invariant values))) + (deps [_ _] {}) + (flow [_] + (if-some [error (reduce (comp reduced {}) + nil (eduction (filter failure?) values))] + (m/latest #(throw (ex-info "Illegal access." {:info (failure-info error)}))) + (apply i/fixed (map invariant values)))) IFn (#?(:clj invoke :cljs -invoke) [this step done] ((flow this) step done))) @@ -108,8 +127,10 @@ T T T -> (EXPR T) (and (instance? Ap other) (= inputs (.-inputs ^Ap other)))) Expr - (deps [_] (into #{} (mapcat deps) inputs)) - (flow [_] (apply i/latest-product invoke (map flow inputs))) + (deps [_ site] + (reduce (fn [r x] (merge-with + r (deps x site))) {} inputs)) + (flow [_] + (apply i/latest-product invoke (map flow inputs))) IFn (#?(:clj invoke :cljs -invoke) [this step done] ((flow this) step done))) @@ -135,7 +156,7 @@ T T T -> (EXPR T) (and (instance? Join other) (= input (.-input ^Join other)))) Expr - (deps [_] (deps input)) + (deps [_ site] (deps input site)) (flow [_] (i/latest-concat (flow input))) IFn (#?(:clj invoke :cljs -invoke) [this step done] @@ -315,24 +336,6 @@ T T T -> (EXPR T) [^Frame frame] (.-site frame)) -(defn node-site - "Returns the site of given node." - [^Frame frame id] - (if-some [site (nth (.-nodes (frame-cdef frame)) id)] - site (frame-site frame))) - -(defn call-site - "Returns the site of given call." - [^Frame frame id] - (if-some [site (nth (.-calls (frame-cdef frame)) id)] - site (frame-site frame))) - -(defn result-site - "Returns the site of result." - [^Frame frame] - (if-some [site (.-result (frame-cdef frame))] - site (frame-site frame))) - (defn peer-push [^Peer peer offset item] (let [^objects state (.-state peer) ^objects queues (.-queues peer) @@ -358,22 +361,6 @@ T T T -> (EXPR T) (aset state peer-slot-output-pending false) (step)))) -(defn peer-tap [^Peer peer port] - (peer-push peer 0 port) peer) - -(defn port-attach [^objects port ps] - (aset port port-slot-process ps) - (reduce peer-tap (frame-peer (aget port port-slot-frame)) - (aget port port-slot-deps))) - -(defn peer-untap [^Peer peer port] - (peer-push peer 1 port) peer) - -(defn port-detach [^objects port] - (aset port port-slot-process nil) - (reduce peer-untap (frame-peer (aget port port-slot-frame)) - (aget port port-slot-deps))) - (defn frame-child {:tag Frame} [^Frame frame [call-id rank]] @@ -386,10 +373,14 @@ T T T -> (EXPR T) (let [^objects state (.-state peer)] (reduce frame-child (aget state peer-slot-root) path))) -(defn port-process - [^objects port] +(defn port-process [^objects port] (aget port port-slot-process)) +(defn port-site [^objects port] + (aget port port-slot-site)) + +(declare port-slot port-attach port-detach) + (deftype Remote [port step done ^:unsynchronized-mutable ^:mutable diff] IFn (#?(:clj invoke :cljs -invoke) [_] @@ -421,12 +412,30 @@ T T T -> (EXPR T) (and (instance? Slot that) (= (slot-port this) (slot-port that)))) Expr - (deps [this] (port-deps (slot-port this))) - (flow [this] (port-flow (slot-port this))) + (deps [this site] + (let [port (slot-port this)] + (if (= site (port-site port)) + (port-deps port) + {port 1}))) + (flow [this] + (port-flow (slot-port this))) IFn (#?(:clj invoke :cljs -invoke) [this step done] ((flow this) step done))) +(defn port-slot + {:tag Slot} + [^objects port] + (aget port port-slot-slot)) + +(defn port-attach [^objects port ps] + (aset port port-slot-process ps) + (peer-push (frame-peer (.-frame (port-slot port))) peer-queue-tap port)) + +(defn port-detach [^objects port] + (aset port port-slot-process nil) + (peer-push (frame-peer (.-frame (port-slot port))) peer-queue-untap port)) + (defn frame-port {:tag 'objects} [^Frame frame id] @@ -439,58 +448,49 @@ T T T -> (EXPR T) (frame-port (.-frame slot) (.-id slot))) (defn port-ready [^objects port] - (peer-push (frame-peer (aget port port-slot-frame)) 2 port)) + (peer-push (frame-peer (.-frame (port-slot port))) peer-queue-ready port)) -(defn port-tap [^objects port] - (let [prev (aget port port-slot-refcount)] - (aset port port-slot-refcount (inc prev)) - (when (zero? prev) - (aset port port-slot-process - ((port-flow port) - #(port-ready port) - #(do (aset port port-slot-process nil) - (port-ready port))))))) - -(defn port-untap [^objects port] - (let [curr (dec (aget port port-slot-refcount))] - (aset port port-slot-refcount curr) - (when (zero? curr) ((port-process port))))) - -(defn make-local [frame id incseq] - (let [port (object-array port-slots)] - (aset port port-slot-frame frame) - (aset port port-slot-id id) - (aset port port-slot-deps #{port}) - (aset port port-slot-flow incseq) - (aset port port-slot-refcount (identity 0)) - port)) - -(defn make-remote [frame id deps] - (let [port (object-array port-slots)] - (aset port port-slot-frame frame) - (aset port port-slot-id id) - (aset port port-slot-deps deps) - (aset port port-slot-flow - (m/signal i/combine - (fn [step done] - (let [ps (->Remote port step done (i/empty-diff 0))] - (port-attach port ps) (step) ps)))) port)) +(defn define-slot [^Frame frame id expr] + (let [^objects ports (.-ports frame)] + (when-not (nil? (aget ports id)) + (throw (error "Can't redefine slot."))) + (aset ports id + (if (instance? Slot expr) + (slot-port expr) + (let [cdef (ctor-cdef (frame-ctor frame)) + nodes (.-nodes cdef) + nodec (count nodes) + site (if-some [site (if (< id nodec) + (nodes id) + (let [id (+ id nodec) + calls (.-calls cdef) + callc (count calls)] + (if (< id callc) + (calls id) + (.-result cdef))))] + site (frame-site frame)) + port (object-array port-slots)] + (aset port port-slot-slot (->Slot frame id)) + (aset port port-slot-site site) + (aset port port-slot-deps (deps expr site)) + (aset port port-slot-flow + (m/signal i/combine + (if (= site (.-site (frame-peer frame))) + (flow expr) + (fn [step done] + (let [ps (->Remote port step done (i/empty-diff 0))] + (port-attach port ps) (step) ps))))) + (aset port port-slot-refcount (identity 0)) + (aset port port-slot-requested (identity 0)) + port))) nil)) (defn make-frame [^Frame parent call-id rank ctor] - (let [peer (ctor-peer ctor) - cdef (ctor-cdef ctor) + (let [cdef (ctor-cdef ctor) callc (count (.-calls cdef)) - result (+ (count (.-nodes cdef)) callc) - ports (object-array (inc result)) + id (+ (count (.-nodes cdef)) callc) frame (->Frame parent call-id rank (if (nil? parent) :client (frame-site parent)) ctor - (int-array (inc callc)) (object-array callc) ports nil) - expr ((.-build cdef) frame)] - (aset ports result - (if (instance? Slot expr) - (slot-port expr) - (if (= (.-site peer) (result-site frame)) - (make-local frame nil (flow expr)) - (make-remote frame nil (deps expr))))) frame)) + (int-array (inc callc)) (object-array callc) (object-array (inc id)) nil)] + (define-slot frame id ((.-build cdef) frame)) frame)) (defn peer-cancel [^Peer peer] (prn :TODO-cancel)) @@ -518,52 +518,119 @@ T T T -> (EXPR T) (.-rank ^Frame frame)])) path))) -(defn port-inst [^objects port] - [(frame-path (aget port port-slot-frame)) - (aget port port-slot-id) - (when-some [ps (port-process port)] @ps)]) +(defn enable [^objects port] + (aset port port-slot-process + ((port-flow port) + #(port-ready port) + #(do (aset port port-slot-process nil) + (port-ready port))))) + +(defn disable [^objects port] + (when-some [ps (port-process port)] + (aset port port-slot-process nil) + (ps))) + +(defn local-port-tap [_ ^objects port n] + (let [prev (aget port port-slot-refcount)] + (aset port port-slot-refcount (+ prev n)) + (when (zero? prev) + (when (zero? (aget port port-slot-requested)) + (enable port))))) + +(defn local-port-untap [_ ^objects port n] + (let [curr (- (aget port port-slot-refcount) n)] + (aset port port-slot-refcount curr) + (when (zero? curr) + (when (zero? (aget port port-slot-requested)) + (disable port))))) + +(defn remote-port-tap [_ ^objects port n] + (aset port port-slot-refcount + (+ (aget port port-slot-refcount) n))) + +(defn remote-port-untap [_ ^objects port n] + (aset port port-slot-refcount + (- (aget port port-slot-refcount) n))) (defn peer-transfer [^Peer peer] (let [^objects state (.-state peer) ^objects queues (.-queues peer) ^ints pushes (.-pushes peer)] - (loop [insts [] + (loop [toggle #{} + change {} + freeze #{} tap-pull 0 untap-pull 0 - ready-pull 0] - (let [^objects tap-queue (aget queues 0) - ^objects untap-queue (aget queues 1) - ^objects ready-queue (aget queues 2)] - (if-some [port (aget tap-queue tap-pull)] - (do (aset tap-queue tap-pull nil) - (port-tap port) - (recur insts - (rem (unchecked-inc-int tap-pull) - (alength tap-queue)) untap-pull ready-pull)) - (if-some [port (aget untap-queue untap-pull)] - (do (aset untap-queue untap-pull nil) - (port-untap port) - (recur insts tap-pull - (rem (unchecked-inc-int untap-pull) - (alength untap-queue)) ready-pull)) - (if-some [port (aget ready-queue ready-pull)] - (do (aset ready-queue ready-pull nil) - (recur (conj insts (port-inst port)) - tap-pull untap-pull - (rem (unchecked-inc-int ready-pull) - (alength ready-queue)))) - (do (aset state peer-slot-output-pending true) - (aset pushes 0 0) - (aset pushes 1 0) - (aset pushes 2 0) - (encode insts (aget state peer-slot-writer-opts)))))))))) + toggle-pull 0 + change-pull 0] + (let [^objects tap-queue (aget queues peer-queue-tap) + ^objects untap-queue (aget queues peer-queue-untap) + ^objects toggle-queue (aget queues peer-queue-toggle) + ^objects ready-queue (aget queues peer-queue-ready)] + (if-some [^objects remote-port (aget tap-queue tap-pull)] + (let [prev (aget remote-port port-slot-requested)] + (aset tap-queue tap-pull nil) + (aset remote-port port-slot-requested (inc prev)) + (reduce-kv local-port-tap nil (port-deps remote-port)) + (recur (if (zero? (+ prev (aget remote-port port-slot-refcount))) + (conj toggle (port-slot remote-port)) toggle) change freeze + (rem (unchecked-inc-int tap-pull) + (alength tap-queue)) untap-pull toggle-pull change-pull)) + (if-some [^objects remote-port (aget untap-queue untap-pull)] + (let [curr (dec (aget remote-port port-slot-requested))] + (aset untap-queue untap-pull nil) + (aset remote-port port-slot-requested curr) + (run! local-port-untap (port-deps remote-port)) + (recur (if (zero? (+ curr (aget remote-port port-slot-requested))) + (conj toggle (port-slot remote-port)) toggle) change freeze + tap-pull (rem (unchecked-inc-int untap-pull) + (alength untap-queue)) toggle-pull change-pull)) + (if-some [^objects local-port (aget toggle-queue toggle-pull)] + (let [deps (port-deps local-port)] + (aset toggle-queue toggle-pull nil) + (if (zero? (aget local-port port-slot-requested)) + (do (aset local-port port-slot-requested (identity 1)) + (run! remote-port-tap deps) + (when (zero? (aget local-port port-slot-refcount)) + (enable local-port))) + (do (aset local-port port-slot-requested (identity 0)) + (run! remote-port-untap deps) + (when (zero? (aget local-port port-slot-refcount)) + (disable local-port)))) + (recur toggle change freeze tap-pull untap-pull + (rem (unchecked-inc-int toggle-pull) + (alength toggle-queue)) change-pull)) + (if-some [^objects local-port (aget ready-queue change-pull)] + (let [slot (port-slot local-port)] + (aset ready-queue change-pull nil) + (if-some [ps (port-process local-port)] + (let [diff @ps] + (recur toggle (assoc change + slot (if-some [p (change slot)] + (i/combine p diff) diff)) + freeze tap-pull untap-pull toggle-pull + (rem (unchecked-inc-int change-pull) + (alength ready-queue)))) + (recur toggle change (conj freeze slot) + tap-pull untap-pull toggle-pull + (rem (unchecked-inc-int change-pull) + (alength ready-queue))))) + (let [acks (aget state peer-slot-output-acks)] + (aset state peer-slot-output-acks (identity 0)) + (aset state peer-slot-output-pending true) + (aset pushes peer-queue-tap 0) + (aset pushes peer-queue-untap 0) + (aset pushes peer-queue-toggle 0) + (aset pushes peer-queue-ready 0) + (encode [acks toggle change freeze] + (aget state peer-slot-writer-opts))))))))))) (defn frame-shared? [^Frame frame] - (let [rank (.-rank frame) - call-id (.-call-id frame) - ^Frame parent (.-parent frame) - ^objects children (.-children parent)] - (contains? (aget children call-id) rank))) + (if-some [^Frame parent (.-parent frame)] + (let [rank (.-rank frame) + call-id (.-call-id frame) + ^objects children (.-children parent)] + (contains? (aget children call-id) rank)) true)) (defn frame-share [^Frame frame] (let [rank (.-rank frame) @@ -583,23 +650,44 @@ T T T -> (EXPR T) (dissoc (aget children call-id) rank frame)))) -(defn peer-inst [^Peer peer [path id diff]] - ((port-process (frame-port (peer-frame peer path) id)) diff) - peer) +(defn peer-ack [^Peer peer] + ;; TODO + ) + +(defn peer-toggle [^Peer peer ^Slot slot] + (peer-push peer peer-queue-toggle (slot-port slot)) peer) + +(defn peer-change [^Peer peer ^Slot slot diff] + ((port-process (slot-port slot)) diff) peer) + +(defn peer-freeze [^Peer peer ^Slot slot] + ((port-process (slot-port slot)) nil) peer) (defn peer-input-ready [^Peer peer] - (let [^objects state (.-state peer)] + (let [^objects state (.-state peer) + step (.-step peer)] (loop [] (when (aset state peer-slot-input-busy (not (aget state peer-slot-input-busy))) - (try (reduce peer-inst peer - (decode @(aget state peer-slot-input-process) - (aget state peer-slot-reader-opts))) - (catch #?(:clj Throwable :cljs :default) e - (pst e) - ;; TODO - )) - (recur))))) + (let [[acks toggle change freeze] + (decode + (try @(aget state peer-slot-input-process) + (catch #?(:clj Throwable :cljs :default) e + (pst e) + ;; TODO + )) + (aget state peer-slot-reader-opts))] + (dotimes [_ acks] (peer-ack peer)) + (reduce peer-toggle peer toggle) + (reduce-kv peer-change peer change) + (reduce peer-freeze peer freeze) + (when (pos? (+ (count toggle) (count change) (count freeze))) + (aset state peer-slot-output-acks + (inc (aget state peer-slot-output-acks))) + (when (aget state peer-slot-output-pending) + (aset state peer-slot-output-pending false) + (step))) + (recur)))))) (defn peer-result-diff [^Peer peer diff] (prn :TODO-result-diff diff) @@ -611,39 +699,26 @@ T T T -> (EXPR T) (defn define-node "Defines signals node id for given frame." [^Frame frame id expr] - (let [^objects ports (.-ports frame)] - (when-not (nil? (aget ports id)) - (throw (error "Can't redefine signal node."))) - (aset ports id - (if (instance? Slot expr) - (slot-port expr) - (if (= (node-site frame id) (.-site (frame-peer frame))) - (make-local frame id (m/signal i/combine (flow expr))) - (make-remote frame id (deps expr))))) nil)) + (define-slot frame id expr)) (defn define-call "Defines call site id for given frame." [^Frame frame id expr] - (let [^objects ports (.-ports frame) - slot (+ id (count (.-nodes (frame-cdef frame))))] - (when-not (nil? (aget ports slot)) - (throw (error "Can't redefine call site."))) - (aset ports slot - (if (= (call-site frame id) (.-site (frame-peer frame))) - (make-local frame id - (m/signal i/combine - (i/latest-product - (fn [ctor] - (when-not (instance? Ctor ctor) - (throw (error (str "Not a constructor - " (pr-str ctor))))) - (when-not (identical? (frame-peer frame) (ctor-peer ctor)) - (throw (error "Can't call foreign constructor."))) - (let [^ints ranks (.-ranks frame) - rank (aget ranks id)] - (aset ranks id (inc rank)) - (make-frame frame id rank ctor))) - (flow expr)))) - (make-remote frame id (deps expr)))) nil)) + (define-slot frame (+ id (count (.-nodes (frame-cdef frame)))) + (reify Expr + (deps [_ site] (deps expr site)) + (flow [_] + (i/latest-product + (fn [ctor] + (when-not (instance? Ctor ctor) + (throw (error (str "Not a constructor - " (pr-str ctor))))) + (when-not (identical? (frame-peer frame) (ctor-peer ctor)) + (throw (error "Can't call foreign constructor."))) + (let [^ints ranks (.-ranks frame) + rank (aget ranks id)] + (aset ranks id (inc rank)) + (make-frame frame id rank ctor))) + (flow expr)))))) (defn define-free "Defines free variable id for given constructor." @@ -669,7 +744,7 @@ T T T -> (EXPR T) {:tag Ctor} [^Frame frame key idx & frees] (let [^Peer peer (frame-peer frame) - ^Cdef cdef ((ca/check some? ((.-defs peer) key) {:key key}) idx) + ^Cdef cdef (((.-defs peer) key) idx) ctor (->Ctor peer key idx (object-array (.-frees cdef)) {} nil)] (run! (partial apply define-free ctor) (eduction (map-indexed vector) frees)) @@ -708,17 +783,21 @@ Returns a peer definition from given definitions and main key. (fn [step done] (let [state (object-array peer-slots) peer (->Peer site defs step done - (doto (object-array 3) - (aset 0 (object-array 1)) - (aset 1 (object-array 1)) - (aset 2 (object-array 1))) - (int-array 3) state) + (doto (object-array peer-queues) + (aset peer-queue-tap (object-array 1)) + (aset peer-queue-untap (object-array 1)) + (aset peer-queue-toggle (object-array 1)) + (aset peer-queue-ready (object-array 1))) + (int-array peer-queues) state) input (m/stream (m/observe events)) root (->> args (apply bind-args (->Ctor peer main 0 (object-array 0) {} nil)) (make-frame nil 0 0))] (aset state peer-slot-writer-opts - {:handlers {Ctor (t/write-handler + {:default-handler (t/write-handler + (fn [_] "unserializable") + (fn [_] (comment TODO fetch port info))) + :handlers {Ctor (t/write-handler (fn [_] "ctor") (fn [^Ctor ctor] (assert (identical? peer (.-peer ctor))) @@ -733,33 +812,57 @@ Returns a peer definition from given definitions and main key. [(frame-path frame) (when-not (frame-shared? frame) (frame-share frame) - (.-ctor frame))]))}}) + (.-ctor frame))])) + Join (t/write-handler + (fn [_] "join") + (fn [^Join join] + (.-input join))) + Ap (t/write-handler + (fn [_] "ap") + (fn [^Ap ap] + (.-inputs ap))) + Pure (t/write-handler + (fn [_] "pure") + (fn [^Pure pure] + (.-values pure)))}}) (aset state peer-slot-reader-opts - {:handlers {"ctor" (t/read-handler - (fn [[key idx env & free]] - (->Ctor peer key idx (object-array free) env nil))) - "slot" (t/read-handler - (fn [[frame id]] - (->Slot frame id))) - "frame" (t/read-handler - (fn [[path ctor]] - (if (nil? ctor) - (peer-frame peer path) - (let [[call rank] (peek path) - parent (peer-frame peer (pop path)) - frame (make-frame parent call rank ctor)] - (frame-share frame) frame))))}}) + {:handlers {"ctor" (t/read-handler + (fn [[key idx env & free]] + (->Ctor peer key idx (object-array free) env nil))) + "slot" (t/read-handler + (fn [[frame id]] + (->Slot frame id))) + "frame" (t/read-handler + (fn [[path ctor]] + (if (nil? ctor) + (peer-frame peer path) + (let [[call rank] (peek path) + parent (peer-frame peer (pop path)) + frame (make-frame parent call rank ctor)] + (frame-share frame) frame)))) + "join" (t/read-handler + (fn [input] + (->Join input nil))) + "ap" (t/read-handler + (fn [inputs] + (->Ap inputs nil))) + "pure" (t/read-handler + (fn [values] + (->Pure values nil))) + "unserializable" (t/read-handler + (fn [_] + (->Failure :unserializable)))}}) + (aset state peer-slot-output-acks (identity 0)) (aset state peer-slot-output-pending true) (aset state peer-slot-input-busy true) (aset state peer-slot-input-process (input #(peer-input-ready peer) done)) (aset state peer-slot-root root) - (case site - :client (aset state peer-slot-result - ((m/reduce peer-result-diff peer - (m/signal i/combine (port-flow (result root)))) - peer-result-success pst)) - :server (reduce peer-tap peer (aget (result root) port-slot-deps))) + (when (= site :client) + (aset state peer-slot-result + ((m/reduce peer-result-diff peer + (m/signal i/combine (port-flow (result root)))) + peer-result-success pst))) (peer-input-ready peer) peer))) ;; local only diff --git a/test/hyperfiddle/electric/impl/runtime_test.cljc b/test/hyperfiddle/electric/impl/runtime_test.cljc index 779df68ff..51790115a 100644 --- a/test/hyperfiddle/electric/impl/runtime_test.cljc +++ b/test/hyperfiddle/electric/impl/runtime_test.cljc @@ -10,11 +10,13 @@ cb (fn [e] #?(:clj (.printStackTrace ^Throwable e) :cljs (.error js/console e))))) +(defmacro cdefs [form] + (l/compile ::Main form + (assoc (l/normalize-env &env) + ::l/peers {:client :clj, :server :clj}))) + (defmacro root-frame [form] - `(r/root-frame {::Main ~(l/compile ::Main form - (assoc (l/normalize-env &env) - ::l/peers {:client :clj, :server :clj}))} - ::Main)) + `(r/root-frame {::Main (cdefs ~form)} ::Main)) (defmacro peers [form] (let [main (l/compile ::Main form @@ -148,52 +150,104 @@ % := nil) (tests - (def cdefs - [(r/cdef 0 [:server] [] nil - (fn [frame] - (r/define-node frame 0 (r/pure :foo)) - (r/ap (r/pure rcf/tap) (r/node frame 0))))]) + (def cp + {::Main [(r/cdef 0 [:server] [] nil + (fn [frame] + (r/define-node frame 0 (r/pure :foo)) + (r/ap (r/pure rcf/tap) (r/node frame 0))))]}) (def c-ps ((r/peer (fn [!] (def s->c !) #(prn :dispose)) - :client {::Main cdefs} ::Main) - #(prn :step-c) #(prn :done-c))) + :client cp ::Main) + #(rcf/tap :step-c) #(prn :done-c))) + % := :step-c (def s-ps ((r/peer (fn [!] (def c->s !) #(prn :dispose)) - :server {::Main cdefs} ::Main) + :server cp ::Main) #(rcf/tap :step-s) #(prn :done-s))) + (c->s @c-ps) % := :step-s (s->c @s-ps) - % := :foo) + % := :foo + % := :step-c + (c->s @c-ps) + % := :step-s + (s->c @s-ps)) (tests - (def cdefs - [(r/cdef 0 [:server] [:client] nil - (fn [frame] - (r/define-node frame 0 (r/pure (r/make-ctor frame ::Main 1))) - (r/define-call frame 0 (r/node frame 0)) - (r/ap (r/pure rcf/tap) (r/join (r/call frame 0))))) - (r/cdef 0 [] [] nil - (fn [frame] (r/pure :foo)))]) + #_(rcf/tap (e/client (e/$ (e/server (e/fn []))))) + (def cp + {::Main [(r/cdef 0 [:server] [:client] nil + (fn [frame] + (r/define-node frame 0 (r/pure (r/make-ctor frame ::Main 1))) + (r/define-call frame 0 (r/node frame 0)) + (r/ap (r/pure rcf/tap) (r/join (r/call frame 0))))) + (r/cdef 0 [] [] nil + (fn [frame] (r/pure :foo)))]}) (def c-ps ((r/peer (fn [!] (def s->c !) #(prn :dispose)) - :client {::Main cdefs} ::Main) - #(prn :step-c) #(prn :done-c))) + :client cp ::Main) + #(rcf/tap :step-c) #(prn :done-c))) + % := :step-c (def s-ps ((r/peer (fn [!] (def c->s !) #(prn :dispose)) - :server {::Main cdefs} ::Main) + :server cp ::Main) #(rcf/tap :step-s) #(prn :done-s))) + (c->s @c-ps) % := :step-s (s->c @s-ps) - % := :foo) \ No newline at end of file + % := :foo + % := :step-c + (c->s @c-ps) + % := :step-s + (s->c @s-ps)) + +(tests + #_(rcf/tap (e/client (e/$ (e/server (let [foo :foo] (e/fn [] foo)))))) + (def cp + {::Main [(r/cdef 0 [:server :server] [:client] nil + (fn [frame] + (r/define-node frame 0 (r/pure :foo)) + (r/define-node frame 1 (r/pure (r/make-ctor frame ::Main 1 (r/node frame 0)))) + (r/define-call frame 0 (r/node frame 1)) + (r/ap (r/pure rcf/tap) (r/join (r/call frame 0))))) + (r/cdef 1 [] [] nil + (fn [frame] (r/free frame 0)))]}) + (def c-ps + ((r/peer + (fn [!] + (def s->c !) + #(prn :dispose)) + :client cp ::Main) + #(rcf/tap :step-c) #(prn :done-c))) + % := :step-c + (def s-ps + ((r/peer + (fn [!] + (def c->s !) + #(prn :dispose)) + :server cp ::Main) + #(rcf/tap :step-s) #(prn :done-s))) + (c->s @c-ps) + % := :step-s + (s->c @s-ps) + % := :step-c + (c->s @c-ps) + % := :step-s + (s->c @s-ps) + % := :foo + % := :step-c + (c->s @c-ps) + % := :step-s + (s->c @s-ps)) \ No newline at end of file From 1230b186df15e39a2cfc04bbbe940bce64ff7cc3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Fri, 15 Mar 2024 09:29:54 +0100 Subject: [PATCH 144/428] use compiler in runtime tests --- .../electric/impl/runtime_test.cljc | 68 ++++++------------- 1 file changed, 21 insertions(+), 47 deletions(-) diff --git a/test/hyperfiddle/electric/impl/runtime_test.cljc b/test/hyperfiddle/electric/impl/runtime_test.cljc index 51790115a..7bcfafa99 100644 --- a/test/hyperfiddle/electric/impl/runtime_test.cljc +++ b/test/hyperfiddle/electric/impl/runtime_test.cljc @@ -19,11 +19,12 @@ `(r/root-frame {::Main (cdefs ~form)} ::Main)) (defmacro peers [form] - (let [main (l/compile ::Main form - (assoc (l/normalize-env &env) - ::l/peers {:client :clj, :server :clj}))] - `{:client #(r/peer % :client {::Main ~main} ::Main) - :server #(r/peer % :server {::Main ~main} ::Main)})) + `(fn [site# input#] + (r/peer input# site# + {::Main ~(l/compile ::Main form + (assoc (l/normalize-env &env) + ::l/peers {:client :clj, :server :clj}))} + ::Main))) (tests (on-diff! rcf/tap (root-frame "hello electric")) @@ -150,25 +151,19 @@ % := nil) (tests - (def cp - {::Main [(r/cdef 0 [:server] [] nil - (fn [frame] - (r/define-node frame 0 (r/pure :foo)) - (r/ap (r/pure rcf/tap) (r/node frame 0))))]}) + (def peer (peers (rcf/tap (e/server :foo)))) (def c-ps - ((r/peer + ((peer :client (fn [!] (def s->c !) - #(prn :dispose)) - :client cp ::Main) + #(prn :dispose))) #(rcf/tap :step-c) #(prn :done-c))) % := :step-c (def s-ps - ((r/peer + ((peer :server (fn [!] (def c->s !) - #(prn :dispose)) - :server cp ::Main) + #(prn :dispose))) #(rcf/tap :step-s) #(prn :done-s))) (c->s @c-ps) % := :step-s @@ -180,29 +175,19 @@ (s->c @s-ps)) (tests - #_(rcf/tap (e/client (e/$ (e/server (e/fn []))))) - (def cp - {::Main [(r/cdef 0 [:server] [:client] nil - (fn [frame] - (r/define-node frame 0 (r/pure (r/make-ctor frame ::Main 1))) - (r/define-call frame 0 (r/node frame 0)) - (r/ap (r/pure rcf/tap) (r/join (r/call frame 0))))) - (r/cdef 0 [] [] nil - (fn [frame] (r/pure :foo)))]}) + (def peer (peers (rcf/tap (e/client (e/$ (e/server (e/fn [] :foo))))))) (def c-ps - ((r/peer + ((peer :client (fn [!] (def s->c !) - #(prn :dispose)) - :client cp ::Main) + #(prn :dispose))) #(rcf/tap :step-c) #(prn :done-c))) % := :step-c (def s-ps - ((r/peer + ((peer :server (fn [!] (def c->s !) - #(prn :dispose)) - :server cp ::Main) + #(prn :dispose))) #(rcf/tap :step-s) #(prn :done-s))) (c->s @c-ps) % := :step-s @@ -214,30 +199,19 @@ (s->c @s-ps)) (tests - #_(rcf/tap (e/client (e/$ (e/server (let [foo :foo] (e/fn [] foo)))))) - (def cp - {::Main [(r/cdef 0 [:server :server] [:client] nil - (fn [frame] - (r/define-node frame 0 (r/pure :foo)) - (r/define-node frame 1 (r/pure (r/make-ctor frame ::Main 1 (r/node frame 0)))) - (r/define-call frame 0 (r/node frame 1)) - (r/ap (r/pure rcf/tap) (r/join (r/call frame 0))))) - (r/cdef 1 [] [] nil - (fn [frame] (r/free frame 0)))]}) + (def peer (peers (rcf/tap (e/client (e/$ (e/server (let [foo :foo] (e/fn [] foo)))))))) (def c-ps - ((r/peer + ((peer :client (fn [!] (def s->c !) - #(prn :dispose)) - :client cp ::Main) + #(prn :dispose))) #(rcf/tap :step-c) #(prn :done-c))) % := :step-c (def s-ps - ((r/peer + ((peer :server (fn [!] (def c->s !) - #(prn :dispose)) - :server cp ::Main) + #(prn :dispose))) #(rcf/tap :step-s) #(prn :done-s))) (c->s @c-ps) % := :step-s From e60de2f62b644ba1f5bb94734a502a5b5f332a00 Mon Sep 17 00:00:00 2001 From: xificurC Date: Fri, 15 Mar 2024 11:18:34 +0100 Subject: [PATCH 145/428] source map test shim, misc --- src/contrib/assert.cljc | 12 ++++++++++++ src/contrib/triple_store.clj | 7 ++++++- src/hyperfiddle/electric/impl/lang_de2.clj | 6 +++--- src/hyperfiddle/electric_de.cljc | 7 +++++++ src/hyperfiddle/electric_local_def_de.cljc | 12 ++++++++++++ test/hyperfiddle/electric/impl/compiler_test.cljc | 12 +++++++++--- 6 files changed, 49 insertions(+), 7 deletions(-) diff --git a/src/contrib/assert.cljc b/src/contrib/assert.cljc index a1bb579fd..aca8dbb1e 100644 --- a/src/contrib/assert.cljc +++ b/src/contrib/assert.cljc @@ -20,6 +20,18 @@ ([pred v] `(check ~pred ~v {})) ([pred v ex-data] `(-check '~pred ~pred '~v ~v ~ex-data))) +(defn -is [v pred vq predq msg ex-data] + (when-not (pred v) + (throw (ex-info (str "assertion failed: (" (pr-str predq) " " (pr-str vq) ") for " (pr-str vq) " = " (pr-str v) + (when msg (str "\n\n " msg))) + (assoc ex-data ::v v ::pred pred))))) + +(defmacro is + ([v] `(is ~v some?)) + ([v pred] `(is ~v ~pred nil)) + ([v pred msg] `(is ~v ~pred ~msg {})) + ([v pred msg ex-data] `(-is ~v ~pred '~v '~pred ~msg ~ex-data))) + (tests (check nil) :throws #?(:clj clojure.lang.ExceptionInfo :cljs js/Error) (check odd? 2) :throws #?(:clj clojure.lang.ExceptionInfo :cljs js/Error) diff --git a/src/contrib/triple_store.clj b/src/contrib/triple_store.clj index 7bfabe235..2273f156e 100644 --- a/src/contrib/triple_store.clj +++ b/src/contrib/triple_store.clj @@ -1,7 +1,8 @@ (ns contrib.triple-store (:refer-clojure :exclude [find]) (:require [dom-top.core :refer [loopr]] - [clojure.set :as set])) + [clojure.set :as set] + [contrib.assert :as ca])) ;; ts - triple store ;; e - entity (id of entity) @@ -72,3 +73,7 @@ (defn find [ts & kvs] (let [ret (reduce set/intersection (into [] (comp (partition-all 2) (map (fn [[k v]] (-> ts :ave (get k) (get v))))) kvs))] (when (seq ret) ret))) +(defn find1 [ts & kvs] + (let [vs (apply find ts kvs)] + (ca/check #(= 1 (count %)) vs) + (first vs))) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 13328aa1a..57ab557f5 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -610,10 +610,10 @@ (?add-source-map e form)))) (::lookup) (let [[_ sym] form] (ts/add ts {:db/id (->id), ::parent pe, ::type ::lookup, ::sym sym})) (::static-vars) (recur (second form) pe (assoc env ::static-vars true) ts) - #_else (let [e (->id)] + #_else (let [e (->id), uid (->uid)] (reduce (fn [ts nx] (analyze (wrap-ap-arg nx) e env ts)) - (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) - (?add-source-map e form)) form))) + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap, ::uid uid}) + (?add-source-map uid form)) form))) (instance? cljs.tagged_literals.JSValue form) (let [o (.-val ^cljs.tagged_literals.JSValue form)] diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 55ea4e8f7..819b09f81 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -242,3 +242,10 @@ this tuple. Returns the concatenation of all body results as a single vector. 19 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6) (nth s 7) (nth s 8) (nth s 9) (nth s 10) (nth s 11) (nth s 12) (nth s 13) (nth s 14) (nth s 15) (nth s 16) (nth s 17) (nth s 18)) 20 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6) (nth s 7) (nth s 8) (nth s 9) (nth s 10) (nth s 11) (nth s 12) (nth s 13) (nth s 14) (nth s 15) (nth s 16) (nth s 17) (nth s 18) (nth s 19))))) (defmacro apply [F & args] `($ Apply* ~F [~@args])) + +(cc/defn on-unmount* [f] (m/observe (cc/fn [!] (! nil) f))) + +(defmacro on-unmount "Run clojure(script) thunk `f` during unmount. + + Standard electric code runs on mount, therefore there is no `on-mount`." + [f] `(input (on-unmount* ~f))) ; experimental diff --git a/src/hyperfiddle/electric_local_def_de.cljc b/src/hyperfiddle/electric_local_def_de.cljc index e40e6d0b1..619e028dc 100644 --- a/src/hyperfiddle/electric_local_def_de.cljc +++ b/src/hyperfiddle/electric_local_def_de.cljc @@ -26,6 +26,18 @@ ([nm form] `(test-compile ~nm {} ~form)) ([nm env form] `(lang/compile ~nm '~form (merge web-config (lang/normalize-env ~env)))))) +#?(:clj (defn code->ts* [env conf form] + (ca/check map? conf) + (let [env (merge (->local-config env) (lang/normalize-env env) conf) + expanded (lang/expand-all env `(::lang/ctor ~form)) + _ (when (::lang/print-expansion env) (fipp.edn/pprint expanded)) + ts (lang/analyze expanded '_ env (lang/->ts)) + _ (when (::lang/print-analysis env) (run! prn (->> ts :eav vals (sort-by :db/id))))] + (lang/analyze-electric env ts)))) + +#?(:clj (defmacro code->ts {:style/indent 1} [conf & body] + `(code->ts* ~&env ~conf '(do ~@body)))) + #?(:clj (defn collect-deps [deps] (loop [ret (sorted-set) deps deps] diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index 6fbb6d807..8c85835b6 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -1,6 +1,7 @@ (ns hyperfiddle.electric.impl.compiler-test (:require [hyperfiddle.electric-de :as e] [hyperfiddle.incseq :as i] + #?(:clj [contrib.triple-store :as ts]) #?(:clj [hyperfiddle.electric.impl.lang-de2 :as lang]) [hyperfiddle.electric.impl.runtime-de :as r] [hyperfiddle.electric-local-def-de :as l] @@ -491,9 +492,14 @@ (r/cdef 0 [] [] nil (fn [~'frame] (r/pure 1))) (r/cdef 0 [] [] nil (fn [~'frame] (r/pure 2)))])) -(comment ; TODO rewrite for new iteration - ;; ( ) - ;; source-map => ::line ::column +(comment + + (let [ts (l/code->ts {} (prn :hello)) + ap-uid (lang/e->uid ts (ts/find1 ts ::lang/type ::lang/ap))] + (match (ts/->node ts (ts/find1 ts ::lang/source-map-of ap-uid)) + {::lang/line `tm/_, ::lang/column `tm/_})) + + (number? (-> (l/compile-client-source-map (prn "hello world")) first ::lang/line)) := true (let [sm (l/compile-client-source-map (let [x "Hello world", y "Hello world"] [x y])) line (-> sm first ::lang/line)] From b99b9660f456e5e91a590236de2c75604af13bc7 Mon Sep 17 00:00:00 2001 From: xificurC Date: Fri, 15 Mar 2024 15:39:03 +0100 Subject: [PATCH 146/428] 2 local peers test entrypoint, first test using it --- src/hyperfiddle/electric/impl/runtime_de.cljc | 6 ++--- src/hyperfiddle/electric_local_def_de.cljc | 27 +++++++++++++++++++ test/hyperfiddle/electric_de_test.cljc | 18 ++++++++++--- 3 files changed, 45 insertions(+), 6 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index a972575af..19768f153 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -493,7 +493,7 @@ T T T -> (EXPR T) (define-slot frame id ((.-build cdef) frame)) frame)) (defn peer-cancel [^Peer peer] - (prn :TODO-cancel)) + #_(prn :TODO-cancel)) (defn decode [^String s opts] #?(:clj (t/read (t/reader (ByteArrayInputStream. (.getBytes s)) :json opts)) @@ -690,11 +690,11 @@ T T T -> (EXPR T) (recur)))))) (defn peer-result-diff [^Peer peer diff] - (prn :TODO-result-diff diff) + #_(prn :TODO-result-diff diff) peer) (defn peer-result-success [^Peer peer] - (prn :TODO-result-success)) + #_(prn :TODO-result-success)) (defn define-node "Defines signals node id for given frame." diff --git a/src/hyperfiddle/electric_local_def_de.cljc b/src/hyperfiddle/electric_local_def_de.cljc index 619e028dc..158a5c06a 100644 --- a/src/hyperfiddle/electric_local_def_de.cljc +++ b/src/hyperfiddle/electric_local_def_de.cljc @@ -66,3 +66,30 @@ (when (::lang/print-source env) (fipp.edn/pprint ctors)) (when (::lang/print-defs env) (fipp.edn/pprint defs)) `(run-single (r/root-frame ~defs ::Main))))) + +(defn run-local [defs main] + (m/reduce #(do %2) nil + (let [s->c (m/dfv), c->s (m/dfv) + c (r/peer (fn [!] (s->c !) #()) :client defs main) + s (r/peer (fn [!] (c->s !) #()) :server defs main)] + (m/ap (m/amb= + (let [v (m/?> c)] ((m/? c->s) v)) + (let [v (m/?> s)] ((m/? s->c) v))))))) + +(defmacro local {:style/indent 1} [conf & body] + (ca/is conf map? "provide config map as first argument") + (let [env (merge (->local-config &env) (lang/normalize-env &env) conf) + expanded (lang/expand-all env `(::lang/ctor (do ~@body))) + _ (when (::lang/print-expansion env) (fipp.edn/pprint expanded)) + ts (lang/analyze expanded '_ env (lang/->ts)) + _ (when (::lang/print-analysis env) (run! prn (->> ts :eav vals (sort-by :db/id)))) + ts (lang/analyze-electric env ts) + ctors (mapv #(lang/emit-ctor ts % env ::Main) (lang/get-ordered-ctors-e ts)) + ret-e (lang/get-ret-e ts (lang/get-child-e ts 0)) + deps (lang/emit-deps ts ret-e) + deps (collect-deps deps) + defs (into {} (map (fn [dep] [(keyword dep) dep])) deps) + defs (assoc defs ::Main ctors)] + (when (::lang/print-source env) (fipp.edn/pprint ctors)) + (when (::lang/print-defs env) (fipp.edn/pprint defs)) + `(run-local ~defs ::Main))) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 299d26153..e1f3b1ed1 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -596,20 +596,32 @@ (with ((l/single {} (try (tap (e/server (e/client 1))) (catch Pending _))) tap tap) % := 1)) +(tests "client/server transfer" + (with ((l/local {} (tap (e/server 1))) tap tap) + % := 1)) + ;; TODO network -;; (l/def foo nil) +(def foo nil) (skip (with ((l/single {} (try (tap (binding [foo 1] (e/server (e/client foo)))) - (catch Pending _))) tap tap) + (catch Pending _))) tap tap) + % := 1)) + +(tests + (with ((l/single {} (tap (binding [foo 1] (e/server (e/client foo))))) tap tap) % := 1)) ;; TODO network -;; (l/def foo nil) +(def foo nil) (skip (with ((l/single {} (try (tap (binding [foo 1] (e/server (new (e/fn [] (e/client foo)))))) (catch Pending _))) tap tap) % := 1)) +(skip + (with ((l/single {} (tap (binding [foo 1] (e/server ($ (e/fn [] (e/client foo))))))) tap tap) + % := 1)) + ;; TODO try/catch ;; (l/def foo1 nil) ;; (l/def Bar1 (e/fn [] (e/client foo1))) From 6fcadfdab2436b7936e4c00111631d7ea23428c4 Mon Sep 17 00:00:00 2001 From: xificurC Date: Fri, 15 Mar 2024 17:16:26 +0100 Subject: [PATCH 147/428] add 2peer tests, most failing --- test/hyperfiddle/electric_de_test.cljc | 86 ++++++++++++++++++++++++-- 1 file changed, 82 insertions(+), 4 deletions(-) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index e1f3b1ed1..502293079 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -9,7 +9,7 @@ #?(:cljs [hyperfiddle.goog-calls-test-de]) [clojure.string :as str] [missionary.core :as m]) - #?(:cljs (:require-macros [hyperfiddle.electric-de-test :refer [skip tests]])) + #?(:cljs (:require-macros [hyperfiddle.electric-de-test :refer [skip tests failing]])) (:import [hyperfiddle.electric Pending Failure] [missionary Cancelled] #?(:clj [clojure.lang ExceptionInfo]))) @@ -22,6 +22,10 @@ (defmacro tests {:style/indent 0} [& body] `(do (swap! stats update :tested inc) (rcf/tests ~@body))) +(defmacro failing {:style/indent 0} [& body] + nil + #_`(try (do ~@body) (catch ~(if (:js-globals &env) :default 'Throwable) e# (prn e#)))) + (tests "call on local electric ctor" (with ((l/single {} (let [x (e/ctor 1)] (tap ($ x)))) tap tap) % := 1)) @@ -618,18 +622,22 @@ (catch Pending _))) tap tap) % := 1)) -(skip +(failing (with ((l/single {} (tap (binding [foo 1] (e/server ($ (e/fn [] (e/client foo))))))) tap tap) % := 1)) ;; TODO try/catch -;; (l/def foo1 nil) -;; (l/def Bar1 (e/fn [] (e/client foo1))) +(def foo1 nil) +(def Bar1) (skip (with ((l/single {} (try (tap (binding [foo1 1] (e/server (Bar1.)))) (catch Pending _))) tap tap) % := 1)) +(failing + (with ((l/single {} (tap (binding [Bar1 (e/fn [] (e/client foo1)), foo1 1] (e/server ($ Bar1))))) tap tap) + % := 1)) + ;; TODO try/catch (skip "reactive pending states" ;~(m/reductions {} hyperfiddle.electric.impl.runtime/pending m/none) @@ -936,6 +944,13 @@ (swap! !t not) % := nil)) +(def !t (atom true)) +(tests + (with ((l/single {} (tap (let [t (e/watch !t)] (when t t (e/server t))))) tap tap) + % := true + (swap! !t not) + % := nil)) + (tests (def !state (atom true)) (with ((l/single {} (when (e/watch !state) (tap :touch))) tap tap) @@ -977,6 +992,19 @@ (reset! !state [3]) % := [3 3])) +(def !state (atom [1])) +(def state) +(failing + (reset! !state [1]) + "Nested e/for with transfer" + (with ((l/single {} (binding [state (e/watch !state)] + (e/for-by identity [x (e/server state)] + (e/for-by identity [y (e/server state)] + (tap [x y]))))) tap tap) + % := [1 1] + (reset! !state [3]) + % := [3 3])) + (tests "Static call" (with ((l/single {} (tap (Math/abs -1))) tap tap) @@ -1018,6 +1046,13 @@ % := [::client 1 2] % := [::server 1 2]) +(failing "fn destructuring" + (with ((l/single {} + (tap (e/client ((fn [{:keys [a] ::keys [b]}] [::client a b]) {:a 1 ::b 2}))) + (tap (e/server ((fn [{:keys [a] ::keys [b]}] [::server a b]) {:a 1 ::b 2})))) tap tap)) + % := [::client 1 2] + % := [::server 1 2]) + ;; TODO try/catch (skip (def !xs (atom [false])) @@ -1066,6 +1101,16 @@ ; the remote tap on the switch has been removed % := [:client false])) +(def !x (atom true)) +(failing + (reset! !x true) + (with ((l/single {} (let [x (e/watch !x)] + (tap (if x (e/server [:server x]) [:client x])))) tap tap) + % := [:server true] + (swap! !x not) + ; the remote tap on the switch has been removed + % := [:client false])) + ;; TODO transfer try/catch (skip (def !x (atom true)) @@ -1083,6 +1128,21 @@ ; current behavior - Dustin likes, Leo does not like ) +(def !x (atom true)) +(failing + (reset! !x true) + (with ((l/single {} + (let [x (e/watch !x)] + (if (e/server x) ; to be consistent, client should see x first and switch + (e/server (tap x)) ; but test shows that the server sees x change before client + (e/server x)))) tap tap) + % := true + (swap! !x not) + % := false #_ ::rcf/timeout) + ; we have to choose: consistency or less latency? + ; current behavior - Dustin likes, Leo does not like + ) + ;; TODO transfer try/catch ;; https://www.notion.so/hyperfiddle/distribution-glitch-stale-local-cache-of-remote-value-should-be-invalidated-pending-47f5e425d6cf43fd9a37981c9d80d2af (skip "glitch - stale local cache of remote value should be invalidated/pending" @@ -1127,6 +1187,14 @@ % := 1 % := 1)) +(failing + (with ((l/single {} (e/server + (let [foo 1] + (tap foo) + (tap (e/client foo))))) tap tap) + % := 1 + % := 1)) + ;; TODO transfer try/catch (skip "Today, bindings fail to transfer, resulting in unbound var exception. This will be fixed" ; https://www.notion.so/hyperfiddle/photon-binding-transfer-unification-of-client-server-binding-7e56d9329d224433a1ee3057e96541d1 @@ -1153,6 +1221,10 @@ (catch Pending _))) tap tap) % := 2)) +(failing "static method call in e/server" + (with ((l/single {} (tap (e/server (Math/max 2 1)))) tap tap) + % := 2)) + ;; TODO transfer try/catch (skip "static method call in e/client" (with ((l/single {} (try (tap (e/server (subvec (vec (range 10)) @@ -1161,6 +1233,12 @@ (catch Pending _))) tap tap) % := [1 2])) +(failing "static method call in e/client" + (with ((l/single {} (tap (e/server (subvec (vec (range 10)) + (Math/min 1 1) + (Math/min 3 3))))) tap tap) + % := [1 2])) + (def !state (atom 0)) (def global) (tests "Inline cc/fn support" From 617b3a9583d266578fa6b9aa013c6d7aa20e8de1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Fri, 15 Mar 2024 21:35:34 +0100 Subject: [PATCH 148/428] fix site resolution --- src/hyperfiddle/electric/impl/runtime_de.cljc | 254 ++++++++---------- test/hyperfiddle/electric_de_test.cljc | 4 +- 2 files changed, 116 insertions(+), 142 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 19768f153..c5f84a56c 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -268,34 +268,29 @@ T T T -> (EXPR T) [^Ctor ctor] (((.-defs (ctor-peer ctor)) (.-key ctor)) (.-idx ctor))) -(declare result) - (defn port-flow [^objects port] (aget port port-slot-flow)) (defn port-deps [^objects port] (aget port port-slot-deps)) -(deftype Frame [parent call-id rank site ctor - ^ints ranks ^objects children ^objects ports +(deftype Frame [slot rank site ctor + ^ints ranks ^objects children + ^objects calls ^objects nodes ^:unsynchronized-mutable ^:mutable hash-memo] #?(:clj Object) #?(:cljs IHash) (#?(:clj hashCode :cljs -hash) [_] (if-some [h hash-memo] - h (set! hash-memo - (-> (hash parent) - (hash-combine (hash call-id)) - (hash-combine (hash rank)))))) + h (set! hash-memo (hash-combine (hash slot) (hash rank))))) #?(:cljs IEquiv) (#?(:clj equals :cljs -equiv) [_ other] (and (instance? Frame other) - (= parent (.-parent ^Frame other)) - (= call-id (.-call-id ^Frame other)) + (= slot (.-slot ^Frame other)) (= rank (.-rank ^Frame other)))) IFn (#?(:clj invoke :cljs -invoke) [this step done] - ((port-flow (result this)) step done))) + ((port-flow (aget nodes (dec (alength nodes)))) step done))) (defn frame-ctor "Returns the constructor of given frame." @@ -315,17 +310,6 @@ T T T -> (EXPR T) [^Frame frame] (ctor-cdef (frame-ctor frame))) -(defn frame-parent - "Returns the parent frame of given frame if not root, nil otherwise." - {:tag Frame} - [^Frame frame] - (.-parent frame)) - -(defn frame-call-id - "Returns the call id of given frame." - [^Frame frame] - (.-call-id frame)) - (defn frame-call-count "Returns the call count of given frame." [^Frame frame] @@ -436,61 +420,67 @@ T T T -> (EXPR T) (aset port port-slot-process nil) (peer-push (frame-peer (.-frame (port-slot port))) peer-queue-untap port)) -(defn frame-port - {:tag 'objects} - [^Frame frame id] - (let [^objects ports (.-ports frame)] - (aget ports id))) - (defn slot-port {:tag 'objects} [^Slot slot] - (frame-port (.-frame slot) (.-id slot))) + (let [id (.-id slot) + ^Frame frame (.-frame slot)] + (if (neg? id) + (aget ^objects (.-nodes frame) (- -1 id)) + (aget ^objects (.-calls frame) id)))) (defn port-ready [^objects port] (peer-push (frame-peer (.-frame (port-slot port))) peer-queue-ready port)) -(defn define-slot [^Frame frame id expr] - (let [^objects ports (.-ports frame)] - (when-not (nil? (aget ports id)) - (throw (error "Can't redefine slot."))) - (aset ports id - (if (instance? Slot expr) - (slot-port expr) - (let [cdef (ctor-cdef (frame-ctor frame)) - nodes (.-nodes cdef) - nodec (count nodes) - site (if-some [site (if (< id nodec) - (nodes id) - (let [id (+ id nodec) - calls (.-calls cdef) - callc (count calls)] - (if (< id callc) - (calls id) - (.-result cdef))))] - site (frame-site frame)) - port (object-array port-slots)] - (aset port port-slot-slot (->Slot frame id)) - (aset port port-slot-site site) - (aset port port-slot-deps (deps expr site)) - (aset port port-slot-flow - (m/signal i/combine - (if (= site (.-site (frame-peer frame))) - (flow expr) - (fn [step done] - (let [ps (->Remote port step done (i/empty-diff 0))] - (port-attach port ps) (step) ps))))) - (aset port port-slot-refcount (identity 0)) - (aset port port-slot-requested (identity 0)) - port))) nil)) - -(defn make-frame [^Frame parent call-id rank ctor] +(defn frame-path [^Frame frame] + (loop [^Frame frame frame + path ()] + (if-some [^Slot slot (.-slot frame)] + (recur (.-frame slot) + (conj path [(.-id slot) (.-rank frame)])) + (vec path)))) + +(defn define-slot [^Slot slot expr] + (let [^Frame frame (.-frame slot) + id (.-id slot) + site (if-some [site (let [cdef (ctor-cdef (frame-ctor frame)) + nodes (.-nodes cdef) + calls (.-calls cdef)] + (if (neg? id) + (let [id (- -1 id)] + (if (= id (count nodes)) + (.-result cdef) (nodes id))) + (calls id)))] + site (frame-site frame)) + port (if (instance? Slot expr) + (slot-port expr) + (let [port (object-array port-slots)] + (aset port port-slot-slot slot) + (aset port port-slot-site site) + (aset port port-slot-deps (deps expr site)) + (aset port port-slot-flow + (m/signal i/combine + (if (= site (.-site (frame-peer frame))) + (flow expr) + (fn [step done] + (let [ps (->Remote port step done (i/empty-diff 0))] + (port-attach port ps) (step) ps))))) + (aset port port-slot-refcount (identity 0)) + (aset port port-slot-requested (identity 0)) + port))] + (if (neg? id) + (aset ^objects (.-nodes frame) (- -1 id) port) + (aset ^objects (.-calls frame) id port)) nil)) + +(defn make-frame [^Slot slot rank ctor] (let [cdef (ctor-cdef ctor) callc (count (.-calls cdef)) - id (+ (count (.-nodes cdef)) callc) - frame (->Frame parent call-id rank (if (nil? parent) :client (frame-site parent)) ctor - (int-array (inc callc)) (object-array callc) (object-array (inc id)) nil)] - (define-slot frame id ((.-build cdef) frame)) frame)) + nodec (count (.-nodes cdef)) + frame (->Frame slot rank + (if (nil? slot) :client (port-site (slot-port slot))) ctor + (int-array (inc callc)) (object-array callc) (object-array callc) + (object-array (inc nodec)) nil)] + (define-slot (->Slot frame (- -1 nodec)) ((.-build cdef) frame)) frame)) (defn peer-cancel [^Peer peer] #_(prn :TODO-cancel)) @@ -508,16 +498,6 @@ T T T -> (EXPR T) :cljs (t/write (t/writer :json opts) value))) -(defn frame-path [^Frame frame] - (loop [^Frame frame frame - path ()] - (if-some [parent (.-parent frame)] - (recur parent - (conj path - [(.-call-id ^Frame frame) - (.-rank ^Frame frame)])) - path))) - (defn enable [^objects port] (aset port port-slot-process ((port-flow port) @@ -552,6 +532,10 @@ T T T -> (EXPR T) (aset port port-slot-refcount (- (aget port port-slot-refcount) n))) +(defn port-coordinates [^objects port] + (let [slot (port-slot port)] + [(frame-path (.-frame slot)) (.-id slot)])) + (defn peer-transfer [^Peer peer] (let [^objects state (.-state peer) ^objects queues (.-queues peer) @@ -626,29 +610,24 @@ T T T -> (EXPR T) (aget state peer-slot-writer-opts))))))))))) (defn frame-shared? [^Frame frame] - (if-some [^Frame parent (.-parent frame)] - (let [rank (.-rank frame) - call-id (.-call-id frame) + (if-some [^Slot slot (.-slot frame)] + (let [^Frame parent (.-frame slot) ^objects children (.-children parent)] - (contains? (aget children call-id) rank)) true)) + (contains? (aget children (.-id slot)) (.-rank frame))) true)) (defn frame-share [^Frame frame] - (let [rank (.-rank frame) - call-id (.-call-id frame) - ^Frame parent (.-parent frame) - ^objects children (.-children parent)] - (aset children call-id - (assoc (aget children call-id) - rank frame)))) + (let [^Slot slot (.-slot frame) + ^Frame parent (.-frame slot) + ^objects children (.-children parent) + id (.-id slot)] + (aset children id (assoc (aget children id) (.-rank frame) frame)))) (defn frame-unshare [^Frame frame] - (let [rank (.-rank frame) - call-id (.-call-id frame) - ^Frame parent (.-parent frame) - ^objects children (.-children parent)] - (aset children call-id - (dissoc (aget children call-id) - rank frame)))) + (let [^Slot slot (.-slot frame) + ^Frame parent (.-frame slot) + ^objects children (.-children parent) + id (.-id slot)] + (aset children id (dissoc (aget children id) (.-rank frame) frame)))) (defn peer-ack [^Peer peer] ;; TODO @@ -658,7 +637,9 @@ T T T -> (EXPR T) (peer-push peer peer-queue-toggle (slot-port slot)) peer) (defn peer-change [^Peer peer ^Slot slot diff] - ((port-process (slot-port slot)) diff) peer) + (let [port (slot-port slot) + ps (port-process port)] + (ps diff)) peer) (defn peer-freeze [^Peer peer ^Slot slot] ((port-process (slot-port slot)) nil) peer) @@ -696,29 +677,42 @@ T T T -> (EXPR T) (defn peer-result-success [^Peer peer] #_(prn :TODO-result-success)) +(defn node + "Returns the signal node id for given frame." + {:tag Slot} + [^Frame frame id] + (->Slot frame (- -1 id))) + +(defn call + "Returns the call site id for given frame." + {:tag Slot} + [^Frame frame id] + (->Slot frame id)) + (defn define-node "Defines signals node id for given frame." [^Frame frame id expr] - (define-slot frame id expr)) + (define-slot (node frame id) expr)) (defn define-call "Defines call site id for given frame." [^Frame frame id expr] - (define-slot frame (+ id (count (.-nodes (frame-cdef frame)))) - (reify Expr - (deps [_ site] (deps expr site)) - (flow [_] - (i/latest-product - (fn [ctor] - (when-not (instance? Ctor ctor) - (throw (error (str "Not a constructor - " (pr-str ctor))))) - (when-not (identical? (frame-peer frame) (ctor-peer ctor)) - (throw (error "Can't call foreign constructor."))) - (let [^ints ranks (.-ranks frame) - rank (aget ranks id)] - (aset ranks id (inc rank)) - (make-frame frame id rank ctor))) - (flow expr)))))) + (let [slot (call frame id)] + (define-slot slot + (reify Expr + (deps [_ site] (deps expr site)) + (flow [_] + (i/latest-product + (fn [ctor] + (when-not (instance? Ctor ctor) + (throw (error (str "Not a constructor - " (pr-str ctor))))) + (when-not (identical? (frame-peer frame) (ctor-peer ctor)) + (throw (error "Can't call foreign constructor."))) + (let [^ints ranks (.-ranks frame) + rank (aget ranks id)] + (aset ranks id (inc rank)) + (make-frame slot rank ctor))) + (flow expr))))))) (defn define-free "Defines free variable id for given constructor." @@ -736,8 +730,8 @@ T T T -> (EXPR T) ([^Frame frame key nf] (loop [frame frame] (if-some [s ((.-env (frame-ctor frame)) key)] - s (if-some [p (frame-parent frame)] - (recur p) nf))))) + s (if-some [^Slot slot (.-slot frame)] + (recur (.-frame slot)) nf))))) (defn make-ctor "Returns a fresh constructor for cdef coordinates key and idx." @@ -750,18 +744,6 @@ T T T -> (EXPR T) (eduction (map-indexed vector) frees)) ctor)) -(defn node - "Returns the signal node id for given frame." - {:tag Slot} - [^Frame frame id] - (->Slot frame id)) - -(defn call - "Returns the call site id for given frame." - {:tag Slot} - [^Frame frame id] - (->Slot frame (+ (count (.-nodes (frame-cdef frame))) id))) - (defn free "Returns the free variable id for given frame." {:tag Slot} @@ -769,14 +751,6 @@ T T T -> (EXPR T) (let [^objects free (.-free (frame-ctor frame))] (aget free id))) -(defn result - "Returns the result of given frame." - {:tag 'objects} - [^Frame frame] - (let [^objects ports (.-ports frame) - ^Cdef cdef (frame-cdef frame)] - (aget ports (+ (count (.-nodes cdef)) (count (.-calls cdef)))))) - (defn peer " Returns a peer definition from given definitions and main key. " [events site defs main & args] @@ -792,7 +766,7 @@ Returns a peer definition from given definitions and main key. input (m/stream (m/observe events)) root (->> args (apply bind-args (->Ctor peer main 0 (object-array 0) {} nil)) - (make-frame nil 0 0))] + (make-frame nil 0))] (aset state peer-slot-writer-opts {:default-handler (t/write-handler (fn [_] "unserializable") @@ -836,9 +810,9 @@ Returns a peer definition from given definitions and main key. (fn [[path ctor]] (if (nil? ctor) (peer-frame peer path) - (let [[call rank] (peek path) + (let [[id rank] (peek path) parent (peer-frame peer (pop path)) - frame (make-frame parent call rank ctor)] + frame (make-frame (call parent id) rank ctor)] (frame-share frame) frame)))) "join" (t/read-handler (fn [input] @@ -861,7 +835,7 @@ Returns a peer definition from given definitions and main key. (when (= site :client) (aset state peer-slot-result ((m/reduce peer-result-diff peer - (m/signal i/combine (port-flow (result root)))) + (m/signal i/combine root)) peer-result-success pst))) (peer-input-ready peer) peer))) @@ -869,7 +843,7 @@ Returns a peer definition from given definitions and main key. (defn root-frame [defs main] (->> (bind-args (->Ctor (->Peer :client defs nil nil nil nil nil) main 0 (object-array 0) {} nil)) - (make-frame nil 0 0) + (make-frame nil 0) (m/signal i/combine))) #?(:clj diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 502293079..ad4203bf9 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -622,8 +622,8 @@ (catch Pending _))) tap tap) % := 1)) -(failing - (with ((l/single {} (tap (binding [foo 1] (e/server ($ (e/fn [] (e/client foo))))))) tap tap) +(tests + (with ((l/local {} (tap (binding [foo 1] (e/server ($ (e/fn [] (e/client foo))))))) tap tap) % := 1)) ;; TODO try/catch From 5ecf079fe1f62e30dfe4e544873da7a3f09489cd Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 18 Mar 2024 09:58:56 +0100 Subject: [PATCH 149/428] use l/local in 2peer tests --- test/hyperfiddle/electric_de_test.cljc | 28 +++++++++++++------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index ad4203bf9..3271f73fc 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -634,8 +634,8 @@ (catch Pending _))) tap tap) % := 1)) -(failing - (with ((l/single {} (tap (binding [Bar1 (e/fn [] (e/client foo1)), foo1 1] (e/server ($ Bar1))))) tap tap) +(tests + (with ((l/local {} (tap (binding [Bar1 (e/fn [] (e/client foo1)), foo1 1] (e/server ($ Bar1))))) tap tap) % := 1)) ;; TODO try/catch @@ -997,7 +997,7 @@ (failing (reset! !state [1]) "Nested e/for with transfer" - (with ((l/single {} (binding [state (e/watch !state)] + (with ((l/local {} (binding [state (e/watch !state)] (e/for-by identity [x (e/server state)] (e/for-by identity [y (e/server state)] (tap [x y]))))) tap tap) @@ -1046,8 +1046,8 @@ % := [::client 1 2] % := [::server 1 2]) -(failing "fn destructuring" - (with ((l/single {} +(tests "fn destructuring" + (with ((l/local {} (tap (e/client ((fn [{:keys [a] ::keys [b]}] [::client a b]) {:a 1 ::b 2}))) (tap (e/server ((fn [{:keys [a] ::keys [b]}] [::server a b]) {:a 1 ::b 2})))) tap tap)) % := [::client 1 2] @@ -1102,9 +1102,9 @@ % := [:client false])) (def !x (atom true)) -(failing +(tests (reset! !x true) - (with ((l/single {} (let [x (e/watch !x)] + (with ((l/local {} (let [x (e/watch !x)] (tap (if x (e/server [:server x]) [:client x])))) tap tap) % := [:server true] (swap! !x not) @@ -1131,7 +1131,7 @@ (def !x (atom true)) (failing (reset! !x true) - (with ((l/single {} + (with ((l/local {} (let [x (e/watch !x)] (if (e/server x) ; to be consistent, client should see x first and switch (e/server (tap x)) ; but test shows that the server sees x change before client @@ -1187,8 +1187,8 @@ % := 1 % := 1)) -(failing - (with ((l/single {} (e/server +(tests + (with ((l/local {} (e/server (let [foo 1] (tap foo) (tap (e/client foo))))) tap tap) @@ -1221,8 +1221,8 @@ (catch Pending _))) tap tap) % := 2)) -(failing "static method call in e/server" - (with ((l/single {} (tap (e/server (Math/max 2 1)))) tap tap) +(tests "static method call in e/server" + (with ((l/local {} (tap (e/server (Math/max 2 1)))) tap tap) % := 2)) ;; TODO transfer try/catch @@ -1233,8 +1233,8 @@ (catch Pending _))) tap tap) % := [1 2])) -(failing "static method call in e/client" - (with ((l/single {} (tap (e/server (subvec (vec (range 10)) +(tests "static method call in e/client" + (with ((l/local {} (tap (e/server (subvec (vec (range 10)) (Math/min 1 1) (Math/min 3 3))))) tap tap) % := [1 2])) From e2ee51a0b68691234b328d9591ae3dcfa239e7a3 Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 18 Mar 2024 10:05:55 +0100 Subject: [PATCH 150/428] fix browser tests --- src/hyperfiddle/electric/impl/runtime_de.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index c5f84a56c..03d7c55da 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -437,7 +437,7 @@ T T T -> (EXPR T) path ()] (if-some [^Slot slot (.-slot frame)] (recur (.-frame slot) - (conj path [(.-id slot) (.-rank frame)])) + (conj path [(.-id slot) (.-rank ^Frame frame)])) (vec path)))) (defn define-slot [^Slot slot expr] From 724cf0f2df803c1dd017ed090a4f0babef57a410 Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 18 Mar 2024 14:25:17 +0100 Subject: [PATCH 151/428] dom3 wip --- .clj-kondo/config.edn | 1 + src/hyperfiddle/electric_de.cljc | 12 +- src/hyperfiddle/electric_dom3.cljc | 284 +++++++++++++++++++++++++++++ 3 files changed, 291 insertions(+), 6 deletions(-) create mode 100644 src/hyperfiddle/electric_dom3.cljc diff --git a/.clj-kondo/config.edn b/.clj-kondo/config.edn index 95396a9ea..70b3b5ea3 100644 --- a/.clj-kondo/config.edn +++ b/.clj-kondo/config.edn @@ -1,5 +1,6 @@ {:lint-as {hyperfiddle.electric/def clojure.core/def hyperfiddle.electric/defn clojure.core/defn + hyperfiddle.electric-de/defn clojure.core/defn hyperfiddle.electric/for clojure.core/for hyperfiddle.electric/with-cycle clojure.core/let hyperfiddle.electric/fn clojure.core/fn diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 819b09f81..3b4a7bac4 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -15,8 +15,13 @@ #?(:clj (cc/defn dget [v] `(::lang/lookup ~v))) #?(:clj (cc/defn ->pos-args [n] (eduction (take n) (map dget) (range)))) +(defmacro check-electric [fn form] + (if (::lang/electric &env) + form + (throw (ex-info (str "Electric code (" fn ") inside a Clojure function") (into {:electric-fn fn} (meta &form)))))) + (defmacro ctor [expr] `(::lang/ctor ~expr)) -(defmacro $ [F & args] `(lang/$ ~F ~@args)) +(defmacro $ [F & args] `(check-electric $ (lang/$ ~F ~@args))) (defmacro pure " Syntax : @@ -34,11 +39,6 @@ Syntax : Returns the successive states of items described by `incseq`. " [flow] `(::lang/join ~flow)) -(defmacro check-electric [fn form] - (if (::lang/electric &env) - form - (throw (ex-info (str "Electric code (" fn ") inside a Clojure function") (into {:electric-fn fn} (meta &form)))))) - (defmacro fn* [bs & body] `(check-electric fn* (ctor diff --git a/src/hyperfiddle/electric_dom3.cljc b/src/hyperfiddle/electric_dom3.cljc new file mode 100644 index 000000000..b4746e8a4 --- /dev/null +++ b/src/hyperfiddle/electric_dom3.cljc @@ -0,0 +1,284 @@ +(ns hyperfiddle.electric-dom3 + (:refer-clojure :exclude [time class?]) + (:require + [clojure.string :as str] + [contrib.assert :as ca] + #?(:cljs goog.dom) + #?(:cljs goog.object) + #?(:cljs goog.style) + [hyperfiddle.electric-de :as e :refer [$]] + [hyperfiddle.rcf :as rcf :refer [tests]] + [missionary.core :as m]) + #?(:clj (:import [clojure.lang ExceptionInfo])) + #?(:cljs (:require-macros [hyperfiddle.electric-dom3]))) + +(def node) + +;; used as a speed hack during unmount +#?(:cljs (defn ^:no-doc hide [node] (set! (.. node -style -display) "none"))) + +#?(:cljs (defn appending> [elem parent] + (ca/is parent some? "DOM node parent cannot be nil. Maybe dom/node is unbound?") + (m/observe (fn [!] (.appendChild parent elem) (! elem) #(hide elem))))) + +(defmacro with [elem & body] `(binding [node (e/input (appending> ~elem node))] ~@body)) + +#?(:cljs (defn -googDomSetTextContentNoWarn [node str] + ;; Electric says :infer-warning Cannot infer target type in expression, fixme + (goog.dom/setTextContent node str))) + +#?(:cljs (defn text-node? [nd] (= (.-nodeType nd) (.-TEXT_NODE nd)))) + +(defmacro text [& strs] + `(do (ca/is node text-node? "Cannot nest dom/text or text nodes in other text nodes") + ~@(eduction (map (fn [str] + `(with (goog.dom/createTextNode "") + (-googDomSetTextContentNoWarn node ~str)))) + strs))) + +(defmacro comment_ [& strs] + `(do ~@(eduction (map (fn [str] + `(with (.createComment js/document "") + (-googDomSetTextContentNoWarn node ~str)))) + strs))) + +(def ^:const SVG-NS "http://www.w3.org/2000/svg") +(def ^:const XLINK-NS "http://www.w3.org/1999/xlink") + +(def alias->ns {"svg" SVG-NS, "xlink" XLINK-NS}) + +(defn attr-alias [attr] (second (re-find #"^([^:]+):" (name attr)))) + +(defn resolve-attr-alias [attr] + (let [attr (name attr)] + (if-let [alias (attr-alias attr)] + (let [attr (-> (str/replace-first attr alias "") + (str/replace-first #"^:" ""))] + [(alias->ns alias) attr]) + [nil attr]))) + +#?(:cljs + (defn set-attribute-ns + ([node attr v] + (let [[ns attr] (resolve-attr-alias attr)] + (set-attribute-ns node ns attr v))) + ([^js node ns attr v] + (.setAttributeNS node ns attr v)))) + +#?(:cljs (defn- css-var? [k] (str/starts-with? k "--"))) +#?(:cljs (defn set-style> [node k v] + (let [k (clj->js k), v (clj->js v) + setter (if (css-var? k) #(.setProperty (.-style node) k %) #(goog.style/setStyle_ node % k))] + (m/observe (fn [!] (setter v) (! v) #(setter nil)))))) + +#?(:cljs (defn set-property> + ([node k v] (set-property> node (.-namespaceURI node) k v)) + ([node ns k v] + (let [k (name k), v (clj->js v) + setter (case k + "list" ; corner case, list (datalist) is set by attribute and readonly as a prop. + #(set-attribute-ns node nil k %) + (if (or (= SVG-NS ns) (some? (goog.object/get goog.dom/DIRECT_ATTRIBUTE_MAP_ k))) + #(set-attribute-ns node k %) + (if (goog.object/containsKey node k) ; is there an object property for this key? + #(goog.object/set node k %) + #(set-attribute-ns node k %))))] + (m/observe (fn [!] (setter v) (! v) #(setter nil))))))) + +(def LAST-PROPS + "Due to a bug in both Webkit and FF, input type range's knob renders in the + wrong place if value is set after `min` and `max`, and `max` is above 100. + Other UI libs circumvent this issue by setting `value` last." + [:value ::value]) + +(defn ordered-props "Sort props by key to ensure they are applied in a predefined order. See `LAST-PROPS`." + [props-map] + (let [props (apply dissoc props-map LAST-PROPS)] + (concat (seq props) (seq (select-keys props-map LAST-PROPS))))) + +(defn parse-class [xs] + (cond (or (string? xs) (keyword? xs) (symbol? xs)) (re-seq #"[^\s]+" (name xs)) + (or (vector? xs) (seq? xs) (list? xs) (set? xs)) (into [] (comp (mapcat parse-class) (distinct)) xs) + (nil? xs) nil + :else (throw (ex-info "don't know how to parse into a classlist" {:data xs})))) + +(tests + (parse-class "a") := ["a"] + (parse-class :a) := ["a"] + (parse-class 'a/b) := ["b"] + (parse-class "a b") := ["a" "b"] + (parse-class ["a"]) := ["a"] + (parse-class ["a" "b" "a"]) := ["a" "b"] + (parse-class ["a" "b"]) := ["a" "b"] + (parse-class ["a b" "c"]) := ["a" "b" "c"] + (parse-class [["a b"] '("c d") #{#{"e"} "f"}]) := ["a" "b" "c" "d" "e" "f"] + (parse-class nil) := nil + (parse-class "") := nil + (parse-class " a") := ["a"] + (try (parse-class 42) (throw (ex-info "" {})) + (catch ExceptionInfo ex (ex-data ex) := {:data 42}))) + +#?(:cljs + (defn register-class! [^js node class] + (let [refs (or (.-hyperfiddle_electric_dom2_class_refs node) {})] + (.add (.-classList node) class) + (set! (.-hyperfiddle_electric_dom2_class_refs node) (update refs class (fn [cnt] (inc (or cnt 0)))))))) + +#?(:cljs + (defn unregister-class! [^js node class] + (let [refs (or (.-hyperfiddle_electric_dom2_class_refs node) {}) + refs (if (= 1 (get refs class)) + (do (.remove (.-classList node) class) + (dissoc refs class)) + (update refs class dec))] + (set! (.-hyperfiddle_electric_dom2_class_refs node) refs)))) + +#?(:cljs + (defn- manage-class> [node class] + (m/relieve {} + (m/observe (fn [!] + (! nil) + (register-class! node class) + #(unregister-class! node class)))))) + +(e/defn ClassList [node classes] + (e/client + (e/input (manage-class> node (e/diff-by identity (parse-class classes)))))) + +(e/defn Style [node k v] (e/client (e/input (set-style> node k v)))) + +(e/defn Styles [node kvs] + (e/client + (let [[k v] (e/diff-by first kvs)] + ($ Style node k v)))) + +(defmacro style [m] + (if (map? m) ; map = static keyset, no need to diff, cheaper + `(do ~@(map (fn [[k v]] `($ Style node ~k ~v)) m)) + `($ Styles node ~m))) + +(e/defn Attribute [node k v] (e/client (e/input (set-property> node k v)))) + +(def ^:private style? #{:style ::style}) ; TODO disambiguate +(def ^:private class? #{:class ::class}) + +(e/defn Property [node k v] + (e/client + (cond (style? k) ($ Style node k v) + (class? k) ($ ClassList node v) + :else ($ Attribute node k v)))) + +(e/defn Properties [node kvs] + (e/client + (let [[k v] (e/diff-by key (ordered-props kvs))] + ($ Property node k v)))) + +(defmacro props [m] + (if (map? m) ; map = static keyset, no need to diff, cheaper + `(do ~@(eduction (map (fn [[k v]] `($ Property node ~k ~v))) + (ordered-props m))) + `(do (let [[k# v#] (e/diff-by key (ordered-props ~m))] + ($ Property node k# v#)) + nil))) + +(defmacro element {:style/indent 1} [t & body] `(with (goog.dom/createElement ~(name t)) ~@body)) + +(defmacro a {:style/indent 0} [& body] `(element :a ~@body)) +(defmacro abbr {:style/indent 0} [& body] `(element :abbr ~@body)) +(defmacro address {:style/indent 0} [& body] `(element :address ~@body)) +(defmacro area {:style/indent 0} [& body] `(element :area ~@body)) +(defmacro article {:style/indent 0} [& body] `(element :article ~@body)) +(defmacro aside {:style/indent 0} [& body] `(element :aside ~@body)) +(defmacro audio {:style/indent 0} [& body] `(element :audio ~@body)) +(defmacro b {:style/indent 0} [& body] `(element :b ~@body)) +(defmacro bdi {:style/indent 0} [& body] `(element :bdi ~@body)) +(defmacro bdo {:style/indent 0} [& body] `(element :bdo ~@body)) +(defmacro blockquote {:style/indent 0} [& body] `(element :blockquote ~@body)) +(defmacro br {:style/indent 0} [& body] `(element :br ~@body)) +(defmacro button {:style/indent 0} [& body] `(element :button ~@body)) +(defmacro canvas {:style/indent 0} [& body] `(element :canvas ~@body)) +(defmacro cite {:style/indent 0} [& body] `(element :cite ~@body)) +(defmacro code {:style/indent 0} [& body] `(element :code ~@body)) +(defmacro colgroup {:style/indent 0} [& body] `(element :colgroup ~@body)) +(defmacro col {:style/indent 0} [& body] `(element :col ~@body)) +(defmacro data {:style/indent 0} [& body] `(element :data ~@body)) +(defmacro datalist {:style/indent 0} [& body] `(element :datalist ~@body)) +(defmacro del {:style/indent 0} [& body] `(element :del ~@body)) +(defmacro details {:style/indent 0} [& body] `(element :details ~@body)) +(defmacro dfn {:style/indent 0} [& body] `(element :dfn ~@body)) +(defmacro dialog {:style/indent 0} [& body] `(element :dialog ~@body)) +(defmacro div {:style/indent 0} [& body] `(element :div ~@body)) +(defmacro dl "The
HTML element represents a description list. The element encloses a list of groups of terms (specified using the
element) and descriptions (provided by
elements). Common uses for this element are to implement a glossary or to display metadata (a list of key-value pairs)." {:style/indent 0} [& body] `(element :dl ~@body)) +(defmacro dt "The
HTML element specifies a term in a description or definition list, and as such must be used inside a
element. It is usually followed by a
element; however, multiple
elements in a row indicate several terms that are all defined by the immediate next
element." {:style/indent 0} [& body] `(element :dt ~@body)) +(defmacro dd "The
HTML element provides the description, definition, or value for the preceding term (
) in a description list (
)." {:style/indent 0} [& body] `(element :dd ~@body)) +(defmacro em {:style/indent 0} [& body] `(element :em ~@body)) +(defmacro embed {:style/indent 0} [& body] `(element :embed ~@body)) +(defmacro fieldset {:style/indent 0} [& body] `(element :fieldset ~@body)) +(defmacro figure {:style/indent 0} [& body] `(element :figure ~@body)) +(defmacro footer {:style/indent 0} [& body] `(element :footer ~@body)) +(defmacro form {:style/indent 0} [& body] `(element :form ~@body)) +(defmacro h1 {:style/indent 0} [& body] `(element :h1 ~@body)) +(defmacro h2 {:style/indent 0} [& body] `(element :h2 ~@body)) +(defmacro h3 {:style/indent 0} [& body] `(element :h3 ~@body)) +(defmacro h4 {:style/indent 0} [& body] `(element :h4 ~@body)) +(defmacro h5 {:style/indent 0} [& body] `(element :h5 ~@body)) +(defmacro h6 {:style/indent 0} [& body] `(element :h6 ~@body)) +(defmacro header {:style/indent 0} [& body] `(element :header ~@body)) +(defmacro hgroup {:style/indent 0} [& body] `(element :hgroup ~@body)) +(defmacro hr {:style/indent 0} [& body] `(element :hr ~@body)) +(defmacro i {:style/indent 0} [& body] `(element :i ~@body)) +(defmacro iframe {:style/indent 0} [& body] `(element :iframe ~@body)) +(defmacro img {:style/indent 0} [& body] `(element :img ~@body)) +(defmacro input {:style/indent 0} [& body] `(element :input ~@body)) +(defmacro ins {:style/indent 0} [& body] `(element :ins ~@body)) +(defmacro kbd {:style/indent 0} [& body] `(element :kbd ~@body)) +(defmacro label {:style/indent 0} [& body] `(element :label ~@body)) +(defmacro legend {:style/indent 0} [& body] `(element :legend ~@body)) +(defmacro li {:style/indent 0} [& body] `(element :li ~@body)) +(defmacro link {:style/indent 0} [& body] `(element :link ~@body)) +(defmacro main {:style/indent 0} [& body] `(element :main ~@body)) +#_(defmacro map {:style/indent 0} [& body] `(element :map ~@body)) +(defmacro mark {:style/indent 0} [& body] `(element :mark ~@body)) +(defmacro math {:style/indent 0} [& body] `(element :math ~@body)) +(defmacro menu {:style/indent 0} [& body] `(element :menu ~@body)) +(defmacro itemprop {:style/indent 0} [& body] `(element :itemprop ~@body)) +(defmacro meter {:style/indent 0} [& body] `(element :meter ~@body)) +(defmacro nav {:style/indent 0} [& body] `(element :nav ~@body)) +(defmacro noscript {:style/indent 0} [& body] `(element :noscript ~@body)) +(defmacro object {:style/indent 0} [& body] `(element :object ~@body)) +(defmacro ol {:style/indent 0} [& body] `(element :ol ~@body)) +(defmacro option {:style/indent 0} [& body] `(element :option ~@body)) +(defmacro optgroup {:style/indent 0} [& body] `(element :optgroup ~@body)) +(defmacro output {:style/indent 0} [& body] `(element :output ~@body)) +(defmacro p {:style/indent 0} [& body] `(element :p ~@body)) +(defmacro picture {:style/indent 0} [& body] `(element :picture ~@body)) +(defmacro pre {:style/indent 0} [& body] `(element :pre ~@body)) +(defmacro progress {:style/indent 0} [& body] `(element :progress ~@body)) +(defmacro q {:style/indent 0} [& body] `(element :q ~@body)) +(defmacro ruby {:style/indent 0} [& body] `(element :ruby ~@body)) +(defmacro s {:style/indent 0} [& body] `(element :s ~@body)) +(defmacro samp {:style/indent 0} [& body] `(element :samp ~@body)) +(defmacro script {:style/indent 0} [& body] `(element :script ~@body)) +(defmacro section {:style/indent 0} [& body] `(element :section ~@body)) +(defmacro select {:style/indent 0} [& body] `(element :select ~@body)) +(defmacro slot {:style/indent 0} [& body] `(element :slot ~@body)) +(defmacro small {:style/indent 0} [& body] `(element :small ~@body)) +(defmacro span {:style/indent 0} [& body] `(element :span ~@body)) +(defmacro strong {:style/indent 0} [& body] `(element :strong ~@body)) +(defmacro sub {:style/indent 0} [& body] `(element :sub ~@body)) +(defmacro summary {:style/indent 0} [& body] `(element :summary ~@body)) +(defmacro sup {:style/indent 0} [& body] `(element :sup ~@body)) +(defmacro table {:style/indent 0} [& body] `(element :table ~@body)) +(defmacro tbody {:style/indent 0} [& body] `(element :tbody ~@body)) +(defmacro td {:style/indent 0} [& body] `(element :td ~@body)) +(defmacro th {:style/indent 0} [& body] `(element :th ~@body)) +(defmacro thead {:style/indent 0} [& body] `(element :thead ~@body)) +(defmacro tr {:style/indent 0} [& body] `(element :tr ~@body)) +(defmacro template {:style/indent 0} [& body] `(element :template ~@body)) +(defmacro textarea {:style/indent 0} [& body] `(element :textarea ~@body)) +(defmacro time {:style/indent 0} [& body] `(element :time ~@body)) +(defmacro u {:style/indent 0} [& body] `(element :u ~@body)) +(defmacro ul {:style/indent 0} [& body] `(element :ul ~@body)) +(defmacro var {:style/indent 0} [& body] `(element :var ~@body)) +(defmacro video {:style/indent 0} [& body] `(element :video ~@body)) +(defmacro wbr {:style/indent 0} [& body] `(element :wbr ~@body)) From 40252126d09dbcb6e149da986dae8ba008f7c676 Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 19 Mar 2024 16:08:21 +0100 Subject: [PATCH 152/428] improve error messages, turn unresolvable symbol compile-time errors to runtime errors. Since constructors start unsited any macro wrapping already sited code to a constructor would otherwise fail to compile. `e/amb` is an example, `binding` another. --- src/hyperfiddle/electric/impl/lang_de2.clj | 28 ++++++------------- src/hyperfiddle/electric/impl/runtime_de.cljc | 2 ++ src/hyperfiddle/electric_de.cljc | 2 +- src/hyperfiddle/electric_dom3.cljc | 3 +- .../electric/impl/compiler_test.cljc | 5 +--- 5 files changed, 15 insertions(+), 25 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 57ab557f5..2febcc015 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -215,8 +215,8 @@ (defn fail! ([env msg] (fail! env msg {})) - ([env msg data] (throw (ex-info (str (when-some [d (::def env)] (str "in " d ":\n")) msg) - (merge {:form (-> env ::last pop peek) :in (::def env) :for ((juxt ::me ::current) env)} data))))) + ([env msg data] (throw (ex-info (str "\n" (get-ns env) (when-some [d (::def env)] (str "/" d)) ":" (-> env ::meta :line) ":" (-> env ::meta :column) "\n" msg) + (merge {:in (::def env) :for (or (::current env) ::unsited)} data))))) (defn get-them [env] (-> env ::peers keys set (disj (::current env)) first)) @@ -406,17 +406,10 @@ {::lang nil, ::type ::node, ::node nd} (case (get (::peers env) (::current env)) :clj (let [v (analyze-clj-symbol sym (get-ns env))] (case v nil (cannot-resolve! env sym) #_else (assoc v ::lang :clj))) - :cljs (assoc (analyze-cljs-symbol sym env) - ::lang :cljs) - #_unsited (let [langs (set (vals (::peers env))) - vs (->> langs - (into #{} - (map #(case % - :clj (some-> (analyze-clj-symbol sym (get-ns env)) (assoc ::lang :clj)) - :cljs (some-> (analyze-cljs-symbol sym env) (assoc ::lang :cljs))))))] - (cond (contains? vs nil) (cannot-resolve! env sym) - (> (count (sequence (comp (map #(select-keys % [::type ::sym])) (distinct)) vs)) 1) (ambiguous-resolve! env sym vs) - :else (assoc (first vs) ::lang nil))))))) + :cljs (assoc (analyze-cljs-symbol sym env) ::lang :cljs) + #_unsited (case (->env-type env) + :clj (assoc (or (analyze-clj-symbol sym (get-ns env)) {::type ::var, ::sym `r/cannot-resolve}) :lang :clj) + :cljs (assoc (analyze-cljs-symbol sym env) :lang :cljs)))))) (defn ->bindlocal-body-e [ts e] (second (get-children-e ts e))) @@ -498,18 +491,15 @@ (swap! @(requiring-resolve 'cljs.env/*compiler*) assoc-in [:cljs.analyzer/namespaces ns :defs sym] {:name sym})) -(defn store [env form] - (if (::last env) - (update env ::last #(conj (pop %) form)) - (assoc env ::last (conj (clojure.lang.PersistentQueue/EMPTY) nil form)))) - (defn e->uid [ts e] (ca/check (::uid (ts/->node ts e)))) (defn uid->e [ts uid] (first (ca/check #(= 1 (count %)) (ts/find ts ::uid uid)))) (defn reparent-children [ts from-e to-e] (reduce (fn [ts e] (ts/asc ts e ::parent to-e)) ts (ts/find ts ::parent from-e))) +(defn ?update-meta [env form] (cond-> env (meta form) (assoc ::meta (meta form)))) + (defn analyze [form pe env {{::keys [->id ->uid]} :o :as ts}] - (let [env (store env form)] + (let [env (?update-meta env form)] (cond (and (seq? form) (seq form)) (case (first form) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 03d7c55da..cdb06c6f0 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -861,3 +861,5 @@ Returns a peer definition from given definitions and main key. (apply array-map gmap) (if (seq gmap) (first gmap) {})) gmap)) + +(defn cannot-resolve [& args] (throw (ex-info "definition called on a peer that doesn't support it" {:args args}))) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 3b4a7bac4..82c350b37 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -106,7 +106,7 @@ Returns the successive states of items described by `incseq`. (defmacro defn [nm & fdecl] (let [[_defn sym] (macroexpand `(cc/defn ~nm ~@fdecl)) - env (merge (meta nm) (lang/normalize-env &env) l/web-config) + env (merge (meta nm) (lang/normalize-env &env) l/web-config {::lang/def nm}) nm2 (vary-meta nm merge (meta sym)) expanded (lang/expand-all env `(fn ~nm2 ~@(cond-> fdecl (string? (first fdecl)) next))) _ (when (::lang/print-expansion env) (fipp.edn/pprint expanded)) diff --git a/src/hyperfiddle/electric_dom3.cljc b/src/hyperfiddle/electric_dom3.cljc index b4746e8a4..71fc46514 100644 --- a/src/hyperfiddle/electric_dom3.cljc +++ b/src/hyperfiddle/electric_dom3.cljc @@ -28,9 +28,10 @@ (goog.dom/setTextContent node str))) #?(:cljs (defn text-node? [nd] (= (.-nodeType nd) (.-TEXT_NODE nd)))) +#?(:cljs (defn ensure-not-in-text-node! [nd] (ca/is nd text-node? "Cannot nest dom/text or text nodes in other text nodes"))) (defmacro text [& strs] - `(do (ca/is node text-node? "Cannot nest dom/text or text nodes in other text nodes") + `(do (ensure-not-in-text-node! node) ~@(eduction (map (fn [str] `(with (goog.dom/createTextNode "") (-googDomSetTextContentNoWarn node ~str)))) diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index 8c85835b6..bb341b5ab 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -105,10 +105,7 @@ (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure prn)) (r/node ~'frame 0)))) (r/cdef 0 [] [] nil - (fn [~'frame] (r/pure nil)))]) - - (let [ex (try (l/test-compile ::Main cannot-be-unsited) (catch ExceptionInfo e e))] - (ex-message ex) := "Unsited symbol `cannot-be-unsited` resolves to different vars on different peers. Please resolve ambiguity by siting the expression using it.")) + (fn [~'frame] (r/pure nil)))])) (tests "test-let" (match (l/test-compile ::Main (::lang/site :client (let [a :foo] [a a]))) From 47606e7bc6f5c62c92d699d5c45ea261c0b19293 Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 19 Mar 2024 21:36:50 +0100 Subject: [PATCH 153/428] fixes to get starter app running - temporarily search for node metadata on clj side even for cljs code - add new shadow reload hook - wrap goog.dom calls in cljs defns. Is this a regression? Macros expanded to goog.dom calls in other namespaces which failed to find goog.dom. Not sure if this is the case in regular cljs code too. --- .../electric/impl/cljs_analyzer.clj | 6 ++--- src/hyperfiddle/electric/impl/lang_de2.clj | 14 +++++++---- .../electric/shadow_cljs/hooks_de.clj | 24 +++++++++++++++++++ src/hyperfiddle/electric_de.cljc | 2 ++ src/hyperfiddle/electric_dom3.cljc | 7 ++++-- 5 files changed, 43 insertions(+), 10 deletions(-) create mode 100644 src/hyperfiddle/electric/shadow_cljs/hooks_de.clj diff --git a/src/hyperfiddle/electric/impl/cljs_analyzer.clj b/src/hyperfiddle/electric/impl/cljs_analyzer.clj index c27195413..435ea1792 100644 --- a/src/hyperfiddle/electric/impl/cljs_analyzer.clj +++ b/src/hyperfiddle/electric/impl/cljs_analyzer.clj @@ -91,8 +91,6 @@ o)) o))) -(defn ->def-info [ns$ sym] {::name (with-meta (symbol (str ns$) (str sym)) (meta sym)), ::meta (meta sym)}) - (defn add-require [!a ns$ reqk from$ to$] (swap! !a assoc-in [::nses ns$ reqk from$] to$)) (defn add-refers [!a ns$ refk o req$] @@ -160,6 +158,8 @@ #_else noneT))) args)))) +(defn ->def-info [ns$ sym] {::name (with-meta (symbol (str ns$) (str sym)) (meta sym)), ::meta (meta sym)}) + (defn add-def [!a ns$ sym] (swap! !a assoc-in [::nses ns$ ::defs sym] (->def-info ns$ sym))) (defn collect-defs [!a ns$ env o] @@ -198,7 +198,7 @@ (recur @!a))))) noneT)) -(defn purge-ns [!a ns$] (swap! !a (fn [a] (-> a (update ::ns-tasks dissoc ns$) (update ::nses dissoc ns$)))) nil) +(defn purge-ns [a ns$] (-> a (update ::ns-tasks dissoc ns$) (update ::nses dissoc ns$))) (defn find-var [a sym ns$] (let [nsa (-> a ::nses (get ns$))] diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 2febcc015..53750ab8f 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -378,11 +378,15 @@ (defn resolve-node [sym env] (case (->env-type env) :clj (when-some [^clojure.lang.Var vr (resolve env sym)] - (when (-> vr meta node?) - (symbol (-> vr .ns str) (-> vr .sym str)))) - :cljs (when-some [vr (cljs-ana/find-var @!a sym (get-ns env)) #_(resolve-cljs env sym)] - (when (-> vr ::cljs-ana/meta node?) - (symbol (-> vr :name str)))))) + (when (-> vr meta node?) (symbol vr))) + :cljs (when-some [vr (cljs-ana/find-var @!a sym (get-ns env))] + ;; temporary hack + ;; the commented out expression should work, seems the new cljs analyzer loses the metadata + ;; so we check it on clj side, which is safe for a clj-server/cljs-client setup + (when-some [vr (cljs-ana/safe-requiring-resolve (-> vr ::cljs-ana/name))] + (when (-> vr meta node?) (symbol vr))) + #_(when (-> vr ::cljs-ana/meta node?) + (symbol (-> vr :name str)))))) (defn analyze-clj-symbol [sym ns$] (if (resolve-static-field sym) diff --git a/src/hyperfiddle/electric/shadow_cljs/hooks_de.clj b/src/hyperfiddle/electric/shadow_cljs/hooks_de.clj new file mode 100644 index 000000000..7db6ad8b4 --- /dev/null +++ b/src/hyperfiddle/electric/shadow_cljs/hooks_de.clj @@ -0,0 +1,24 @@ +(ns hyperfiddle.electric.shadow-cljs.hooks-de + (:require [clojure.string :as str] + [hyperfiddle.electric.impl.lang-de2 :as lang] + [hyperfiddle.electric.impl.cljs-analyzer :as cljs-ana])) + +(let [!first-run? (volatile! true)] ; first run is noop + (defn reload-clj + "When any Electric def is changed, recompile it in both Clojure and ClojureScript +(because the expression may contain e/client and/or e/server). Takes care to prevent +double reloads (i.e. from :require-macros)." + {:shadow.build/stage :compile-finish} [build-state] + (prn ::reload-hook) + (if @!first-run? + (vreset! !first-run? false) + (when (= :dev (:shadow.build/mode build-state)) + (let [compiled-keys (-> build-state :shadow.build/build-info :compiled) + cljc-infos (eduction (filter (fn [[_ f]] (str/ends-with? f ".cljc"))) + (map #(get (:sources build-state) %)) compiled-keys)] + (doseq [{ns-sym :ns, macro-requires :macro-requires} cljc-infos] + (when (and (not (get macro-requires ns-sym)) (-> ns-sym find-ns meta ::lang/has-edef?)) + (prn ::reloading ns-sym) + (swap! lang/!a cljs-ana/purge-ns ns-sym) + (require ns-sym :reload)))))) + build-state)) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 82c350b37..909aa10ca 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -115,6 +115,8 @@ Returns the successive states of items described by `incseq`. ctors (mapv #(lang/emit-ctor ts % env (-> nm ns-qualify keyword)) (lang/get-ordered-ctors-e ts)) deps (lang/emit-deps ts (lang/get-root-e ts)) nm3 (vary-meta nm2 assoc ::lang/deps `'~deps)] + (when-not (::lang/has-edef? (meta *ns*)) + (alter-meta! *ns* assoc ::lang/has-edef? true)) (when (::lang/print-source env) (fipp.edn/pprint ctors)) `(def ~nm3 ~ctors))) diff --git a/src/hyperfiddle/electric_dom3.cljc b/src/hyperfiddle/electric_dom3.cljc index 71fc46514..8accbde17 100644 --- a/src/hyperfiddle/electric_dom3.cljc +++ b/src/hyperfiddle/electric_dom3.cljc @@ -27,13 +27,15 @@ ;; Electric says :infer-warning Cannot infer target type in expression, fixme (goog.dom/setTextContent node str))) +#?(:cljs (defn ->text-node [] (goog.dom/createTextNode ""))) + #?(:cljs (defn text-node? [nd] (= (.-nodeType nd) (.-TEXT_NODE nd)))) #?(:cljs (defn ensure-not-in-text-node! [nd] (ca/is nd text-node? "Cannot nest dom/text or text nodes in other text nodes"))) (defmacro text [& strs] `(do (ensure-not-in-text-node! node) ~@(eduction (map (fn [str] - `(with (goog.dom/createTextNode "") + `(with (->text-node) (-googDomSetTextContentNoWarn node ~str)))) strs))) @@ -182,7 +184,8 @@ ($ Property node k# v#)) nil))) -(defmacro element {:style/indent 1} [t & body] `(with (goog.dom/createElement ~(name t)) ~@body)) +#?(:cljs (defn ->elem [t] (goog.dom/createElement t))) +(defmacro element {:style/indent 1} [t & body] `(with (->elem ~(name t)) ~@body)) (defmacro a {:style/indent 0} [& body] `(element :a ~@body)) (defmacro abbr {:style/indent 0} [& body] `(element :abbr ~@body)) From 357973bbee9b359bc963925674cafd6f09fe1b86 Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 19 Mar 2024 21:56:34 +0100 Subject: [PATCH 154/428] dom3: remove element on unmount --- src/hyperfiddle/electric_dom3.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/hyperfiddle/electric_dom3.cljc b/src/hyperfiddle/electric_dom3.cljc index 8accbde17..0876013fe 100644 --- a/src/hyperfiddle/electric_dom3.cljc +++ b/src/hyperfiddle/electric_dom3.cljc @@ -19,7 +19,7 @@ #?(:cljs (defn appending> [elem parent] (ca/is parent some? "DOM node parent cannot be nil. Maybe dom/node is unbound?") - (m/observe (fn [!] (.appendChild parent elem) (! elem) #(hide elem))))) + (m/observe (fn [!] (.appendChild parent elem) (! elem) #(.remove elem))))) (defmacro with [elem & body] `(binding [node (e/input (appending> ~elem node))] ~@body)) From 0a214acca01f05861d5113ac4cee110e0bcc7b27 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Wed, 20 Mar 2024 13:37:41 +0100 Subject: [PATCH 155/428] fix inconsistent tap request --- src/hyperfiddle/electric/impl/runtime_de.cljc | 361 +++++++++++------- src/hyperfiddle/electric_local_def_de.cljc | 4 +- test/hyperfiddle/electric_de_test.cljc | 15 +- 3 files changed, 240 insertions(+), 140 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index cdb06c6f0..7667c5253 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -4,7 +4,7 @@ [cognitect.transit :as t]) (:import missionary.Cancelled #?(:clj (clojure.lang IFn IDeref)) - #?(:clj (java.io ByteArrayInputStream ByteArrayOutputStream)))) + #?(:clj (java.io ByteArrayInputStream ByteArrayOutputStream Writer)))) #?(:clj (set! *warn-on-reflection* true)) @@ -42,7 +42,8 @@ (def port-slot-requested 4) (def port-slot-refcount 5) (def port-slot-process 6) -(def port-slots 7) +(def port-slot-state 7) +(def port-slots 8) (declare peer-cancel peer-transfer) @@ -363,29 +364,35 @@ T T T -> (EXPR T) (defn port-site [^objects port] (aget port port-slot-site)) -(declare port-slot port-attach port-detach) +(declare port-slot) -(deftype Remote [port step done ^:unsynchronized-mutable ^:mutable diff] +(deftype Remote [port step done] IFn (#?(:clj invoke :cljs -invoke) [_] - (port-detach port) - (if (nil? diff) - (step) (set! diff nil))) - (#?(:clj invoke :cljs -invoke) [_ value] - (if (nil? value) - (do (port-detach port) - (when (nil? diff) (done))) - (if-some [prev diff] - (set! diff (i/combine prev value)) - (do (set! diff value) (step))))) + (aset ^objects port port-slot-process nil) + (if (nil? (aget ^objects port port-slot-state)) + (step) (aset ^objects port port-slot-state nil))) IDeref (#?(:clj deref :cljs -deref) [this] - (if-some [value diff] - (do (set! diff nil) + (if-some [value (aget ^objects port port-slot-state)] + (do (aset ^objects port port-slot-state nil) (when-not (identical? this (port-process port)) (done)) value) (do (done) (throw (Cancelled. "Remote port cancelled.")))))) +(defn port-freeze [^objects port] + (aset port port-slot-process nil) + (when (nil? (aget port port-slot-state)) + (when-some [^Remote ps (aget port port-slot-process)] + ((.-done ps))))) + +(defn port-change [^objects port value] + (if-some [prev (aget port port-slot-state)] + (aset port port-slot-state (i/combine prev value)) + (do (aset port port-slot-state value) + (when-some [^Remote ps (aget port port-slot-process)] + ((.-step ps)))))) + (deftype Slot [^Frame frame id] #?(:clj Object) #?(:cljs IHash) @@ -412,14 +419,6 @@ T T T -> (EXPR T) [^objects port] (aget port port-slot-slot)) -(defn port-attach [^objects port ps] - (aset port port-slot-process ps) - (peer-push (frame-peer (.-frame (port-slot port))) peer-queue-tap port)) - -(defn port-detach [^objects port] - (aset port port-slot-process nil) - (peer-push (frame-peer (.-frame (port-slot port))) peer-queue-untap port)) - (defn slot-port {:tag 'objects} [^Slot slot] @@ -452,6 +451,7 @@ T T T -> (EXPR T) (.-result cdef) (nodes id))) (calls id)))] site (frame-site frame)) + local? (= site (.-site (frame-peer frame))) port (if (instance? Slot expr) (slot-port expr) (let [port (object-array port-slots)] @@ -460,24 +460,25 @@ T T T -> (EXPR T) (aset port port-slot-deps (deps expr site)) (aset port port-slot-flow (m/signal i/combine - (if (= site (.-site (frame-peer frame))) + (if local? (flow expr) (fn [step done] - (let [ps (->Remote port step done (i/empty-diff 0))] - (port-attach port ps) (step) ps))))) + (let [ps (->Remote port step done)] + (aset port port-slot-process ps) + (step) ps))))) (aset port port-slot-refcount (identity 0)) (aset port port-slot-requested (identity 0)) + (aset port port-slot-state (if local? false (i/empty-diff 0))) port))] (if (neg? id) (aset ^objects (.-nodes frame) (- -1 id) port) (aset ^objects (.-calls frame) id port)) nil)) -(defn make-frame [^Slot slot rank ctor] +(defn make-frame [^Slot slot rank site ctor] (let [cdef (ctor-cdef ctor) callc (count (.-calls cdef)) nodec (count (.-nodes cdef)) - frame (->Frame slot rank - (if (nil? slot) :client (port-site (slot-port slot))) ctor + frame (->Frame slot rank site ctor (int-array (inc callc)) (object-array callc) (object-array callc) (object-array (inc nodec)) nil)] (define-slot (->Slot frame (- -1 nodec)) ((.-build cdef) frame)) frame)) @@ -502,11 +503,11 @@ T T T -> (EXPR T) (aset port port-slot-process ((port-flow port) #(port-ready port) - #(do (aset port port-slot-process nil) + #(do (aset port port-slot-state true) (port-ready port))))) (defn disable [^objects port] - (when-some [ps (port-process port)] + (let [ps (port-process port)] (aset port port-slot-process nil) (ps))) @@ -552,53 +553,54 @@ T T T -> (EXPR T) ^objects toggle-queue (aget queues peer-queue-toggle) ^objects ready-queue (aget queues peer-queue-ready)] (if-some [^objects remote-port (aget tap-queue tap-pull)] - (let [prev (aget remote-port port-slot-requested)] - (aset tap-queue tap-pull nil) - (aset remote-port port-slot-requested (inc prev)) - (reduce-kv local-port-tap nil (port-deps remote-port)) - (recur (if (zero? (+ prev (aget remote-port port-slot-refcount))) - (conj toggle (port-slot remote-port)) toggle) change freeze - (rem (unchecked-inc-int tap-pull) - (alength tap-queue)) untap-pull toggle-pull change-pull)) + (do (aset tap-queue tap-pull nil) + (let [prev (aget remote-port port-slot-requested)] + (aset remote-port port-slot-requested (inc prev)) + (reduce-kv local-port-tap nil (port-deps remote-port)) + (recur (if (zero? (+ prev (aget remote-port port-slot-refcount))) + (conj toggle (port-slot remote-port)) toggle) change freeze + (rem (unchecked-inc-int tap-pull) + (alength tap-queue)) untap-pull toggle-pull change-pull))) (if-some [^objects remote-port (aget untap-queue untap-pull)] - (let [curr (dec (aget remote-port port-slot-requested))] - (aset untap-queue untap-pull nil) - (aset remote-port port-slot-requested curr) - (run! local-port-untap (port-deps remote-port)) - (recur (if (zero? (+ curr (aget remote-port port-slot-requested))) - (conj toggle (port-slot remote-port)) toggle) change freeze - tap-pull (rem (unchecked-inc-int untap-pull) - (alength untap-queue)) toggle-pull change-pull)) + (do (aset untap-queue untap-pull nil) + (let [curr (dec (aget remote-port port-slot-requested))] + (aset remote-port port-slot-requested curr) + (reduce-kv local-port-untap nil (port-deps remote-port)) + (recur (if (zero? (+ curr (aget remote-port port-slot-refcount))) + (conj toggle (port-slot remote-port)) toggle) change freeze + tap-pull (rem (unchecked-inc-int untap-pull) + (alength untap-queue)) toggle-pull change-pull))) (if-some [^objects local-port (aget toggle-queue toggle-pull)] - (let [deps (port-deps local-port)] - (aset toggle-queue toggle-pull nil) - (if (zero? (aget local-port port-slot-requested)) - (do (aset local-port port-slot-requested (identity 1)) - (run! remote-port-tap deps) - (when (zero? (aget local-port port-slot-refcount)) - (enable local-port))) - (do (aset local-port port-slot-requested (identity 0)) - (run! remote-port-untap deps) - (when (zero? (aget local-port port-slot-refcount)) - (disable local-port)))) + (do (aset toggle-queue toggle-pull nil) + (if (zero? (aget local-port port-slot-requested)) + (do (aset local-port port-slot-requested (identity 1)) + (reduce-kv remote-port-tap nil (port-deps local-port)) + (when (zero? (aget local-port port-slot-refcount)) + (enable local-port))) + (do (aset local-port port-slot-requested (identity 0)) + (reduce-kv remote-port-untap nil (port-deps local-port)) + (when (zero? (aget local-port port-slot-refcount)) + (disable local-port)))) (recur toggle change freeze tap-pull untap-pull (rem (unchecked-inc-int toggle-pull) (alength toggle-queue)) change-pull)) (if-some [^objects local-port (aget ready-queue change-pull)] - (let [slot (port-slot local-port)] - (aset ready-queue change-pull nil) - (if-some [ps (port-process local-port)] - (let [diff @ps] - (recur toggle (assoc change - slot (if-some [p (change slot)] - (i/combine p diff) diff)) - freeze tap-pull untap-pull toggle-pull - (rem (unchecked-inc-int change-pull) - (alength ready-queue)))) - (recur toggle change (conj freeze slot) - tap-pull untap-pull toggle-pull - (rem (unchecked-inc-int change-pull) - (alength ready-queue))))) + (do (aset ready-queue change-pull nil) + (if-some [ps (port-process local-port)] + (if (aget local-port port-slot-state) + (recur toggle change (conj freeze (port-slot local-port)) + tap-pull untap-pull toggle-pull + (rem (unchecked-inc-int change-pull) + (alength ready-queue))) + (let [diff @ps + slot (port-slot local-port)] + (recur toggle (assoc change + slot (if-some [p (change slot)] + (i/combine p diff) diff)) + freeze tap-pull untap-pull toggle-pull + (rem (unchecked-inc-int change-pull) + (alength ready-queue))))) + (recur toggle change freeze tap-pull untap-pull toggle-pull change-pull))) (let [acks (aget state peer-slot-output-acks)] (aset state peer-slot-output-acks (identity 0)) (aset state peer-slot-output-pending true) @@ -637,12 +639,10 @@ T T T -> (EXPR T) (peer-push peer peer-queue-toggle (slot-port slot)) peer) (defn peer-change [^Peer peer ^Slot slot diff] - (let [port (slot-port slot) - ps (port-process port)] - (ps diff)) peer) + (port-change (slot-port slot) diff) peer) (defn peer-freeze [^Peer peer ^Slot slot] - ((port-process (slot-port slot)) nil) peer) + (port-freeze (slot-port slot)) peer) (defn peer-input-ready [^Peer peer] (let [^objects state (.-state peer) @@ -694,25 +694,104 @@ T T T -> (EXPR T) [^Frame frame id expr] (define-slot (node frame id) expr)) +(defn port-attach [^Peer peer ^objects port n] + (dotimes [_ n] (peer-push peer peer-queue-tap port)) peer) + +(defn port-detach [^Peer peer ^objects port n] + (dotimes [_ n] (peer-push peer peer-queue-untap port)) peer) + +(defn frame-up [^Frame frame] + (let [^objects nodes (.-nodes frame) + result (aget nodes (dec (alength nodes))) + site (port-site (slot-port (.-slot frame)))] + (reduce-kv port-attach (frame-peer frame) + (deps (port-slot result) site)) + (port-flow result))) + +(defn frame-down [^Frame frame] + (let [^objects nodes (.-nodes frame) + result (aget nodes (dec (alength nodes))) + site (port-site (slot-port (.-slot frame)))] + (reduce-kv port-detach (frame-peer frame) + (deps (port-slot result) site)))) + +(defn apply-cycle [^objects buffer cycle] + (let [i (nth cycle 0) + x (aget buffer i) + j (loop [i i + k 1] + (let [j (nth cycle k) + y (aget buffer j) + k (unchecked-inc-int k)] + (aset buffer i y) + (if (< k (count cycle)) + (recur j k) j)))] + (aset buffer j x) buffer)) + +(def call-slot-slot 0) +(def call-slot-buffer 1) +(def call-slots 2) + +(defn call-transfer [^objects state {:keys [grow degree shrink permutation change freeze]}] + (let [^Slot slot (aget state call-slot-slot) + ^Frame parent (.-frame slot) + id (.-id slot) + ^ints ranks (.-ranks parent) + site (port-site (slot-port slot)) + size-after (- degree shrink) + ^objects buffer (let [^objects buffer (aget state call-slot-buffer) + cap (alength buffer)] + (if (< degree cap) + buffer (let [b (object-array (loop [cap cap] + (let [cap (bit-shift-left cap 1)] + (if (< degree cap) + cap (recur cap)))))] + #?(:clj (System/arraycopy buffer 0 b 0 cap) + :cljs (dotimes [i cap] (aset b i (aget buffer i)))) + (aset state call-slot-buffer b))))] + (reduce apply-cycle buffer (i/decompose permutation)) + (dotimes [i shrink] + (let [j (+ size-after i)] + (frame-down (aget buffer j)) + (aset buffer j nil))) + {:grow grow + :degree degree + :shrink shrink + :permutation permutation + :freeze freeze + :change (reduce-kv (fn [change i ctor] + (when-not (instance? Ctor ctor) + (throw (error (str "Not a constructor - " (pr-str ctor))))) + (when-not (identical? (frame-peer parent) (ctor-peer ctor)) + (throw (error "Can't call foreign constructor."))) + (when-some [frame (aget buffer i)] (frame-down frame)) + (let [rank (aget ranks id) + frame (make-frame slot rank site ctor)] + (aset buffer i frame) + (aset ranks id (inc rank)) + (assoc change i (frame-up frame)))) + {} change)})) + +(deftype Call [expr slot] + Expr + (deps [_ site] (deps expr site)) + (flow [_] + (fn [step done] + (let [state (doto (object-array call-slots) + (aset call-slot-slot slot) + (aset call-slot-buffer (object-array 1))) + ps ((flow expr) step done)] + (reify + IFn + (invoke [_] (ps)) + IDeref + (deref [_] (call-transfer state @ps))))))) + (defn define-call "Defines call site id for given frame." [^Frame frame id expr] (let [slot (call frame id)] - (define-slot slot - (reify Expr - (deps [_ site] (deps expr site)) - (flow [_] - (i/latest-product - (fn [ctor] - (when-not (instance? Ctor ctor) - (throw (error (str "Not a constructor - " (pr-str ctor))))) - (when-not (identical? (frame-peer frame) (ctor-peer ctor)) - (throw (error "Can't call foreign constructor."))) - (let [^ints ranks (.-ranks frame) - rank (aget ranks id)] - (aset ranks id (inc rank)) - (make-frame slot rank ctor))) - (flow expr))))))) + (define-slot slot (->Call expr slot)))) (defn define-free "Defines free variable id for given constructor." @@ -764,41 +843,41 @@ Returns a peer definition from given definitions and main key. (aset peer-queue-ready (object-array 1))) (int-array peer-queues) state) input (m/stream (m/observe events)) - root (->> args - (apply bind-args (->Ctor peer main 0 (object-array 0) {} nil)) - (make-frame nil 0))] + ^Frame root (->> args + (apply bind-args (->Ctor peer main 0 (object-array 0) {} nil)) + (make-frame nil 0 :client))] (aset state peer-slot-writer-opts {:default-handler (t/write-handler (fn [_] "unserializable") (fn [_] (comment TODO fetch port info))) - :handlers {Ctor (t/write-handler - (fn [_] "ctor") - (fn [^Ctor ctor] - (assert (identical? peer (.-peer ctor))) - (list* (.-key ctor) (.-idx ctor) (.-env ctor) (.-free ctor)))) - Slot (t/write-handler - (fn [_] "slot") - (fn [^Slot slot] - [(.-frame slot) (.-id slot)])) - Frame (t/write-handler - (fn [_] "frame") - (fn [^Frame frame] - [(frame-path frame) - (when-not (frame-shared? frame) - (frame-share frame) - (.-ctor frame))])) - Join (t/write-handler - (fn [_] "join") - (fn [^Join join] - (.-input join))) - Ap (t/write-handler - (fn [_] "ap") - (fn [^Ap ap] - (.-inputs ap))) - Pure (t/write-handler - (fn [_] "pure") - (fn [^Pure pure] - (.-values pure)))}}) + :handlers {Ctor (t/write-handler + (fn [_] "ctor") + (fn [^Ctor ctor] + (assert (identical? peer (.-peer ctor))) + (list* (.-key ctor) (.-idx ctor) (.-env ctor) (.-free ctor)))) + Slot (t/write-handler + (fn [_] "slot") + (fn [^Slot slot] + [(.-frame slot) (.-id slot)])) + Frame (t/write-handler + (fn [_] "frame") + (fn [^Frame frame] + [(frame-path frame) + (when-not (frame-shared? frame) + (frame-share frame) + (.-ctor frame))])) + Join (t/write-handler + (fn [_] "join") + (fn [^Join join] + (.-input join))) + Ap (t/write-handler + (fn [_] "ap") + (fn [^Ap ap] + (.-inputs ap))) + Pure (t/write-handler + (fn [_] "pure") + (fn [^Pure pure] + (.-values pure)))}}) (aset state peer-slot-reader-opts {:handlers {"ctor" (t/read-handler (fn [[key idx env & free]] @@ -812,7 +891,9 @@ Returns a peer definition from given definitions and main key. (peer-frame peer path) (let [[id rank] (peek path) parent (peer-frame peer (pop path)) - frame (make-frame (call parent id) rank ctor)] + slot (call parent id) + site (port-site (slot-port slot)) + frame (make-frame slot rank site ctor)] (frame-share frame) frame)))) "join" (t/read-handler (fn [input] @@ -833,17 +914,39 @@ Returns a peer definition from given definitions and main key. (input #(peer-input-ready peer) done)) (aset state peer-slot-root root) (when (= site :client) - (aset state peer-slot-result - ((m/reduce peer-result-diff peer - (m/signal i/combine root)) - peer-result-success pst))) + (let [^objects nodes (.-nodes root) + result (aget nodes (dec (alength nodes)))] + (reduce-kv port-attach peer (deps (port-slot result) site)) + (aset state peer-slot-result + ((m/reduce peer-result-diff peer (port-flow result)) + peer-result-success pst)))) (peer-input-ready peer) peer))) +#?(:clj + (defmethod print-method Slot [^Slot slot ^Writer w] + (.write w "#Slot[") + (print-method (.-frame slot) w) + (.write w " ") + (print-method (.-id slot) w) + (.write w "]"))) + +#?(:clj + (defmethod print-method Frame [^Frame frame ^Writer w] + (.write w "#Frame[") + (when-some [[x & xs] (seq (frame-path frame))] + (print-method x w) + (loop [xs xs] + (when-some [[x & xs] xs] + (.write w " ") + (print-method x w) + (recur xs)))) + (.write w "]"))) + ;; local only (defn root-frame [defs main] (->> (bind-args (->Ctor (->Peer :client defs nil nil nil nil nil) main 0 (object-array 0) {} nil)) - (make-frame nil 0) + (make-frame nil 0 :client) (m/signal i/combine))) #?(:clj diff --git a/src/hyperfiddle/electric_local_def_de.cljc b/src/hyperfiddle/electric_local_def_de.cljc index 158a5c06a..b0347ad21 100644 --- a/src/hyperfiddle/electric_local_def_de.cljc +++ b/src/hyperfiddle/electric_local_def_de.cljc @@ -70,8 +70,8 @@ (defn run-local [defs main] (m/reduce #(do %2) nil (let [s->c (m/dfv), c->s (m/dfv) - c (r/peer (fn [!] (s->c !) #()) :client defs main) - s (r/peer (fn [!] (c->s !) #()) :server defs main)] + c (m/stream (r/peer (fn [!] (s->c !) #()) :client defs main)) + s (m/stream (r/peer (fn [!] (c->s !) #()) :server defs main))] (m/ap (m/amb= (let [v (m/?> c)] ((m/? c->s) v)) (let [v (m/?> s)] ((m/? s->c) v))))))) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 3271f73fc..3d73f243b 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -1049,9 +1049,9 @@ (tests "fn destructuring" (with ((l/local {} (tap (e/client ((fn [{:keys [a] ::keys [b]}] [::client a b]) {:a 1 ::b 2}))) - (tap (e/server ((fn [{:keys [a] ::keys [b]}] [::server a b]) {:a 1 ::b 2})))) tap tap)) + (tap (e/server ((fn [{:keys [a] ::keys [b]}] [::server a b]) {:a 1 ::b 2})))) tap tap) % := [::client 1 2] - % := [::server 1 2]) + % := [::server 1 2])) ;; TODO try/catch (skip @@ -1129,19 +1129,16 @@ ) (def !x (atom true)) -(failing +(tests (reset! !x true) (with ((l/local {} (let [x (e/watch !x)] - (if (e/server x) ; to be consistent, client should see x first and switch - (e/server (tap x)) ; but test shows that the server sees x change before client + (if (e/server x) + (e/server (tap x)) (e/server x)))) tap tap) % := true (swap! !x not) - % := false #_ ::rcf/timeout) - ; we have to choose: consistency or less latency? - ; current behavior - Dustin likes, Leo does not like - ) + % := ::rcf/timeout)) ;; TODO transfer try/catch ;; https://www.notion.so/hyperfiddle/distribution-glitch-stale-local-cache-of-remote-value-should-be-invalidated-pending-47f5e425d6cf43fd9a37981c9d80d2af From 9ae94e73ebff3de275002240edb87790b6275352 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Wed, 20 Mar 2024 21:32:03 +0100 Subject: [PATCH 156/428] update missionary --- deps.edn | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/deps.edn b/deps.edn index 43ee6451e..32ff3b4a1 100644 --- a/deps.edn +++ b/deps.edn @@ -2,7 +2,7 @@ :deps {com.cognitect/transit-clj {:mvn/version "1.0.333"} com.cognitect/transit-cljs {:mvn/version "0.8.280"} com.hyperfiddle/rcf {:mvn/version "20220926-202227"} - missionary/missionary {:mvn/version "b.34"} + missionary/missionary {:mvn/version "b.35"} dom-top/dom-top {:mvn/version "1.0.9"} fipp/fipp {:mvn/version "0.6.26"} org.clojure/clojure {:mvn/version "1.12.0-alpha5"} From 67181e64a8ed5ac8d0edecd2e202cc3cbcc00cd1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Wed, 20 Mar 2024 21:41:53 +0100 Subject: [PATCH 157/428] fix runtime tests --- test/hyperfiddle/electric/impl/runtime_test.cljc | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/test/hyperfiddle/electric/impl/runtime_test.cljc b/test/hyperfiddle/electric/impl/runtime_test.cljc index 7bcfafa99..0728a63ee 100644 --- a/test/hyperfiddle/electric/impl/runtime_test.cljc +++ b/test/hyperfiddle/electric/impl/runtime_test.cljc @@ -170,9 +170,7 @@ (s->c @s-ps) % := :foo % := :step-c - (c->s @c-ps) - % := :step-s - (s->c @s-ps)) + (c->s @c-ps)) (tests (def peer (peers (rcf/tap (e/client (e/$ (e/server (e/fn [] :foo))))))) @@ -194,9 +192,7 @@ (s->c @s-ps) % := :foo % := :step-c - (c->s @c-ps) - % := :step-s - (s->c @s-ps)) + (c->s @c-ps)) (tests (def peer (peers (rcf/tap (e/client (e/$ (e/server (let [foo :foo] (e/fn [] foo)))))))) @@ -222,6 +218,4 @@ (s->c @s-ps) % := :foo % := :step-c - (c->s @c-ps) - % := :step-s - (s->c @s-ps)) \ No newline at end of file + (c->s @c-ps)) \ No newline at end of file From fe982db9500d4ccac8f3f8cd7c74809806459ea2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Wed, 20 Mar 2024 21:43:21 +0100 Subject: [PATCH 158/428] restore test - nested e/for with transfer --- test/hyperfiddle/electric_de_test.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 3d73f243b..66f8050ac 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -994,7 +994,7 @@ (def !state (atom [1])) (def state) -(failing +(tests (reset! !state [1]) "Nested e/for with transfer" (with ((l/local {} (binding [state (e/watch !state)] From f8ccbcc6e131dd193cb6fe3b7dfa833897eba8f2 Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 25 Mar 2024 10:21:20 +0100 Subject: [PATCH 159/428] node tests runner - allow passing args --- ci/run_tests_node.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ci/run_tests_node.sh b/ci/run_tests_node.sh index 4f176c43f..3d7c538f6 100755 --- a/ci/run_tests_node.sh +++ b/ci/run_tests_node.sh @@ -1,5 +1,5 @@ #!/bin/sh echo "Running NodeJS tests" -clojure -M:test:shadow-cljs compile :test --force-spawn \ +clojure -M:test:shadow-cljs compile :test --force-spawn "$@" \ && node out/node-tests.js From 2207c6356020ebd17c0f21217ed401175ac82137 Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 25 Mar 2024 10:26:24 +0100 Subject: [PATCH 160/428] tests cleanup --- test/hyperfiddle/electric_de_test.cljc | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 66f8050ac..76b07da4b 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -946,20 +946,23 @@ (def !t (atom true)) (tests + (reset! !t true) (with ((l/single {} (tap (let [t (e/watch !t)] (when t t (e/server t))))) tap tap) % := true (swap! !t not) % := nil)) +(def !state (atom true)) (tests - (def !state (atom true)) + (reset! !state true) (with ((l/single {} (when (e/watch !state) (tap :touch))) tap tap) % := :touch (reset! !state true) (tap ::nope) % := ::nope)) +(def !state (atom true)) (tests "e/for in a conditional" - (def !state (atom true)) + (reset! !state true) (with ((l/single {} (tap (if (e/watch !state) 1 (e/for-by identity [_ []])))) tap tap) % := 1 (swap! !state not) From e295d4f92e165ce3450b1e5566da7cfa3d7639ce Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 25 Mar 2024 10:26:35 +0100 Subject: [PATCH 161/428] compiler: ::lang/trace to trace interop calls --- src/hyperfiddle/electric/impl/lang_de2.clj | 5 ++++- src/hyperfiddle/electric/impl/runtime_de.cljc | 2 ++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 53750ab8f..1933ee55c 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -93,11 +93,14 @@ (declare -expand-all) +(defn traceable [f] (case (namespace f) ("hyperfiddle.electric.impl.runtime-de" "missionary.core" "hyperfiddle.incseq") false #_else true)) + (defn ?expand-macro [o env caller] (if (symbol? (first o)) (let [o2 (?meta o (expand-macro env o))] (if (identical? o o2) - (?meta o (list* (first o) (mapv (fn-> caller env) (rest o)))) + (?meta o (cond->> (?meta o (list* (first o) (mapv (fn-> caller env) (rest o)))) + (and (::trace env) (traceable (first o))) (list `r/tracing (list 'quote o)))) (caller o2 env))) (?meta o (list* (caller (first o) env) (mapv (fn-> caller env) (next o)))))) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 7667c5253..ba4bb2515 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -966,3 +966,5 @@ Returns a peer definition from given definitions and main key. gmap)) (defn cannot-resolve [& args] (throw (ex-info "definition called on a peer that doesn't support it" {:args args}))) + +(defn tracing [o dot] (prn '[o_o] o '=>> dot) dot) From 0881b3beab5947b4d79e2c76106052835a91c539 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Mon, 25 Mar 2024 16:32:38 +0100 Subject: [PATCH 162/428] fn - apply --- src/hyperfiddle/electric/impl/lang_de2.clj | 33 +++- src/hyperfiddle/electric/impl/runtime_de.cljc | 180 +++++++----------- src/hyperfiddle/electric_de.cljc | 108 ++++++----- src/hyperfiddle/electric_local_def_de.cljc | 12 +- test/hyperfiddle/electric_de_test.cljc | 4 +- 5 files changed, 160 insertions(+), 177 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 53750ab8f..1ec0841a9 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -102,10 +102,7 @@ (?meta o (list* (caller (first o) env) (mapv (fn-> caller env) (next o)))))) (defmacro $ [F & args] - (let [cnt (count args), gs (repeatedly cnt gensym)] - `(let* [~@(interleave gs args), F# ~F] - (binding [~@(interleave (range) gs), ::r/arity ~cnt, ::r/argv [~@gs], ::r/fn F#] - (::call F#))))) + `(::call (r/dispatch ~F ~@(map (fn [arg] `(::pure ~arg)) args)))) (defn -expand-all [o env] (cond @@ -138,9 +135,8 @@ [(conj bs sym (-expand-all v env)) (add-local env sym)]) [[] env] (partition-all 2 bs))] - (recur (?meta o `(binding [::r/fn (::ctor (let* [~@(interleave (take-nth 2 bs2) (map #(list ::lookup %) (range)))] ~@body))] - (binding [~@(interleave (range) (take-nth 2 (next bs2)))] - (::call (::lookup ::r/fn))))) + (recur (?meta o `(binding [::r/fn (hyperfiddle.electric-de/fn [~@(take-nth 2 bs2)] ~@body)] + ($ (::lookup ::r/fn) ~@(take-nth 2 (next bs2))))) env2)) (recur) (recur (?meta o `($ (::lookup ::r/fn) ~@(next o))) env) @@ -675,12 +671,12 @@ ::var (let [in (::resolved-in nd)] (list* `r/lookup 'frame (keyword (::qualified-var nd)) (when (or (nil? in) (= in (->env-type env))) [(list `r/pure (::qualified-var nd))]))) - ::node (list `r/lookup 'frame (keyword (::node nd)) (list `r/pure (list `r/make-ctor 'frame (keyword (::node nd)) 0))) + ::node (list `r/lookup 'frame (keyword (::node nd)) (list `r/pure (list `r/resolve 'frame (keyword (::node nd))))) ::join (list `r/join (rec (get-child-e ts e))) ::pure (list `r/pure (rec (get-child-e ts e))) ::comp (list 'fn* '[] (doall (map rec (get-children-e ts e)))) ::site (recur (get-child-e ts e)) - ::ctor (list* `r/make-ctor 'frame nm (::ctor-idx nd) + ::ctor (list* `r/ctor nm (::ctor-idx nd) (mapv (fn [e] (let [nd (ts/->node ts e)] (case (::closed-over nd) @@ -783,6 +779,17 @@ es (ts/find (mark ts e) ::node-used true)] (into (sorted-set) (map #(::node (ts/->node ts %))) es))) +(defn emit-fn [ts e nm] + ((fn rec [e] + (let [nd (get (:eav ts) e)] + (case (::type nd) + ::ap (map rec (get-children-e ts e)) + ::pure (rec (get-child-e ts e)) + ::comp `(fn [] ~(map rec (get-children-e ts e))) + ::literal (::v nd) + ::ctor `(r/ctor ~nm ~(::ctor-idx nd)) + ::mklocal (recur (get-ret-e ts (get-child-e ts e)))))) e)) + (defn get-deps [sym] (-> sym resolve meta ::deps)) (defn delete-point-recursively [ts e] @@ -960,7 +967,13 @@ (defn compile* [nm env ts] (let [ts (analyze-electric env ts) - ret (->> (get-ordered-ctors-e ts) (mapv #(emit-ctor ts % env nm)))] + ret `(fn + ([] {0 (r/ctor ~nm 0)}) + ([idx#] + (case idx# + ~@(->> (get-ordered-ctors-e ts) + (map #(emit-ctor ts % env nm)) + (interleave (range))))))] (when (::print-source env) (fipp.edn/pprint ret)) ret)) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 7667c5253..839134a8a 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -1,4 +1,5 @@ (ns hyperfiddle.electric.impl.runtime-de + (:refer-clojure :exclude [resolve]) (:require [hyperfiddle.incseq :as i] [missionary.core :as m] [cognitect.transit :as t]) @@ -211,63 +212,46 @@ T T T -> (EXPR T) (declare slot-port) -(deftype Ctor [peer key idx ^objects free env - ^:unsynchronized-mutable ^:mutable hash-memo] - #?(:clj Object) - #?(:cljs IHash) - (#?(:clj hashCode :cljs -hash) [_] - (if-some [h hash-memo] - h (loop [h (-> (hash peer) - (hash-combine (hash key)) - (hash-combine (hash idx)) - (hash-combine (hash env))) - i 0] - (if (== i (alength free)) - (set! hash-memo h) - (recur (hash-combine h (hash (slot-port (aget free i)))) - (inc i)))))) - #?(:cljs IEquiv) - (#?(:clj equals :cljs -equiv) [_ other] - (and (instance? Ctor other) - (= peer (.-peer ^Ctor other)) - (= key (.-key ^Ctor other)) - (= idx (.-idx ^Ctor other)) - (= env (.-env ^Ctor other)) - (let [n (alength free) - ^objects f (.-free ^Ctor other)] - (if (== n (alength f)) - (loop [i 0] - (if (== i n) - true (if (= (slot-port (aget free i)) (slot-port (aget f i))) - (recur (inc i)) false))) false))))) - (defn bind " (CTOR T) -> (CTOR T) (CTOR T) (VAR A) (EXPR A) -> (CTOR T) (CTOR T) (VAR A) (EXPR A) (VAR B) (EXPR B) -> (CTOR T) (CTOR T) (VAR A) (EXPR A) (VAR B) (EXPR B) (VAR C) (EXPR C) -> (CTOR T) -" ([^Ctor ctor] ctor) - ([^Ctor ctor k v] - (->Ctor (.-peer ctor) (.-key ctor) (.-idx ctor) (.-free ctor) - (assoc (.-env ctor) k v) nil)) - ([^Ctor ctor k v & kvs] - (->Ctor (.-peer ctor) (.-key ctor) (.-idx ctor) (.-free ctor) - (apply assoc (.-env ctor) k v kvs) nil))) - -(defn bind-args [^Ctor ctor & args] +" ([ctor] ctor) + ([[key idx free env] k v] + [key idx free (assoc env k v)]) + ([[key idx free env] k v & kvs] + [key idx free (apply assoc env k v kvs)])) + +(defn bind-args [ctor & args] (reduce (partial apply bind) ctor (eduction (map-indexed vector) args))) -(defn ctor-peer - "Returns the peer of given constructor." - {:tag Peer} - [^Ctor ctor] - (.-peer ctor)) +(defn arity-mismatch [arity] + (throw (Error. (str "Wrong number of args (" arity ")")))) + +(defn get-variadic [F arity] + (if-some [[fixed ctor] (F -1)] + (if (< arity fixed) + (arity-mismatch arity) + [fixed ctor]) + (arity-mismatch arity))) + +(defn dispatch [F & args] + (let [arity (count args)] + (if-some [ctor (F arity)] + (reduce (partial apply bind) ctor (eduction (map-indexed vector) args)) + (let [[fixed ctor] (get-variadic F arity)] + (bind (reduce (partial apply bind) ctor (eduction (take fixed) (map-indexed vector) args)) + -1 (effect (apply i/latest-product (comp seq list) (drop fixed args)))))))) -(defn ctor-cdef +(defn peer-root [^Peer peer key] + ((.-defs peer) key)) + +(defn peer-cdef "Returns the cdef of given constructor." {:tag Cdef} - [^Ctor ctor] - (((.-defs (ctor-peer ctor)) (.-key ctor)) (.-idx ctor))) + [^Peer peer key idx] + ((peer-root peer key) idx)) (defn port-flow [^objects port] (aget port port-slot-flow)) @@ -275,7 +259,7 @@ T T T -> (EXPR T) (defn port-deps [^objects port] (aget port port-slot-deps)) -(deftype Frame [slot rank site ctor +(deftype Frame [peer slot rank site ctor ^ints ranks ^objects children ^objects calls ^objects nodes ^:unsynchronized-mutable ^:mutable hash-memo] @@ -283,10 +267,14 @@ T T T -> (EXPR T) #?(:cljs IHash) (#?(:clj hashCode :cljs -hash) [_] (if-some [h hash-memo] - h (set! hash-memo (hash-combine (hash slot) (hash rank))))) + h (set! hash-memo (-> (hash Frame) + (hash-combine (hash peer)) + (hash-combine (hash slot)) + (hash-combine (hash rank)))))) #?(:cljs IEquiv) (#?(:clj equals :cljs -equiv) [_ other] (and (instance? Frame other) + (= peer (.-peer ^Frame other)) (= slot (.-slot ^Frame other)) (= rank (.-rank ^Frame other)))) IFn @@ -295,7 +283,6 @@ T T T -> (EXPR T) (defn frame-ctor "Returns the constructor of given frame." - {:tag Ctor} [^Frame frame] (.-ctor frame)) @@ -303,13 +290,19 @@ T T T -> (EXPR T) "Returns the peer of given frame." {:tag Peer} [^Frame frame] - (ctor-peer (frame-ctor frame))) + (.-peer frame)) (defn frame-cdef "Returns the cdef of given frame." {:tag Cdef} [^Frame frame] - (ctor-cdef (frame-ctor frame))) + (let [[key idx _ _] (frame-ctor frame)] + (peer-cdef (.-peer frame) key idx))) + +(defn resolve + "Returns the root binding of electric var matching given keyword." + [^Frame frame key] + ((peer-root (.-peer frame) key))) (defn frame-call-count "Returns the call count of given frame." @@ -442,7 +435,7 @@ T T T -> (EXPR T) (defn define-slot [^Slot slot expr] (let [^Frame frame (.-frame slot) id (.-id slot) - site (if-some [site (let [cdef (ctor-cdef (frame-ctor frame)) + site (if-some [site (let [cdef (frame-cdef frame) nodes (.-nodes cdef) calls (.-calls cdef)] (if (neg? id) @@ -474,11 +467,12 @@ T T T -> (EXPR T) (aset ^objects (.-nodes frame) (- -1 id) port) (aset ^objects (.-calls frame) id port)) nil)) -(defn make-frame [^Slot slot rank site ctor] - (let [cdef (ctor-cdef ctor) +(defn make-frame [^Peer peer ^Slot slot rank site ctor] + (let [[key idx _ _] ctor + cdef (peer-cdef peer key idx) callc (count (.-calls cdef)) nodec (count (.-nodes cdef)) - frame (->Frame slot rank site ctor + frame (->Frame peer slot rank site ctor (int-array (inc callc)) (object-array callc) (object-array callc) (object-array (inc nodec)) nil)] (define-slot (->Slot frame (- -1 nodec)) ((.-build cdef) frame)) frame)) @@ -735,6 +729,7 @@ T T T -> (EXPR T) (defn call-transfer [^objects state {:keys [grow degree shrink permutation change freeze]}] (let [^Slot slot (aget state call-slot-slot) ^Frame parent (.-frame slot) + ^Peer peer (.-peer parent) id (.-id slot) ^ints ranks (.-ranks parent) site (port-site (slot-port slot)) @@ -760,13 +755,9 @@ T T T -> (EXPR T) :permutation permutation :freeze freeze :change (reduce-kv (fn [change i ctor] - (when-not (instance? Ctor ctor) - (throw (error (str "Not a constructor - " (pr-str ctor))))) - (when-not (identical? (frame-peer parent) (ctor-peer ctor)) - (throw (error "Can't call foreign constructor."))) (when-some [frame (aget buffer i)] (frame-down frame)) (let [rank (aget ranks id) - frame (make-frame slot rank site ctor)] + frame (make-frame peer slot rank site ctor)] (aset buffer i frame) (aset ranks id (inc rank)) (assoc change i (frame-up frame)))) @@ -793,14 +784,6 @@ T T T -> (EXPR T) (let [slot (call frame id)] (define-slot slot (->Call expr slot)))) -(defn define-free - "Defines free variable id for given constructor." - [^Ctor ctor id ^Slot slot] - (let [^objects free (.-free ctor)] - (when-not (nil? (aget free id)) - (throw (error "Can't redefine free variable."))) - (aset free id slot) nil)) - (defn lookup "Returns the value associated with given key in the dynamic environment of given frame." {:tag Expr} @@ -808,27 +791,21 @@ T T T -> (EXPR T) (lookup frame key (->Unbound key))) ([^Frame frame key nf] (loop [frame frame] - (if-some [s ((.-env (frame-ctor frame)) key)] - s (if-some [^Slot slot (.-slot frame)] - (recur (.-frame slot)) nf))))) - -(defn make-ctor - "Returns a fresh constructor for cdef coordinates key and idx." - {:tag Ctor} - [^Frame frame key idx & frees] - (let [^Peer peer (frame-peer frame) - ^Cdef cdef (((.-defs peer) key) idx) - ctor (->Ctor peer key idx (object-array (.-frees cdef)) {} nil)] - (run! (partial apply define-free ctor) - (eduction (map-indexed vector) frees)) - ctor)) + (let [[_ _ _ env] (frame-ctor frame)] + (if-some [s (env key)] + s (if-some [^Slot slot (.-slot frame)] + (recur (.-frame slot)) nf)))))) + +(defn ctor + "Returns the constructor for cdef coordinates key and idx, with given free variables." + [key idx & frees] [key idx (vec frees) {}]) (defn free "Returns the free variable id for given frame." {:tag Slot} [^Frame frame id] - (let [^objects free (.-free (frame-ctor frame))] - (aget free id))) + (let [[_ _ free _] (frame-ctor frame)] + (free id))) (defn peer " Returns a peer definition from given definitions and main key. @@ -844,18 +821,14 @@ Returns a peer definition from given definitions and main key. (int-array peer-queues) state) input (m/stream (m/observe events)) ^Frame root (->> args - (apply bind-args (->Ctor peer main 0 (object-array 0) {} nil)) - (make-frame nil 0 :client))] + (eduction (map pure)) + (apply dispatch ((defs main))) + (make-frame peer nil 0 :client))] (aset state peer-slot-writer-opts {:default-handler (t/write-handler (fn [_] "unserializable") (fn [_] (comment TODO fetch port info))) - :handlers {Ctor (t/write-handler - (fn [_] "ctor") - (fn [^Ctor ctor] - (assert (identical? peer (.-peer ctor))) - (list* (.-key ctor) (.-idx ctor) (.-env ctor) (.-free ctor)))) - Slot (t/write-handler + :handlers {Slot (t/write-handler (fn [_] "slot") (fn [^Slot slot] [(.-frame slot) (.-id slot)])) @@ -879,10 +852,7 @@ Returns a peer definition from given definitions and main key. (fn [^Pure pure] (.-values pure)))}}) (aset state peer-slot-reader-opts - {:handlers {"ctor" (t/read-handler - (fn [[key idx env & free]] - (->Ctor peer key idx (object-array free) env nil))) - "slot" (t/read-handler + {:handlers {"slot" (t/read-handler (fn [[frame id]] (->Slot frame id))) "frame" (t/read-handler @@ -893,7 +863,7 @@ Returns a peer definition from given definitions and main key. parent (peer-frame peer (pop path)) slot (call parent id) site (port-site (slot-port slot)) - frame (make-frame slot rank site ctor)] + frame (make-frame peer slot rank site ctor)] (frame-share frame) frame)))) "join" (t/read-handler (fn [input] @@ -944,20 +914,10 @@ Returns a peer definition from given definitions and main key. ;; local only (defn root-frame [defs main] - (->> (bind-args (->Ctor (->Peer :client defs nil nil nil nil nil) - main 0 (object-array 0) {} nil)) - (make-frame nil 0 :client) + (->> (dispatch ((defs main))) + (make-frame (->Peer :client defs nil nil nil nil nil) nil 0 :client) (m/signal i/combine))) -#?(:clj - (def arg-sym - (map (comp symbol - (partial intern *ns*) - (fn [i] - (with-meta (symbol (str "%" i)) - {::type ::node}))) - (range)))) - (defn get-destructure-map [gmap] (if (seq? gmap) (if (next gmap) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 909aa10ca..5f4757880 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -39,12 +39,6 @@ Syntax : Returns the successive states of items described by `incseq`. " [flow] `(::lang/join ~flow)) -(defmacro fn* [bs & body] - `(check-electric fn* - (ctor - (let [~@(interleave bs (->pos-args (count bs)))] - ~@body)))) - #?(:clj (cc/defn- varargs? [args] (boolean (and (seq args) (= '& (-> args pop peek)))))) #?(:clj (cc/defn- ?bind-self [code ?name] (cond->> code ?name (list 'let* [?name `(::lang/lookup ::r/fn)])))) @@ -80,23 +74,19 @@ Returns the successive states of items described by `incseq`. arities (cond-> args2 (vector? (first args2)) list) {positionals false, varargs true} (group-by (comp varargs? first) arities) _ (check-only-one-vararg! ?name (mapv first varargs)) - _ (check-arity-conflicts! ?name (mapv first positionals) (ffirst varargs)) - [?vararg npos map-vararg?] (when-some [va (first varargs)] - (let [[args & body] va - npos (-> args count (- 2)) - unvarargd (-> args pop pop (conj (peek args)))] - `[(hyperfiddle.electric-de/fn* ~unvarargd ~@body) ~npos ~(map? (peek args))])) - dispatch-map (into {} (map (cc/fn [[args :as fargs]] [(count args) `(hyperfiddle.electric-de/fn* ~@fargs)])) - positionals)] + _ (check-arity-conflicts! ?name (mapv first positionals) (ffirst varargs))] + ;; TODO map varargs `(check-electric fn - (ctor - ~(-> (if ?vararg - (let [code `(binding [~npos (-prep-varargs ~npos (::lang/lookup ::r/argv) ~map-vararg?)] (::lang/call ~?vararg))] - (if (seq positionals) - `(if-some [F# (~dispatch-map (::lang/lookup ::r/arity))] (::lang/call F#) ~code) - code)) - `(::lang/call (~dispatch-map (::lang/lookup ::r/arity)))) - (?bind-self ?name)))))) + ~(into (if-some [[args & body] (first varargs)] + {-1 [(-> args count (- 2)) + `(::lang/ctor + (let [~@(interleave (-> args pop pop) (map dget (range))) + ~(peek args) (dget -1)] ~@body))]} {}) + (map (cc/fn [[args & body]] + [(count args) + `(::lang/ctor + (let [~@(interleave args (map dget (range)))] + ~@body))])) positionals)))) (cc/defn ns-qualify [sym] (if (namespace sym) sym (symbol (str *ns*) (str sym)))) @@ -112,13 +102,16 @@ Returns the successive states of items described by `incseq`. _ (when (::lang/print-expansion env) (fipp.edn/pprint expanded)) ts (lang/analyze expanded '_ env (lang/->ts)) ts (lang/analyze-electric env ts) - ctors (mapv #(lang/emit-ctor ts % env (-> nm ns-qualify keyword)) (lang/get-ordered-ctors-e ts)) + k (-> nm ns-qualify keyword) + ctors (mapv #(lang/emit-ctor ts % env k) (lang/get-ordered-ctors-e ts)) + source `(cc/fn ([] ~(lang/emit-fn ts (lang/get-root-e ts) k)) + ([idx#] (case idx# ~@(interleave (range) ctors)))) deps (lang/emit-deps ts (lang/get-root-e ts)) nm3 (vary-meta nm2 assoc ::lang/deps `'~deps)] (when-not (::lang/has-edef? (meta *ns*)) (alter-meta! *ns* assoc ::lang/has-edef? true)) - (when (::lang/print-source env) (fipp.edn/pprint ctors)) - `(def ~nm3 ~ctors))) + (when (::lang/print-source env) (fipp.edn/pprint source)) + `(def ~nm3 ~source))) (defmacro amb " Syntax : @@ -218,32 +211,45 @@ this tuple. Returns the concatenation of all body results as a single vector. (reduce (cc/fn [ac [nm & fargs]] `(::lang/bindlocal ~nm (hyperfiddle.electric-de/fn ~@fargs) ~ac)) (cons 'do body) sb) sb))) -(cc/defn- -splicev [args] (into [] cat [(pop args) (peek args)])) -(hyperfiddle.electric-de/defn Apply* [F args] - (let [s (-splicev args)] - (case (count s) - 0 ($ F) - 1 ($ F (nth s 0)) - 2 ($ F (nth s 0) (nth s 1)) - 3 ($ F (nth s 0) (nth s 1) (nth s 2)) - 4 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3)) - 5 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4)) - 6 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5)) - 7 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6)) - 8 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6) (nth s 7)) - 9 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6) (nth s 7) (nth s 8)) - 10 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6) (nth s 7) (nth s 8) (nth s 9)) - 11 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6) (nth s 7) (nth s 8) (nth s 9) (nth s 10)) - 12 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6) (nth s 7) (nth s 8) (nth s 9) (nth s 10) (nth s 11)) - 13 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6) (nth s 7) (nth s 8) (nth s 9) (nth s 10) (nth s 11) (nth s 12)) - 14 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6) (nth s 7) (nth s 8) (nth s 9) (nth s 10) (nth s 11) (nth s 12) (nth s 13)) - 15 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6) (nth s 7) (nth s 8) (nth s 9) (nth s 10) (nth s 11) (nth s 12) (nth s 13) (nth s 14)) - 16 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6) (nth s 7) (nth s 8) (nth s 9) (nth s 10) (nth s 11) (nth s 12) (nth s 13) (nth s 14) (nth s 15)) - 17 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6) (nth s 7) (nth s 8) (nth s 9) (nth s 10) (nth s 11) (nth s 12) (nth s 13) (nth s 14) (nth s 15) (nth s 16)) - 18 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6) (nth s 7) (nth s 8) (nth s 9) (nth s 10) (nth s 11) (nth s 12) (nth s 13) (nth s 14) (nth s 15) (nth s 16) (nth s 17)) - 19 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6) (nth s 7) (nth s 8) (nth s 9) (nth s 10) (nth s 11) (nth s 12) (nth s 13) (nth s 14) (nth s 15) (nth s 16) (nth s 17) (nth s 18)) - 20 ($ F (nth s 0) (nth s 1) (nth s 2) (nth s 3) (nth s 4) (nth s 5) (nth s 6) (nth s 7) (nth s 8) (nth s 9) (nth s 10) (nth s 11) (nth s 12) (nth s 13) (nth s 14) (nth s 15) (nth s 16) (nth s 17) (nth s 18) (nth s 19))))) -(defmacro apply [F & args] `($ Apply* ~F [~@args])) +(hyperfiddle.electric-de/defn Dispatch [F offset args] + (let [arity (+ offset (count args))] + (if-some [ctor (F arity)] + (loop [offset offset + args args + ctor ctor] + (if (< offset arity) + (recur (inc offset) (next args) + (r/bind ctor offset (::lang/pure (first args)))) + ctor)) + (let [[fixed ctor] (r/get-variadic F arity)] + (loop [offset offset + args args + ctor ctor] + (if (< offset fixed) + (recur (inc offset) (next args) + (r/bind ctor offset (::lang/pure (first args)))) + (r/bind ctor -1 (::lang/pure args)))))))) + +(hyperfiddle.electric-de/defn Apply + ([F a] + (::lang/call + (r/bind-args ($ Dispatch F 0 a)))) + ([F a b] + (::lang/call + (r/bind-args ($ Dispatch F 1 b) + (::lang/pure a)))) + ([F a b c] + (::lang/call + (r/bind-args ($ Dispatch F 2 c) + (::lang/pure a) (::lang/pure b)))) + ([F a b c d] + (::lang/call + (r/bind-args ($ Dispatch F 3 d) + (::lang/pure a) (::lang/pure b) (::lang/pure c)))) + ([F a b c d & es] + (::lang/call + (r/bind-args ($ Dispatch F (+ 4 (count es)) (concat (butlast es) (last es))) + (::lang/pure a) (::lang/pure b) (::lang/pure c) (::lang/pure d))))) (cc/defn on-unmount* [f] (m/observe (cc/fn [!] (! nil) f))) diff --git a/src/hyperfiddle/electric_local_def_de.cljc b/src/hyperfiddle/electric_local_def_de.cljc index b0347ad21..30b385773 100644 --- a/src/hyperfiddle/electric_local_def_de.cljc +++ b/src/hyperfiddle/electric_local_def_de.cljc @@ -58,12 +58,14 @@ _ (when (::lang/print-analysis env) (run! prn (->> ts :eav vals (sort-by :db/id)))) ts (lang/analyze-electric env ts) ctors (mapv #(lang/emit-ctor ts % env ::Main) (lang/get-ordered-ctors-e ts)) + source `(cc/fn ([] {0 ~(lang/emit-fn ts (lang/get-root-e ts) ::Main)}) + ([idx#] (case idx# ~@(interleave (range) ctors)))) ret-e (lang/get-ret-e ts (lang/get-child-e ts 0)) deps (lang/emit-deps ts ret-e) deps (collect-deps deps) defs (into {} (map (fn [dep] [(keyword dep) dep])) deps) - defs (assoc defs ::Main ctors)] - (when (::lang/print-source env) (fipp.edn/pprint ctors)) + defs (assoc defs ::Main source)] + (when (::lang/print-source env) (fipp.edn/pprint source)) (when (::lang/print-defs env) (fipp.edn/pprint defs)) `(run-single (r/root-frame ~defs ::Main))))) @@ -85,11 +87,13 @@ _ (when (::lang/print-analysis env) (run! prn (->> ts :eav vals (sort-by :db/id)))) ts (lang/analyze-electric env ts) ctors (mapv #(lang/emit-ctor ts % env ::Main) (lang/get-ordered-ctors-e ts)) + source `(cc/fn ([] {0 ~(lang/emit-fn ts (lang/get-root-e ts) ::Main)}) + ([idx#] (case idx# ~@(interleave (range) ctors)))) ret-e (lang/get-ret-e ts (lang/get-child-e ts 0)) deps (lang/emit-deps ts ret-e) deps (collect-deps deps) defs (into {} (map (fn [dep] [(keyword dep) dep])) deps) - defs (assoc defs ::Main ctors)] - (when (::lang/print-source env) (fipp.edn/pprint ctors)) + defs (assoc defs ::Main source)] + (when (::lang/print-source env) (fipp.edn/pprint source)) (when (::lang/print-defs env) (fipp.edn/pprint defs)) `(run-local ~defs ::Main))) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 66f8050ac..8aeb54b1c 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -27,8 +27,8 @@ #_`(try (do ~@body) (catch ~(if (:js-globals &env) :default 'Throwable) e# (prn e#)))) (tests "call on local electric ctor" - (with ((l/single {} (let [x (e/ctor 1)] (tap ($ x)))) tap tap) - % := 1)) + (with ((l/single {} (let [x (e/fn [] 1)] (tap ($ x)))) tap tap) + % := 1)) (defrecord Point [x y]) (tests "new on class" From 41f8392d4d715072b4e892084bc525948adb199d Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 25 Mar 2024 16:52:40 +0100 Subject: [PATCH 163/428] fix tests --- test/hyperfiddle/electric_de_test.cljc | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 76b07da4b..f0404fe9b 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -2159,15 +2159,15 @@ % := 1)) (tests "()" - (with ((l/single {}+ {} (tap ())) tap tap) + (with ((l/single {} (tap ())) tap tap) % := ())) (tests "(#())" - (with ((l/single {}+ {} (tap (#()))) tap tap) + (with ((l/single {} (tap (#()))) tap tap) % := ())) (tests "((fn []))" - (with ((l/single {}+ {} (tap ((fn [])))) tap tap) + (with ((l/single {} (tap ((fn [])))) tap tap) % := nil)) (tests "binding in interop fn" From 78a197a8975efa5a53c87a2201d2329f01e83d7f Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 25 Mar 2024 21:59:53 +0100 Subject: [PATCH 164/428] compiler: fix mark calls after e/fn impl change --- src/hyperfiddle/electric/impl/lang_de2.clj | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 1ec0841a9..3180487ff 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -945,11 +945,10 @@ (let [nd (ts/->node ts e)] (vswap! seen conj e) (case (::type nd) - (::literal ::var ::lookup ::node) ts + (::literal ::var ::lookup ::node ::ctor) ts (::ap ::comp) (reduce #(mark-used-calls % ctor-e %2) ts (get-children-e ts e)) (::site ::join ::pure ::mklocal) (recur ts ctor-e (get-child-e ts e)) (::bindlocal) (recur ts ctor-e (->bindlocal-body-e ts e)) - (::ctor) (recur ts e (get-child-e ts e)) (::call) (if (::call-idx nd) ts (-> (mark-used-calls ts ctor-e (get-child-e ts e)) @@ -959,9 +958,11 @@ (::localref) (let [nx-e (->> (::ref nd) (->localv-e ts) (get-ret-e ts))] (recur ts (find-ctor-e ts nx-e) nx-e)) #_else (throw (ex-info (str "cannot mark-used-calls on " (::type nd)) (or nd {}))))))) - ts (-> ts (mark-used-calls (get-root-e ts) (get-ret-e ts (get-child-e ts (get-root-e ts)))) - reroute-local-aliases (handle-let-refs (get-root-e ts)) inline-nodes order-nodes order-frees - collapse-ap-with-only-pures)] + mark-used-calls2 (fn [ts] + (reduce (fn [ts ctor-e] (mark-used-calls ts ctor-e (get-ret-e ts (get-child-e ts ctor-e)))) + ts (->> ts :ave ::ctor-idx vals (reduce into)))) + ts (-> ts mark-used-calls2 reroute-local-aliases (handle-let-refs (get-root-e ts)) + inline-nodes order-nodes order-frees collapse-ap-with-only-pures)] (when (::print-db env) (run! prn (ts->reducible ts))) ts)) From 0c95d7fbe710acbb0a6a5fd1a6d6fa7fe12e0d9d Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 26 Mar 2024 09:01:53 +0100 Subject: [PATCH 165/428] e/fn* -> e/fn --- src/hyperfiddle/electric_de.cljc | 2 +- test/hyperfiddle/electric_de_test.cljc | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 5f4757880..8d2bac400 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -172,7 +172,7 @@ For each tuple in the cartesian product of `table1 table2 ,,, tableN`, calls bod [] `(do ~@body) (let [[args exprs] (cc/apply map vector (partition-all 2 bindings))] `(::lang/call - (r/bind-args (hyperfiddle.electric-de/fn* ~args ~@body) + (r/bind-args (hyperfiddle.electric-de/fn ~args ~@body) ~@(map (clojure.core/fn [expr] `(r/effect (r/fixed-signals (join (i/items (pure ~expr)))))) exprs)))))) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 8aeb54b1c..1536981f9 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -586,7 +586,7 @@ % := ::outer)) (tests "lazy parameters. Flows are not run unless sampled" - (with ((l/single {} [($ (e/fn* [_]) (tap :not)) (tap :boom)]) tap tap) + (with ((l/single {} [($ (e/fn [_]) (tap :not)) (tap :boom)]) tap tap) % := :boom)) (tests "lazy parameters. Flows are not run unless sampled" From a63396283c4debde7709ee6af46e4368d217c77c Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 26 Mar 2024 09:06:59 +0100 Subject: [PATCH 166/428] fix e/cursor impl --- src/hyperfiddle/electric_de.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 8d2bac400..0552b7e47 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -172,7 +172,7 @@ For each tuple in the cartesian product of `table1 table2 ,,, tableN`, calls bod [] `(do ~@body) (let [[args exprs] (cc/apply map vector (partition-all 2 bindings))] `(::lang/call - (r/bind-args (hyperfiddle.electric-de/fn ~args ~@body) + (r/bind-args (ctor (let [~@(interleave args (->pos-args (count args)))] ~@body)) ~@(map (clojure.core/fn [expr] `(r/effect (r/fixed-signals (join (i/items (pure ~expr)))))) exprs)))))) From 95b126a72fa0915d25ce2c218c194634f5e858ac Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 26 Mar 2024 13:36:59 +0100 Subject: [PATCH 167/428] fix binding and calls double eval --- src/hyperfiddle/electric/impl/lang_de2.clj | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 3180487ff..bbe554bd3 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -918,10 +918,9 @@ (recur (cond-> ac (= ::ctor (::type nd)) (conj e)) (::parent nd))))) ctors-uid (mapv #(e->uid ts %) ctors-e) localv-e (->localv-e ts mklocal-uid) - ;; TODO maybe necessary, no proof yet - ;; ts (cond-> ts (in-a-call? ts e) - ;; (-> (ts/upd (::ref nd) ::in-call #(conj (or % #{}) e)) - ;; (ensure-node (::ref nd)))) + ts (cond-> ts (in-a-call? ts e) + (-> (ts/upd (::ref nd) ::in-call #(conj (or % #{}) e)) + (ensure-node (::ref nd)))) ts (if (seq ctors-e) ; closed over (-> ts (ensure-node mklocal-uid) (ensure-free-node mklocal-uid (first ctors-uid)) From 210cea1f2101f2a5f0de7396585cee9425a5a1fb Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 28 Mar 2024 12:03:58 +0100 Subject: [PATCH 168/428] fix in-a-call? marking internal locals as nodes --- src/hyperfiddle/electric/impl/lang_de2.clj | 28 ++++++++++++---------- src/hyperfiddle/electric_local_def_de.cljc | 3 --- 2 files changed, 16 insertions(+), 15 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index bbe554bd3..82f839ee5 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -203,7 +203,9 @@ (defn expand-all [env o] (m/? (cljs-ana/analyze-nsT !a env (get-ns env))) - (-expand-all o (assoc env ::electric true))) + (let [expanded (-expand-all o (assoc env ::electric true))] + (when (::print-expansion env) (fipp.edn/pprint expanded)) + expanded)) ;;;;;;;;;;;;;;;; ;;; COMPILER ;;; @@ -491,7 +493,7 @@ (swap! @(requiring-resolve 'cljs.env/*compiler*) assoc-in [:cljs.analyzer/namespaces ns :defs sym] {:name sym})) -(defn e->uid [ts e] (ca/check (::uid (ts/->node ts e)))) +(defn e->uid [ts e] (ca/is (::uid (ts/->node ts e)))) (defn uid->e [ts uid] (first (ca/check #(= 1 (count %)) (ts/find ts ::uid uid)))) (defn reparent-children [ts from-e to-e] (reduce (fn [ts e] (ts/asc ts e ::parent to-e)) ts (ts/find ts ::parent from-e))) @@ -588,8 +590,9 @@ ce env (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) (ts/add {:db/id ce, ::parent e, ::type ::ctor, ::uid (->uid)}) (?add-source-map e form)))) - (::call) (let [e (->id)] (recur (second form) e env (-> (ts/add ts {:db/id e, ::parent pe, ::type ::call}) - (?add-source-map e form)))) + (::call) (let [e (->id)] (recur (second form) e env + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::call, ::uid (->uid)}) + (?add-source-map e form)))) (::pure) (let [e (->id)] (recur (second form) e env (-> (ts/add ts {:db/id e, ::parent pe, ::type ::pure}) (?add-source-map e form)))) (::join) (let [e (->id)] (recur (second form) e env (-> (ts/add ts {:db/id e, ::parent pe, ::type ::join}) @@ -883,13 +886,13 @@ ts (->> ts :ave ::used-refs vals (reduce into) (mapv #(e->uid ts %)) (remove #(has-node? ts %))))) - in-a-call? (fn in-a-call? [ts e] - (loop [e (::parent (ts/->node ts e))] + in-a-call? (fn in-a-call? [ts ref-e mklocal-e] + (loop [e (::parent (ts/->node ts ref-e))] (when-let [nd (ts/->node ts e)] (case (::type nd) - ::call true - ::ctor false - #_else (recur (::parent nd)))))) + ::call e + ::ctor nil + #_else (when (not= e mklocal-e) (recur (::parent nd))))))) seen (volatile! #{}) reroute-local-aliases (fn reroute-local-aliases [ts] (reduce (fn [ts bl-e] @@ -918,9 +921,10 @@ (recur (cond-> ac (= ::ctor (::type nd)) (conj e)) (::parent nd))))) ctors-uid (mapv #(e->uid ts %) ctors-e) localv-e (->localv-e ts mklocal-uid) - ts (cond-> ts (in-a-call? ts e) - (-> (ts/upd (::ref nd) ::in-call #(conj (or % #{}) e)) - (ensure-node (::ref nd)))) + ts (if-some [call-e (in-a-call? ts e mklocal-e)] + (-> ts (ts/upd mklocal-e ::in-call #(conj (or % #{}) (e->uid ts call-e))) + (ensure-node mklocal-uid)) + ts) ts (if (seq ctors-e) ; closed over (-> ts (ensure-node mklocal-uid) (ensure-free-node mklocal-uid (first ctors-uid)) diff --git a/src/hyperfiddle/electric_local_def_de.cljc b/src/hyperfiddle/electric_local_def_de.cljc index 30b385773..2ac0fc2c6 100644 --- a/src/hyperfiddle/electric_local_def_de.cljc +++ b/src/hyperfiddle/electric_local_def_de.cljc @@ -30,7 +30,6 @@ (ca/check map? conf) (let [env (merge (->local-config env) (lang/normalize-env env) conf) expanded (lang/expand-all env `(::lang/ctor ~form)) - _ (when (::lang/print-expansion env) (fipp.edn/pprint expanded)) ts (lang/analyze expanded '_ env (lang/->ts)) _ (when (::lang/print-analysis env) (run! prn (->> ts :eav vals (sort-by :db/id))))] (lang/analyze-electric env ts)))) @@ -53,7 +52,6 @@ (ca/check map? conf) (let [env (merge (->local-config &env) (lang/normalize-env &env) conf) expanded (lang/expand-all env `(::lang/ctor (do ~@body))) - _ (when (::lang/print-expansion env) (fipp.edn/pprint expanded)) ts (lang/analyze expanded '_ env (lang/->ts)) _ (when (::lang/print-analysis env) (run! prn (->> ts :eav vals (sort-by :db/id)))) ts (lang/analyze-electric env ts) @@ -82,7 +80,6 @@ (ca/is conf map? "provide config map as first argument") (let [env (merge (->local-config &env) (lang/normalize-env &env) conf) expanded (lang/expand-all env `(::lang/ctor (do ~@body))) - _ (when (::lang/print-expansion env) (fipp.edn/pprint expanded)) ts (lang/analyze expanded '_ env (lang/->ts)) _ (when (::lang/print-analysis env) (run! prn (->> ts :eav vals (sort-by :db/id)))) ts (lang/analyze-electric env ts) From 92591e09322886959767624668fb55f41ba8353c Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 28 Mar 2024 12:03:58 +0100 Subject: [PATCH 169/428] fix ca/is --- src/contrib/assert.cljc | 3 ++- src/hyperfiddle/electric/impl/lang_de2.clj | 4 ++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/contrib/assert.cljc b/src/contrib/assert.cljc index aca8dbb1e..96e512fa8 100644 --- a/src/contrib/assert.cljc +++ b/src/contrib/assert.cljc @@ -24,7 +24,8 @@ (when-not (pred v) (throw (ex-info (str "assertion failed: (" (pr-str predq) " " (pr-str vq) ") for " (pr-str vq) " = " (pr-str v) (when msg (str "\n\n " msg))) - (assoc ex-data ::v v ::pred pred))))) + (assoc ex-data ::v v ::pred pred)))) + v) (defmacro is ([v] `(is ~v some?)) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 82f839ee5..6292feeb5 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -872,9 +872,9 @@ (-> ts (reparent-children e (::parent (ts/->node ts e))) (ts/del e))) inline-nodes (fn inline-nodes [ts] (reduce (fn [ts mklocal-uid] - (let [mklocal-nd (ts/->node ts (uid->e ts mklocal-uid)) + (let [mklocal-nd (ca/is (ts/->node ts (uid->e ts mklocal-uid)) (comp #{::mklocal} ::type)) localrefs-e (mapv #(uid->e ts %) (::used-refs mklocal-nd)) - localref-e (first (ca/check #(= 1 (count %)) localrefs-e {:refs localrefs-e})) + localref-e (first (ca/check #(= 1 (count %)) localrefs-e {:refs localrefs-e, :mklocal-nd mklocal-nd})) localv-e (->localv-e ts mklocal-uid), localv-nd (ts/->node ts localv-e) site (get-site ts (get-ret-e ts localv-e))] (-> ts From 040b77242e59792db046ba1959e1fe7e591a4e19 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Thu, 28 Mar 2024 17:53:26 +0100 Subject: [PATCH 170/428] fix latest-product incorrect freeze combination --- src/hyperfiddle/incseq.cljc | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/hyperfiddle/incseq.cljc b/src/hyperfiddle/incseq.cljc index 3b928ad9d..f359f7bd0 100644 --- a/src/hyperfiddle/incseq.cljc +++ b/src/hyperfiddle/incseq.cljc @@ -726,10 +726,9 @@ combined with given function. (let [j (unchecked-dec-int j) c (aget counts (unchecked-add-int offset j))] (if (frozen? (aget freezers j) (rem n c)) - (conj! s i) (if (pos? j) (recur (quot n c) j) - s))))) + (conj! s i)) s)))) s (combine-indices lr-size-after size-after r k))) (transient #{}) freeze))))) (let [j (bit-shift-right i 1)] From 274ce456f3b48db6d9ca1411d8919203e41eae60 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Wed, 27 Mar 2024 18:40:26 +0100 Subject: [PATCH 171/428] fn - apply, map varargs + self recursion --- src/hyperfiddle/electric/impl/lang_de2.clj | 9 +- src/hyperfiddle/electric/impl/runtime_de.cljc | 26 +++-- src/hyperfiddle/electric_de.cljc | 97 ++++++++----------- test/hyperfiddle/electric_de_test.cljc | 14 +-- 4 files changed, 76 insertions(+), 70 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 6292feeb5..ea23d099d 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -135,11 +135,14 @@ [(conj bs sym (-expand-all v env)) (add-local env sym)]) [[] env] (partition-all 2 bs))] - (recur (?meta o `(binding [::r/fn (hyperfiddle.electric-de/fn [~@(take-nth 2 bs2)] ~@body)] - ($ (::lookup ::r/fn) ~@(take-nth 2 (next bs2))))) + (recur (?meta o `(::call (r/bind-args (r/bind-self (::ctor (let [~@(interleave (take-nth 2 bs2) + (map (fn [i] `(::lookup ~i)) + (range)))] ~@body))) + ~@(map (fn [arg] `(::pure ~arg)) + (take-nth 2 (next bs2)))))) env2)) - (recur) (recur (?meta o `($ (::lookup ::r/fn) ~@(next o))) env) + (recur) (recur (?meta o `(::call (r/bind-args (::lookup :recur) ~@(map (fn [arg] `(::pure ~arg)) (next o))))) env) (case clojure.core/case) (let [[_ v & clauses] o diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 839134a8a..1c573d779 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -226,23 +226,37 @@ T T T -> (EXPR T) (defn bind-args [ctor & args] (reduce (partial apply bind) ctor (eduction (map-indexed vector) args))) +(defn bind-self [ctor] + (bind ctor :recur (pure ctor))) + (defn arity-mismatch [arity] (throw (Error. (str "Wrong number of args (" arity ")")))) (defn get-variadic [F arity] - (if-some [[fixed ctor] (F -1)] + (if-some [[fixed map? ctor] (F -1)] (if (< arity fixed) (arity-mismatch arity) - [fixed ctor]) + [fixed map? ctor]) (arity-mismatch arity))) +(defn varargs [map?] + (if map? + (fn [& args] + (loop [args args + m nil] + (if-some [[k & args] args] + (if-some [[v & args] args] + (recur args (assoc m k v)) + (merge m k)) m))) + (fn [& args] args))) + (defn dispatch [F & args] (let [arity (count args)] (if-some [ctor (F arity)] - (reduce (partial apply bind) ctor (eduction (map-indexed vector) args)) - (let [[fixed ctor] (get-variadic F arity)] - (bind (reduce (partial apply bind) ctor (eduction (take fixed) (map-indexed vector) args)) - -1 (effect (apply i/latest-product (comp seq list) (drop fixed args)))))))) + (apply bind-args (bind-self ctor) args) + (let [[fixed map? ctor] (get-variadic F arity)] + (bind (apply bind-args (bind-self ctor) (take fixed args)) + -1 (apply ap (pure (varargs map?)) (drop fixed args))))))) (defn peer-root [^Peer peer key] ((.-defs peer) key)) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 0552b7e47..6ff76f1f8 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -41,17 +41,6 @@ Returns the successive states of items described by `incseq`. #?(:clj (cc/defn- varargs? [args] (boolean (and (seq args) (= '& (-> args pop peek)))))) -#?(:clj (cc/defn- ?bind-self [code ?name] (cond->> code ?name (list 'let* [?name `(::lang/lookup ::r/fn)])))) - -(cc/defn -prep-varargs [n argv map-vararg?] - (let [v (into [] (drop n) argv)] - (when (seq v) ; varargs value is `nil` when no args provided - (if map-vararg? ; [x y & {:keys [z]}] <- vararg map destructuring - (if (even? (count v)) - (cc/apply array-map v) ; ($ MapVararg :x 1) - (merge (cc/apply array-map (pop v)) (peek v))) ; ($ MapVararg :x 1 {:y 2}) - v)))) - #?(:clj (cc/defn- throw-arity-conflict! [?name group] (throw (ex-info (str "Conflicting arity definitions" (when ?name (str " in " ?name)) ": " (str/join " and " group)) @@ -74,19 +63,23 @@ Returns the successive states of items described by `incseq`. arities (cond-> args2 (vector? (first args2)) list) {positionals false, varargs true} (group-by (comp varargs? first) arities) _ (check-only-one-vararg! ?name (mapv first varargs)) - _ (check-arity-conflicts! ?name (mapv first positionals) (ffirst varargs))] - ;; TODO map varargs + _ (check-arity-conflicts! ?name (mapv first positionals) (ffirst varargs)) + code (into (if-some [[args & body] (first varargs)] + {-1 [(-> args count (- 2)) + (map? (peek args)) + `(::lang/ctor + (let [~@(interleave (-> args pop pop) (map dget (range))) + ~(peek args) ~(dget -1)] ~@body))]} {}) + (map (cc/fn [[args & body]] + [(count args) + `(::lang/ctor + (let [~@(interleave args (map dget (range)))] + ~@body))])) positionals)] `(check-electric fn - ~(into (if-some [[args & body] (first varargs)] - {-1 [(-> args count (- 2)) - `(::lang/ctor - (let [~@(interleave (-> args pop pop) (map dget (range))) - ~(peek args) (dget -1)] ~@body))]} {}) - (map (cc/fn [[args & body]] - [(count args) - `(::lang/ctor - (let [~@(interleave args (map dget (range)))] - ~@body))])) positionals)))) + ~(if #_?name false ;; TODO + `(::lang/mklocal ~?name + (::lang/bindlocal ~?name + ~code ~?name)) code)))) (cc/defn ns-qualify [sym] (if (namespace sym) sym (symbol (str *ns*) (str sym)))) @@ -211,45 +204,41 @@ this tuple. Returns the concatenation of all body results as a single vector. (reduce (cc/fn [ac [nm & fargs]] `(::lang/bindlocal ~nm (hyperfiddle.electric-de/fn ~@fargs) ~ac)) (cons 'do body) sb) sb))) -(hyperfiddle.electric-de/defn Dispatch [F offset args] - (let [arity (+ offset (count args))] +(hyperfiddle.electric-de/defn Dispatch [F static args] + (let [offset (count static) + arity (+ offset (count args))] (if-some [ctor (F arity)] - (loop [offset offset - args args - ctor ctor] - (if (< offset arity) - (recur (inc offset) (next args) - (r/bind ctor offset (::lang/pure (first args)))) - ctor)) - (let [[fixed ctor] (r/get-variadic F arity)] - (loop [offset offset - args args - ctor ctor] - (if (< offset fixed) - (recur (inc offset) (next args) - (r/bind ctor offset (::lang/pure (first args)))) - (r/bind ctor -1 (::lang/pure args)))))))) + (loop [args args + static static] + (if (< (count static) arity) + (recur (next args) (conj static (::lang/pure (first args)))) + (cc/apply r/bind-args (r/bind-self ctor) static))) + (let [[fixed map? ctor] (r/get-variadic F arity)] + (if (< fixed offset) + (loop [args args + static static] + (let [args (cons (::lang/join (peek static)) args) + static (pop static)] + (if (< fixed (count static)) + (recur args static) + (cc/apply r/bind-args (r/bind (r/bind-self ctor) -1 (::lang/pure (cc/apply (r/varargs map?) args))) static)))) + (loop [args args + static static] + (if (< (count static) fixed) + (recur (next args) (conj static (::lang/pure (first args)))) + (cc/apply r/bind-args (r/bind (r/bind-self ctor) -1 (::lang/pure (cc/apply (r/varargs map?) args))) static)))))))) (hyperfiddle.electric-de/defn Apply ([F a] - (::lang/call - (r/bind-args ($ Dispatch F 0 a)))) + (::lang/call ($ Dispatch F [] a))) ([F a b] - (::lang/call - (r/bind-args ($ Dispatch F 1 b) - (::lang/pure a)))) + (::lang/call ($ Dispatch F [(::lang/pure a)] b))) ([F a b c] - (::lang/call - (r/bind-args ($ Dispatch F 2 c) - (::lang/pure a) (::lang/pure b)))) + (::lang/call ($ Dispatch F [(::lang/pure a) (::lang/pure b)] c))) ([F a b c d] - (::lang/call - (r/bind-args ($ Dispatch F 3 d) - (::lang/pure a) (::lang/pure b) (::lang/pure c)))) + (::lang/call ($ Dispatch F [(::lang/pure a) (::lang/pure b) (::lang/pure c)] d))) ([F a b c d & es] - (::lang/call - (r/bind-args ($ Dispatch F (+ 4 (count es)) (concat (butlast es) (last es))) - (::lang/pure a) (::lang/pure b) (::lang/pure c) (::lang/pure d))))) + (::lang/call ($ Dispatch F [(::lang/pure a) (::lang/pure b) (::lang/pure c) (::lang/pure d)] (concat (butlast es) (last es)))))) (cc/defn on-unmount* [f] (m/observe (cc/fn [!] (! nil) f))) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 1536981f9..750eaa986 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -1960,20 +1960,20 @@ (ex-message %) := "You called VarArgs with 0 arguments but it only supports 1")) (tests "e/apply" - (with ((l/single {} (tap (e/apply VarArgs [1 2 3]))) tap tap) + (with ((l/single {} (tap ($ e/Apply VarArgs [1 2 3]))) tap tap) % := [1 [2 3]])) (tests "e/apply" - (with ((l/single {} (tap (e/apply Two 1 [2]))) tap tap) + (with ((l/single {} (tap ($ e/Apply Two 1 [2]))) tap tap) % := [1 2])) (tests "e/apply" - (with ((l/single {} (tap (e/apply Two [1 2]))) tap tap) + (with ((l/single {} (tap ($ e/Apply Two [1 2]))) tap tap) % := [1 2])) (tests "e/apply" - (with ((l/single {} (tap (e/apply Two [1 (inc 1)]))) tap tap) + (with ((l/single {} (tap ($ e/Apply Two [1 (inc 1)]))) tap tap) % := [1 2])) ;; TODO try/catch (skip "e/apply" - (with ((l/single {} (tap (try (e/apply Two [1 2 3]) (throw (ex-info "boo" {})) + (with ((l/single {} (tap (try ($ e/Apply Two [1 2 3]) (throw (ex-info "boo" {})) (catch ExceptionInfo e e)))) tap tap) (ex-message %) := "You called Two with 3 arguments but it only supports 2")) @@ -1987,10 +1987,10 @@ (with ((l/single {} (tap ($ (e/fn ([_]) ([_ & xs] (mapv inc xs))) 1 2 3 4))) tap tap) % := [3 4 5])) (tests "multi-arity e/fn" - (with ((l/single {} (tap (e/apply (e/fn ([_] :one) ([_ _] :two)) 1 [2]))) tap tap) + (with ((l/single {} (tap ($ e/Apply (e/fn ([_] :one) ([_ _] :two)) 1 [2]))) tap tap) % := :two)) (tests "multi-arity e/fn" - (with ((l/single {} (tap (e/apply (e/fn ([_]) ([_ & xs] (mapv inc xs))) 1 2 [3 4]))) tap tap) + (with ((l/single {} (tap ($ e/Apply (e/fn ([_]) ([_ & xs] (mapv inc xs))) 1 2 [3 4]))) tap tap) % := [3 4 5])) (tests "self-recur by name, e/fn" From ffc297b15e99b7167ef36287d97e13ab3669d68e Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 3 Apr 2024 19:00:52 +0200 Subject: [PATCH 172/428] fix e/fn self-recur --- src/hyperfiddle/electric/impl/lang_de2.clj | 28 ++++++++------ src/hyperfiddle/electric_de.cljc | 38 +++++++++---------- .../electric/impl/compiler_test.cljc | 5 +++ 3 files changed, 41 insertions(+), 30 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index ea23d099d..80de10e67 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -102,7 +102,7 @@ (?meta o (list* (caller (first o) env) (mapv (fn-> caller env) (next o)))))) (defmacro $ [F & args] - `(::call (r/dispatch ~F ~@(map (fn [arg] `(::pure ~arg)) args)))) + `(::call ((::static-vars r/dispatch) ~F ~@(map (fn [arg] `(::pure ~arg)) args)))) (defn -expand-all [o env] (cond @@ -407,14 +407,16 @@ (if-some [uid (::electric-let local)] {::lang nil, ::type ::localref, ::sym sym, ::ref uid} {::lang nil, ::type ::local, ::sym sym}) - (if-some [nd (resolve-node sym env)] - {::lang nil, ::type ::node, ::node nd} - (case (get (::peers env) (::current env)) - :clj (let [v (analyze-clj-symbol sym (get-ns env))] (case v nil (cannot-resolve! env sym) #_else (assoc v ::lang :clj))) - :cljs (assoc (analyze-cljs-symbol sym env) ::lang :cljs) - #_unsited (case (->env-type env) - :clj (assoc (or (analyze-clj-symbol sym (get-ns env)) {::type ::var, ::sym `r/cannot-resolve}) :lang :clj) - :cljs (assoc (analyze-cljs-symbol sym env) :lang :cljs)))))) + (if (= sym (::def env)) + {::lang nil, ::type ::self, ::sym sym} + (if-some [nd (resolve-node sym env)] + {::lang nil, ::type ::node, ::node nd} + (case (get (::peers env) (::current env)) + :clj (let [v (analyze-clj-symbol sym (get-ns env))] (case v nil (cannot-resolve! env sym) #_else (assoc v ::lang :clj))) + :cljs (assoc (analyze-cljs-symbol sym env) ::lang :cljs) + #_unsited (case (->env-type env) + :clj (assoc (or (analyze-clj-symbol sym (get-ns env)) {::type ::var, ::sym `r/cannot-resolve}) :lang :clj) + :cljs (assoc (analyze-cljs-symbol sym env) :lang :cljs))))))) (defn ->bindlocal-body-e [ts e] (second (get-children-e ts e))) @@ -629,6 +631,8 @@ ::sym form, ::uid (->uid)}) (::local) (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form})) + (::self) (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) + (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v (list form)})) (::static ::var) (if (::static-vars env) (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form})) @@ -790,11 +794,13 @@ (let [nd (get (:eav ts) e)] (case (::type nd) ::ap (map rec (get-children-e ts e)) - ::pure (rec (get-child-e ts e)) + (::pure ::site) (rec (get-child-e ts e)) ::comp `(fn [] ~(map rec (get-children-e ts e))) ::literal (::v nd) ::ctor `(r/ctor ~nm ~(::ctor-idx nd)) - ::mklocal (recur (get-ret-e ts (get-child-e ts e)))))) e)) + ::mklocal (recur (get-ret-e ts (get-child-e ts e))) + ::localref (recur (->> (::ref nd) (->localv-e ts) (get-ret-e ts)))))) + e)) (defn get-deps [sym] (-> sym resolve meta ::deps)) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 6ff76f1f8..fcde639b8 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -58,28 +58,28 @@ Returns the successive states of items described by `incseq`. (when-some [same (get grouped (-> vararg count dec))] (throw-arity-conflict! ?name (conj same vararg)))))) -(defmacro fn [& args] +(defmacro -fn [& args] (let [[?name args2] (if (symbol? (first args)) [(first args) (rest args)] [nil args]) arities (cond-> args2 (vector? (first args2)) list) {positionals false, varargs true} (group-by (comp varargs? first) arities) _ (check-only-one-vararg! ?name (mapv first varargs)) - _ (check-arity-conflicts! ?name (mapv first positionals) (ffirst varargs)) - code (into (if-some [[args & body] (first varargs)] - {-1 [(-> args count (- 2)) - (map? (peek args)) - `(::lang/ctor - (let [~@(interleave (-> args pop pop) (map dget (range))) - ~(peek args) ~(dget -1)] ~@body))]} {}) - (map (cc/fn [[args & body]] - [(count args) - `(::lang/ctor - (let [~@(interleave args (map dget (range)))] - ~@body))])) positionals)] + _ (check-arity-conflicts! ?name (mapv first positionals) (ffirst varargs))] + (into (if-some [[args & body] (first varargs)] + {-1 [(-> args count (- 2)) + (map? (peek args)) + `(::lang/ctor + (let [~@(interleave (-> args pop pop) (map dget (range))) + ~(peek args) ~(dget -1)] ~@body))]} {}) + (map (cc/fn [[args & body]] + [(count args) + `(::lang/ctor + (let [~@(interleave args (map dget (range)))] + ~@body))])) positionals))) + +(defmacro fn [& args] + (let [?nm (first args)] `(check-electric fn - ~(if #_?name false ;; TODO - `(::lang/mklocal ~?name - (::lang/bindlocal ~?name - ~code ~?name)) code)))) + ~(if (symbol? ?nm) `(::lang/mklocal ~?nm (::lang/bindlocal ~?nm (-fn ~@args) ~?nm)) `(-fn ~@args))))) (cc/defn ns-qualify [sym] (if (namespace sym) sym (symbol (str *ns*) (str sym)))) @@ -91,13 +91,13 @@ Returns the successive states of items described by `incseq`. (let [[_defn sym] (macroexpand `(cc/defn ~nm ~@fdecl)) env (merge (meta nm) (lang/normalize-env &env) l/web-config {::lang/def nm}) nm2 (vary-meta nm merge (meta sym)) - expanded (lang/expand-all env `(fn ~nm2 ~@(cond-> fdecl (string? (first fdecl)) next))) + expanded (lang/expand-all env `(-fn ~nm2 ~@(cond-> fdecl (string? (first fdecl)) next))) _ (when (::lang/print-expansion env) (fipp.edn/pprint expanded)) ts (lang/analyze expanded '_ env (lang/->ts)) ts (lang/analyze-electric env ts) k (-> nm ns-qualify keyword) ctors (mapv #(lang/emit-ctor ts % env k) (lang/get-ordered-ctors-e ts)) - source `(cc/fn ([] ~(lang/emit-fn ts (lang/get-root-e ts) k)) + source `(cc/fn ~nm ([] ~(lang/emit-fn ts (lang/get-root-e ts) k)) ([idx#] (case idx# ~@(interleave (range) ctors)))) deps (lang/emit-deps ts (lang/get-root-e ts)) nm3 (vary-meta nm2 assoc ::lang/deps `'~deps)] diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index bb341b5ab..67491fea5 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -537,6 +537,11 @@ ;; TODO `set!` needs cc/fn ;; (let [sm (l/compile-client-with-source-map (set! (.-x (Object.)) 1))]) + + (l/test-compile ::Main (e/letfn [(Foo [] Foo)] Foo)) + + (l/test-compile ::Main (e/$ (e/fn Foo ([] (e/$ Foo 10)) ([x] (inc x))) 100)) + (l/test-compile ::Main (e/$ (::lang/mklocal Foo (::lang/bindlocal Foo (e/fn [x] Foo) Foo)))) ) (prn :ok) From 96b4a7bc816e8b7f048b5713687f9857c87e6112 Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 3 Apr 2024 19:03:49 +0200 Subject: [PATCH 173/428] fix jvm test runner --- src/hyperfiddle/electric/impl/lang_de.clj | 661 ---------------------- 1 file changed, 661 deletions(-) delete mode 100644 src/hyperfiddle/electric/impl/lang_de.clj diff --git a/src/hyperfiddle/electric/impl/lang_de.clj b/src/hyperfiddle/electric/impl/lang_de.clj deleted file mode 100644 index 963e60895..000000000 --- a/src/hyperfiddle/electric/impl/lang_de.clj +++ /dev/null @@ -1,661 +0,0 @@ -(ns hyperfiddle.electric.impl.lang-de - (:refer-clojure :exclude [compile]) - (:require [cljs.analyzer :as cljs-ana] - [cljs.core] - [cljs.env] - [clojure.string :as str] - [contrib.assert :as ca] - [contrib.debug] - [contrib.triple-store :as ts] - [dom-top.core :refer [loopr]] - [hyperfiddle.electric :as-alias e] - [hyperfiddle.electric.impl.analyzer :as ana] - [hyperfiddle.electric.impl.runtime-de :as r] - [hyperfiddle.incseq :as i] - [hyperfiddle.rcf :as rcf :refer [tests]])) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; HIGH-LEVEL RUNTIME API ;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defn r-invoke [f & args] - (apply f args)) - -(defmacro r-defs [& exprs] - `(fn [tier# id#] - (binding [r/*tier* tier#] - (case id# - ~(interleave (range) exprs))))) - -(defmacro r-static [expr] - `(r/pure ~expr)) - -(defmacro r-ap [& args] - `(i/latest-product r-invoke ~@args)) - -(defmacro r-free [id] ; looks up a free (closed over) expr in ctor - `(r/ctor-free (r/tier-ctor r/*tier*) ~id)) - -(defmacro r-local [id] ; looks up a local (from defs block) expr - `(r/tier-local r/*tier* ~id)) - -(defmacro r-remote [id] - `(r/tier-local r/*tier* ~id)) - -(defmacro r-ctor [slots output & free] - `(r/pure (r/peer-ctor (r/tier-peer r/*tier*) ~slots ~output - (doto (object-array ~(count free)) - ~@(map-indexed (partial list `aset) free))))) - -(defmacro r-call [id] - `(i/latest-concat (r/tier-slot r/*tier* ~id))) - -(defmacro r-join [expr] - `(r/pure ~expr)) - -(defmacro r-join [expr] - `(i/latest-concat ~expr)) - -(defmacro r-var [id] - `(r/pure (r/peer-var (r/tier-peer r/*tier*) (quote ~id)))) - -(defmacro r-lookup [id] - `(r/tier-lookup r/*tier* (quote ~id))) - -;;;;;;;;;;;;;;;; -;;; EXPANDER ;;; -;;;;;;;;;;;;;;;; - -(defn- fn-> [f a] (fn [o] (f o a))) - -(declare -expand-all-in-try) - -(defn resolve-cljs [env sym] - (when (not= '. sym) - (let [!found? (volatile! true) - resolved (binding [cljs-ana/*cljs-warnings* (assoc cljs-ana/*cljs-warnings* :undeclared-ns false)] - (cljs-ana/resolve-var env sym - (fn [env prefix suffix] - (cljs-ana/confirm-var-exists env prefix suffix - (fn [_ _ _] (vreset! !found? false)))) nil))] - (when (and resolved @!found? (not (:macro resolved))) - ;; If the symbol is unqualified and is from a different ns (through e.g. :refer) - ;; cljs returns only :name and :ns. We cannot tell if it resolved to a macro. - ;; We recurse with the fully qualified symbol to get all the information. - ;; The symbol can also resolve to a local in which case we're done. - ;; TODO how to trigger these in tests? - (if (and (simple-symbol? sym) (not= (:ns env) (:ns resolved)) (not= :local (:op resolved))) - (recur env (ca/check qualified-symbol? (:name resolved) {:sym sym, :resolved resolved})) - resolved))))) - -(defn serialized-require [sym] - ;; we might be expanding clj code before the ns got loaded (during cljs compilation) - ;; to correctly lookup vars the ns needs to be loaded - ;; since shadow-cljs compiles in parallel we need to serialize the requires - (when-not (get (loaded-libs) sym) - (try (#'clojure.core/serialized-require sym) ; try bc it can be cljs file - (catch java.io.FileNotFoundException _)))) - -(defn macroexpand-clj [o] (serialized-require (ns-name *ns*)) (macroexpand-1 o)) - -(defn expand-referred-or-local-macros [o cljs-macro-env] - ;; (:require [some.ns :refer [some-macro]]) - ;; `some-macro` might be a macro and cljs expander lookup fails to find it - ;; another case is when a cljc file :require-macros itself without refering the macros - (if-some [vr (when (simple-symbol? (first o)) (resolve (first o)))] - (if (and (not (class? vr)) (.isMacro ^clojure.lang.Var vr)) - (apply vr o cljs-macro-env (rest o)) - o) - o)) - -(defn expand-macro [env o] - (let [[f & args] o, n (name f), e (dec (count n))] - (if (= "." n) - o - (if (and (not= ".." n) (= \. (nth n e))) - `(new ~(symbol (namespace f) (subs n 0 e)) ~@args) - (if (some? (re-find #"^\.[^.]" n)) - (list* '. (first args) (symbol (subs n 1)) (rest args)) - (if (= :cljs (get (::peers env) (::current env))) - (let [cljs-env (::cljs-env env)] - (if (resolve-cljs cljs-env f) - o - (let [cljs-macro-env (cond-> cljs-env (::ns cljs-env) (assoc :ns (::ns cljs-env)))] - (if-some [expander (cljs-ana/get-expander f cljs-macro-env)] - (apply expander o cljs-macro-env args) - (expand-referred-or-local-macros o cljs-macro-env))))) - (macroexpand-clj o))))))) - -(defn find-local-entry [env sym] (find (:locals env) sym)) -(defn add-local [env sym] (update env :locals assoc sym ::unknown)) - -(def ^:dynamic *electric* true) - -(defn ?meta [metao o] - (if (instance? clojure.lang.IObj o) - (cond-> o (meta metao) (vary-meta #(merge (meta metao) %))) - o)) - -(defn -expand-all [o env] - (cond - (and (seq? o) (seq o)) - (if (find-local-entry env (first o)) - (list* (first o) (mapv (fn-> -expand-all env) (rest o))) - (case (first o) - ;; (ns ns* deftype* defrecord* var) - - (do) (if (nnext o) - (let [body (mapv #(list `e/drain %) (next o)) - body (conj (pop body) (second (peek body)))] ; last arg isn't drained - (recur (?meta o (cons `e/amb body)) env)) - (recur (?meta o (second o)) env)) - - (let*) (let [[_ bs & body] o - [bs2 env2] (reduce - (fn [[bs env] [sym v]] - [(conj bs sym (-expand-all v env)) (add-local env sym)]) - [[] env] - (partition-all 2 bs))] - (?meta o (list 'let* bs2 (-expand-all (?meta body (cons 'do body)) env2)))) - - (loop*) (let [[_ bs & body] o - [bs2 env2] (reduce - (fn [[bs env] [sym v]] - [(conj bs sym (-expand-all v env)) (add-local env sym)]) - [[] env] - (partition-all 2 bs))] - (recur (?meta o `(binding [r/rec (::closure (let [~@(interleave (take-nth 2 bs2) r/arg-sym)] - ~@body))] - (new r/rec ~@(take-nth 2 (next bs2))))) env2)) - - (case clojure.core/case) - (let [[_ v & clauses] o - has-default-clause? (odd? (count clauses)) - clauses2 (cond-> clauses has-default-clause? butlast) - xpand (fn-> -expand-all env)] - (?meta o (list* 'case (xpand v) - (cond-> (into [] (comp (partition-all 2) (mapcat (fn [[match expr]] [match (xpand expr)]))) - clauses2) - has-default-clause? (conj (xpand (last clauses))))))) - - (quote) o - - (fn*) (let [[?name more] (if (symbol? (second o)) [(second o) (nnext o)] [nil (next o)]) - arities (cond-> more (vector? (first more)) list)] - (?meta o (apply list - (into (if ?name ['fn* ?name] ['fn*]) - (map (fn [[syms & body]] - (binding [*electric* false] - (list syms (-expand-all (cons 'do body) (reduce add-local env syms)))))) - arities)))) - - (letfn*) (let [[_ bs & body] o - env2 (reduce add-local env (take-nth 2 bs)) - xpand (fn-> -expand-all env2) - bs2 (into [] (comp (partition-all 2) - (mapcat (fn [[sym v]] [sym (binding [*electric* false] (xpand v))]))) - bs)] - (?meta o `(let* [~(vec (take-nth 2 bs2)) (::letfn ~bs2)] ~(-expand-all (cons 'do body) env2)))) - - ;; TODO expand `do` - (try) (throw (ex-info "try is TODO" {:o o})) #_(list* 'try (mapv (fn-> -all-in-try env) (rest o))) - - (binding clojure.core/binding) - (let [[_ bs & body] o] - (?meta o (list 'binding (into [] (comp (partition-all 2) (mapcat (fn [[sym v]] [sym (-expand-all v env)]))) bs) - (-expand-all (cons 'do body) env)))) - - (set!) (if *electric* - (recur (?meta o `((fn* [v#] (set! ~(nth o 1) v#)) ~(nth o 2))) env) - (?meta o (list 'set! (-expand-all (nth o 1) env) (-expand-all (nth o 2) env)))) - - ;; (::toggle :client {:debug :info} form) - (::toggle) (?meta o (seq (conj (into [] (take 3) o) - (-expand-all (cons 'do (drop 3 o)) (assoc env ::current (second o)))))) - - #_else - (if (symbol? (first o)) - (let [o2 (expand-macro env o)] - (if (identical? o o2) - (?meta o (list* (first o) (mapv (fn-> -expand-all env) (rest o)))) - (recur (?meta o o2) env))) - (?meta o (list* (-expand-all (first o) env) (mapv (fn-> -expand-all env) (next o))))))) - - (map-entry? o) (clojure.lang.MapEntry. (-expand-all (key o) env) (-expand-all (val o) env)) - (coll? o) (?meta (meta o) (into (empty o) (map (fn-> -expand-all env)) o)) - :else o)) - -#_(defn -expand-all-in-try [o env] - (if (seq? o) - (if (find-local-entry env (first o)) - (list* (first o) (mapv (fn-> -expand-all env) (rest o))) - (case (first o) - (catch) (let [[_ typ sym & body] o, env2 (add-local env sym)] - (list* 'catch typ sym (mapv (fn-> -expand-all env2) body))) - #_else (-expand-all o env))) - (-expand-all o env))) - -;; :js-globals -> cljs env -;; :locals -> cljs or electric env -;; ::lang/peers -> electric env -;; if ::current = :clj expand with clj environment -;; if ::current = :cljs expand with cljs environment - -(defn enrich-for-require-macros-lookup [cljs-env nssym] - (if-some [src (cljs-ana/locate-src nssym)] - (let [ast (:ast (with-redefs [cljs-ana/missing-use-macro? (constantly nil)] - (binding [cljs-ana/*passes* []] - (cljs-ana/parse-ns src {:load-macros true, :restore false}))))] - ;; we parsed the ns form without `ns-side-effects` because it triggers weird bugs - ;; this means the macro nss from `:require-macros` might not be loaded - (run! serialized-require (-> ast :require-macros vals set)) - (assoc cljs-env ::ns ast)) - cljs-env)) - -(tests "enrich of clj source file is noop" - (cljs.env/ensure (enrich-for-require-macros-lookup {:a 1} 'clojure.core)) := {:a 1}) - -;; takes an electric environment, which can be clj or cljs -;; if it's clj we need to prep the cljs environment (cljs.env/ensure + cljs.analyzer/empty-env with patched ns) -;; we need to be able to swap the environments infinite number of times - -(defn ->common-env [env] - (if (::cljs-env env) - env - (assoc env ::cljs-env - (if (contains? env :js-globals) - env - (cond-> (cljs.analyzer/empty-env) (:ns env) (enrich-for-require-macros-lookup (:ns env))))))) - -(defn expand-all [env o] (cljs.env/ensure (-expand-all o (->common-env env)))) - -;;;;;;;;;;;;;;;; -;;; COMPILER ;;; -;;;;;;;;;;;;;;;; - -(defn get-configs-to-compile [conf lang] - (into #{} - (comp - (keep (fn [[peer peer-lang]] (when (= lang peer-lang) peer))) - (mapcat (fn [peer] (into [] (comp (filter (fn [current] (or (not (::only conf)) (get (::only conf) current)))) - (map (fn [current] (assoc conf ::me peer, ::current current)))) - (keys (::peers conf)))))) - (::peers conf))) - -(tests - (get-configs-to-compile {::peers {:client :clj :server :cljs}, ::current :client} :cljs) - := #{{::peers {:client :clj :server :cljs}, ::me :server, ::current :client} - {::peers {:client :clj :server :cljs}, ::me :server, ::current :server}} - - (get-configs-to-compile {::peers {:client :clj :server :clj}, ::current :client} :clj) - := #{{::peers {:client :clj :server :clj}, ::me :client, ::current :client} - {::peers {:client :clj :server :clj}, ::me :client, ::current :server} - {::peers {:client :clj :server :clj}, ::me :server ::current :client} - {::peers {:client :clj :server :clj}, ::me :server ::current :server}} - - (get-configs-to-compile {::peers {:client :clj :server :clj}, ::current :client, ::only #{:client}} :clj) - := #{{::peers {:client :clj :server :clj}, ::me :client, ::current :client, ::only #{:client}} - {::peers {:client :clj :server :clj}, ::me :server, ::current :client, ::only #{:client}}} - ) - -(defn mksym [x & xs] - (if (or (symbol? x) (keyword? x)) - (symbol (namespace x) (apply str (name x) (map name (flatten xs)))) - (symbol (apply str (name x) (map name (flatten xs)))))) -(defn as-node [o] (vary-meta o assoc ::type ::node)) -(defn node? [mt] (-> mt ::type #{::node})) -(defn as-node-signifier [o] (vary-meta o assoc ::type ::node-signifier)) -(defn node-signifier? [mt] (-> mt ::type #{::node-signifier})) -(defn signifier->node [sym cfg] (mksym sym "_hf_" (::me cfg) "_" (::current cfg))) - -(defn find-local [sym env] (-> env :locals (get sym))) -(defn find-electric-local [sym env] (let [local (find-local sym env)] (when (::pub local) local))) - -(defn- find-node-signifier [sym env] - (case (get (::peers env) (::me env)) - :clj (when-some [^clojure.lang.Var vr (resolve env sym)] - (when (-> vr meta node-signifier?) - (symbol (-> vr .ns str) (-> vr .sym str)))) - :cljs (when-some [vr (resolve-cljs env sym)] - (when (-> vr :meta node-signifier?) - (symbol (-> vr :name str)))))) ; there's `:ns` but `:name` already contains the ns (?) - -(defn- find-node [sym env] - (case (get (::peers env) (::me env)) - :clj (when-some [^clojure.lang.Var vr (resolve env sym)] - (when (-> vr meta node?) - (symbol (-> vr .ns str) (-> vr .sym str)))) - :cljs (when-some [vr (resolve-cljs env sym)] - (when (-> vr :meta node?) - (symbol (-> vr :name str)))))) ; there's `:ns` but `:name` already contains the ns (?) - -(declare analyze-me analyze-them) - -(defn get-them [env] (-> env ::peers keys set (disj (::current env)) first)) -(defn toggle [env] (assoc env ::current (get-them env))) - -(tests - (toggle {::peers {:client :cljs, :server :clj} ::current :server}) - := {::peers {:client :cljs, :server :clj} ::current :client}) - -(defn fail! - ([env msg] (fail! env msg {})) - ([env msg data] (throw (ex-info (str "in" (some->> (::def env) (str " ")) ": " (-> env ::last peek pr-str) "\n" msg) - (merge {:form (-> env ::last pop peek) :in (::def env) :for ((juxt ::me ::current) env)} data))))) - -(defn cannot-resolve! [env form] - (fail! env (str "I cannot resolve " "`"form"`" - (when-let [them (get-them env)] - (let [site (name them)] - (str ", maybe it's defined only on the " site "?" - \newline "If `" form "` is supposed to be a macro, you might need to :refer it in the :require-macros clause.")))) - {:locals (keys (:locals env))})) - -(defn ns-qualify [node] (if (namespace node) node (symbol (str *ns*) (str node)))) - -(tests - (ns-qualify 'foo) := `foo - (ns-qualify 'a/b) := 'a/b) - -(defn qualify-sym-in-var-node "If ast node is `:var`, update :form to be a fully qualified symbol" [env ast] - (if (and (= :var (:op ast)) (not (-> ast :env :def-var))) - (assoc ast :form (case (get (::peers env) (::current env)) - :clj (symbol (str (:ns (:meta ast))) (str (:name (:meta ast)))) - :cljs (:name (:info ast)))) - ast)) - -(defn ->meta [o env] (merge (::meta (find-electric-local o env)) (meta o))) - -(defn closure - "Analyze a cc/fn form, looking for electric defs and electric lexical bindings references. - Rewrites the cc/fn form into a closure over electric dynamic and lexical scopes. - Return a pair [closure form, references to close over]. - - e.g.: - (let [x 1] - (binding [y 2] - (fn [arg] [x y arg]))) - - => - [(fn [x123 y123] - (fn [& rest-args123] - (binding [y y123] - (let [x x123] - (apply (fn [arg] [x y arg]) rest-args123))))) - [x y]] - " - [env form] - (let [refered-evars (atom {}) - refered-lexical (atom {}) - edef? (fn [ast] (or (#{::node ::node-signifier} (-> ast :meta ::type)) - (#{::node ::node-signifier} (-> ast :info :meta ::type)))) - dynamic? (fn [ast] (or (:assignable? ast) ; clj - (:dynamic (:meta (:info ast))) ; cljs - )) - lexical? (fn [ast] (or (::provided? ast) ; clj - (::provided? (:info ast)) ;cljs - )) - namespaced? (fn [ast] (qualified-symbol? (:form ast))) - safe-let-name (fn [sym] (if (qualified-symbol? sym) - (symbol (str/replace (str (munge sym)) #"\." "_")) - sym)) - record-lexical! (fn [{:keys [form]}] - (swap! refered-lexical assoc (with-meta form (->meta form env)) - (gensym (name form)))) - record-edef! (fn [{:keys [form] :as ast}] - (if (dynamic? ast) - (swap! refered-evars assoc form #_(ana/var-name ast) (gensym (name form))) - (record-lexical! ast))) - env (update env :locals update-vals #(if (map? %) (assoc % ::provided? true) {::provided? true})) - rewrite-ast (fn [ast] - (cond - (edef? ast) (do (record-edef! ast) - (cond (dynamic? ast) (qualify-sym-in-var-node env ast) - (namespaced? ast) (update ast :form safe-let-name) - :else ast)) - (lexical? ast) (do (record-lexical! ast) ast) - :else (qualify-sym-in-var-node env ast))) - form (case (get (::peers env) (::current env)) - :clj (-> (ana/analyze-clj env form) - (ana/walk-clj rewrite-ast) - (ana/emit-clj)) - :cljs (-> (binding [cljs.analyzer/*cljs-warning-handlers* - [(fn [_warning-type _env _extra])]] - (ana/analyze-cljs env form)) - (ana/walk-cljs rewrite-ast) - (ana/emit-cljs))) - rest-args-sym (gensym "rest-args") - all-syms (merge @refered-evars @refered-lexical) - [syms gensyms] [(keys all-syms) (vals all-syms)] - fn? (and (seq? form) (#{'fn 'fn* 'clojure.core/fn 'clojure.core/fn* 'cljs.core/fn 'cljs.core/fn*} (first form))) - form (if fn? - `(apply ~form ~rest-args-sym) - form) - form (if (seq @refered-lexical) - `(let [~@(flatten (map (fn [[k v]] [(safe-let-name k) v]) @refered-lexical))] - ~form) - form) - form (if (seq @refered-evars) - `(binding [~@(flatten (seq @refered-evars))] - ~form) - form) - form (if fn? - `(fn [~@gensyms] (fn [~'& ~rest-args-sym] ~form)) - `(fn [~@gensyms] ~form))] - [form syms])) - -(defn bound-js-fn - "Given a js global resolving to a function (e.g js/alert, js/console.log required-js-ns/js-fn), ensures it - is called under the correct `this` context." - [sym] - (let [fields (str/split (name sym) #"\.")] - `(.bind ~sym ~(symbol (namespace sym) - (if (seq (rest fields)) - (str/join (interpose '. (butlast fields))) - "globalThis"))))) - -(defn- class-constructor-call? [env f] - (and (symbol? f) (not (or (find-local f env) (find-node-signifier f env) (find-node f env))))) - -(defn with-interop-locals [env syms] (update env :locals merge (zipmap syms (repeat {})))) - -(defn resolve-static-field [sym] - (when-some [ns (some-> (namespace sym) symbol)] - (when-some [cls (resolve ns)] - (when (class? cls) - (clojure.lang.Reflector/getField cls (name sym) true))))) - -(defn get-children-e [ts e] (-> ts :ave ::parent (get e))) -(defn get-root-e [ts] (first (get-children-e ts '_))) - -(defn find-let-ref [sym pe ts] - (loop [pe pe] - (when pe - (let [p (ts/get-entity ts pe)] - (if (and (= ::let (::type p)) (= sym (::sym p))) - pe - (recur (::parent p))))))) - -(defn ?add-source-map [{{::keys [->id]} :o :as ts} pe form] - (let [mt (meta form)] - (cond-> ts (:line mt) (ts/add {:db/id (->id), ::source-map-of pe, ::line (:line mt), ::column (:column mt)})))) - -(defn analyze [form pe {{::keys [env ->id]} :o :as ts}] - (cond - (and (seq? form) (seq form)) - (case (first form) - (let*) (let [[_ bs bform] form] - (loopr [ts ts, pe pe] - [[s v] (eduction (partition-all 2) bs)] - (let [e (->id)] - (recur (analyze v e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::let, ::sym s}) - (update-in [:o ::env :locals s] assoc ::electric-let true, :db/id e) - (?add-source-map e form))) e)) - (analyze bform pe ts))) - (case) (let [[_ test & brs] form - [default brs2] (if (odd? (count brs)) [(last brs) (butlast brs)] [:TODO brs])] - (loopr [bs [], mp {}] - [[v br] (partition 2 brs2)] - (let [b (gensym "case-val")] - (recur (conj bs b `(::ctor ~br)) - (reduce (fn [ac nx] (assoc ac (list 'quote nx) b)) mp (if (seq v) v [v])))) - (recur (?meta form `(let* ~bs (::call (~mp ~test (::ctor ~default))))) pe ts))) - (quote) (ts/add ts {:db/id (->id), ::parent pe, ::type ::static, ::v form}) - (fn*) (let [e (->id), ce (->id) - [form refs] (closure env form) - ts2 (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) - (?add-source-map e form) - (ts/add {:db/id ce, ::parent e, ::type ::static, ::v form}))] - (reduce (fn [ts nx] (analyze nx e ts)) ts2 refs)) - (::ctor) (let [e (->id)] (recur (second form) e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ctor}) - (?add-source-map e form)))) - (::call) (let [e (->id)] (recur (second form) e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::call}) - (?add-source-map e form)))) - (::pure) (let [e (->id)] (recur (second form) e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::pure}) - (?add-source-map e form)))) - (::join) (let [e (->id)] (recur (second form) e (-> (ts/add ts {:db/id e, ::parent pe, ::type ::join}) - (?add-source-map e form)))) - #_else (let [e (->id)] - (reduce (fn [ts nx] (analyze nx e ts)) (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) - (?add-source-map e form)) form))) - - (vector? form) (recur (?meta form (cons `vector form)) pe ts) - (map? form) (recur (?meta form (cons `hash-map (eduction cat form))) pe ts) - - (symbol? form) - (let [e (->id)] - (if-some [lr-e (find-let-ref form pe ts)] - (-> (ts/add ts {:db/id e, ::parent pe, ::type ::let-ref, ::ref lr-e, ::sym form}) - (?add-source-map e form)) - (-> (ts/add ts {:db/id e, ::parent pe, ::type ::static, ::v form}) - (?add-source-map e form)))) - - :else - (let [e (->id)] - (-> (ts/add ts {:db/id e, ::parent pe, ::type ::static, ::v form}) - (?add-source-map e form))))) - -(defn ->->id [] (let [!i (long-array [-1])] (fn [] (aset !i 0 (unchecked-inc (aget !i 0)))))) - -(defn compile-me [pe {{::keys [env ->id]} :o :as ts}] - (let [find-return-node (fn [ts e] - (let [nd (get (:eav ts) e)] - (case (::type nd) ::let (recur ts (second (get-children-e ts e))) #_else e))) - ensure-ordered (fn [ts ->order e] (cond-> ts (not (::order (get (:eav ts) e))) (ts/asc e ::order (->order)))) - order (fn order [ts ->order e] ; gives each toplevel flow an order index - (let [nd (get (:eav ts) e)] - (if (::order nd) - ts - (case (::type nd) - ::static ts - ::ap (reduce (fn [ts e] (order ts ->order e)) ts (get-children-e ts e)) - ::let (reduce (fn [ts e] (order ts ->order e)) - (ts/asc ts e ::order (->order)) - (get-children-e ts e)) - ::let-ref (order ts ->order (::ref nd)) - ::ctor (let [ce (first (get-children-e ts e))] - (ensure-ordered (order ts ->order ce) ->order ce)) - ::call (let [ce (first (get-children-e ts e)) - ts (order ts ->order ce)] - (cond-> ts (not (= ::let-ref (::type (get (:eav ts) ce)))) (ensure-ordered ->order ce))) - ::pure (recur ts ->order (first (get-children-e ts e))) - ::join (recur ts ->order (first (get-children-e ts e))) - #_else (throw (ex-info (str "cannot order: " (::type nd)) {:nd nd})))))) - index-calls (fn index-calls [ts] - (let [->idx (->->id)] - (reduce (fn [ts e] - (let [ce (first (get-children-e ts e)) - ctor-ord (loop [ce ce] - (if-some [ref-e (-> ts :eav (get ce) ::ref)] - (recur ref-e) - (-> ts :eav (get ce) ::order)))] - (-> ts (ts/asc e ::ctor-order ctor-ord) (ts/asc e ::call-idx (->idx))))) - ts (-> ts :ave ::type ::call)))) - get-letrefs-e (fn get-letrefs-e [ts e] - (loop [letrefs-e (sorted-set) unwalked-e (get-children-e ts e)] - (if-some [[ce & more-e] unwalked-e] - (recur (cond-> letrefs-e (= ::let-ref (::type (get (:eav ts) ce))) (conj ce)) - (into more-e (get-children-e ts ce))) - letrefs-e))) - ;; free-of-ctor - pointer to ctor - ;; free-idx - index of this free var in ctor free array - ;; parent-free - present if there's a parent ctor closing over this free var, index in parent free array - capture-frees (fn capture-frees [ts] - (loopr [ts ts, prev-e 0] - [ctor-e (or (->> ts :ave ::type ::ctor) [])] - (let [letrefs-e (get-letrefs-e ts ctor-e) - refs-e (into (sorted-set) (map #(::ref (get (:eav ts) %))) letrefs-e) - frees-e (into (sorted-set) (take-while #(< % ctor-e)) refs-e) - ->free-idx (->->id)] - (recur (reduce (fn [ts free-e] - (ts/add ts (merge {:db/id (->id), ::free-of-ctor ctor-e - ::ref free-e, ::free-idx (->free-idx)} - (when (< free-e prev-e) - {::parent-free - (let [parent-frees-e (-> ts :ave ::free-of-ctor (get prev-e))] - (reduce (fn [_ pfe] - (let [pf (get (:eav ts) pfe)] - (when (= free-e (::ref pf)) - (reduced (::free-idx pf))))) - nil parent-frees-e))})))) - ts frees-e) - ctor-e)) - ts)) - ;; _ (run! prn (->> ts :eav vals (sort-by :db/id))) - ts (-> ts (order (->->id) (find-return-node ts (get-root-e ts))) capture-frees index-calls) - gen (fn gen [ts e ctor-e top?] ; `top?` - let at top compiles to the value, otherwise to reference of it - (let [nd (get (:eav ts) e) - frees-e (-> ts :ave ::free-of-ctor (get ctor-e)) - ref->idx (reduce (fn [ac free-e] - (let [nd (get (:eav ts) free-e)] - (assoc ac (::ref nd) (::free-idx nd)))) {} frees-e)] - (case (::type nd) - ::static (list `r-static (::v nd)) - ::ap (cons `r-ap (mapv #(gen ts % ctor-e false) (get-children-e ts e))) - ::let (gen ts ((if top? first second) (get-children-e ts e)) ctor-e false) - ::let-ref (if-some [idx (ref->idx (::ref nd))] - (list `r-free idx) - (list `r-local (->> nd ::ref (get (:eav ts)) ::order))) - ::ctor (list* `r-ctor '[] (->> e (get-children-e ts) first (get (:eav ts)) ::order) - (mapv #(let [nd (get (:eav ts) %)] - (if-some [pfe (::parent-free nd)] - (list `r-free pfe) - (list `r-local (->> nd ::ref (get (:eav ts)) ::order)))) - (-> ts :ave ::free-of-ctor (get e)))) - ::call (list `r-call (::call-idx nd)) - ::pure (list `r-pure (gen ts (first (get-children-e ts e)) ctor-e top?)) - ::join (list `r-join (gen ts (first (get-children-e ts e)) ctor-e top?)) - #_else (throw (ex-info (str "cannot gen: " (::type nd)) {:nd nd}))))) - get-source-map (fn get-source-map [ts e] - (let [eav (:eav ts)] - (loop [e e] - (or (get eav (-> ts :ave ::source-map-of (get e) first)) - (some-> (-> eav (get e) ::parent) recur))))) - gen-sm (fn gen-sm [ts e top?] ; `top?` - let at top compiles to the value, otherwise to reference of it - (let [nd (get (:eav ts) e)] - (case (::type nd) - ::static (get-source-map ts e) - ::ap (cons (get-source-map ts e) (mapv #(gen-sm ts % false) (get-children-e ts e))) - ::let (gen-sm ts ((if top? first second) (get-children-e ts e)) false) - ::let-ref nil - ::ctor (get-source-map ts e) - ::call (get-source-map ts e) - ::pure (list (get-source-map ts e) (gen-sm ts (first (get-children-e ts e)) top?)) - ::join (list (get-source-map ts e) (gen-sm ts (first (get-children-e ts e)) top?)) - #_else (throw (ex-info (str "cannot gen-sm: " (::type nd)) {:nd nd}))))) - gen-call-ctors-vec (fn gen-call-ctors-vec [ts] - (into [] (map #(-> ts :eav (get %) ::ctor-order)) (-> ts :ave ::type ::call))) - roots (->> ts :ave ::order vals (reduce into) (sort-by #(->> % (get (:eav ts)) ::order)))] - ;; (run! prn (->> ts :eav vals (sort-by :db/id))) - (cond-> {:source - `(r/peer (r-defs ~@(conj (mapv #(gen ts % (::parent (get (:eav ts) %)) true) roots) - (let [ret-e (find-return-node ts (get-root-e ts))] - (gen ts ret-e (::parent (get (:eav ts) ret-e)) true)))) - ~(gen-call-ctors-vec ts) ~(count roots))} - (::include-source-map env) (assoc :source-map - (conj (mapv #(gen-sm ts % true) roots) - (gen-sm ts (find-return-node ts (get-root-e ts)) true)))))) - -(defn compile [form env] - (let [ts (ts/->ts {::->id (->->id), ::env env})] - (compile-me '_ (analyze (expand-all env form) '_ ts)))) From 166c6f0f31555f8242c444f4dd9de829c045a78a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Thu, 4 Apr 2024 12:18:40 +0200 Subject: [PATCH 174/428] fix i/items spawn0 -> cancel0 -> spawn1 -> transfer0 refactor incseq --- src/hyperfiddle/incseq.cljc | 499 +++---------------------- src/hyperfiddle/incseq/diff_impl.cljc | 126 +++++++ src/hyperfiddle/incseq/items_impl.cljc | 322 ++++++++++++++++ src/hyperfiddle/incseq/perm_impl.cljc | 119 ++++++ 4 files changed, 612 insertions(+), 454 deletions(-) create mode 100644 src/hyperfiddle/incseq/diff_impl.cljc create mode 100644 src/hyperfiddle/incseq/items_impl.cljc create mode 100644 src/hyperfiddle/incseq/perm_impl.cljc diff --git a/src/hyperfiddle/incseq.cljc b/src/hyperfiddle/incseq.cljc index f359f7bd0..0bad2ec8e 100644 --- a/src/hyperfiddle/incseq.cljc +++ b/src/hyperfiddle/incseq.cljc @@ -37,9 +37,11 @@ successive sequence diffs. Incremental sequences are applicative functors with ` `latest-concat`. "} hyperfiddle.incseq (:refer-clojure :exclude [cycle int-array]) - (:require [hyperfiddle.rcf :refer [tests]]) + (:require [hyperfiddle.incseq.perm-impl :as p] + [hyperfiddle.incseq.diff-impl :as d] + [hyperfiddle.incseq.items-impl :as i] + [hyperfiddle.rcf :refer [tests]]) (:import #?(:clj (clojure.lang IFn IDeref)) - #?(:clj (java.util.concurrent.locks ReentrantLock)) missionary.Cancelled)) @@ -72,129 +74,76 @@ successive sequence diffs. Incremental sequences are applicative functors with ` ;; public API -(defn inverse " +(def inverse " Returns the inverse of permutation `p`. -" [p] (into {} (map (juxt val key)) p)) +" p/inverse) -(defn cycle " +(def cycle " Returns the cyclic permutation denoted by given sequence of indices. -" ([_] {}) - ([i & js] (zipmap `(~i ~@js) `(~@js ~i)))) +" p/cycle) -(defn rotation " +(def rotation " Returns the permutation moving an item from index `i` to index `j` and shifting items in-between. ```clojure (= (rotation i j) (inverse (rotation j i))) ``` -" [i j] - (case (compare i j) - -1 (apply cycle (range i (inc j) +1)) - 0 {} - +1 (apply cycle (range i (dec j) -1)))) +" p/rotation) -(defn split-swap " +(def split-swap " Returns the permutation swapping two contiguous blocks of respective sizes `l` and `r` at index `i`. ```clojure (= (split-swap i l r) (inverse (split-swap i r l))) ``` -" [i l r] - (let [l (int l) - r (int r)] - (case l - 0 {} - (case r - 0 {} - (let [j (unchecked-add-int i l) - k (unchecked-add-int j r)] - (zipmap (range i k) - (concat (range j k) - (range i j)))))))) - - -(defn arrange " +" p/split-swap) + + +(def arrange " Arranges elements of `v` according to permutation `p`. -" [v p] - (persistent! - (reduce-kv - (fn [r i j] - (assoc! r i (nth v j))) - (transient v) p))) +" p/arrange) -(defn decompose " +(def decompose " Decompose permutation `p` as a product of disjoint cycles, represented as a set of vectors. 1-cycles matching fixed points are omitted, the size of each cycle is therefore at least 2. -" [p] - (loop [p p - cs #{}] - (case p - {} cs - (let [[i j] (first p)] - (let [c (loop [c [i] - j j] - (let [c (conj c j) - j (p j)] - (if (== i j) - c (recur c j))))] - (recur (apply dissoc p c) - (conj cs c))))))) - - -(defn compose " +" p/decompose) + + +(def compose " Returns the composition of given permutations. -" ([] {}) - ([x] x) - ([x y] - (reduce-kv - (fn [r i j] - (let [k (y j j)] - (if (== i k) - (dissoc r i) - (assoc r i k)))) - y x)) - ([x y & zs] - (reduce compose (compose x y) zs))) - - -(defn order " +" p/compose) + + +(def order " Returns the [order](https://en.wikipedia.org/wiki/Order_(group_theory)) of permutation `p`, i.e. the smallest positive integer `n` such that `(= {} (apply compose (repeat n p)))`. -" [p] - (loop [o 1, q p] - (case q - {} o - (recur (unchecked-inc o) - (compose p q))))) +" p/order) -(defn involution? " +(def involution? " Returns `true` if permutation `p` is an [involution](https://en.wikipedia.org/wiki/Involution_(mathematics)#Group_theory), i.e. its order is 2. -" [p] (and (not= {} p) (= {} (compose p p)))) +" p/involution?) -(defn transposition? " +(def transposition? " Returns `true` if permutation `p` is a [transposition](https://en.wikipedia.org/wiki/Cyclic_permutation#Transpositions), i.e. it is a 2-cycle. -" [p] (= 2 (count p))) +" p/transposition?) -(defn recompose " +(def recompose " Reconstructs the permutation defined by given set of disjoint cycles. -" [cycles] - (->> cycles - (eduction (map (partial apply cycle))) - (reduce compose (compose)))) +" p/recompose) -(defn empty-diff " +(def empty-diff " Return the empty diff for `n`-item collection. -" [n] {:degree n :grow 0 :shrink 0 :permutation {} :change {} :freeze #{}}) +" d/empty-diff) (def ^{:doc " @@ -303,95 +252,11 @@ Returns a flow producing the successive diffs of given continuous flow of collec (def ^{:doc " Returns the application of diff `d` to vector `v`. -"} patch-vec - (let [grow! (fn [v n] - (reduce conj! v (repeat n nil))) - shrink! (fn [v n] - (loop [i 0, v v] - (if (< i n) - (recur (inc i) - (pop! v)) v))) - change! (fn [r c] - (reduce-kv assoc! r c)) - cycles! (partial reduce - (fn [v c] - (let [i (nth c 0) - x (nth v i)] - (loop [v v - i i - k 1] - (let [j (nth c k) - v (assoc! v i (nth v j)) - k (unchecked-inc-int k)] - (if (< k (count c)) - (recur v j k) - (assoc! v j x)))))))] - (fn - ([] []) - ([v d] - (-> v - (transient) - (grow! (:grow d)) - (cycles! (decompose (:permutation d))) - (shrink! (:shrink d)) - (change! (:change d)) - (persistent!)))))) - -(defn patch-count [v d] (- (:degree d) (:shrink d))) - -(defn ^{:doc " +"} patch-vec d/patch-vec) + +(def ^{:doc " Returns the diff applying given diffs successively. -"} combine - ([x] x) - ([x y] - (let [px (:permutation x) - py (:permutation y) - dx (:degree x) - dy (:degree y) - cx (:change x) - cy (:change y) - fx (:freeze x) - fy (:freeze y) - degree (unchecked-add dy (:shrink x)) - size-before (unchecked-subtract dx (:grow x)) - size-between (unchecked-subtract dy (:grow y)) - size-after (unchecked-subtract dy (:shrink y))] - (loop [i size-after - d degree - p (compose py - (split-swap size-between - (unchecked-subtract degree dy) - (unchecked-subtract degree dx)) px) - c (reduce-kv assoc! - (reduce-kv - (fn [r i j] - (if (contains? cx j) - (assoc! r i (cx j)) r)) - (reduce dissoc! (transient cx) - (vals py)) py) cy) - f (reduce conj! - (reduce-kv - (fn [r i j] - (if (contains? fx j) - (conj! r i) r)) - (reduce disj! (transient fx) - (vals py)) py) fy)] - (if (< i d) - (let [j (p i i) - c (dissoc! c i) - f (disj! f i)] - (if (< j size-before) - (recur (unchecked-inc i) d p c f) - (recur i (unchecked-dec d) - (compose (rotation i d) - p (rotation d j)) c f))) - {:degree d - :permutation p - :grow (unchecked-subtract d size-before) - :shrink (unchecked-subtract d size-after) - :change (persistent! c) - :freeze (persistent! f)})))) - ([x y & zs] (reduce combine (combine x y) zs))) +"} combine d/combine) (def ^{:doc " @@ -605,7 +470,7 @@ combined with given function. (reduce compose {} (eduction (map (fn [k] - (split-swap + (p/split-swap (+ r-size-after (* k r-degree)) r-remove (- remove-offset (* k r-size-after))))) (range l))) @@ -613,7 +478,7 @@ combined with given function. (reduce compose {} (eduction (map (fn [k] - (split-swap + (p/split-swap (- create-offset (* k r-degree)) (* k r-size-before) r-create))) (range l)))))) @@ -920,9 +785,9 @@ sequence. (reduce compose {}) (compose (case (compare l r) - -1 (split-swap (+ o l) (+ l c) (- r l)) + -1 (p/split-swap (+ o l) (+ l c) (- r l)) 0 {} - +1 (split-swap (+ o r) (- l r) (+ c r)))))) + +1 (p/split-swap (+ o r) (- l r) (+ c r)))))) (ensure-capacity [^objects state grow degree shrink] (loop [] (let [counts ^ints (aget state slot-counts) @@ -1035,9 +900,9 @@ sequence. :shrink shrink :degree global-degree :permutation (compose - (split-swap (unchecked-add-int offset size-after) shift shrink) + (p/split-swap (unchecked-add-int offset size-after) shift shrink) (into {} (map (juxt (comp +offset key) (comp +offset val))) permutation) - (split-swap (unchecked-add-int offset size-before) shift grow)) + (p/split-swap (unchecked-add-int offset size-before) shift grow)) :change (into {} (map (juxt (comp +offset key) val)) change) :freeze (into #{} (map +offset) freeze)}))) (try @(aget input inner-slot-process) @@ -1364,284 +1229,10 @@ optional `compare` function, `clojure.core/compare` by default. :change {0 curr} :freeze #{}}))))))))))))))) -(def ^{:arglists '([incseq])} items - (let [slot-lock 0 - slot-busy 1 - slot-buffer 2 - slot-output 3 - slot-input 4 - slots 5 - item-slot-parent 0 - item-slot-frozen 1 - item-slot-state 2 - item-slot-fail 3 - item-slot-next 4 - item-slot-step 5 - item-slot-done 6 - item-slots 7] - (letfn [(acquire [^objects state] - #?(:clj (let [^ReentrantLock lock (aget state slot-lock) - held (.isHeldByCurrentThread lock)] - (.lock lock) held) - :cljs (let [held (aget state slot-lock)] - (aset state slot-lock true) held))) - (release [^objects state held] - (if held - #?(:clj (.unlock ^ReentrantLock (aget state slot-lock)) - :cljs (aset state slot-lock held)) - (let [^objects output (aget state slot-output) - ^objects head (aget output item-slot-parent)] - (aset output item-slot-parent nil) - #?(:clj (.unlock ^ReentrantLock (aget state slot-lock)) - :cljs (aset state slot-lock held)) - (loop [^objects head head] - (when-not (nil? head) - (let [item (aget head item-slot-next)] - (aset head item-slot-next nil) - (if-some [step (aget head item-slot-step)] - (step) (let [done (aget head item-slot-done)] - (aset head item-slot-done nil) (done))) - (recur item))))))) - (ensure-capacity [^objects state n] - (let [^objects b (aget state slot-buffer) - l (alength b)] - (if (< l n) - (let [a (object-array - (loop [l l] - (let [l (bit-shift-left l 1)] - (if (< l n) (recur l) l))))] - #?(:cljs (dotimes [i l] (aset a i (aget b i))) - :clj (System/arraycopy b 0 a 0 l)) - (aset state slot-buffer a)) b))) - (apply-cycle [^objects buffer cycle] - (let [i (nth cycle 0) - x (aget buffer i) - j (loop [i i - k 1] - (let [j (nth cycle k) - y (aget buffer j) - k (unchecked-inc-int k)] - (aset buffer i y) - (if (< k (count cycle)) - (recur j k) j)))] - (aset buffer j x) buffer)) - (detach [^objects buffer i] - (propagate-freeze buffer i) (aset buffer i nil) buffer) - (propagate-change [^objects buffer i x] - (aset ^objects (aget buffer i) item-slot-state x) buffer) - (propagate-freeze [^objects buffer i] - (aset ^objects (aget buffer i) item-slot-frozen true) buffer) - (item-failure [done] - (done) (throw (#?(:clj Error. :cljs js/Error.) "Illegal concurrent cursor."))) - (item-cancel [^objects item] - (let [parent (aget item item-slot-parent) - held (acquire parent)] - (when-not (aget item item-slot-fail) - (aset item item-slot-fail true) - (when (identical? item (aget item item-slot-next)) - (notify parent item))) - (release parent held))) - (item-transfer [^objects item] - (let [parent (aget item item-slot-parent) - held (acquire parent)] - (input-transfer parent) - (if (aget item item-slot-fail) - (do (aset item item-slot-step nil) - (notify parent item) - (release parent held) - (throw (Cancelled. "Cursor cancelled."))) - (let [state (aget item item-slot-state)] - (if (aget item item-slot-frozen) - (do (aset item item-slot-step nil) - (notify parent item)) - (aset item item-slot-next item)) - (release parent held) state)))) - (create-item [^objects parent i] - (let [item (object-array item-slots)] - (aset ^objects (aget parent slot-buffer) i item) - (aset item item-slot-parent parent) - (aset item item-slot-frozen false) - (aset item item-slot-state item) parent)) - (get-cursor [^objects item] - (fn [step done] - (let [parent (aget item item-slot-parent) - held (acquire parent)] - (if (nil? (aget item item-slot-done)) - (do (aset item item-slot-fail false) - (aset item item-slot-step step) - (aset item item-slot-done done) - (notify parent item) - (release parent held) - (->Ps item item-cancel item-transfer)) - (do (release parent held) (step) - (->Ps done {} item-failure)))))) - (input-transfer [^objects state] - (when (aget state slot-busy) - (let [^objects output (aget state slot-output)] - (loop [] - (if (aget output item-slot-frozen) - (when-some [^objects buffer (aget state slot-buffer)] - (let [n (loop [i 0] - (if (< i (alength buffer)) - (if-some [^objects item (aget buffer i)] - (do (aset item item-slot-frozen true) - (recur (inc i))) i) i))] - (when (nil? (aget output item-slot-state)) - (aset output item-slot-state (empty-diff n))))) - (try - (let [{:keys [grow degree shrink permutation change freeze]} @(aget state slot-input) - ^objects buffer (ensure-capacity state degree) - created (range (- degree grow) degree) - iperm (inverse permutation) - indices (into #{} (map (fn [i] (iperm i i))) created)] - (reduce create-item state created) - (reduce apply-cycle buffer (decompose permutation)) - (reduce detach buffer (range (- degree shrink) degree)) - (reduce-kv propagate-change buffer change) - (reduce propagate-freeze buffer freeze) - (let [diff {:grow grow - :degree degree - :shrink shrink - :permutation permutation - :change (reduce - (fn [m i] - (assoc m i (get-cursor (aget buffer i)))) - {} indices) - :freeze indices}] - (aset output item-slot-state - (if-some [d (aget output item-slot-state)] - (combine d diff) diff)))) - (catch #?(:clj Throwable :cljs :default) e - (aset output item-slot-fail true) - (aset output item-slot-state e)))) - (when (aset state slot-busy (not (aget state slot-busy))) (recur)))))) - (input-ready [^objects state] - (let [held (acquire state) - ^objects buffer (aget state slot-buffer) - ^objects output (aget state slot-output) - ^objects head (aget output item-slot-parent)] - (aset state slot-busy (not (aget state slot-busy))) - (aset output item-slot-parent - (loop [i 0 - h (when (identical? output (aget output item-slot-next)) - (aset output item-slot-next head) output)] - (if (< i (alength buffer)) - (if-some [^objects item (aget buffer i)] - (recur (inc i) - (if (identical? item (aget item item-slot-next)) - (do (aset item item-slot-next h) item) h)) h) h))) - (release state held))) - (notify [^objects state ^objects item] - (let [^objects output (aget state slot-output)] - (aset item item-slot-next (aget output item-slot-parent)) - (aset output item-slot-parent item))) - (cancel [^objects state] - ((aget state slot-input))) - (transfer [^objects state] - (let [^objects output (aget state slot-output) - held (acquire state)] - (input-transfer state) - (let [diff (aget output item-slot-state)] - (aset output item-slot-state nil) - (if (aget output item-slot-frozen) - (do (aset output item-slot-step nil) - (notify state output)) - (aset output item-slot-next output)) - (if (aget output item-slot-fail) - (do (release state held) (throw diff)) - (do (release state held) diff)))))] - (fn [incseq] - (fn [step done] - (let [state (object-array slots) - output (object-array item-slots)] - (aset output item-slot-next output) - (aset output item-slot-frozen false) - (aset output item-slot-fail false) - (aset output item-slot-step step) - (aset output item-slot-done done) - (aset state slot-lock #?(:clj (ReentrantLock.) :cljs false)) - (aset state slot-busy false) - (aset state slot-buffer (object-array 1)) - (aset state slot-output output) - (aset state slot-input - (incseq #(input-ready state) - #(do (aset output item-slot-frozen true) - (input-ready state)))) - (->Ps state cancel transfer))))))) +(def ^{:arglists '([incseq])} items i/flow) ;; unit tests -(tests "permutations" - (decompose {0 1, 1 4, 2 3, 3 2, 4 0}) := - #{[0 1 4] [2 3]} - - (recompose #{[0 1 4] [2 3]}) := - {0 1, 1 4, 2 3, 3 2, 4 0} - - (decompose (inverse {0 1, 1 4, 2 3, 3 2, 4 0})) := - #{[1 0 4] [3 2]} - - (recompose #{[1 0 4] [3 2]}) := - {0 4, 1 0, 2 3, 3 2, 4 1} - - (arrange [0 1 2 3 4] {0 1, 1 4, 2 3, 3 2, 4 0}) := - [1 4 3 2 0] - - (arrange [:a :b :c :d :e] {0 1, 1 4, 2 3, 3 2, 4 0}) := - [:b :e :d :c :a] - - (compose - (cycle 1 3 2 4) - (cycle 1 4 2 3)) := {} - - (inverse (split-swap 4 2 3)) := (split-swap 4 3 2) - - (order (cycle 2)) := 1 - (order (cycle 2 3)) := 2 - (order (cycle 2 3 4)) := 3 - (order (compose (cycle 0 1) (cycle 2 3 4))) := 6 - - (involution? (cycle 2)) := false - (involution? (cycle 2 3)) := true - (involution? (cycle 2 3 4)) := false - - (transposition? (cycle 2 3)) := true - (transposition? (cycle 2 3 4)) := false) - -(tests "sequence diffs" - (patch-vec [:a :b :c] - {:grow 1 - :degree 4 - :permutation (rotation 3 1) - :shrink 2 - :change {1 :e}}) := - [:a :e] - (patch-vec [:a :e] - {:grow 2 - :degree 4 - :permutation (rotation 1 3) - :shrink 1 - :change {0 :f 1 :g 2 :h}}) := - [:f :g :h] - - (patch-vec [:a :b :c] - {:grow 1 - :degree 4 - :permutation {} - :shrink 1 - :change {0 :f, 1 :g, 2 :h}}) := - [:f :g :h] - - (combine - {:degree 1 :grow 1 :permutation {} :shrink 0 :change {0 :a} :freeze #{}} - {:degree 1 :grow 0 :permutation {} :shrink 1 :change {} :freeze #{}}) := - {:degree 0 :grow 0 :permutation {} :shrink 0 :change {} :freeze #{}} - - (combine - {:grow 1 :degree 4 :permutation (rotation 3 1) :shrink 2 :change {1 :e} :freeze #{}} - {:grow 2 :degree 4 :permutation (rotation 1 3) :shrink 1 :change {0 :f 1 :g 2 :h} :freeze #{}}) := - {:degree 5 :grow 2 :shrink 2 :permutation (compose (cycle 2 4) (cycle 1 3)) :change {0 :f, 1 :g, 2 :h} :freeze #{}}) - (tests "incremental sequences" (letfn [(queue [] #?(:clj (let [q (java.util.LinkedList.)] diff --git a/src/hyperfiddle/incseq/diff_impl.cljc b/src/hyperfiddle/incseq/diff_impl.cljc new file mode 100644 index 000000000..b8c68b174 --- /dev/null +++ b/src/hyperfiddle/incseq/diff_impl.cljc @@ -0,0 +1,126 @@ +(ns hyperfiddle.incseq.diff-impl + (:require [hyperfiddle.incseq.perm-impl :as p] + [hyperfiddle.rcf :refer [tests]])) + +(defn empty-diff [n] + {:degree n :grow 0 :shrink 0 :permutation {} :change {} :freeze #{}}) + +(def patch-vec + (let [grow! (fn [v n] + (reduce conj! v (repeat n nil))) + shrink! (fn [v n] + (loop [i 0, v v] + (if (< i n) + (recur (inc i) + (pop! v)) v))) + change! (fn [r c] + (reduce-kv assoc! r c)) + cycles! (partial reduce + (fn [v c] + (let [i (nth c 0) + x (nth v i)] + (loop [v v + i i + k 1] + (let [j (nth c k) + v (assoc! v i (nth v j)) + k (unchecked-inc-int k)] + (if (< k (count c)) + (recur v j k) + (assoc! v j x)))))))] + (fn + ([] []) + ([v d] + (-> v + (transient) + (grow! (:grow d)) + (cycles! (p/decompose (:permutation d))) + (shrink! (:shrink d)) + (change! (:change d)) + (persistent!)))))) + +(defn combine + ([x] x) + ([x y] + (let [px (:permutation x) + py (:permutation y) + dx (:degree x) + dy (:degree y) + cx (:change x) + cy (:change y) + fx (:freeze x) + fy (:freeze y) + degree (unchecked-add dy (:shrink x)) + size-before (unchecked-subtract dx (:grow x)) + size-between (unchecked-subtract dy (:grow y)) + size-after (unchecked-subtract dy (:shrink y))] + (loop [i size-after + d degree + p (p/compose py + (p/split-swap size-between + (unchecked-subtract degree dy) + (unchecked-subtract degree dx)) px) + c (reduce-kv assoc! + (reduce-kv + (fn [r i j] + (if (contains? cx j) + (assoc! r i (cx j)) r)) + (reduce dissoc! (transient cx) + (vals py)) py) cy) + f (reduce conj! + (reduce-kv + (fn [r i j] + (if (contains? fx j) + (conj! r i) r)) + (reduce disj! (transient fx) + (vals py)) py) fy)] + (if (< i d) + (let [j (p i i) + c (dissoc! c i) + f (disj! f i)] + (if (< j size-before) + (recur (unchecked-inc i) d p c f) + (recur i (unchecked-dec d) + (p/compose (p/rotation i d) + p (p/rotation d j)) c f))) + {:degree d + :permutation p + :grow (unchecked-subtract d size-before) + :shrink (unchecked-subtract d size-after) + :change (persistent! c) + :freeze (persistent! f)})))) + ([x y & zs] (reduce combine (combine x y) zs))) + +(tests "sequence diffs" + (patch-vec [:a :b :c] + {:grow 1 + :degree 4 + :permutation (p/rotation 3 1) + :shrink 2 + :change {1 :e}}) := + [:a :e] + (patch-vec [:a :e] + {:grow 2 + :degree 4 + :permutation (p/rotation 1 3) + :shrink 1 + :change {0 :f 1 :g 2 :h}}) := + [:f :g :h] + + (patch-vec [:a :b :c] + {:grow 1 + :degree 4 + :permutation {} + :shrink 1 + :change {0 :f, 1 :g, 2 :h}}) := + [:f :g :h] + + (combine + {:degree 1 :grow 1 :permutation {} :shrink 0 :change {0 :a} :freeze #{}} + {:degree 1 :grow 0 :permutation {} :shrink 1 :change {} :freeze #{}}) := + {:degree 0 :grow 0 :permutation {} :shrink 0 :change {} :freeze #{}} + + (combine + {:grow 1 :degree 4 :permutation (p/rotation 3 1) :shrink 2 :change {1 :e} :freeze #{}} + {:grow 2 :degree 4 :permutation (p/rotation 1 3) :shrink 1 :change {0 :f 1 :g 2 :h} :freeze #{}}) := + {:degree 5 :grow 2 :shrink 2 :permutation (p/compose (p/cycle 2 4) (p/cycle 1 3)) :change {0 :f, 1 :g, 2 :h} :freeze #{}}) \ No newline at end of file diff --git a/src/hyperfiddle/incseq/items_impl.cljc b/src/hyperfiddle/incseq/items_impl.cljc new file mode 100644 index 000000000..08d4dee3c --- /dev/null +++ b/src/hyperfiddle/incseq/items_impl.cljc @@ -0,0 +1,322 @@ +(ns hyperfiddle.incseq.items-impl + (:require [hyperfiddle.incseq.perm-impl :as p] + [hyperfiddle.incseq.diff-impl :as d] + [hyperfiddle.rcf :as rcf :refer [tests]] + [clojure.test :refer [is]]) + (:import #?(:clj (clojure.lang IFn IDeref)) + #?(:clj (java.util.concurrent.locks ReentrantLock)) + missionary.Cancelled)) + +(def slot-lock 0) +(def slot-busy 1) +(def slot-done 2) +(def slot-buffer 3) +(def slot-input 4) +(def slot-output 5) +(def slot-diff 6) +(def slot-head-step 7) +(def slot-head-done 8) +(def slots 9) + +(def item-slot-parent 0) +(def item-slot-frozen 1) +(def item-slot-state 2) +(def item-slot-current 3) +(def item-slots 4) + +(declare item-cancel item-transfer) + +(deftype Item [state step done next] + IFn + (#?(:clj invoke :cljs -invoke) [this] + (item-cancel this)) + IDeref + (#?(:clj deref :cljs -deref) [this] + (item-transfer this))) + +(declare cancel transfer) + +(deftype Ps [state] + IFn + (#?(:clj invoke :cljs -invoke) [_] + (cancel state)) + IDeref + (#?(:clj deref :cljs -deref) [_] + (transfer state))) + +(defn get-next [^Item item] + (aget ^objects (.-next item) 0)) + +(defn set-next [^Item item x] + (aset ^objects (.-next item) 0 x)) + +(defn acquire [^objects state] + #?(:clj (let [^ReentrantLock lock (aget state slot-lock) + held (.isHeldByCurrentThread lock)] + (.lock lock) held) + :cljs (let [held (aget state slot-lock)] + (aset state slot-lock true) held))) + +(defn release [^objects state held] + (if held + #?(:clj (.unlock ^ReentrantLock (aget state slot-lock)) + :cljs (aset state slot-lock held)) + (let [^objects head-step (aget state slot-head-step) + ^objects head-done (aget state slot-head-done)] + (aset state slot-head-step nil) + (aset state slot-head-done nil) + #?(:clj (.unlock ^ReentrantLock (aget state slot-lock)) + :cljs (aset state slot-lock held)) + (loop [^Item head head-step] + (when-not (nil? head) + (let [item (get-next head)] + (set-next head nil) + ((.-step head)) + (recur item)))) + (loop [^objects head head-done] + (when-not (nil? head) + (let [item (get-next head)] + (set-next head nil) + ((.-done head)) + (recur item))))))) + +(defn ensure-capacity [^objects state n] + (let [^objects b (aget state slot-buffer) + l (alength b)] + (if (< l n) + (let [a (object-array + (loop [l l] + (let [l (bit-shift-left l 1)] + (if (< l n) (recur l) l))))] + #?(:cljs (dotimes [i l] (aset a i (aget b i))) + :clj (System/arraycopy b 0 a 0 l)) + (aset state slot-buffer a)) b))) + +(defn apply-cycle [^objects buffer cycle] + (let [i (nth cycle 0) + x (aget buffer i) + j (loop [i i + k 1] + (let [j (nth cycle k) + y (aget buffer j) + k (unchecked-inc-int k)] + (aset buffer i y) + (if (< k (count cycle)) + (recur j k) j)))] + (aset buffer j x) buffer)) + +(defn propagate-change [^objects buffer i x] + (aset ^objects (aget buffer i) item-slot-state x) buffer) + +(defn propagate-freeze [^objects buffer i] + (aset ^objects (aget buffer i) item-slot-frozen true) buffer) + +(defn detach [^objects buffer i] + (propagate-freeze buffer i) (aset buffer i nil) buffer) + +(defn item-step [^Item item] + (let [^objects state (.-state item) + ^objects parent (aget state item-slot-parent)] + (set-next item (aget parent slot-head-step)) + (aset parent slot-head-step item))) + +(defn item-done [^Item item] + (let [^objects state (.-state item) + ^objects parent (aget state item-slot-parent)] + (set-next item (aget parent slot-head-done)) + (aset parent slot-head-done item))) + +(defn get-cursor [^objects state] + (fn [step done] + (let [^objects parent (aget state item-slot-parent) + held (acquire parent)] + (if (nil? (aget state item-slot-current)) + (let [item (->Item state step done (object-array 1))] + (aset state item-slot-current item) (item-step item) + (release parent held) item) + (do (release parent held) + (throw (#?(:clj Error. :cljs js/Error.) "Illegal concurrent cursor."))))))) + +(defn create-item [^objects parent i] + (let [state (object-array item-slots) + ^objects buffer (aget parent slot-buffer)] + (aset state item-slot-parent parent) + (aset state item-slot-frozen false) + (aset buffer i state) parent)) + +(defn input-transfer [^objects parent] + (when (aget parent slot-busy) + (loop [] + (try + (let [{:keys [grow degree shrink permutation change freeze]} @(aget parent slot-input) + ^objects buffer (ensure-capacity parent degree) + created (range (- degree grow) degree) + iperm (p/inverse permutation) + indices (into #{} (map (fn [i] (iperm i i))) created)] + (reduce create-item parent created) + (reduce apply-cycle buffer (p/decompose permutation)) + (reduce detach buffer (range (- degree shrink) degree)) + (reduce-kv propagate-change buffer change) + (reduce propagate-freeze buffer freeze) + (let [diff {:grow grow + :degree degree + :shrink shrink + :permutation permutation + :change (reduce + (fn [m i] + (assoc m i (get-cursor (aget buffer i)))) + {} indices) + :freeze indices}] + (aset parent slot-diff + (if-some [d (aget parent slot-diff)] + (d/combine d diff) diff)))) + (catch #?(:clj Throwable :cljs :default) e + (aset parent slot-input nil) + (aset parent slot-diff e))) + (when (aset parent slot-busy (not (aget parent slot-busy))) (recur))))) + +(defn enqueue-all [^objects parent head] + (let [^objects buffer (aget parent slot-buffer)] + (loop [i 0 + h (let [^Item output (aget parent slot-output)] + (when (identical? output (get-next output)) + (set-next output head) output))] + (if (< i (alength buffer)) + (if-some [^objects state (aget buffer i)] + (if-some [^Item item (aget state item-slot-current)] + (recur (inc i) + (if (identical? item (get-next item)) + (do (set-next item h) item) h)) h) h) h)))) + +(defn item-cancel [^Item item] + (let [^objects state (.-state item) + parent (aget state item-slot-parent) + held (acquire parent)] + (when (identical? item (aget state item-slot-current)) + (aset state item-slot-current nil) + (when (identical? item (get-next item)) + (item-step item))) + (release parent held))) + +(defn item-transfer [^Item item] + (let [^objects state (.-state item) + parent (aget state item-slot-parent) + held (acquire parent)] + (if (identical? item (aget state item-slot-current)) + (do (input-transfer parent) + (let [diff (aget state item-slot-state)] + (if (or (aget state item-slot-frozen) (aget parent slot-done)) + (item-done item) (set-next item item)) + (release parent held) diff)) + (do (item-done item) + (release parent held) + (throw (Cancelled. "Cursor cancelled.")))))) + +(defn cancel [^objects parent] + (when-some [ps (aget parent slot-input)] (ps))) + +(defn transfer [^objects parent] + (let [held (acquire parent) + output (aget parent slot-output)] + (input-transfer parent) + (let [diff (aget parent slot-diff)] + (aset parent slot-diff nil) + (if (aget parent slot-done) + (do (set-next output (aget parent slot-head-done)) + (aset parent slot-head-done output)) + (set-next output output)) + (if (nil? (aget parent slot-input)) + (do (release parent held) (throw diff)) + (do (release parent held) diff))))) + +(defn flow [incseq] + (fn [step done] + (let [parent (object-array slots) + output (->Item parent step done (object-array 1))] + (set-next output output) + (aset parent slot-lock #?(:clj (ReentrantLock.) :cljs false)) + (aset parent slot-busy false) + (aset parent slot-buffer (object-array 1)) + (aset parent slot-output output) + (aset parent slot-input + (incseq #(let [held (acquire parent)] + (aset parent slot-busy (not (aget parent slot-busy))) + (aset parent slot-head-step (enqueue-all parent (aget parent slot-head-step))) + (release parent held)) + #(let [held (acquire parent)] + (aset parent slot-done true) + (aset parent slot-head-done (enqueue-all parent (aget parent slot-head-done))) + (release parent held)))) + (->Ps parent)))) + +(tests + (let [q #?(:clj (let [q (java.util.LinkedList.)] + (fn + ([] (.remove q)) + ([x] (.add q x) nil))) + :cljs (let [q (make-array 0)] + (fn + ([] + (when (zero? (alength q)) + (throw (js/Error. "No such element."))) + (.shift q)) + ([x] (.push q x) nil)))) + ps ((flow (fn [step done] + (q [step done]) + (step) + (reify + IFn + (#?(:clj invoke :cljs -invoke) [_] + (q :cancel)) + IDeref + (#?(:clj deref :cljs -deref) [_] + (q))))) + #(q :step) #(q :done)) + [step done] (q) + _ (is (::rcf/= (q) :step)) + _ (q (assoc (d/empty-diff 2) + :change {0 :foo 1 :bar} + :grow 2)) + diff @ps + _ (is (::rcf/= (dissoc diff :change) + (assoc (dissoc (d/empty-diff 2) :change) + :freeze #{0 1} + :grow 2))) + [item0 item1] (map (:change diff) [0 1]) + ps0 (item0 #(q :step0) #(q :done0)) + _ (is (::rcf/= (q) :step0)) + _ (is (::rcf/= @ps0 :foo)) + ps1 (item1 #(q :step1) #(q :done1)) + _ (is (::rcf/= (q) :step1)) + _ (step) + _ (is (::rcf/= (hash-set (q) (q)) #{:step :step0})) + _ (q (assoc (d/empty-diff 2) + :permutation {0 1 1 0} + :change {1 :foo 0 :BAR})) + _ (is (::rcf/= @ps (assoc (d/empty-diff 2) :permutation {0 1 1 0}))) + _ (is (::rcf/= @ps1 :BAR)) + _ (is (::rcf/= @ps0 :foo)) + _ (ps0) + _ (is (::rcf/= (q) :step0)) + ps0- (item0 #(q :step0-) #(q :done0-)) + _ (is (::rcf/= (q) :step0-)) + _ (is (::rcf/= nil (try @ps0 (catch Cancelled _)))) + _ (is (::rcf/= (q) :done0)) + _ (step) + _ (is (::rcf/= (hash-set (q) (q)) #{:step :step1})) + _ (q (assoc (d/empty-diff 2) + :change {1 :FOO})) + _ (is (::rcf/= @ps0- :FOO)) + _ (is (::rcf/= nil (try (item1 #(q :step1-) #(q :done1-)) + (catch #?(:clj Error :cljs js/Error) _)))) + _ (step) + _ (is (::rcf/= (hash-set (q)) #{:step0-})) + _ (q (assoc (d/empty-diff 2) + :freeze #{0 1})) + _ (is (::rcf/= @ps1 :BAR)) + _ (is (::rcf/= (q) :done1)) + _ (is (::rcf/= @ps0- :FOO)) + _ (is (::rcf/= (q) :done0-)) + _ (is (::rcf/= @ps (d/empty-diff 2))) + _ (done) + _ (is (::rcf/= (q) :done))])) \ No newline at end of file diff --git a/src/hyperfiddle/incseq/perm_impl.cljc b/src/hyperfiddle/incseq/perm_impl.cljc new file mode 100644 index 000000000..7322e9e53 --- /dev/null +++ b/src/hyperfiddle/incseq/perm_impl.cljc @@ -0,0 +1,119 @@ +(ns hyperfiddle.incseq.perm-impl + (:refer-clojure :exclude [cycle]) + (:require [hyperfiddle.rcf :refer [tests]])) + +(defn inverse [p] (into {} (map (juxt val key)) p)) + +(defn cycle + ([_] {}) + ([i & js] (zipmap `(~i ~@js) `(~@js ~i)))) + +(defn rotation [i j] + (case (compare i j) + -1 (apply cycle (range i (inc j) +1)) + 0 {} + +1 (apply cycle (range i (dec j) -1)))) + +(defn split-swap [i l r] + (let [l (int l) + r (int r)] + (case l + 0 {} + (case r + 0 {} + (let [j (unchecked-add-int i l) + k (unchecked-add-int j r)] + (zipmap (range i k) + (concat (range j k) + (range i j)))))))) + +(defn arrange [v p] + (persistent! + (reduce-kv + (fn [r i j] + (assoc! r i (nth v j))) + (transient v) p))) + +(defn decompose [p] + (loop [p p + cs #{}] + (case p + {} cs + (let [[i j] (first p)] + (let [c (loop [c [i] + j j] + (let [c (conj c j) + j (p j)] + (if (== i j) + c (recur c j))))] + (recur (apply dissoc p c) + (conj cs c))))))) + +(defn compose + ([] {}) + ([x] x) + ([x y] + (reduce-kv + (fn [r i j] + (let [k (y j j)] + (if (== i k) + (dissoc r i) + (assoc r i k)))) + y x)) + ([x y & zs] + (reduce compose (compose x y) zs))) + +(defn order [p] + (loop [o 1, q p] + (case q + {} o + (recur (unchecked-inc o) + (compose p q))))) + +(defn involution? [p] + (and (not= {} p) (= {} (compose p p)))) + +(defn transposition? [p] + (= 2 (count p))) + +(defn recompose [cycles] + (->> cycles + (eduction (map (partial apply cycle))) + (reduce compose (compose)))) + +(tests "permutations" + (decompose {0 1, 1 4, 2 3, 3 2, 4 0}) := + #{[0 1 4] [2 3]} + + (recompose #{[0 1 4] [2 3]}) := + {0 1, 1 4, 2 3, 3 2, 4 0} + + (decompose (inverse {0 1, 1 4, 2 3, 3 2, 4 0})) := + #{[1 0 4] [3 2]} + + (recompose #{[1 0 4] [3 2]}) := + {0 4, 1 0, 2 3, 3 2, 4 1} + + (arrange [0 1 2 3 4] {0 1, 1 4, 2 3, 3 2, 4 0}) := + [1 4 3 2 0] + + (arrange [:a :b :c :d :e] {0 1, 1 4, 2 3, 3 2, 4 0}) := + [:b :e :d :c :a] + + (compose + (cycle 1 3 2 4) + (cycle 1 4 2 3)) := {} + + (inverse (split-swap 4 2 3)) := (split-swap 4 3 2) + + (order (cycle 2)) := 1 + (order (cycle 2 3)) := 2 + (order (cycle 2 3 4)) := 3 + (order (compose (cycle 0 1) (cycle 2 3 4))) := 6 + + (involution? (cycle 2)) := false + (involution? (cycle 2 3)) := true + (involution? (cycle 2 3 4)) := false + + (transposition? (cycle 2 3)) := true + (transposition? (cycle 2 3 4)) := false) \ No newline at end of file From 38d18b515d768709f502c0efd70cd099a7021686 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Thu, 4 Apr 2024 17:27:43 +0200 Subject: [PATCH 175/428] variadic recur consistent with clojure --- src/hyperfiddle/electric/impl/runtime_de.cljc | 2 +- src/hyperfiddle/electric_de.cljc | 15 ++++++++------- test/hyperfiddle/electric_de_test.cljc | 11 +---------- 3 files changed, 10 insertions(+), 18 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 1c573d779..ac4b067ea 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -256,7 +256,7 @@ T T T -> (EXPR T) (apply bind-args (bind-self ctor) args) (let [[fixed map? ctor] (get-variadic F arity)] (bind (apply bind-args (bind-self ctor) (take fixed args)) - -1 (apply ap (pure (varargs map?)) (drop fixed args))))))) + fixed (apply ap (pure (varargs map?)) (drop fixed args))))))) (defn peer-root [^Peer peer key] ((.-defs peer) key)) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index fcde639b8..ac2fb8c9d 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -65,11 +65,12 @@ Returns the successive states of items described by `incseq`. _ (check-only-one-vararg! ?name (mapv first varargs)) _ (check-arity-conflicts! ?name (mapv first positionals) (ffirst varargs))] (into (if-some [[args & body] (first varargs)] - {-1 [(-> args count (- 2)) - (map? (peek args)) - `(::lang/ctor - (let [~@(interleave (-> args pop pop) (map dget (range))) - ~(peek args) ~(dget -1)] ~@body))]} {}) + (let [fixed (-> args pop pop)] + {-1 [(count fixed) + (map? (peek args)) + `(::lang/ctor + (let [~@(interleave fixed (map dget (range))) + ~(peek args) ~(dget (count fixed))] ~@body))]}) {}) (map (cc/fn [[args & body]] [(count args) `(::lang/ctor @@ -221,12 +222,12 @@ this tuple. Returns the concatenation of all body results as a single vector. static (pop static)] (if (< fixed (count static)) (recur args static) - (cc/apply r/bind-args (r/bind (r/bind-self ctor) -1 (::lang/pure (cc/apply (r/varargs map?) args))) static)))) + (cc/apply r/bind-args (r/bind (r/bind-self ctor) fixed (::lang/pure (cc/apply (r/varargs map?) args))) static)))) (loop [args args static static] (if (< (count static) fixed) (recur (next args) (conj static (::lang/pure (first args)))) - (cc/apply r/bind-args (r/bind (r/bind-self ctor) -1 (::lang/pure (cc/apply (r/varargs map?) args))) static)))))))) + (cc/apply r/bind-args (r/bind (r/bind-self ctor) fixed (::lang/pure (cc/apply (r/varargs map?) args))) static)))))))) (hyperfiddle.electric-de/defn Apply ([F a] diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 750eaa986..24927914f 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -2018,20 +2018,11 @@ % := nil % := :done)) (tests "self-recur by recur, varargs" - (with ((l/single {} ($ (e/fn [& xs] (if (tap (seq xs)) (recur) (tap :done))) 0 1 2)) tap tap) + (with ((l/single {} ($ (e/fn [& xs] (if (tap (seq xs)) (recur nil) (tap :done))) 0 1 2)) tap tap) % := [0 1 2] % := nil % := :done)) -(tests "self-recur by recur, varargs & multi-arity" - ;; Note this differs from clojure where varargs recur doesn't take variadic args anymore but a collection. - ;; In electric there's no tail recursion so `recur` is used as an anonymous self-call. - ;; This means a multi-arity fn can recur to other arities. - ;; As a side effect we have to keep varargs as varargs on recur. - (with ((l/single {} ($ (e/fn ([] (tap :done)) ([& xs] (if (tap (seq xs)) (recur) (tap :no)))) 0 1 2)) tap tap) - % := '(0 1 2) - % := :done)) - #?(:clj (tests "e/fn multi-arity mistakes" (try (lang/expand-all {} '(e/fn Named ([x] x) ([y] y))) From fc1dfa61a7bba30f07002cc06dd319fb7caa1ad6 Mon Sep 17 00:00:00 2001 From: xificurC Date: Fri, 5 Apr 2024 07:32:41 +0200 Subject: [PATCH 176/428] fix binding nodes, make self-reference dynamic --- src/hyperfiddle/electric/impl/lang_de2.clj | 18 ++++++++++++------ test/hyperfiddle/electric_de_test.cljc | 8 ++++++++ 2 files changed, 20 insertions(+), 6 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 80de10e67..a2307eab3 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -356,7 +356,8 @@ (clojure.lang.Reflector/getField cls (name sym) true))))) (defn get-children-e [ts e] (-> ts :ave ::parent (get e))) -(defn get-child-e [ts e] (ca/check some? (first (get-children-e ts e)) {:e e})) +(defn ?get-child-e [ts e] (first (get-children-e ts e))) +(defn get-child-e [ts e] (ca/is (first (get-children-e ts e)) some? "no child" {:e e, :nd (ts/->node ts e)})) (defn get-root-e [ts] (get-child-e ts '_)) (defn ?add-source-map [{{::keys [->id]} :o :as ts} pe form] @@ -449,8 +450,10 @@ (defn get-lookup-key [sym env] (if (symbol? sym) - (let [{::keys [type sym]} (resolve-symbol sym env)] - (case type + (let [it (resolve-symbol sym env)] + (case (::type it) + (::var) (keyword (::sym it)) + (::node) (keyword (::node it)) (::static) (throw (ex-info (str "`" sym "` did not resolve as a var") {::form sym})) #_else (keyword sym))) sym)) @@ -631,8 +634,11 @@ ::sym form, ::uid (->uid)}) (::local) (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form})) - (::self) (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) - (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v (list form)})) + (::self) (let [ce (->id)] + (-> ts + (ts/add {:db/id e, ::parent pe, ::type ::lookup, ::sym (keyword (ns-qualify form))}) + (ts/add {:db/id ce, ::parent e, ::type ::pure}) + (ts/add {:db/id (->id), ::parent ce, ::type ::literal, ::v (list form)}))) (::static ::var) (if (::static-vars env) (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form})) @@ -702,7 +708,7 @@ first (ts/->node ts) ::free-idx))))) (ts/find ts ::ctor-free (e->uid ts e)))) ::call (list `r/join (list `r/call 'frame (::call-idx (ts/->node ts e)))) - ::lookup (list `r/lookup 'frame (::sym nd)) + ::lookup (list* `r/lookup 'frame (::sym nd) (when-some [c (?get-child-e ts e)] (list (rec c)))) ::mklocal (recur (get-ret-e ts (get-child-e ts e))) ::bindlocal (recur (get-ret-e ts (->bindlocal-body-e ts e))) ::localref diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 24927914f..7e71de0b7 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -2175,6 +2175,14 @@ ($ Even? 2)))) tap tap) % := true)) +(e/defn Self [] Self) +(tests + (with ((l/single {} + (let [Bar Self] + (binding [Self (e/fn [] 111)] + (tap (= Bar (e/$ Bar)))))) tap tap) + % := false)) + (let [{:keys [tested skipped]} @stats, all (+ tested skipped)] (prn '===) (println 'tested tested (str (long (* (/ tested all) 100)) "%")) From 00c7acbff7db21316c3938d68fa164620a5a364e Mon Sep 17 00:00:00 2001 From: xificurC Date: Fri, 5 Apr 2024 10:27:50 +0200 Subject: [PATCH 177/428] fix most tests --- src/hyperfiddle/electric/impl/runtime_de.cljc | 2 +- .../electric/impl/compiler_test.cljc | 102 +++++++++--------- .../electric/impl/expand_de_test.cljc | 2 +- test/hyperfiddle/electric_de_test.cljc | 35 +++--- 4 files changed, 67 insertions(+), 74 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index ac4b067ea..d70c3d57b 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -230,7 +230,7 @@ T T T -> (EXPR T) (bind ctor :recur (pure ctor))) (defn arity-mismatch [arity] - (throw (Error. (str "Wrong number of args (" arity ")")))) + (throw (error (str "Wrong number of args (" arity ")")))) (defn get-variadic [F arity] (if-some [[fixed map? ctor] (F -1)] diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index 67491fea5..06a66c55a 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -28,9 +28,10 @@ (try (apply f args) (catch Throwable e (find-source-map-info path)))) +(defn ->code [v] `(fn tm/_ ([tm/_] (case tm/_ ~@(interleave (range) v))))) + (defmacro match [code matcher] - `(let [ret# ~code, match# (tm/test-match ret# ~matcher)] - ;; (t/is (= ret# match#)) + `(let [ret# ~code, matcher# (->code ~matcher) match# (tm/test-match ret# matcher#)] ret# := match# (when (not= ret# match#) (fipp.edn/pprint match#)) match#)) @@ -100,7 +101,7 @@ (match (l/test-compile ::Main (prn (e/client (::lang/call (e/server (::lang/ctor)))))) `[(r/cdef 0 [:client] [:client] nil (fn [~'frame] - (r/define-call ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) + (r/define-call ~'frame 0 (r/pure (r/ctor ::Main 1))) (r/define-node ~'frame 0 (r/join (r/call ~'frame 0))) (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure prn)) (r/node ~'frame 0)))) @@ -175,7 +176,7 @@ (match (l/test-compile ::Main (::lang/ctor :foo)) `[(r/cdef 0 [] [] nil (fn [~'frame] - (r/pure (r/make-ctor ~'frame ::Main 1)))) + (r/pure (r/ctor ::Main 1)))) (r/cdef 0 [] [] nil (fn [~'frame] (r/pure :foo)))]) @@ -184,7 +185,7 @@ `[(r/cdef 0 [nil] [] nil (fn [~'frame] (r/define-node ~'frame 0 (r/pure 1)) - (r/pure (r/make-ctor ~'frame ::Main 1 (r/node ~'frame 0))))) + (r/pure (r/ctor ::Main 1 (r/node ~'frame 0))))) (r/cdef 1 [] [] nil (fn [~'frame] (r/free ~'frame 0)))]) @@ -192,7 +193,7 @@ (match (l/test-compile ::Main (let [a 1] (::lang/ctor (let [a 2] a)))) `[(r/cdef 0 [] [] nil (fn [~'frame] - (r/pure (r/make-ctor ~'frame ::Main 1)))) + (r/pure (r/ctor ::Main 1)))) (r/cdef 0 [] [] nil (fn [~'frame] (r/pure 2)))]) @@ -201,10 +202,10 @@ `[(r/cdef 0 [nil] [] nil (fn [~'frame] (r/define-node ~'frame 0 (r/pure 1)) - (r/pure (r/make-ctor ~'frame ::Main 1 (r/node ~'frame 0))))) + (r/pure (r/ctor ::Main 1 (r/node ~'frame 0))))) (r/cdef 1 [] [] nil (fn [~'frame] - (r/pure (r/make-ctor ~'frame ::Main 2 (r/free ~'frame 0))))) + (r/pure (r/ctor ::Main 2 (r/free ~'frame 0))))) (r/cdef 1 [] [] nil (fn [~'frame] (r/free ~'frame 0)))]) @@ -213,13 +214,13 @@ `[(r/cdef 0 [nil] [] nil (fn [~'frame] (r/define-node ~'frame 0 (r/pure 1)) - (r/pure (r/make-ctor ~'frame ::Main 1 (r/node ~'frame 0))))) + (r/pure (r/ctor ::Main 1 (r/node ~'frame 0))))) (r/cdef 1 [nil] [] nil (fn [~'frame] (r/define-node ~'frame 0 (r/pure 2)) (r/ap (r/pure clojure.core/vector) (r/free ~'frame 0) - (r/pure (r/make-ctor ~'frame ::Main 2 (r/node ~'frame 0)))))) + (r/pure (r/ctor ::Main 2 (r/node ~'frame 0)))))) (r/cdef 1 [] [] nil (fn [~'frame] (r/free ~'frame 0)))]) @@ -228,13 +229,13 @@ `[(r/cdef 0 [nil] [] nil (fn [~'frame] (r/define-node ~'frame 0 (r/pure 1)) - (r/pure (r/make-ctor ~'frame ::Main 1 (r/node ~'frame 0))))) + (r/pure (r/ctor ::Main 1 (r/node ~'frame 0))))) (r/cdef 1 [] [] nil (fn [~'frame] - (r/pure (r/make-ctor ~'frame ::Main 2 (r/free ~'frame 0))))) + (r/pure (r/ctor ::Main 2 (r/free ~'frame 0))))) (r/cdef 1 [] [] nil (fn [~'frame] - (r/pure (r/make-ctor ~'frame ::Main 3 (r/free ~'frame 0))))) + (r/pure (r/ctor ::Main 3 (r/free ~'frame 0))))) (r/cdef 1 [] [] nil (fn [~'frame] (r/free ~'frame 0)))]) @@ -244,12 +245,12 @@ (fn [~'frame] (r/define-node ~'frame 0 (r/pure 1)) (r/define-node ~'frame 1 (r/pure 2)) - (r/pure (r/make-ctor ~'frame ::Main 1 (r/node ~'frame 0) (r/node ~'frame 1))))) + (r/pure (r/ctor ::Main 1 (r/node ~'frame 0) (r/node ~'frame 1))))) (r/cdef 2 [] [] nil (fn [~'frame] (r/ap (r/pure clojure.core/vector) (r/free ~'frame 0) - (r/pure (r/make-ctor ~'frame ::Main 2 (r/free ~'frame 1)))))) + (r/pure (r/ctor ::Main 2 (r/free ~'frame 1)))))) (r/cdef 1 [] [] nil (fn [~'frame] (r/free ~'frame 0)))]) @@ -259,12 +260,12 @@ (fn [~'frame] (r/define-node ~'frame 0 (r/pure 2)) (r/define-node ~'frame 1 (r/pure 1)) - (r/pure (r/make-ctor ~'frame ::Main 1 (r/node ~'frame 0) (r/node ~'frame 1))))) + (r/pure (r/ctor ::Main 1 (r/node ~'frame 0) (r/node ~'frame 1))))) (r/cdef 2 [] [] nil (fn [~'frame] (r/ap (r/pure clojure.core/vector) (r/free ~'frame 0) - (r/pure (r/make-ctor ~'frame ::Main 2 (r/free ~'frame 1)))))) + (r/pure (r/ctor ::Main 2 (r/free ~'frame 1)))))) (r/cdef 1 [] [] nil (fn [~'frame] (r/free ~'frame 0)))]) @@ -272,7 +273,7 @@ (match (l/test-compile ::Main (let [x (::lang/ctor :foo)] x)) `[(r/cdef 0 [] [] nil (fn [~'frame] - (r/pure (r/make-ctor ~'frame ::Main 1)))) + (r/pure (r/ctor ::Main 1)))) (r/cdef 0 [] [] nil (fn [~'frame] (r/pure :foo)))]) @@ -283,7 +284,7 @@ (fn [~'frame] (r/define-node ~'frame 0 (r/pure "fizz")) (r/define-node ~'frame 1 (r/pure "buzz")) - (r/pure (r/make-ctor ~'frame ::Main 1 (r/node ~'frame 0) (r/node ~'frame 1))))) + (r/pure (r/ctor ::Main 1 (r/node ~'frame 0) (r/node ~'frame 1))))) (r/cdef 2 [] [] nil (fn [~'frame] (r/ap (r/lookup ~'frame :clojure.core/str (r/pure clojure.core/str)) @@ -294,25 +295,25 @@ (match (l/test-compile ::Main (::lang/call (::lang/ctor :foo))) `[(r/cdef 0 [] [nil] nil (fn [~'frame] - (r/define-call ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) + (r/define-call ~'frame 0 (r/pure (r/ctor ::Main 1))) (r/join (r/call ~'frame 0)))) (r/cdef 0 [] [] nil (fn [~'frame] (r/pure :foo)))]) (match (l/test-compile ::Main (let [x (::lang/ctor :foo), y x] (::lang/call y))) - `[(r/cdef 0 [] [nil] nil + `[(r/cdef 0 [nil] [nil] nil (fn [~'frame] - (r/define-call ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) + (r/define-node ~'frame 0 (r/pure (r/ctor ::Main 1))) + (r/define-call ~'frame 0 (r/node ~'frame 0)) (r/join (r/call ~'frame 0)))) (r/cdef 0 [] [] nil - (fn [~'frame] - (r/pure :foo)))]) + (fn [~'frame] (r/pure :foo)))]) (match (l/test-compile ::Main (vector 1 (::lang/call (::lang/ctor :foo)))) `[(r/cdef 0 [] [nil] nil (fn [~'frame] - (r/define-call ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) + (r/define-call ~'frame 0 (r/pure (r/ctor ::Main 1))) (r/ap (r/lookup ~'frame :clojure.core/vector (r/pure clojure.core/vector)) (r/pure 1) (r/join (r/call ~'frame 0))))) @@ -322,7 +323,7 @@ (match (l/test-compile ::Main (let [x (::lang/ctor :foo)] [(::lang/call x) (::lang/call x)])) `[(r/cdef 0 [nil] [nil nil] nil (fn [~'frame] - (r/define-node ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) + (r/define-node ~'frame 0 (r/pure (r/ctor ::Main 1))) (r/define-call ~'frame 0 (r/node ~'frame 0)) (r/define-call ~'frame 1 (r/node ~'frame 0)) (r/ap (r/pure clojure.core/vector) @@ -334,8 +335,8 @@ (match (l/test-compile ::Main [(::lang/call (::lang/ctor :foo)) (::lang/call (::lang/ctor :bar))]) `[(r/cdef 0 [] [nil nil] nil (fn [~'frame] - (r/define-call ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) - (r/define-call ~'frame 1 (r/pure (r/make-ctor ~'frame ::Main 2))) + (r/define-call ~'frame 0 (r/pure (r/ctor ::Main 1))) + (r/define-call ~'frame 1 (r/pure (r/ctor ::Main 2))) (r/ap (r/pure clojure.core/vector) (r/join (r/call ~'frame 0)) (r/join (r/call ~'frame 1))))) @@ -350,11 +351,11 @@ `[(r/cdef 0 [nil] [nil] nil (fn [~'frame] (r/define-node ~'frame 0 (r/pure :foo)) - (r/define-call ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1 (r/node ~'frame 0)))) + (r/define-call ~'frame 0 (r/pure (r/ctor ::Main 1 (r/node ~'frame 0)))) (r/join (r/call ~'frame 0)))) (r/cdef 1 [] [] nil (fn [~'frame] - (r/pure (r/make-ctor ~'frame ::Main 2 (r/free ~'frame 0))))) + (r/pure (r/ctor ::Main 2 (r/free ~'frame 0))))) (r/cdef 1 [] [] nil (fn [~'frame] (r/free ~'frame 0)))])) @@ -362,11 +363,12 @@ (tests "test-conditionals" ;; ({nil (ctor :y)} :x (ctor :z)) (match (l/test-compile ::Main (case :x nil :y :z)) - `[(r/cdef 0 [] [nil] nil + `[(r/cdef 0 [nil] [nil] nil (fn [~'frame] - (r/define-call ~'frame 0 (r/ap (r/ap (r/pure (fn* [] (hash-map 'nil (r/make-ctor ~'frame ::Main 1))))) - (r/pure :x) - (r/pure (r/make-ctor ~'frame ::Main 2)))) + (r/define-node ~'frame 0 (r/pure (r/ctor ::Main 1))) + (r/define-call ~'frame 0 (r/ap (r/ap (r/pure hash-map) (r/pure 'nil) (r/node ~'frame 0)) + (r/pure :x) + (r/pure (r/ctor ::Main 2)))) (r/join (r/call ~'frame 0)))) (r/cdef 0 [] [] nil (fn [~'frame] (r/pure :y))) (r/cdef 0 [] [] nil (fn [~'frame] (r/pure :z)))]) @@ -374,12 +376,12 @@ (match (l/test-compile ::Main (case 'foo (foo bar) :share-this :else)) `[(r/cdef 0 [nil] [nil] nil (fn [~'frame] - (r/define-node ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) + (r/define-node ~'frame 0 (r/pure (r/ctor ::Main 1))) (r/define-call ~'frame 0 (r/ap (r/ap (r/pure clojure.core/hash-map) (r/pure '~'foo) (r/node ~'frame 0) (r/pure '~'bar) (r/node ~'frame 0)) (r/pure '~'foo) - (r/pure (r/make-ctor ~'frame ::Main 2)))) + (r/pure (r/ctor ::Main 2)))) (r/join (r/call ~'frame 0)))) (r/cdef 0 [] [] nil (fn [~'frame] @@ -391,12 +393,12 @@ (match (l/test-compile ::Main (if 1 2 3)) `[(r/cdef 0 [nil] [nil] nil (fn [~'frame] - (r/define-node ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) + (r/define-node ~'frame 0 (r/pure (r/ctor ::Main 1))) (r/define-call ~'frame 0 (r/ap (r/ap (r/pure clojure.core/hash-map) (r/pure 'nil) (r/node ~'frame 0) (r/pure 'false) (r/node ~'frame 0)) (r/pure 1) - (r/pure (r/make-ctor ~'frame ::Main 2)))) + (r/pure (r/ctor ::Main 2)))) (r/join (r/call ~'frame 0)))) (r/cdef 0 [] [] nil (fn [~'frame] @@ -424,7 +426,7 @@ (match (l/test-compile ::Main (e/client (e/ctor (let [x 1] [x x])))) `[(r/cdef 0 [] [] :client (fn [~'frame] - (r/pure (r/make-ctor ~'frame ::Main 1)))) + (r/pure (r/ctor ::Main 1)))) (r/cdef 0 [nil] [] nil (fn [~'frame] (r/define-node ~'frame 0 (r/pure 1)) @@ -436,12 +438,14 @@ (match (l/test-compile ::Main (binding [inc dec, dec inc] (inc (dec 0)))) - `[(r/cdef 0 [] [nil] nil - (fn [~'frame] - (r/define-call ~'frame 0 - (r/ap (r/pure (fn* [] (r/bind (r/make-ctor ~'frame ::Main 1) - :clojure.core/inc (r/lookup ~'frame :clojure.core/dec (r/pure dec)) - :clojure.core/dec (r/lookup ~'frame :clojure.core/inc (r/pure inc))))))) + `[(r/cdef 0 [nil nil] [nil] nil + (fn [~'frame] + (r/define-node ~'frame 0 (r/lookup ~'frame :clojure.core/dec (r/pure dec))) + (r/define-node ~'frame 1 (r/lookup ~'frame :clojure.core/inc (r/pure inc))) + (r/define-call ~'frame 0 (r/ap (r/pure (fn* [] + (r/bind (r/ctor ::Main 1) + :clojure.core/inc (r/node ~'frame 0) + :clojure.core/dec (r/node ~'frame 1)))))) (r/join (r/call ~'frame 0)))) (r/cdef 0 [] [] nil (fn [~'frame] @@ -459,12 +463,12 @@ (match (l/test-compile ::Main (::lang/call (::lang/call (::lang/ctor (::lang/ctor :foo))))) `[(r/cdef 0 [] [nil nil] nil (fn [~'frame] - (r/define-call ~'frame 0 (r/pure (r/make-ctor ~'frame ::Main 1))) ; must come first + (r/define-call ~'frame 0 (r/pure (r/ctor ::Main 1))) ; must come first (r/define-call ~'frame 1 (r/join (r/call ~'frame 0))) (r/join (r/call ~'frame 1)))) (r/cdef 0 [] [] nil (fn [~'frame] - (r/pure (r/make-ctor ~'frame ::Main 2)))) + (r/pure (r/ctor ::Main 2)))) (r/cdef 0 [] [] nil (fn [~'frame] (r/pure :foo)))]) @@ -478,9 +482,9 @@ (match (l/test-compile ::Main (let [x 1] [(::lang/call (::lang/ctor 1)) x x (::lang/call (::lang/ctor 2))])) `[(r/cdef 0 [nil] [nil nil] nil (fn [~'frame] - (r/define-call ~'frame 0 (r/pure (r/make-ctor ~'frame :hyperfiddle.electric.impl.compiler-test/Main 1))) + (r/define-call ~'frame 0 (r/pure (r/ctor :hyperfiddle.electric.impl.compiler-test/Main 1))) (r/define-node ~'frame 0 (r/pure 1)) - (r/define-call ~'frame 1 (r/pure (r/make-ctor ~'frame :hyperfiddle.electric.impl.compiler-test/Main 2))) + (r/define-call ~'frame 1 (r/pure (r/ctor :hyperfiddle.electric.impl.compiler-test/Main 2))) (r/ap (r/pure clojure.core/vector) (r/join (r/call ~'frame 0)) (r/node ~'frame 0) diff --git a/test/hyperfiddle/electric/impl/expand_de_test.cljc b/test/hyperfiddle/electric/impl/expand_de_test.cljc index 2a5c3061d..054a5c386 100644 --- a/test/hyperfiddle/electric/impl/expand_de_test.cljc +++ b/test/hyperfiddle/electric/impl/expand_de_test.cljc @@ -101,7 +101,7 @@ ;; (all '(catch (-> 1 inc))) := '(catch (inc 1)) (let [x (all '(loop [with-open inc, x 2] (-> x with-open)))] - (first x) := 'binding + (first x) := ::l/call (has-line-meta? x) := true) (let [x (all '(binding [x (-> 1 inc)] (-> x inc)))] diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 7e71de0b7..3f61a2d80 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -1,5 +1,5 @@ (ns hyperfiddle.electric-de-test - (:require [hyperfiddle.rcf :as rcf :refer [tap with %]] + (:require [hyperfiddle.rcf :as rcf :refer [tap with % tests]] [hyperfiddle.electric-de :as e :refer [$]] [hyperfiddle.electric-local-def-de :as l] [hyperfiddle.electric.impl.io :as electric-io] @@ -9,22 +9,14 @@ #?(:cljs [hyperfiddle.goog-calls-test-de]) [clojure.string :as str] [missionary.core :as m]) - #?(:cljs (:require-macros [hyperfiddle.electric-de-test :refer [skip tests failing]])) + #?(:cljs (:require-macros [hyperfiddle.electric-de-test :refer [skip failing]])) (:import [hyperfiddle.electric Pending Failure] [missionary Cancelled] #?(:clj [clojure.lang ExceptionInfo]))) -(def stats (atom {:skipped 0, :tested 0})) +(defmacro skip {:style/indent 0} [& _body] `(print "-")) -(defmacro skip {:style/indent 0} [& _body] - `(do (swap! stats update :skipped inc) (pr '~'-))) - -(defmacro tests {:style/indent 0} [& body] - `(do (swap! stats update :tested inc) (rcf/tests ~@body))) - -(defmacro failing {:style/indent 0} [& body] - nil - #_`(try (do ~@body) (catch ~(if (:js-globals &env) :default 'Throwable) e# (prn e#)))) +(defmacro failing {:style/indent 0} [& body] nil) (tests "call on local electric ctor" (with ((l/single {} (let [x (e/fn [] 1)] (tap ($ x)))) tap tap) @@ -1239,6 +1231,7 @@ (def !state (atom 0)) (def global) (tests "Inline cc/fn support" + (reset! !state 0) (with ((l/single {} (let [state (e/watch !state) local [:local state] f (binding [global [:global state]] @@ -1257,8 +1250,8 @@ % := [1 :b '(:c :d) [:local 1] [:global 1]])) (def !state (atom 0)) -(def global) (tests + (reset! !state 0) (with ((l/single {} (let [state (e/watch !state)] (tap [state state]) @@ -1272,9 +1265,9 @@ (tests "cc/fn lexical bindings are untouched" (with ((l/single {} (let [a 1 - b 2 - f (fn [a] (let [b 3] [a b]))] - (tap (f 2)))) tap tap) + b 2 + f (fn [a] (let [b 3] [a b]))] + (tap (f 2)))) tap tap) % := [2 3])) (tests "Inline cc/fn shorthand support" @@ -1323,9 +1316,10 @@ % := [false false true true] % := [false false true true])) +(def !state (atom 0)) +(def global) (tests "Inline letfn support" - (def !state (atom 0)) - (def global) + (reset! !state 0) (with ((l/single {} (let [state (e/watch !state) local [:local state]] (binding [global [:global state]] @@ -2182,8 +2176,3 @@ (binding [Self (e/fn [] 111)] (tap (= Bar (e/$ Bar)))))) tap tap) % := false)) - -(let [{:keys [tested skipped]} @stats, all (+ tested skipped)] - (prn '===) - (println 'tested tested (str (long (* (/ tested all) 100)) "%")) - (println 'skipped skipped (str (long (* (/ skipped all) 100)) "%"))) From 8097f847268718e356feb94b3ce8c5f5c3485bf2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Fri, 5 Apr 2024 15:52:16 +0200 Subject: [PATCH 178/428] fix cljs compat --- src/hyperfiddle/electric/impl/runtime_de.cljc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index ba4bb2515..f7bb276f4 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -783,9 +783,9 @@ T T T -> (EXPR T) ps ((flow expr) step done)] (reify IFn - (invoke [_] (ps)) + (#?(:clj invoke :cljs -invoke) [_] (ps)) IDeref - (deref [_] (call-transfer state @ps))))))) + (#?(:clj deref :cljs -deref) [_] (call-transfer state @ps))))))) (defn define-call "Defines call site id for given frame." From 69f1356636e289e12a103947e7dc604593e3c914 Mon Sep 17 00:00:00 2001 From: xificurC Date: Fri, 5 Apr 2024 16:50:36 +0200 Subject: [PATCH 179/428] compiler: optimize pure-fn calls We already have an optimization where (ap (pure (literal inc)) (pure (literal 1))) simplifies to (r/ap (r/pure (fn* [] (inc 1)))) . This commit allows to simplify to (r/pure (inc 1)) . This optimization is not sound if the fn is impure, e.g. (prn 1). For now we have a crude way to disambiguate pure and impure fns - a set containing the pure fns. --- src/contrib/triple_store.clj | 4 +- src/hyperfiddle/electric/impl/lang_de2.clj | 85 ++++++++++++++-------- test/contrib/triple_store_test.clj | 1 + 3 files changed, 58 insertions(+), 32 deletions(-) diff --git a/src/contrib/triple_store.clj b/src/contrib/triple_store.clj index 2273f156e..57dae4d9d 100644 --- a/src/contrib/triple_store.clj +++ b/src/contrib/triple_store.clj @@ -54,7 +54,9 @@ ] (->TripleStore (:o ts) eav ave vea))) -(defn asc [ts e a v] (upd ts e a (fn [_] v))) +(defn asc + ([ts e a v] (upd ts e a (fn [_] v))) + ([ts e a v & avs] (apply asc (asc ts e a v) e avs))) (defn get-entity [ts e] (get (:eav ts) e)) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index a2307eab3..b099a5bfb 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -357,7 +357,7 @@ (defn get-children-e [ts e] (-> ts :ave ::parent (get e))) (defn ?get-child-e [ts e] (first (get-children-e ts e))) -(defn get-child-e [ts e] (ca/is (first (get-children-e ts e)) some? "no child" {:e e, :nd (ts/->node ts e)})) +(defn get-child-e [ts e] (ca/is (first (get-children-e ts e)) some? (str "no child for " e) {:e e, :nd (ts/->node ts e)})) (defn get-root-e [ts] (get-child-e ts '_)) (defn ?add-source-map [{{::keys [->id]} :o :as ts} pe form] @@ -470,10 +470,10 @@ form (let [ap-arg (gensym "ap-arg")] `(let* [~ap-arg ~form] ~ap-arg))) #_form) -(defn ap-literal [f args pe e env {{::keys [->id]} :o :as ts}] +(defn ap-literal [f args pe e env {{::keys [->id ->uid]} :o :as ts}] (let [ce (->id)] (reduce (fn [ts form] (analyze form e env ts)) - (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap}) + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap, ::uid (->uid)}) (ts/add {:db/id ce, ::parent e, ::type ::pure}) (ts/add {:db/id (->id), ::parent ce, ::type ::literal, ::v f})) (mapv wrap-ap-arg args)))) @@ -501,7 +501,7 @@ (swap! @(requiring-resolve 'cljs.env/*compiler*) assoc-in [:cljs.analyzer/namespaces ns :defs sym] {:name sym})) -(defn e->uid [ts e] (ca/is (::uid (ts/->node ts e)))) +(defn e->uid [ts e] (ca/is (::uid (ts/->node ts e)) some? "node without uid" {:e e, :nd (ts/->node ts e)})) (defn uid->e [ts uid] (first (ca/check #(= 1 (count %)) (ts/find ts ::uid uid)))) (defn reparent-children [ts from-e to-e] (reduce (fn [ts e] (ts/asc ts e ::parent to-e)) ts (ts/find ts ::parent from-e))) @@ -678,6 +678,8 @@ (defn get-node-idx [ts ctor-uid uid] (->> (ts/find ts ::ctor-node ctor-uid, ::ctor-ref uid) first (ts/->node ts) ::node-idx)) +(defn ->thunk [xs] `(fn* [] (~@xs))) + (defn emit [ts e ctor-e env nm] ((fn rec [e] (let [nd (get (:eav ts) e)] @@ -690,7 +692,7 @@ ::node (list `r/lookup 'frame (keyword (::node nd)) (list `r/pure (list `r/resolve 'frame (keyword (::node nd))))) ::join (list `r/join (rec (get-child-e ts e))) ::pure (list `r/pure (rec (get-child-e ts e))) - ::comp (list 'fn* '[] (doall (map rec (get-children-e ts e)))) + ::comp ((or (::comp-fn nd) ->thunk) (eduction (map rec) (get-children-e ts e))) #_(list 'fn* '[] (doall (map rec (get-children-e ts e)))) ::site (recur (get-child-e ts e)) ::ctor (list* `r/ctor nm (::ctor-idx nd) (mapv (fn [e] @@ -729,8 +731,7 @@ (list `r/define-call 'frame (::call-idx (ts/->node ts e)) (emit ts (get-ret-e ts (get-child-e ts e)) ctor-e env nm))) -(defn get-ordered-ctors-e [ts] - (into [] (map (comp first second)) (->> ts :ave ::ctor-idx (sort-by first)))) +(defn get-ordered-ctors-e [ts] (into [] (map (comp first second)) (->> ts :ave ::ctor-idx (sort-by first)))) (defn get-ordered-calls-e [ts ctor-uid] (->> (ts/find ts ::ctor-call ctor-uid) (sort-by #(::call-idx (ts/->node ts %))))) @@ -801,7 +802,7 @@ (case (::type nd) ::ap (map rec (get-children-e ts e)) (::pure ::site) (rec (get-child-e ts e)) - ::comp `(fn [] ~(map rec (get-children-e ts e))) + ::comp ((or (::comp-fn nd) ->thunk) (eduction (map rec) (get-children-e ts e))) ::literal (::v nd) ::ctor `(r/ctor ~nm ~(::ctor-idx nd)) ::mklocal (recur (get-ret-e ts (get-child-e ts e))) @@ -816,28 +817,50 @@ (reduce delete-point-recursively ts ce) ts))) +(def pure-fns '#{clojure.core/vector clojure.core/hash-map}) + +(defn implode-point [ts e] ; remove e, reparent child, keep e as id + (let [nd (ts/->node ts e), ce (get-child-e ts e), cnd (ts/->node ts ce)] + (-> ts (ts/del e) (ts/del ce) (ts/add (assoc cnd :db/id e, ::parent (::parent nd))) (reparent-children ce e)))) + +(defn wrap-point [{{::keys [->id]} :o :as ts} e wrap-nd] ; wrap e in another point `nd`, keeping order + (let [nd (ts/->node ts e), new-e (->id)] + (-> ts (ts/del e) + (ts/add (merge wrap-nd (select-keys nd [:db/id ::parent]))) + (reparent-children e new-e) + (ts/add (assoc nd :db/id new-e, ::parent e))))) + (defn analyze-electric [env {{::keys [->id]} :o :as ts}] - (when (::print-analysis env) (run! prn (ts->reducible ts))) - (let [collapse-ap-with-only-pures + (when (::print-analysis env) (prn :analysis) (run! prn (ts->reducible ts))) + (let [pure-fn? (fn pure-fn? [nd] (and (= ::literal (::type nd)) (pure-fns (::v nd)))) + collapse-ap-with-only-pures (fn collapse-ap-with-only-pures [ts] - ;; (ap (pure x) (pure y) (pure z)) -> (ap (pure (comp x y z))) - (reduce (fn [ts ap-e] - (let [ce (get-children-e ts ap-e)] + (reduce (fn [ts ap-uid] + (let [ap-e (uid->e ts ap-uid), ce (get-children-e ts ap-e)] + (when (::print-ap-collapse env) (prn :ap-collapse) (run! prn (ts->reducible ts))) (if (every? #(= ::pure (::type (ts/->node ts (get-ret-e ts %)))) ce) - (let [pure-e (->id), comp-e (->id)] - (reduce (fn [ts e] - (let [ce (->> e (get-ret-e ts) (get-child-e ts)) - cnd (ts/->node ts ce), newe (->id)] - (-> ts - (ts/add (assoc cnd :db/id newe, ::parent comp-e)) - (reparent-children ce newe) - (delete-point-recursively e)))) - (-> ts - (ts/add {:db/id pure-e, ::parent ap-e, ::type ::pure}) - (ts/add {:db/id comp-e, ::parent pure-e, ::type ::comp})) - ce)) + (if (pure-fn? (->> ce first (get-ret-e ts) (get-child-e ts) (ts/->node ts))) + ;; (ap (pure vector) (pure 1) (pure 2)) -> (pure (comp-with list vector 1 2)) + (-> (reduce (fn [ts ce] + (let [pure-e (get-ret-e ts ce)] + (implode-point ts pure-e))) + (ts/asc ts ap-e ::type ::comp, ::comp-fn list*) ce) + (wrap-point ap-e {::type ::pure})) + ;; (ap (pure x) (pure y) (pure z)) -> (ap (pure (comp-with ->call x y z))) + (let [pure-e (->id), comp-e (->id)] + (reduce (fn [ts e] + (let [ce (->> e (get-ret-e ts) (get-child-e ts)) + cnd (ts/->node ts ce), newe (->id)] + (-> ts + (ts/add (assoc cnd :db/id newe, ::parent comp-e)) + (reparent-children ce newe) + (delete-point-recursively e)))) + (-> ts + (ts/add {:db/id pure-e, ::parent ap-e, ::type ::pure}) + (ts/add {:db/id comp-e, ::parent pure-e, ::type ::comp})) + ce))) ts))) - ts (ts/find ts ::type ::ap))) + ts (eduction (map #(e->uid ts %)) (ts/find ts ::type ::ap)))) ->ctor-idx (->->id) seen (volatile! #{}) mark-used-ctors (fn mark-used-ctors [ts e] @@ -856,7 +879,7 @@ (::localref) (recur ts (->> (::ref nd) (->localv-e ts) (get-ret-e ts))) #_else (throw (ex-info (str "cannot mark-used-ctors on " (pr-str (::type nd))) (or nd {}))))))) ts (-> ts (compute-effect-order (get-root-e ts)) (mark-used-ctors (get-root-e ts))) - ctors-e (get-ordered-ctors-e ts) + ctors-uid (mapv #(e->uid ts %) (get-ordered-ctors-e ts)) has-node? (fn has-node? [ts uid] (ts/find ts ::ctor-ref uid)) ensure-node (fn ensure-node [ts uid] (let [ctor-uid (e->uid ts (find-ctor-e ts (uid->e ts uid)))] @@ -954,8 +977,8 @@ (do (vswap! seen conj mklocal-uid) (recur ts (get-ret-e ts localv-e))))) #_else (throw (ex-info (str "cannot handle-let-refs on " (::type nd)) (or nd {})))))) - ->call-idx (let [mp (zipmap ctors-e (repeatedly ->->id))] - (fn ->call-idx [ctor-e] ((get mp ctor-e)))) + ->call-idx (let [mp (zipmap ctors-uid (repeatedly ->->id))] + (fn ->call-idx [ctor-uid] ((get mp ctor-uid)))) seen (volatile! #{}) mark-used-calls (fn mark-used-calls [ts ctor-e e] (if (@seen e) @@ -970,7 +993,7 @@ (::call) (if (::call-idx nd) ts (-> (mark-used-calls ts ctor-e (get-child-e ts e)) - (ts/asc e ::call-idx (->call-idx ctor-e)) + (ts/asc e ::call-idx (->call-idx (e->uid ts ctor-e))) (ts/asc e ::ctor-call (::uid (ts/->node ts ctor-e))))) (::let) (recur ts ctor-e (->bindlocal-body-e ts e)) (::localref) (let [nx-e (->> (::ref nd) (->localv-e ts) (get-ret-e ts))] @@ -981,7 +1004,7 @@ ts (->> ts :ave ::ctor-idx vals (reduce into)))) ts (-> ts mark-used-calls2 reroute-local-aliases (handle-let-refs (get-root-e ts)) inline-nodes order-nodes order-frees collapse-ap-with-only-pures)] - (when (::print-db env) (run! prn (ts->reducible ts))) + (when (::print-db env) (prn :db) (run! prn (ts->reducible ts))) ts)) (defn compile* [nm env ts] diff --git a/test/contrib/triple_store_test.clj b/test/contrib/triple_store_test.clj index 8fcc0c153..a58ce3f17 100644 --- a/test/contrib/triple_store_test.clj +++ b/test/contrib/triple_store_test.clj @@ -11,6 +11,7 @@ (-> (ts/->ts) (ts/add {:db/id '_}) (ts/upd '_ :x (fnil inc 0)) (ts/upd '_ :x (fnil inc 0)) (ts/get-entity '_) :x) := 2 (-> (ts/->ts) (ts/add {:db/id 1}) (ts/asc 1 :x 2) (ts/asc 1 :x 2) :ave :x (get 2)) := #{1} + (-> (ts/->ts) (ts/add {:db/id 1}) (ts/asc 1 :x 2 :y 3) :eav (get 1)) := {:db/id 1, :x 2, :y 3} (-> (ts/->ts) (ts/add {:db/id 1, :foo 1, :bar 1}) (ts/add {:db/id 2, :foo 1, :bar 1}) (ts/find :foo 1 :bar 1)) := #{1 2} From 89dfa526ed88843788fcf72745686d3d528aeaa8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Fri, 5 Apr 2024 15:29:34 +0200 Subject: [PATCH 180/428] fix cljs compat --- src/hyperfiddle/electric/impl/runtime_de.cljc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index d70c3d57b..267347dfa 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -788,9 +788,9 @@ T T T -> (EXPR T) ps ((flow expr) step done)] (reify IFn - (invoke [_] (ps)) + (#?(:clj invoke :cljs -invoke) [_] (ps)) IDeref - (deref [_] (call-transfer state @ps))))))) + (#?(:clj deref :cljs -deref) [_] (call-transfer state @ps))))))) (defn define-call "Defines call site id for given frame." From e5ab322f2fa68932da2d02d88c39c1d71ccbd89f Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 8 Apr 2024 10:23:53 +0200 Subject: [PATCH 181/428] better ::trace --- src/hyperfiddle/electric/impl/lang_de2.clj | 6 +++++- src/hyperfiddle/electric/impl/runtime_de.cljc | 2 +- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 1933ee55c..394f642ad 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -95,12 +95,16 @@ (defn traceable [f] (case (namespace f) ("hyperfiddle.electric.impl.runtime-de" "missionary.core" "hyperfiddle.incseq") false #_else true)) +(defn trace-crumb [o env] + (let [ns (-> env :ns :name), {:keys [line column]} (meta o)] + (str ns ":" line ":" column " " o))) + (defn ?expand-macro [o env caller] (if (symbol? (first o)) (let [o2 (?meta o (expand-macro env o))] (if (identical? o o2) (?meta o (cond->> (?meta o (list* (first o) (mapv (fn-> caller env) (rest o)))) - (and (::trace env) (traceable (first o))) (list `r/tracing (list 'quote o)))) + (and (::trace env) (traceable (first o))) (list `r/tracing (list 'quote (trace-crumb o env))))) (caller o2 env))) (?meta o (list* (caller (first o) env) (mapv (fn-> caller env) (next o)))))) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index f7bb276f4..47eb85665 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -967,4 +967,4 @@ Returns a peer definition from given definitions and main key. (defn cannot-resolve [& args] (throw (ex-info "definition called on a peer that doesn't support it" {:args args}))) -(defn tracing [o dot] (prn '[o_o] o '=>> dot) dot) +(defn tracing [info v] (print "[o_o]" info "=>> ") (prn v) v) From 24f7196f45dc1a1daa79fbb640474804e7dee7db Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 8 Apr 2024 17:14:52 +0200 Subject: [PATCH 182/428] compiler: fix siting --- src/hyperfiddle/electric/impl/lang_de2.clj | 28 +++++++-------- .../electric/impl/compiler_test.cljc | 35 ++++++++++++------- 2 files changed, 35 insertions(+), 28 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index b099a5bfb..723318b71 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -460,23 +460,13 @@ (declare analyze) -;; Due to an early bad assumption only `let` bound values are considered -;; for nodes (`r/define-node`). But in `(e/client (name (e/server :x)))` -;; `:x` needs to be a node too. For this reason we wrap function arguments -;; in an implicit `let`. This doesn't increase the generated code size -;; because `handle-let-refs` is smart enough to inline wherever possible. -(defn wrap-ap-arg [form] - (if (or (symbol? form) (keyword? form) (number? form)) - form - (let [ap-arg (gensym "ap-arg")] `(let* [~ap-arg ~form] ~ap-arg))) #_form) - (defn ap-literal [f args pe e env {{::keys [->id ->uid]} :o :as ts}] (let [ce (->id)] (reduce (fn [ts form] (analyze form e env ts)) (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap, ::uid (->uid)}) (ts/add {:db/id ce, ::parent e, ::type ::pure}) (ts/add {:db/id (->id), ::parent ce, ::type ::literal, ::v f})) - (mapv wrap-ap-arg args)))) + args))) (defn ->class-method-call [clazz method method-args pe env form {{::keys [->id]} :o :as ts}] (if (seq method-args) @@ -605,14 +595,20 @@ (?add-source-map e form)))) (::join) (let [e (->id)] (recur (second form) e env (-> (ts/add ts {:db/id e, ::parent pe, ::type ::join}) (?add-source-map e form)))) - (::site) (let [[_ site bform] form, e (->id)] - (recur bform e (assoc env ::current site) - (-> (ts/add ts {:db/id e, ::parent pe, ::type ::site, ::site site}) - (?add-source-map e form)))) + (::site) (let [[_ site bform] form, current (::current env), env2 (assoc env ::current site)] + (if (or (nil? site) (= site current)) + (let [e (->id)] + (recur bform e env2 + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::site, ::site site}) + (?add-source-map e form)))) + ;; Due to an early bad assumption only locals are considered for runtime nodes. + ;; Since any site change can result in a new node we wrap these sites in an implicit local. + ;; Electric aggressively inlines locals, so the generated code size will stay the same. + (recur `(::mklocal k# (::bindlocal k# ~form k#)) pe env2 ts))) (::lookup) (let [[_ sym] form] (ts/add ts {:db/id (->id), ::parent pe, ::type ::lookup, ::sym sym})) (::static-vars) (recur (second form) pe (assoc env ::static-vars true) ts) #_else (let [e (->id), uid (->uid)] - (reduce (fn [ts nx] (analyze (wrap-ap-arg nx) e env ts)) + (reduce (fn [ts nx] (analyze nx e env ts)) (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap, ::uid uid}) (?add-source-map uid form)) form))) diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index 06a66c55a..080caa08b 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -98,15 +98,22 @@ (r/ap (r/lookup ~'frame :clojure.core/name (r/pure clojure.core/name)) (r/node ~'frame 0))))]) - (match (l/test-compile ::Main (prn (e/client (::lang/call (e/server (::lang/ctor)))))) - `[(r/cdef 0 [:client] [:client] nil + (match (l/test-compile ::Main (prn (e/client (::lang/call (e/server (e/ctor nil)))))) + `[(r/cdef 0 [:server :client] [:client] nil (fn [~'frame] - (r/define-call ~'frame 0 (r/pure (r/ctor ::Main 1))) - (r/define-node ~'frame 0 (r/join (r/call ~'frame 0))) - (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure prn)) - (r/node ~'frame 0)))) + (r/define-node ~'frame 0 (r/pure (r/ctor ::Main 1))) + (r/define-call ~'frame 0 (r/node ~'frame 0)) + (r/define-node ~'frame 1 (r/join (r/call ~'frame 0))) + (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure prn)) (r/node ~'frame 1)))) (r/cdef 0 [] [] nil - (fn [~'frame] (r/pure nil)))])) + (fn [~'frame] (r/pure nil)))]) + + (match (l/test-compile ::Main (e/pure (e/server 2))) + `[(r/cdef 0 [:server] [] nil + (fn [~'frame] + (r/define-node ~'frame 0 (r/pure 2)) + (r/pure (r/node ~'frame 0))))]) + ) (tests "test-let" (match (l/test-compile ::Main (::lang/site :client (let [a :foo] [a a]))) @@ -145,13 +152,13 @@ (match (l/test-compile ::Main (e/client (let [x "Hello", y "world"] [x y]))) `[(r/cdef 0 [] [] :client (fn [~'frame] - (r/ap (r/pure (fn* [] (clojure.core/vector "Hello" "world"))))))]) + (r/pure (clojure.core/vector "Hello" "world"))))]) (match (l/test-compile ::Main (e/client (let [a (e/server :foo)] (e/server (prn a))))) - `[(r/cdef 0 [] [] :server + `[(r/cdef 0 [:server] [] :server (fn [~'frame] - (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure clojure.core/prn)) - (r/pure :foo))))]) + (r/define-node ~'frame 0 (r/pure :foo)) + (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure prn)) (r/node ~'frame 0))))]) (match (l/test-compile ::Main (concat (let [x 1] [x x]) (let [y 2] [y y]))) `[(r/cdef 0 [nil nil] [] nil @@ -457,7 +464,11 @@ (match (l/test-compile ::Main [1 2]) `[(r/cdef 0 [] [] nil (fn [~'frame] - (r/ap (r/pure (fn* [] (clojure.core/vector 1 2))))))])) + (r/pure (clojure.core/vector 1 2))))]) + (match (l/test-compile ::Main ((::lang/static-vars prn) 1)) + `[(r/cdef 0 [] [] nil + (fn [~'frame] + (r/ap (r/pure (fn* [] (~'prn 1))))))])) (tests "ordering" (match (l/test-compile ::Main (::lang/call (::lang/call (::lang/ctor (::lang/ctor :foo))))) From 7f655d5089b76b080a53ca097a9bb8eeabaf39bb Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 8 Apr 2024 21:45:44 +0200 Subject: [PATCH 183/428] compiler: cleanup, walkthrough markdown --- src/hyperfiddle/electric/impl/lang_de2.clj | 17 +-- .../electric/impl/lang_de_walkthrough.md | 114 ++++++++++++++++++ 2 files changed, 120 insertions(+), 11 deletions(-) create mode 100644 src/hyperfiddle/electric/impl/lang_de_walkthrough.md diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 723318b71..7fe0a0061 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -229,11 +229,6 @@ \newline "If `" form "` is supposed to be a macro, you might need to :refer it in the :require-macros clause.")))) {:locals (keys (:locals env))})) -(defn ambiguous-resolve! [env sym vs] - (fail! env - (str "Unsited symbol `" sym "` resolves to different vars on different peers. Please resolve ambiguity by siting the expression using it.") - {:resolves vs})) - (defn ns-qualify [node] (if (namespace node) node (symbol (str *ns*) (str node)))) (tests @@ -904,7 +899,7 @@ ts (-> ts :ave ::ctor-free vals))) unlink (fn [ts e] (-> ts (reparent-children e (::parent (ts/->node ts e))) (ts/del e))) - inline-nodes (fn inline-nodes [ts] + inline-locals (fn inline-locals [ts] (reduce (fn [ts mklocal-uid] (let [mklocal-nd (ca/is (ts/->node ts (uid->e ts mklocal-uid)) (comp #{::mklocal} ::type)) localrefs-e (mapv #(uid->e ts %) (::used-refs mklocal-nd)) @@ -938,11 +933,11 @@ (ts/find ts ::type ::localref, ::ref (::ref bl-nd)))) ts))) ts (ts/find ts ::type ::bindlocal))) - handle-let-refs (fn handle-let-refs [ts e] ; nodes and frees (closed over) + optimize-locals (fn optimize-locals [ts e] ; nodes and frees (closed over) (let [nd (ts/->node ts e)] (case (::type nd) (::literal ::var ::lookup ::node) ts - (::ap ::comp) (reduce handle-let-refs ts (get-children-e ts e)) + (::ap ::comp) (reduce optimize-locals ts (get-children-e ts e)) (::site ::join ::pure ::ctor ::call ::mklocal) (recur ts (get-child-e ts e)) (::bindlocal) (recur ts (->bindlocal-body-e ts e)) (::localref) @@ -972,7 +967,7 @@ (or (and (@seen mklocal-uid) ts) (do (vswap! seen conj mklocal-uid) (recur ts (get-ret-e ts localv-e))))) - #_else (throw (ex-info (str "cannot handle-let-refs on " (::type nd)) (or nd {})))))) + #_else (throw (ex-info (str "cannot optimize-locals on " (::type nd)) (or nd {})))))) ->call-idx (let [mp (zipmap ctors-uid (repeatedly ->->id))] (fn ->call-idx [ctor-uid] ((get mp ctor-uid)))) seen (volatile! #{}) @@ -998,8 +993,8 @@ mark-used-calls2 (fn [ts] (reduce (fn [ts ctor-e] (mark-used-calls ts ctor-e (get-ret-e ts (get-child-e ts ctor-e)))) ts (->> ts :ave ::ctor-idx vals (reduce into)))) - ts (-> ts mark-used-calls2 reroute-local-aliases (handle-let-refs (get-root-e ts)) - inline-nodes order-nodes order-frees collapse-ap-with-only-pures)] + ts (-> ts mark-used-calls2 reroute-local-aliases (optimize-locals (get-root-e ts)) + inline-locals order-nodes order-frees collapse-ap-with-only-pures)] (when (::print-db env) (prn :db) (run! prn (ts->reducible ts))) ts)) diff --git a/src/hyperfiddle/electric/impl/lang_de_walkthrough.md b/src/hyperfiddle/electric/impl/lang_de_walkthrough.md new file mode 100644 index 000000000..baf5692b0 --- /dev/null +++ b/src/hyperfiddle/electric/impl/lang_de_walkthrough.md @@ -0,0 +1,114 @@ +# Compiler walkthrough + +The electric compiler has 3 major components - expander, analyzer and emitter. +Each stage has its own complications and separating them aids in debugging and +reasoning. The final `compile` var calls them in the correct order to generate +electric runtime code. + +## Expander + +Expanding correctly across both clj and cljs is tricker than it should be. +Having it as a separate phase helped honing in on the differences and finding +the best solutions. + +The expander expands all macros to electric built-ins. The analyzer can use the +expander to re-expand a built-in to a set of other built-ins. + +Electric Clojurescript macroexpansion is different from stock expansion: +- cljs allows (defn foo) and (defmacro foo) to live alongside, since macroexpansion happens in a separate stage. +- cljs prefers the macro version wherever it can since it generates code GCC can better optimize. +- electric prefers defns since it generate smaller code which should be faster. + +For this reason we have our own analyzer. It's not a full analyzer, just enough to find macros and vars. + +We want to be able to source map electric code and clojure macroexpansion +doesn't forward line/column information since it's stored in the seq's metadata. +The expander takes care to forward metadata on re-expansion so we can later +source map. + +## Analyzer + +The analyzer is the hardest stage of all. It has to take in the expanded user +code and figure out what electric code we need to generate. + +Since the analyzer is changing all the time, is complicated and I didn't +know/understand all of its requirements I chose to keep all information in a +single triple store. Using a triple store allows working with the data flexibly +and in multiple passes. I built my own simple triple store to gain speed and +customize it to my needs. The triple store has 3 parts + +- o - an options map that can carry arbitrary extra data +- eav - the main index, for `{:db/id 1, :foo :bar}` it looks like `{1 {:db/id 1, :foo :bar}}`, + i.e. we can get our hands on the inserted map through a single map lookup +- ave - the key-value index which allows traversing the graph in arbitrary ways. + For `:foo` from the map before it looks like `{:foo {:bar (sorted-set 1)}}`. The + sorted set is (ab)used in the analyzer to keep track of node ordering in the graph. + +There's 4 main keys we use: +- `:db/id`, used by the triple store internally, as the entity key. We refer to + this value as `e` in the codebase. Function returning the entity ID end with + a `-e` suffix. +- `::type`, to categorize the nodes. +- `::parent`, a universal backreference key, holding the parent's `:db/id` value. + This allows traversing the graph both ways easily. Reading it we can go to the + parent, querying it in the :ave index we can find all children. Since the :ave + index uses a sorted set for the values we get the ordering for free, provided + the children's `:db/ids` are sorted. This is a strength during initial analysis + and poses some problems when doing graph rewrites, as one has to take care to + preserve the ordering during rewrites. +- `::uid`, used as a universal, unchanging ID. When I started implementing graph + rewrites I realized backreferences can get stale. Instead of meticulously + updating all of them I decided to create this unchanging ID which survives all + rewrites. + +The analyzer uses `->id` and `->uid` to generate a monotonically-increasing +integer. Together with the triple store's sorted maps we get node ordering for +free. + +The analyzer operates in multiple passes over the triple store. The first pass +is `analyze`, which takes the expanded user code, potentially re-expands some +forms and produces the first triple store. There are some non-obvious node types: +- `::mklocal` and `::bindlocal` - `let` expands to these, but also `e/letfn` uses + these. `::mklocal` introduces a local and `::bindlocal` binds it. Separating the + creation and binding of the local allows circular and forward references. E.g. + in `e/letfn` if one defines `Foo` and `Bar` we can first introduce the 2 + locals through `::mklocal` and bind them with `::bindlocal` afterwards. +- `::localref` - a reference to an electric local. E.g. the returning `x` in `(let [x 1] x)`. +- `::lookup` - in electric all vars are dynamic and can be rebound. This node type + is a lookup into the dynamic binding of the vars. We allow binding through + non-symbolic keys, e.g. we use keywords for some private bindings and numbers + for passing positional arguments. + +`analyze-electric` takes the output of `analyze` and performs deeper analysis +and graph rewrites. The current passes are: +- `compute-effect-order` - reachable nodes get an ::fx-order key with an + increasing integer value denoting their evaluation order. The ordering is + later used to generate side effecting code in correct order as required by the + runtime. +- `mark-used-ctors` - marks and orders all used constructors (e/fns desugar to + ctors). Used means we perform DCE, e.g. in (let [x 1, y (e/ctor 1)] x) we + won't compile the ctor. +- `mark-used-calls2` - inside the marked ctors, marks and order all calls. It's + safe to mark inside ctors since calls can't happen outside of a ctor. +- `reroute-local-aliases` - if a local just aliases another one, reroutes the + references to the origin. E.g. a similar clojure pass would rewrite + `(let [x 1, y x] [y y])` to `(let [x 1] [x x])`. +- `optimize-locals` - walking the code, finding all localrefs, decides whether the + locals need to become runtime nodes. The compiler aggressively inlines when + possible. This pass also has to handle closed over references (free variables). +- `inline-locals` - inlines locals +- `order-nodes` - orders nodes based on compute-effect-order ordering +- `order-frees` - orders frees based on compute-effect-order ordering +- `collapse-ap-with-only-pures` - `(r/ap (r/pure x) (r/pure y) (r/pure z))` can + optimize to 2 cases: + - `(r/ap (r/pure (fn* [] (x y z))))` if `x` is an impure fn + - `(r/pure (x y z))` if `x` is a pure fn + This pass handles both cases. We list pure fns in a hash-map. + +## Emitter + +This is the simplest part of the compiler. It takes the final triple store as +input has a straightforward mapping from the graph to the final runtime code. +`emit` is the main var which is currently ~40 lines of simple code. `emit-ctor` +is the glue which ties together `emit` and other parts of the emitter to +generate code for a single ctor. From 0db9312e586cf0ac861292451bdb0daffee7a756 Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 9 Apr 2024 16:35:49 +0200 Subject: [PATCH 184/428] compiler: remove missionary from cljs-analyzer Fixed some tests on cljs side, where the new analyzer doesn't pierce into rcf/tests forms to look for defs --- .../electric/impl/cljs_analyzer.clj | 4 +- .../electric/impl/cljs_analyzer2.clj | 230 ++++++++++++++++++ src/hyperfiddle/electric/impl/lang_de2.clj | 9 +- src/hyperfiddle/electric_de.cljc | 3 +- src/hyperfiddle/electric_local_def_de.cljc | 6 +- test/hyperfiddle/electric_de_test.cljc | 35 ++- 6 files changed, 259 insertions(+), 28 deletions(-) create mode 100644 src/hyperfiddle/electric/impl/cljs_analyzer2.clj diff --git a/src/hyperfiddle/electric/impl/cljs_analyzer.clj b/src/hyperfiddle/electric/impl/cljs_analyzer.clj index 435ea1792..82572aa7c 100644 --- a/src/hyperfiddle/electric/impl/cljs_analyzer.clj +++ b/src/hyperfiddle/electric/impl/cljs_analyzer.clj @@ -29,7 +29,7 @@ (let [rdr (m/?> (m/observe (fn [!] (let [rdr (rt/source-logging-push-back-reader (io/reader rs))] (! rdr) #(.close ^java.io.Reader rdr)))))] - (m/? (m/?> (m/seed (repeat (m/sp (ed/parse-next rdr parse-opts)))))))) + (m/? (m/?> (m/seed (repeat (m/via m/blk (ed/parse-next rdr parse-opts)))))))) (m/eduction (take-while (complement #{::done})))))) (defn safe-require [sym] @@ -192,7 +192,7 @@ (loop [a @!a] (or (-> a ::ns-tasks (get ns$)) (let [T (->> (resource-forms> rs) (m/reduce #(collect-defs !a ns$ env %2) nil)) - T (m/memo (m/via m/blk (m/? T)))] + T (m/memo T)] (if (compare-and-set! !a a (assoc-in a [::ns-tasks ns$] T)) T (recur @!a))))) diff --git a/src/hyperfiddle/electric/impl/cljs_analyzer2.clj b/src/hyperfiddle/electric/impl/cljs_analyzer2.clj new file mode 100644 index 000000000..1bab0da5c --- /dev/null +++ b/src/hyperfiddle/electric/impl/cljs_analyzer2.clj @@ -0,0 +1,230 @@ +(ns hyperfiddle.electric.impl.cljs-analyzer2 + (:refer-clojure :exclude [find-var]) + (:require [edamame.core :as ed] + [clojure.core :as cc] + [clojure.string :as str] + [clojure.tools.reader.reader-types :as rt] + [clojure.java.io :as io] + [cljs.tagged-literals] + [contrib.debug] + [cljs.core] ; for cljs macroexpansion + [cljs.env] + [cljs.analyzer] + [cljs.repl])) ; for cljs macroexpansion + +(defn ns->basename [ns$] (-> ns$ name (.replace \- \_) (.replace \. \/))) + +(defn ns->resource [ns$] + (let [base (ns->basename ns$)] + (or (io/resource (str base ".cljs")) + (io/resource (str base ".cljc"))))) + +(let [parse-opts + (ed/normalize-opts {:all true, :row-key :line, :col-key :column, :end-location false + :readers cljs.tagged-literals/*cljs-data-readers* :auto-resolve name + :features #{:cljs}, :read-cond :allow, :eof ::done})] + (defn resource-forms [rs] + (with-open [rdr (rt/source-logging-push-back-reader (io/reader rs))] + (loop [v []] + (let [nx (ed/parse-next rdr parse-opts)] + (if (= nx ::done) v (recur (conj v nx)))))))) + +(defn safe-require [sym] + ;; we might be expanding clj code before the ns got loaded (during cljs compilation) + ;; to correctly lookup vars the ns needs to be loaded + ;; since shadow-cljs compiles in parallel we need to serialize the requires + (when-not (get (loaded-libs) sym) + (try (#'clojure.core/serialized-require sym) ; try bc it can be cljs file + (catch java.io.FileNotFoundException _)))) + +(defn find-ns-var [^clojure.lang.Namespace nso sym] (.findInternedVar nso sym)) +(declare find-var find-macro-var) + +(defn mksym [& xs] (symbol (apply str (mapv #((if (or (keyword? %) (symbol? %)) name str) %) xs)))) + +(let [-base-cljs-env {:context :statement + :locals {} + :fn-scope [] + :js-globals (into {} + (map #(vector % {:op :js-var :name % :ns 'js}) + '(alert window document console escape unescape + screen location navigator history location + global process require module exports)))}] + (defn ->cljs-env + ([] (->cljs-env (ns-name *ns*))) + ([nssym] (cond-> -base-cljs-env nssym (assoc :ns {:name nssym}))))) + +(def special? '#{if def fn* do let* loop* letfn* throw try catch finally + recur new set! ns deftype* defrecord* . js* & quote case* var ns*}) + +(defn skip-docstring [args] (cond-> args (string? (first args)) next)) +(defn skip-attr-map [args] (cond-> args (map? (first args)) next)) +(defn skip-inline-opts [args] (cond-> args (keyword? (first args)) (-> nnext recur))) + +(let [blacklisted '#{cljs.core/exists? cljs.core/str cljs.core/extend-type} + short-circuit-def '#{clojure.core/defn, cljs.core/defn, clojure.core/defn-, cljs.core/defn-} + declare? '#{clojure.core/declare cljs.core/declare} + deftype? '#{clojure.core/deftype cljs.core/deftype} + defrecord? '#{clojure.core/defrecord cljs.core/defrecord} + defmacro? '#{clojure.core/defmacro cljs.core/defmacro} + defprotocol? '#{clojure.core/defprotocol cljs.core/defprotocol}] + (defn expand [a ns$ ls env [f & args :as o]] + (if (symbol? f) + (if (or (special? f) (ls f)) + o + (if-some [mac (find-macro-var a f ns$)] + (let [sym (symbol mac)] + (cond (= 'hyperfiddle.rcf/tests sym) nil ; circular, we can skip rcf tests + (= 'hyperfiddle.electric-de/defn sym) `(def ~(first args)) ; circular, don't go deeper + (short-circuit-def sym) `(def ~(first args)) + (declare? sym) `(do ~@(mapv #(list 'def %) args)) + (deftype? sym) (let [[nm] args] `(declare ~nm ~(mksym '-> nm))) + (defrecord? sym) (let [[nm] args] `(declare ~nm ~(mksym '-> nm) ~(mksym 'map-> nm))) + (defmacro? sym) nil + (defprotocol? sym) (let [[_ nm & args] o, fns (-> args skip-docstring skip-inline-opts)] + `(declare ~nm ~@(mapv first fns))) + (blacklisted sym) o ; reading compiler atom *during macroexpansion* + :else (apply mac o env args))) + o)) + o))) + +(defn add-require [!a ns$ reqk from$ to$] (swap! !a assoc-in [::nses ns$ reqk from$] to$)) + +(defn add-refers [!a ns$ refk o req$] + (reduce (fn [_ nx] (swap! !a assoc-in [::nses ns$ refk (or (get (:rename o) nx) nx)] (mksym req$ '/ nx))) + nil (:refer o))) + +(declare add-requireT analyze-nsT) + +(defn ?auto-alias-clojureT [!a ns$ reqk refk req$] + (when-not (ns->resource req$) + (let [cljs (str/replace-first (str req$) #"^clojure\." "cljs."), cljs$ (symbol cljs)] + (when-not (= req$ cljs$) + (when (ns->resource cljs$) + (add-requireT !a ns$ reqk refk [cljs$ :as req$]) + cljs$))))) + +(defn add-requireT [!a ns$ reqk refk r] + (let [r (if (or (symbol? r) (string? r)) [r] r) + [req$ & o] r, o (apply hash-map o)] + (when (not= ns$ req$) + (let [req$ (or (?auto-alias-clojureT !a ns$ reqk refk req$) req$)] + (add-require !a ns$ reqk req$ req$) + (when (:as o) (add-require !a ns$ reqk (:as o) req$)) + (when (:refer o) (add-refers !a ns$ refk o req$)) + (analyze-nsT !a (->cljs-env ns$) req$) + (when (:refer-macros o) + (add-requireT !a ns$ reqk refk + (into [req$] cat (-> (select-keys o [:as]) (assoc :refer (:refer-macros o)))))))))) + +(defn -add-requiresT [!a ns$ rs reqk refk] + (run! #(add-requireT !a ns$ reqk refk %) rs)) + +(defn add-require-macrosT [!a ns$ rs] (-add-requiresT !a ns$ rs ::require-macros ::refer-macros)) +(defn add-requiresT [!a ns$ rs] (-add-requiresT !a ns$ rs ::requires ::refers)) +(defn add-refer-clojure [!a ns$ ov] + (let [o (apply hash-map ov)] + (when (:exclude o) + (swap! !a assoc-in [::nses ns$ ::excludes] (set (:exclude o)))) + (when (:rename o) + (swap! !a + (fn [a] + (-> a (update-in [::nses ns$ ::refers] merge + (reduce-kv (fn [m k v] (assoc m v (symbol "cljs.core" (name k)))) {} (:rename o))) + (update-in [::nses ns$ ::excludes] into (keys (:rename o))))))))) +(defn use->require [args] + (let [o (apply hash-map (next args))] + (into [(first args)] cat (cond-> (select-keys o [:rename]) (:only o) (assoc :refer (:only o)))))) + +(defn add-ns-infoT [!a [_ns ns$ & args]] + (let [args (-> args skip-docstring skip-attr-map)] + (run! (fn [[typ & args]] + (case typ + (:require) (add-requiresT !a ns$ args) + (:require-macros) (add-require-macrosT !a ns$ args) + (:use) (add-requiresT !a ns$ (mapv use->require args)) + (:use-macros) (add-require-macrosT !a ns$ (mapv use->require args)) + (:refer-clojure) (add-refer-clojure !a ns$ args) + #_else nil)) + args))) + +(defn ->def-info [ns$ sym] {::name (with-meta (symbol (str ns$) (str sym)) (meta sym)), ::meta (meta sym)}) + +(defn add-def [!a ns$ sym] (swap! !a assoc-in [::nses ns$ ::defs sym] (->def-info ns$ sym))) + +(defn collect-defs [!a ns$ env o] + ((fn rec [ls !a o] + (when (and (seq? o) (seq o)) + (case (first o) + (def) (add-def !a ns$ (second o)) + (ns) (add-ns-infoT !a o) + (fn*) nil + (let*) (let [[_ bs & body] o + ls (transduce (partition-all 2) (completing (fn [ls [k v]] (rec ls !a v) (conj ls k))) ls bs)] + (rec ls !a (cons 'do body))) + #_else (let [o2 (expand @!a ns$ ls env o)] + (if (identical? o o2) + (run! #(rec ls !a %) o) + (recur ls !a o2)))))) + #{} !a o)) + +(defn keep-if [v pred] (when (pred v) v)) +(defn macro-var? [vr] (and (instance? clojure.lang.Var vr) (.isMacro ^clojure.lang.Var vr))) + +(defn safe-requiring-resolve [sym] (try (requiring-resolve sym) (catch java.io.FileNotFoundException _))) + +;;;;;;;;;;;;;;;;;; +;;; PUBLIC API ;;; +;;;;;;;;;;;;;;;;;; + +(def !nss (atom {})) + +(defn analyze-nsT [!a env ns$] + (when-some [rs (some-> ns$ ns->resource)] + (loop [a @!a] + (or (-> a ::ns-tasks (get ns$)) + (if (compare-and-set! !a a (assoc-in a [::ns-tasks ns$] true)) + (->> (resource-forms rs) (reduce #(collect-defs !a ns$ env %2) nil)) + (recur @!a)))))) + +(defn purge-ns [a ns$] (-> a (update ::ns-tasks dissoc ns$) (update ::nses dissoc ns$))) + +(defn find-var [a sym ns$] + (let [nsa (-> a ::nses (get ns$))] + (if (simple-symbol? sym) + (or (-> nsa ::defs (get sym)) + (when-not (get (::excludes nsa) sym) + (-> a ::nses (get 'cljs.core) ::defs (get sym))) + (when-some [renamed (get (::refers nsa) sym)] + (-> a ::nses (get (symbol (namespace renamed))) ::defs (get (symbol (name renamed)))))) + (or (-> a ::nses (get (-> sym namespace symbol)) ::defs (get (-> sym name symbol))) + (when-some [sym-ns$ (-> nsa ::requires (get (symbol (namespace sym))))] + (find-var a (symbol (name sym)) sym-ns$)) + (when (= "clojure.core" (namespace sym)) + (-> a ::nses (get 'cljs.core) ::defs (get (-> sym name symbol)))))))) + +;; cljs analyzer has extra, clojure.core -> cljs.core, clojure.repl -> cljs.repl, do we need it? +(defn find-macro-var [a sym ns$] + (when-not (find-var a sym ns$) + (-> (cond + (simple-symbol? sym) + (or (do (safe-require ns$) (some-> (find-ns ns$) (find-ns-var sym))) + (when-some [ref (-> a ::nses (get ns$) ::refers (get sym))] (safe-requiring-resolve ref)) + (when-some [ref (-> a ::nses (get ns$) ::refer-macros (get sym))] (safe-requiring-resolve ref)) + (when-not (get (-> a ::nses (get ns$) ::excludes) sym) (find-ns-var (find-ns 'clojure.core) sym))) + + (#{"cljs.core" "clojure.core"} (namespace sym)) + (safe-requiring-resolve sym) + + :else + (let [sym-ns$ (-> sym namespace symbol), sym-base$ (-> sym name symbol)] + (or (when-some [sym-ns$ (-> a ::nses (get ns$) ::requires (get sym-ns$))] + (safe-require sym-ns$) + (some-> (find-ns sym-ns$) (find-ns-var sym-base$))) + (when-some [sym-ns$ (-> a ::nses (get ns$) ::require-macros (get sym-ns$))] + (safe-require sym-ns$) + (some-> (find-ns sym-ns$) (find-ns-var sym-base$))) + (some-> (find-ns sym-ns$) (find-ns-var sym-base$))))) + (keep-if macro-var?)))) + +(defn ->!a [] (let [!a (atom {})] (analyze-nsT !a (->cljs-env 'cljs.core) 'cljs.core) !a)) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 7fe0a0061..e65cf870d 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -12,7 +12,7 @@ [missionary.core :as m] [hyperfiddle.electric-de :as-alias e] [hyperfiddle.electric.impl.analyzer :as ana] - [hyperfiddle.electric.impl.cljs-analyzer :as cljs-ana] + [hyperfiddle.electric.impl.cljs-analyzer2 :as cljs-ana] [hyperfiddle.electric.impl.destructure :as dst] [hyperfiddle.electric.impl.runtime-de :as r] [hyperfiddle.rcf :as rcf :refer [tests]])) @@ -205,7 +205,7 @@ (-expand-all o env))) (defn expand-all [env o] - (m/? (cljs-ana/analyze-nsT !a env (get-ns env))) + (cljs-ana/analyze-nsT !a env (get-ns env)) (let [expanded (-expand-all o (assoc env ::electric true))] (when (::print-expansion env) (fipp.edn/pprint expanded)) expanded)) @@ -808,7 +808,7 @@ (reduce delete-point-recursively ts ce) ts))) -(def pure-fns '#{clojure.core/vector clojure.core/hash-map}) +(def pure-fns '#{clojure.core/vector clojure.core/hash-map clojure.core/get clojure.core/boolean}) (defn implode-point [ts e] ; remove e, reparent child, keep e as id (let [nd (ts/->node ts e), ce (get-child-e ts e), cnd (ts/->node ts ce)] @@ -1007,7 +1007,8 @@ ~@(->> (get-ordered-ctors-e ts) (map #(emit-ctor ts % env nm)) (interleave (range))))))] - (when (::print-source env) (fipp.edn/pprint ret)) + (when (and (::print-clj-source env) (= :clj (->env-type env))) (fipp.edn/pprint ret)) + (when (and (::print-cljs-source env) (= :cljs (->env-type env))) (fipp.edn/pprint ret)) ret)) (defn ->ts [] (ts/->ts {::->id (->->id), ::->uid (->->id)})) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index ac2fb8c9d..846d786b7 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -104,7 +104,8 @@ Returns the successive states of items described by `incseq`. nm3 (vary-meta nm2 assoc ::lang/deps `'~deps)] (when-not (::lang/has-edef? (meta *ns*)) (alter-meta! *ns* assoc ::lang/has-edef? true)) - (when (::lang/print-source env) (fipp.edn/pprint source)) + (when (and (::lang/print-clj-source env) (= :clj (lang/->env-type env))) (fipp.edn/pprint source)) + (when (and (::lang/print-cljs-source env) (= :cljs (lang/->env-type env))) (fipp.edn/pprint source)) `(def ~nm3 ~source))) (defmacro amb " diff --git a/src/hyperfiddle/electric_local_def_de.cljc b/src/hyperfiddle/electric_local_def_de.cljc index 2ac0fc2c6..6fa03697c 100644 --- a/src/hyperfiddle/electric_local_def_de.cljc +++ b/src/hyperfiddle/electric_local_def_de.cljc @@ -63,7 +63,8 @@ deps (collect-deps deps) defs (into {} (map (fn [dep] [(keyword dep) dep])) deps) defs (assoc defs ::Main source)] - (when (::lang/print-source env) (fipp.edn/pprint source)) + (when (and (::lang/print-clj-source env) (= :clj (lang/->env-type env))) (fipp.edn/pprint source)) + (when (and (::lang/print-cljs-source env) (= :cljs (lang/->env-type env))) (fipp.edn/pprint source)) (when (::lang/print-defs env) (fipp.edn/pprint defs)) `(run-single (r/root-frame ~defs ::Main))))) @@ -91,6 +92,7 @@ deps (collect-deps deps) defs (into {} (map (fn [dep] [(keyword dep) dep])) deps) defs (assoc defs ::Main source)] - (when (::lang/print-source env) (fipp.edn/pprint source)) + (when (and (::lang/print-clj-source env) (= :clj (lang/->env-type env))) (fipp.edn/pprint source)) + (when (and (::lang/print-cljs-source env) (= :cljs (lang/->env-type env))) (fipp.edn/pprint source)) (when (::lang/print-defs env) (fipp.edn/pprint defs)) `(run-local ~defs ::Main))) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 3f61a2d80..12829aeed 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -197,27 +197,24 @@ (with ((l/single {} (tap ($ My-inc 1))) tap tap) % := 2)) -(tests "control flow implemented with lazy signals" - (e/defn If2 [x a b] ; Key question - how lazy are the parameters? - (->> (boolean x) - (get {true (e/fn [] a) - false (e/fn [] b)}) - ($))) +(e/defn If2 [x a b] ; Key question - how lazy are the parameters? + (->> (boolean x) + (get {true (e/fn [] a) + false (e/fn [] b)}) + ($))) - (def !x (atom false)) - (def !a (atom :a)) - (def !b (atom :b)) - (with ((l/single {} (let [x (e/watch !x) - a (tap (e/watch !a)) ; lazy - b (tap (e/watch !b))] ; lazy +(def !branch (atom false)) +(tests "control flow implemented with lazy signals" + (with ((l/single {} (let [x (e/watch !branch) + a (tap :a) ; lazy + b (tap :b)] ; lazy (tap ($ If2 x a b)))) tap tap) % := :b % := :b - (swap! !x not) + (swap! !branch not) % := :a % := :a - (swap! !x not) - % := :b + (swap! !branch not) % := :b)) (tests "lazy let" @@ -1451,9 +1448,9 @@ (set! (.-x o) ($ (e/fn [] 0)))))) tap tap) % := 0))) +(def a-root 1) #?(:cljs (tests "set! to alter root binding" - (def a-root 1) (with ((l/single {} (set! a-root 2)) tap tap)) (instance? Cancelled %) := true a-root := 2)) @@ -1993,8 +1990,8 @@ (tests "self-recur by recur, e/fn" (with ((l/single {} (tap ($ (e/fn fib [n] (case n 0 0 1 1 (+ (recur (- n 1)) (recur (- n 2))))) 6))) tap tap) % := 8)) +(e/defn Fib [n] (case n 0 0 1 1 (+ ($ Fib (- n 1)) ($ Fib (- n 2))))) (tests "self-recur by name, e/defn" - (e/defn Fib [n] (case n 0 0 1 1 (+ ($ Fib (- n 1)) ($ Fib (- n 2))))) (with ((l/single {} (tap ($ Fib 7))) tap tap) % := 13)) (tests "self-recur by name, e/fn thunk" @@ -2126,8 +2123,8 @@ (swap! !v inc) % := #{2})) -(tests "let over e/def" - (let [x 1] (e/defn XX [] [x x])) +(let [x 1] (e/defn XX [] [x x])) +(tests "let over e/defn" (with ((l/single {} (tap ($ XX))) tap tap) % := [1 1])) From 34a10b8d5540224cf0c547b33d91c413bf9e1565 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Tue, 9 Apr 2024 18:45:29 +0200 Subject: [PATCH 185/428] fix pure transfer --- src/hyperfiddle/electric/impl/lang_de2.clj | 16 ++-- src/hyperfiddle/electric/impl/runtime_de.cljc | 74 +++++++++++-------- src/hyperfiddle/electric_de.cljc | 7 +- .../electric/impl/runtime_test.cljc | 33 +++++++++ 4 files changed, 89 insertions(+), 41 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 394f642ad..d3d01a89e 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -439,7 +439,7 @@ (loop [e e] (when-some [nd (ts/->node ts e)] (case (::type nd) - (::literal ::ap ::join ::pure ::comp ::ctor ::call) e + (::literal ::ap ::join ::pure ::comp ::ctor ::call ::frame) e (::site) (when (some? (::site nd)) (recur (::parent nd))) (::var ::node ::lookup ::mklocal ::bindlocal ::localref) (some-> (::parent nd) recur) #_else (throw (ex-info (str "can't find-sitable-point-e for " (pr-str (::type nd))) (or nd {}))))))) @@ -609,6 +609,7 @@ (recur bform e (assoc env ::current site) (-> (ts/add ts {:db/id e, ::parent pe, ::type ::site, ::site site}) (?add-source-map e form)))) + (::frame) (ts/add ts {:db/id (->id), ::parent pe, ::type ::frame}) (::lookup) (let [[_ sym] form] (ts/add ts {:db/id (->id), ::parent pe, ::type ::lookup, ::sym sym})) (::static-vars) (recur (second form) pe (assoc env ::static-vars true) ts) #_else (let [e (->id), uid (->uid)] @@ -703,6 +704,7 @@ first (ts/->node ts) ::free-idx))))) (ts/find ts ::ctor-free (e->uid ts e)))) ::call (list `r/join (list `r/call 'frame (::call-idx (ts/->node ts e)))) + ::frame 'frame ::lookup (list `r/lookup 'frame (::sym nd)) ::mklocal (recur (get-ret-e ts (get-child-e ts e))) ::bindlocal (recur (get-ret-e ts (->bindlocal-body-e ts e))) @@ -741,12 +743,12 @@ ts (do (vswap! seen conj e) (case (::type nd) - (::literal ::var ::lookup ::node) (ord ts e) + (::literal ::var ::lookup ::node ::frame) (ord ts e) (::ap ::comp) (ord (reduce rec ts (get-children-e ts e)) e) (::site ::join ::pure ::call ::ctor ::mklocal) (ord (rec ts (get-child-e ts e)) e) (::bindlocal) (recur ts (->bindlocal-body-e ts e)) (::localref) (ord (rec ts (->localv-e ts (::ref nd))) (uid->e ts (::ref nd))) - #_else (throw (ex-info (str "cannot compure-effect-order on " (pr-str (::type nd))) (or nd {}))) + #_else (throw (ex-info (str "cannot compute-effect-order on " (pr-str (::type nd))) (or nd {}))) ))))) ts e))) @@ -780,7 +782,7 @@ (let [nd (ts/->node ts e)] (vswap! seen conj e) (case (::type nd) - (::literal ::var ::lookup) ts + (::literal ::var ::lookup ::frame) ts (::ap ::comp) (reduce mark ts (get-children-e ts e)) (::site ::join ::pure ::call ::ctor ::mklocal) (recur ts (get-child-e ts e)) (::bindlocal) (recur ts (->bindlocal-body-e ts e)) @@ -828,7 +830,7 @@ (let [nd (get (:eav ts) e)] (vswap! seen conj e) (case (::type nd) - (::literal ::var ::lookup ::node) ts + (::literal ::var ::lookup ::node ::frame) ts (::ap ::comp) (reduce mark-used-ctors ts (get-children-e ts e)) (::site ::join ::pure ::call ::mklocal) (recur ts (get-child-e ts e)) (::bindlocal) (recur ts (->bindlocal-body-e ts e)) @@ -904,7 +906,7 @@ handle-let-refs (fn handle-let-refs [ts e] ; nodes and frees (closed over) (let [nd (ts/->node ts e)] (case (::type nd) - (::literal ::var ::lookup ::node) ts + (::literal ::var ::lookup ::node ::frame) ts (::ap ::comp) (reduce handle-let-refs ts (get-children-e ts e)) (::site ::join ::pure ::ctor ::call ::mklocal) (recur ts (get-child-e ts e)) (::bindlocal) (recur ts (->bindlocal-body-e ts e)) @@ -945,7 +947,7 @@ (let [nd (ts/->node ts e)] (vswap! seen conj e) (case (::type nd) - (::literal ::var ::lookup ::node) ts + (::literal ::var ::lookup ::node ::frame) ts (::ap ::comp) (reduce #(mark-used-calls % ctor-e %2) ts (get-children-e ts e)) (::site ::join ::pure ::mklocal) (recur ts ctor-e (get-child-e ts e)) (::bindlocal) (recur ts ctor-e (->bindlocal-body-e ts e)) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 47eb85665..88f2aae06 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -70,30 +70,24 @@ (defn invariant [x] (m/cp x)) -(defn incseq " -(EXPR T) -> (IS T) -" [expr] (flow expr)) - -(deftype Pure [values +(deftype Pure [value ^:unsynchronized-mutable ^:mutable hash-memo] #?(:clj Object) #?(:cljs IHash) (#?(:clj hashCode :cljs -hash) [_] (if-some [h hash-memo] - h (set! hash-memo - (hash-combine (hash Pure) - (hash-ordered-coll values))))) + h (set! hash-memo (hash-combine (hash Pure) (hash value))))) #?(:cljs IEquiv) (#?(:clj equals :cljs -equiv) [_ other] (and (instance? Pure other) - (= values (.-values ^Pure other)))) + (= value (.-value ^Pure other)))) Expr (deps [_ _] {}) (flow [_] - (if-some [error (reduce (comp reduced {}) - nil (eduction (filter failure?) values))] - (m/latest #(throw (ex-info "Illegal access." {:info (failure-info error)}))) - (apply i/fixed (map invariant values)))) + (if (failure? value) + (m/latest #(throw (ex-info "Illegal access." {:info (failure-info value)}))) + (i/fixed (invariant value)))) + #_#_ IFn (#?(:clj invoke :cljs -invoke) [this step done] ((flow this) step done))) @@ -103,8 +97,8 @@ T -> (EXPR T) T T -> (EXPR T) T T T -> (EXPR T) -" [& values] - (->Pure values nil)) +" [value] + (->Pure value nil)) (defn invoke ([f] (f)) @@ -132,6 +126,7 @@ T T T -> (EXPR T) (reduce (fn [r x] (merge-with + r (deps x site))) {} inputs)) (flow [_] (apply i/latest-product invoke (map flow inputs))) + #_#_ IFn (#?(:clj invoke :cljs -invoke) [this step done] ((flow this) step done))) @@ -159,6 +154,7 @@ T T T -> (EXPR T) Expr (deps [_ site] (deps input site)) (flow [_] (i/latest-concat (flow input))) + #_#_ IFn (#?(:clj invoke :cljs -invoke) [this step done] ((flow this) step done))) @@ -410,6 +406,7 @@ T T T -> (EXPR T) {port 1}))) (flow [this] (port-flow (slot-port this))) + #_#_ IFn (#?(:clj invoke :cljs -invoke) [this step done] ((flow this) step done))) @@ -694,26 +691,39 @@ T T T -> (EXPR T) [^Frame frame id expr] (define-slot (node frame id) expr)) -(defn port-attach [^Peer peer ^objects port n] - (dotimes [_ n] (peer-push peer peer-queue-tap port)) peer) +(defn slot-frame [^Slot slot] + (.-frame slot)) + +(defn port-attach [_ ^objects port n] + (let [peer (frame-peer (slot-frame (port-slot port)))] + (dotimes [_ n] (peer-push peer peer-queue-tap port)))) + +(defn port-detach [_ ^objects port n] + (let [peer (frame-peer (slot-frame (port-slot port)))] + (dotimes [_ n] (peer-push peer peer-queue-untap port)))) + +(defn incseq [^Frame frame expr] + (let [deps (deps expr (.-site (frame-peer frame))) + flow (flow expr)] + (fn [step done] + (reduce-kv port-attach nil deps) + (flow step #(do (reduce-kv port-detach nil deps) (done)))))) -(defn port-detach [^Peer peer ^objects port n] - (dotimes [_ n] (peer-push peer peer-queue-untap port)) peer) +(defn frame-result [^Frame frame] + (let [^objects nodes (.-nodes frame)] + (aget nodes (dec (alength nodes))))) (defn frame-up [^Frame frame] - (let [^objects nodes (.-nodes frame) - result (aget nodes (dec (alength nodes))) - site (port-site (slot-port (.-slot frame)))] - (reduce-kv port-attach (frame-peer frame) - (deps (port-slot result) site)) + (let [result (frame-result frame)] + (reduce-kv port-attach nil + (deps (port-slot result) + (port-site (slot-port (.-slot frame))))) (port-flow result))) (defn frame-down [^Frame frame] - (let [^objects nodes (.-nodes frame) - result (aget nodes (dec (alength nodes))) - site (port-site (slot-port (.-slot frame)))] - (reduce-kv port-detach (frame-peer frame) - (deps (port-slot result) site)))) + (reduce-kv port-detach nil + (deps (port-slot (frame-result frame)) + (port-site (slot-port (.-slot frame)))))) (defn apply-cycle [^objects buffer cycle] (let [i (nth cycle 0) @@ -877,7 +887,7 @@ Returns a peer definition from given definitions and main key. Pure (t/write-handler (fn [_] "pure") (fn [^Pure pure] - (.-values pure)))}}) + (.-value pure)))}}) (aset state peer-slot-reader-opts {:handlers {"ctor" (t/read-handler (fn [[key idx env & free]] @@ -902,8 +912,8 @@ Returns a peer definition from given definitions and main key. (fn [inputs] (->Ap inputs nil))) "pure" (t/read-handler - (fn [values] - (->Pure values nil))) + (fn [value] + (->Pure value nil))) "unserializable" (t/read-handler (fn [_] (->Failure :unserializable)))}}) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 909aa10ca..468f62a6f 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -23,13 +23,16 @@ (defmacro ctor [expr] `(::lang/ctor ~expr)) (defmacro $ [F & args] `(check-electric $ (lang/$ ~F ~@args))) +(defmacro frame [] + `(::lang/pure (::lang/frame))) + (defmacro pure " Syntax : ```clojure (pure table) ``` Returns the incremental sequence describing `table`. -" [expr] `(::lang/pure ~expr)) +" [expr] `(r/incseq (frame) (::lang/pure ~expr))) (defmacro join " Syntax : @@ -126,7 +129,7 @@ Syntax : (amb table1 table2 ,,, tableN) ``` Returns the concatenation of `table1 table2 ,,, tableN`. -" [& exprs] `(::lang/call (join (r/pure ~@(mapv #(list `ctor %) exprs))))) +" [& exprs] `(::lang/call (join (i/fixed ~@(map #(list `r/invariant (list `ctor %)) exprs))))) (defmacro input " Syntax : diff --git a/test/hyperfiddle/electric/impl/runtime_test.cljc b/test/hyperfiddle/electric/impl/runtime_test.cljc index 0728a63ee..03ce5b3db 100644 --- a/test/hyperfiddle/electric/impl/runtime_test.cljc +++ b/test/hyperfiddle/electric/impl/runtime_test.cljc @@ -1,5 +1,6 @@ (ns hyperfiddle.electric.impl.runtime-test (:require [missionary.core :as m] + [hyperfiddle.incseq :as i] [hyperfiddle.electric-de :as e] [hyperfiddle.electric.impl.lang-de2 :as l] [hyperfiddle.electric.impl.runtime-de :as r] @@ -218,4 +219,36 @@ (s->c @s-ps) % := :foo % := :step-c + (c->s @c-ps)) + +(tests + #_(rcf/tap (e/join (e/pure (let [x (e/server 2)] x)))) + + (def Main + [(r/cdef 0 [:server] [] nil + (fn [frame] + (r/define-node frame 0 (r/pure 2)) + (r/ap (r/pure rcf/tap) + (r/join (r/ap (r/pure r/incseq) (r/pure frame) + (r/pure (r/node frame 0)))))))]) + + (def c-ps + ((r/peer (fn [!] + (def s->c !) + #(prn :dispose)) + :client {::Main Main} ::Main) + #(rcf/tap :step-c) #(rcf/tap :done-c))) + % := :step-c + + (def s-ps + ((r/peer (fn [!] + (def c->s !) + #(prn :dispose)) + :server {::Main Main} ::Main) + #(rcf/tap :step-s) #(rcf/tap :done-s))) + (c->s @c-ps) + % := :step-s + (s->c @s-ps) + % := 2 + % := :step-c (c->s @c-ps)) \ No newline at end of file From 1829d37ec8216706024ccd6613e807472ab00b97 Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 10 Apr 2024 09:38:26 +0200 Subject: [PATCH 186/428] fix cljs test --- test/hyperfiddle/electric_de_test.cljc | 1 - 1 file changed, 1 deletion(-) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 12829aeed..2ac07a48b 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -1452,7 +1452,6 @@ #?(:cljs (tests "set! to alter root binding" (with ((l/single {} (set! a-root 2)) tap tap)) - (instance? Cancelled %) := true a-root := 2)) ;; TODO e/fn arity check, try/catch From 51dda5f83b9c1f2d47708e497a60eaf9f88b1856 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Wed, 10 Apr 2024 10:30:16 +0200 Subject: [PATCH 187/428] force cljs int array zero init --- src/hyperfiddle/electric/impl/runtime_de.cljc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 267347dfa..372c45630 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -487,7 +487,7 @@ T T T -> (EXPR T) callc (count (.-calls cdef)) nodec (count (.-nodes cdef)) frame (->Frame peer slot rank site ctor - (int-array (inc callc)) (object-array callc) (object-array callc) + (i/int-array (inc callc)) (object-array callc) (object-array callc) (object-array (inc nodec)) nil)] (define-slot (->Slot frame (- -1 nodec)) ((.-build cdef) frame)) frame)) @@ -832,7 +832,7 @@ Returns a peer definition from given definitions and main key. (aset peer-queue-untap (object-array 1)) (aset peer-queue-toggle (object-array 1)) (aset peer-queue-ready (object-array 1))) - (int-array peer-queues) state) + (i/int-array peer-queues) state) input (m/stream (m/observe events)) ^Frame root (->> args (eduction (map pure)) From fb308291fe1eae8e0b5aa0d36fa1daeaa43d0134 Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 25 Mar 2024 10:26:35 +0100 Subject: [PATCH 188/428] compiler: ::lang/trace to trace interop calls --- src/hyperfiddle/electric/impl/lang_de2.clj | 5 ++++- src/hyperfiddle/electric/impl/runtime_de.cljc | 2 ++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index e65cf870d..f5555939d 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -93,11 +93,14 @@ (declare -expand-all) +(defn traceable [f] (case (namespace f) ("hyperfiddle.electric.impl.runtime-de" "missionary.core" "hyperfiddle.incseq") false #_else true)) + (defn ?expand-macro [o env caller] (if (symbol? (first o)) (let [o2 (?meta o (expand-macro env o))] (if (identical? o o2) - (?meta o (list* (first o) (mapv (fn-> caller env) (rest o)))) + (?meta o (cond->> (?meta o (list* (first o) (mapv (fn-> caller env) (rest o)))) + (and (::trace env) (traceable (first o))) (list `r/tracing (list 'quote o)))) (caller o2 env))) (?meta o (list* (caller (first o) env) (mapv (fn-> caller env) (next o)))))) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 372c45630..e20cd6a88 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -940,3 +940,5 @@ Returns a peer definition from given definitions and main key. gmap)) (defn cannot-resolve [& args] (throw (ex-info "definition called on a peer that doesn't support it" {:args args}))) + +(defn tracing [o dot] (prn '[o_o] o '=>> dot) dot) From 38156e78aa3ccdd70376a4537f146b47767ceac5 Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 26 Mar 2024 13:36:38 +0100 Subject: [PATCH 189/428] DOM3 related fixes, nodes properly mount/unmount --- src/hyperfiddle/electric/impl/runtime_de.cljc | 4 +++- src/hyperfiddle/electric_dom3.cljc | 7 ++++--- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index e20cd6a88..77a7cfd3b 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -939,6 +939,8 @@ Returns a peer definition from given definitions and main key. (if (seq gmap) (first gmap) {})) gmap)) -(defn cannot-resolve [& args] (throw (ex-info "definition called on a peer that doesn't support it" {:args args}))) +(defn cannot-resolve [& args] + (apply println "[!_!] definition called on a peer that doesn't support it" args) + #_(throw (ex-info "definition called on a peer that doesn't support it" {:args args}))) (defn tracing [o dot] (prn '[o_o] o '=>> dot) dot) diff --git a/src/hyperfiddle/electric_dom3.cljc b/src/hyperfiddle/electric_dom3.cljc index 0876013fe..b44e51a85 100644 --- a/src/hyperfiddle/electric_dom3.cljc +++ b/src/hyperfiddle/electric_dom3.cljc @@ -21,7 +21,8 @@ (ca/is parent some? "DOM node parent cannot be nil. Maybe dom/node is unbound?") (m/observe (fn [!] (.appendChild parent elem) (! elem) #(.remove elem))))) -(defmacro with [elem & body] `(binding [node (e/input (appending> ~elem node))] ~@body)) +;; TODO this should be a simple `binding` but the observer doesn't unmount that way +(defmacro with [elem & body] `(let [nd# (e/input (appending> ~elem node))] (binding [node nd#] ~@body nd#))) #?(:cljs (defn -googDomSetTextContentNoWarn [node str] ;; Electric says :infer-warning Cannot infer target type in expression, fixme @@ -30,10 +31,10 @@ #?(:cljs (defn ->text-node [] (goog.dom/createTextNode ""))) #?(:cljs (defn text-node? [nd] (= (.-nodeType nd) (.-TEXT_NODE nd)))) -#?(:cljs (defn ensure-not-in-text-node! [nd] (ca/is nd text-node? "Cannot nest dom/text or text nodes in other text nodes"))) +#?(:cljs (defn ensure-not-in-text-node! [nd] (ca/is nd (complement text-node?) "Cannot nest dom/text or text nodes in other text nodes"))) (defmacro text [& strs] - `(do (ensure-not-in-text-node! node) + `(do #_(ensure-not-in-text-node! node) ; TODO adding this breaks unmounting ~@(eduction (map (fn [str] `(with (->text-node) (-googDomSetTextContentNoWarn node ~str)))) From 69a61bb17fbb8fed313e46ad54471177273341de Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 28 Mar 2024 09:12:39 +0100 Subject: [PATCH 190/428] refactor --- src/hyperfiddle/electric_dom3.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/hyperfiddle/electric_dom3.cljc b/src/hyperfiddle/electric_dom3.cljc index b44e51a85..7f3c2e310 100644 --- a/src/hyperfiddle/electric_dom3.cljc +++ b/src/hyperfiddle/electric_dom3.cljc @@ -22,7 +22,7 @@ (m/observe (fn [!] (.appendChild parent elem) (! elem) #(.remove elem))))) ;; TODO this should be a simple `binding` but the observer doesn't unmount that way -(defmacro with [elem & body] `(let [nd# (e/input (appending> ~elem node))] (binding [node nd#] ~@body nd#))) +(defmacro with [elem & body] `(binding [node (e/input (appending> ~elem node))] ~@body node)) #?(:cljs (defn -googDomSetTextContentNoWarn [node str] ;; Electric says :infer-warning Cannot infer target type in expression, fixme From de6b29115dd380ac0b4905183c63c95e7d5f316f Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 28 Mar 2024 09:12:53 +0100 Subject: [PATCH 191/428] dom/listen prototype --- src/hyperfiddle/electric_dom3.cljc | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/src/hyperfiddle/electric_dom3.cljc b/src/hyperfiddle/electric_dom3.cljc index 7f3c2e310..72a104d9a 100644 --- a/src/hyperfiddle/electric_dom3.cljc +++ b/src/hyperfiddle/electric_dom3.cljc @@ -185,6 +185,19 @@ ($ Property node k# v#)) nil))) +#?(:cljs + (defn listen> [nd typ f opts] + (m/observe (fn [!] + (! nil) + (let [! (comp ! f), opts (clj->js opts)] + (.addEventListener nd typ ! opts)) #(.removeEventListener nd typ ! opts))))) + +(defmacro listen + ([typ] `(listen ~typ identity)) + ([typ f] `(listen ~typ ~f node)) + ([nd typ f] `(listen ~nd ~typ ~f nil)) + ([nd typ f opts] `(listen> ~nd ~typ ~f ~opts))) + #?(:cljs (defn ->elem [t] (goog.dom/createElement t))) (defmacro element {:style/indent 1} [t & body] `(with (->elem ~(name t)) ~@body)) From adb7aacf2b107f42cd45dd4e424bd0ed8ff48b0d Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 2 Apr 2024 19:49:26 +0200 Subject: [PATCH 192/428] dom scratches --- scratch/peter/y2024/dom3_components.cljc | 155 +++++++++++++++++++ scratch/peter/y2024/dom3_event_handling.cljc | 154 ++++++++++++++++++ 2 files changed, 309 insertions(+) create mode 100644 scratch/peter/y2024/dom3_components.cljc create mode 100644 scratch/peter/y2024/dom3_event_handling.cljc diff --git a/scratch/peter/y2024/dom3_components.cljc b/scratch/peter/y2024/dom3_components.cljc new file mode 100644 index 000000000..0b7ee5a11 --- /dev/null +++ b/scratch/peter/y2024/dom3_components.cljc @@ -0,0 +1,155 @@ +(ns peter.y2024.dom3-components + (:require [hyperfiddle.electric-de :as e :refer [$]] + [hyperfiddle.electric-dom3 :as dom])) + +;; goal - converge (dom/div (dom/button)) and ($ Div ($ Button)) styles +;; experiment - thunk components, mount in 1 go + +(comment + ;; this is problematic in current design, although the requirement seems simple: + ;; create a new DOM component derived from an existing one, adding some props + (e/defn DivContainer [] + (dom/div + (dom/props {:class "container"}) + 'bodyhere)) + ;; how do we add body? + (defmacro div-container [& body] + `(dom/div (dom/props {:class "container"}) ~@body)) + ;; here we had to use a macro + ;; what if we want to inject this component into another one? + ;; Not possible as a macro + ) + + +(e/defn Nobody []) + +;; a DOM component => a 1-arg e/fn taking a Body continuation, returning a 0-arg e/fn +(e/defn Div [Body] (e/fn [] (dom/with (.createElement js/document "div") ($ Body)))) + +;; ugly but works +(binding [dom/node js/document.body] + ($ ($ Div + (e/fn [] + ($ ($ Div + (e/fn [] + (dom/style '...) + ($ ($ Div Nobody))))) + ($ ($ Div Nobody)))))) + +;; remove the boilerplate +(defmacro $$ [Compo & body] `($ ($ ~Compo (e/fn [] ~@body)))) + +(binding [dom/node js/document.body] + ($$ Div + ($$ Div + (dom/style '...) + ($$ Div)) + ($$ Div))) + +;; initial problem was to e.g. create div container with props and pass DOM nodes in + +(e/defn DivContainer [Body] + (e/fn [] + (dom/with (.createElement js/document "div") + (dom/props {:class "container"}) + ($ Body)))) + +;; or +(e/defn DivContainer [Body] + (e/fn [] + ($$ Div + (dom/props {:class "container"}) + ($ Body)))) + +(binding [dom/node js/document.body] + ($$ DivContainer + ($$ Div (dom/props '..)))) + +;; higher order component +(e/defn MyComponentBuilder [ChildComponent] + (e/fn [Body] + (e/fn [] ($$ ChildComponent) ($ Body)))) + +(binding [dom/node js/document.body] + ($$ Div + ;; ugly, we have to `$` and then `$$` + ($$ ($ MyComponentBuilder Div)))) + +;; possible helper to write higher order components +(defmacro component [body-sym & body] `(e/fn [~body-sym] (e/fn [] ~@body))) + +(e/defn MyCompoBuilder [ChildComponent] + (component Body + ($$ ChildComponent) + ($ Body))) + +;; how would we write the TxButton3 example from event handling + +(e/defn TxButton3 [BusyBody Tx] + (component Body + (dom/button + (let [!evt (atom nil), !busy (atom nil), busy (boolean (e/watch !busy))] + (dom/listen "click" (partial reset! !evt)) + (dom/props {:disabled busy}) + (when (e/watch !evt) + ;; contract - Tx calls `done` once done, returns busy state + (reset! !busy ($ Tx #(reset! !evt nil)))) + ($ BusyBody busy)) + ($ Body)))) + +;; usage of above +(e/defn ButtonUsage [] + ($$ ($ TxButton3 + (e/fn [busy] (dom/style {:aria-busy busy, :background-color (when busy "yellow")})) + (e/fn [done] (case (e/input (transact! :conn (inc (get-count db)))) + ::pending true #_else (done)))))) + +;; TxButton3 shows syntax trickery, ideally we'd like to flatten the e/fns +(e/defn TxButtonFlat [BusyBody Tx Body] + ($$ dom/Button + (let [!evt (atom nil), !busy (atom nil), busy (boolean (e/watch !busy))] + (dom/listen "click" (partial reset! !evt)) + (dom/props {:disabled busy}) + (when (e/watch !evt) + ;; contract - Tx calls `done` once done, returns busy state + (reset! !busy ($ Tx #(reset! !evt nil)))) + ($ BusyBody busy)) + ($ Body))) + +;; now there's a syntactic clash on `$$` +;; - on one hand we want to thunk the body continuation to remove the (e/fn []) boilerplate +;; - on the other hand we want to pass an unknown number of positional arguments before + +(comment + ;; this doesn't work, but we'd like it to work + ($$ TxButtonFlat + ;; these are positional + (e/fn [busy] (dom/style {:aria-busy busy, :background-color (when busy "yellow")})) + (e/fn [done] (case (e/input (transact! :conn (inc (get-count db)))) + ::pending true #_else (done))) + ;; this is thunked body + (dom/props 'txbuttonpropshere) + (dom/style 'stylehere)) + + ;; we could have a number of positional macros + ;; $$0 $$1 $$2 ... + ;; quite ugly and error prone + ($$2 TxButtonFlat '..) + + + ;; we could take the positionals in a vector form + ($$ Div + ($$ TxButtonFlat [(e/fn [busy]) (e/fn [done])] + 'bodyhere)) + ;; or + ($$ Div + ($$ [TxButtonFlat (e/fn [busy]) (e/fn [done])] + 'bodyhere)) + + ;; calling by hand is still ugly, right? + ($ ($ Div + (e/fn [] + ($ ($ TxButtonFlat + (e/fn [busy]) + (e/fn [done]) + (e/fn [] '...))))))) diff --git a/scratch/peter/y2024/dom3_event_handling.cljc b/scratch/peter/y2024/dom3_event_handling.cljc new file mode 100644 index 000000000..95cc4c1d4 --- /dev/null +++ b/scratch/peter/y2024/dom3_event_handling.cljc @@ -0,0 +1,154 @@ +(ns peter.y2024.dom3-event-handling + (:require [hyperfiddle.electric-de :as e :refer [$]] + [hyperfiddle.electric-dom3 :as dom] + [missionary.core :as m] + [hyperfiddle.incseq :as i])) + +;;;;;;;;;;;;;; +;;; EVENTS ;;; +;;;;;;;;;;;;;; + +;; (dom/listen "input" #(-> % .-target .-value)) +;; starts as the empty incseq, afterwards has a single changing value +;; (), ("f"), ("fo"), ("foo") ... +;; to be implemented, right now it starts as nil +;; (nil), ("f"), ("fo"), ("foo") ... + +;; (dom/event-log "keydown" #(when (= "enter" (.-key %)) [% (-> % .-target .-value)])) +;; returns a log (append-only incseq) of values derived from the event stream +;; {}, {1 "buy milk"}, {1 "buy milk", 2 "visit grandma"}, ... + +#?(:cljs + ;; TODO starts as empty incseq, later singleton changing value + (defn listen1 [nd typ f opts] + (m/observe (fn [!] + (! nil) + (let [! (comp ! f) , opts (clj->js opts)] + (.addEventListener nd typ ! opts)) #(.removeEventListener nd typ ! opts))))) + +(defmacro listen + ([typ] `(listen ~typ identity)) + ([typ f] `(listen node ~typ ~f)) + ([nd typ f] `(listen ~nd ~typ ~f nil)) + ([nd typ f opts] `(e/input (listen1 ~nd ~typ ~f ~opts)))) + +(defn append-only [> js opts)] + (.addEventListener nd typ ! opts)) #(.removeEventListener nd typ ! opts)))))) + +(defmacro event-log + ([typ] `(event-log ~typ identity)) + ([typ f] `(event-log node ~typ ~f)) + ([nd typ f] `(event-log ~nd ~typ ~f nil)) + ([nd typ f opts] `(e/input (event-log* ~nd ~typ ~f ~opts)))) + +;;;;;;;;;;;;;;;;;;; +;;; INPUT FIELD ;;; +;;;;;;;;;;;;;;;;;;; + +;; input field matches electric semantics + +(e/defn InputField [] + ;; this abstraction is useless, electric semantics match this perfectly + (dom/input + (listen "input" #(-> % .-target .-value)))) + +;;;;;;;;;;;;;;;;; +;;; TX BUTTON ;;; +;;;;;;;;;;;;;;;;; + +;; requirements: +;; - run on click +;; - disable while transacting +;; - prevent cycles +;; - allow userland to read busy state + +(defn transact! [conn v] (m/ap (m/amb= ::pending (m/? (m/sleep 1000 ::done))))) +(declare db get-count) + +(e/defn TxButton [Body Tx] + (dom/button + (let [!evt (atom nil), !busy (atom nil), busy (boolean (e/watch !busy))] + (dom/listen "click" (partial reset! !evt)) + (dom/props {:disabled busy}) + (when (e/watch !evt) + ;; contract - Tx returns `::pending` (only) while Tx is running + (reset! !busy (case ($ Tx (e/watch !evt)) + ::pending true + #_else (reset! !evt nil)))) + ($ Body busy)))) + +;; usage of above +(e/defn ButtonUsage [] + ($ TxButton + (e/fn [busy] (dom/style {:aria-busy busy, :background-color (when busy "yellow")})) + (e/fn [_evt] (e/input (transact! :conn (inc (get-count db))))))) + +;; different abstraction, different contract +(e/defn TxButton2 [Body Tx] + (dom/button + (let [!evt (atom nil), !busy (atom nil), busy (boolean (e/watch !busy))] + (dom/listen "click" (partial reset! !evt)) + (dom/props {:disabled busy}) + (when (e/watch !evt) + ;; contract - Tx sets !evt to nil once done, returns busy state + (reset! !busy ($ Tx !evt))) + ($ Body busy)))) + +;; usage of above +(e/defn ButtonUsage2 [] + ($ TxButton2 + (e/fn [busy] (dom/style {:aria-busy busy, :background-color (when busy "yellow")})) + (e/fn [!evt] (case (e/input (transact! :conn (inc (get-count db)))) + ::pending true #_else (reset! !evt nil))))) + +;; another abstraction +(e/defn TxButton3 [Body Tx] + (dom/button + (let [!evt (atom nil), !busy (atom nil), busy (boolean (e/watch !busy))] + (dom/listen "click" (partial reset! !evt)) + (dom/props {:disabled busy}) + (when (e/watch !evt) + ;; contract - Tx calls `done` once done, returns busy state + (reset! !busy ($ Tx #(reset! !evt nil)))) + ($ Body busy)))) + +;; usage of above +(e/defn ButtonUsage3 [] + ($ TxButton3 + (e/fn [busy] (dom/style {:aria-busy busy, :background-color (when busy "yellow")})) + (e/fn [done] (case (e/input (transact! :conn (inc (get-count db)))) + ::pending true #_else (done))))) + +;;;;;;;;;;;;;;;;;; +;;; CREATE NEW ;;; +;;;;;;;;;;;;;;;;;; + +;; create new matches e/cursor semantics + +#?(:cljs (defn value-on-enter [nd evt] (when (= "enter" (.-key evt)) [evt (.-value nd)]))) + +(e/defn CreateNew [] + (let [in (dom/input (dom/props {:placeholder "what needs to be done?"}) dom/node)] + (dom/ul + (e/cursor [v (event-log in "keydown" (partial value-on-enter in))] + (dom/li (dom/text v)))))) + +;; OPTIMISTIC UPDATES - merge 2 incseqs (is there an operator for that?) +;; `value-on-enter` would need to change to return an ID key that will persist + +(declare query-todos) +(e/defn CreateNewOptimistic [] + (let [in (dom/input (dom/props {:placeholder "what needs to be done?"}) dom/node)] + (dom/ul + (e/cursor [v (e/merge (event-log in "keydown" (partial value-on-enter in)) (query-todos db))] + (dom/li (dom/text v)))))) From 0f070b05ced3efaaee180e90d67bd3de7047ef4d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Wed, 10 Apr 2024 14:20:27 +0200 Subject: [PATCH 193/428] fix runtime test --- .../electric/impl/runtime_test.cljc | 26 +++++++------------ 1 file changed, 9 insertions(+), 17 deletions(-) diff --git a/test/hyperfiddle/electric/impl/runtime_test.cljc b/test/hyperfiddle/electric/impl/runtime_test.cljc index 03ce5b3db..c74ac2a13 100644 --- a/test/hyperfiddle/electric/impl/runtime_test.cljc +++ b/test/hyperfiddle/electric/impl/runtime_test.cljc @@ -222,29 +222,21 @@ (c->s @c-ps)) (tests - #_(rcf/tap (e/join (e/pure (let [x (e/server 2)] x)))) - - (def Main - [(r/cdef 0 [:server] [] nil - (fn [frame] - (r/define-node frame 0 (r/pure 2)) - (r/ap (r/pure rcf/tap) - (r/join (r/ap (r/pure r/incseq) (r/pure frame) - (r/pure (r/node frame 0)))))))]) + (def peer (peers (rcf/tap (e/join (e/pure (let [x (e/server 2)] x)))))) (def c-ps - ((r/peer (fn [!] - (def s->c !) - #(prn :dispose)) - :client {::Main Main} ::Main) + ((peer :client + (fn [!] + (def s->c !) + #(prn :dispose))) #(rcf/tap :step-c) #(rcf/tap :done-c))) % := :step-c (def s-ps - ((r/peer (fn [!] - (def c->s !) - #(prn :dispose)) - :server {::Main Main} ::Main) + ((peer :server + (fn [!] + (def c->s !) + #(prn :dispose))) #(rcf/tap :step-s) #(rcf/tap :done-s))) (c->s @c-ps) % := :step-s From 46fed15429f46ee34fc98818c3cd64bcff2e29d1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Wed, 10 Apr 2024 14:22:10 +0200 Subject: [PATCH 194/428] fix type mismatch in e/Apply --- src/hyperfiddle/electric_de.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 0deb375e3..9605df4a9 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -222,7 +222,7 @@ this tuple. Returns the concatenation of all body results as a single vector. (if (< fixed offset) (loop [args args static static] - (let [args (cons (::lang/join (peek static)) args) + (let [args (cons (::lang/join (r/incseq (frame) (peek static))) args) static (pop static)] (if (< fixed (count static)) (recur args static) From de1a8053b435758b6a5e12b0283622ae5f320e4f Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 10 Apr 2024 14:34:15 +0200 Subject: [PATCH 195/428] compiler: optimize r/incseq call --- src/hyperfiddle/electric/impl/lang_de2.clj | 3 ++- src/hyperfiddle/electric_de.cljc | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index dfe0e7d57..67499704b 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -817,7 +817,8 @@ (reduce delete-point-recursively ts ce) ts))) -(def pure-fns '#{clojure.core/vector clojure.core/hash-map clojure.core/get clojure.core/boolean}) +(def pure-fns '#{clojure.core/vector clojure.core/hash-map clojure.core/get clojure.core/boolean + hyperfiddle.electric.impl.runtime-de/incseq}) (defn implode-point [ts e] ; remove e, reparent child, keep e as id (let [nd (ts/->node ts e), ce (get-child-e ts e), cnd (ts/->node ts ce)] diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 9605df4a9..70ef71666 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -32,7 +32,7 @@ Syntax : (pure table) ``` Returns the incremental sequence describing `table`. -" [expr] `(r/incseq (frame) (::lang/pure ~expr))) +" [expr] `((::lang/static-vars r/incseq) (frame) (::lang/pure ~expr))) (defmacro join " Syntax : From 71a3f3da1dc189888cfd5c6e9d6d542fa51ac2f4 Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 10 Apr 2024 14:47:57 +0200 Subject: [PATCH 196/428] compiler: fix test after e/pure changes --- test/hyperfiddle/electric/impl/compiler_test.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index 080caa08b..a65412e04 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -112,7 +112,7 @@ `[(r/cdef 0 [:server] [] nil (fn [~'frame] (r/define-node ~'frame 0 (r/pure 2)) - (r/pure (r/node ~'frame 0))))]) + (r/pure (r/incseq ~'frame (r/node ~'frame 0)))))]) ) (tests "test-let" From 16689ba57d6a33aade4faf2c13fa843a3975baa4 Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 10 Apr 2024 14:59:44 +0200 Subject: [PATCH 197/428] get rid of spurious exception in tests --- test/hyperfiddle/electric_de_test.cljc | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index a8c875b7a..d9f7e18ef 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -941,22 +941,22 @@ (swap! !t not) % := nil)) -(def !state (atom true)) +(def !state1 (atom true)) (tests - (reset! !state true) - (with ((l/single {} (when (e/watch !state) (tap :touch))) tap tap) + (reset! !state1 true) + (with ((l/single {} (when (e/watch !state1) (tap :touch))) tap tap) % := :touch - (reset! !state true) + (reset! !state1 true) (tap ::nope) % := ::nope)) -(def !state (atom true)) +(def !state2 (atom true)) (tests "e/for in a conditional" - (reset! !state true) - (with ((l/single {} (tap (if (e/watch !state) 1 (e/for-by identity [_ []])))) tap tap) + (reset! !state2 true) + (with ((l/single {} (tap (if (e/watch !state2) 1 (e/for-by identity [_ []])))) tap tap) % := 1 - (swap! !state not) + (swap! !state2 not) % := [] - (swap! !state not) + (swap! !state2 not) % := 1) ) From 64c15394922d2f1d34ceb5312662c93759fbf10d Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 10 Apr 2024 15:00:15 +0200 Subject: [PATCH 198/428] move incseq items-impl tests to clojure.test The RCF tests are failing in cljs and the tests are synchronous. --- src/hyperfiddle/incseq/items_impl.cljc | 76 +------------------ test/hyperfiddle/incseq/items_impl_test.cljc | 78 ++++++++++++++++++++ 2 files changed, 79 insertions(+), 75 deletions(-) create mode 100644 test/hyperfiddle/incseq/items_impl_test.cljc diff --git a/src/hyperfiddle/incseq/items_impl.cljc b/src/hyperfiddle/incseq/items_impl.cljc index 08d4dee3c..b04273a0f 100644 --- a/src/hyperfiddle/incseq/items_impl.cljc +++ b/src/hyperfiddle/incseq/items_impl.cljc @@ -1,8 +1,6 @@ (ns hyperfiddle.incseq.items-impl (:require [hyperfiddle.incseq.perm-impl :as p] - [hyperfiddle.incseq.diff-impl :as d] - [hyperfiddle.rcf :as rcf :refer [tests]] - [clojure.test :refer [is]]) + [hyperfiddle.incseq.diff-impl :as d]) (:import #?(:clj (clojure.lang IFn IDeref)) #?(:clj (java.util.concurrent.locks ReentrantLock)) missionary.Cancelled)) @@ -248,75 +246,3 @@ (aset parent slot-head-done (enqueue-all parent (aget parent slot-head-done))) (release parent held)))) (->Ps parent)))) - -(tests - (let [q #?(:clj (let [q (java.util.LinkedList.)] - (fn - ([] (.remove q)) - ([x] (.add q x) nil))) - :cljs (let [q (make-array 0)] - (fn - ([] - (when (zero? (alength q)) - (throw (js/Error. "No such element."))) - (.shift q)) - ([x] (.push q x) nil)))) - ps ((flow (fn [step done] - (q [step done]) - (step) - (reify - IFn - (#?(:clj invoke :cljs -invoke) [_] - (q :cancel)) - IDeref - (#?(:clj deref :cljs -deref) [_] - (q))))) - #(q :step) #(q :done)) - [step done] (q) - _ (is (::rcf/= (q) :step)) - _ (q (assoc (d/empty-diff 2) - :change {0 :foo 1 :bar} - :grow 2)) - diff @ps - _ (is (::rcf/= (dissoc diff :change) - (assoc (dissoc (d/empty-diff 2) :change) - :freeze #{0 1} - :grow 2))) - [item0 item1] (map (:change diff) [0 1]) - ps0 (item0 #(q :step0) #(q :done0)) - _ (is (::rcf/= (q) :step0)) - _ (is (::rcf/= @ps0 :foo)) - ps1 (item1 #(q :step1) #(q :done1)) - _ (is (::rcf/= (q) :step1)) - _ (step) - _ (is (::rcf/= (hash-set (q) (q)) #{:step :step0})) - _ (q (assoc (d/empty-diff 2) - :permutation {0 1 1 0} - :change {1 :foo 0 :BAR})) - _ (is (::rcf/= @ps (assoc (d/empty-diff 2) :permutation {0 1 1 0}))) - _ (is (::rcf/= @ps1 :BAR)) - _ (is (::rcf/= @ps0 :foo)) - _ (ps0) - _ (is (::rcf/= (q) :step0)) - ps0- (item0 #(q :step0-) #(q :done0-)) - _ (is (::rcf/= (q) :step0-)) - _ (is (::rcf/= nil (try @ps0 (catch Cancelled _)))) - _ (is (::rcf/= (q) :done0)) - _ (step) - _ (is (::rcf/= (hash-set (q) (q)) #{:step :step1})) - _ (q (assoc (d/empty-diff 2) - :change {1 :FOO})) - _ (is (::rcf/= @ps0- :FOO)) - _ (is (::rcf/= nil (try (item1 #(q :step1-) #(q :done1-)) - (catch #?(:clj Error :cljs js/Error) _)))) - _ (step) - _ (is (::rcf/= (hash-set (q)) #{:step0-})) - _ (q (assoc (d/empty-diff 2) - :freeze #{0 1})) - _ (is (::rcf/= @ps1 :BAR)) - _ (is (::rcf/= (q) :done1)) - _ (is (::rcf/= @ps0- :FOO)) - _ (is (::rcf/= (q) :done0-)) - _ (is (::rcf/= @ps (d/empty-diff 2))) - _ (done) - _ (is (::rcf/= (q) :done))])) \ No newline at end of file diff --git a/test/hyperfiddle/incseq/items_impl_test.cljc b/test/hyperfiddle/incseq/items_impl_test.cljc new file mode 100644 index 000000000..55fa1ecf3 --- /dev/null +++ b/test/hyperfiddle/incseq/items_impl_test.cljc @@ -0,0 +1,78 @@ +(ns hyperfiddle.incseq.items-impl-test + (:require [hyperfiddle.incseq.diff-impl :as d] + [hyperfiddle.incseq.items-impl :as ii] + [clojure.test :as t]) + (:import #?(:clj [clojure.lang IFn IDeref]) + [missionary Cancelled])) + +(t/deftest basic + (let [q #?(:clj (let [q (java.util.LinkedList.)] + (fn + ([] (.remove q)) + ([x] (.add q x) nil))) + :cljs (let [q (make-array 0)] + (fn + ([] + (when (zero? (alength q)) + (throw (js/Error. "No such element."))) + (.shift q)) + ([x] (.push q x) nil)))) + ps ((ii/flow (fn [step done] + (q [step done]) + (step) + (reify + IFn + (#?(:clj invoke :cljs -invoke) [_] + (q :cancel)) + IDeref + (#?(:clj deref :cljs -deref) [_] + (q))))) + #(q :step) #(q :done)) + [step done] (q) + _ (t/is (= (q) :step)) + _ (q (assoc (d/empty-diff 2) + :change {0 :foo 1 :bar} + :grow 2)) + diff @ps + _ (t/is (= (dissoc diff :change) + (assoc (dissoc (d/empty-diff 2) :change) + :freeze #{0 1} + :grow 2))) + [item0 item1] (map (:change diff) [0 1]) + ps0 (item0 #(q :step0) #(q :done0)) + _ (t/is (= (q) :step0)) + _ (t/is (= @ps0 :foo)) + ps1 (item1 #(q :step1) #(q :done1)) + _ (t/is (= (q) :step1)) + _ (step) + _ (t/is (= (hash-set (q) (q)) #{:step :step0})) + _ (q (assoc (d/empty-diff 2) + :permutation {0 1 1 0} + :change {1 :foo 0 :BAR})) + _ (t/is (= @ps (assoc (d/empty-diff 2) :permutation {0 1 1 0}))) + _ (t/is (= @ps1 :BAR)) + _ (t/is (= @ps0 :foo)) + _ (ps0) + _ (t/is (= (q) :step0)) + ps0- (item0 #(q :step0-) #(q :done0-)) + _ (t/is (= (q) :step0-)) + _ (t/is (= nil (try @ps0 (catch Cancelled _)))) + _ (t/is (= (q) :done0)) + _ (step) + _ (t/is (= (hash-set (q) (q)) #{:step :step1})) + _ (q (assoc (d/empty-diff 2) + :change {1 :FOO})) + _ (t/is (= @ps0- :FOO)) + _ (t/is (= nil (try (item1 #(q :step1-) #(q :done1-)) + (catch #?(:clj Error :cljs js/Error) _)))) + _ (step) + _ (t/is (= (hash-set (q)) #{:step0-})) + _ (q (assoc (d/empty-diff 2) + :freeze #{0 1})) + _ (t/is (= @ps1 :BAR)) + _ (t/is (= (q) :done1)) + _ (t/is (= @ps0- :FOO)) + _ (t/is (= (q) :done0-)) + _ (t/is (= @ps (d/empty-diff 2))) + _ (done) + _ (t/is (= (q) :done))])) From 2dccbb44df63ff736fa06a203ac9eaa284aeb36e Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 10 Apr 2024 16:15:21 +0200 Subject: [PATCH 199/428] fix style call in dom/Property --- src/hyperfiddle/electric_dom3.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/hyperfiddle/electric_dom3.cljc b/src/hyperfiddle/electric_dom3.cljc index 72a104d9a..e7f432d89 100644 --- a/src/hyperfiddle/electric_dom3.cljc +++ b/src/hyperfiddle/electric_dom3.cljc @@ -168,7 +168,7 @@ (e/defn Property [node k v] (e/client - (cond (style? k) ($ Style node k v) + (cond (style? k) ($ Styles node v) (class? k) ($ ClassList node v) :else ($ Attribute node k v)))) From af7d84a7e72417568f4dccb27b77551671f28021 Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 10 Apr 2024 16:57:11 +0200 Subject: [PATCH 200/428] dom3: fix return value of `with` Before there was a bug and it had to come last --- src/hyperfiddle/electric_dom3.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/hyperfiddle/electric_dom3.cljc b/src/hyperfiddle/electric_dom3.cljc index e7f432d89..72b3f751d 100644 --- a/src/hyperfiddle/electric_dom3.cljc +++ b/src/hyperfiddle/electric_dom3.cljc @@ -22,7 +22,7 @@ (m/observe (fn [!] (.appendChild parent elem) (! elem) #(.remove elem))))) ;; TODO this should be a simple `binding` but the observer doesn't unmount that way -(defmacro with [elem & body] `(binding [node (e/input (appending> ~elem node))] ~@body node)) +(defmacro with [elem & body] `(binding [node (e/input (appending> ~elem node))] node ~@body)) #?(:cljs (defn -googDomSetTextContentNoWarn [node str] ;; Electric says :infer-warning Cannot infer target type in expression, fixme From 9008b11780be21ed517ad6ae8337cf33ad39506c Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 10 Apr 2024 17:29:07 +0200 Subject: [PATCH 201/428] fix scratch dom node --- scratch/peter/y2024/dom3_event_handling.cljc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/scratch/peter/y2024/dom3_event_handling.cljc b/scratch/peter/y2024/dom3_event_handling.cljc index 95cc4c1d4..50b3ac778 100644 --- a/scratch/peter/y2024/dom3_event_handling.cljc +++ b/scratch/peter/y2024/dom3_event_handling.cljc @@ -28,7 +28,7 @@ (defmacro listen ([typ] `(listen ~typ identity)) - ([typ f] `(listen node ~typ ~f)) + ([typ f] `(listen dom/node ~typ ~f)) ([nd typ f] `(listen ~nd ~typ ~f nil)) ([nd typ f opts] `(e/input (listen1 ~nd ~typ ~f ~opts)))) @@ -47,7 +47,7 @@ (defmacro event-log ([typ] `(event-log ~typ identity)) - ([typ f] `(event-log node ~typ ~f)) + ([typ f] `(event-log dom/node ~typ ~f)) ([nd typ f] `(event-log ~nd ~typ ~f nil)) ([nd typ f opts] `(e/input (event-log* ~nd ~typ ~f ~opts)))) From 3b8b0c41aa5b51be239ab30e822f7fa66e1caade Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Wed, 10 Apr 2024 18:58:52 +0200 Subject: [PATCH 202/428] fix incorrect permutation in latest-concat --- src/hyperfiddle/incseq.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/hyperfiddle/incseq.cljc b/src/hyperfiddle/incseq.cljc index 0bad2ec8e..ab91f6c28 100644 --- a/src/hyperfiddle/incseq.cljc +++ b/src/hyperfiddle/incseq.cljc @@ -900,7 +900,7 @@ sequence. :shrink shrink :degree global-degree :permutation (compose - (p/split-swap (unchecked-add-int offset size-after) shift shrink) + (p/split-swap (unchecked-add-int offset size-after) shrink shift) (into {} (map (juxt (comp +offset key) (comp +offset val))) permutation) (p/split-swap (unchecked-add-int offset size-before) shift grow)) :change (into {} (map (juxt (comp +offset key) val)) change) From e039abaa4bcd5e9c10f28aa93f16d96cbeec8ff8 Mon Sep 17 00:00:00 2001 From: xificurC Date: Fri, 12 Apr 2024 10:09:26 +0200 Subject: [PATCH 203/428] entrypoint cleanup --- src/hyperfiddle/electric/impl/lang_de2.clj | 34 +++++++++++++ src/hyperfiddle/electric_de.cljc | 22 +++------ src/hyperfiddle/electric_local_def_de.cljc | 55 +++------------------- 3 files changed, 48 insertions(+), 63 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 67499704b..c2f449106 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -1027,3 +1027,37 @@ (compile* nm env (analyze (expand-all env `(::ctor ~form)) '_ env (->ts)))) + +(defn collect-deps [deps] + (loop [ret (sorted-set) deps deps] + (if-some [d (first deps)] + (if (ret d) + (recur ret (disj deps d)) + (let [dds (get-deps d)] + (recur (conj ret d) (into deps dds)))) + ret))) + +(defn ->source [env root-key efn] + (let [expanded (expand-all env efn) + _ (when (::print-expansion env) (fipp.edn/pprint expanded)) + ts (analyze expanded '_ env (->ts)) + _ (when (::print-analysis env) (run! prn (->> ts :eav vals (sort-by :db/id)))) + ts (analyze-electric env ts) + ctors (mapv #(emit-ctor ts % env root-key) (get-ordered-ctors-e ts)) + source `(fn ([] ~(emit-fn ts (get-root-e ts) root-key)) + ([idx#] (case idx# ~@(interleave (range) ctors))))] + (when (and (::print-clj-source env) (= :clj (->env-type env))) (fipp.edn/pprint source)) + (when (and (::print-cljs-source env) (= :cljs (->env-type env))) (fipp.edn/pprint source)) + [source ts])) + +(defn ->defs [env root-key efn] + (let [[source ts] (->source env root-key efn) + ret-e (get-ret-e ts (get-child-e ts 0)) + deps (emit-deps ts ret-e) + deps (collect-deps deps) + defs (into {} (map (fn [dep] [(keyword dep) dep])) deps) + defs (assoc defs root-key source)] + (when (and (::print-clj-source env) (= :clj (->env-type env))) (fipp.edn/pprint source)) + (when (and (::print-cljs-source env) (= :cljs (->env-type env))) (fipp.edn/pprint source)) + (when (::print-defs env) (fipp.edn/pprint defs)) + defs)) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 70ef71666..230da128a 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -8,10 +8,11 @@ [hyperfiddle.rcf :as rcf :refer [tests]] #?(:clj [contrib.triple-store :as ts]) #?(:clj [fipp.edn]) - [missionary.core :as m] - [hyperfiddle.electric-local-def-de :as l]) + [missionary.core :as m]) #?(:cljs (:require-macros hyperfiddle.electric-de))) +(def web-config {::lang/peers {:client :cljs, :server :clj}}) + #?(:clj (cc/defn dget [v] `(::lang/lookup ~v))) #?(:clj (cc/defn ->pos-args [n] (eduction (take n) (map dget) (range)))) @@ -93,22 +94,13 @@ Returns the successive states of items described by `incseq`. (defmacro defn [nm & fdecl] (let [[_defn sym] (macroexpand `(cc/defn ~nm ~@fdecl)) - env (merge (meta nm) (lang/normalize-env &env) l/web-config {::lang/def nm}) + env (merge (meta nm) (lang/normalize-env &env) web-config {::lang/def nm}) nm2 (vary-meta nm merge (meta sym)) - expanded (lang/expand-all env `(-fn ~nm2 ~@(cond-> fdecl (string? (first fdecl)) next))) - _ (when (::lang/print-expansion env) (fipp.edn/pprint expanded)) - ts (lang/analyze expanded '_ env (lang/->ts)) - ts (lang/analyze-electric env ts) - k (-> nm ns-qualify keyword) - ctors (mapv #(lang/emit-ctor ts % env k) (lang/get-ordered-ctors-e ts)) - source `(cc/fn ~nm ([] ~(lang/emit-fn ts (lang/get-root-e ts) k)) - ([idx#] (case idx# ~@(interleave (range) ctors)))) + [source ts] (lang/->source env (-> nm ns-qualify keyword) + `(-fn ~nm2 ~@(cond-> fdecl (string? (first fdecl)) next))) deps (lang/emit-deps ts (lang/get-root-e ts)) nm3 (vary-meta nm2 assoc ::lang/deps `'~deps)] - (when-not (::lang/has-edef? (meta *ns*)) - (alter-meta! *ns* assoc ::lang/has-edef? true)) - (when (and (::lang/print-clj-source env) (= :clj (lang/->env-type env))) (fipp.edn/pprint source)) - (when (and (::lang/print-cljs-source env) (= :cljs (lang/->env-type env))) (fipp.edn/pprint source)) + (when-not (::lang/has-edef? (meta *ns*)) (alter-meta! *ns* assoc ::lang/has-edef? true)) `(def ~nm3 ~source))) (defmacro amb " diff --git a/src/hyperfiddle/electric_local_def_de.cljc b/src/hyperfiddle/electric_local_def_de.cljc index 6fa03697c..d3df31c0d 100644 --- a/src/hyperfiddle/electric_local_def_de.cljc +++ b/src/hyperfiddle/electric_local_def_de.cljc @@ -5,6 +5,7 @@ [contrib.assert :as ca] #?(:clj [fipp.edn]) [contrib.cljs-target] + [hyperfiddle.electric-de :as e] [hyperfiddle.electric.impl.lang-de2 :as lang] [hyperfiddle.electric.impl.runtime-de :as r] #?(:clj [contrib.triple-store :as ts]) @@ -20,11 +21,9 @@ (defn ->local-config [env] (let [p (if (:js-globals env) :cljs :clj)] {::lang/peers {:client p, :server p}})) -(def web-config {::lang/peers {:client :cljs, :server :clj}}) - #?(:clj (defmacro test-compile ([nm form] `(test-compile ~nm {} ~form)) - ([nm env form] `(lang/compile ~nm '~form (merge web-config (lang/normalize-env ~env)))))) + ([nm env form] `(lang/compile ~nm '~form (merge e/web-config (lang/normalize-env ~env)))))) #?(:clj (defn code->ts* [env conf form] (ca/check map? conf) @@ -37,36 +36,12 @@ #?(:clj (defmacro code->ts {:style/indent 1} [conf & body] `(code->ts* ~&env ~conf '(do ~@body)))) -#?(:clj - (defn collect-deps [deps] - (loop [ret (sorted-set) deps deps] - (if-some [d (first deps)] - (if (ret d) - (recur ret (disj deps d)) - (let [dds (lang/get-deps d)] - (recur (conj ret d) (into deps dds)))) - ret)))) +#?(:clj (defn ->env [env conf] (merge (->local-config env) (lang/normalize-env env) conf))) (defn run-single [frame] (m/reduce #(do %2) nil frame)) -#?(:clj (defmacro single {:style/indent 1} [conf & body] - (ca/check map? conf) - (let [env (merge (->local-config &env) (lang/normalize-env &env) conf) - expanded (lang/expand-all env `(::lang/ctor (do ~@body))) - ts (lang/analyze expanded '_ env (lang/->ts)) - _ (when (::lang/print-analysis env) (run! prn (->> ts :eav vals (sort-by :db/id)))) - ts (lang/analyze-electric env ts) - ctors (mapv #(lang/emit-ctor ts % env ::Main) (lang/get-ordered-ctors-e ts)) - source `(cc/fn ([] {0 ~(lang/emit-fn ts (lang/get-root-e ts) ::Main)}) - ([idx#] (case idx# ~@(interleave (range) ctors)))) - ret-e (lang/get-ret-e ts (lang/get-child-e ts 0)) - deps (lang/emit-deps ts ret-e) - deps (collect-deps deps) - defs (into {} (map (fn [dep] [(keyword dep) dep])) deps) - defs (assoc defs ::Main source)] - (when (and (::lang/print-clj-source env) (= :clj (lang/->env-type env))) (fipp.edn/pprint source)) - (when (and (::lang/print-cljs-source env) (= :cljs (lang/->env-type env))) (fipp.edn/pprint source)) - (when (::lang/print-defs env) (fipp.edn/pprint defs)) - `(run-single (r/root-frame ~defs ::Main))))) +(defmacro single {:style/indent 1} [conf & body] + (ca/is conf map? "provide config map as first argument") + `(run-single (r/root-frame ~(lang/->defs (->env &env conf) ::Main `(e/fn [] (do ~@body))) ::Main))) (defn run-local [defs main] (m/reduce #(do %2) nil @@ -79,20 +54,4 @@ (defmacro local {:style/indent 1} [conf & body] (ca/is conf map? "provide config map as first argument") - (let [env (merge (->local-config &env) (lang/normalize-env &env) conf) - expanded (lang/expand-all env `(::lang/ctor (do ~@body))) - ts (lang/analyze expanded '_ env (lang/->ts)) - _ (when (::lang/print-analysis env) (run! prn (->> ts :eav vals (sort-by :db/id)))) - ts (lang/analyze-electric env ts) - ctors (mapv #(lang/emit-ctor ts % env ::Main) (lang/get-ordered-ctors-e ts)) - source `(cc/fn ([] {0 ~(lang/emit-fn ts (lang/get-root-e ts) ::Main)}) - ([idx#] (case idx# ~@(interleave (range) ctors)))) - ret-e (lang/get-ret-e ts (lang/get-child-e ts 0)) - deps (lang/emit-deps ts ret-e) - deps (collect-deps deps) - defs (into {} (map (fn [dep] [(keyword dep) dep])) deps) - defs (assoc defs ::Main source)] - (when (and (::lang/print-clj-source env) (= :clj (lang/->env-type env))) (fipp.edn/pprint source)) - (when (and (::lang/print-cljs-source env) (= :cljs (lang/->env-type env))) (fipp.edn/pprint source)) - (when (::lang/print-defs env) (fipp.edn/pprint defs)) - `(run-local ~defs ::Main))) + `(run-local ~(lang/->defs (->env &env conf) ::Main `(e/fn [] (do ~@body))) ::Main)) From f983b05d7057048d0d26e96975dacdcd77a41101 Mon Sep 17 00:00:00 2001 From: xificurC Date: Fri, 12 Apr 2024 14:33:36 +0200 Subject: [PATCH 204/428] websocket de entrypoint --- src/hyperfiddle/electric/impl/runtime_de.cljc | 3 + src/hyperfiddle/electric_client_de.cljs | 171 +++++++++++ src/hyperfiddle/electric_de.cljc | 13 + src/hyperfiddle/electric_ring_adapter_de.clj | 266 ++++++++++++++++++ 4 files changed, 453 insertions(+) create mode 100644 src/hyperfiddle/electric_client_de.cljs create mode 100644 src/hyperfiddle/electric_ring_adapter_de.clj diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 1edfeba76..c4d49ac87 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -916,6 +916,9 @@ Returns a peer definition from given definitions and main key. peer-result-success pst)))) (peer-input-ready peer) peer))) +(defn subject-at [^objects arr slot] + (fn [!] (aset arr slot !) #(aset arr slot nil))) + #?(:clj (defmethod print-method Slot [^Slot slot ^Writer w] (.write w "#Slot[") diff --git a/src/hyperfiddle/electric_client_de.cljs b/src/hyperfiddle/electric_client_de.cljs new file mode 100644 index 000000000..fc3bd60e7 --- /dev/null +++ b/src/hyperfiddle/electric_client_de.cljs @@ -0,0 +1,171 @@ +(ns hyperfiddle.electric-client-de + (:require [contrib.cljs-target :refer [do-browser]] + [missionary.core :as m] + [hyperfiddle.electric.impl.runtime-de :as r]) + (:import missionary.Cancelled)) + +(goog-define ELECTRIC_USER_VERSION "hyperfiddle_electric_client__dirty") ; url safe + +(do-browser + (defn server-url [] + (let [url (new js/URL (.-location js/window)) + proto (.-protocol url)] + (set! (.-protocol url) + (case proto + "http:" "ws:" + "https:" "wss:" + (throw (ex-info "Unexpected protocol" proto)))) + (.. url -searchParams (set "ELECTRIC_USER_VERSION" ELECTRIC_USER_VERSION)) + (set! (.-hash url) "") ; fragment is forbidden in WS URL https://websockets.spec.whatwg.org/#ref-for-dom-websocket-websocket%E2%91%A0 + (.toString url)))) + +(def ^:dynamic *ws-server-url* (do-browser (server-url))) + +(defn remove-listeners [ws] + (set! (.-onopen ws) nil) + (set! (.-onclose ws) nil)) + +(defn connect [url] + (fn [s f] + (try + (let [ws (new js/WebSocket url)] + (set! (.-binaryType ws) "arraybuffer") + (set! (.-onopen ws) + (fn [_] + (remove-listeners ws) + (s ws))) + (set! (.-onclose ws) + (fn [_] + (remove-listeners ws) + (s nil))) + #(when (= (.-CONNECTING js/WebSocket) (.-readyState ws)) + (.close ws))) + (catch :default e + (f e) #())))) + +(defn wait-for-flush [ws] + (m/sp + (while (< 4096 (.-bufferedAmount ws)) + (m/? (m/sleep 50))))) + +(defn wait-for-close [ws] + (fn [s f] + (set! (.-onclose ws) + (fn [e] + (set! (.-onclose ws) nil) + (s {:code (.-code e) + :reason (.-reason e)}))) + #(when-not (nil? (.-onclose ws)) + (set! (.-onclose ws) nil) + (f (Cancelled.))))) + +(defn payload [x] + (.-data x)) + +(defn send! [ws msg] + (doto ws (.send msg))) + +(defn send-all [ws msgs] + (m/reduce {} nil (m/ap (m/? (wait-for-flush (send! ws (m/?> msgs))))))) + +(defn handle-hf-heartbeat [ws cb] + (fn [msg] + (if (= msg "HEARTBEAT") + (send! ws "HEARTBEAT") + (cb msg)))) + +(defn connector " +cb : the callback for incoming messages. +msgs : the discrete flow of messages to send, spawned when websocket is connected, cancelled on websocket close. +Returns a task producing nil or failing if the websocket was closed before end of reduction. " + [cb msgs] + (m/sp + (if-some [ws (m/? (connect *ws-server-url*))] + (try + (set! (.-onmessage ws) (comp (handle-hf-heartbeat ws cb) payload)) + (m/? (m/race (send-all ws msgs) (wait-for-close ws))) + (finally + (when-not (= (.-CLOSED js/WebSocket) (.-readyState ws)) + (.close ws) (m/? (m/compel wait-for-close))))) + {}))) + +(defn fib-iter [[a b]] + (case b + 0 [1 1] + [b (+ a b)])) + +(def fib (map first (iterate fib-iter [1 1]))) + +(comment (take 5 fib2) := [1 1 2 3 5]) + +(def retry-delays (map (partial * 100) (next fib))) +;; Browsers throttle websocket connects after too many attempts in a short time. +;; To prevent using browsers as port scanners. +;; Symptom: WS takes a long time to establish a connection for no apparent reason. +;; Sometimes happens in dev after multiple page refreshes in a short time. + +(comment (take 5 retry-delays)) + +(defn wait-for-window-to-be-visible + "Return a task completing when the current browser tab or window becomes visible + to the user, or immediately if it is already visible. Use case: detect when a + background tab becomes active again." + [] + (let [visible! (m/dfv) + visible? #(= "visible" (.-visibilityState js/document))] + (letfn [(on-visibility-change [_] + ;; don't use a one-off event-listener because the visiblitichange + ;; event's spec doesn't say "visible" means the page was "hidden" + ;; before. "hidden" or "visible" could therefore fire more than + ;; once. Spec: https://html.spec.whatwg.org/multipage/interaction.html#page-visibility + (when (visible?) + (.removeEventListener js/document "visibilitychange" on-visibility-change) + (visible! true)))] + (if (visible?) + (visible! true) + (.addEventListener js/document "visibilitychange" on-visibility-change))) + visible!)) + +(defn boot-with-retry [client conn] + (m/sp + (let [ws-server-url *ws-server-url*] + (loop [delays retry-delays] + (let [s (object-array 1)] + (.log js/console "Connecting...") + (when-some [[delay & delays] + (when-some [info (binding [*ws-server-url* ws-server-url] + (m/? (conn (fn [x] ((aget s 0) x)) + (client (r/subject-at s 0)))))] + (if-some [code (:code info)] + (let [retry? (case code ; https://www.rfc-editor.org/rfc/rfc6455#section-7.4.1 + (1000 1001) (do (js/console.debug (str "Electric websocket disconnected - " code)) true) + (1005 1006) (do (js/console.log "Electric Websocket connection lost.") true) + (1008) (throw (ex-info "Stale Electric client" {:hyperfiddle.electric/type ::stale-client})) + (1012) ; Incompatible client. Do not attempt to reconnect (it would fail again) + (js/console.error (str "A mismatch between Electric client and server's programs was detected." + "\nThe connection was closed. Refresh the page to attempt a reconnect." + "\nCommonly, in local dev envs, this is a stale browser tab auto-reconnecting, or the clj and cljs REPLs are out of sync due to evaluating an Electric def in one process but not the other." + "\nThis should not happen in prod. See `https://github.com/hyperfiddle/electric-starter-app/` for a reference configuration.")) + (1013) ; server timeout - The WS spec defines 1011 - arbitrary server error, + ; and 1015 - TLS exception. 1012, 1013, and 1014 are undefined. We + ; pick 1013 for "Server closed the connection because it didn't hear of + ; this client for too long". + (do (js/console.log "Electric server timed out, considering this Electric client inactive.") + true) + ; else + (do (js/console.log (str "Electric Websocket disconnected for an unexpected reason - " (pr-str info))) + true))] + (when retry? + (m/? (wait-for-window-to-be-visible)) + (seq retry-delays))) + (do (.log js/console "Electric client failed to connect to Electric server.") delays)))] + (.log js/console (str "Next attempt in " (/ delay 1000) " seconds.")) + (recur (m/? (m/sleep delay delays))))))))) + +(defn reload-when-stale [task] + (fn [s f] + (task s (fn [error] + (when (= ::stale-client (:hyperfiddle.electric/type (ex-data error))) + (do (js/console.log "Electric server and Electric client version mismatches. Refreshing page to load new assets.") + (.reload (.-location js/window)))) + (f error))))) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 230da128a..d2372a26f 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -243,3 +243,16 @@ this tuple. Returns the concatenation of all body results as a single vector. Standard electric code runs on mount, therefore there is no `on-mount`." [f] `(input (on-unmount* ~f))) ; experimental + +(defmacro boot-server [opts Main & args] + (let [env (merge (lang/normalize-env &env) web-config opts) + defs (lang/->defs env ::Main `(e/fn [] ($ ~Main ~@args)))] + `(cc/fn [events#] (m/stream (r/peer events# :server ~defs ::Main))))) + +(defmacro boot-client [opts Main & args] + (let [env (merge (lang/normalize-env &env) web-config opts) + defs (lang/->defs env ::Main `(e/fn [] ($ ~Main ~@args)))] + `(hyperfiddle.electric-client-de/reload-when-stale + (hyperfiddle.electric-client-de/boot-with-retry + (cc/fn [events#] (m/stream (r/peer events# :client ~defs ::Main))) + hyperfiddle.electric-client-de/connector)))) diff --git a/src/hyperfiddle/electric_ring_adapter_de.clj b/src/hyperfiddle/electric_ring_adapter_de.clj new file mode 100644 index 000000000..913372de6 --- /dev/null +++ b/src/hyperfiddle/electric_ring_adapter_de.clj @@ -0,0 +1,266 @@ +(ns hyperfiddle.electric-ring-adapter-de + "Provide a `wrap-electric-websocket` Ring middleware, starting and managing an Electric Server. + This is a Ring 1.11+ compliant, generic implementation. It is compatible with + ring-jetty out of the box, and can be extended to other servers. See + `hyperfiddle.electric-httpkit-adapter` for an example of an extension." + (:refer-clojure :exclude [send]) + (:require [clojure.tools.logging :as log] + [hyperfiddle.electric-de :as-alias e] + [hyperfiddle.electric.impl.runtime-de :as r] + [hyperfiddle.electric.debug :as dbg] + [missionary.core :as m] + [ring.websocket :as ws]) + (:import missionary.Cancelled)) + +(def ELECTRIC-CONNECTION-TIMEOUT + "Time after which the server will close the socket if it hasn't seen any websocket activity from the client." + ;; https://www.notion.so/hyperfiddle/electric-server-heartbeat-issues-4243f981954c419f8eb0785e8e789fb7?pvs=4 + 59000) + +(def ELECTRIC-HEARTBEAT-INTERVAL + "Delay between two server-send ping-emulating messages. Used to keep the connection up." + 45000) + +(defprotocol Socket + "An abstraction over various Socket impl. E.g. Ring-websocket Socket or HTTPKit + AsyncChannel" + (open? [this]) + (close [this code] [this code reason]) + (send [this value] [this value success-cb failure-cb])) + +(defprotocol Pingable + (ping [this] [this value]) + (pong [this] [this value])) + +(defrecord RingSocket [socket] + Socket + (open? [_] (ws/open? socket)) + (close [_this code] (ws/close socket code "")) + (close [_this code reason] (ws/close socket code reason)) + (send [_this value] (ws/send socket value)) + (send [_this value success-cb failure-cb] (ws/send socket value success-cb failure-cb)) + Pingable + (ping [_this] (ws/ping socket)) + (ping [_this value] (ws/ping socket (if (string? value) (java.nio.ByteBuffer/wrap (.getBytes value)) value))) + (pong [_this] (ws/pong socket)) + (pong [_this value] (ws/pong socket (if (string? value) (java.nio.ByteBuffer/wrap (.getBytes value)) value)))) + +(defn reject-websocket-handler + "Will accept socket connection upgrade and immediately close the socket on + connection, with given `code` and `reason`. Use this to cleanly reject a + websocket connection." + ;; Rejecting the HTTP 101 Upgrade request would also prevent the socket to + ;; open, but for security reasons, the client is never informed of the HTTP + ;; 101 failure cause. + [code reason] + {:on-open (fn [socket] (close (RingSocket. socket) code reason))}) + +(defn failure + "Called on reactor termination, connection timeout, or reactor crash. A + connection timeout or reactor crash will close the socket. " + [socket ^Throwable e] + (if (instance? Cancelled e) + (log/debug "Websocket handler completed gracefully.") + ;; Reactor shuts down asynchronously on socket close. User code can throw + ;; during cancellation phase, so the reactor can fail while shutting down. + ;; In which case socket will already be closed. + (when (open? socket) + (let [{::keys [type time-seconds] :as ex-data} (ex-data e)] + (case (or type (::e/type ex-data)) + ::timeout + (do (log/info (format "Connection to client lost after %ss. Closing socket." time-seconds)) + (close socket 1013 "Try again later")) + ::e/misaligned-dag + (do (log/error (ex-message e)) + (close socket 1012 "Misaligned client")) + (do + (log/error (dbg/update-stack-trace! e #(filter (partial dbg/stack-element-matches? #"hyperfiddle.*") %)) + "Websocket handler failure." ex-data) + (close socket 1011 "Server process crash"))))))) + +(defn write-msg + "Return a task, writing a message on a websocket when run." + [socket message] + (fn [s f] + (try + ;; Usually throws IOException, but can also throw NPE when socket remote went away. + (send socket message (fn write-success [] (s :ack)) (fn write-failed [err] (f err))) + (catch Throwable e (f e))) + #())) + +(defn timeout + "Throw if `mailbox` haven't got any message after given `time` ms" + [mailbox time] + (m/sp + (loop [] + (when (= :timeout (m/? (m/timeout mailbox time :timeout))) + (throw (ex-info "No message received after specified time" {::type ::timeout, ::time-seconds (int (/ time 1000))}))) + (recur)))) + +(defn send-hf-heartbeat [delay ping!] + (m/sp (loop [] (m/? (m/sleep delay)) (ping!) (recur)))) + +(defmulti handle-close-status-code + "Perform an action on socket close, dispatching on status code. List of status + code and their meaning: + https://www.rfc-editor.org/rfc/rfc6455.html#section-7.4.1" + (fn [_ring-req _socket status-code & [_reason]] status-code)) + +(defmethod handle-close-status-code 1000 ; normal closure + [_ring-req _socket status-code & [reason]] + (log/debug "Client disconnected gracefully" {:status status-code, :reason reason})) + +(defmethod handle-close-status-code 1001 ; remote (client) is going away + ;; Graceful disconnect. Typical of a hard navigation or tab close. + [_ring-req _socket status-code & [reason]] + (log/debug "Client navigated away" {:status status-code, :reason reason})) + +(defmethod handle-close-status-code 1005 ; placeholder for no known status code + ;; default code set by Chrome and FF unless specified. + [_ring-req _socket status-code & [reason]] + (log/debug "Client disconnected for an unknown reason (browser default close code)" {:status status-code, :reason reason})) + +(def GENERIC-WS-CLOSE-MESSAGES + "https://www.rfc-editor.org/rfc/rfc6455.html#section-7.4.1" + {1000 "Normal close" + 1001 "Client navigated away gracefully" + 1002 "Client closed websocket due to protocol error" + 1003 "Client closed websocket because it received unexpected data type" + 1004 "Websocket got closed for an unknown reason with a reserved status code." + 1005 "Client closed websocket without providing a close status code" + 1006 "Client closed websocket abnormally" + 1007 "Client closed websocket because it received a message with inconsistent data in the message (e.g. wrong encoding)" + 1008 "Client closed websocket because it received a message violating its policy." + 1009 "Client closed websocket because it received a message that is too big to be processed." + 1010 "Client closed websocket because the server failed to negotiate a client-required extension during handshake." + 1011 "Server closed websocket because of an unexpected condition." + 1015 "TLS handshake failure while establishing websocket connection."}) + +(defmethod handle-close-status-code :default + [_ring-req _socket status-code & [reason]] + (log/debug (GENERIC-WS-CLOSE-MESSAGES status-code "Client disconnected for an unexpected reason") {:status status-code :reason reason})) + +(defn electric-ws-handler + "Return a map of generic ring-compliant handlers, describing how to start and manage an Electric server process hooked onto a websocket. + Extensions (e.g. `hyperfiddle.electric-httpkit-adapter`) can extend the handler map as needed." + [ring-req boot-fn] + (let [state (object-array 2) + on-message-slot (int 0) + on-close-slot (int 1) + keepalive-mailbox (m/mbx)] + {:on-open (fn on-open [socket] + (log/debug "WS connect" ring-req) + (aset state on-close-slot + ((m/join (fn [& _]) + (timeout keepalive-mailbox ELECTRIC-CONNECTION-TIMEOUT) + (m/reduce #(write-msg socket %2) nil ((boot-fn ring-req) (r/subject-at state on-message-slot))) + (send-hf-heartbeat ELECTRIC-HEARTBEAT-INTERVAL #(ping socket "HEARTBEAT"))) + {} (partial failure socket)))) ; Start Electric process + :on-close (fn on-close [_socket _status-code & [_reason]] + ((aget state on-close-slot))) + :on-error (fn on-error [_socket err] + (if (and (instance? java.nio.channels.ClosedChannelException err) (nil? (ex-message err))) + (log/debug "Websocket was closed unexpectedly") ; common in dev + (log/error err "Websocket error"))) + :on-ping (fn on-ping [socket data] ; keep connection alive + (keepalive-mailbox nil)) + :on-pong (fn on-pong [_socket _bytebuffer] ; keep connection alive + (keepalive-mailbox nil)) + :on-message (fn on-message [_socket text-or-buff] + (keepalive-mailbox nil) + (if (instance? CharSequence text-or-buff) + (let [text text-or-buff] + (log/trace "text received" text) + (when-not (= "HEARTBEAT" text) + ((aget state on-message-slot) text))) + (let [^java.nio.ByteBuffer buff text-or-buff] + (log/trace "bytes received" (- (.limit buff) (.position buff))) + ((aget state on-message-slot) text-or-buff))))})) + +(defn ring-ws-handler + "Return a Ring 1.11+ websocket listener starting and managing an Electric Server process." + [ring-req boot-fn] + (let [{:keys [on-open on-close on-error on-ping on-pong on-message]} (electric-ws-handler ring-req boot-fn)] + {::ws/listener + (-> {:on-open on-open + :on-close (fn [socket status-code reason] + (handle-close-status-code ring-req socket (long status-code) reason) + (on-close socket status-code reason)) + :on-error on-error + :on-ping (fn [socket data] + (on-ping socket data) + (pong socket data)) + :on-pong on-pong + :on-message on-message} + (update-vals + (fn [f] + (fn [socket & args] + (apply f (RingSocket. socket) args)))))})) + +(defn wrap-electric-websocket + "A ring middleware starting an Electric server program defined by `electric-boot-fn` on websocket connection. + E.g.: + ``` + (-> ring-handler + (wrap-electric-websocket (fn [ring-req] (e/boot-server {} my-ns/MyElectricDefn ring-req))) + (wrap-cookies) + (wrap-params) + ... + ) + ```" + [next-handler entrypoint] + (fn [ring-request] + (if (ws/upgrade-request? ring-request) + (ring-ws-handler ring-request entrypoint) + (next-handler ring-request)))) + +(defn wrap-reject-stale-client + "A Ring 1.11+ compatible middleware intercepting websocket UPGRADE request and + checking if Electric client and Electric server versions matches. + An Electric client is allowed to connect if: + - its version matches the server's version, + - the server does not have a defined version (dev mode). + Otherwise, the websocket connection is gracefully rejected and the client is + instructed to reload the page so to get new javascript assets. + + The rejection action can be redefined by providing an `on-mismatch` callback + argument taking: + - ring upgrade request, + - client-version, + - server-version, + and returning the ring handler to be applied. + + e.g. + With ring-jetty 1.11+ + ``` + (wrap-reject-stale-client handler {:hyperfiddle.electric/user-version nil}) ; will accept any client + (wrap-reject-stale-client handler {:hyperfiddle.electric/user-version \"12345\"}) ; will only accept clients of version 12345 + ``` + + With http-kit, which is not fully ring 1.11+ compliant as of Jan 9 2024 + ``` + (wrap-reject-stale-client handler {:hyperfiddle.electric/user-version \"12345\"} + (fn on-mismatch [ring-request client-version server-version] + (log/info 'wrap-reject-stale-client \": Electric client connection was rejected because client version doesn't match the server version. Client was instructed to perform a page reload so to get new javascript assets.\" + {:client-version (pr-str client-version) + :server-version (pr-str server-version)}) + (httpkit/as-channel ring-request ; this is HTTPkit specific + (electric-httpkit/reject-websocket-handler 1008 \"stale client\") ; Websocket close code 1008 instructs the Electric client of the version mismatch + ))) + ```" + ([next-handler config] + (wrap-reject-stale-client next-handler config + (fn on-mismatch [_ring-request client-version server-version] + (log/info 'wrap-reject-stale-client ": Electric client connection was rejected because client version doesn't match the server version. Client was instructed to perform a page reload so to get new javascript assets." + {:client-version (pr-str client-version) + :server-version (pr-str server-version)}) + {::ws/listener (reject-websocket-handler 1008 "stale client")}))) ; https://www.rfc-editor.org/rfc/rfc6455#section-7.4.1 + ([next-handler {:keys [:hyperfiddle.electric/user-version]} on-missmatch] + (fn [ring-request] + (if (ws/upgrade-request? ring-request) + (let [client-version (get-in ring-request [:query-params "ELECTRIC_USER_VERSION"])] + (cond + (nil? user-version) (next-handler ring-request) + (= client-version user-version) (next-handler ring-request) + :else (on-missmatch ring-request client-version user-version))) + (next-handler ring-request))))) From 9293877f324f3ee3d41d00b0e966ae1c64c50c3a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Fri, 12 Apr 2024 14:51:44 +0200 Subject: [PATCH 205/428] fix incorrect ready port consumption when port is disabled --- src/hyperfiddle/electric/impl/runtime_de.cljc | 76 +++++++++---------- test/hyperfiddle/electric_de_test.cljc | 12 +++ 2 files changed, 50 insertions(+), 38 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index c4d49ac87..8d32608ae 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -324,6 +324,8 @@ T T T -> (EXPR T) [^Frame frame] (.-site frame)) +(declare port-slot) + (defn peer-push [^Peer peer offset item] (let [^objects state (.-state peer) ^objects queues (.-queues peer) @@ -367,8 +369,6 @@ T T T -> (EXPR T) (defn port-site [^objects port] (aget port port-slot-site)) -(declare port-slot) - (deftype Remote [port step done] IFn (#?(:clj invoke :cljs -invoke) [_] @@ -552,60 +552,60 @@ T T T -> (EXPR T) tap-pull 0 untap-pull 0 toggle-pull 0 - change-pull 0] + ready-pull 0] (let [^objects tap-queue (aget queues peer-queue-tap) ^objects untap-queue (aget queues peer-queue-untap) ^objects toggle-queue (aget queues peer-queue-toggle) ^objects ready-queue (aget queues peer-queue-ready)] (if-some [^objects remote-port (aget tap-queue tap-pull)] (do (aset tap-queue tap-pull nil) - (let [prev (aget remote-port port-slot-requested)] + (let [tap-pull (rem (unchecked-inc-int tap-pull) + (alength tap-queue)) + prev (aget remote-port port-slot-requested)] (aset remote-port port-slot-requested (inc prev)) (reduce-kv local-port-tap nil (port-deps remote-port)) (recur (if (zero? (+ prev (aget remote-port port-slot-refcount))) (conj toggle (port-slot remote-port)) toggle) change freeze - (rem (unchecked-inc-int tap-pull) - (alength tap-queue)) untap-pull toggle-pull change-pull))) + tap-pull untap-pull toggle-pull ready-pull))) (if-some [^objects remote-port (aget untap-queue untap-pull)] (do (aset untap-queue untap-pull nil) - (let [curr (dec (aget remote-port port-slot-requested))] + (let [untap-pull (rem (unchecked-inc-int untap-pull) + (alength untap-queue)) + curr (dec (aget remote-port port-slot-requested))] (aset remote-port port-slot-requested curr) (reduce-kv local-port-untap nil (port-deps remote-port)) (recur (if (zero? (+ curr (aget remote-port port-slot-refcount))) (conj toggle (port-slot remote-port)) toggle) change freeze - tap-pull (rem (unchecked-inc-int untap-pull) - (alength untap-queue)) toggle-pull change-pull))) + tap-pull untap-pull toggle-pull ready-pull))) (if-some [^objects local-port (aget toggle-queue toggle-pull)] (do (aset toggle-queue toggle-pull nil) - (if (zero? (aget local-port port-slot-requested)) - (do (aset local-port port-slot-requested (identity 1)) - (reduce-kv remote-port-tap nil (port-deps local-port)) - (when (zero? (aget local-port port-slot-refcount)) - (enable local-port))) - (do (aset local-port port-slot-requested (identity 0)) - (reduce-kv remote-port-untap nil (port-deps local-port)) - (when (zero? (aget local-port port-slot-refcount)) - (disable local-port)))) - (recur toggle change freeze tap-pull untap-pull - (rem (unchecked-inc-int toggle-pull) - (alength toggle-queue)) change-pull)) - (if-some [^objects local-port (aget ready-queue change-pull)] - (do (aset ready-queue change-pull nil) - (if-some [ps (port-process local-port)] - (if (aget local-port port-slot-state) - (recur toggle change (conj freeze (port-slot local-port)) - tap-pull untap-pull toggle-pull - (rem (unchecked-inc-int change-pull) - (alength ready-queue))) - (let [diff @ps - slot (port-slot local-port)] - (recur toggle (assoc change - slot (if-some [p (change slot)] - (i/combine p diff) diff)) - freeze tap-pull untap-pull toggle-pull - (rem (unchecked-inc-int change-pull) - (alength ready-queue))))) - (recur toggle change freeze tap-pull untap-pull toggle-pull change-pull))) + (let [toggle-pull (rem (unchecked-inc-int toggle-pull) + (alength toggle-queue))] + (if (zero? (aget local-port port-slot-requested)) + (do (aset local-port port-slot-requested (identity 1)) + (reduce-kv remote-port-tap nil (port-deps local-port)) + (when (zero? (aget local-port port-slot-refcount)) + (enable local-port))) + (do (aset local-port port-slot-requested (identity 0)) + (reduce-kv remote-port-untap nil (port-deps local-port)) + (when (zero? (aget local-port port-slot-refcount)) + (disable local-port)))) + (recur toggle change freeze tap-pull untap-pull toggle-pull ready-pull))) + (if-some [^objects local-port (aget ready-queue ready-pull)] + (do (aset ready-queue ready-pull nil) + (let [ready-pull (rem (unchecked-inc-int ready-pull) + (alength ready-queue))] + (if-some [ps (port-process local-port)] + (if (aget local-port port-slot-state) + (recur toggle change (conj freeze (port-slot local-port)) + tap-pull untap-pull toggle-pull ready-pull) + (let [diff @ps + slot (port-slot local-port)] + (recur toggle (assoc change + slot (if-some [p (change slot)] + (i/combine p diff) diff)) + freeze tap-pull untap-pull toggle-pull ready-pull))) + (recur toggle change freeze tap-pull untap-pull toggle-pull ready-pull)))) (let [acks (aget state peer-slot-output-acks)] (aset state peer-slot-output-acks (identity 0)) (aset state peer-slot-output-pending true) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index d9f7e18ef..6e38715bb 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -2175,3 +2175,15 @@ (binding [Self (e/fn [] 111)] (tap (= Bar (e/$ Bar)))))) tap tap) % := false)) + +(tests + (def !offset (atom 0)) + (with ((l/local {} + (e/cursor [j (let [o (e/watch !offset)] + (e/diff-by identity + (range o (+ o 2))))] + (e/server (tap j)))) + tap tap) + (hash-set % %) := #{0 1} + (swap! !offset inc) + % := 2)) \ No newline at end of file From b15768446d25b4cf567d8b8f36002fd3673d9eb7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Fri, 12 Apr 2024 18:14:19 +0200 Subject: [PATCH 206/428] workaround cljs transit quirks --- src/hyperfiddle/electric/impl/runtime_de.cljc | 61 ++++++++++--------- 1 file changed, 32 insertions(+), 29 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 8d32608ae..f90ae0a1d 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -847,34 +847,37 @@ Returns a peer definition from given definitions and main key. ^Frame root (->> args (eduction (map pure)) (apply dispatch ((defs main))) - (make-frame peer nil 0 :client))] + (make-frame peer nil 0 :client)) + handlers {Slot (t/write-handler + (fn [_] "slot") + (fn [^Slot slot] + [(.-frame slot) (.-id slot)])) + Frame (t/write-handler + (fn [_] "frame") + (fn [^Frame frame] + [(frame-path frame) + (when-not (frame-shared? frame) + (frame-share frame) + (.-ctor frame))])) + Ap (t/write-handler + (fn [_] "ap") + (fn [^Ap ap] + (.-inputs ap))) + ;; must wrap payload in vector, cf https://github.com/cognitect/transit-cljs/issues/23 + Pure (t/write-handler + (fn [_] "pure") + (fn [^Pure pure] + [(.-value pure)])) + Join (t/write-handler + (fn [_] "join") + (fn [^Join join] + [(.-input join)]))} + default (t/write-handler + (fn [_] "unserializable") + (fn [_]))] (aset state peer-slot-writer-opts - {:default-handler (t/write-handler - (fn [_] "unserializable") - (fn [_] (comment TODO fetch port info))) - :handlers {Slot (t/write-handler - (fn [_] "slot") - (fn [^Slot slot] - [(.-frame slot) (.-id slot)])) - Frame (t/write-handler - (fn [_] "frame") - (fn [^Frame frame] - [(frame-path frame) - (when-not (frame-shared? frame) - (frame-share frame) - (.-ctor frame))])) - Join (t/write-handler - (fn [_] "join") - (fn [^Join join] - (.-input join))) - Ap (t/write-handler - (fn [_] "ap") - (fn [^Ap ap] - (.-inputs ap))) - Pure (t/write-handler - (fn [_] "pure") - (fn [^Pure pure] - (.-value pure)))}}) + #?(:clj {:handlers handlers :default-handler default} + :cljs {:handlers (assoc handlers :default default)})) (aset state peer-slot-reader-opts {:handlers {"slot" (t/read-handler (fn [[frame id]] @@ -890,13 +893,13 @@ Returns a peer definition from given definitions and main key. frame (make-frame peer slot rank site ctor)] (frame-share frame) frame)))) "join" (t/read-handler - (fn [input] + (fn [[input]] (->Join input nil))) "ap" (t/read-handler (fn [inputs] (->Ap inputs nil))) "pure" (t/read-handler - (fn [value] + (fn [[value]] (->Pure value nil))) "unserializable" (t/read-handler (fn [_] From 2e3e4b9c63fc6588f0db065f10a815a56743b6d7 Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 15 Apr 2024 10:45:57 +0200 Subject: [PATCH 207/428] compiler: clj compiles in presence of cljs-sided js constructor This didn't compile before this fix (e/client (fn [] (js/Date.))) because on clj side we also emitted `(new js/Date)`. Now we emit a vector of conveyed references. --- src/hyperfiddle/electric/impl/lang_de2.clj | 7 +++++-- test/hyperfiddle/electric/impl/compiler_test.cljc | 10 ++++++++++ 2 files changed, 15 insertions(+), 2 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index c2f449106..802c5baa6 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -531,8 +531,11 @@ (quote) (let [e (->id)] (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form}))) - (fn*) (let [e (->id), [form refs] (closure env form)] - (ap-literal form refs pe e env (?add-source-map ts e form))) + (fn*) (let [e (->id), [form refs] (closure env form) + current (get (::peers env) (::current env))] + (if (or (nil? current) (= (->env-type env) current)) + (ap-literal form refs pe e env (?add-source-map ts e form)) + (recur `[~@refs] pe env ts))) (::cc-letfn) (let [[_ bs] form, [form refs] (closure env `(letfn* ~bs ~(vec (take-nth 2 bs)))), e (->id)] (ap-literal form refs pe e env (?add-source-map ts e form))) (new) (let [[_ f & args] form, current (get (::peers env) (::current env))] diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index a65412e04..9535fb3a9 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -504,6 +504,16 @@ (r/cdef 0 [] [] nil (fn [~'frame] (r/pure 1))) (r/cdef 0 [] [] nil (fn [~'frame] (r/pure 2)))])) +(tests "cc-fn-wrapping-js-constructor" + (match (l/test-compile ::Main (e/client (fn [] (js/Date.)))) + `[(r/cdef 0 [] [] :client + (fn [~'frame] (r/pure (vector))))]) ; shim, no conveyed values + (match (l/test-compile ::Main (let [x 1] (e/client (fn [] (js/Date. x))))) + `[(r/cdef 0 [nil] [] :client + (fn [~'frame] + (r/define-node ~'frame 0 (r/pure 1)) + (r/ap (r/pure vector) (r/node ~'frame 0))))])) ; shim, conveyed `x` + (comment (let [ts (l/code->ts {} (prn :hello)) From 0b4b86389fa2b920fe5424f42073f54bdc67180f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Mon, 15 Apr 2024 14:11:17 +0200 Subject: [PATCH 208/428] cljs custom writers --- src/hyperfiddle/electric/impl/runtime_de.cljc | 26 +++++++++++++++++-- 1 file changed, 24 insertions(+), 2 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index f90ae0a1d..3c5318259 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -928,7 +928,16 @@ Returns a peer definition from given definitions and main key. (print-method (.-frame slot) w) (.write w " ") (print-method (.-id slot) w) - (.write w "]"))) + (.write w "]")) + :cljs + (extend-protocol IPrintWithWriter + Slot + (-pr-writer [slot w o] + (-write w "#Slot[") + (-pr-writer (.-frame slot) w o) + (-write w " ") + (-write w (.-id slot)) + (-write w "]")))) #?(:clj (defmethod print-method Frame [^Frame frame ^Writer w] @@ -940,7 +949,20 @@ Returns a peer definition from given definitions and main key. (.write w " ") (print-method x w) (recur xs)))) - (.write w "]"))) + (.write w "]")) + :cljs + (extend-protocol IPrintWithWriter + Frame + (-pr-writer [frame w o] + (-write w "#Frame[") + (when-some [[x & xs] (seq (frame-path frame))] + (-write w x) + (loop [xs xs] + (when-some [[x & xs] xs] + (-write w " ") + (-write w x) + (recur xs)))) + (-write w "]")))) ;; local only (defn root-frame [defs main] From 98a44e743d96fa78f9b1fe8b38b35bbe0764ea35 Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 15 Apr 2024 17:07:29 +0200 Subject: [PATCH 209/428] compiler: js lib support, this binding --- .../electric/impl/cljs_analyzer2.clj | 19 ++- src/hyperfiddle/electric/impl/lang_de2.clj | 41 ++++--- .../electric/impl/cljs_analyzer2_test.clj | 116 ++++++++++++++++++ .../electric/impl/cljs_file_to_analyze.cljs | 3 +- test/hyperfiddle/electric_de_test.cljc | 19 +-- test/hyperfiddle/js_calls_test_de.cljs | 43 +++++++ test/hyperfiddle/js_calls_test_de.js | 23 ++++ 7 files changed, 233 insertions(+), 31 deletions(-) create mode 100644 test/hyperfiddle/electric/impl/cljs_analyzer2_test.clj create mode 100644 test/hyperfiddle/js_calls_test_de.cljs create mode 100644 test/hyperfiddle/js_calls_test_de.js diff --git a/src/hyperfiddle/electric/impl/cljs_analyzer2.clj b/src/hyperfiddle/electric/impl/cljs_analyzer2.clj index 1bab0da5c..c366bf091 100644 --- a/src/hyperfiddle/electric/impl/cljs_analyzer2.clj +++ b/src/hyperfiddle/electric/impl/cljs_analyzer2.clj @@ -219,12 +219,23 @@ :else (let [sym-ns$ (-> sym namespace symbol), sym-base$ (-> sym name symbol)] (or (when-some [sym-ns$ (-> a ::nses (get ns$) ::requires (get sym-ns$))] - (safe-require sym-ns$) - (some-> (find-ns sym-ns$) (find-ns-var sym-base$))) + (when (symbol? sym-ns$) + (safe-require sym-ns$) + (some-> (find-ns sym-ns$) (find-ns-var sym-base$)))) (when-some [sym-ns$ (-> a ::nses (get ns$) ::require-macros (get sym-ns$))] - (safe-require sym-ns$) - (some-> (find-ns sym-ns$) (find-ns-var sym-base$))) + (when (symbol? sym-ns$) + (safe-require sym-ns$) + (some-> (find-ns sym-ns$) (find-ns-var sym-base$)))) (some-> (find-ns sym-ns$) (find-ns-var sym-base$))))) (keep-if macro-var?)))) (defn ->!a [] (let [!a (atom {})] (analyze-nsT !a (->cljs-env 'cljs.core) 'cljs.core) !a)) + +(defn- referred-from-js-require? [a ns$ ref] (-> a ::nses (get ns$) ::requires (get (namespace ref)))) + +(defn js-call? [a sym ns$] + (if (qualified-symbol? sym) + (or (= "js" (namespace sym)) + (string? (-> a ::nses (get ns$) ::requires (get (-> sym namespace symbol))))) + (when-some [ref (-> a ::nses (get ns$) ::refers (get sym))] + (referred-from-js-require? a ns$ ref)))) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 802c5baa6..2409e6e7b 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -462,7 +462,7 @@ (declare analyze) -(defn ap-literal [f args pe e env {{::keys [->id ->uid]} :o :as ts}] +(defn ->ap-literal [f args pe e env {{::keys [->id ->uid]} :o :as ts}] (let [ce (->id)] (reduce (fn [ts form] (analyze form e env ts)) (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap, ::uid (->uid)}) @@ -474,7 +474,7 @@ (if (seq method-args) (let [f (let [margs (repeatedly (count method-args) gensym), meth (symbol (str clazz) (str method))] `(fn [~@margs] (~meth ~@margs)))] - (ap-literal f method-args pe (->id) env ts)) + (->ap-literal f method-args pe (->id) env ts)) (let [e (->id)] ; (. java.time.Instant now) (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form}))))) @@ -487,7 +487,7 @@ (defn ->obj-method-call [o method method-args pe env {{::keys [->id]} :o :as ts}] (let [f (let [[oo & margs] (mapv #(gensym-with-local-meta env %) (cons o method-args))] `(fn [~oo ~@margs] (. ~oo ~method ~@margs)))] - (ap-literal f (cons o method-args) pe (->id) env ts))) + (->ap-literal f (cons o method-args) pe (->id) env ts))) (defn def-sym-in-cljs-compiler! [sym ns] (swap! @(requiring-resolve 'cljs.env/*compiler*) @@ -523,25 +523,25 @@ (case) (let [[_ test & brs] form [default brs2] (if (odd? (count brs)) [(last brs) (butlast brs)] [:TODO brs])] (loopr [bs [], mp {}] - [[v br] (partition 2 brs2)] - (let [b (gensym "case-val")] - (recur (conj bs b `(::ctor ~br)) - (reduce (fn [ac nx] (assoc ac (list 'quote nx) b)) mp (if (seq? v) v [v])))) - (recur (?meta form `(let* ~bs (::call (~mp ~test (::ctor ~default))))) pe env ts))) + [[v br] (partition 2 brs2)] + (let [b (gensym "case-val")] + (recur (conj bs b `(::ctor ~br)) + (reduce (fn [ac nx] (assoc ac (list 'quote nx) b)) mp (if (seq? v) v [v])))) + (recur (?meta form `(let* ~bs (::call (~mp ~test (::ctor ~default))))) pe env ts))) (quote) (let [e (->id)] (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v form}))) (fn*) (let [e (->id), [form refs] (closure env form) current (get (::peers env) (::current env))] (if (or (nil? current) (= (->env-type env) current)) - (ap-literal form refs pe e env (?add-source-map ts e form)) + (->ap-literal form refs pe e env (?add-source-map ts e form)) (recur `[~@refs] pe env ts))) (::cc-letfn) (let [[_ bs] form, [form refs] (closure env `(letfn* ~bs ~(vec (take-nth 2 bs)))), e (->id)] - (ap-literal form refs pe e env (?add-source-map ts e form))) + (->ap-literal form refs pe e env (?add-source-map ts e form))) (new) (let [[_ f & args] form, current (get (::peers env) (::current env))] (if (or (nil? current) (= (->env-type env) current)) (let [f (let [gs (repeatedly (count args) gensym)] `(fn [~@gs] (new ~f ~@gs)))] - (ap-literal f args pe (->id) env ts)) + (->ap-literal f args pe (->id) env ts)) (recur `[~@args] pe env ts))) ;; (. java.time.Instant now) ;; (. java.time.Instant ofEpochMilli 1) @@ -572,7 +572,7 @@ (let [[_ o x & xs] form] (if (seq xs) ; (. i1 isAfter i2) (->obj-method-call o x xs pe env ts) - (ap-literal `(fn [oo#] (. oo# ~x)) [o] pe (->id) env ts)))) ; (. pt x) + (->ap-literal `(fn [oo#] (. oo# ~x)) [o] pe (->id) env ts)))) ; (. pt x) (binding clojure.core/binding) (let [[_ bs bform] form, gs (repeatedly (/ (count bs) 2) gensym)] (recur (if (seq bs) `(let* [~@(interleave gs (take-nth 2 (next bs)))] @@ -586,7 +586,7 @@ (case (->env-type env) :clj (recur `((fn* ([x#] (def ~sym x#))) ~v) pe env ts) :cljs (do (def-sym-in-cljs-compiler! sym (get-ns env)) - (ap-literal `(fn [v#] (set! ~sym v#)) [v] pe (->id) env ts)))) + (->ap-literal `(fn [v#] (set! ~sym v#)) [v] pe (->id) env ts)))) (set!) (let [[_ target v] form] (recur `((fn* ([v#] (set! ~target v#))) ~v) pe env ts)) (::ctor) (let [e (->id), ce (->id)] (recur (list ::site nil (second form)) @@ -613,10 +613,17 @@ (::frame) (ts/add ts {:db/id (->id), ::parent pe, ::type ::frame}) (::lookup) (let [[_ sym] form] (ts/add ts {:db/id (->id), ::parent pe, ::type ::lookup, ::sym sym})) (::static-vars) (recur (second form) pe (assoc env ::static-vars true) ts) - #_else (let [e (->id), uid (->uid)] - (reduce (fn [ts nx] (analyze nx e env ts)) - (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap, ::uid uid}) - (?add-source-map uid form)) form))) + (::debug) (recur (second form) pe (assoc env ::debug true) ts) + #_else (let [current (get (::peers env) (::current env)), [f & args] form] + (if (and (= :cljs (->env-type env)) (contains? #{nil :cljs} current) (symbol? f) + (let [js-call? (cljs-ana/js-call? @!a f (get-ns env))] + (when (::debug env) (prn :js-call? f '=> js-call?)) + js-call?)) + (->ap-literal (bound-js-fn f) args pe (->id) env ts) + (let [e (->id), uid (->uid)] + (reduce (fn [ts nx] (analyze nx e env ts)) + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::ap, ::uid uid}) + (?add-source-map uid form)) form))))) (instance? cljs.tagged_literals.JSValue form) (let [o (.-val ^cljs.tagged_literals.JSValue form)] diff --git a/test/hyperfiddle/electric/impl/cljs_analyzer2_test.clj b/test/hyperfiddle/electric/impl/cljs_analyzer2_test.clj new file mode 100644 index 000000000..31b5ace5c --- /dev/null +++ b/test/hyperfiddle/electric/impl/cljs_analyzer2_test.clj @@ -0,0 +1,116 @@ +(ns hyperfiddle.electric.impl.cljs-analyzer2-test + (:require [clojure.test :as t] + [cljs.env] + [cljs.analyzer] + [hyperfiddle.electric.impl.cljs-analyzer2 :as ana])) + +(comment + (time (let [!a (atom {})] (ana/analyze-nsT !a {} 'cljs.core))) + (-> @!a ::ana/nses (get 'cljs.core) ::ana/defs count) + ) + +(t/deftest ns-expansion + (let [ns$ 'hyperfiddle.electric.impl.cljs-file-to-analyze + !a (ana/->!a) + _ (ana/analyze-nsT !a {} ns$) + a @!a] + (t/is (nil? (ana/find-var a 'non ns$))) + (t/is (nil? (ana/find-var a 'first ns$))) + (t/is (= 'cljs.core/next (::ana/name (ana/find-var a 'nxt ns$)))) + (t/are [x] (some? (ana/find-var a x ns$)) + 'foo + 'bar + 'baz + 'an-fn + 'behind-require + 'str + 'behind-alias + 'behind-require-macros + 'behind-require-macro-alias + 'behind-required-refer + 'behind-required-rename + 'behind-require-macro-refer + 'behind-require-macro-rename + 'behind-include-macros + 'behind-refer-macros + 'behind-use + 'behind-use-renamed + 'behind-use-macro + 'behind-use-macro-renamed + 'behind-auto-alias + 'behind-auto-alias-alias + 'behind-auto-alias-refer + 'nxt))) + +(t/deftest runtime-vars + (let [ns$ 'hyperfiddle.electric.impl.cljs-file-to-analyze, + !a (ana/->!a) + _ (ana/analyze-nsT !a {} ns$) + a @!a] + (t/are [x] (nil? (ana/find-var a x ns$)) + 'hyperfiddle.electric.impl.cljs-file-to-analyze.runtime/only-macro + 'run/only-macro + 'only-macro + 'next) ; renamed in :refer-clojure + (t/are [x] (some? (ana/find-var a x ns$)) + 'hyperfiddle.electric.impl.cljs-file-to-analyze.runtime/macro-and-runtime + 'run/macro-and-runtime + 'macro-and-runtime + 'hyperfiddle.electric.impl.cljs-file-to-analyze.runtime/only-runtime + 'run/only-runtime + 'only-runtime))) + +(t/deftest local-shadowing + (let [ns$ 'hyperfiddle.electric.impl.cljs-file-to-analyze + !a (ana/->!a) + _ (ana/analyze-nsT !a {} ns$) + a @!a] + (t/are [x] (nil? (ana/find-var a x ns$)) + 'shadowed-by-let + 'shadowed-by-let-destructure + 'shadowed-by-fn + 'shadowed-by-fn-destructure + 'shadowed-by-letfn-fn-name + 'shadowed-by-letfn-other-fn-name + 'shadowed-by-letfn-local))) + +(t/deftest defs-match-official-cljs-analyzer + (let [ns$ 'cljs.analyzer + !a (ana/->!a) + _ (ana/analyze-nsT !a {} ns$) + a @!a + c (cljs.env/ensure + (cljs.analyzer/analyze-file "cljs/core.cljs") + (cljs.analyzer/analyze-file "cljs/analyzer.cljc") + @cljs.env/*compiler*)] + (t/are [ns$] (= (into #{} (keep (fn [[k v]] (when-not (:anonymous v) k))) + (-> c :cljs.analyzer/namespaces (get ns$) :defs)) + (set (-> a ::ana/nses (get ns$) ::ana/defs keys))) + 'cljs.core + 'cljs.analyzer))) + +(t/deftest clojure-core-var-found-as-cljs-core-var + (let [ns$ 'cljs.analyzer + !a (ana/->!a) + _ (ana/analyze-nsT !a {} ns$) + a @!a] + (t/is (some? (ana/find-var a 'clojure.core/vector ns$))))) + +(t/deftest non-required-var-can-be-found ; e.g. a macro from another ns might have expanded to it + (let [ns$ 'cljs.source-map + !a (ana/->!a) + _ (ana/analyze-nsT !a {} ns$) + a @!a] + (t/is (some? (ana/find-var a 'cljs.source-map/encode 'cljs.core))))) + +(t/deftest npm-shadow-extension + (let [ns$ 'hyperfiddle.electric.impl.cljs-file-to-analyze + !a (ana/->!a) + _ (ana/analyze-nsT !a {} ns$) + a @!a] + (t/is (boolean (ana/js-call? a 'jslib/foo ns$))) + (t/is (boolean (ana/js-call? a 'js/alert ns$))) + (t/is (boolean (ana/js-call? a 'js-referred ns$))) + (t/is (boolean (ana/js-call? a 'js-renamed ns$))) + (t/is (not (ana/js-call? a 'not-js-referred ns$))) + (t/is (not (ana/js-call? a 'run/only-runtime ns$))))) diff --git a/test/hyperfiddle/electric/impl/cljs_file_to_analyze.cljs b/test/hyperfiddle/electric/impl/cljs_file_to_analyze.cljs index 98083da91..0bb6001c3 100644 --- a/test/hyperfiddle/electric/impl/cljs_file_to_analyze.cljs +++ b/test/hyperfiddle/electric/impl/cljs_file_to_analyze.cljs @@ -5,7 +5,8 @@ [hyperfiddle.electric.impl.cljs-file-to-analyze.include :as inc :include-macros true] [hyperfiddle.electric.impl.cljs-file-to-analyze.refer-macros :refer-macros [refmac]] [hyperfiddle.electric.impl.cljs-file-to-analyze.runtime :as run :refer [only-macro only-runtime macro-and-runtime]] - [clojure.analyzer-testing-auto-alias :as auto-alias :refer [auto-aliased]]) + [clojure.analyzer-testing-auto-alias :as auto-alias :refer [auto-aliased]] + ["some-js-lib" :as jslib :refer [js-referred js-to-rename] :rename {js-to-rename js-renamed}]) (:require-macros [hyperfiddle.electric.impl.cljs-file-to-analyze.macro-ns :as reqmac :refer [reqmacrefer reqmacrename] :rename {reqmacrename reqmacrenamed}]) (:use [hyperfiddle.electric.impl.cljs-file-to-analyze.use :only [useme renameme] :rename {renameme use-renamed}]) (:use-macros [hyperfiddle.electric.impl.cljs-file-to-analyze.use-macros :only [useme-mac renameme-mac] :rename {renameme-mac use-renamed-mac}]) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 6e38715bb..eedd239f5 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -7,6 +7,7 @@ [hyperfiddle.electric.impl.runtime-de :as r] [contrib.cljs-target :refer [do-browser]] #?(:cljs [hyperfiddle.goog-calls-test-de]) + #?(:cljs [hyperfiddle.js-calls-test-de]) [clojure.string :as str] [missionary.core :as m]) #?(:cljs (:require-macros [hyperfiddle.electric-de-test :refer [skip failing]])) @@ -1228,11 +1229,11 @@ (Math/min 3 3))))) tap tap) % := [1 2])) -(def !state (atom 0)) +(def !state3 (atom 0)) (def global) (tests "Inline cc/fn support" - (reset! !state 0) - (with ((l/single {} (let [state (e/watch !state) + (reset! !state3 0) + (with ((l/single {} (let [state (e/watch !state3) local [:local state] f (binding [global [:global state]] (fn ([a] [a local hyperfiddle.electric-de-test/global]) @@ -1244,22 +1245,22 @@ % := [0 [:local 0] [:global 0]] % := [0 :b [:local 0] [:global 0]] % := [0 :b '(:c :d) [:local 0] [:global 0]] - (swap! !state inc) + (swap! !state3 inc) % := [1 [:local 1] [:global 1]] % := [1 :b [:local 1] [:global 1]] % := [1 :b '(:c :d) [:local 1] [:global 1]])) -(def !state (atom 0)) +(def !state4 (atom 0)) (tests - (reset! !state 0) + (reset! !state4 0) (with ((l/single {} - (let [state (e/watch !state)] + (let [state (e/watch !state4)] (tap [state state]) (tap [state state]))) tap tap) % := [0 0] % := [0 0] - (swap! !state inc) + (swap! !state4 inc) % := [1 1] % := [1 1])) @@ -2186,4 +2187,4 @@ tap tap) (hash-set % %) := #{0 1} (swap! !offset inc) - % := 2)) \ No newline at end of file + % := 2)) diff --git a/test/hyperfiddle/js_calls_test_de.cljs b/test/hyperfiddle/js_calls_test_de.cljs new file mode 100644 index 000000000..bd315fec9 --- /dev/null +++ b/test/hyperfiddle/js_calls_test_de.cljs @@ -0,0 +1,43 @@ +(ns hyperfiddle.js-calls-test-de + (:require [hyperfiddle.electric-local-def-de :as l] + [hyperfiddle.rcf :as rcf :refer [tests tap % with]] + [hyperfiddle.electric.impl.lang-de2 :as lang] + ["./js_calls_test_de" :as call-test])) + +;;; Goal: confirm Electric and CLJS have the same js function call semantics. + +(call-test/install) ; required for later tests + +;;; The two tests blocks should be identical in intent and result. + +;; CLJS +(tests + "js scoped call in cljs" + call-test/scope.fn := call-test/scope.fn + (call-test/scope.fn) := "value" + (.fn call-test/scope) := "value" + (js/hyperfiddle.js_calls_test_de.scope.fn) := "value" ; requires `(call-test/install)` + (let [fn (.-fn call-test/scope)] + (undefined? (fn)) := true ; fn lost its `this` context + ((.bind fn call-test/scope)) := "value" ; re-set `this` context to `scope` + )) + +;; Electric +(tests + "js scoped call in electric" + (with ((l/single {} + (tap call-test/scope.fn) + (tap (call-test/scope.fn)) ; direct access + (tap (.fn call-test/scope)) ; two-step access + (tap (js/hyperfiddle.js_calls_test_de.scope.fn)) ; global access, requires `(call-test/install)` + (let [fn (.-fn call-test/scope)] + (tap (undefined? (fn))) + (tap ((.bind fn call-test/scope))))) tap tap) + % := call-test/scope.fn + % := "value" + % := "value" + % := "value" + % := true + % := "value" + )) + diff --git a/test/hyperfiddle/js_calls_test_de.js b/test/hyperfiddle/js_calls_test_de.js new file mode 100644 index 000000000..8b07817cf --- /dev/null +++ b/test/hyperfiddle/js_calls_test_de.js @@ -0,0 +1,23 @@ +// Test that when electric calls scope.fn(), fn is called with `scope` bound as `this`, thus returning `"value"` +// See `js_calls_test.cljs` + +// How to reproduce from JS console: + +// ```js +// scope.fn(); // => "value" +// var fn = scope.fn; +// fn(); // => undefined + +// fn.bind(scope)(); // => "value +// ``` + +export var scope = { + value: "value", + fn: function(){ + return this.value; + } +}; + +export function install(){ + globalThis.hyperfiddle.js_calls_test_de.scope = scope; +} From b4e4f33b891776266e2d34a0b60b381af278c198 Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 15 Apr 2024 17:08:46 +0200 Subject: [PATCH 210/428] compiler: qualify js required vars in lookup --- src/hyperfiddle/electric/impl/cljs_analyzer2.clj | 5 +++++ src/hyperfiddle/electric/impl/lang_de2.clj | 2 +- test/hyperfiddle/electric/impl/compiler_test.cljc | 7 +++++++ 3 files changed, 13 insertions(+), 1 deletion(-) diff --git a/src/hyperfiddle/electric/impl/cljs_analyzer2.clj b/src/hyperfiddle/electric/impl/cljs_analyzer2.clj index c366bf091..d15cfcc7f 100644 --- a/src/hyperfiddle/electric/impl/cljs_analyzer2.clj +++ b/src/hyperfiddle/electric/impl/cljs_analyzer2.clj @@ -239,3 +239,8 @@ (string? (-> a ::nses (get ns$) ::requires (get (-> sym namespace symbol))))) (when-some [ref (-> a ::nses (get ns$) ::refers (get sym))] (referred-from-js-require? a ns$ ref)))) + +(defn ns-qualify [a sym ns$] + (if-some [qual-ns (keep-if (-> a ::nses (get ns$) ::requires (get (-> sym namespace symbol))) symbol?)] + (symbol (str qual-ns) (name sym)) + sym)) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 2409e6e7b..ad9bbd902 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -403,7 +403,7 @@ (defn analyze-cljs-symbol [sym env] (if-some [v (cljs-ana/find-var @!a sym (get-ns env))] {::type ::var, ::sym (untwin (::cljs-ana/name v))} - {::type ::static, ::sym sym})) + {::type ::static, ::sym (if (qualified-symbol? sym) (cljs-ana/ns-qualify @!a sym (get-ns env)) sym)})) (defn resolve-symbol [sym env] (if-some [local (-> env :locals (get sym))] diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index 9535fb3a9..44901150a 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -10,6 +10,7 @@ [hyperfiddle.rcf :as rcf :refer [tests]] [hyperfiddle.electric.impl.expand-require-referred :as ref :refer [referred referred-fn]] #?(:clj [contrib.test-match :as tm]) + #?(:cljs [goog.math :as gm]) [fipp.edn] [missionary.core :as m]) #?(:clj (:import [clojure.lang ExceptionInfo]))) @@ -514,6 +515,12 @@ (r/define-node ~'frame 0 (r/pure 1)) (r/ap (r/pure vector) (r/node ~'frame 0))))])) ; shim, conveyed `x` +(tests + "js-vars-have-qualified-lookup" + (match (l/test-compile ::Main (e/client (gm/clamp -1 0 5))) + `[(r/cdef 0 [] [] :client + (fn [~'frame] (r/ap (r/lookup ~'frame :goog.math/clamp) (r/pure -1) (r/pure 0) (r/pure 5))))])) + (comment (let [ts (l/code->ts {} (prn :hello)) From 766973640924ab49cb76ef12fab8fb27a75f33cf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Mon, 15 Apr 2024 17:13:39 +0200 Subject: [PATCH 211/428] fix frame serialization --- src/hyperfiddle/electric/impl/runtime_de.cljc | 35 ++++++++----------- 1 file changed, 14 insertions(+), 21 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 3c5318259..0f8ba6436 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -351,18 +351,6 @@ T T T -> (EXPR T) (aset state peer-slot-output-pending false) (step)))) -(defn frame-child - {:tag Frame} - [^Frame frame [call-id rank]] - (let [^objects children (.-children frame)] - (get (aget children call-id) rank))) - -(defn peer-frame - {:tag Frame} - [^Peer peer path] - (let [^objects state (.-state peer)] - (reduce frame-child (aget state peer-slot-root) path))) - (defn port-process [^objects port] (aget port port-slot-process)) @@ -699,9 +687,17 @@ T T T -> (EXPR T) [^Frame frame id expr] (define-slot (node frame id) expr)) -(defn slot-frame [^Slot slot] +(defn slot-frame + "Returns the frame of given slot." + {:tag Frame} + [^Slot slot] (.-frame slot)) +(defn slot-id + "Returns the id of given slot." + [^Slot slot] + (.-id slot)) + (defn port-attach [_ ^objects port n] (let [peer (frame-peer (slot-frame (port-slot port)))] (dotimes [_ n] (peer-push peer peer-queue-tap port)))) @@ -855,7 +851,7 @@ Returns a peer definition from given definitions and main key. Frame (t/write-handler (fn [_] "frame") (fn [^Frame frame] - [(frame-path frame) + [(.-slot frame) (.-rank frame) (when-not (frame-shared? frame) (frame-share frame) (.-ctor frame))])) @@ -883,14 +879,11 @@ Returns a peer definition from given definitions and main key. (fn [[frame id]] (->Slot frame id))) "frame" (t/read-handler - (fn [[path ctor]] + (fn [[slot rank ctor]] (if (nil? ctor) - (peer-frame peer path) - (let [[id rank] (peek path) - parent (peer-frame peer (pop path)) - slot (call parent id) - site (port-site (slot-port slot)) - frame (make-frame peer slot rank site ctor)] + (if (nil? slot) + root (get (aget ^objects (.-children (slot-frame slot)) (slot-id slot)) rank)) + (let [frame (make-frame peer slot rank (port-site (slot-port slot)) ctor)] (frame-share frame) frame)))) "join" (t/read-handler (fn [[input]] From 10f606e6ffc3e7ee1666b66b795e538ee47b8a63 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Tue, 16 Apr 2024 14:52:22 +0200 Subject: [PATCH 212/428] fix ring websocket writer --- src/hyperfiddle/electric_ring_adapter_de.clj | 34 ++++++++++++++++++-- 1 file changed, 32 insertions(+), 2 deletions(-) diff --git a/src/hyperfiddle/electric_ring_adapter_de.clj b/src/hyperfiddle/electric_ring_adapter_de.clj index 913372de6..2f4bb2d76 100644 --- a/src/hyperfiddle/electric_ring_adapter_de.clj +++ b/src/hyperfiddle/electric_ring_adapter_de.clj @@ -10,7 +10,8 @@ [hyperfiddle.electric.debug :as dbg] [missionary.core :as m] [ring.websocket :as ws]) - (:import missionary.Cancelled)) + (:import missionary.Cancelled + (java.util.concurrent.atomic AtomicInteger))) (def ELECTRIC-CONNECTION-TIMEOUT "Time after which the server will close the socket if it hasn't seen any websocket activity from the client." @@ -88,6 +89,35 @@ (catch Throwable e (f e))) #())) +(defn write-msgs + "Returns a task writing all messages emitted by flow on websocket." + [socket msgs] + (fn [s f] + (let [slot-ps 0 + slot-done 1 + slot-error 2 + slots (object-array 3) + state (AtomicInteger.)] + (letfn [(ready [] + (if (aget slots slot-done) + (if-some [e (aget slots slot-error)] (f e) (s nil)) + (if (nil? (aget slots slot-error)) + (try (send socket @(aget slots slot-ps) ack crash) + (catch Throwable e (crash e))) + (do (try @(aget slots slot-ps) (catch Throwable _)) + (ack))))) + (ack [] (when (zero? (.decrementAndGet state)) (ready))) + (crash [e] + (aset slots slot-done e) + (cancel) (ack)) + (cancel [] ((aget slots slot-ps)))] + (aset slots slot-done false) + (aset slots slot-ps + (msgs #(when (zero? (.incrementAndGet state)) (ready)) + #(do (aset slots slot-done true) + (when (zero? (.incrementAndGet state)) (ready))))) + (ack) cancel)))) + (defn timeout "Throw if `mailbox` haven't got any message after given `time` ms" [mailbox time] @@ -153,7 +183,7 @@ (aset state on-close-slot ((m/join (fn [& _]) (timeout keepalive-mailbox ELECTRIC-CONNECTION-TIMEOUT) - (m/reduce #(write-msg socket %2) nil ((boot-fn ring-req) (r/subject-at state on-message-slot))) + (write-msgs socket ((boot-fn ring-req) (r/subject-at state on-message-slot))) (send-hf-heartbeat ELECTRIC-HEARTBEAT-INTERVAL #(ping socket "HEARTBEAT"))) {} (partial failure socket)))) ; Start Electric process :on-close (fn on-close [_socket _status-code & [_reason]] From 19f9e925b891e8126ffda9f14ef08e8cd0ce4c3a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Tue, 16 Apr 2024 15:51:07 +0200 Subject: [PATCH 213/428] fix Unbound interface --- src/hyperfiddle/electric/impl/runtime_de.cljc | 79 ++++++++++++------- 1 file changed, 51 insertions(+), 28 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 0f8ba6436..96c15f311 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -197,10 +197,26 @@ T T T -> (EXPR T) (#?(:clj deref :cljs -deref) [_] (done) (throw e))) -(deftype Unbound [k] - IFn - (#?(:clj invoke :cljs -invoke) [_ step done] - (step) (->Failer done (error (str "Unbound electric var lookup - " (pr-str k)))))) +(defn failer [e] + (fn [step done] + (step) + (->Failer done e))) + +(deftype Unbound [key ^:unsynchronized-mutable ^:mutable hash-memo] + #?(:clj Object) + #?(:cljs IHash) + (#?(:clj hashCode :cljs -hash) [_] + (if-some [h hash-memo] + h (set! hash-memo + (hash-combine (hash Unbound) + (hash key))))) + #?(:cljs IEquiv) + (#?(:clj equals :cljs -equiv) [_ other] + (and (instance? Unbound other) + (= key (.-key ^Unbound other)))) + Expr + (deps [_ _] {}) + (flow [_] (failer (error (str "Unbound electric var lookup - " (pr-str key)))))) (deftype Cdef [frees nodes calls result build]) @@ -808,7 +824,7 @@ T T T -> (EXPR T) "Returns the value associated with given key in the dynamic environment of given frame." {:tag Expr} ([^Frame frame key] - (lookup frame key (->Unbound key))) + (lookup frame key (->Unbound key nil))) ([^Frame frame key nf] (loop [frame frame] (let [[_ _ _ env] (frame-ctor frame)] @@ -844,30 +860,34 @@ Returns a peer definition from given definitions and main key. (eduction (map pure)) (apply dispatch ((defs main))) (make-frame peer nil 0 :client)) - handlers {Slot (t/write-handler - (fn [_] "slot") - (fn [^Slot slot] - [(.-frame slot) (.-id slot)])) - Frame (t/write-handler - (fn [_] "frame") - (fn [^Frame frame] - [(.-slot frame) (.-rank frame) - (when-not (frame-shared? frame) - (frame-share frame) - (.-ctor frame))])) - Ap (t/write-handler - (fn [_] "ap") - (fn [^Ap ap] - (.-inputs ap))) + handlers {Slot (t/write-handler + (fn [_] "slot") + (fn [^Slot slot] + [(.-frame slot) (.-id slot)])) + Frame (t/write-handler + (fn [_] "frame") + (fn [^Frame frame] + [(.-slot frame) (.-rank frame) + (when-not (frame-shared? frame) + (frame-share frame) + (.-ctor frame))])) + Ap (t/write-handler + (fn [_] "ap") + (fn [^Ap ap] + (.-inputs ap))) ;; must wrap payload in vector, cf https://github.com/cognitect/transit-cljs/issues/23 - Pure (t/write-handler - (fn [_] "pure") - (fn [^Pure pure] - [(.-value pure)])) - Join (t/write-handler - (fn [_] "join") - (fn [^Join join] - [(.-input join)]))} + Pure (t/write-handler + (fn [_] "pure") + (fn [^Pure pure] + [(.-value pure)])) + Join (t/write-handler + (fn [_] "join") + (fn [^Join join] + [(.-input join)])) + Unbound (t/write-handler + (fn [_] "unbound") + (fn [^Unbound unbound] + [(.-key unbound)]))} default (t/write-handler (fn [_] "unserializable") (fn [_]))] @@ -894,6 +914,9 @@ Returns a peer definition from given definitions and main key. "pure" (t/read-handler (fn [[value]] (->Pure value nil))) + "unbound" (t/read-handler + (fn [[key]] + (->Unbound key nil))) "unserializable" (t/read-handler (fn [_] (->Failure :unserializable)))}}) From 18268730aa74555da08e240a97073fd8f531f695 Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 16 Apr 2024 17:16:32 +0200 Subject: [PATCH 214/428] compiler: peers don't compile foreign code Before this code like (e/server (java.time.Instant/now)) would fail to compile on cljs side because the compiler emitted the interop code in cljs too. Now it emits a vector call with the rest of the arguments, to have complete code analysis (e.g. for node dependencies) --- src/hyperfiddle/electric/impl/lang_de2.clj | 53 ++++++++++++------- .../electric/impl/compiler_test.cljc | 9 +++- 2 files changed, 40 insertions(+), 22 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index ad9bbd902..4a7d3a8d6 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -500,6 +500,8 @@ (defn ?update-meta [env form] (cond-> env (meta form) (assoc ::meta (meta form)))) +(defn my-turn? [env] (let [c (get (::peers env) (::current env))] (or (nil? c) (= c (->env-type env))))) + (defn analyze [form pe env {{::keys [->id ->uid]} :o :as ts}] (let [env (?update-meta env form)] (cond @@ -552,27 +554,38 @@ ;; (. i1 (isAfter i2)) ;; (. pt x) ;; (. pt -x) - (.) (cond - (implicit-cljs-nses (second form)) ; (Math/abs -1) expanded to (. Math abs -1) - (let [[_ clazz method & method-args] form] ; cljs fails on dot form, so we compile as class call - (->class-method-call clazz method method-args pe env form ts)) - - (and (symbol? (second form)) (class? (resolve env (second form)))) - (if (seq? (nth form 2)) ; (. java.time.Instant (ofEpochMilli 1)) - (let [[_ clazz [method & method-args]] form] + (.) (let [me? (my-turn? env)] + (cond + (implicit-cljs-nses (second form)) ; (Math/abs -1) expanded to (. Math abs -1) + (let [[_ clazz method & method-args] form] ; cljs fails on dot form, so we compile as class call (->class-method-call clazz method method-args pe env form ts)) - (let [[_ clazz x & xs] form] - (->class-method-call clazz x xs pe env form ts))) - - (seq? (nth form 2)) ; (. i1 (isAfter i2)) - (let [[_ o [method & method-args]] form] - (->obj-method-call o method method-args pe env ts)) - - :else - (let [[_ o x & xs] form] - (if (seq xs) ; (. i1 isAfter i2) - (->obj-method-call o x xs pe env ts) - (->ap-literal `(fn [oo#] (. oo# ~x)) [o] pe (->id) env ts)))) ; (. pt x) + + (and (symbol? (second form)) (class? (resolve env (second form)))) + (if (seq? (nth form 2)) ; (. java.time.Instant (ofEpochMilli 1)) + (if me? + (let [[_ clazz [method & method-args]] form] + (->class-method-call clazz method method-args pe env form ts)) + (recur `[~@(next (nth form 2))] pe env ts)) + (let [[_ clazz x & xs] form] ; (. java.time.instant opEpochMilli 1) + (if me? + (->class-method-call clazz x xs pe env form ts) + (recur `[~@xs] pe env ts)))) + + (seq? (nth form 2)) ; (. i1 (isAfter i2)) + (let [[_ o [method & method-args]] form] + (if me? + (->obj-method-call o method method-args pe env ts) + (recur `[~(second form) ~@(next (nth form 2))] pe env ts))) + + :else + (let [[_ o x & xs] form] + (if (seq xs) ; (. i1 isAfter i2) + (if me? + (->obj-method-call o x xs pe env ts) + (recur `[~o ~@xs] pe env ts)) + (if me? ; (. pt x) + (->ap-literal `(fn [oo#] (. oo# ~x)) [o] pe (->id) env ts) + (recur nil pe env ts)))))) (binding clojure.core/binding) (let [[_ bs bform] form, gs (repeatedly (/ (count bs) 2) gensym)] (recur (if (seq bs) `(let* [~@(interleave gs (take-nth 2 (next bs)))] diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index 44901150a..dff603b11 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -515,12 +515,17 @@ (r/define-node ~'frame 0 (r/pure 1)) (r/ap (r/pure vector) (r/node ~'frame 0))))])) ; shim, conveyed `x` -(tests - "js-vars-have-qualified-lookup" +(tests "js-vars-have-qualified-lookup" (match (l/test-compile ::Main (e/client (gm/clamp -1 0 5))) `[(r/cdef 0 [] [] :client (fn [~'frame] (r/ap (r/lookup ~'frame :goog.math/clamp) (r/pure -1) (r/pure 0) (r/pure 5))))])) +(tests "peers-dont-compile-foreign-code" + (match (l/test-compile ::Main (merge e/web-config (lang/normalize-env {}) {:js-globals {}}) + (e/server (java.time.Instant/ofEpochMilli 11))) + `[(r/cdef 0 [] [] :server + (fn [~'frame] (r/pure (vector 11))))])) + (comment (let [ts (l/code->ts {} (prn :hello)) From fcfeab9c1099e2d97c9773b750d45c4d569f0911 Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 18 Apr 2024 09:27:55 +0200 Subject: [PATCH 215/428] misc --- src/contrib/assert.cljc | 8 ++++++-- src/hyperfiddle/electric/shadow_cljs/hooks_de.clj | 2 +- src/hyperfiddle/electric_dom3.cljc | 1 - 3 files changed, 7 insertions(+), 4 deletions(-) diff --git a/src/contrib/assert.cljc b/src/contrib/assert.cljc index 96e512fa8..b39ae12a1 100644 --- a/src/contrib/assert.cljc +++ b/src/contrib/assert.cljc @@ -22,9 +22,13 @@ (defn -is [v pred vq predq msg ex-data] (when-not (pred v) - (throw (ex-info (str "assertion failed: (" (pr-str predq) " " (pr-str vq) ") for " (pr-str vq) " = " (pr-str v) + ;; throws don't show up in electric yet + #_(throw (ex-info (str "assertion failed: (" (pr-str predq) " " (pr-str vq) ") for " (pr-str vq) " = " (pr-str v) (when msg (str "\n\n " msg))) - (assoc ex-data ::v v ::pred pred)))) + (assoc ex-data ::v v ::pred pred))) + (#?(:clj println :cljs js/console.error) + (str "assertion failed: (" (pr-str predq) " " (pr-str vq) ") for " (pr-str vq) " = " (pr-str v) + (when msg (str "\n\n " msg)) (when (seq ex-data) (str "\n\n" ex-data))))) v) (defmacro is diff --git a/src/hyperfiddle/electric/shadow_cljs/hooks_de.clj b/src/hyperfiddle/electric/shadow_cljs/hooks_de.clj index 7db6ad8b4..8f09972f3 100644 --- a/src/hyperfiddle/electric/shadow_cljs/hooks_de.clj +++ b/src/hyperfiddle/electric/shadow_cljs/hooks_de.clj @@ -1,7 +1,7 @@ (ns hyperfiddle.electric.shadow-cljs.hooks-de (:require [clojure.string :as str] [hyperfiddle.electric.impl.lang-de2 :as lang] - [hyperfiddle.electric.impl.cljs-analyzer :as cljs-ana])) + [hyperfiddle.electric.impl.cljs-analyzer2 :as cljs-ana])) (let [!first-run? (volatile! true)] ; first run is noop (defn reload-clj diff --git a/src/hyperfiddle/electric_dom3.cljc b/src/hyperfiddle/electric_dom3.cljc index 72b3f751d..284a94d1f 100644 --- a/src/hyperfiddle/electric_dom3.cljc +++ b/src/hyperfiddle/electric_dom3.cljc @@ -21,7 +21,6 @@ (ca/is parent some? "DOM node parent cannot be nil. Maybe dom/node is unbound?") (m/observe (fn [!] (.appendChild parent elem) (! elem) #(.remove elem))))) -;; TODO this should be a simple `binding` but the observer doesn't unmount that way (defmacro with [elem & body] `(binding [node (e/input (appending> ~elem node))] node ~@body)) #?(:cljs (defn -googDomSetTextContentNoWarn [node str] From 0e890f3051a4bbd0280b89e8099e066afcf4ddf1 Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 22 Apr 2024 10:55:20 +0200 Subject: [PATCH 216/428] fixes based on starter-app usage --- src/contrib/assert.cljc | 4 +- src/hyperfiddle/electric/impl/lang_de2.clj | 43 +-- src/hyperfiddle/electric/impl/runtime_de.cljc | 41 ++- src/hyperfiddle/electric_de.cljc | 21 +- src/hyperfiddle/electric_dom3_efns.cljc | 329 ++++++++++++++++++ src/hyperfiddle/electric_local_def_de.cljc | 4 +- 6 files changed, 385 insertions(+), 57 deletions(-) create mode 100644 src/hyperfiddle/electric_dom3_efns.cljc diff --git a/src/contrib/assert.cljc b/src/contrib/assert.cljc index b39ae12a1..bea8f66f9 100644 --- a/src/contrib/assert.cljc +++ b/src/contrib/assert.cljc @@ -23,10 +23,10 @@ (defn -is [v pred vq predq msg ex-data] (when-not (pred v) ;; throws don't show up in electric yet - #_(throw (ex-info (str "assertion failed: (" (pr-str predq) " " (pr-str vq) ") for " (pr-str vq) " = " (pr-str v) + (throw (ex-info (str "assertion failed: (" (pr-str predq) " " (pr-str vq) ") for " (pr-str vq) " = " (pr-str v) (when msg (str "\n\n " msg))) (assoc ex-data ::v v ::pred pred))) - (#?(:clj println :cljs js/console.error) + #_(#?(:clj println :cljs js/console.error) (str "assertion failed: (" (pr-str predq) " " (pr-str vq) ") for " (pr-str vq) " = " (pr-str v) (when msg (str "\n\n " msg)) (when (seq ex-data) (str "\n\n" ex-data))))) v) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 4a7d3a8d6..2f27f8ebe 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -109,7 +109,7 @@ (?meta o (list* (caller (first o) env) (mapv (fn-> caller env) (next o)))))) (defmacro $ [F & args] - `(::call ((::static-vars r/dispatch) ~F ~@(map (fn [arg] `(::pure ~arg)) args)))) + `(::call ((::static-vars r/dispatch) '~F ~F ~@(map (fn [arg] `(::pure ~arg)) args)))) (defn -expand-all [o env] (cond @@ -378,7 +378,7 @@ (untwin 'a) := 'a (untwin 'cljs.core/not-in-clj) := 'cljs.core/not-in-clj) -(defn node? [mt] (::deps mt)) +(defn node? [mt] (::node mt)) (defn resolve-node [sym env] (case (->env-type env) :clj (when-some [^clojure.lang.Var vr (resolve env sym)] @@ -803,6 +803,7 @@ (defn emit-deps [ts e] (let [seen (volatile! #{}) + ret (volatile! (sorted-set)) mark (fn mark [ts e] (if (@seen e) ts @@ -814,10 +815,10 @@ (::site ::join ::pure ::call ::ctor ::mklocal) (recur ts (get-child-e ts e)) (::bindlocal) (recur ts (->bindlocal-body-e ts e)) (::localref) (recur ts (->> (::ref nd) (->localv-e ts) (get-ret-e ts))) - (::node) (ts/asc ts e ::node-used true) - #_else (throw (ex-info (str "cannot emit-deps/mark on " (pr-str (::type nd))) (or nd {}))))))) - es (ts/find (mark ts e) ::node-used true)] - (into (sorted-set) (map #(::node (ts/->node ts %))) es))) + (::node) (do (vswap! ret conj (::node nd)) ts) + #_else (throw (ex-info (str "cannot emit-deps/mark on " (pr-str (::type nd))) (or nd {})))))))] + (mark ts e) + @ret)) (defn emit-fn [ts e nm] ((fn rec [e] @@ -832,8 +833,6 @@ ::localref (recur (->> (::ref nd) (->localv-e ts) (get-ret-e ts)))))) e)) -(defn get-deps [sym] (-> sym resolve meta ::deps)) - (defn delete-point-recursively [ts e] (let [ts (ts/del ts e)] (if-some [ce (get-children-e ts e)] @@ -1051,15 +1050,6 @@ (analyze (expand-all env `(::ctor ~form)) '_ env (->ts)))) -(defn collect-deps [deps] - (loop [ret (sorted-set) deps deps] - (if-some [d (first deps)] - (if (ret d) - (recur ret (disj deps d)) - (let [dds (get-deps d)] - (recur (conj ret d) (into deps dds)))) - ret))) - (defn ->source [env root-key efn] (let [expanded (expand-all env efn) _ (when (::print-expansion env) (fipp.edn/pprint expanded)) @@ -1067,20 +1057,11 @@ _ (when (::print-analysis env) (run! prn (->> ts :eav vals (sort-by :db/id)))) ts (analyze-electric env ts) ctors (mapv #(emit-ctor ts % env root-key) (get-ordered-ctors-e ts)) + deps-set (emit-deps ts (get-root-e ts)) + deps (into {} (map (fn [dep] [(keyword dep) dep])) deps-set) source `(fn ([] ~(emit-fn ts (get-root-e ts) root-key)) - ([idx#] (case idx# ~@(interleave (range) ctors))))] - (when (and (::print-clj-source env) (= :clj (->env-type env))) (fipp.edn/pprint source)) - (when (and (::print-cljs-source env) (= :cljs (->env-type env))) (fipp.edn/pprint source)) - [source ts])) - -(defn ->defs [env root-key efn] - (let [[source ts] (->source env root-key efn) - ret-e (get-ret-e ts (get-child-e ts 0)) - deps (emit-deps ts ret-e) - deps (collect-deps deps) - defs (into {} (map (fn [dep] [(keyword dep) dep])) deps) - defs (assoc defs root-key source)] + ([idx#] (case idx# ~@(interleave (range) ctors))) + ([get# deps#] ~deps))] (when (and (::print-clj-source env) (= :clj (->env-type env))) (fipp.edn/pprint source)) (when (and (::print-cljs-source env) (= :cljs (->env-type env))) (fipp.edn/pprint source)) - (when (::print-defs env) (fipp.edn/pprint defs)) - defs)) + source)) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 96c15f311..cbea916cb 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -1,6 +1,8 @@ (ns hyperfiddle.electric.impl.runtime-de (:refer-clojure :exclude [resolve]) (:require [hyperfiddle.incseq :as i] + [contrib.assert :as ca] + [contrib.debug] [missionary.core :as m] [cognitect.transit :as t]) (:import missionary.Cancelled @@ -109,6 +111,13 @@ T T T -> (EXPR T) ([f a b c d] (f a b c d)) ([f a b c d & es] (apply f a b c d es))) +;; TODO the runtime swallows exceptions somewhere +;; maybe in latest-product, not sure. +;; investigate and remove this afterwards +(defn invoke-print-throws [& args] + (try (apply invoke args) + (catch #?(:clj Throwable :cljs :default) e (#?(:clj prn :cljs js/console.error) e)))) + (deftype Ap [inputs ^:unsynchronized-mutable ^:mutable hash-memo] #?(:clj Object) @@ -126,7 +135,7 @@ T T T -> (EXPR T) (deps [_ site] (reduce (fn [r x] (merge-with + r (deps x site))) {} inputs)) (flow [_] - (apply i/latest-product invoke (map flow inputs))) + (apply i/latest-product invoke-print-throws (map flow inputs))) #_#_ IFn (#?(:clj invoke :cljs -invoke) [this step done] @@ -241,15 +250,15 @@ T T T -> (EXPR T) (defn bind-self [ctor] (bind ctor :recur (pure ctor))) -(defn arity-mismatch [arity] - (throw (error (str "Wrong number of args (" arity ")")))) +(defn arity-mismatch [nm arity] + (throw (error (str nm ": wrong number of args (" arity ")")))) -(defn get-variadic [F arity] +(defn get-variadic [nm F arity] (if-some [[fixed map? ctor] (F -1)] (if (< arity fixed) - (arity-mismatch arity) + (arity-mismatch nm arity) [fixed map? ctor]) - (arity-mismatch arity))) + (arity-mismatch nm arity))) (defn varargs [map?] (if map? @@ -262,16 +271,18 @@ T T T -> (EXPR T) (merge m k)) m))) (fn [& args] args))) -(defn dispatch [F & args] +(defn dispatch [nm F & args] (let [arity (count args)] (if-some [ctor (F arity)] (apply bind-args (bind-self ctor) args) - (let [[fixed map? ctor] (get-variadic F arity)] + (let [[fixed map? ctor] (get-variadic nm F arity)] (bind (apply bind-args (bind-self ctor) (take fixed args)) fixed (apply ap (pure (varargs map?)) (drop fixed args))))))) (defn peer-root [^Peer peer key] - ((.-defs peer) key)) + (let [defs (.-defs peer)] + (when-not (contains? defs key) (throw (error (str (pr-str key) " not defined")))) + (defs key))) (defn peer-cdef "Returns the cdef of given constructor." @@ -858,7 +869,7 @@ Returns a peer definition from given definitions and main key. input (m/stream (m/observe events)) ^Frame root (->> args (eduction (map pure)) - (apply dispatch ((defs main))) + (apply dispatch "" ((defs main))) (make-frame peer nil 0 :client)) handlers {Slot (t/write-handler (fn [_] "slot") @@ -982,7 +993,7 @@ Returns a peer definition from given definitions and main key. ;; local only (defn root-frame [defs main] - (->> (dispatch ((defs main))) + (->> (dispatch "" ((defs main))) (make-frame (->Peer :client defs nil nil nil nil nil) nil 0 :client) (m/signal i/combine))) @@ -996,3 +1007,11 @@ Returns a peer definition from given definitions and main key. (defn cannot-resolve [& args] (throw (ex-info "definition called on a peer that doesn't support it" {:args args}))) (defn tracing [info v] (print "[o_o]" info "=>> ") (prn v) v) + +(defn ->defs [mp] + (loop [ret {}, left mp] + (if-some [[k f] (first left)] + (if (ret k) + (recur ret (dissoc left k)) + (recur (assoc ret k f) (merge (dissoc left k) (f :get :deps)))) + ret))) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index d2372a26f..acfd249ce 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -95,13 +95,11 @@ Returns the successive states of items described by `incseq`. (defmacro defn [nm & fdecl] (let [[_defn sym] (macroexpand `(cc/defn ~nm ~@fdecl)) env (merge (meta nm) (lang/normalize-env &env) web-config {::lang/def nm}) - nm2 (vary-meta nm merge (meta sym)) - [source ts] (lang/->source env (-> nm ns-qualify keyword) - `(-fn ~nm2 ~@(cond-> fdecl (string? (first fdecl)) next))) - deps (lang/emit-deps ts (lang/get-root-e ts)) - nm3 (vary-meta nm2 assoc ::lang/deps `'~deps)] + nm2 (vary-meta nm merge (meta sym) {::lang/node true}) + source (lang/->source env (-> nm ns-qualify keyword) + `(-fn ~nm2 ~@(cond-> fdecl (string? (first fdecl)) next)))] (when-not (::lang/has-edef? (meta *ns*)) (alter-meta! *ns* assoc ::lang/has-edef? true)) - `(def ~nm3 ~source))) + `(def ~nm2 ~source))) (defmacro amb " Syntax : @@ -210,7 +208,7 @@ this tuple. Returns the concatenation of all body results as a single vector. (if (< (count static) arity) (recur (next args) (conj static (::lang/pure (first args)))) (cc/apply r/bind-args (r/bind-self ctor) static))) - (let [[fixed map? ctor] (r/get-variadic F arity)] + (let [[fixed map? ctor] (r/get-variadic "apply" F arity)] (if (< fixed offset) (loop [args args static static] @@ -246,13 +244,14 @@ this tuple. Returns the concatenation of all body results as a single vector. (defmacro boot-server [opts Main & args] (let [env (merge (lang/normalize-env &env) web-config opts) - defs (lang/->defs env ::Main `(e/fn [] ($ ~Main ~@args)))] - `(cc/fn [events#] (m/stream (r/peer events# :server ~defs ::Main))))) + source (lang/->source env ::Main `(e/fn [] ($ ~Main ~@args)))] + `(cc/fn [events#] + (m/stream (r/peer events# :server (r/->defs {::Main ~source}) ::Main))))) (defmacro boot-client [opts Main & args] (let [env (merge (lang/normalize-env &env) web-config opts) - defs (lang/->defs env ::Main `(e/fn [] ($ ~Main ~@args)))] + source (lang/->source env ::Main `(e/fn [] ($ ~Main ~@args)))] `(hyperfiddle.electric-client-de/reload-when-stale (hyperfiddle.electric-client-de/boot-with-retry - (cc/fn [events#] (m/stream (r/peer events# :client ~defs ::Main))) + (cc/fn [events#] (m/stream (r/peer events# :client (r/->defs {::Main ~source}) ::Main))) hyperfiddle.electric-client-de/connector)))) diff --git a/src/hyperfiddle/electric_dom3_efns.cljc b/src/hyperfiddle/electric_dom3_efns.cljc new file mode 100644 index 000000000..7feaeea36 --- /dev/null +++ b/src/hyperfiddle/electric_dom3_efns.cljc @@ -0,0 +1,329 @@ +(ns hyperfiddle.electric-dom3-efns + (:refer-clojure :exclude [time class?]) + (:require + [clojure.string :as str] + [contrib.assert :as ca] + [contrib.debug] + #?(:cljs goog.dom) + #?(:cljs goog.object) + #?(:cljs goog.style) + [hyperfiddle.electric-de :as e :refer [$]] + [hyperfiddle.electric.impl.lang-de2 :as lang] + [hyperfiddle.incseq :as i] + [hyperfiddle.rcf :as rcf :refer [tests]] + [missionary.core :as m]) + #?(:clj (:import [clojure.lang ExceptionInfo])) + #?(:cljs (:require-macros [hyperfiddle.electric-dom3-efns]))) + +(def node) + +#?(:cljs (defn node? [v] (when v (= 1 (.-nodeType v))))) + +#?(:cljs (defn appending> [elem parent] + (ca/is parent node? "DOM node parent is not an HTML Node. Maybe dom/node is unbound?" {:parent parent}) + (m/observe (fn [!] (.appendChild parent elem) (! elem) #(.remove elem))))) + +(e/defn With [elem Body] (binding [node (e/input (appending> elem node))] node ($ Body))) + +#?(:cljs (defn -googDomSetTextContentNoWarn [node str] + ;; Electric says :infer-warning Cannot infer target type in expression, fixme + (goog.dom/setTextContent node str))) + +#?(:cljs (defn ->text-node [] (goog.dom/createTextNode ""))) + +#?(:cljs (defn text-node? [nd] (= (.-nodeType nd) (.-TEXT_NODE nd)))) +#?(:cljs (defn ensure-not-in-text-node! [nd] (ca/is nd (complement text-node?) "Cannot nest dom/text or text nodes in other text nodes"))) + +(e/defn Text [str] ($ With (->text-node) (e/fn [] (-googDomSetTextContentNoWarn node str)))) + +(defmacro text [& strs] `(do (ensure-not-in-text-node! node) ~@(for [s strs] `($ Text ~s)))) + +(e/defn Comment [str] + ($ With (.createComment js/document "") (e/fn [] (-googDomSetTextContentNoWarn node str)))) + +(def ^:const SVG-NS "http://www.w3.org/2000/svg") +(def ^:const XLINK-NS "http://www.w3.org/1999/xlink") + +(def alias->ns {"svg" SVG-NS, "xlink" XLINK-NS}) + +(defn attr-alias [attr] (second (re-find #"^([^:]+):" (name attr)))) + +(defn resolve-attr-alias [attr] + (let [attr (name attr)] + (if-let [alias (attr-alias attr)] + (let [attr (-> (str/replace-first attr alias "") + (str/replace-first #"^:" ""))] + [(alias->ns alias) attr]) + [nil attr]))) + +#?(:cljs + (defn set-attribute-ns + ([node attr v] + (let [[ns attr] (resolve-attr-alias attr)] + (set-attribute-ns node ns attr v))) + ([^js node ns attr v] + (.setAttributeNS node ns attr v)))) + +#?(:cljs (defn- css-var? [k] (str/starts-with? k "--"))) +#?(:cljs (defn set-style> [node k v] + (let [k (clj->js k), v (clj->js v) + setter (if (css-var? k) #(.setProperty (.-style node) k %) #(goog.style/setStyle_ node % k))] + (m/observe (fn [!] (setter v) (! v) #(setter nil)))))) + +#?(:cljs (defn set-property> + ([node k v] (set-property> node (.-namespaceURI node) k v)) + ([node ns k v] + (let [k (name k), v (clj->js v) + setter (case k + "list" ; corner case, list (datalist) is set by attribute and readonly as a prop. + #(set-attribute-ns node nil k %) + (if (or (= SVG-NS ns) (some? (goog.object/get goog.dom/DIRECT_ATTRIBUTE_MAP_ k))) + #(set-attribute-ns node k %) + (if (goog.object/containsKey node k) ; is there an object property for this key? + #(goog.object/set node k %) + #(set-attribute-ns node k %))))] + (m/observe (fn [!] (setter v) (! v) #(setter nil))))))) + +(def LAST-PROPS + "Due to a bug in both Webkit and FF, input type range's knob renders in the + wrong place if value is set after `min` and `max`, and `max` is above 100. + Other UI libs circumvent this issue by setting `value` last." + [:value ::value]) + +(defn ordered-props "Sort props by key to ensure they are applied in a predefined order. See `LAST-PROPS`." + [props-map] + (let [props (apply dissoc props-map LAST-PROPS)] + (concat (seq props) (seq (select-keys props-map LAST-PROPS))))) + +(defn parse-class [xs] + (cond (or (string? xs) (keyword? xs) (symbol? xs)) (re-seq #"[^\s]+" (name xs)) + (or (vector? xs) (seq? xs) (list? xs) (set? xs)) (into [] (comp (mapcat parse-class) (distinct)) xs) + (nil? xs) nil + :else (throw (ex-info "don't know how to parse into a classlist" {:data xs})))) + +(tests + (parse-class "a") := ["a"] + (parse-class :a) := ["a"] + (parse-class 'a/b) := ["b"] + (parse-class "a b") := ["a" "b"] + (parse-class ["a"]) := ["a"] + (parse-class ["a" "b" "a"]) := ["a" "b"] + (parse-class ["a" "b"]) := ["a" "b"] + (parse-class ["a b" "c"]) := ["a" "b" "c"] + (parse-class [["a b"] '("c d") #{#{"e"} "f"}]) := ["a" "b" "c" "d" "e" "f"] + (parse-class nil) := nil + (parse-class "") := nil + (parse-class " a") := ["a"] + (try (parse-class 42) (throw (ex-info "" {})) + (catch ExceptionInfo ex (ex-data ex) := {:data 42}))) + +#?(:cljs + (defn register-class! [^js node class] + (let [refs (or (.-hyperfiddle_electric_dom2_class_refs node) {})] + (.add (.-classList node) class) + (set! (.-hyperfiddle_electric_dom2_class_refs node) (update refs class (fn [cnt] (inc (or cnt 0)))))))) + +#?(:cljs + (defn unregister-class! [^js node class] + (let [refs (or (.-hyperfiddle_electric_dom2_class_refs node) {}) + refs (if (= 1 (get refs class)) + (do (.remove (.-classList node) class) + (dissoc refs class)) + (update refs class dec))] + (set! (.-hyperfiddle_electric_dom2_class_refs node) refs)))) + +#?(:cljs + (defn- manage-class> [node class] + (m/relieve {} + (m/observe (fn [!] + (! nil) + (register-class! node class) + #(unregister-class! node class)))))) + +(e/defn ClassList [node classes] + (e/client + (e/input (manage-class> node (e/diff-by identity (parse-class classes)))))) + +(e/defn Style [node k v] (e/client (e/input (set-style> node k v)))) + +(e/defn Styles [node kvs] + (e/client + (e/cursor [[k v] (e/diff-by first kvs)] + ($ Style node k v)))) + +(defmacro style [m] + (if (map? m) ; map = static keyset, no need to diff, cheaper + `(do ~@(map (fn [[k v]] `($ Style node ~k ~v)) m)) + `($ Styles node ~m))) + +(e/defn Attribute [node k v] (e/client (e/input (set-property> node k v)))) + +(def ^:private style? #{:style ::style}) ; TODO disambiguate +(def ^:private class? #{:class ::class}) + +(e/defn Property [node k v] + (e/client + (cond (style? k) ($ Styles node v) + (class? k) ($ ClassList node v) + :else ($ Attribute node k v)))) + +(e/defn Properties [node kvs] + (e/client + (let [[k v] (e/diff-by key (ordered-props kvs))] + ($ Property node k v)))) + +(defmacro props [m] + (if (map? m) ; map = static keyset, no need to diff, cheaper + `(do ~@(eduction (map (fn [[k v]] `($ Property node ~k ~v))) + (ordered-props m))) + `(do (let [[k# v#] (e/diff-by key (ordered-props ~m))] + ($ Property node k# v#)) + nil))) + +#?(:cljs + (defn listen> [nd typ f opts] + (m/observe (fn [!] + (! nil) + (let [! (comp ! f), opts (clj->js opts)] + (.addEventListener nd typ ! opts)) #(.removeEventListener nd typ ! opts))))) + +(defmacro listen + ([typ] `(listen ~typ identity)) + ([typ f] `(listen ~typ ~f node)) + ([nd typ f] `(listen ~nd ~typ ~f nil)) + ([nd typ f opts] `(listen> ~nd ~typ ~f ~opts))) + +#?(:cljs (defn ->elem [t] (goog.dom/createElement t))) + +(defmacro a {:style/indent 0} [& body] `($ With (->elem "a") (e/fn [] ~@body))) +(defmacro abbr {:style/indent 0} [& body] `($ With (->elem "abbr") (e/fn [] ~@body))) +(defmacro address {:style/indent 0} [& body] `($ With (->elem "address") (e/fn [] ~@body))) +(defmacro area {:style/indent 0} [& body] `($ With (->elem "area") (e/fn [] ~@body))) +(defmacro article {:style/indent 0} [& body] `($ With (->elem "article") (e/fn [] ~@body))) +(defmacro aside {:style/indent 0} [& body] `($ With (->elem "aside") (e/fn [] ~@body))) +(defmacro audio {:style/indent 0} [& body] `($ With (->elem "audio") (e/fn [] ~@body))) +(defmacro b {:style/indent 0} [& body] `($ With (->elem "b") (e/fn [] ~@body))) +(defmacro bdi {:style/indent 0} [& body] `($ With (->elem "bdi") (e/fn [] ~@body))) +(defmacro bdo {:style/indent 0} [& body] `($ With (->elem "bdo") (e/fn [] ~@body))) +(defmacro blockquote {:style/indent 0} [& body] `($ With (->elem "blockquote") (e/fn [] ~@body))) +(defmacro br {:style/indent 0} [& body] `($ With (->elem "br") (e/fn [] ~@body))) +(defmacro button {:style/indent 0} [& body] `($ With (->elem "button") (e/fn [] ~@body))) +(defmacro canvas {:style/indent 0} [& body] `($ With (->elem "canvas") (e/fn [] ~@body))) +(defmacro cite {:style/indent 0} [& body] `($ With (->elem "cite") (e/fn [] ~@body))) +(defmacro code {:style/indent 0} [& body] `($ With (->elem "code") (e/fn [] ~@body))) +(defmacro colgroup {:style/indent 0} [& body] `($ With (->elem "colgroup") (e/fn [] ~@body))) +(defmacro col {:style/indent 0} [& body] `($ With (->elem "col") (e/fn [] ~@body))) +(defmacro data {:style/indent 0} [& body] `($ With (->elem "data") (e/fn [] ~@body))) +(defmacro datalist {:style/indent 0} [& body] `($ With (->elem "datalist") (e/fn [] ~@body))) +(defmacro del {:style/indent 0} [& body] `($ With (->elem "del") (e/fn [] ~@body))) +(defmacro details {:style/indent 0} [& body] `($ With (->elem "details") (e/fn [] ~@body))) +(defmacro dfn {:style/indent 0} [& body] `($ With (->elem "dfn") (e/fn [] ~@body))) +(defmacro dialog {:style/indent 0} [& body] `($ With (->elem "dialog") (e/fn [] ~@body))) +(defmacro div {:style/indent 0} [& body] `($ With (->elem "div") (e/fn [] ~@body))) +(defmacro dl "The
HTML element represents a description list. The element encloses a list of groups of terms (specified using the
element) and descriptions (provided by
elements). Common uses for this element are to implement a glossary or to display metadata (a list of key-value pairs)." {:style/indent 0} [& body] `($ With (->elem "dl") (e/fn [] ~@body))) +(defmacro dt "The
HTML element specifies a term in a description or definition list, and as such must be used inside a
element. It is usually followed by a
element; however, multiple
elements in a row indicate several terms that are all defined by the immediate next
element." {:style/indent 0} [& body] `($ With (->elem "dt") (e/fn [] ~@body))) +(defmacro dd "The
HTML element provides the description, definition, or value for the preceding term (
) in a description list (
)." {:style/indent 0} [& body] `($ With (->elem "dd") (e/fn [] ~@body))) +(defmacro em {:style/indent 0} [& body] `($ With (->elem "em") (e/fn [] ~@body))) +(defmacro embed {:style/indent 0} [& body] `($ With (->elem "embed") (e/fn [] ~@body))) +(defmacro fieldset {:style/indent 0} [& body] `($ With (->elem "fieldset") (e/fn [] ~@body))) +(defmacro figure {:style/indent 0} [& body] `($ With (->elem "figure") (e/fn [] ~@body))) +(defmacro footer {:style/indent 0} [& body] `($ With (->elem "footer") (e/fn [] ~@body))) +(defmacro form {:style/indent 0} [& body] `($ With (->elem "form") (e/fn [] ~@body))) +(defmacro h1 {:style/indent 0} [& body] `($ With (->elem "h1") (e/fn [] ~@body))) +(defmacro h2 {:style/indent 0} [& body] `($ With (->elem "h2") (e/fn [] ~@body))) +(defmacro h3 {:style/indent 0} [& body] `($ With (->elem "h3") (e/fn [] ~@body))) +(defmacro h4 {:style/indent 0} [& body] `($ With (->elem "h4") (e/fn [] ~@body))) +(defmacro h5 {:style/indent 0} [& body] `($ With (->elem "h5") (e/fn [] ~@body))) +(defmacro h6 {:style/indent 0} [& body] `($ With (->elem "h6") (e/fn [] ~@body))) +(defmacro header {:style/indent 0} [& body] `($ With (->elem "header") (e/fn [] ~@body))) +(defmacro hgroup {:style/indent 0} [& body] `($ With (->elem "hgroup") (e/fn [] ~@body))) +(defmacro hr {:style/indent 0} [& body] `($ With (->elem "hr") (e/fn [] ~@body))) +(defmacro i {:style/indent 0} [& body] `($ With (->elem "i") (e/fn [] ~@body))) +(defmacro iframe {:style/indent 0} [& body] `($ With (->elem "iframe") (e/fn [] ~@body))) +(defmacro img {:style/indent 0} [& body] `($ With (->elem "img") (e/fn [] ~@body))) +(defmacro input {:style/indent 0} [& body] `($ With (->elem "input") (e/fn [] ~@body))) +(defmacro ins {:style/indent 0} [& body] `($ With (->elem "ins") (e/fn [] ~@body))) +(defmacro kbd {:style/indent 0} [& body] `($ With (->elem "kbd") (e/fn [] ~@body))) +(defmacro label {:style/indent 0} [& body] `($ With (->elem "label") (e/fn [] ~@body))) +(defmacro legend {:style/indent 0} [& body] `($ With (->elem "legend") (e/fn [] ~@body))) +(defmacro li {:style/indent 0} [& body] `($ With (->elem "li") (e/fn [] ~@body))) +(defmacro link {:style/indent 0} [& body] `($ With (->elem "link") (e/fn [] ~@body))) +(defmacro main {:style/indent 0} [& body] `($ With (->elem "main") (e/fn [] ~@body))) +#_(defmacro map {:style/indent 0} [& body] `($ With (->elem "map") (e/fn [] ~@body))) +(defmacro mark {:style/indent 0} [& body] `($ With (->elem "mark") (e/fn [] ~@body))) +(defmacro math {:style/indent 0} [& body] `($ With (->elem "math") (e/fn [] ~@body))) +(defmacro menu {:style/indent 0} [& body] `($ With (->elem "menu") (e/fn [] ~@body))) +(defmacro itemprop {:style/indent 0} [& body] `($ With (->elem "itemprop") (e/fn [] ~@body))) +(defmacro meter {:style/indent 0} [& body] `($ With (->elem "meter") (e/fn [] ~@body))) +(defmacro nav {:style/indent 0} [& body] `($ With (->elem "nav") (e/fn [] ~@body))) +(defmacro noscript {:style/indent 0} [& body] `($ With (->elem "noscript") (e/fn [] ~@body))) +(defmacro object {:style/indent 0} [& body] `($ With (->elem "object") (e/fn [] ~@body))) +(defmacro ol {:style/indent 0} [& body] `($ With (->elem "ol") (e/fn [] ~@body))) +(defmacro option {:style/indent 0} [& body] `($ With (->elem "option") (e/fn [] ~@body))) +(defmacro optgroup {:style/indent 0} [& body] `($ With (->elem "optgroup") (e/fn [] ~@body))) +(defmacro output {:style/indent 0} [& body] `($ With (->elem "output") (e/fn [] ~@body))) +(defmacro p {:style/indent 0} [& body] `($ With (->elem "p") (e/fn [] ~@body))) +(defmacro picture {:style/indent 0} [& body] `($ With (->elem "picture") (e/fn [] ~@body))) +(defmacro pre {:style/indent 0} [& body] `($ With (->elem "pre") (e/fn [] ~@body))) +(defmacro progress {:style/indent 0} [& body] `($ With (->elem "progress") (e/fn [] ~@body))) +(defmacro q {:style/indent 0} [& body] `($ With (->elem "q") (e/fn [] ~@body))) +(defmacro ruby {:style/indent 0} [& body] `($ With (->elem "ruby") (e/fn [] ~@body))) +(defmacro s {:style/indent 0} [& body] `($ With (->elem "s") (e/fn [] ~@body))) +(defmacro samp {:style/indent 0} [& body] `($ With (->elem "samp") (e/fn [] ~@body))) +(defmacro script {:style/indent 0} [& body] `($ With (->elem "script") (e/fn [] ~@body))) +(defmacro section {:style/indent 0} [& body] `($ With (->elem "section") (e/fn [] ~@body))) +(defmacro select {:style/indent 0} [& body] `($ With (->elem "select") (e/fn [] ~@body))) +(defmacro slot {:style/indent 0} [& body] `($ With (->elem "slot") (e/fn [] ~@body))) +(defmacro small {:style/indent 0} [& body] `($ With (->elem "small") (e/fn [] ~@body))) +(defmacro span {:style/indent 0} [& body] `($ With (->elem "span") (e/fn [] ~@body))) +(defmacro strong {:style/indent 0} [& body] `($ With (->elem "strong") (e/fn [] ~@body))) +(defmacro sub {:style/indent 0} [& body] `($ With (->elem "sub") (e/fn [] ~@body))) +(defmacro summary {:style/indent 0} [& body] `($ With (->elem "summary") (e/fn [] ~@body))) +(defmacro sup {:style/indent 0} [& body] `($ With (->elem "sup") (e/fn [] ~@body))) +(defmacro table {:style/indent 0} [& body] `($ With (->elem "table") (e/fn [] ~@body))) +(defmacro tbody {:style/indent 0} [& body] `($ With (->elem "tbody") (e/fn [] ~@body))) +(defmacro td {:style/indent 0} [& body] `($ With (->elem "td") (e/fn [] ~@body))) +(defmacro th {:style/indent 0} [& body] `($ With (->elem "th") (e/fn [] ~@body))) +(defmacro thead {:style/indent 0} [& body] `($ With (->elem "thead") (e/fn [] ~@body))) +(defmacro tr {:style/indent 0} [& body] `($ With (->elem "tr") (e/fn [] ~@body))) +(defmacro template {:style/indent 0} [& body] `($ With (->elem "template") (e/fn [] ~@body))) +(defmacro textarea {:style/indent 0} [& body] `($ With (->elem "textarea") (e/fn [] ~@body))) +(defmacro time {:style/indent 0} [& body] `($ With (->elem "time") (e/fn [] ~@body))) +(defmacro u {:style/indent 0} [& body] `($ With (->elem "u") (e/fn [] ~@body))) +(defmacro ul {:style/indent 0} [& body] `($ With (->elem "ul") (e/fn [] ~@body))) +(defmacro var {:style/indent 0} [& body] `($ With (->elem "var") (e/fn [] ~@body))) +(defmacro video {:style/indent 0} [& body] `($ With (->elem "video") (e/fn [] ~@body))) +(defmacro wbr {:style/indent 0} [& body] `($ With (->elem "wbr") (e/fn [] ~@body))) + +#?(:cljs + ;; TODO starts as empty incseq, later singleton changing value + (defn listen1 [nd typ f opts] + (m/observe (fn [!] + (! nil) + (let [! (comp ! f) , opts (clj->js opts)] + (.addEventListener nd typ ! opts)) #(.removeEventListener nd typ ! opts))))) + +(defmacro listen + ([typ] `(listen ~typ identity)) + ([typ f] `(listen node ~typ ~f)) + ([nd typ f] `(listen ~nd ~typ ~f nil)) + ([nd typ f opts] `(e/input (listen1 ~nd ~typ ~f ~opts)))) + +(defn append-only [> js opts)] + (.addEventListener nd typ ! opts)) #(.removeEventListener nd typ ! opts)))))) + +(defmacro event-log + ([typ] `(event-log ~typ identity)) + ([typ f] `(event-log node ~typ ~f)) + ([nd typ f] `(event-log ~nd ~typ ~f nil)) + ([nd typ f opts] `(e/join (event-log* ~nd ~typ ~f ~opts)))) diff --git a/src/hyperfiddle/electric_local_def_de.cljc b/src/hyperfiddle/electric_local_def_de.cljc index d3df31c0d..2b2b3526b 100644 --- a/src/hyperfiddle/electric_local_def_de.cljc +++ b/src/hyperfiddle/electric_local_def_de.cljc @@ -41,7 +41,7 @@ (defn run-single [frame] (m/reduce #(do %2) nil frame)) (defmacro single {:style/indent 1} [conf & body] (ca/is conf map? "provide config map as first argument") - `(run-single (r/root-frame ~(lang/->defs (->env &env conf) ::Main `(e/fn [] (do ~@body))) ::Main))) + `(run-single (r/root-frame (r/->defs {::Main ~(lang/->source (->env &env conf) ::Main `(e/fn [] (do ~@body)))}) ::Main))) (defn run-local [defs main] (m/reduce #(do %2) nil @@ -54,4 +54,4 @@ (defmacro local {:style/indent 1} [conf & body] (ca/is conf map? "provide config map as first argument") - `(run-local ~(lang/->defs (->env &env conf) ::Main `(e/fn [] (do ~@body))) ::Main)) + `(run-local (r/->defs {::Main ~(lang/->source (->env &env conf) ::Main `(e/fn [] (do ~@body)))}) ::Main)) From fa3ed0e5cfd4e7e0fad089be0e3e4770f51adbaa Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 22 Apr 2024 11:12:23 +0200 Subject: [PATCH 217/428] test for r/->defs bug --- test/hyperfiddle/electric/impl/runtime_test.cljc | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/test/hyperfiddle/electric/impl/runtime_test.cljc b/test/hyperfiddle/electric/impl/runtime_test.cljc index c74ac2a13..2a8dadd62 100644 --- a/test/hyperfiddle/electric/impl/runtime_test.cljc +++ b/test/hyperfiddle/electric/impl/runtime_test.cljc @@ -243,4 +243,7 @@ (s->c @s-ps) % := 2 % := :step-c - (c->s @c-ps)) \ No newline at end of file + (c->s @c-ps)) + +(tests + (set (keys (r/->defs {:a (fn [_ _] {:b (fn [_ _] {:a (fn [_ _])})})}))) := #{:a :b}) From 06ea0d0ee958d894e4b045db7928222102da9138 Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 22 Apr 2024 11:27:20 +0200 Subject: [PATCH 218/428] incseq count --- src/hyperfiddle/incseq.cljc | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/src/hyperfiddle/incseq.cljc b/src/hyperfiddle/incseq.cljc index ab91f6c28..310f283e4 100644 --- a/src/hyperfiddle/incseq.cljc +++ b/src/hyperfiddle/incseq.cljc @@ -40,7 +40,8 @@ successive sequence diffs. Incremental sequences are applicative functors with ` (:require [hyperfiddle.incseq.perm-impl :as p] [hyperfiddle.incseq.diff-impl :as d] [hyperfiddle.incseq.items-impl :as i] - [hyperfiddle.rcf :refer [tests]]) + [hyperfiddle.rcf :refer [tests]] + [missionary.core :as m]) (:import #?(:clj (clojure.lang IFn IDeref)) missionary.Cancelled)) @@ -1231,8 +1232,25 @@ optional `compare` function, `clojure.core/compare` by default. (def ^{:arglists '([incseq])} items i/flow) +(def ^{:arglists '([incseq]) + :doc " +Returns the provided `incseq`'s size as a continuous flow +"} count* + (fn [is] (m/reductions (fn [r x] (-> r (+ (:grow x)) (- (:shrink x)))) 0 is))) + ;; unit tests +(tests + (def !x (atom [:foo])) + (def ps ((count* (diff-by identity (m/watch !x))) #() #())) + @ps := 0 + @ps := 1 + (swap! !x conj :bar), @!x := [:foo :bar] + @ps := 2 + (swap! !x pop), @!x := [:foo] + @ps := 1 + (ps)) + (tests "incremental sequences" (letfn [(queue [] #?(:clj (let [q (java.util.LinkedList.)] From 84a37227fb560b0e06ef697e92f893b39ccee3a1 Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 22 Apr 2024 14:20:39 +0200 Subject: [PATCH 219/428] improve docstring --- src/hyperfiddle/incseq.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/hyperfiddle/incseq.cljc b/src/hyperfiddle/incseq.cljc index 310f283e4..067811529 100644 --- a/src/hyperfiddle/incseq.cljc +++ b/src/hyperfiddle/incseq.cljc @@ -1234,7 +1234,7 @@ optional `compare` function, `clojure.core/compare` by default. (def ^{:arglists '([incseq]) :doc " -Returns the provided `incseq`'s size as a continuous flow +Returns the size of `incseq` as a continuous flow. "} count* (fn [is] (m/reductions (fn [r x] (-> r (+ (:grow x)) (- (:shrink x)))) 0 is))) From edf6762ff3655203a11532e87f838cc2e13c8cf9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Fri, 26 Apr 2024 18:40:42 +0200 Subject: [PATCH 220/428] fix latest-product glitch --- src/hyperfiddle/incseq.cljc | 307 +-------------- .../incseq/latest_product_impl.cljc | 369 ++++++++++++++++++ 2 files changed, 371 insertions(+), 305 deletions(-) create mode 100644 src/hyperfiddle/incseq/latest_product_impl.cljc diff --git a/src/hyperfiddle/incseq.cljc b/src/hyperfiddle/incseq.cljc index 067811529..bff9fa817 100644 --- a/src/hyperfiddle/incseq.cljc +++ b/src/hyperfiddle/incseq.cljc @@ -40,6 +40,7 @@ successive sequence diffs. Incremental sequences are applicative functors with ` (:require [hyperfiddle.incseq.perm-impl :as p] [hyperfiddle.incseq.diff-impl :as d] [hyperfiddle.incseq.items-impl :as i] + [hyperfiddle.incseq.latest-product-impl :as lp] [hyperfiddle.rcf :refer [tests]] [missionary.core :as m]) (:import #?(:clj (clojure.lang IFn IDeref)) @@ -384,311 +385,7 @@ A collection is fixed iff its size is invariant and its items are immobile. :doc " Returns the incremental sequence defined by applying the cartesian product of items in given incremental sequences, combined with given function. -"} latest-product - (let [slot-notifier 0 - slot-terminator 1 - slot-combinator 2 - slot-processes 3 - slot-buffers 4 - slot-freezers 5 - slot-counts 6 - slot-ready 7 - slot-push 8 - slot-live 9 - slot-args 10 - slot-value 11 - slots 12] - (letfn [(call [f ^objects args] - (case (alength args) - 0 (f) - 1 (f (aget args 0)) - 2 (f (aget args 0) (aget args 1)) - 3 (f (aget args 0) (aget args 1) (aget args 2)) - 4 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3)) - 5 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4)) - 6 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5)) - 7 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5) (aget args 6)) - 8 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5) (aget args 6) (aget args 7)) - 9 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5) (aget args 6) (aget args 7) (aget args 8)) - 10 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5) (aget args 6) (aget args 7) (aget args 8) (aget args 9)) - 11 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5) (aget args 6) (aget args 7) (aget args 8) (aget args 9) (aget args 10)) - 12 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5) (aget args 6) (aget args 7) (aget args 8) (aget args 9) (aget args 10) (aget args 11)) - 13 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5) (aget args 6) (aget args 7) (aget args 8) (aget args 9) (aget args 10) (aget args 11) (aget args 12)) - 14 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5) (aget args 6) (aget args 7) (aget args 8) (aget args 9) (aget args 10) (aget args 11) (aget args 12) (aget args 13)) - 15 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5) (aget args 6) (aget args 7) (aget args 8) (aget args 9) (aget args 10) (aget args 11) (aget args 12) (aget args 13) (aget args 14)) - 16 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5) (aget args 6) (aget args 7) (aget args 8) (aget args 9) (aget args 10) (aget args 11) (aget args 12) (aget args 13) (aget args 14) (aget args 15)) - 17 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5) (aget args 6) (aget args 7) (aget args 8) (aget args 9) (aget args 10) (aget args 11) (aget args 12) (aget args 13) (aget args 14) (aget args 15) (aget args 16)) - 18 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5) (aget args 6) (aget args 7) (aget args 8) (aget args 9) (aget args 10) (aget args 11) (aget args 12) (aget args 13) (aget args 14) (aget args 15) (aget args 16) (aget args 17)) - 19 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5) (aget args 6) (aget args 7) (aget args 8) (aget args 9) (aget args 10) (aget args 11) (aget args 12) (aget args 13) (aget args 14) (aget args 15) (aget args 16) (aget args 17) (aget args 18)) - 20 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5) (aget args 6) (aget args 7) (aget args 8) (aget args 9) (aget args 10) (aget args 11) (aget args 12) (aget args 13) (aget args 14) (aget args 15) (aget args 16) (aget args 17) (aget args 18) (aget args 19)) - (apply f (aclone args)))) - (combine-indices [total-card degree r j] - (eduction - (mapcat (fn [k] (range k (unchecked-add-int k r)))) - (range (unchecked-multiply-int j r) total-card - (unchecked-multiply-int degree r)))) - (ensure-capacity [^objects freezers ^objects buffers item grow degree] - (let [^ints freezer (aget freezers item) - n (bit-shift-left (alength freezer) 5)] - (when (< n degree) - (loop [n n] - (let [n (bit-shift-left n 1)] - (if (< n degree) - (recur n) - (let [a (int-array (bit-shift-right n 5)) - s (-> (unchecked-subtract-int degree grow) - (bit-shift-right 5) - (unchecked-inc-int))] - #?(:clj (System/arraycopy freezer 0 a 0 s) - :cljs (dotimes [i s] (aset a i (aget freezer i)))) - (aset freezers item a))))))) - (let [^objects buffer (aget buffers item) - n (alength buffer)] - (when (< n degree) - (loop [n n] - (let [n (bit-shift-left n 1)] - (if (< n degree) - (recur n) - (let [a (object-array n) - s (unchecked-subtract-int degree grow)] - #?(:clj (System/arraycopy buffer 0 a 0 s) - :cljs (dotimes [i s] (aset a i (aget buffer i)))) - (aset buffers item a)))))))) - (compute-permutation [l r grow degree shrink permutation] - (let [lr (unchecked-multiply l r) - size-after (unchecked-subtract degree shrink) - size-before (unchecked-subtract degree grow) - r-create (unchecked-multiply r grow) - r-degree (unchecked-multiply r degree) - r-remove (unchecked-multiply r shrink) - r-size-before (unchecked-multiply r size-before) - r-size-after (unchecked-multiply r size-after) - lr-size-after (unchecked-multiply lr size-after) - lr-degree (unchecked-multiply lr degree) - create-offset (unchecked-subtract lr-degree r-create) - remove-offset (unchecked-subtract lr-size-after r-size-after)] - (compose - (reduce compose {} - (eduction - (map (fn [k] - (p/split-swap - (+ r-size-after (* k r-degree)) r-remove - (- remove-offset (* k r-size-after))))) - (range l))) - permutation - (reduce compose {} - (eduction - (map (fn [k] - (p/split-swap - (- create-offset (* k r-degree)) - (* k r-size-before) r-create))) - (range l)))))) - (freeze! [^ints freezer i] - (let [j (int (bit-shift-right i 5)) - k (int (bit-and i (unchecked-dec (bit-shift-left 1 5))))] - (aset freezer j (int (bit-set (aget freezer j) k))))) - (unfreeze! [^ints freezer i] - (let [j (int (bit-shift-right i 5)) - k (int (bit-and i (unchecked-dec (bit-shift-left 1 5))))] - (aset freezer j (int (bit-clear (aget freezer j) k))))) - (frozen? [^ints freezer i] - (let [j (bit-shift-right i 5) - k (bit-and i (unchecked-dec (bit-shift-left 1 5)))] - (bit-test (aget freezer j) k))) - (cancel [^objects state] - (let [^objects processes (aget state slot-processes)] - (dotimes [item (alength processes)] ((aget processes item))))) - (transfer [^objects state] - (let [^objects processes (aget state slot-processes) - ^objects freezers (aget state slot-freezers) - ^objects buffers (aget state slot-buffers) - ^objects args (aget state slot-args) - ^ints counts (aget state slot-counts) - ^ints ready (aget state slot-ready) - offset (bit-shift-right (alength counts) 1) - arity (alength processes) - f (aget state slot-combinator) - item (aget ready 0)] - (aset ready 0 arity) - ((locking state - (loop [item item - i (rem 1 arity)] - (if (nil? (aget state slot-notifier)) - (try @(aget processes item) (catch #?(:clj Throwable :cljs :default) _)) - (aset state slot-value - (try (let [diff (aget state slot-value) - count-index (unchecked-add-int offset item) - {:keys [grow shrink degree permutation change freeze]} @(aget processes item)] - (ensure-capacity freezers buffers item grow degree) - (let [^ints freezer (aget freezers item) - ^objects buffer (aget buffers item) - size-before (unchecked-subtract-int degree grow) - size-after (unchecked-subtract-int degree shrink)] - (aset counts count-index size-after) - (loop [i size-before] - (when (< i degree) - (aset buffer i buffer) - (recur (unchecked-inc-int i)))) - (loop [l 1, r 1, i count-index] - (case i - 1 (let [lr-size-after (aget counts 1) - foreign-degree (unchecked-multiply-int l r) - product-degree (unchecked-multiply-int degree foreign-degree) - product-cycles (into #{} - (mapcat - (fn [cycle] - (let [k (nth cycle 0) - x (aget buffer k) - f (frozen? freezer k) - l (reduce - (fn [k l] - (aset buffer k (aget buffer l)) - ((if (frozen? freezer l) - freeze! unfreeze!) - freezer k) l) - k (subvec cycle 1))] - (aset buffer l x) - ((if f freeze! unfreeze!) - freezer k)) - (->> cycle - (map (partial combine-indices product-degree degree r)) - (apply map vector)))) - (decompose permutation))] - (loop [i size-after] - (when (< i degree) - (unfreeze! freezer i) - (aset buffer i nil) - (recur (unchecked-inc-int i)))) - (combine diff - (hash-map - :grow (unchecked-multiply-int grow foreign-degree) - :degree product-degree - :permutation (compute-permutation l r grow degree shrink - (recompose product-cycles)) - :shrink (unchecked-multiply-int shrink foreign-degree) - :change (persistent! - (reduce-kv - (fn [m k v] - (let [^objects buffer (aget buffers item)] - (if (= (aget buffer k) (aset buffer k v)) - m (reduce (fn [m i] - (loop [n i - j (alength buffers)] - (let [j (unchecked-dec-int j) - c (aget counts (unchecked-add-int offset j))] - (aset args j (aget ^objects (aget buffers j) (rem n c))) - (if (pos? j) - (recur (quot n c) j) - (assoc! m i (call f args)))))) - m (combine-indices lr-size-after size-after r k))))) - (transient {}) change)) - :freeze (persistent! - (reduce - (fn [s k] - (freeze! (aget freezers item) k) - (reduce (fn [s i] - (loop [n i - j (alength freezers)] - (let [j (unchecked-dec-int j) - c (aget counts (unchecked-add-int offset j))] - (if (frozen? (aget freezers j) (rem n c)) - (if (pos? j) - (recur (quot n c) j) - (conj! s i)) s)))) - s (combine-indices lr-size-after size-after r k))) - (transient #{}) freeze))))) - (let [j (bit-shift-right i 1)] - (if (odd? i) - (let [x (aget counts (unchecked-dec-int i))] - (aset counts j (unchecked-multiply-int x (aget counts i))) - (recur (unchecked-multiply-int x l) r j)) - (let [x (aget counts (unchecked-inc-int i))] - (aset counts j (unchecked-multiply-int x (aget counts i))) - (recur l (unchecked-multiply-int x r) j)))))))) - (catch #?(:clj Throwable :cljs :default) e - (aset state slot-notifier nil) - (cancel state) e)))) - (let [item (aget ready i)] - (if (== arity item) - (do (aset state slot-push nil) - (if (zero? (aget state slot-live)) - (aget state slot-terminator) nop)) - (do (aset ready i arity) - (recur item (rem (unchecked-inc-int i) arity)))))))) - (let [x (aget state slot-value)] - (aset state slot-value (empty-diff (aget counts 1))) - (if (nil? (aget state slot-notifier)) (throw x) x)))) - (terminated [^objects state] - ((locking state - (if (zero? (aset state slot-live (dec (aget state slot-live)))) - (if (nil? (aget state slot-push)) (aget state slot-terminator) nop) nop)))) - (input-ready [^objects state item] - ((locking state - (let [^objects processes (aget state slot-processes) - ^ints ready (aget state slot-ready) - arity (alength processes) - item (int item)] - (if-some [i (aget state slot-push)] - (do (aset state slot-push (identity (rem (unchecked-inc-int i) arity))) - (aset ready i item) nop) - (do (aset state slot-push (identity (rem 1 arity))) - (if-some [cb (aget state slot-notifier)] - (do (aset ready 0 item) cb) - (loop [item item - i (rem 1 arity)] - (try @(aget processes item) (catch #?(:clj Throwable :cljs :default) _)) - (let [item (aget ready i)] - (if (== arity item) - (do (aset state slot-push nil) - (if (zero? (aget state slot-live)) - (aget state slot-terminator) nop)) - (do (aset ready i arity) - (recur item (rem (unchecked-inc-int i) arity))))))))))))) - (input-spawn [^objects state item flow] - (let [^objects freezers (aget state slot-freezers) - ^objects buffers (aget state slot-buffers) - ^objects processes (aget state slot-processes)] - (aset freezers item (int-array 1)) - (aset buffers item (object-array 1)) - (aset processes item - (flow #(input-ready state item) - #(terminated state)))) - state)] - (fn [f & diffs] - (let [diffs (vec diffs)] - (fn [n t] - (let [state (object-array slots) - arity (count diffs) - ready (int-array arity)] - (dotimes [i arity] (aset ready i arity)) - (aset state slot-notifier n) - (aset state slot-terminator t) - (aset state slot-combinator f) - (aset state slot-args (object-array arity)) - (aset state slot-buffers (object-array arity)) - (aset state slot-freezers (object-array arity)) - (aset state slot-processes (object-array arity)) - (aset state slot-ready ready) - (aset state slot-counts - (let [o (loop [o 1] - (if (< o arity) - (recur (bit-shift-left o 1)) o)) - n (bit-shift-left o 1) - arr (int-array n)] - (loop [f (unchecked-subtract o arity) - o o - n n] - (when (< 1 o) - (loop [i (unchecked-subtract n f)] - (when (< i n) - (aset arr i 1) - (recur (unchecked-inc i)))) - (recur (bit-shift-right f 1) - (bit-shift-right o 1) o))) arr)) - (aset state slot-live (identity arity)) - (aset state slot-value (empty-diff 0)) - (reduce-kv input-spawn state diffs) - (->Ps state cancel transfer)))))))) +"} latest-product lp/flow) (def ^{:arglists '([incseq-of-incseqs]) diff --git a/src/hyperfiddle/incseq/latest_product_impl.cljc b/src/hyperfiddle/incseq/latest_product_impl.cljc new file mode 100644 index 000000000..19cce8e13 --- /dev/null +++ b/src/hyperfiddle/incseq/latest_product_impl.cljc @@ -0,0 +1,369 @@ +(ns hyperfiddle.incseq.latest-product-impl + (:require [hyperfiddle.incseq.perm-impl :as p] + [hyperfiddle.incseq.diff-impl :as d]) + #?(:clj (:import (java.util.concurrent.locks Lock ReentrantLock) + (clojure.lang IFn IDeref)))) + +(def slot-lock 0) +(def slot-notifier 1) +(def slot-terminator 2) +(def slot-combinator 3) +(def slot-processes 4) +(def slot-buffers 5) +(def slot-freezers 6) +(def slot-counts 7) +(def slot-ready 8) +(def slot-push 9) +(def slot-live 10) +(def slot-args 11) +(def slots 12) + +(defn lock [^objects state] + #?(:clj (.lock ^Lock (aget state slot-lock)))) + +(defn unlock [^objects state] + #?(:clj (.unlock ^Lock (aget state slot-lock)))) + +(defn call [f ^objects args] + (case (alength args) + 0 (f) + 1 (f (aget args 0)) + 2 (f (aget args 0) (aget args 1)) + 3 (f (aget args 0) (aget args 1) (aget args 2)) + 4 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3)) + 5 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4)) + 6 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5)) + 7 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5) (aget args 6)) + 8 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5) (aget args 6) (aget args 7)) + 9 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5) (aget args 6) (aget args 7) (aget args 8)) + 10 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5) (aget args 6) (aget args 7) (aget args 8) (aget args 9)) + 11 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5) (aget args 6) (aget args 7) (aget args 8) (aget args 9) (aget args 10)) + 12 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5) (aget args 6) (aget args 7) (aget args 8) (aget args 9) (aget args 10) (aget args 11)) + 13 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5) (aget args 6) (aget args 7) (aget args 8) (aget args 9) (aget args 10) (aget args 11) (aget args 12)) + 14 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5) (aget args 6) (aget args 7) (aget args 8) (aget args 9) (aget args 10) (aget args 11) (aget args 12) (aget args 13)) + 15 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5) (aget args 6) (aget args 7) (aget args 8) (aget args 9) (aget args 10) (aget args 11) (aget args 12) (aget args 13) (aget args 14)) + 16 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5) (aget args 6) (aget args 7) (aget args 8) (aget args 9) (aget args 10) (aget args 11) (aget args 12) (aget args 13) (aget args 14) (aget args 15)) + 17 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5) (aget args 6) (aget args 7) (aget args 8) (aget args 9) (aget args 10) (aget args 11) (aget args 12) (aget args 13) (aget args 14) (aget args 15) (aget args 16)) + 18 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5) (aget args 6) (aget args 7) (aget args 8) (aget args 9) (aget args 10) (aget args 11) (aget args 12) (aget args 13) (aget args 14) (aget args 15) (aget args 16) (aget args 17)) + 19 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5) (aget args 6) (aget args 7) (aget args 8) (aget args 9) (aget args 10) (aget args 11) (aget args 12) (aget args 13) (aget args 14) (aget args 15) (aget args 16) (aget args 17) (aget args 18)) + 20 (f (aget args 0) (aget args 1) (aget args 2) (aget args 3) (aget args 4) (aget args 5) (aget args 6) (aget args 7) (aget args 8) (aget args 9) (aget args 10) (aget args 11) (aget args 12) (aget args 13) (aget args 14) (aget args 15) (aget args 16) (aget args 17) (aget args 18) (aget args 19)) + (apply f (aclone args)))) + +(defn combine-indices [total-card degree r j] + (eduction + (mapcat (fn [k] (range k (unchecked-add-int k r)))) + (range (unchecked-multiply-int j r) total-card + (unchecked-multiply-int degree r)))) + +(defn ensure-capacity [^objects freezers ^objects buffers item grow degree] + (let [^ints freezer (aget freezers item) + n (bit-shift-left (alength freezer) 5)] + (when (< n degree) + (loop [n n] + (let [n (bit-shift-left n 1)] + (if (< n degree) + (recur n) + (let [a (int-array (bit-shift-right n 5)) + s (-> (unchecked-subtract-int degree grow) + (bit-shift-right 5) + (unchecked-inc-int))] + #?(:clj (System/arraycopy freezer 0 a 0 s) + :cljs (dotimes [i s] (aset a i (aget freezer i)))) + (aset freezers item a))))))) + (let [^objects buffer (aget buffers item) + n (alength buffer)] + (when (< n degree) + (loop [n n] + (let [n (bit-shift-left n 1)] + (if (< n degree) + (recur n) + (let [a (object-array n) + s (unchecked-subtract-int degree grow)] + #?(:clj (System/arraycopy buffer 0 a 0 s) + :cljs (dotimes [i s] (aset a i (aget buffer i)))) + (aset buffers item a)))))))) + +(defn compute-permutation [l r grow degree shrink permutation] + (let [lr (unchecked-multiply l r) + size-after (unchecked-subtract degree shrink) + size-before (unchecked-subtract degree grow) + r-create (unchecked-multiply r grow) + r-degree (unchecked-multiply r degree) + r-remove (unchecked-multiply r shrink) + r-size-before (unchecked-multiply r size-before) + r-size-after (unchecked-multiply r size-after) + lr-size-after (unchecked-multiply lr size-after) + lr-degree (unchecked-multiply lr degree) + create-offset (unchecked-subtract lr-degree r-create) + remove-offset (unchecked-subtract lr-size-after r-size-after)] + (p/compose + (reduce p/compose {} + (eduction + (map (fn [k] + (p/split-swap + (+ r-size-after (* k r-degree)) r-remove + (- remove-offset (* k r-size-after))))) + (range l))) + permutation + (reduce p/compose {} + (eduction + (map (fn [k] + (p/split-swap + (- create-offset (* k r-degree)) + (* k r-size-before) r-create))) + (range l)))))) + +(defn freeze! [^ints freezer i] + (let [j (int (bit-shift-right i 5)) + k (int (bit-and i (unchecked-dec (bit-shift-left 1 5))))] + (aset freezer j (int (bit-set (aget freezer j) k))))) + +(defn unfreeze! [^ints freezer i] + (let [j (int (bit-shift-right i 5)) + k (int (bit-and i (unchecked-dec (bit-shift-left 1 5))))] + (aset freezer j (int (bit-clear (aget freezer j) k))))) + +(defn frozen? [^ints freezer i] + (let [j (bit-shift-right i 5) + k (bit-and i (unchecked-dec (bit-shift-left 1 5)))] + (bit-test (aget freezer j) k))) + +(defn flush-ready [^objects state item pull] + (let [^objects processes (aget state slot-processes) + ^ints ready (aget state slot-ready) + arity (alength processes)] + (loop [item item + pull pull] + (try @(aget processes item) (catch #?(:clj Throwable :cljs :default) _)) + (let [item (aget ready pull)] + (when-not (== arity item) + (aset ready pull arity) + (recur item (rem (unchecked-inc-int pull) arity))))))) + +(defn cancel [^objects state] + (let [^objects processes (aget state slot-processes)] + (dotimes [item (alength processes)] ((aget processes item))))) + +(defn transfer [^objects state] + (let [^objects processes (aget state slot-processes) + ^objects freezers (aget state slot-freezers) + ^objects buffers (aget state slot-buffers) + ^objects args (aget state slot-args) + ^ints counts (aget state slot-counts) + ^ints ready (aget state slot-ready) + offset (bit-shift-right (alength counts) 1) + arity (alength processes) + f (aget state slot-combinator) + item (aget ready 0)] + (aset ready 0 arity) + (lock state) + (try (loop [item item + pull (rem 1 arity) + diff (d/empty-diff (aget counts 1))] + (let [count-index (unchecked-add-int offset item) + item-diff @(aget processes item) + item-grow (:grow item-diff) + item-shrink (:shrink item-diff) + item-degree (:degree item-diff)] + (ensure-capacity freezers buffers item item-grow item-degree) + (let [^ints freezer (aget freezers item) + ^objects buffer (aget buffers item) + size-before (unchecked-subtract-int item-degree item-grow) + size-after (unchecked-subtract-int item-degree item-shrink)] + (aset counts count-index size-after) + (loop [i size-before] + (when (< i item-degree) + (aset buffer i buffer) + (recur (unchecked-inc-int i)))) + (let [[l r] (loop [l 1, r 1, i count-index] + (case i + 1 [l r] + (let [j (bit-shift-right i 1)] + (if (odd? i) + (let [x (aget counts (unchecked-dec-int i))] + (aset counts j (unchecked-multiply-int x (aget counts i))) + (recur (unchecked-multiply-int x l) r j)) + (let [x (aget counts (unchecked-inc-int i))] + (aset counts j (unchecked-multiply-int x (aget counts i))) + (recur l (unchecked-multiply-int x r) j)))))) + lr-size-after (aget counts 1) + foreign-degree (unchecked-multiply-int l r) + product-degree (unchecked-multiply-int item-degree foreign-degree) + product-cycles (into #{} + (mapcat + (fn [cycle] + (let [k (nth cycle 0) + x (aget buffer k) + f (frozen? freezer k) + l (reduce + (fn [k l] + (aset buffer k (aget buffer l)) + ((if (frozen? freezer l) + freeze! unfreeze!) + freezer k) l) + k (subvec cycle 1))] + (aset buffer l x) + ((if f freeze! unfreeze!) + freezer k)) + (->> cycle + (map (partial combine-indices product-degree item-degree r)) + (apply map vector)))) + (p/decompose (:permutation item-diff)))] + (loop [i size-after] + (when (< i item-degree) + (unfreeze! freezer i) + (aset buffer i nil) + (recur (unchecked-inc-int i)))) + (let [product-grow (unchecked-multiply-int item-grow foreign-degree) + product-permutation (compute-permutation l r item-grow item-degree item-shrink + (p/recompose product-cycles)) + product-shrink (unchecked-multiply-int item-shrink foreign-degree) + product-change (persistent! + (reduce-kv + (fn [m k v] + (let [^objects buffer (aget buffers item)] + (if (= (aget buffer k) (aset buffer k v)) + m (reduce (fn [m i] (assoc! m i nil)) + m (combine-indices lr-size-after size-after r k))))) + (transient {}) (:change item-diff))) + product-freeze (persistent! + (reduce + (fn [s k] + (freeze! (aget freezers item) k) + (reduce conj! s (combine-indices lr-size-after size-after r k))) + (transient #{}) (:freeze item-diff))) + diff (d/combine diff {:grow product-grow + :degree product-degree + :shrink product-shrink + :permutation product-permutation + :change product-change + :freeze product-freeze}) + item (aget ready pull)] + (if (== arity item) + (assoc diff + :change (persistent! + (reduce (fn [m i] + (loop [n i + j (alength buffers)] + (let [j (unchecked-dec-int j) + c (aget counts (unchecked-add-int offset j))] + (aset args j (aget ^objects (aget buffers j) (rem n c))) + (if (pos? j) + (recur (quot n c) j) + (assoc! m i (call f args)))))) + (transient {}) (keys (:change diff)))) + :freeze (persistent! + (reduce (fn [s i] + (loop [n i + j (alength freezers)] + (let [j (unchecked-dec-int j) + c (aget counts (unchecked-add-int offset j))] + (if (frozen? (aget freezers j) (rem n c)) + (if (pos? j) + (recur (quot n c) j) + (conj! s i)) s)))) + (transient #{}) (:freeze diff)))) + (do (aset ready pull arity) + (recur item (rem (unchecked-inc-int pull) arity) diff)))))))) + (catch #?(:clj Throwable :cljs :default) e + (aset state slot-notifier nil) + (cancel state) + (let [push (aget state slot-push)] + (loop [pull push] + (let [item (aget ready pull) + pull (rem (unchecked-inc-int pull) arity)] + (if (== item arity) + (when-not (== pull push) (recur pull)) + (flush-ready state item pull))))) + (throw e)) + (finally + (aset state slot-push nil) + (let [live (aget state slot-live)] + (unlock state) + (when (zero? live) + ((aget state slot-terminator)))))))) + +(defn terminated [^objects state] + (lock state) + (if (zero? (aset state slot-live (dec (aget state slot-live)))) + (if (nil? (aget state slot-push)) + (do (unlock state) + ((aget state slot-terminator))) + (unlock state)) (unlock state))) + +(defn input-ready [^objects state item] + (lock state) + (let [^objects processes (aget state slot-processes) + ^ints ready (aget state slot-ready) + arity (alength processes) + item (int item)] + (if-some [i (aget state slot-push)] + (do (aset state slot-push (identity (rem (unchecked-inc-int i) arity))) + (aset ready i item) + (unlock state)) + (do (aset state slot-push (identity (rem 1 arity))) + (if-some [cb (aget state slot-notifier)] + (do (aset ready 0 item) + (unlock state) + (cb)) + (do (flush-ready state item (rem 1 arity)) + (aset state slot-push nil) + (if (zero? (aget state slot-live)) + (do (unlock state) + ((aget state slot-terminator))) + (unlock state)))))))) + +(defn input-spawn [^objects state item flow] + (let [^objects freezers (aget state slot-freezers) + ^objects buffers (aget state slot-buffers) + ^objects processes (aget state slot-processes)] + (aset freezers item (int-array 1)) + (aset buffers item (object-array 1)) + (aset processes item + (flow #(input-ready state item) + #(terminated state)))) + state) + +(deftype Ps [state] + IFn + (#?(:clj invoke :cljs -invoke) [_] + (cancel state)) + IDeref + (#?(:clj deref :cljs -deref) [_] + (transfer state))) + +(defn flow [f & diffs] + (let [diffs (vec diffs)] + (fn [n t] + (let [state (object-array slots) + arity (count diffs) + ready (int-array arity)] + (dotimes [i arity] (aset ready i arity)) + #?(:clj (aset state slot-lock (ReentrantLock.))) + (aset state slot-notifier n) + (aset state slot-terminator t) + (aset state slot-combinator f) + (aset state slot-args (object-array arity)) + (aset state slot-buffers (object-array arity)) + (aset state slot-freezers (object-array arity)) + (aset state slot-processes (object-array arity)) + (aset state slot-ready ready) + (aset state slot-counts + (let [o (loop [o 1] + (if (< o arity) + (recur (bit-shift-left o 1)) o)) + n (bit-shift-left o 1) + arr (int-array n)] + (loop [f (unchecked-subtract o arity) + o o + n n] + (when (< 1 o) + (loop [i (unchecked-subtract n f)] + (when (< i n) + (aset arr i 1) + (recur (unchecked-inc i)))) + (recur (bit-shift-right f 1) + (bit-shift-right o 1) o))) arr)) + (aset state slot-live (identity arity)) + (reduce-kv input-spawn state diffs) + (->Ps state))))) \ No newline at end of file From 8ae7ca6a4f55288910f089f01a1d15841808e82e Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 30 Apr 2024 09:13:18 +0200 Subject: [PATCH 221/428] dom3 updates --- src/hyperfiddle/electric_dom3_efns.cljc | 38 +++++++++++++++++++++++++ 1 file changed, 38 insertions(+) diff --git a/src/hyperfiddle/electric_dom3_efns.cljc b/src/hyperfiddle/electric_dom3_efns.cljc index 7feaeea36..3818600db 100644 --- a/src/hyperfiddle/electric_dom3_efns.cljc +++ b/src/hyperfiddle/electric_dom3_efns.cljc @@ -327,3 +327,41 @@ ([typ f] `(event-log node ~typ ~f)) ([nd typ f] `(event-log ~nd ~typ ~f nil)) ([nd typ f opts] `(e/join (event-log* ~nd ~typ ~f ~opts)))) + + +;;;;;;;;;;;;;;;;;;;;;; +;;; NEXT ITERATION ;;; +;;;;;;;;;;;;;;;;;;;;;; + +#?(:cljs (defn listen* + ([node typ] (listen* node typ identity)) + ([node typ f] (listen* node typ f {})) + ([node typ f opts] + (m/observe (fn [!] + (let [! #(! (f %)), opts (clj->js opts)] + (.addEventListener node typ ! opts) + #(.removeEventListener node typ ! opts))))))) + +(defn uf->is [uf] + (m/ap (m/amb (i/empty-diff 0) + (let [!first (atom true) v (m/?> uf)] + (assoc (i/empty-diff 1) :grow (if @!first (do (swap! !first not) 1) 0), :change {0 v}))))) + +(comment + (def !! (atom nil)) + (def ps ((uf->is (m/observe (fn [!] (reset! !! !) #()))) #(prn :step) #(prn :done))) + (def v []) + (alter-var-root #'v i/patch-vec @ps) + (@!! 5) + ) + +(defn nop []) + +(defn event->task [flow] + (uf->is (m/ap + (let [!busy? (atom false) + v (m/?> (m/eduction (remove (fn [_] @!busy?)) flow)) + dfv (m/dfv), done! #(dfv false)] + (m/amb + [v done! (reset! !busy? true)] + [v done! (reset! !busy? (m/? dfv))]))))) From 282bb2585b64aa40bddf923560cc52a525497c81 Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 30 Apr 2024 09:13:24 +0200 Subject: [PATCH 222/428] try/catch in runtime_de --- src/hyperfiddle/electric/impl/runtime_de.cljc | 212 +++++++++--------- 1 file changed, 107 insertions(+), 105 deletions(-) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index cbea916cb..3b040b466 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -561,75 +561,76 @@ T T T -> (EXPR T) (let [^objects state (.-state peer) ^objects queues (.-queues peer) ^ints pushes (.-pushes peer)] - (loop [toggle #{} - change {} - freeze #{} - tap-pull 0 - untap-pull 0 - toggle-pull 0 - ready-pull 0] - (let [^objects tap-queue (aget queues peer-queue-tap) - ^objects untap-queue (aget queues peer-queue-untap) - ^objects toggle-queue (aget queues peer-queue-toggle) - ^objects ready-queue (aget queues peer-queue-ready)] - (if-some [^objects remote-port (aget tap-queue tap-pull)] - (do (aset tap-queue tap-pull nil) - (let [tap-pull (rem (unchecked-inc-int tap-pull) - (alength tap-queue)) - prev (aget remote-port port-slot-requested)] - (aset remote-port port-slot-requested (inc prev)) - (reduce-kv local-port-tap nil (port-deps remote-port)) - (recur (if (zero? (+ prev (aget remote-port port-slot-refcount))) - (conj toggle (port-slot remote-port)) toggle) change freeze - tap-pull untap-pull toggle-pull ready-pull))) - (if-some [^objects remote-port (aget untap-queue untap-pull)] - (do (aset untap-queue untap-pull nil) - (let [untap-pull (rem (unchecked-inc-int untap-pull) - (alength untap-queue)) - curr (dec (aget remote-port port-slot-requested))] - (aset remote-port port-slot-requested curr) - (reduce-kv local-port-untap nil (port-deps remote-port)) - (recur (if (zero? (+ curr (aget remote-port port-slot-refcount))) - (conj toggle (port-slot remote-port)) toggle) change freeze - tap-pull untap-pull toggle-pull ready-pull))) - (if-some [^objects local-port (aget toggle-queue toggle-pull)] - (do (aset toggle-queue toggle-pull nil) - (let [toggle-pull (rem (unchecked-inc-int toggle-pull) - (alength toggle-queue))] - (if (zero? (aget local-port port-slot-requested)) - (do (aset local-port port-slot-requested (identity 1)) - (reduce-kv remote-port-tap nil (port-deps local-port)) - (when (zero? (aget local-port port-slot-refcount)) - (enable local-port))) - (do (aset local-port port-slot-requested (identity 0)) - (reduce-kv remote-port-untap nil (port-deps local-port)) - (when (zero? (aget local-port port-slot-refcount)) - (disable local-port)))) - (recur toggle change freeze tap-pull untap-pull toggle-pull ready-pull))) - (if-some [^objects local-port (aget ready-queue ready-pull)] - (do (aset ready-queue ready-pull nil) - (let [ready-pull (rem (unchecked-inc-int ready-pull) - (alength ready-queue))] - (if-some [ps (port-process local-port)] - (if (aget local-port port-slot-state) - (recur toggle change (conj freeze (port-slot local-port)) - tap-pull untap-pull toggle-pull ready-pull) - (let [diff @ps - slot (port-slot local-port)] - (recur toggle (assoc change - slot (if-some [p (change slot)] - (i/combine p diff) diff)) - freeze tap-pull untap-pull toggle-pull ready-pull))) - (recur toggle change freeze tap-pull untap-pull toggle-pull ready-pull)))) - (let [acks (aget state peer-slot-output-acks)] - (aset state peer-slot-output-acks (identity 0)) - (aset state peer-slot-output-pending true) - (aset pushes peer-queue-tap 0) - (aset pushes peer-queue-untap 0) - (aset pushes peer-queue-toggle 0) - (aset pushes peer-queue-ready 0) - (encode [acks toggle change freeze] - (aget state peer-slot-writer-opts))))))))))) + (try (loop [toggle #{} + change {} + freeze #{} + tap-pull 0 + untap-pull 0 + toggle-pull 0 + ready-pull 0] + (let [^objects tap-queue (aget queues peer-queue-tap) + ^objects untap-queue (aget queues peer-queue-untap) + ^objects toggle-queue (aget queues peer-queue-toggle) + ^objects ready-queue (aget queues peer-queue-ready)] + (if-some [^objects remote-port (aget tap-queue tap-pull)] + (do (aset tap-queue tap-pull nil) + (let [tap-pull (rem (unchecked-inc-int tap-pull) + (alength tap-queue)) + prev (aget remote-port port-slot-requested)] + (aset remote-port port-slot-requested (inc prev)) + (reduce-kv local-port-tap nil (port-deps remote-port)) + (recur (if (zero? (+ prev (aget remote-port port-slot-refcount))) + (conj toggle (port-slot remote-port)) toggle) change freeze + tap-pull untap-pull toggle-pull ready-pull))) + (if-some [^objects remote-port (aget untap-queue untap-pull)] + (do (aset untap-queue untap-pull nil) + (let [untap-pull (rem (unchecked-inc-int untap-pull) + (alength untap-queue)) + curr (dec (aget remote-port port-slot-requested))] + (aset remote-port port-slot-requested curr) + (reduce-kv local-port-untap nil (port-deps remote-port)) + (recur (if (zero? (+ curr (aget remote-port port-slot-refcount))) + (conj toggle (port-slot remote-port)) toggle) change freeze + tap-pull untap-pull toggle-pull ready-pull))) + (if-some [^objects local-port (aget toggle-queue toggle-pull)] + (do (aset toggle-queue toggle-pull nil) + (let [toggle-pull (rem (unchecked-inc-int toggle-pull) + (alength toggle-queue))] + (if (zero? (aget local-port port-slot-requested)) + (do (aset local-port port-slot-requested (identity 1)) + (reduce-kv remote-port-tap nil (port-deps local-port)) + (when (zero? (aget local-port port-slot-refcount)) + (enable local-port))) + (do (aset local-port port-slot-requested (identity 0)) + (reduce-kv remote-port-untap nil (port-deps local-port)) + (when (zero? (aget local-port port-slot-refcount)) + (disable local-port)))) + (recur toggle change freeze tap-pull untap-pull toggle-pull ready-pull))) + (if-some [^objects local-port (aget ready-queue ready-pull)] + (do (aset ready-queue ready-pull nil) + (let [ready-pull (rem (unchecked-inc-int ready-pull) + (alength ready-queue))] + (if-some [ps (port-process local-port)] + (if (aget local-port port-slot-state) + (recur toggle change (conj freeze (port-slot local-port)) + tap-pull untap-pull toggle-pull ready-pull) + (let [diff @ps + slot (port-slot local-port)] + (recur toggle (assoc change + slot (if-some [p (change slot)] + (i/combine p diff) diff)) + freeze tap-pull untap-pull toggle-pull ready-pull))) + (recur toggle change freeze tap-pull untap-pull toggle-pull ready-pull)))) + (let [acks (aget state peer-slot-output-acks)] + (aset state peer-slot-output-acks (identity 0)) + (aset state peer-slot-output-pending true) + (aset pushes peer-queue-tap 0) + (aset pushes peer-queue-untap 0) + (aset pushes peer-queue-toggle 0) + (aset pushes peer-queue-ready 0) + (encode [acks toggle change freeze] + (aget state peer-slot-writer-opts))))))))) + (catch #?(:clj Throwable :cljs :default) e (pst e) (throw e))))) (defn frame-shared? [^Frame frame] (if-some [^Slot slot (.-slot frame)] @@ -774,41 +775,42 @@ T T T -> (EXPR T) (def call-slots 2) (defn call-transfer [^objects state {:keys [grow degree shrink permutation change freeze]}] - (let [^Slot slot (aget state call-slot-slot) - ^Frame parent (.-frame slot) - ^Peer peer (.-peer parent) - id (.-id slot) - ^ints ranks (.-ranks parent) - site (port-site (slot-port slot)) - size-after (- degree shrink) - ^objects buffer (let [^objects buffer (aget state call-slot-buffer) - cap (alength buffer)] - (if (< degree cap) - buffer (let [b (object-array (loop [cap cap] - (let [cap (bit-shift-left cap 1)] - (if (< degree cap) - cap (recur cap)))))] - #?(:clj (System/arraycopy buffer 0 b 0 cap) - :cljs (dotimes [i cap] (aset b i (aget buffer i)))) - (aset state call-slot-buffer b))))] - (reduce apply-cycle buffer (i/decompose permutation)) - (dotimes [i shrink] - (let [j (+ size-after i)] - (frame-down (aget buffer j)) - (aset buffer j nil))) - {:grow grow - :degree degree - :shrink shrink - :permutation permutation - :freeze freeze - :change (reduce-kv (fn [change i ctor] - (when-some [frame (aget buffer i)] (frame-down frame)) - (let [rank (aget ranks id) - frame (make-frame peer slot rank site ctor)] - (aset buffer i frame) - (aset ranks id (inc rank)) - (assoc change i (frame-up frame)))) - {} change)})) + (try (let [^Slot slot (aget state call-slot-slot) + ^Frame parent (.-frame slot) + ^Peer peer (.-peer parent) + id (.-id slot) + ^ints ranks (.-ranks parent) + site (port-site (slot-port slot)) + size-after (- degree shrink) + ^objects buffer (let [^objects buffer (aget state call-slot-buffer) + cap (alength buffer)] + (if (< degree cap) + buffer (let [b (object-array (loop [cap cap] + (let [cap (bit-shift-left cap 1)] + (if (< degree cap) + cap (recur cap)))))] + #?(:clj (System/arraycopy buffer 0 b 0 cap) + :cljs (dotimes [i cap] (aset b i (aget buffer i)))) + (aset state call-slot-buffer b))))] + (reduce apply-cycle buffer (i/decompose permutation)) + (dotimes [i shrink] + (let [j (+ size-after i)] + (frame-down (aget buffer j)) + (aset buffer j nil))) + {:grow grow + :degree degree + :shrink shrink + :permutation permutation + :freeze freeze + :change (reduce-kv (fn [change i ctor] + (when-some [frame (aget buffer i)] (frame-down frame)) + (let [rank (aget ranks id) + frame (make-frame peer slot rank site ctor)] + (aset buffer i frame) + (aset ranks id (inc rank)) + (assoc change i (frame-up frame)))) + {} change)}) + (catch #?(:clj Throwable :cljs :default) e (pst e) (throw e)))) (deftype Call [expr slot] Expr @@ -900,7 +902,7 @@ Returns a peer definition from given definitions and main key. (fn [^Unbound unbound] [(.-key unbound)]))} default (t/write-handler - (fn [_] "unserializable") + (fn [v] (prn :unserializable v) "unserializable") (fn [_]))] (aset state peer-slot-writer-opts #?(:clj {:handlers handlers :default-handler default} From 1abc6a0e85ec18162bfac747e8e0686c5d21a2a3 Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 30 Apr 2024 09:43:54 +0200 Subject: [PATCH 223/428] bug repro --- src/hyperfiddle/electric_dom3_efns.cljc | 2 -- test/hyperfiddle/electric_de_test.cljc | 30 +++++++++++++++++++++++++ 2 files changed, 30 insertions(+), 2 deletions(-) diff --git a/src/hyperfiddle/electric_dom3_efns.cljc b/src/hyperfiddle/electric_dom3_efns.cljc index 3818600db..986f123ad 100644 --- a/src/hyperfiddle/electric_dom3_efns.cljc +++ b/src/hyperfiddle/electric_dom3_efns.cljc @@ -355,8 +355,6 @@ (@!! 5) ) -(defn nop []) - (defn event->task [flow] (uf->is (m/ap (let [!busy? (atom false) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index eedd239f5..18afd6afb 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -5,6 +5,7 @@ [hyperfiddle.electric.impl.io :as electric-io] [hyperfiddle.electric.impl.lang-de2 :as lang] [hyperfiddle.electric.impl.runtime-de :as r] + [hyperfiddle.incseq :as i] [contrib.cljs-target :refer [do-browser]] #?(:cljs [hyperfiddle.goog-calls-test-de]) #?(:cljs [hyperfiddle.js-calls-test-de]) @@ -2188,3 +2189,32 @@ (hash-set % %) := #{0 1} (swap! !offset inc) % := 2)) + +(defn payT [_] (m/sp (m/? (m/sleep 10)) (rand-int 1000))) +(defn task->incseq [T] (m/ap (m/amb (i/empty-diff 0) (assoc (i/empty-diff 1) :grow 1, :change {0 (m/? T)})))) + +(defn uf->is [uf] + (m/ap (m/amb (i/empty-diff 0) + (let [!first (atom true) v (m/?> uf)] + (assoc (i/empty-diff 1) :grow (if @!first (do (swap! !first not) 1) 0), :change {0 v}))))) + +(defn event->task [flow] + (uf->is (m/ap + (let [!busy? (atom false) + v (m/?> (m/eduction (remove (fn [_] @!busy?)) flow)) + dfv (m/dfv), done! #(dfv false)] + (m/amb + [v done! (reset! !busy? true)] + [v done! (reset! !busy? (m/? dfv))]))))) + + +(def !c (atom nil)) +(tests + (with ((l/local {} + (let [[v done!] (e/join (event->task (m/observe (fn [!] (reset! !c !) #()))))] + (case (e/server (e/join (task->incseq (payT v)))) + (tap (done!))))) tap tap) + (@!c 1) + % := false + (@!c 2) + % := false)) From 51a99d60bcdbe1118cf47966bdf14f7a77faddb2 Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 30 Apr 2024 17:01:00 +0200 Subject: [PATCH 224/428] scratch --- scratch/peter/y2024/dom3_use_cases.cljc | 161 ++++++++++++++++++++++++ 1 file changed, 161 insertions(+) create mode 100644 scratch/peter/y2024/dom3_use_cases.cljc diff --git a/scratch/peter/y2024/dom3_use_cases.cljc b/scratch/peter/y2024/dom3_use_cases.cljc new file mode 100644 index 000000000..6bf3e5dc1 --- /dev/null +++ b/scratch/peter/y2024/dom3_use_cases.cljc @@ -0,0 +1,161 @@ +(ns peter.y2024.dom3-use-cases + (:require + [missionary.core :as m] + [hyperfiddle.electric-de :as e :refer [$]] + [hyperfiddle.electric-dom3-efns :as dom] + [hyperfiddle.incseq :as i])) + +;;;;;;;;;;;;;;;;;; +;;; PAY BUTTON ;;; +;;;;;;;;;;;;;;;;;; + +(defn ->state [events] + (m/ap (let [!state (atom [::idle]) + [state v] (m/?> (m/watch !state)) + e (m/?> events)] + )) + (->> (m/ap + (let [!take? (atom true), done! #(reset! !take? true), e (m/?> events)] + (if @!take? + (do (reset! !take? false) [e done!]) + (m/amb)))) + (m/reductions {} nil))) + +(defn listen> [node typ] + (m/observe (fn [!] (.addEventListener node typ !) #(.removeEventListener node typ !)))) + +(let [[state v !state] (events->state 'node "click")] + (case state + ::idle (dom/style {:background-color "gray"}) + ::busy (do (dom/props {:aria-busy true}) (if-let [v ($ ProcessPayment)] (!state ::failed v) (!state ::success))) + ::success (do (dom/style {:background-color "green"}) (after 5000 (!state ::idle))) + ::failed (do (dom/style {:background-color "red"}) ($ ShowError v)))) + + + + +(dom/style {:background-color + (if-some [done! (tx-events "click")] + (case ($ SuccessMonitor ($ Transact)) + ::success (do (done!) "green") + ::failure (do (done!) "red") + nil "yellow") + "gray")}) + +(dom/style {:background-color + (let [[_foo done! busy?] (tx-events "click" (fn [e] (.stopPropagation e) "foo"))] + (case ($ CheckResult ($ Transact conn {:foo :bar}) busy?) + ::success (do (done!) "green") + ::failure (do (done!) "red") + #_else (if busy? "yellow" "purple")))}) + +(dom/style {:background-color + (let [[_foo done! busy?] (tx-events "click" (fn [e] (.stopPropagation e) "foo")) + true? (fetch db user :checkbox)] + (case ($ CheckResult ($ Transact conn {:checked (not true?)}) busy?) + ::success (do (done!) "green") + ::failure (do (done!) "red") + #_else (if busy? "yellow" "purple")))}) + +#?(:cljs (defn listen* [node typ f opts] + (m/observe (fn [!] + (let [! #(! (f %)), opts (clj->js opts)] + (.addEventListener node typ ! opts) + #(.removeEventListener node typ ! opts)))))) + +(defn event->task [flow] + (->> (m/ap + (let [!busy? (atom false) + v (m/?> (m/eduction (remove (fn [_] @!busy?)) flow)) + dfv (m/dfv)] + (m/amb [v #(dfv false) (reset! !busy? true)] [v #() (reset! !busy? (m/? dfv))]))) + (m/reductions {} [nil #() false]))) + +(comment + (def !! (atom nil)) + (def ps ((event->task (m/observe (fn [!] (reset! !! !) #()))) #(prn :step) #(prn :done))) + @ps + (@!! 5) + (def d @ps) + d + ((second d)) + (ps) + ) + +(dom/on "click" (e/fn [e] + (let [true? (fetch db user :checkbox)] + (Transact conn {:checked (not true?)})))) + +(hf-ui/button) + +(dom/button + (let [[v busy? done!] (tx-events "keydown" (fn [e] (when (= "Enter" (.-key e)) (-> e .-target .-value))))] + (when ($ Transact {}) (done!)) + ) + ) + +(dom/style {:background-color + (or (tx-events "click" + (e/fn [busy?] + (when busy? (dom/props {:disabled true})) + (case ($ SuccessMonitor ($ Transact) busy?) + ::success "green" + ::failure "red" + #_else nil))) + "purple")}) + +(if-some [busy! (tx-events "click")] + (case ($ SuccessMonitor ($ Transact)) + ::success "green" + ::failure "red" + nil "yellow") + "gray") + + +;;;;;;;;;;;;;;;;;;;;;;;;; +;;; OPTIMISTIC UPDATE ;;; +;;;;;;;;;;;;;;;;;;;;;;;;; + +;; [ buy milk... ] <- input +;; +;; [ ] go to store <- open task +;; [X] call car shop <- completed task +;; +;; - tasks are stored on server +;; - we want to render new tasks as user enters them +;; - user is decopuled from server/network, i.e. can enter N tasks concurrently +;; - tasks have to render immediately +;; - as server acks/rejects them they should update + +;; impl +;; - project server values into local spine +;; - CRUD updates go to local spine + +(defn pop-value [nd] (let [v (.-value nd)] (set! (.-value nd) "") v)) +(defn enter [e] (when (= "Enter" (.-key e)) (pop-value (.-target e)))) +(defn add-task! [S e] + (when-some [v (enter e)] + (let [id (random-uuid)] + (S id {} {:db/id id, :task/description v, ::state ::local})))) + +;; fill client spine with data from server query +(let [S ($ Project (i/spine) (e/server #(query-tasks db)))] + (dom/input + ;; optimistically add local items to the spine + (e/join (dom/uf->is (dom/listen* dom/node "keydown" (partial add-task! S))))) + (dom/ul + (e/cursor [t (e/join S)] + (dom/li + (dom/text (:task/description t)) + (dom/props {:border-color + (case (::state t) + ;; transact local items + ;; hoist transaction up to survive page navigating away + ::local (do ($ Transact S t) "blue") + ::ok "green" + ::failed "red")}) + ;; mount retry button when task failed to transact + (when (= ::failed (::state t)) + (dom/button (dom/text "Retry") + (let [[v done! busy?] (e/join (dom/event->task (dom/listen* dom/node "click" identity)))] + (when ($ Transact S t) (done!))))))))) From 9a183bb921dc1e95750cd208ddba37e4418f8cfd Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 2 May 2024 12:54:10 +0200 Subject: [PATCH 225/428] fixes for latest clojure version --- deps.edn | 2 +- src/hyperfiddle/electric/impl/expand.clj | 27 ++++++++- src/hyperfiddle/electric/impl/lang_de2.clj | 11 +++- .../electric/impl/expand_test.cljc | 8 +++ test/hyperfiddle/electric_de_test.cljc | 58 ++++++++++--------- 5 files changed, 75 insertions(+), 31 deletions(-) diff --git a/deps.edn b/deps.edn index 32ff3b4a1..9d64bc3b5 100644 --- a/deps.edn +++ b/deps.edn @@ -5,7 +5,7 @@ missionary/missionary {:mvn/version "b.35"} dom-top/dom-top {:mvn/version "1.0.9"} fipp/fipp {:mvn/version "0.6.26"} - org.clojure/clojure {:mvn/version "1.12.0-alpha5"} + org.clojure/clojure {:mvn/version "1.12.0-alpha11"} org.clojure/clojurescript {:mvn/version "1.11.121"} org.clojure/tools.analyzer.jvm {:mvn/version "1.2.3"} ;; used by Electric org.clojure/tools.logging {:mvn/version "1.2.4"} diff --git a/src/hyperfiddle/electric/impl/expand.clj b/src/hyperfiddle/electric/impl/expand.clj index 42cddaa3a..182d54d2c 100644 --- a/src/hyperfiddle/electric/impl/expand.clj +++ b/src/hyperfiddle/electric/impl/expand.clj @@ -37,7 +37,32 @@ (try (#'clojure.core/serialized-require sym) ; try bc it can be cljs file (catch java.io.FileNotFoundException _)))) -(defn macroexpand-clj [o] (serialized-require (ns-name *ns*)) (macroexpand-1 o)) +(defn ?expand-clj-method-call [o] + (let [[s & args] o] + (if (clojure.lang.Compiler/namesStaticMember s) + (let [?class (-> s namespace symbol)] + (if (clojure.lang.Compiler$HostExpr/maybeClass ?class false) + (list* '. ?class (-> s name symbol) args) + o)) + o))) + +(defn macroexpand-clj [o] + (serialized-require (ns-name *ns*)) + (let [o2 (macroexpand-1 o)] + (if (identical? o o2) + (?expand-clj-method-call o) + o2))) + +;; - else if(namesStaticMember(sym)) +;; - { +;; - Symbol target = Symbol.intern(sym.ns); +;; - Class c = HostExpr.maybeClass(target, false); +;; - if(c != null) +;; - { +;; - Symbol meth = Symbol.intern(sym.name); +;; - return preserveTag(form, RT.listStar(DOT, target, meth, form.next())); +;; - } +;; - } (defn expand-referred-or-local-macros [o cljs-macro-env] ;; (:require [some.ns :refer [some-macro]]) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 2f27f8ebe..8476eda1a 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -56,11 +56,20 @@ (declare -expand-all-in-try) +(defn ?expand-clj-method-call [o] + (let [[s & args] o] + (if (clojure.lang.Compiler/namesStaticMember s) + (let [?class (-> s namespace symbol)] + (if (clojure.lang.Compiler$HostExpr/maybeClass ?class false) + (list* '. ?class (-> s name symbol) args) + o)) + o))) + (defn macroexpand-clj [o env] (serialized-require (ns-name *ns*)) (if-some [mac (when-some [mac (resolve env (first o))] (when (.isMacro ^clojure.lang.Var mac) mac))] (apply mac o env (next o)) - (try (macroexpand-1 o) ; e.g. (Math/abs 1) will expand to (. Math abs 1) + (try (?expand-clj-method-call o) (catch ClassNotFoundException _ o)))) ; e.g. (goog.color/hslToHex ..) won't expand on clj (def !a (cljs-ana/->!a)) diff --git a/test/hyperfiddle/electric/impl/expand_test.cljc b/test/hyperfiddle/electric/impl/expand_test.cljc index 32c821de0..f119e1720 100644 --- a/test/hyperfiddle/electric/impl/expand_test.cljc +++ b/test/hyperfiddle/electric/impl/expand_test.cljc @@ -151,3 +151,11 @@ :ns 'hyperfiddle.electric.impl.expand-unloaded} '(let [x 1])))) (throw (ex-info "clj macroexpansion for unloaded ns fails" {})))) + +#?(:clj + (tests + "clojure 1.12 macroexpansion regression on class/method calls" + (all '(clojure.lang.PersistentArrayMap/createAsIfByAssoc nil)) := '(. clojure.lang.PersistentArrayMap createAsIfByAssoc nil) + + +)) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 18afd6afb..bf240ffa2 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -2190,31 +2190,33 @@ (swap! !offset inc) % := 2)) -(defn payT [_] (m/sp (m/? (m/sleep 10)) (rand-int 1000))) -(defn task->incseq [T] (m/ap (m/amb (i/empty-diff 0) (assoc (i/empty-diff 1) :grow 1, :change {0 (m/? T)})))) - -(defn uf->is [uf] - (m/ap (m/amb (i/empty-diff 0) - (let [!first (atom true) v (m/?> uf)] - (assoc (i/empty-diff 1) :grow (if @!first (do (swap! !first not) 1) 0), :change {0 v}))))) - -(defn event->task [flow] - (uf->is (m/ap - (let [!busy? (atom false) - v (m/?> (m/eduction (remove (fn [_] @!busy?)) flow)) - dfv (m/dfv), done! #(dfv false)] - (m/amb - [v done! (reset! !busy? true)] - [v done! (reset! !busy? (m/? dfv))]))))) - - -(def !c (atom nil)) -(tests - (with ((l/local {} - (let [[v done!] (e/join (event->task (m/observe (fn [!] (reset! !c !) #()))))] - (case (e/server (e/join (task->incseq (payT v)))) - (tap (done!))))) tap tap) - (@!c 1) - % := false - (@!c 2) - % := false)) +(comment + (defn payT [_] (m/sp (m/? (m/sleep 10)) (rand-int 1000))) + (defn task->incseq [T] (m/ap (m/amb (i/empty-diff 0) (assoc (i/empty-diff 1) :grow 1, :change {0 (m/? T)})))) + + (defn uf->is [uf] + (m/ap (m/amb (i/empty-diff 0) + (let [!first (atom true) v (m/?> uf)] + (assoc (i/empty-diff 1) :grow (if @!first (do (swap! !first not) 1) 0), :change {0 v}))))) + + (defn event->task [flow] + (uf->is (m/ap + (let [!busy? (atom false) + v (m/?> (m/eduction (remove (fn [_] @!busy?)) flow)) + dfv (m/dfv), done! #(dfv false)] + (m/amb + [v done! (reset! !busy? true)] + [v done! (reset! !busy? (m/? dfv))]))))) + + + (def !c (atom nil)) + (tests + (with ((l/local {} + (let [[v done!] (e/join (event->task (m/observe (fn [!] (reset! !c !) #()))))] + (case (e/server (e/join (task->incseq (payT v)))) + (tap (done!))))) tap tap) + (@!c 1) + % := false + (@!c 2) + % := false)) + ) From 944984c862779a5859964818978e19da2b4771e8 Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 2 May 2024 17:14:51 +0200 Subject: [PATCH 226/428] shadow: more resilient and correct shadow hook The previous implementation from v2 runs after compiling the cljs files, since that's the only point in the shadow hooks where the list of recompiled files is available. This is problematic though. Imagine adding #?(:clj (def foo 1)) and using it in an `e/server` block. Since the cljs compiler runs first the namespace may not be reloaded on clj and the compiler will fail, throwing an exception. The new implementation monkey-patches the shadow compiler in order to recompile on clj first, fixing the use case above. --- .../electric/shadow_cljs/hooks_de.clj | 42 ++++++++++--------- 1 file changed, 22 insertions(+), 20 deletions(-) diff --git a/src/hyperfiddle/electric/shadow_cljs/hooks_de.clj b/src/hyperfiddle/electric/shadow_cljs/hooks_de.clj index 8f09972f3..dca4741cc 100644 --- a/src/hyperfiddle/electric/shadow_cljs/hooks_de.clj +++ b/src/hyperfiddle/electric/shadow_cljs/hooks_de.clj @@ -1,24 +1,26 @@ (ns hyperfiddle.electric.shadow-cljs.hooks-de - (:require [clojure.string :as str] + (:require [shadow.build.compiler] [hyperfiddle.electric.impl.lang-de2 :as lang] [hyperfiddle.electric.impl.cljs-analyzer2 :as cljs-ana])) -(let [!first-run? (volatile! true)] ; first run is noop - (defn reload-clj - "When any Electric def is changed, recompile it in both Clojure and ClojureScript -(because the expression may contain e/client and/or e/server). Takes care to prevent -double reloads (i.e. from :require-macros)." - {:shadow.build/stage :compile-finish} [build-state] - (prn ::reload-hook) - (if @!first-run? - (vreset! !first-run? false) - (when (= :dev (:shadow.build/mode build-state)) - (let [compiled-keys (-> build-state :shadow.build/build-info :compiled) - cljc-infos (eduction (filter (fn [[_ f]] (str/ends-with? f ".cljc"))) - (map #(get (:sources build-state) %)) compiled-keys)] - (doseq [{ns-sym :ns, macro-requires :macro-requires} cljc-infos] - (when (and (not (get macro-requires ns-sym)) (-> ns-sym find-ns meta ::lang/has-edef?)) - (prn ::reloading ns-sym) - (swap! lang/!a cljs-ana/purge-ns ns-sym) - (require ns-sym :reload)))))) - build-state)) +;; Shadow-cljs doesn't expose a way to act before compiling a cljs file. +;; It filters resources in a series of functions, calling `do-compile-cljs-resource` in the end. +;; So we wrap this final step and alter the var. +(defonce original-do-compile-cljs-resource shadow.build.compiler/do-compile-cljs-resource) +(def !built-this-cycle (atom #{})) ; build once per cycle +(defonce first-compile? true) ; on first compile we don't need to recompile +(defn wrapped-do-compile-cljs-resource [state {ns$ :ns :as rc} source] + (swap! lang/!a cljs-ana/purge-ns ns$) + (when (and (not (@!built-this-cycle ns$)) (some-> (find-ns ns$) meta ::lang/has-edef?)) + (prn ::recompile-clj ns$) + (require ns$ :reload)) + (original-do-compile-cljs-resource state rc source)) + +(defn reload-clj "On `e/defn` change, recompile Clojure namespace (because the expression + may contain e/client and/or e/server). Prevents double-reloads (e.g. from :require-macros)." + {:shadow.build/stage :compile-finish} [build-state] + (when first-compile? + (alter-var-root #'first-compile? not) + (alter-var-root #'shadow.build.compiler/do-compile-cljs-resource (constantly #'wrapped-do-compile-cljs-resource))) + (reset! !built-this-cycle #{}) + build-state) From 831d1e6c5a2eb998739e8de59fc627693253f289 Mon Sep 17 00:00:00 2001 From: xificurC Date: Fri, 10 May 2024 17:39:19 +0200 Subject: [PATCH 227/428] contrib.debug/instrument* catches transfer exceptions --- src/contrib/debug.cljc | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/contrib/debug.cljc b/src/contrib/debug.cljc index 7869e1421..e33eb36a9 100644 --- a/src/contrib/debug.cljc +++ b/src/contrib/debug.cljc @@ -49,11 +49,13 @@ (reify IFn (#?(:clj invoke :cljs -invoke) [_] (prn nm id :cancelled) (it)) IDeref (#?(:clj deref :cljs -deref) [_] - (let [v @it] + (let [v (try @it (catch #?(:clj Throwable :cljs :default) e [::ex e]))] (prn nm id :transferred (if (instance? Failure v) (let [e (.-error v)] [(type e) (ex-message e)]) v)) - v)))))) + (if (and (vector? v) (= ::ex (first v))) + (throw (second v)) + v))))))) (defmacro instrument [nm & body] `(new (instrument* ~nm (hyperfiddle.electric/fn [] ~@body)))) From 77d9e4f54f91429031a6543a32c4d768b0fc87e3 Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 14 May 2024 10:13:30 +0200 Subject: [PATCH 228/428] compiler: improves gensym names in codegen --- src/hyperfiddle/electric/impl/lang_de2.clj | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 8476eda1a..f0b92a960 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -519,7 +519,8 @@ (let*) (let [[_ bs bform] form] (recur (?meta form (reduce (fn [ac [k v]] - `(::mklocal k# (::bindlocal k# ~v (::mklocal ~k (::bindlocal ~k k# ~ac))))) + (let [g (gensym k)] + `(::mklocal ~g (::bindlocal ~g ~v (::mklocal ~k (::bindlocal ~k ~g ~ac)))))) bform (->> bs (partition 2) reverse))) pe env ts)) (::mklocal) (let [[_ k bform] form, e (->id), uid (->uid) @@ -631,7 +632,8 @@ ;; Due to an early bad assumption only locals are considered for runtime nodes. ;; Since any site change can result in a new node we wrap these sites in an implicit local. ;; Electric aggressively inlines locals, so the generated code size will stay the same. - (recur `(::mklocal k# (::bindlocal k# ~form k#)) pe env2 ts))) + (let [g (gensym "site-local")] + (recur `(::mklocal ~g (::bindlocal ~g ~form ~g)) pe env2 ts)))) (::frame) (ts/add ts {:db/id (->id), ::parent pe, ::type ::frame}) (::lookup) (let [[_ sym] form] (ts/add ts {:db/id (->id), ::parent pe, ::type ::lookup, ::sym sym})) (::static-vars) (recur (second form) pe (assoc env ::static-vars true) ts) From 2eb09745ec81c194b51a24041155fc586d0c2eee Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 14 May 2024 10:15:31 +0200 Subject: [PATCH 229/428] compiler: fixes locals site resolution --- src/hyperfiddle/electric/impl/lang_de2.clj | 12 ++++++++++-- test/hyperfiddle/electric/impl/compiler_test.cljc | 14 ++++++++++---- 2 files changed, 20 insertions(+), 6 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index f0b92a960..4af37db04 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -459,6 +459,15 @@ ::site (::site nd) #_else (recur (::parent nd)))))) +(defn get-local-site [ts localv-e] + (let [ret-e (get-ret-e ts localv-e)] + (loop [e ret-e] + (let [nd (ts/->node ts e)] + (case (::type nd) + (::localref) (get-local-site ts (->localv-e ts (::ref nd))) + (::site) (::site nd) + #_else (recur (::parent nd))))))) + (defn get-lookup-key [sym env] (if (symbol? sym) (let [it (resolve-symbol sym env)] @@ -1004,8 +1013,7 @@ (cond-> (ts/upd ts mklocal-e ::used-refs #(conj (or % #{}) (::uid nd))) (or (= 1 (count (::used-refs mklocal-nd))) ; before inc, now it's 2 (when-some [pt-e (find-sitable-point-e ts e)] - (not= (get-site ts pt-e) - (get-site ts (get-ret-e ts localv-e))))) + (not= (get-site ts pt-e) (get-local-site ts localv-e)))) (ensure-node mklocal-uid)))] (or (and (@seen mklocal-uid) ts) (do (vswap! seen conj mklocal-uid) diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index dff603b11..ecb79b89b 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -114,7 +114,13 @@ (fn [~'frame] (r/define-node ~'frame 0 (r/pure 2)) (r/pure (r/incseq ~'frame (r/node ~'frame 0)))))]) - ) + + (match (l/test-compile ::Main (let [x (e/server (identity 1))] (inc x))) + `[(r/cdef 0 [:server] [] nil + (fn [~'frame] + (r/define-node ~'frame 0 (r/ap (r/lookup ~'frame :clojure.core/identity (r/pure identity)) (r/pure 1))) + (r/ap (r/lookup ~'frame :clojure.core/inc (r/pure inc)) + (r/node ~'frame 0))))])) (tests "test-let" (match (l/test-compile ::Main (::lang/site :client (let [a :foo] [a a]))) @@ -156,10 +162,10 @@ (r/pure (clojure.core/vector "Hello" "world"))))]) (match (l/test-compile ::Main (e/client (let [a (e/server :foo)] (e/server (prn a))))) - `[(r/cdef 0 [:server] [] :server + `[(r/cdef 0 [] [] :server (fn [~'frame] - (r/define-node ~'frame 0 (r/pure :foo)) - (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure prn)) (r/node ~'frame 0))))]) + (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure prn)) + (r/pure :foo))))]) (match (l/test-compile ::Main (concat (let [x 1] [x x]) (let [y 2] [y y]))) `[(r/cdef 0 [nil nil] [] nil From d352f11fc517d1d9328c6509ae322e8aa8ba879c Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 14 May 2024 10:15:52 +0200 Subject: [PATCH 230/428] electric: fixes `e/amb` by propagating siting This worked `(do (e/server (d/pull db x)))` This didn't `(do (e/server (d/pull db x)) nil)` `(do a b)` expands to `(e/amb (e/drain a) b)`. `e/amb` wraps a and b into ctors. Ctors clear siting. This fix propagates the site into the ctors. --- src/hyperfiddle/electric_de.cljc | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index acfd249ce..ab0c41c8a 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -22,6 +22,7 @@ (throw (ex-info (str "Electric code (" fn ") inside a Clojure function") (into {:electric-fn fn} (meta &form)))))) (defmacro ctor [expr] `(::lang/ctor ~expr)) +(defmacro sited-ctor [expr] `(::lang/ctor (::lang/site ~(::lang/current &env) ~expr))) (defmacro $ [F & args] `(check-electric $ (lang/$ ~F ~@args))) (defmacro frame [] @@ -107,7 +108,7 @@ Syntax : (amb table1 table2 ,,, tableN) ``` Returns the concatenation of `table1 table2 ,,, tableN`. -" [& exprs] `(::lang/call (join (i/fixed ~@(map #(list `r/invariant (list `ctor %)) exprs))))) +" [& exprs] `(::lang/call (join (i/fixed ~@(map #(list `r/invariant (list `sited-ctor %)) exprs))))) (defmacro input " Syntax : From 54b8cf25bcfc4ece13a0181279a2e9152b43ce79 Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 15 May 2024 11:06:50 +0200 Subject: [PATCH 231/428] more dom3 event handling experiments --- src/hyperfiddle/electric_dom3_efns.cljc | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/src/hyperfiddle/electric_dom3_efns.cljc b/src/hyperfiddle/electric_dom3_efns.cljc index 986f123ad..f414160ba 100644 --- a/src/hyperfiddle/electric_dom3_efns.cljc +++ b/src/hyperfiddle/electric_dom3_efns.cljc @@ -303,7 +303,7 @@ (let [! (comp ! f) , opts (clj->js opts)] (.addEventListener nd typ ! opts)) #(.removeEventListener nd typ ! opts))))) -(defmacro listen +(defmacro listen2 ([typ] `(listen ~typ identity)) ([typ f] `(listen node ~typ ~f)) ([nd typ f] `(listen ~nd ~typ ~f nil)) @@ -342,6 +342,16 @@ (.addEventListener node typ ! opts) #(.removeEventListener node typ ! opts))))))) +#?(:cljs (defn listen*-some + ([node typ] (listen*-some node typ identity)) + ([node typ f] (listen*-some node typ f {})) + ([node typ f opts] + (m/observe (fn [!] + (let [! #(some-> (f %) !), opts (clj->js opts)] + (.addEventListener node typ ! opts) + #(.removeEventListener node typ ! opts)))) + #_(m/eduction (filter some?) (listen* node typ f opts))))) + (defn uf->is [uf] (m/ap (m/amb (i/empty-diff 0) (let [!first (atom true) v (m/?> uf)] @@ -363,3 +373,12 @@ (m/amb [v done! (reset! !busy? true)] [v done! (reset! !busy? (m/? dfv))]))))) + +(defn event->tasks [flow] + (uf->is + (m/ap + (let [S (i/spine)] + (m/amb S + (let [v (m/?> flow), id (random-uuid)] + (S id {} [v #(S id {} nil)]) + (m/amb))))))) From 99a57b2a79cc5751ca2b77a469157283b0367bd9 Mon Sep 17 00:00:00 2001 From: xificurC Date: Tue, 21 May 2024 09:20:12 +0200 Subject: [PATCH 232/428] dom3: next event handler iteration --- src/hyperfiddle/electric_dom3_efns.cljc | 59 +++++++++++++++++++++---- 1 file changed, 51 insertions(+), 8 deletions(-) diff --git a/src/hyperfiddle/electric_dom3_efns.cljc b/src/hyperfiddle/electric_dom3_efns.cljc index f414160ba..85e7bbfba 100644 --- a/src/hyperfiddle/electric_dom3_efns.cljc +++ b/src/hyperfiddle/electric_dom3_efns.cljc @@ -374,11 +374,54 @@ [v done! (reset! !busy? true)] [v done! (reset! !busy? (m/? dfv))]))))) -(defn event->tasks [flow] - (uf->is - (m/ap - (let [S (i/spine)] - (m/amb S - (let [v (m/?> flow), id (random-uuid)] - (S id {} [v #(S id {} nil)]) - (m/amb))))))) +(defn ->task + ([flow] (->task nil flow)) + ([init flow] + (->> (m/ap (let [v (m/?< flow), dfv (m/dfv), done! #(dfv nil)] + (try (m/amb [v done!] [v (m/? dfv)]) + (catch missionary.Cancelled _ (m/amb))))) + (m/reductions {} [init nil])))) + +(comment + (def !! (atom nil)) + (def ps ((->task (m/observe (fn [!] (reset! !! !) #()))) #(prn :step) #(prn :done))) + @ps + (@!! 2) + ((second *1)) + (ps) + ) + +(defn ->box + ([] (->box nil)) + ([init] (let [o (object-array 1)] + (aset o (int 0) init) + (fn ([] (aget o (int 0))) ([v] (aset o (int 0) v)))))) + +(defn ->backpressured-task + ([flow] (->backpressured-task nil flow)) + ([init flow] + (->> (m/ap + (let [busy? (->box) + v (m/?> (m/eduction (remove (fn [_] (busy?))) flow)) + dfv (m/dfv), done! #(dfv nil)] + (m/amb + [v (busy? done!)] + [v (busy? (m/? dfv))]))) + (m/reductions {} [init nil])))) + +(defn event->latest-task [flow] + (uf->is (m/cp + (let [!busy? (atom false) + v (m/?< flow) + dfv (m/dfv), done! #(dfv false)] + (m/amb + [v done! (reset! !busy? true)] + [v done! (reset! !busy? (m/? dfv))]))))) + +(defn ->tasks [flow] + (m/ap + (let [S (i/spine)] + (m/amb S + (let [v (m/?> flow), id (random-uuid)] + (S id {} [v #(S id {} nil)]) + (m/amb)))))) From c086e7c55c39b0d92775b0183494db9a98217894 Mon Sep 17 00:00:00 2001 From: xificurC Date: Fri, 24 May 2024 15:08:03 +0200 Subject: [PATCH 233/428] compiler: tag support --- src/hyperfiddle/electric/impl/lang_de2.clj | 11 +++++++-- src/hyperfiddle/electric/impl/runtime_de.cljc | 2 ++ .../electric/impl/compiler_test.cljc | 23 ++++++++++++++++++- 3 files changed, 33 insertions(+), 3 deletions(-) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 4af37db04..87d60a37d 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -628,6 +628,9 @@ (::call) (let [e (->id)] (recur (second form) e env (-> (ts/add ts {:db/id e, ::parent pe, ::type ::call, ::uid (->uid)}) (?add-source-map e form)))) + (::tag) (let [e (->id)] (recur (second form) e env + (-> (ts/add ts {:db/id e, ::parent pe, ::type ::call, ::uid (->uid), ::call-type ::tag}) + (?add-source-map e form)))) (::pure) (let [e (->id)] (recur (second form) e env (-> (ts/add ts {:db/id e, ::parent pe, ::type ::pure}) (?add-source-map e form)))) (::join) (let [e (->id)] (recur (second form) e env (-> (ts/add ts {:db/id e, ::parent pe, ::type ::join}) @@ -722,6 +725,8 @@ (defn ->thunk [xs] `(fn* [] (~@xs))) +(defn tag-call? [ts e] (= ::tag (::call-type (ts/->node ts e)))) + (defn emit [ts e ctor-e env nm] ((fn rec [e] (let [nd (get (:eav ts) e)] @@ -751,7 +756,9 @@ ::closed-ref (::closed-ref nd)) first (ts/->node ts) ::free-idx))))) (ts/find ts ::ctor-free (e->uid ts e)))) - ::call (list `r/join (list `r/call 'frame (::call-idx (ts/->node ts e)))) + ::call (if (tag-call? ts e) + (list `r/pure (list `r/tag 'frame (::call-idx nd))) + (list `r/join (list `r/call 'frame (::call-idx nd)))) ::frame 'frame ::lookup (list* `r/lookup 'frame (::sym nd) (when-some [c (?get-child-e ts e)] (list (rec c)))) ::mklocal (recur (get-ret-e ts (get-child-e ts e))) @@ -803,7 +810,7 @@ (let [ret-e (get-ret-e ts (get-child-e ts ctor-e)) ctor-uid (::uid (ts/->node ts ctor-e)) nodes-e (get-ordered-nodes-e ts ctor-uid) - calls-e (get-ordered-calls-e ts ctor-uid)] + calls-e (into [] (remove #(tag-call? ts %)) (get-ordered-calls-e ts ctor-uid))] `(r/cdef ~(count (ts/find ts ::ctor-free ctor-uid)) ~(mapv #(get-site ts (->> (ts/->node ts %) ::ctor-ref (->localv-e ts) (get-ret-e ts))) nodes-e) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 3b040b466..8ded93299 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -1017,3 +1017,5 @@ Returns a peer definition from given definitions and main key. (recur ret (dissoc left k)) (recur (assoc ret k f) (merge (dissoc left k) (f :get :deps)))) ret))) + +(def tag) diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index ecb79b89b..895e2a9ea 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -2,7 +2,7 @@ (:require [hyperfiddle.electric-de :as e] [hyperfiddle.incseq :as i] #?(:clj [contrib.triple-store :as ts]) - #?(:clj [hyperfiddle.electric.impl.lang-de2 :as lang]) + [hyperfiddle.electric.impl.lang-de2 :as lang] [hyperfiddle.electric.impl.runtime-de :as r] [hyperfiddle.electric-local-def-de :as l] #?(:clj [hyperfiddle.electric.impl.compiler-test-clj :refer [cannot-be-unsited]] @@ -532,6 +532,27 @@ `[(r/cdef 0 [] [] :server (fn [~'frame] (r/pure (vector 11))))])) +(tests "::lang/tag" + (match (l/test-compile ::Main [(::lang/tag) + (::lang/tag) + (::lang/call (::lang/ctor 1)) + (::lang/tag) + (::lang/call (::lang/ctor 2))]) + `[(r/cdef 0 [] [nil nil] nil + (fn [~'frame] + (r/define-call ~'frame 2 (r/pure (r/ctor ::Main 1))) + (r/define-call ~'frame 4 (r/pure (r/ctor ::Main 2))) + (r/ap (r/pure vector) + (r/pure (r/tag ~'frame 0)) + (r/pure (r/tag ~'frame 1)) + (r/join (r/call ~'frame 2)) + (r/pure (r/tag ~'frame 3)) + (r/join (r/call ~'frame 4))))) + (r/cdef 0 [] [] nil + (fn [~'frame] (r/pure 1))) + (r/cdef 0 [] [] nil + (fn [~'frame] (r/pure 2)))])) + (comment (let [ts (l/code->ts {} (prn :hello)) From a9972fee0aaf911800b23c11089fd45a5de79f08 Mon Sep 17 00:00:00 2001 From: xificurC Date: Mon, 27 May 2024 12:55:19 +0200 Subject: [PATCH 234/428] compiler: fix node&call ordering --- src/contrib/triple_store.clj | 5 +- src/hyperfiddle/electric/impl/lang_de2.clj | 60 ++++++++++--------- src/hyperfiddle/electric/impl/runtime_de.cljc | 10 +++- test/contrib/triple_store_test.clj | 2 + .../electric/impl/compiler_test.cljc | 50 +++++++++++++--- test/hyperfiddle/electric_de_test.cljc | 2 +- 6 files changed, 88 insertions(+), 41 deletions(-) diff --git a/src/contrib/triple_store.clj b/src/contrib/triple_store.clj index 57dae4d9d..1c92e776d 100644 --- a/src/contrib/triple_store.clj +++ b/src/contrib/triple_store.clj @@ -46,8 +46,9 @@ v1 (-> eav (get e) (get a)) ave (if (= v0 v1) (:ave ts) - (let [ave (update (:ave ts) a update v1 (fnil conj (sorted-set)) e)] - (cond-> ave (contains? (get ave a) v0) (update a update v0 disj e)))) + (let [ave (update (:ave ts) a update v1 (fnil conj (sorted-set)) e) + ave (cond-> ave (contains? (get ave a) v0) (update a update v0 disj e))] + (cond-> ave (not (seq (-> ave (get a) (get v0)))) (update a dissoc v0)))) vea (:vea ts) ;; vea (update (:vea ts) v1 update e (fnil conj #{}) a) ;; vea (cond-> vea (contains? (get vea v0) e) (update v0 update e disj a)) diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 87d60a37d..0c11ddbad 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -431,6 +431,7 @@ :cljs (assoc (analyze-cljs-symbol sym env) :lang :cljs))))))) +(defn ->bindlocal-value-e [ts e] (first (get-children-e ts e))) (defn ->bindlocal-body-e [ts e] (second (get-children-e ts e))) (defn ->localv-e [ts mklocal-uid] (->> (ts/find ts ::type ::bindlocal, ::ref mklocal-uid) first (get-child-e ts))) @@ -789,8 +790,8 @@ (defn get-ordered-nodes-e [ts ctor-uid] (->> (ts/find ts ::ctor-node ctor-uid) (sort-by #(::node-idx (ts/->node ts %))))) -(defn compute-effect-order [ts e] - (let [->order (->->id), ord (fn [ts e] (ts/upd ts e ::fx-order #(or % (->order)))), seen (volatile! #{})] +(defn compute-program-order [ts e] + (let [->order (->->id), ord (fn [ts e] (ts/upd ts e ::pg-order #(or % (->order)))), seen (volatile! #{})] ((fn rec [ts e] (let [nd (ts/->node ts e)] (if (@seen e) @@ -800,9 +801,9 @@ (::literal ::var ::lookup ::node ::frame) (ord ts e) (::ap ::comp) (ord (reduce rec ts (get-children-e ts e)) e) (::site ::join ::pure ::call ::ctor ::mklocal) (ord (rec ts (get-child-e ts e)) e) - (::bindlocal) (recur ts (->bindlocal-body-e ts e)) + (::bindlocal) (-> ts (rec (->bindlocal-value-e ts e)) (rec (->bindlocal-body-e ts e)) (ord e)) (::localref) (ord (rec ts (->localv-e ts (::ref nd))) (uid->e ts (::ref nd))) - #_else (throw (ex-info (str "cannot compute-effect-order on " (pr-str (::type nd))) (or nd {}))) + #_else (throw (ex-info (str "cannot compute-program-order on " (pr-str (::type nd))) (or nd {}))) ))))) ts e))) @@ -818,10 +819,10 @@ ~(get-site ts ret-e) (fn [~'frame] ~@(let [node-inits (->> nodes-e - (mapv (fn [e] [(->> e (ts/->node ts) ::ctor-ref (uid->e ts) (ts/->node ts) ::fx-order) + (mapv (fn [e] [(->> e (ts/->node ts) ::ctor-ref (uid->e ts) (ts/->node ts) ::pg-order) (emit-node-init ts ctor-e e env nm)]))) call-inits (->> calls-e - (mapv (fn [e] [(->> e (ts/->node ts) ::fx-order) + (mapv (fn [e] [(->> e (ts/->node ts) ::pg-order) (emit-call-init ts ctor-e e env nm)])))] ;; with xforms would be ;; (into [] (comp cat (x/sort-by first) (map second)) [node-inits call-inits]) @@ -880,6 +881,8 @@ (reparent-children e new-e) (ts/add (assoc nd :db/id new-e, ::parent e))))) +(defn get-program-order [ts e] (::pg-order (ts/->node ts e))) + (defn analyze-electric [env {{::keys [->id]} :o :as ts}] (when (::print-analysis env) (prn :analysis) (run! prn (ts->reducible ts))) (let [pure-fn? (fn pure-fn? [nd] (and (= ::literal (::type nd)) (pure-fns (::v nd)))) @@ -928,7 +931,7 @@ (recur (ts/asc ts e ::ctor-idx (->ctor-idx)) (get-child-e ts e))) (::localref) (recur ts (->> (::ref nd) (->localv-e ts) (get-ret-e ts))) #_else (throw (ex-info (str "cannot mark-used-ctors on " (pr-str (::type nd))) (or nd {}))))))) - ts (-> ts (compute-effect-order (get-root-e ts)) (mark-used-ctors (get-root-e ts))) + ts (-> ts (compute-program-order (get-root-e ts)) (mark-used-ctors (get-root-e ts))) ctors-uid (mapv #(e->uid ts %) (get-ordered-ctors-e ts)) has-node? (fn has-node? [ts uid] (ts/find ts ::ctor-ref uid)) ensure-node (fn ensure-node [ts uid] @@ -947,33 +950,32 @@ (reduce (fn [ts nodes-e] (let [->idx (->->id)] (reduce (fn [ts e] (ts/asc ts e ::node-idx (->idx))) - ts (sort-by #(->> % (ts/->node ts) ::ctor-ref (uid->e ts) (ts/->node ts) ::fx-order) - nodes-e)))) + ts (sort-by #(get-program-order ts (uid->e ts (::ctor-ref (ts/->node ts %)))) nodes-e)))) ts (-> ts :ave ::ctor-node vals))) order-frees (fn order-frees [ts] (reduce (fn [ts frees-e] (let [->idx (->->id)] (reduce (fn [ts e] (ts/asc ts e ::free-idx (->idx))) - ts (sort-by #(::fx-order (ts/->node ts %)) frees-e)))) + ts (sort-by #(::pg-order (ts/->node ts %)) frees-e)))) ts (-> ts :ave ::ctor-free vals))) unlink (fn [ts e] (-> ts (reparent-children e (::parent (ts/->node ts e))) (ts/del e))) inline-locals (fn inline-locals [ts] - (reduce (fn [ts mklocal-uid] - (let [mklocal-nd (ca/is (ts/->node ts (uid->e ts mklocal-uid)) (comp #{::mklocal} ::type)) - localrefs-e (mapv #(uid->e ts %) (::used-refs mklocal-nd)) - localref-e (first (ca/check #(= 1 (count %)) localrefs-e {:refs localrefs-e, :mklocal-nd mklocal-nd})) - localv-e (->localv-e ts mklocal-uid), localv-nd (ts/->node ts localv-e) - site (get-site ts (get-ret-e ts localv-e))] - (-> ts - (ts/asc localref-e ::type ::site) - (ts/asc localref-e ::site site) - (ts/asc localv-e ::parent localref-e) - (unlink (:db/id mklocal-nd)) - (unlink (::parent localv-nd))))) - ts (->> ts :ave ::used-refs vals (reduce into) - (mapv #(e->uid ts %)) - (remove #(has-node? ts %))))) + (reduce (fn [ts mklocal-uid] + (let [mklocal-nd (ca/is (ts/->node ts (uid->e ts mklocal-uid)) (comp #{::mklocal} ::type)) + localrefs-e (mapv #(uid->e ts %) (::used-refs mklocal-nd)) + localref-e (first (ca/check #(= 1 (count %)) localrefs-e {:refs localrefs-e, :mklocal-nd mklocal-nd})) + localv-e (->localv-e ts mklocal-uid), localv-nd (ts/->node ts localv-e) + site (get-site ts (get-ret-e ts localv-e))] + (-> ts + (ts/asc localref-e ::type ::site) + (ts/asc localref-e ::site site) + (ts/asc localv-e ::parent localref-e) + (unlink (:db/id mklocal-nd)) + (unlink (::parent localv-nd))))) + ts (->> ts :ave ::used-refs vals (reduce into) + (mapv #(e->uid ts %)) + (remove #(has-node? ts %))))) in-a-call? (fn in-a-call? [ts ref-e mklocal-e] (loop [e (::parent (ts/->node ts ref-e))] (when-let [nd (ts/->node ts e)] @@ -1039,10 +1041,9 @@ (::ap ::comp) (reduce #(mark-used-calls % ctor-e %2) ts (get-children-e ts e)) (::site ::join ::pure ::mklocal) (recur ts ctor-e (get-child-e ts e)) (::bindlocal) (recur ts ctor-e (->bindlocal-body-e ts e)) - (::call) (if (::call-idx nd) + (::call) (if (::ctor-call nd) ts (-> (mark-used-calls ts ctor-e (get-child-e ts e)) - (ts/asc e ::call-idx (->call-idx (e->uid ts ctor-e))) (ts/asc e ::ctor-call (::uid (ts/->node ts ctor-e))))) (::let) (recur ts ctor-e (->bindlocal-body-e ts e)) (::localref) (let [nx-e (->> (::ref nd) (->localv-e ts) (get-ret-e ts))] @@ -1051,7 +1052,10 @@ mark-used-calls2 (fn [ts] (reduce (fn [ts ctor-e] (mark-used-calls ts ctor-e (get-ret-e ts (get-child-e ts ctor-e)))) ts (->> ts :ave ::ctor-idx vals (reduce into)))) - ts (-> ts mark-used-calls2 reroute-local-aliases (optimize-locals (get-root-e ts)) + index-calls (fn [ts] + (reduce (fn [ts e] (ts/asc ts e ::call-idx (->call-idx (::ctor-call (ts/->node ts e))))) + ts (sort-by #(get-program-order ts %) (->> ts :ave ::ctor-call vals (reduce into))))) + ts (-> ts mark-used-calls2 index-calls reroute-local-aliases (optimize-locals (get-root-e ts)) inline-locals order-nodes order-frees collapse-ap-with-only-pures)] (when (::print-db env) (prn :db) (run! prn (ts->reducible ts))) ts)) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 8ded93299..016cf012a 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -438,14 +438,18 @@ T T T -> (EXPR T) [^objects port] (aget port port-slot-slot)) +(defn get-node-or-call-port [^Frame frame id] + (if (neg? id) + (let [id (- -1 id)] + (-> (aget ^objects (.-nodes frame) id) (ca/is some? "no node port in slot " id))) + (-> (aget ^objects (.-calls frame) id) (ca/is some? "no call port in slot " id)))) + (defn slot-port {:tag 'objects} [^Slot slot] (let [id (.-id slot) ^Frame frame (.-frame slot)] - (if (neg? id) - (aget ^objects (.-nodes frame) (- -1 id)) - (aget ^objects (.-calls frame) id)))) + (get-node-or-call-port frame id))) (defn port-ready [^objects port] (peer-push (frame-peer (.-frame (port-slot port))) peer-queue-ready port)) diff --git a/test/contrib/triple_store_test.clj b/test/contrib/triple_store_test.clj index a58ce3f17..7e31bc7c1 100644 --- a/test/contrib/triple_store_test.clj +++ b/test/contrib/triple_store_test.clj @@ -15,6 +15,8 @@ (-> (ts/->ts) (ts/add {:db/id 1, :foo 1, :bar 1}) (ts/add {:db/id 2, :foo 1, :bar 1}) (ts/find :foo 1 :bar 1)) := #{1 2} + (-> (ts/->ts) (ts/add {:db/id 1, :foo 1}) (ts/asc 1 :foo 2) :ave :foo) := {2 #{1}} + (let [ts (-> (ts/->ts) (ts/add {:db/id 1, :foo 1}) (ts/add {:db/id 2, :foo 2}))] (count (->> ts :ave :foo vals (reduce into))) := 2 (let [ts (ts/del ts 2)] diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index 895e2a9ea..e533d9d93 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -272,9 +272,9 @@ (match (l/test-compile ::Main (let [a 1, b 2] (::lang/ctor [b (::lang/ctor a)]))) `[(r/cdef 0 [nil nil] [] nil (fn [~'frame] - (r/define-node ~'frame 0 (r/pure 2)) - (r/define-node ~'frame 1 (r/pure 1)) - (r/pure (r/ctor ::Main 1 (r/node ~'frame 0) (r/node ~'frame 1))))) + (r/define-node ~'frame 0 (r/pure 1)) + (r/define-node ~'frame 1 (r/pure 2)) + (r/pure (r/ctor ::Main 1 (r/node ~'frame 1) (r/node ~'frame 0))))) (r/cdef 2 [] [] nil (fn [~'frame] (r/ap (r/pure clojure.core/vector) @@ -493,15 +493,15 @@ (match (l/test-compile ::Main (let [x 1, y 2] [y x x y])) `[(r/cdef 0 [nil nil] [] nil (fn [~'frame] - (r/define-node ~'frame 0 (r/pure 2)) - (r/define-node ~'frame 1 (r/pure 1)) + (r/define-node ~'frame 0 (r/pure 1)) + (r/define-node ~'frame 1 (r/pure 2)) (r/ap (r/pure clojure.core/vector) - (r/node ~'frame 0) (r/node ~'frame 1) (r/node ~'frame 1) (r/node ~'frame 0))))]) + (r/node ~'frame 1) (r/node ~'frame 0) (r/node ~'frame 0) (r/node ~'frame 1))))]) (match (l/test-compile ::Main (let [x 1] [(::lang/call (::lang/ctor 1)) x x (::lang/call (::lang/ctor 2))])) `[(r/cdef 0 [nil] [nil nil] nil (fn [~'frame] - (r/define-call ~'frame 0 (r/pure (r/ctor :hyperfiddle.electric.impl.compiler-test/Main 1))) (r/define-node ~'frame 0 (r/pure 1)) + (r/define-call ~'frame 0 (r/pure (r/ctor :hyperfiddle.electric.impl.compiler-test/Main 1))) (r/define-call ~'frame 1 (r/pure (r/ctor :hyperfiddle.electric.impl.compiler-test/Main 2))) (r/ap (r/pure clojure.core/vector) (r/join (r/call ~'frame 0)) @@ -553,6 +553,42 @@ (r/cdef 0 [] [] nil (fn [~'frame] (r/pure 2)))])) +(tests + "call order" + (match (l/test-compile ::Main (let [x (binding [::foo 1] (::lang/lookup ::foo))] + (prn x) + (prn x))) + `[(r/cdef 0 [nil nil] [nil nil] nil + (fn [~'frame] + (r/define-node ~'frame 0 (r/pure 1)) + (r/define-call ~'frame 0 + (r/ap (r/pure (fn* [] + (r/bind (r/ctor ::Main 2) + ::foo (r/node ~'frame 0)))))) + (r/define-node ~'frame 1 (r/join (r/call ~'frame 0))) + (r/define-call ~'frame 1 + (r/join + (r/ap (r/lookup ~'frame :hyperfiddle.incseq/fixed (r/pure hyperfiddle.incseq/fixed)) + (r/ap (r/lookup ~'frame ::r/invariant (r/pure r/invariant)) + (r/pure (r/ctor ::Main 1 (r/node ~'frame 1)))) + (r/ap (r/lookup ~'frame ::r/invariant (r/pure r/invariant)) + (r/pure (r/ctor ::Main 3 (r/node ~'frame 1))))))) + (r/join (r/call ~'frame 1)))) + (r/cdef 1 [] [] nil + (fn [~'frame] + (r/join (r/ap (r/lookup ~'frame ::r/drain (r/pure r/drain)) + (r/pure + (r/incseq ~'frame + (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure prn)) + (r/free ~'frame 0)))))))) + (r/cdef 0 [] [] nil + (fn [~'frame] + (r/lookup ~'frame ::foo))) + (r/cdef 1 [] [] nil + (fn [~'frame] + (r/ap (r/lookup ~'frame :clojure.core/prn (r/pure prn)) + (r/free ~'frame 0))))])) + (comment (let [ts (l/code->ts {} (prn :hello)) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index bf240ffa2..bf567ac66 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -30,7 +30,7 @@ % := (Point. 1 2))) ;; TODO `m/ap` has `try` in expansion -(skip "new on missionary flow" +(tests "new on missionary flow" (with ((l/single {} (tap (e/input (m/ap 1)))) tap tap) % := 1)) From 41734c362e388d5fda8326db31c9fe062861cae3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Fri, 24 May 2024 14:38:24 +0200 Subject: [PATCH 235/428] mount-point --- src/hyperfiddle/electric/impl/lang_de2.clj | 3 +- .../electric/impl/mount_point.cljc | 575 ++++++++++++++++++ src/hyperfiddle/electric/impl/runtime_de.cljc | 344 ++++++----- src/hyperfiddle/electric_de.cljc | 4 + src/hyperfiddle/incseq.cljc | 262 +------- src/hyperfiddle/incseq/arrays_impl.cljc | 34 ++ src/hyperfiddle/incseq/diff_impl.cljc | 14 + .../incseq/latest_concat_impl.cljc | 245 ++++++++ .../incseq/latest_product_impl.cljc | 20 +- src/hyperfiddle/incseq/perm_impl.cljc | 10 + src/hyperfiddle/kvs.cljc | 6 + .../electric/impl/compiler_test.cljc | 2 +- .../electric/impl/mount_point_test.cljc | 147 +++++ 13 files changed, 1233 insertions(+), 433 deletions(-) create mode 100644 src/hyperfiddle/electric/impl/mount_point.cljc create mode 100644 src/hyperfiddle/incseq/arrays_impl.cljc create mode 100644 src/hyperfiddle/incseq/latest_concat_impl.cljc create mode 100644 src/hyperfiddle/kvs.cljc create mode 100644 test/hyperfiddle/electric/impl/mount_point_test.cljc diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj index 0c11ddbad..5366e8232 100644 --- a/src/hyperfiddle/electric/impl/lang_de2.clj +++ b/src/hyperfiddle/electric/impl/lang_de2.clj @@ -811,7 +811,7 @@ (let [ret-e (get-ret-e ts (get-child-e ts ctor-e)) ctor-uid (::uid (ts/->node ts ctor-e)) nodes-e (get-ordered-nodes-e ts ctor-uid) - calls-e (into [] (remove #(tag-call? ts %)) (get-ordered-calls-e ts ctor-uid))] + calls-e (get-ordered-calls-e ts ctor-uid)] `(r/cdef ~(count (ts/find ts ::ctor-free ctor-uid)) ~(mapv #(get-site ts (->> (ts/->node ts %) ::ctor-ref (->localv-e ts) (get-ret-e ts))) nodes-e) @@ -822,6 +822,7 @@ (mapv (fn [e] [(->> e (ts/->node ts) ::ctor-ref (uid->e ts) (ts/->node ts) ::pg-order) (emit-node-init ts ctor-e e env nm)]))) call-inits (->> calls-e + (remove #(tag-call? ts %)) (mapv (fn [e] [(->> e (ts/->node ts) ::pg-order) (emit-call-init ts ctor-e e env nm)])))] ;; with xforms would be diff --git a/src/hyperfiddle/electric/impl/mount_point.cljc b/src/hyperfiddle/electric/impl/mount_point.cljc new file mode 100644 index 000000000..145db8961 --- /dev/null +++ b/src/hyperfiddle/electric/impl/mount_point.cljc @@ -0,0 +1,575 @@ +(ns hyperfiddle.electric.impl.mount-point + (:require [hyperfiddle.kvs :refer [KVS]] + [hyperfiddle.incseq.arrays-impl :as a] + [hyperfiddle.incseq.diff-impl :as d] + [hyperfiddle.incseq.perm-impl :as p] + [hyperfiddle.electric.impl.runtime-de :as r]) + #?(:clj (:import (clojure.lang IFn IDeref) + (java.util.concurrent.locks Lock ReentrantLock)))) + +(def slot-lock 0) +(def slot-blocks 1) +(def slot-reader 2) +(def slots 3) + +(def reader-slot-state 0) +(def reader-slot-step 1) +(def reader-slot-done 2) +(def reader-slot-queue 3) +(def reader-slot-push 4) +(def reader-slot-root 5) +(def reader-slots 6) + +(def call-slot-reader 0) +(def call-slot-block 1) +(def call-slot-index 2) +(def call-slot-buffer 3) +(def call-slot-weight 4) +(def call-slot-process 5) +(def call-slots 6) + +(def block-slot-parent 0) +(def block-slot-index 1) +(def block-slot-frame 2) +(def block-slot-children 3) +(def block-slot-weights 4) +(def block-slots 5) + +(defn enter [^objects state] + (.lock ^Lock (aget state slot-lock))) + +(defn exit [^objects state] + (.unlock ^Lock (aget state slot-lock))) + +(defn frame->block [^objects state frame] + (get (aget state slot-blocks) frame)) + +(defn make-block [frame] + (let [size (r/frame-call-count frame) + children (object-array size)] + (dotimes [index (alength children)] + (when-not (r/frame-call frame index) + (aset children index children))) + (doto (object-array block-slots) + (aset block-slot-frame frame) + (aset block-slot-children children) + (aset block-slot-weights (a/weight-tree size))))) + +(defn ensure-capacity [^objects buffer cap] + (let [n (alength buffer)] + (if (< n cap) + (let [b (object-array (bit-shift-left n 1))] + (a/acopy buffer 0 b 0 n) b) buffer))) + +(defn call-weight [^objects call] + (aget call call-slot-weight)) + +(defn local-block-offset [^objects call index] + (let [^objects buffer (aget call call-slot-buffer) + ^objects reader (aget call call-slot-reader) + ^objects state (aget reader reader-slot-state)] + (loop [index index + offset 0] + (if (zero? index) + offset + (let [index (dec index)] + (recur index + (if-some [^objects block (frame->block state (aget buffer index))] + (let [^ints weights (aget block block-slot-weights)] + (unchecked-add-int offset (aget weights 1))) + offset))))))) + +(defn local-tag-offset [^objects block index] + (let [^ints weights (aget block block-slot-weights)] + (loop [o 0, i (unchecked-add (bit-shift-right (alength weights) 1) index)] + (case i + 1 o + (recur (if (even? i) + o (unchecked-add o + (aget weights (unchecked-dec i)))) + (bit-shift-right i 1)))))) + +(defn tag-offset [^objects block index] + (loop [^objects block block + index index + offset 0] + (let [offset (unchecked-add-int offset (local-tag-offset block index))] + (if-some [^objects call (aget block block-slot-parent)] + (recur (aget call call-slot-block) (aget call call-slot-index) + (unchecked-add-int offset (local-block-offset call (aget block block-slot-index)))) + offset)))) + +(defn update-local-weights [^ints weights index delta] + (loop [i (unchecked-add (bit-shift-right (alength weights) 1) index)] + (aset weights i (unchecked-add-int (aget weights i) delta)) + (when (< 1 i) (recur (bit-shift-right i 1))))) + +(defn update-weights [^objects block index delta] + (loop [^objects block block] + (update-local-weights (aget block block-slot-weights) index delta) + (when-some [^objects call (aget block block-slot-parent)] + (aset call call-slot-weight (+ delta (aget call call-slot-weight))) + (recur (aget call call-slot-block))))) + +(defn swap-indices [^objects call i j] + (let [^objects buffer (aget call call-slot-buffer) + ^objects reader (aget call call-slot-reader) + ^objects state (aget reader reader-slot-state) + fi (aget buffer i) + fj (aget buffer j)] + (aset buffer i fj) + (aset buffer j fi) + (when-some [^objects block (frame->block state fi)] + (aset block block-slot-index j)) + (when-some [^objects block (frame->block state fj)] + (aset block block-slot-index i)))) + +(defn offset-of [^objects call index] + (unchecked-add-int (local-block-offset call index) + (tag-offset (aget call call-slot-block) + (aget call call-slot-index)))) + +(defn block-weight [^objects block] + (let [^ints weights (aget block block-slot-weights)] + (aget weights 1))) + +(defn current-size [^objects reader] + (if-some [root (aget reader reader-slot-root)] + (block-weight root) 0)) + +(defn weight-between [^objects call i j] + (let [^objects buffer (aget call call-slot-buffer) + ^objects reader (aget call call-slot-reader) + ^objects state (aget reader reader-slot-state)] + (loop [i i + w 0] + (let [i (unchecked-inc-int i)] + (if (== i j) + w (recur i + (if-some [^objects block (frame->block state (aget buffer i))] + (unchecked-add-int w (block-weight block)) w))))))) + +(defn drain-exit [^objects reader] + (loop [pull 0] + (let [^objects queue (aget reader reader-slot-queue)] + (when-some [^objects block (aget queue pull)] + (let [pull+ (unchecked-inc-int pull) + index (aget queue pull+) + frame (aget block block-slot-frame) + ^objects children (aget block block-slot-children)] + (when (r/frame-call frame index) + (let [^objects call (aget children index)] + (try @(aget call call-slot-process) + (catch #?(:clj Throwable :cljs :default) _)))) + (recur (rem (unchecked-inc-int pull+) (alength queue))))))) + (aset reader reader-slot-push nil) + (exit (aget reader reader-slot-state))) + +(defn enqueue [^objects reader ^objects block index] + (let [^objects queue (aget reader reader-slot-queue) + cap (alength queue)] + (if-some [i (aget reader reader-slot-push)] + (do (aset reader reader-slot-push + (identity + (if (nil? (aget queue i)) + (let [i+ (unchecked-inc-int i)] + (aset queue i block) + (aset queue i+ index) + (rem (unchecked-inc-int i+) cap)) + (let [n (bit-shift-left cap 1) + q (object-array n)] + (aset reader reader-slot-queue q) + (a/acopy queue i q i + (unchecked-subtract-int cap i)) + (a/acopy queue 0 q cap i) + (let [i (unchecked-add-int i cap) + i+ (unchecked-inc-int i)] + (aset q i block) + (aset q i+ index) + (rem (unchecked-inc-int i+) n)))))) + false) + (do (aset reader reader-slot-push (identity (rem 2 cap))) + (aset queue 0 block) + (aset queue 1 index) + true)))) + +(defn step-exit [^objects reader] + (let [step (aget reader reader-slot-step)] + (exit (aget reader reader-slot-state)) (step))) + +(defn done-exit [^objects reader] + (let [done (aget reader reader-slot-done) + live (aset reader reader-slot-root + (dec (aget reader reader-slot-root)))] + (exit (aget reader reader-slot-state)) + (when (zero? live) (done)))) + +(defn mount-block [^objects reader ^objects block] + (let [frame (aget block block-slot-frame) + ^objects children (aget block block-slot-children)] + (dotimes [index (alength children)] + (if (r/frame-call frame index) + (when-some [^objects call (aget children index)] + (aset call call-slot-process + ((r/flow (r/->Slot frame index)) + #(let [^objects reader (aget call call-slot-reader) + ^objects state (aget reader reader-slot-state)] + (enter state) + (if (enqueue reader block index) + (if (identical? reader (aget state slot-reader)) + (step-exit reader) + (drain-exit state)) + (exit state))) + #(let [^objects reader (aget call call-slot-reader) + ^objects state (aget reader reader-slot-state)] + (enter state) + (if (identical? reader (aget state slot-reader)) + (do (comment TODO mark as done) (exit state)) + (done-exit reader)))))) + (when-not (identical? children (aget children index)) + (enqueue reader block (- index (r/frame-call-count frame)))))))) + +(defn cancel-calls [^objects reader ^objects block] + (let [^objects state (aget reader reader-slot-state) + frame (aget block block-slot-frame) + ^objects children (aget block block-slot-children) + ^ints weights (aget block block-slot-weights) + offset (bit-shift-right (alength weights) 1)] + (dotimes [index (alength children)] + (update-local-weights weights index + (- (aget weights (unchecked-add-int offset index)))) + (when (r/frame-call frame index) + (when-some [^objects call (aget children index)] + (let [^objects buffer (aget call call-slot-buffer) + process (aget call call-slot-process)] + (aset call call-slot-weight 0) + (aset reader reader-slot-root + (inc (aget reader reader-slot-root))) + (loop [i 0] + (when (< i (alength buffer)) + (when-some [f (aget buffer i)] + (when-some [b (frame->block state f)] + (cancel-calls reader b) + (recur (inc i)))))) + (process))))))) + +(defn unmount-block [^objects reader ^objects block] + (when-some [^objects call (aget block block-slot-parent)] + (let [delta (unchecked-negate-int (block-weight block))] + (aset call call-slot-weight (unchecked-add-int (aget call call-slot-weight) delta)) + (update-weights (aget call call-slot-block) (aget call call-slot-index) delta))) + (cancel-calls reader block)) + +(defn reader-cancel [^objects reader] + (let [^objects state (aget reader reader-slot-state)] + (enter state) + (if (identical? reader (aget state slot-reader)) + (let [root (aget reader reader-slot-root)] + (aset reader reader-slot-root (identity 1)) + (when-not (nil? root) (unmount-block reader root)) + (aset state slot-reader nil) + (if (nil? (aget reader reader-slot-push)) + (do (aset reader reader-slot-push (identity 0)) + (step-exit reader)) + (drain-exit reader))) + (exit state)))) + +(defn reader-transfer [^objects reader] + (let [^objects state (aget reader reader-slot-state)] + (enter state) + (if (identical? reader (aget state slot-reader)) + (loop [pull 0 + diff (d/empty-diff (current-size reader))] + (let [^objects queue (aget reader reader-slot-queue)] + (if-some [^objects block (a/aget-aset queue pull nil)] + (let [pull+ (unchecked-inc-int pull) + index (a/aget-aset queue pull+ nil) + frame (aget block block-slot-frame) + children (aget block block-slot-children) + size-before (current-size reader)] + (recur (rem (unchecked-inc-int pull+) (alength queue)) + (if (neg? index) + (let [index (+ index (r/frame-call-count frame))] + (if (r/frame-call frame index) + (assert false) + (let [state (aget children index) + offset (tag-offset block index)] + (update-weights block index 1) + (d/combine diff + {:grow 1 + :degree (inc size-before) + :shrink 0 + :permutation (p/rotation size-before offset) + :change {offset state} + :freeze #{}})))) + (if (r/frame-call frame index) + (let [^objects call (aget children index) + {:keys [degree shrink permutation change]} @(aget call call-slot-process) + ^objects buffer (aset call call-slot-buffer (ensure-capacity (aget call call-slot-buffer) degree)) + perm (loop [p permutation + q {}] + (case p + {} (reduce-kv + (fn [q i f] + (let [p (aget buffer i) + o (offset-of call i) + l (if-some [^objects block (frame->block state p)] + (do (unmount-block reader block) + (block-weight block)) 0) + r (-> (current-size reader) + (unchecked-subtract-int l) + (unchecked-subtract-int o))] + (aset buffer i f) + (when-some [^objects block (frame->block state f)] + (aset block block-slot-index i) + (mount-block reader block)) + (p/compose (p/split-swap o l r) q))) + q change) + (let [[i j] (first p) + k1 (min i j) + k2 (max i j) + r (p/split-long-swap + (offset-of call k1) + (if-some [^objects block (frame->block state (aget buffer k1))] + (block-weight block) 0) + (weight-between call k1 k2) + (if-some [^objects block (frame->block state (aget buffer k2))] + (block-weight block) 0))] + (swap-indices call i j) + (recur (p/compose p (p/cycle i j)) + (p/compose r q)))))] + (dotimes [i shrink] + (let [i (unchecked-subtract degree + (unchecked-inc-int i)) + f (aget buffer i)] + (aset buffer i nil) + (when-some [^objects block (frame->block state f)] + (unmount-block reader block)))) + (d/combine diff + {:grow 0 + :degree size-before + :shrink (unchecked-subtract size-before + (current-size reader)) + :permutation perm + :change {} + :freeze #{}})) + (let [state (aget children index) + offset (tag-offset block index)] + (d/combine diff + (if (identical? state children) + (do (update-weights block index -1) + {:grow 0 + :degree size-before + :shrink 1 + :permutation (p/rotation offset (dec size-before)) + :change {} + :freeze #{}}) + {:grow 0 + :degree size-before + :shrink 0 + :permutation {} + :change {offset state} + :freeze #{}}))))))) + (do (aset reader reader-slot-push nil) + (exit state) diff)))) + (do (done-exit reader) + (throw (missionary.Cancelled.)))))) + +(deftype Reader [state] + IFn + (#?(:clj invoke :cljs -invoke) [this] + (reader-cancel state)) + IDeref + (#?(:clj deref :cljs -deref) [this] + (reader-transfer state))) + +(defn subtree [root frame] + (loop [frame frame + path (list)] + (if (identical? root frame) + path (when-some [slot (r/frame-slot frame)] + (recur (r/slot-frame slot) (conj path slot)))))) + +(defn store-block [^objects state frame block] + (aset state slot-blocks (assoc (aget state slot-blocks) frame block))) + +(defn make-call [^objects reader ^objects block index] + (let [^objects children (aget block block-slot-children)] + (aset children index + (doto (object-array call-slots) + (aset call-slot-reader reader) + (aset call-slot-block block) + (aset call-slot-index index) + (aset call-slot-buffer (object-array 1)) + (aset call-slot-weight (identity 0)))))) + +(defn make-block-and-call [^objects reader ^objects call frame id] + (let [block (make-block frame)] + (store-block (aget reader reader-slot-state) frame block) + (aset block block-slot-parent call) + (make-call reader block id))) + +(defn make-blocks-and-calls [^objects reader ^objects call path] + (loop [call call + path path] + (case path + [] call + (let [slot (peek path)] + (recur (make-block-and-call reader call + (r/slot-frame slot) (r/slot-id slot)) + (pop path)))))) + +(defn insert-block [^objects reader block] + (let [^objects state (aget reader reader-slot-state)] + (if-some [root (aget reader reader-slot-root)] + (loop [^objects root root] + (let [root-frame (aget root block-slot-frame)] + (if-some [path (subtree root-frame (aget block block-slot-frame))] + (aset block block-slot-parent + (loop [call nil + path path] + (case path + [] call + (let [slot (peek path) + path (pop path) + frame (r/slot-frame slot) + id (r/slot-id slot)] + (if-some [^objects block (frame->block state frame)] + (let [^objects children (aget block block-slot-children)] + (if-some [^objects call (aget children id)] + (recur call path) + (make-blocks-and-calls reader (make-call reader block id) path))) + (make-blocks-and-calls reader (make-block-and-call reader call frame id) path)))))) + (let [slot (r/frame-slot root-frame) + frame (r/slot-frame slot) + block (make-block frame)] + (store-block state frame block) + (aset reader reader-slot-root block) + (aset root block-slot-parent + (make-call reader block (r/slot-id slot))) + (recur block))))) + (aset reader reader-slot-root block)) + reader)) + +(defn reader-spawn [^objects state step done] + (let [reader (object-array reader-slots)] + (aset reader reader-slot-state state) + (aset reader reader-slot-step step) + (aset reader reader-slot-done done) + (aset reader reader-slot-queue (object-array 2)) + (aset reader reader-slot-push (identity 0)) + (enter state) + (when (nil? (aget state slot-reader)) + (aset state slot-reader reader) + (reduce insert-block reader (vals (aget state slot-blocks))) + (when-some [root (aget reader reader-slot-root)] + (mount-block reader root))) + (exit state) (step) + (->Reader reader))) + +(defn enqueue-exit [^objects state ^objects block index] + (if-some [^objects reader (aget state slot-reader)] + (if (enqueue reader block index) + (step-exit reader) + (exit state)) + (exit state))) + +(defn failure-exit [^objects state e] + (exit state) (throw e)) + +(defn error [^String msg] + (new #?(:clj Error :cljs js/Error) msg)) + +(deftype MountPoint [^objects state] + KVS + (insert! [_ tag init] + (let [frame (r/tag-frame tag) + index (r/tag-index tag)] + (enter state) + (let [blocks (aget state slot-blocks)] + (if-some [^objects block (get blocks frame)] + (let [^objects children (aget block block-slot-children)] + (if (identical? children (aget children index)) + (do (aset children index init) + (enqueue-exit state block (- index (r/frame-call-count frame)))) + (do (exit state) + (throw (error "Can't insert - tag already present."))))) + (let [^objects block (make-block frame) + ^objects children (aget block block-slot-children)] + (aset state slot-blocks (assoc blocks frame block)) + (aset children index init) + (enqueue-exit state block (- index (r/frame-call-count frame)))))))) + (update! [_ tag f] + (let [frame (r/tag-frame tag) + index (r/tag-index tag)] + (enter state) + (let [blocks (aget state slot-blocks)] + (if-some [^objects block (get blocks frame)] + (let [^objects children (aget block block-slot-children) + x (aget children index)] + (if (identical? children x) + (failure-exit state (error "Can't update - tag is absent.")) + (if (= x (aset children index (f x))) + (exit state) + (enqueue-exit state block index)))) + (failure-exit state (error "Can't update - tag is absent.")))))) + (remove! [_ tag] + (let [frame (r/tag-frame tag) + index (r/tag-index tag)] + (enter state) + (let [blocks (aget state slot-blocks)] + (if-some [^objects block (get blocks frame)] + (let [^objects children (aget block block-slot-children)] + (if (identical? children (aget children index)) + (failure-exit state (error "Can't remove - tag is absent.")) + (do (aset children index children) + ;; TODO if block becomes empty, remove from store + (enqueue-exit state block index)))) + (failure-exit state (error "Can't remove - tag is absent.")))))) + IFn + (#?(:clj invoke :cljs -invoke) [_ step done] + (reader-spawn state step done))) + +(defn create [] + (->MountPoint + (doto (object-array slots) + (aset slot-lock #?(:clj (ReentrantLock.) :cljs nil))))) + +#_ +(defn find-block [^objects state frame] + (when-some [root (aget state slot-root)] + (loop [^objects root root] + (when-some [path (subtree root frame)] + (loop [^objects block root + path path] + (case path + [] block + (let [slot (peek path) + path (pop path) + id (r/slot-id slot) + frame (r/slot-frame slot) + ^objects children (aget block block-slot-children)] + (when-some [^objects call (aget children id)] + (when-some [^objects block (get (aget call call-slot-children) frame)] + (recur block path)))))))))) + +#_ +(defn remove-block [^objects reader ^objects block index] + (loop [^objects block block + index index] + (let [^objects children (aget block block-slot-children)] + (aset children index children) + (when (loop [i 0] + (if (identical? children (aget children i)) + (let [i (inc i)] + (if (< i (alength children)) + (recur i) true)) false)) + (if (identical? block (aget reader reader-slot-root)) + (aset reader reader-slot-root nil) + (let [^objects call (aget block block-slot-parent)] + (when (zero? (count (aset call call-slot-children + (dissoc! (aget call call-slot-children) + (aget block block-slot-frame))))) + ;; TODO cancel process + (recur (aget call call-slot-block) + (aget call call-slot-index))))))))) diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index 016cf012a..e23ba8eef 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -1,6 +1,7 @@ (ns hyperfiddle.electric.impl.runtime-de (:refer-clojure :exclude [resolve]) (:require [hyperfiddle.incseq :as i] + [hyperfiddle.incseq.arrays-impl :as a] [contrib.assert :as ca] [contrib.debug] [missionary.core :as m] @@ -48,6 +49,11 @@ (def port-slot-state 7) (def port-slots 8) +(def call-slot-port 0) +(def call-slot-rank 1) +(def call-slot-children 2) +(def call-slots 3) + (declare peer-cancel peer-transfer) (deftype Peer [site defs step done queues pushes state] @@ -89,11 +95,7 @@ (flow [_] (if (failure? value) (m/latest #(throw (ex-info "Illegal access." {:info (failure-info value)}))) - (i/fixed (invariant value)))) - #_#_ - IFn - (#?(:clj invoke :cljs -invoke) [this step done] - ((flow this) step done))) + (i/fixed (invariant value))))) (defn pure " -> (EXPR VOID) @@ -135,11 +137,7 @@ T T T -> (EXPR T) (deps [_ site] (reduce (fn [r x] (merge-with + r (deps x site))) {} inputs)) (flow [_] - (apply i/latest-product invoke-print-throws (map flow inputs))) - #_#_ - IFn - (#?(:clj invoke :cljs -invoke) [this step done] - ((flow this) step done))) + (apply i/latest-product invoke-print-throws (map flow inputs)))) (defn ap " (EXPR (-> T)) -> (EXPR T) @@ -163,11 +161,7 @@ T T T -> (EXPR T) (= input (.-input ^Join other)))) Expr (deps [_ site] (deps input site)) - (flow [_] (i/latest-concat (flow input))) - #_#_ - IFn - (#?(:clj invoke :cljs -invoke) [this step done] - ((flow this) step done))) + (flow [_] (i/latest-concat (flow input)))) (defn join " (EXPR (IS T)) -> (EXPR T) @@ -296,9 +290,9 @@ T T T -> (EXPR T) (defn port-deps [^objects port] (aget port port-slot-deps)) -(deftype Frame [peer slot rank site ctor - ^ints ranks ^objects children - ^objects calls ^objects nodes +(declare frame-result) + +(deftype Frame [peer slot rank site ctor ^objects nodes ^objects tags ^:unsynchronized-mutable ^:mutable hash-memo] #?(:clj Object) #?(:cljs IHash) @@ -316,7 +310,37 @@ T T T -> (EXPR T) (= rank (.-rank ^Frame other)))) IFn (#?(:clj invoke :cljs -invoke) [this step done] - ((port-flow (aget nodes (dec (alength nodes)))) step done))) + ((port-flow (frame-result this)) step done))) + +(deftype Tag [frame index + ^:unsynchronized-mutable ^:mutable hash-memo] + #?(:clj Object) + #?(:cljs IHash) + (#?(:clj hashCode :cljs -hash) [_] + (if-some [h hash-memo] + h (set! hash-memo (-> (hash Tag) + (hash-combine (hash frame)) + (hash-combine (hash index)))))) + #?(:cljs IEquiv) + (#?(:clj equals :cljs -equiv) [_ other] + (and (instance? Tag other) + (= frame (.-frame ^Tag other)) + (= index (.-index ^Tag other))))) + +(defn tag [^Frame frame id] + (->Tag frame id nil)) + +(defn tag-frame [^Tag tag] + (.-frame tag)) + +(defn tag-index [^Tag tag] + (.-index tag)) + +(defn frame-call [^Frame frame index] + (aget ^objects (.-tags frame) index)) + +(defn frame-call-count [^Frame frame] + (alength ^objects (.-tags frame))) (defn frame-ctor "Returns the constructor of given frame." @@ -341,11 +365,6 @@ T T T -> (EXPR T) [^Frame frame key] ((peer-root (.-peer frame) key))) -(defn frame-call-count - "Returns the call count of given frame." - [^Frame frame] - (count (.-calls (frame-cdef frame)))) - (defn frame-site "Returns the site of given frame." [^Frame frame] @@ -368,9 +387,9 @@ T T T -> (EXPR T) (let [c (bit-shift-left cap 1) q (object-array c)] (aset queues offset q) - (i/acopy queue push q push + (a/acopy queue push q push (unchecked-subtract-int cap push)) - (i/acopy queue 0 q cap push) + (a/acopy queue 0 q cap push) (let [p (unchecked-add-int push cap)] (aset q p item) (rem (unchecked-inc-int p) c))))) @@ -427,29 +446,21 @@ T T T -> (EXPR T) (port-deps port) {port 1}))) (flow [this] - (port-flow (slot-port this))) - #_#_ - IFn - (#?(:clj invoke :cljs -invoke) [this step done] - ((flow this) step done))) + (port-flow (slot-port this)))) (defn port-slot {:tag Slot} [^objects port] (aget port port-slot-slot)) -(defn get-node-or-call-port [^Frame frame id] - (if (neg? id) - (let [id (- -1 id)] - (-> (aget ^objects (.-nodes frame) id) (ca/is some? "no node port in slot " id))) - (-> (aget ^objects (.-calls frame) id) (ca/is some? "no call port in slot " id)))) - (defn slot-port {:tag 'objects} [^Slot slot] (let [id (.-id slot) ^Frame frame (.-frame slot)] - (get-node-or-call-port frame id))) + (if (neg? id) + (aget ^objects (.-nodes frame) (- -1 id)) + (aget ^objects (aget ^objects (.-tags frame) id) call-slot-port)))) (defn port-ready [^objects port] (peer-push (frame-peer (.-frame (port-slot port))) peer-queue-ready port)) @@ -462,49 +473,46 @@ T T T -> (EXPR T) (conj path [(.-id slot) (.-rank ^Frame frame)])) (vec path)))) +(defn make-port [^Slot slot site deps flow] + (let [port (object-array port-slots)] + (aset port port-slot-slot slot) + (aset port port-slot-site site) + (aset port port-slot-deps deps) + (aset port port-slot-refcount (identity 0)) + (aset port port-slot-requested (identity 0)) + (if (= site (.-site (frame-peer (.-frame slot)))) + (do (aset port port-slot-flow (m/signal i/combine flow)) + (aset port port-slot-state false)) + (do (aset port port-slot-flow + (m/signal i/combine + (fn [step done] + (let [ps (->Remote port step done)] + (aset port port-slot-process ps) + (step) ps)))) + (aset port port-slot-state (i/empty-diff 0)))) + port)) + (defn define-slot [^Slot slot expr] (let [^Frame frame (.-frame slot) id (.-id slot) site (if-some [site (let [cdef (frame-cdef frame) nodes (.-nodes cdef) - calls (.-calls cdef)] - (if (neg? id) - (let [id (- -1 id)] - (if (= id (count nodes)) - (.-result cdef) (nodes id))) - (calls id)))] + id (- -1 id)] + (if (= id (count nodes)) + (.-result cdef) (nodes id)))] site (frame-site frame)) - local? (= site (.-site (frame-peer frame))) port (if (instance? Slot expr) (slot-port expr) - (let [port (object-array port-slots)] - (aset port port-slot-slot slot) - (aset port port-slot-site site) - (aset port port-slot-deps (deps expr site)) - (aset port port-slot-flow - (m/signal i/combine - (if local? - (flow expr) - (fn [step done] - (let [ps (->Remote port step done)] - (aset port port-slot-process ps) - (step) ps))))) - (aset port port-slot-refcount (identity 0)) - (aset port port-slot-requested (identity 0)) - (aset port port-slot-state (if local? false (i/empty-diff 0))) - port))] - (if (neg? id) - (aset ^objects (.-nodes frame) (- -1 id) port) - (aset ^objects (.-calls frame) id port)) nil)) + (make-port slot site (deps expr site) (flow expr)))] + (aset ^objects (.-nodes frame) (- -1 id) port) nil)) (defn make-frame [^Peer peer ^Slot slot rank site ctor] (let [[key idx _ _] ctor cdef (peer-cdef peer key idx) - callc (count (.-calls cdef)) nodec (count (.-nodes cdef)) + callc (count (.-calls cdef)) frame (->Frame peer slot rank site ctor - (i/int-array (inc callc)) (object-array callc) (object-array callc) - (object-array (inc nodec)) nil)] + (object-array (inc nodec)) (object-array callc) nil)] (define-slot (->Slot frame (- -1 nodec)) ((.-build cdef) frame)) frame)) (defn peer-cancel [^Peer peer] @@ -636,26 +644,6 @@ T T T -> (EXPR T) (aget state peer-slot-writer-opts))))))))) (catch #?(:clj Throwable :cljs :default) e (pst e) (throw e))))) -(defn frame-shared? [^Frame frame] - (if-some [^Slot slot (.-slot frame)] - (let [^Frame parent (.-frame slot) - ^objects children (.-children parent)] - (contains? (aget children (.-id slot)) (.-rank frame))) true)) - -(defn frame-share [^Frame frame] - (let [^Slot slot (.-slot frame) - ^Frame parent (.-frame slot) - ^objects children (.-children parent) - id (.-id slot)] - (aset children id (assoc (aget children id) (.-rank frame) frame)))) - -(defn frame-unshare [^Frame frame] - (let [^Slot slot (.-slot frame) - ^Frame parent (.-frame slot) - ^objects children (.-children parent) - id (.-id slot)] - (aset children id (dissoc (aget children id) (.-rank frame) frame)))) - (defn peer-ack [^Peer peer] ;; TODO ) @@ -730,6 +718,9 @@ T T T -> (EXPR T) [^Slot slot] (.-id slot)) +(defn frame-slot [^Frame frame] + (.-slot frame)) + (defn port-attach [_ ^objects port n] (let [peer (frame-peer (slot-frame (port-slot port)))] (dotimes [_ n] (peer-push peer peer-queue-tap port)))) @@ -738,23 +729,27 @@ T T T -> (EXPR T) (let [peer (frame-peer (slot-frame (port-slot port)))] (dotimes [_ n] (peer-push peer peer-queue-untap port)))) -(defn incseq [^Frame frame expr] - (let [deps (deps expr (.-site (frame-peer frame))) - flow (flow expr)] - (fn [step done] +(deftype Incseq [site expr] + IFn + (#?(:clj invoke :cljs -invoke) [_ step done] + (let [deps (deps expr site)] (reduce-kv port-attach nil deps) - (flow step #(do (reduce-kv port-detach nil deps) (done)))))) + ((flow expr) step #(do (reduce-kv port-detach nil deps) (done)))))) + +(defn incseq-expr [^Incseq incseq] + (.-expr incseq)) + +(defn incseq [^Frame frame expr] + (->Incseq (.-site (frame-peer frame)) expr)) (defn frame-result [^Frame frame] (let [^objects nodes (.-nodes frame)] (aget nodes (dec (alength nodes))))) (defn frame-up [^Frame frame] - (let [result (frame-result frame)] - (reduce-kv port-attach nil - (deps (port-slot result) - (port-site (slot-port (.-slot frame))))) - (port-flow result))) + (reduce-kv port-attach nil + (deps (port-slot (frame-result frame)) + (port-site (slot-port (.-slot frame)))))) (defn frame-down [^Frame frame] (reduce-kv port-detach nil @@ -774,68 +769,83 @@ T T T -> (EXPR T) (recur j k) j)))] (aset buffer j x) buffer)) -(def call-slot-slot 0) -(def call-slot-buffer 1) -(def call-slots 2) - -(defn call-transfer [^objects state {:keys [grow degree shrink permutation change freeze]}] - (try (let [^Slot slot (aget state call-slot-slot) - ^Frame parent (.-frame slot) - ^Peer peer (.-peer parent) - id (.-id slot) - ^ints ranks (.-ranks parent) - site (port-site (slot-port slot)) - size-after (- degree shrink) - ^objects buffer (let [^objects buffer (aget state call-slot-buffer) - cap (alength buffer)] - (if (< degree cap) - buffer (let [b (object-array (loop [cap cap] - (let [cap (bit-shift-left cap 1)] - (if (< degree cap) - cap (recur cap)))))] - #?(:clj (System/arraycopy buffer 0 b 0 cap) - :cljs (dotimes [i cap] (aset b i (aget buffer i)))) - (aset state call-slot-buffer b))))] - (reduce apply-cycle buffer (i/decompose permutation)) - (dotimes [i shrink] - (let [j (+ size-after i)] - (frame-down (aget buffer j)) - (aset buffer j nil))) - {:grow grow - :degree degree - :shrink shrink - :permutation permutation - :freeze freeze - :change (reduce-kv (fn [change i ctor] - (when-some [frame (aget buffer i)] (frame-down frame)) - (let [rank (aget ranks id) - frame (make-frame peer slot rank site ctor)] - (aset buffer i frame) - (aset ranks id (inc rank)) - (assoc change i (frame-up frame)))) - {} change)}) - (catch #?(:clj Throwable :cljs :default) e (pst e) (throw e)))) - -(deftype Call [expr slot] - Expr - (deps [_ site] (deps expr site)) - (flow [_] - (fn [step done] - (let [state (doto (object-array call-slots) - (aset call-slot-slot slot) - (aset call-slot-buffer (object-array 1))) - ps ((flow expr) step done)] - (reify - IFn - (#?(:clj invoke :cljs -invoke) [_] (ps)) - IDeref - (#?(:clj deref :cljs -deref) [_] (call-transfer state @ps))))))) +(deftype CallPs [^objects call ps ^:unsynchronized-mutable ^:mutable ^objects buffer] + IFn + (#?(:clj invoke :cljs -invoke) [_] (ps)) + IDeref + (#?(:clj deref :cljs -deref) [_] + (try (let [{:keys [grow degree shrink permutation change freeze]} @ps + ^objects port (aget call call-slot-port) + ^Slot slot (port-slot port) + ^Frame parent (.-frame slot) + ^Peer peer (.-peer parent) + site (port-site (slot-port slot)) + size-after (- degree shrink) + ^objects buffer (let [cap (alength buffer)] + (if (< degree cap) + buffer (let [b (object-array (loop [cap cap] + (let [cap (bit-shift-left cap 1)] + (if (< degree cap) + cap (recur cap)))))] + #?(:clj (System/arraycopy buffer 0 b 0 cap) + :cljs (dotimes [i cap] (aset b i (aget buffer i)))) + (set! buffer b))))] + (reduce apply-cycle buffer (i/decompose permutation)) + (dotimes [i shrink] + (let [j (+ size-after i)] + (frame-down (aget buffer j)) + (aset buffer j nil))) + {:grow grow + :degree degree + :shrink shrink + :permutation permutation + :freeze freeze + :change (reduce-kv (fn [change i ctor] + (when-some [frame (aget buffer i)] (frame-down frame)) + (let [rank (aget call call-slot-rank) + frame (make-frame peer slot rank site ctor)] + (aset buffer i frame) + (aset call call-slot-rank (inc rank)) + (frame-up frame) + (assoc change i frame))) + {} change)}) + (catch #?(:clj Throwable :cljs :default) e (pst e) (throw e))))) + +(defn create-call [slot site expr] + (let [call (object-array call-slots)] + (aset call call-slot-port + (make-port slot site + (deps expr site) + (fn [step done] + (->CallPs call + ((flow expr) step done) + (object-array 1))))) + (aset call call-slot-rank (identity 0)) + (aset call call-slot-children {}) + call)) (defn define-call "Defines call site id for given frame." [^Frame frame id expr] - (let [slot (call frame id)] - (define-slot slot (->Call expr slot)))) + (let [^objects tags (.-tags frame)] + (aset tags id (create-call (->Slot frame id) + (if-some [site ((.-calls (frame-cdef frame)) id)] + site (frame-site frame)) expr)) nil)) + +(defn frame-shared? [^Frame frame] + (if-some [^Slot slot (.-slot frame)] + (let [^objects call (frame-call (.-frame slot) (.-id slot))] + (contains? (aget call call-slot-children) (.-rank frame))) true)) + +(defn frame-share [^Frame frame] + (let [^Slot slot (.-slot frame) + ^objects call (frame-call (.-frame slot) (.-id slot))] + (aset call call-slot-children (assoc (aget call call-slot-children) (.-rank frame) frame)))) + +(defn frame-unshare [^Frame frame] + (let [^Slot slot (.-slot frame) + ^objects call (frame-call (.-frame slot) (.-id slot))] + (aset call call-slot-children (dissoc (aget call call-slot-children) (.-rank frame))))) (defn lookup "Returns the value associated with given key in the dynamic environment of given frame." @@ -871,7 +881,7 @@ Returns a peer definition from given definitions and main key. (aset peer-queue-untap (object-array 1)) (aset peer-queue-toggle (object-array 1)) (aset peer-queue-ready (object-array 1))) - (i/int-array peer-queues) state) + (a/int-array peer-queues) state) input (m/stream (m/observe events)) ^Frame root (->> args (eduction (map pure)) @@ -919,7 +929,8 @@ Returns a peer definition from given definitions and main key. (fn [[slot rank ctor]] (if (nil? ctor) (if (nil? slot) - root (get (aget ^objects (.-children (slot-frame slot)) (slot-id slot)) rank)) + root (let [^objects call (frame-call (slot-frame slot) (slot-id slot))] + (get (aget call call-slot-children) rank))) (let [frame (make-frame peer slot rank (port-site (slot-port slot)) ctor)] (frame-share frame) frame)))) "join" (t/read-handler @@ -955,6 +966,23 @@ Returns a peer definition from given definitions and main key. (defn subject-at [^objects arr slot] (fn [!] (aset arr slot !) #(aset arr slot nil))) +#?(:clj + (defmethod print-method Tag [^Tag tag ^Writer w] + (.write w "#Tag[") + (print-method (.-frame tag) w) + (.write w " ") + (print-method (.-index tag) w) + (.write w "]")) + :cljs + (extend-protocol IPrintWithWriter + Tag + (-pr-writer [tag w o] + (-write w "#Tag[") + (-pr-writer (.-frame tag) w o) + (-write w " ") + (-write w (.-index tag)) + (-write w "]")))) + #?(:clj (defmethod print-method Slot [^Slot slot ^Writer w] (.write w "#Slot[") @@ -1021,5 +1049,3 @@ Returns a peer definition from given definitions and main key. (recur ret (dissoc left k)) (recur (assoc ret k f) (merge (dissoc left k) (f :get :deps)))) ret))) - -(def tag) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index ab0c41c8a..a0a16d2fa 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -3,6 +3,7 @@ (:require [hyperfiddle.electric.impl.lang-de2 :as lang] [hyperfiddle.electric.impl.runtime-de :as r] [hyperfiddle.incseq :as i] + [hyperfiddle.electric.impl.mount-point :as mp] [clojure.core :as cc] [clojure.string :as str] [hyperfiddle.rcf :as rcf :refer [tests]] @@ -200,6 +201,9 @@ this tuple. Returns the concatenation of all body results as a single vector. (reduce (cc/fn [ac [nm & fargs]] `(::lang/bindlocal ~nm (hyperfiddle.electric-de/fn ~@fargs) ~ac)) (cons 'do body) sb) sb))) +(defmacro tag [] `(::lang/tag)) +(def mount-point mp/create) + (hyperfiddle.electric-de/defn Dispatch [F static args] (let [offset (count static) arity (+ offset (count args))] diff --git a/src/hyperfiddle/incseq.cljc b/src/hyperfiddle/incseq.cljc index bff9fa817..f61a8ff0d 100644 --- a/src/hyperfiddle/incseq.cljc +++ b/src/hyperfiddle/incseq.cljc @@ -36,11 +36,13 @@ An incremental sequence describes a finite sequence of states varying over time. successive sequence diffs. Incremental sequences are applicative functors with `latest-product` and monads with `latest-concat`. "} hyperfiddle.incseq - (:refer-clojure :exclude [cycle int-array]) - (:require [hyperfiddle.incseq.perm-impl :as p] + (:refer-clojure :exclude [cycle]) + (:require [hyperfiddle.incseq.arrays-impl :as a] + [hyperfiddle.incseq.perm-impl :as p] [hyperfiddle.incseq.diff-impl :as d] [hyperfiddle.incseq.items-impl :as i] [hyperfiddle.incseq.latest-product-impl :as lp] + [hyperfiddle.incseq.latest-concat-impl :as lc] [hyperfiddle.rcf :refer [tests]] [missionary.core :as m]) (:import #?(:clj (clojure.lang IFn IDeref)) @@ -51,20 +53,6 @@ successive sequence diffs. Incremental sequences are applicative functors with ` (defn nop []) - -(defn int-array ^ints [n] - #?(:clj (make-array Integer/TYPE n) - :cljs (let [a (make-array n)] - (dotimes [i n] (aset a i 0)) a))) - - -(defn acopy [source source-offset target target-offset length] - #?(:clj (System/arraycopy source source-offset target target-offset length) - :cljs (dotimes [i length] - (aset target (+ target-offset i) - (aget source (+ source-offset i)))))) - - (deftype Ps [state cancel transfer] IFn (#?(:clj invoke :cljs -invoke) [_] @@ -363,7 +351,7 @@ A collection is fixed iff its size is invariant and its items are immobile. (fn [n t] (let [state (object-array slots) arity (count items) - ready (int-array arity)] + ready (a/int-array arity)] (dotimes [i arity] (aset ready i arity)) (aset state slot-notifier n) (aset state slot-terminator t) @@ -392,244 +380,8 @@ combined with given function. :doc " Returns the incremental sequence defined by the concatenation of incremental sequences defined by given incremental sequence. -"} latest-concat - (let [slot-notifier 0 - slot-terminator 1 - slot-process 2 - slot-buffer 3 - slot-counts 4 - slot-ready 5 - slot-push 6 - slot-live 7 - slot-busy 8 - slot-value 9 - slots 10 - inner-slot-process 0 - inner-slot-index 1 - inner-slots 2] - (letfn [(flush [^objects state] - (loop [i 0] - (if (aget state slot-busy) - (do (aset state slot-busy false) - (try @(aget state slot-process) - (catch #?(:clj Throwable :cljs :default) _)) - (recur i)) - (let [^objects q (aget state slot-ready)] - (if-some [^objects input (aget q i)] - (do (aset q i nil) - (try @(aget input inner-slot-process) - (catch #?(:clj Throwable :cljs :default) _)) - (recur (rem (unchecked-inc-int i) (alength q)))) - (do (aset state slot-push nil) - (if (zero? (aget state slot-live)) - (aget state slot-terminator) nop))))))) - (outer-ready [^objects state] - ((locking state - (aset state slot-busy true) - (if (nil? (aget state slot-push)) - (do (aset state slot-push 0) - (if-some [cb (aget state slot-notifier)] - cb (flush state))) nop)))) - (inner-ready [^objects state ^objects input] - ((locking state - (let [^objects q (aget state slot-ready) - c (alength q)] - (if-some [i (aget state slot-push)] - (do (aset state slot-push - (identity - (if (nil? (aget q i)) - (do (aset q i input) - (rem (unchecked-inc-int i) c)) - (let [n (bit-shift-left c 1) - a (object-array n)] - (aset state slot-ready a) - (acopy q i a i - (unchecked-subtract-int c i)) - (acopy q 0 a c i) - (let [p (unchecked-add-int i c)] - (aset a p input) - (rem (unchecked-inc-int p) n)))))) nop) - (do (aset state slot-push (identity (rem 1 c))) - (aset q 0 input) - (if-some [cb (aget state slot-notifier)] - cb (flush state)))))))) - (terminated [^objects state] - ((locking state - (if (zero? (aset state slot-live (dec (aget state slot-live)))) - (if (nil? (aget state slot-push)) (aget state slot-terminator) nop) nop)))) - (cancel [^objects state] - (locking state - ((aget state slot-process)) - (let [^objects buffer (aget state slot-buffer) - ^ints counts (aget state slot-counts)] - (dotimes [i (aget counts 0)] - (let [^objects inner (aget buffer i)] - ((aget inner inner-slot-process))))))) - (index-in-counts [^ints counts index] - (unchecked-add (bit-shift-right (alength counts) 1) index)) - (compute-offset [^ints counts index l] - (let [delta (unchecked-subtract-int l (aget counts index))] - (loop [o 0, i (int index)] - (aset counts i (unchecked-add-int (aget counts i) delta)) - (case i - 1 o - (recur (if (even? i) - o (unchecked-add o - (aget counts (unchecked-dec-int i)))) - (bit-shift-right i 1)))))) - (split-long-swap [o l c r] - (->> (range o (+ o (min l r))) - (eduction (map (fn [i] (cycle i (+ l c i))))) - (reduce compose {}) - (compose - (case (compare l r) - -1 (p/split-swap (+ o l) (+ l c) (- r l)) - 0 {} - +1 (p/split-swap (+ o r) (- l r) (+ c r)))))) - (ensure-capacity [^objects state grow degree shrink] - (loop [] - (let [counts ^ints (aget state slot-counts) - buffer ^objects (aget state slot-buffer) - length (alength buffer)] - (if (< length degree) - (let [new-length (alength counts) - new-counts (int-array (bit-shift-left new-length 1))] - (acopy buffer 0 (aset state slot-buffer (object-array new-length)) 0 length) - (aset new-counts 1 (aget counts 1)) - (loop [i 1] - (let [j (bit-shift-left i 1)] - (acopy counts i new-counts j i) - (when-not (== j new-length) - (recur j)))) - (aset state slot-counts new-counts) - (recur)) - (loop [i (unchecked-subtract-int degree grow)] - (if (< i degree) - (let [inner (object-array inner-slots)] - (aset buffer i inner) - (aset inner inner-slot-index (identity i)) - (recur (unchecked-inc-int i))) - (aset counts 0 (unchecked-subtract-int degree shrink)))))))) - (swap-buffer [^objects buffer i j] - (let [xi ^objects (aget buffer i) - xj ^objects (aget buffer j)] - (aset xi inner-slot-index j) - (aset xj inner-slot-index i) - (aset buffer i xj) - (aset buffer j xi))) - (transfer [^objects state] - ((locking state - (try - (loop [i 0] - (if (aget state slot-busy) - (do (aset state slot-busy false) - (let [{:keys [grow degree shrink permutation change]} @(aget state slot-process)] - (ensure-capacity state grow degree shrink) - (let [^objects buffer (aget state slot-buffer) - ^ints counts (aget state slot-counts) - global-degree (aget counts 1) - perm (loop [p permutation - q {}] - (case p - {} (reduce - (fn [q index] - (let [^objects inner (aget buffer index) - ^objects inner (if-some [ps (aget inner inner-slot-process)] - (let [clone (object-array inner-slots)] - (aset clone inner-slot-index index) - (aset inner inner-slot-index nil) - (aset buffer index clone) - (ps) clone) inner)] - (aset state slot-live (inc (aget state slot-live))) - (aset inner inner-slot-process - ((change index) #(inner-ready state inner) #(terminated state))) - (let [k (index-in-counts counts index) - l (aget counts k) - o (compute-offset counts k 0) - s (aget counts 1)] - (compose (->> (range o (unchecked-add-int o l)) - (eduction (map (fn [i] (cycle i (unchecked-add-int s i))))) - (reduce compose {})) q)))) - q (sort (keys change))) - (let [[i j] (first p) - k2 (index-in-counts counts (max i j)) - k1 (index-in-counts counts (min i j)) - l2 (aget counts k2) - l1 (aget counts k1) - o2 (compute-offset counts k2 l1) - o1 (compute-offset counts k1 l2)] - (swap-buffer buffer i j) - (recur (compose p (cycle i j)) - (compose (split-long-swap o1 l1 - (unchecked-subtract-int - (unchecked-subtract-int o2 o1) - l1) l2) q)))))] - (dotimes [i shrink] - (let [index (unchecked-dec-int (unchecked-subtract-int degree i)) - ^objects inner (aget buffer index)] - (aset buffer index nil) - (aset inner inner-slot-index nil) - ((aget inner inner-slot-process)) - (compute-offset counts (index-in-counts counts index) 0))) - (aset state slot-value - (combine (aget state slot-value) - {:grow 0 - :degree global-degree - :permutation perm - :shrink (unchecked-subtract global-degree (aget counts 1)) - :change {} - :freeze #{}})))) - (recur i)) - (let [^objects q (aget state slot-ready)] - (if-some [^objects input (aget q i)] - (do (aset q i nil) - (if-some [index (aget input inner-slot-index)] - (let [{:keys [grow degree shrink permutation change freeze]} @(aget input inner-slot-process) - ^ints counts (aget state slot-counts) - global-degree (unchecked-add-int (aget counts 1) grow) - size-before (unchecked-subtract-int degree grow) - size-after (unchecked-subtract-int degree shrink) - offset (compute-offset counts (index-in-counts counts index) size-after) - shift (unchecked-subtract-int global-degree (unchecked-add-int degree offset)) - +offset (partial + offset)] - (aset state slot-value - (combine (aget state slot-value) - {:grow grow - :shrink shrink - :degree global-degree - :permutation (compose - (p/split-swap (unchecked-add-int offset size-after) shrink shift) - (into {} (map (juxt (comp +offset key) (comp +offset val))) permutation) - (p/split-swap (unchecked-add-int offset size-before) shift grow)) - :change (into {} (map (juxt (comp +offset key) val)) change) - :freeze (into #{} (map +offset) freeze)}))) - (try @(aget input inner-slot-process) - (catch #?(:clj Throwable :cljs :default) _))) - (recur (rem (unchecked-inc-int i) (alength q)))) - (do (aset state slot-push nil) - (if (zero? (aget state slot-live)) - (aget state slot-terminator) nop)))))) - (catch #?(:clj Throwable :cljs :default) e - (aset state slot-notifier nil) - (aset state slot-value e) - (cancel state) - (flush state))))) - (let [x (aget state slot-value)] - (aset state slot-value (empty-diff (aget ^ints (aget state slot-counts) 1))) - (if (nil? (aget state slot-notifier)) (throw x) x)))] - (fn [input] - (fn [n t] - (let [state (object-array slots)] - (aset state slot-notifier n) - (aset state slot-terminator t) - (aset state slot-buffer (object-array 1)) - (aset state slot-counts (int-array 2)) - (aset state slot-ready (object-array 1)) - (aset state slot-live (identity 1)) - (aset state slot-busy false) - (aset state slot-value (empty-diff 0)) - (aset state slot-process (input #(outer-ready state) #(terminated state))) - (->Ps state cancel transfer))))))) +"} latest-concat lc/flow) + (def ^{:arglists '([] [sentinel] [sentinel compare]) :doc " diff --git a/src/hyperfiddle/incseq/arrays_impl.cljc b/src/hyperfiddle/incseq/arrays_impl.cljc new file mode 100644 index 000000000..81d448493 --- /dev/null +++ b/src/hyperfiddle/incseq/arrays_impl.cljc @@ -0,0 +1,34 @@ +(ns hyperfiddle.incseq.arrays-impl + (:refer-clojure :exclude [int-array])) + +(defn int-array ^ints [n] + #?(:clj (make-array Integer/TYPE n) + :cljs (let [a (make-array n)] + (dotimes [i n] (aset a i 0)) a))) + +(defn acopy [source source-offset target target-offset length] + #?(:clj (System/arraycopy source source-offset target target-offset length) + :cljs (dotimes [i length] + (aset target (+ target-offset i) + (aget source (+ source-offset i)))))) + +(defn aget-aset [^objects arr i x] + (let [y (aget arr i)] + (aset arr i x) y)) + +(defn weight-tree [size] + (let [o (loop [o 1] + (if (< o size) + (recur (bit-shift-left o 1)) o)) + n (bit-shift-left o 1) + arr (int-array n)] + (loop [f (unchecked-subtract o size) + o o + n n] + (when (< 1 o) + (loop [i (unchecked-subtract n f)] + (when (< i n) + (aset arr i 1) + (recur (unchecked-inc i)))) + (recur (bit-shift-right f 1) + (bit-shift-right o 1) o))) arr)) \ No newline at end of file diff --git a/src/hyperfiddle/incseq/diff_impl.cljc b/src/hyperfiddle/incseq/diff_impl.cljc index b8c68b174..e7198673d 100644 --- a/src/hyperfiddle/incseq/diff_impl.cljc +++ b/src/hyperfiddle/incseq/diff_impl.cljc @@ -91,6 +91,20 @@ :freeze (persistent! f)})))) ([x y & zs] (reduce combine (combine x y) zs))) +(defn subdiff [{:keys [grow shrink degree permutation change freeze]} size offset] + (let [global-degree (unchecked-add-int size grow) + shift (unchecked-subtract-int global-degree (unchecked-add-int degree offset)) + +offset (partial + offset)] + {:grow grow + :shrink shrink + :degree global-degree + :permutation (p/compose + (p/split-swap (unchecked-add-int offset (unchecked-subtract-int degree shrink)) shrink shift) + (into {} (map (juxt (comp +offset key) (comp +offset val))) permutation) + (p/split-swap (unchecked-add-int offset (unchecked-subtract-int degree grow)) shift grow)) + :change (into {} (map (juxt (comp +offset key) val)) change) + :freeze (into #{} (map +offset) freeze)})) + (tests "sequence diffs" (patch-vec [:a :b :c] {:grow 1 diff --git a/src/hyperfiddle/incseq/latest_concat_impl.cljc b/src/hyperfiddle/incseq/latest_concat_impl.cljc new file mode 100644 index 000000000..4d5e78b05 --- /dev/null +++ b/src/hyperfiddle/incseq/latest_concat_impl.cljc @@ -0,0 +1,245 @@ +(ns hyperfiddle.incseq.latest-concat-impl + (:require [hyperfiddle.incseq.arrays-impl :as a] + [hyperfiddle.incseq.perm-impl :as p] + [hyperfiddle.incseq.diff-impl :as d]) + #?(:clj (:import (clojure.lang IFn IDeref)))) + +(def slot-notifier 0) +(def slot-terminator 1) +(def slot-process 2) +(def slot-buffer 3) +(def slot-counts 4) +(def slot-ready 5) +(def slot-push 6) +(def slot-live 7) +(def slot-busy 8) +(def slot-value 9) +(def slots 10) + +(def inner-slot-process 0) +(def inner-slot-index 1) +(def inner-slots 2) + +(defn nop []) + +(defn drain [^objects state] + (loop [i 0] + (if (aget state slot-busy) + (do (aset state slot-busy false) + (try @(aget state slot-process) + (catch #?(:clj Throwable :cljs :default) _)) + (recur i)) + (let [^objects q (aget state slot-ready)] + (if-some [^objects input (aget q i)] + (do (aset q i nil) + (try @(aget input inner-slot-process) + (catch #?(:clj Throwable :cljs :default) _)) + (recur (rem (unchecked-inc-int i) (alength q)))) + (do (aset state slot-push nil) + (if (zero? (aget state slot-live)) + (aget state slot-terminator) nop))))))) + +(defn outer-ready [^objects state] + ((locking state + (aset state slot-busy true) + (if (nil? (aget state slot-push)) + (do (aset state slot-push 0) + (if-some [cb (aget state slot-notifier)] + cb (drain state))) nop)))) + +(defn inner-ready [^objects state ^objects input] + ((locking state + (let [^objects q (aget state slot-ready) + c (alength q)] + (if-some [i (aget state slot-push)] + (do (aset state slot-push + (identity + (if (nil? (aget q i)) + (do (aset q i input) + (rem (unchecked-inc-int i) c)) + (let [n (bit-shift-left c 1) + a (object-array n)] + (aset state slot-ready a) + (a/acopy q i a i + (unchecked-subtract-int c i)) + (a/acopy q 0 a c i) + (let [p (unchecked-add-int i c)] + (aset a p input) + (rem (unchecked-inc-int p) n)))))) nop) + (do (aset state slot-push (identity (rem 1 c))) + (aset q 0 input) + (if-some [cb (aget state slot-notifier)] + cb (drain state)))))))) + +(defn terminated [^objects state] + ((locking state + (if (zero? (aset state slot-live (dec (aget state slot-live)))) + (if (nil? (aget state slot-push)) (aget state slot-terminator) nop) nop)))) + +(defn cancel [^objects state] + (locking state + ((aget state slot-process)) + (let [^objects buffer (aget state slot-buffer) + ^ints counts (aget state slot-counts)] + (dotimes [i (aget counts 0)] + (let [^objects inner (aget buffer i)] + ((aget inner inner-slot-process))))))) + +(defn index-in-counts [^ints counts index] + (unchecked-add (bit-shift-right (alength counts) 1) index)) + +(defn compute-offset [^ints counts index l] + (let [delta (unchecked-subtract-int l (aget counts index))] + (loop [o 0, i (int index)] + (aset counts i (unchecked-add-int (aget counts i) delta)) + (case i + 1 o + (recur (if (even? i) + o (unchecked-add o + (aget counts (unchecked-dec-int i)))) + (bit-shift-right i 1)))))) + +(defn ensure-capacity [^objects state grow degree shrink] + (loop [] + (let [counts ^ints (aget state slot-counts) + buffer ^objects (aget state slot-buffer) + length (alength buffer)] + (if (< length degree) + (let [new-length (alength counts) + new-counts (a/int-array (bit-shift-left new-length 1))] + (a/acopy buffer 0 (aset state slot-buffer (object-array new-length)) 0 length) + (aset new-counts 1 (aget counts 1)) + (loop [i 1] + (let [j (bit-shift-left i 1)] + (a/acopy counts i new-counts j i) + (when-not (== j new-length) + (recur j)))) + (aset state slot-counts new-counts) + (recur)) + (loop [i (unchecked-subtract-int degree grow)] + (if (< i degree) + (let [inner (object-array inner-slots)] + (aset buffer i inner) + (aset inner inner-slot-index (identity i)) + (recur (unchecked-inc-int i))) + (aset counts 0 (unchecked-subtract-int degree shrink)))))))) + +(defn swap-buffer [^objects buffer i j] + (let [xi ^objects (aget buffer i) + xj ^objects (aget buffer j)] + (aset xi inner-slot-index j) + (aset xj inner-slot-index i) + (aset buffer i xj) + (aset buffer j xi))) + +(defn transfer [^objects state] + ((locking state + (try + (loop [i 0] + (if (aget state slot-busy) + (do (aset state slot-busy false) + (let [{:keys [grow degree shrink permutation change]} @(aget state slot-process)] + (ensure-capacity state grow degree shrink) + (let [^objects buffer (aget state slot-buffer) + ^ints counts (aget state slot-counts) + global-degree (aget counts 1) + perm (loop [p permutation + q {}] + (case p + {} (reduce + (fn [q index] + (let [^objects inner (aget buffer index) + ^objects inner (if-some [ps (aget inner inner-slot-process)] + (let [clone (object-array inner-slots)] + (aset clone inner-slot-index index) + (aset inner inner-slot-index nil) + (aset buffer index clone) + (ps) clone) inner)] + (aset state slot-live (inc (aget state slot-live))) + (aset inner inner-slot-process + ((change index) #(inner-ready state inner) #(terminated state))) + (let [k (index-in-counts counts index) + l (aget counts k) + o (compute-offset counts k 0) + s (aget counts 1)] + (p/compose + (->> (range o (unchecked-add-int o l)) + (eduction (map (fn [i] (p/cycle i (unchecked-add-int s i))))) + (reduce p/compose {})) q)))) + q (sort (keys change))) + (let [[i j] (first p) + k2 (index-in-counts counts (max i j)) + k1 (index-in-counts counts (min i j)) + l2 (aget counts k2) + l1 (aget counts k1) + o2 (compute-offset counts k2 l1) + o1 (compute-offset counts k1 l2)] + (swap-buffer buffer i j) + (recur (p/compose p (p/cycle i j)) + (p/compose (p/split-long-swap o1 l1 + (unchecked-subtract-int + (unchecked-subtract-int o2 o1) + l1) l2) q)))))] + (dotimes [i shrink] + (let [index (unchecked-dec-int (unchecked-subtract-int degree i)) + ^objects inner (aget buffer index)] + (aset buffer index nil) + (aset inner inner-slot-index nil) + ((aget inner inner-slot-process)) + (compute-offset counts (index-in-counts counts index) 0))) + (aset state slot-value + (d/combine (aget state slot-value) + {:grow 0 + :degree global-degree + :permutation perm + :shrink (unchecked-subtract global-degree (aget counts 1)) + :change {} + :freeze #{}})))) + (recur i)) + (let [^objects q (aget state slot-ready)] + (if-some [^objects input (aget q i)] + (do (aset q i nil) + (if-some [index (aget input inner-slot-index)] + (let [{:keys [degree shrink] :as d} @(aget input inner-slot-process) + ^ints counts (aget state slot-counts)] + (aset state slot-value + (d/combine (aget state slot-value) + (d/subdiff d (aget counts 1) + (compute-offset counts (index-in-counts counts index) + (unchecked-subtract-int degree shrink)))))) + (try @(aget input inner-slot-process) + (catch #?(:clj Throwable :cljs :default) _))) + (recur (rem (unchecked-inc-int i) (alength q)))) + (do (aset state slot-push nil) + (if (zero? (aget state slot-live)) + (aget state slot-terminator) nop)))))) + (catch #?(:clj Throwable :cljs :default) e + (aset state slot-notifier nil) + (aset state slot-value e) + (cancel state) + (drain state))))) + (let [x (aget state slot-value)] + (aset state slot-value (d/empty-diff (aget ^ints (aget state slot-counts) 1))) + (if (nil? (aget state slot-notifier)) (throw x) x))) + +(deftype Ps [state] + IFn + (#?(:clj invoke :cljs -invoke) [_] + (cancel state)) + IDeref + (#?(:clj deref :cljs -deref) [_] + (transfer state))) + +(defn flow [input] + (fn [n t] + (let [state (object-array slots)] + (aset state slot-notifier n) + (aset state slot-terminator t) + (aset state slot-buffer (object-array 1)) + (aset state slot-counts (a/int-array 2)) + (aset state slot-ready (object-array 1)) + (aset state slot-live (identity 1)) + (aset state slot-busy false) + (aset state slot-value (d/empty-diff 0)) + (aset state slot-process (input #(outer-ready state) #(terminated state))) + (->Ps state)))) \ No newline at end of file diff --git a/src/hyperfiddle/incseq/latest_product_impl.cljc b/src/hyperfiddle/incseq/latest_product_impl.cljc index 19cce8e13..6d77a787c 100644 --- a/src/hyperfiddle/incseq/latest_product_impl.cljc +++ b/src/hyperfiddle/incseq/latest_product_impl.cljc @@ -1,5 +1,6 @@ (ns hyperfiddle.incseq.latest-product-impl - (:require [hyperfiddle.incseq.perm-impl :as p] + (:require [hyperfiddle.incseq.arrays-impl :as a] + [hyperfiddle.incseq.perm-impl :as p] [hyperfiddle.incseq.diff-impl :as d]) #?(:clj (:import (java.util.concurrent.locks Lock ReentrantLock) (clojure.lang IFn IDeref)))) @@ -348,22 +349,7 @@ (aset state slot-freezers (object-array arity)) (aset state slot-processes (object-array arity)) (aset state slot-ready ready) - (aset state slot-counts - (let [o (loop [o 1] - (if (< o arity) - (recur (bit-shift-left o 1)) o)) - n (bit-shift-left o 1) - arr (int-array n)] - (loop [f (unchecked-subtract o arity) - o o - n n] - (when (< 1 o) - (loop [i (unchecked-subtract n f)] - (when (< i n) - (aset arr i 1) - (recur (unchecked-inc i)))) - (recur (bit-shift-right f 1) - (bit-shift-right o 1) o))) arr)) + (aset state slot-counts (a/weight-tree arity)) (aset state slot-live (identity arity)) (reduce-kv input-spawn state diffs) (->Ps state))))) \ No newline at end of file diff --git a/src/hyperfiddle/incseq/perm_impl.cljc b/src/hyperfiddle/incseq/perm_impl.cljc index 7322e9e53..ccd744a1b 100644 --- a/src/hyperfiddle/incseq/perm_impl.cljc +++ b/src/hyperfiddle/incseq/perm_impl.cljc @@ -81,6 +81,16 @@ (eduction (map (partial apply cycle))) (reduce compose (compose)))) +(defn split-long-swap [o l c r] + (->> (range o (+ o (min l r))) + (eduction (map (fn [i] (cycle i (+ l c i))))) + (reduce compose {}) + (compose + (case (compare l r) + -1 (split-swap (+ o l) (+ l c) (- r l)) + 0 {} + +1 (split-swap (+ o r) (- l r) (+ c r)))))) + (tests "permutations" (decompose {0 1, 1 4, 2 3, 3 2, 4 0}) := #{[0 1 4] [2 3]} diff --git a/src/hyperfiddle/kvs.cljc b/src/hyperfiddle/kvs.cljc new file mode 100644 index 000000000..04ef63e9c --- /dev/null +++ b/src/hyperfiddle/kvs.cljc @@ -0,0 +1,6 @@ +(ns hyperfiddle.kvs) + +(defprotocol KVS + (insert! [_ k v]) + (update! [_ k f]) + (remove! [_ k])) \ No newline at end of file diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc index e533d9d93..ed2a9c892 100644 --- a/test/hyperfiddle/electric/impl/compiler_test.cljc +++ b/test/hyperfiddle/electric/impl/compiler_test.cljc @@ -538,7 +538,7 @@ (::lang/call (::lang/ctor 1)) (::lang/tag) (::lang/call (::lang/ctor 2))]) - `[(r/cdef 0 [] [nil nil] nil + `[(r/cdef 0 [] [nil nil nil nil nil] nil (fn [~'frame] (r/define-call ~'frame 2 (r/pure (r/ctor ::Main 1))) (r/define-call ~'frame 4 (r/pure (r/ctor ::Main 2))) diff --git a/test/hyperfiddle/electric/impl/mount_point_test.cljc b/test/hyperfiddle/electric/impl/mount_point_test.cljc new file mode 100644 index 000000000..fd64e37b2 --- /dev/null +++ b/test/hyperfiddle/electric/impl/mount_point_test.cljc @@ -0,0 +1,147 @@ +(ns hyperfiddle.electric.impl.mount-point-test + (:require [hyperfiddle.incseq :as i] + [hyperfiddle.incseq.diff-impl :as d] + [missionary.core :as m] + [hyperfiddle.kvs :as kvs] + [hyperfiddle.electric.impl.runtime-de :as r] + [hyperfiddle.electric.impl.mount-point :as mp] + [clojure.test :refer [deftest is]]) + #?(:clj (:import (java.util LinkedList) + missionary.Cancelled))) + +(defn peer [defs] + (r/->Peer :client defs nil nil nil nil nil)) + +(defn frame [peer slot rank & tags] + (let [tags-array (object-array (count tags)) + frame (r/->Frame peer slot rank nil nil nil tags-array nil)] + (reduce (fn [i tag] + (when tag + (aset tags-array i + (r/create-call + (r/->Slot frame i) + :client (r/effect tag)))) + (inc i)) 0 tags) frame)) + +(defn slot [frame id] + (r/->Slot frame id)) + +(defn queue [] + #?(:clj (let [q (LinkedList.)] + (fn + ([] (.remove q)) + ([x] (.add q x) nil))) + :cljs (let [q (make-array 0)] + (fn + ([] + (when (zero? (alength q)) + (throw (js/Error. "No such element."))) + (.shift q)) + ([x] (.push q x) nil))))) + +(deftest sibling-tags + (let [q (queue) + p (peer {}) + f (frame p nil 0 nil nil nil) + mp (doto (mp/create) + (kvs/insert! (r/tag f 0) :foo) + (kvs/insert! (r/tag f 1) :bar) + (kvs/insert! (r/tag f 2) :baz)) + ps (mp #(q :step) #(q :done))] + (is (= (q) :step)) + (is (= @ps {:grow 3 + :degree 3 + :shrink 0 + :permutation {} + :change {0 :foo, 1 :bar, 2 :baz} + :freeze #{}})) + (kvs/update! mp (r/tag f 1) (constantly :BAR)) + (is (= (q) :step)) + (kvs/remove! mp (r/tag f 0)) + (is (= @ps {:grow 0 + :degree 3 + :shrink 1 + :permutation {0 1, 1 2, 2 0} + :change {0 :BAR} + :freeze #{}})) + (kvs/remove! mp (r/tag f 1)) + (is (= (q) :step)) + (kvs/remove! mp (r/tag f 2)) + (is (= @ps {:grow 0 + :degree 2 + :shrink 2 + :permutation {0 1, 1 0} + :change {} + :freeze #{}})) + (ps) + (is (= (q) :step)) + (is (thrown? Cancelled @ps)) + (is (= (q) :done)))) + +(deftest cousin-tags + (let [q (queue) + p (peer {:cdef [(r/cdef 0 [] [] nil (fn [frame] (r/pure nil)))]}) + r (frame p nil 0 + (m/observe (fn [!] (! (d/empty-diff 0)) (q !) #(q :dispose)))) + f1 (frame p (slot r 0) 0 nil) + f2 (frame p (slot r 0) 1 nil) + mp (doto (mp/create) + (kvs/insert! (r/tag f1 0) :foo) + (kvs/insert! (r/tag f2 0) :bar)) + ps (mp #(q :step) #(q :done))] + (is (= (q) :step)) + (is (= @ps (i/empty-diff 0))) + (let [diff! (q)] + (diff! {:grow 2 + :degree 2 + :shrink 0 + :permutation {} + :change {0 (r/ctor :cdef 0) + 1 (r/ctor :cdef 0)} + :freeze #{}}) + (is (= (q) :step)) + (is (= @ps {:grow 2 + :degree 2 + :shrink 0 + :permutation {} + :change {0 :foo, 1 :bar} + :freeze #{}})) + (diff! {:grow 0 + :degree 2 + :shrink 0 + :permutation {0 1, 1 0} + :change {} + :freeze #{}}) + (is (= (q) :step)) + (is (= @ps {:grow 0 + :degree 2 + :shrink 0 + :permutation {0 1, 1 0} + :change {} + :freeze #{}})) + (diff! {:grow 0 + :degree 2 + :shrink 1 + :permutation {} + :change {} + :freeze #{}}) + (is (= (q) :step)) + (is (= @ps {:grow 0 + :degree 2 + :shrink 1 + :permutation {} + :change {} + :freeze #{}})) + (kvs/update! mp (r/tag f2 0) (constantly :baz)) + (is (= (q) :step)) + (is (= @ps {:grow 0 + :degree 1 + :shrink 0 + :permutation {} + :change {0 :baz} + :freeze #{}})) + (ps) + (is (= (q) :step)) + (is (= (q) :dispose)) + (is (thrown? Cancelled @ps)) + (is (= (q) :done))))) \ No newline at end of file From 627250fc93c4d7c339707319431188b486be8348 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Tue, 28 May 2024 16:27:05 +0200 Subject: [PATCH 236/428] incseq combine optimization : unmove-tail --- src/hyperfiddle/incseq/diff_impl.cljc | 25 +++---- .../electric/impl/mount_point_test.cljc | 2 +- test/hyperfiddle/incseq/diff_impl_test.cljc | 65 +++++++++++++++++++ 3 files changed, 80 insertions(+), 12 deletions(-) create mode 100644 test/hyperfiddle/incseq/diff_impl_test.cljc diff --git a/src/hyperfiddle/incseq/diff_impl.cljc b/src/hyperfiddle/incseq/diff_impl.cljc index e7198673d..3c55831b5 100644 --- a/src/hyperfiddle/incseq/diff_impl.cljc +++ b/src/hyperfiddle/incseq/diff_impl.cljc @@ -39,6 +39,16 @@ (change! (:change d)) (persistent!)))))) +(defn unmove-tail [p o d] + (loop [i o + p p] + (if (< i d) + (recur (inc i) + (if-some [j (p i)] + (if (< o j) + (p/compose p (p/cycle i j)) + p) p)) p))) + (defn combine ([x] x) ([x y] @@ -84,7 +94,9 @@ (p/compose (p/rotation i d) p (p/rotation d j)) c f))) {:degree d - :permutation p + :permutation (-> p + (unmove-tail size-before d) + (unmove-tail size-after d)) :grow (unchecked-subtract d size-before) :shrink (unchecked-subtract d size-after) :change (persistent! c) @@ -128,13 +140,4 @@ :shrink 1 :change {0 :f, 1 :g, 2 :h}}) := [:f :g :h] - - (combine - {:degree 1 :grow 1 :permutation {} :shrink 0 :change {0 :a} :freeze #{}} - {:degree 1 :grow 0 :permutation {} :shrink 1 :change {} :freeze #{}}) := - {:degree 0 :grow 0 :permutation {} :shrink 0 :change {} :freeze #{}} - - (combine - {:grow 1 :degree 4 :permutation (p/rotation 3 1) :shrink 2 :change {1 :e} :freeze #{}} - {:grow 2 :degree 4 :permutation (p/rotation 1 3) :shrink 1 :change {0 :f 1 :g 2 :h} :freeze #{}}) := - {:degree 5 :grow 2 :shrink 2 :permutation (p/compose (p/cycle 2 4) (p/cycle 1 3)) :change {0 :f, 1 :g, 2 :h} :freeze #{}}) \ No newline at end of file + ) \ No newline at end of file diff --git a/test/hyperfiddle/electric/impl/mount_point_test.cljc b/test/hyperfiddle/electric/impl/mount_point_test.cljc index fd64e37b2..c87750e8d 100644 --- a/test/hyperfiddle/electric/impl/mount_point_test.cljc +++ b/test/hyperfiddle/electric/impl/mount_point_test.cljc @@ -70,7 +70,7 @@ (is (= @ps {:grow 0 :degree 2 :shrink 2 - :permutation {0 1, 1 0} + :permutation {} :change {} :freeze #{}})) (ps) diff --git a/test/hyperfiddle/incseq/diff_impl_test.cljc b/test/hyperfiddle/incseq/diff_impl_test.cljc new file mode 100644 index 000000000..7e97bab4f --- /dev/null +++ b/test/hyperfiddle/incseq/diff_impl_test.cljc @@ -0,0 +1,65 @@ +(ns hyperfiddle.incseq.diff-impl-test + (:require [hyperfiddle.incseq.diff-impl :as d] + [hyperfiddle.incseq.perm-impl :as p] + [clojure.test :refer [deftest is]])) + +(deftest combine-simple + (is (= (d/combine + {:grow 1 + :degree 1 + :shrink 0 + :permutation {} + :change {0 :a} + :freeze #{}} + {:grow 0 + :degree 1 + :shrink 1 + :permutation {} + :change {} + :freeze #{}}) + {:grow 0 + :degree 0 + :shrink 0 + :permutation {} + :change {} + :freeze #{}})) + (is (= (d/combine + {:grow 1 + :degree 4 + :shrink 2 + :permutation (p/rotation 3 1) + :change {1 :e} + :freeze #{}} + {:grow 2 + :degree 4 + :shrink 1 + :permutation (p/rotation 1 3) + :change {0 :f 1 :g 2 :h} + :freeze #{}}) + {:grow 2 + :degree 5 + :shrink 2 + :permutation (p/compose (p/cycle 2 4) (p/cycle 1 3)) + :change {0 :f, 1 :g, 2 :h} + :freeze #{}}))) + +(deftest combine-grow-dont-move + (is (= (d/combine + {:grow 2 + :degree 2 + :shrink 0 + :permutation {} + :change {0 :x1, 1 :y1} + :freeze #{}} + {:grow 3 + :shrink 0 + :degree 5 + :permutation {0 2, 1 3, 2 4, 3 0, 4 1} + :change {0 :x0, 1 :y0, 2 :z0} + :freeze #{}}) + {:grow 5 + :degree 5 + :shrink 0 + :permutation {} + :change {3 :x1, 4 :y1, 0 :x0, 1 :y0, 2 :z0} + :freeze #{}}))) \ No newline at end of file From b35cd6f03f0771f39ec9ecbc56419b5eb350462a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Tue, 28 May 2024 16:30:13 +0200 Subject: [PATCH 237/428] latest-concat - fix input flush --- src/hyperfiddle/incseq.cljc | 58 +-- .../incseq/latest_concat_impl.cljc | 363 +++++++++--------- test/hyperfiddle/electric_de_test.cljc | 39 +- .../incseq/latest_concat_impl_test.cljc | 264 +++++++++++++ 4 files changed, 476 insertions(+), 248 deletions(-) create mode 100644 test/hyperfiddle/incseq/latest_concat_impl_test.cljc diff --git a/src/hyperfiddle/incseq.cljc b/src/hyperfiddle/incseq.cljc index f61a8ff0d..381dff84a 100644 --- a/src/hyperfiddle/incseq.cljc +++ b/src/hyperfiddle/incseq.cljc @@ -859,63 +859,7 @@ Returns the size of `incseq` as a continuous flow. (q {:grow 0 :degree 2 :shrink 1 :permutation {} :change {} :freeze #{}}) @ps := {:degree 4 :grow 0 :shrink 2 :permutation {1 2, 2 1} :change {} :freeze #{}}) - (let [q (queue) - ps ((latest-concat (fn [n t] (q n) (->Ps q #(% :cancel) #(%)))) - #(q :step) #(q :done)) - n (q)] - (n) - (q) := :step - (q {:grow 2 :degree 2 :shrink 0 :permutation {} :freeze #{} - :change {0 (fn [n t] (n) (->Ps q #(% :cancel) #(%))) - 1 (fn [n t] (n) (->Ps q #(% :cancel) #(%)))}}) - (q {:grow 3 :shrink 0 :degree 3 :permutation {} :change {0 :x0 1 :y0 2 :z0} :freeze #{}}) - (q {:grow 2 :shrink 0 :degree 2 :permutation {} :change {0 :x1 1 :y1} :freeze #{}}) - @ps := {:degree 5, :permutation {}, :grow 5, :shrink 0, :change {0 :x0, 1 :y0, 2 :z0, 3 :x1, 4 :y1}, :freeze #{}}) - - (let [q (queue) - ps ((latest-concat (fn [n t] (q n) (->Ps q #(% :cancel) #(%)))) - #(q :step) #(q :done)) - n (q)] - (n) - (q) := :step - (q {:grow 1 :degree 1 :shrink 0 :permutation {} :freeze #{} - :change {0 (fn [n t] (n) (->Ps q #(% :cancel) #(%)))}}) - (q {:grow 1 :degree 1 :shrink 0 :permutation {} :change {0 :foo} :freeze #{}}) - @ps := {:degree 1, :permutation {}, :grow 1, :shrink 0, :change {0 :foo}, :freeze #{}} - (n) - (q) := :step - (q {:grow 0 :degree 1 :shrink 0 :permutation {} :freeze #{} - :change {0 (fn [n t] (n) (->Ps q #(% :cancel) #(%)))}}) - (q {:grow 1 :degree 1 :shrink 0 :permutation {} :change {0 :foo} :freeze #{}}) - @ps := {:degree 2, :permutation {0 1, 1 0}, :grow 1, :shrink 1, :change {0 :foo}, :freeze #{}} - (q) := :cancel) - - (let [q (queue) - ps ((latest-concat (fn [n t] (q n) (->Ps q #(% :cancel) #(%)))) - #(q :step) #(q :done)) - n (q)] - (n) - (q) := :step - (q {:grow 2 :degree 2 :shrink 0 :permutation {} :freeze #{} - :change {0 (fn [n t] (n) (->Ps q #(% :cancel) #(%))) - 1 (fn [n t] (n) (->Ps q #(% :cancel) #(%)))}}) - (q {:grow 0 :shrink 0 :degree 0 :permutation {} :change {} :freeze #{}}) - (q {:grow 0 :shrink 0 :degree 0 :permutation {} :change {} :freeze #{}}) - @ps := {:degree 0, :permutation {}, :grow 0, :shrink 0, :change {}, :freeze #{}} - (n) - (q) := :step - (q {:grow 0 :degree 2 :shrink 0 :permutation {} :freeze #{} - :change {1 (fn [n t] (n) (->Ps q #(% :cancel) #(%)))}}) - (q {:grow 1 :degree 1 :shrink 0 :permutation {} :change {0 "hello"} :freeze #{}}) - @ps := {:degree 1 :permutation {} :grow 1 :shrink 0 :change {0 "hello"} :freeze #{}} - (q) := :cancel - (n) - (q) := :step - (q {:grow 0 :degree 2 :shrink 0 :permutation {} :freeze #{} - :change {0 (fn [n t] (n) (->Ps q #(% :cancel) #(%)))}}) - (q {:grow 1 :degree 1 :shrink 0 :permutation {} :change {0 "hello"} :freeze #{}}) - @ps := {:degree 2 :permutation {0 1, 1 0} :grow 1 :shrink 0 :change {0 "hello"} :freeze #{}} - (q) := :cancel))) + )) (comment diff --git a/src/hyperfiddle/incseq/latest_concat_impl.cljc b/src/hyperfiddle/incseq/latest_concat_impl.cljc index 4d5e78b05..20fe00edb 100644 --- a/src/hyperfiddle/incseq/latest_concat_impl.cljc +++ b/src/hyperfiddle/incseq/latest_concat_impl.cljc @@ -2,88 +2,85 @@ (:require [hyperfiddle.incseq.arrays-impl :as a] [hyperfiddle.incseq.perm-impl :as p] [hyperfiddle.incseq.diff-impl :as d]) - #?(:clj (:import (clojure.lang IFn IDeref)))) + #?(:clj (:import (clojure.lang IFn IDeref) + (java.util.concurrent.locks ReentrantLock)))) -(def slot-notifier 0) -(def slot-terminator 1) -(def slot-process 2) +(def slot-step 0) +(def slot-done 1) +(def slot-lock 2) (def slot-buffer 3) (def slot-counts 4) -(def slot-ready 5) -(def slot-push 6) -(def slot-live 7) -(def slot-busy 8) -(def slot-value 9) -(def slots 10) - -(def inner-slot-process 0) -(def inner-slot-index 1) -(def inner-slots 2) - -(defn nop []) - -(defn drain [^objects state] - (loop [i 0] - (if (aget state slot-busy) - (do (aset state slot-busy false) - (try @(aget state slot-process) - (catch #?(:clj Throwable :cljs :default) _)) - (recur i)) - (let [^objects q (aget state slot-ready)] - (if-some [^objects input (aget q i)] - (do (aset q i nil) - (try @(aget input inner-slot-process) - (catch #?(:clj Throwable :cljs :default) _)) - (recur (rem (unchecked-inc-int i) (alength q)))) - (do (aset state slot-push nil) - (if (zero? (aget state slot-live)) - (aget state slot-terminator) nop))))))) +(def slot-queue 5) +(def slot-alive 6) +(def slot-ready 7) +(def slot-pending 8) +(def slot-cancelled 9) +(def slot-process 10) +(def slots 11) + +(def inner-slot-state 0) +(def inner-slot-queue 1) +(def inner-slot-index 2) +(def inner-slot-process 3) +(def inner-slots 4) + +(defn enter [^objects state] + #?(:clj (let [^ReentrantLock lock (aget state slot-lock) + held (.isHeldByCurrentThread lock)] + (.lock lock) held) + :cljs (let [held (aget state slot-lock)] + (aset state slot-lock true) held))) + +(defn unlock [^objects state held] + #?(:clj (.unlock ^ReentrantLock (aget state slot-lock)) + :cljs (aset state slot-lock held))) + +(defn exit [^objects state held] + (let [step (aget state slot-step) + done (aget state slot-done)] + (if (or held (aget state slot-pending)) + (unlock state held) + (if (or (some? (aget state slot-queue)) (aget state slot-ready)) + (do (aset state slot-pending true) + (unlock state held) (step)) + (if (zero? (aget state slot-alive)) + (do (unlock state held) (done)) + (unlock state held)))))) (defn outer-ready [^objects state] - ((locking state - (aset state slot-busy true) - (if (nil? (aget state slot-push)) - (do (aset state slot-push 0) - (if-some [cb (aget state slot-notifier)] - cb (drain state))) nop)))) - -(defn inner-ready [^objects state ^objects input] - ((locking state - (let [^objects q (aget state slot-ready) - c (alength q)] - (if-some [i (aget state slot-push)] - (do (aset state slot-push - (identity - (if (nil? (aget q i)) - (do (aset q i input) - (rem (unchecked-inc-int i) c)) - (let [n (bit-shift-left c 1) - a (object-array n)] - (aset state slot-ready a) - (a/acopy q i a i - (unchecked-subtract-int c i)) - (a/acopy q 0 a c i) - (let [p (unchecked-add-int i c)] - (aset a p input) - (rem (unchecked-inc-int p) n)))))) nop) - (do (aset state slot-push (identity (rem 1 c))) - (aset q 0 input) - (if-some [cb (aget state slot-notifier)] - cb (drain state)))))))) + (let [held (enter state)] + (if (some? (aget state slot-step)) + (aset state slot-ready true) + (try @(aget state slot-process) + (catch #?(:clj Throwable :cljs :default) _))) + (exit state held))) + +(defn inner-ready [^objects inner] + (let [^objects state (aget inner inner-slot-state) + held (enter state)] + (if (nil? (aget inner inner-slot-index)) + (try @(aget inner inner-slot-process) + (catch #?(:clj Throwable :cljs :default) _)) + (do (aset inner inner-slot-queue (aget state slot-queue)) + (aset state slot-queue inner))) + (exit state held))) (defn terminated [^objects state] - ((locking state - (if (zero? (aset state slot-live (dec (aget state slot-live)))) - (if (nil? (aget state slot-push)) (aget state slot-terminator) nop) nop)))) + (let [held (enter state)] + (aset state slot-alive (dec (aget state slot-alive))) + (exit state held))) (defn cancel [^objects state] - (locking state - ((aget state slot-process)) - (let [^objects buffer (aget state slot-buffer) - ^ints counts (aget state slot-counts)] - (dotimes [i (aget counts 0)] - (let [^objects inner (aget buffer i)] - ((aget inner inner-slot-process))))))) + (let [held (enter state)] + (when-not (aget state slot-cancelled) + (aset state slot-cancelled true) + ((aget state slot-process)) + (let [^objects buffer (aget state slot-buffer) + ^ints counts (aget state slot-counts)] + (dotimes [i (aget counts 0)] + (let [^objects inner (aget buffer i)] + ((aget inner inner-slot-process)))))) + (exit state held))) (defn index-in-counts [^ints counts index] (unchecked-add (bit-shift-right (alength counts) 1) index)) @@ -99,10 +96,17 @@ (aget counts (unchecked-dec-int i)))) (bit-shift-right i 1)))))) +(defn make-inner [^objects state index] + (let [inner (object-array inner-slots)] + (aset inner inner-slot-state state) + (aset inner inner-slot-index index) + (aset inner inner-slot-queue inner) + inner)) + (defn ensure-capacity [^objects state grow degree shrink] (loop [] - (let [counts ^ints (aget state slot-counts) - buffer ^objects (aget state slot-buffer) + (let [^ints counts (aget state slot-counts) + ^objects buffer (aget state slot-buffer) length (alength buffer)] (if (< length degree) (let [new-length (alength counts) @@ -118,10 +122,8 @@ (recur)) (loop [i (unchecked-subtract-int degree grow)] (if (< i degree) - (let [inner (object-array inner-slots)] - (aset buffer i inner) - (aset inner inner-slot-index (identity i)) - (recur (unchecked-inc-int i))) + (do (aset buffer i (make-inner state i)) + (recur (unchecked-inc-int i))) (aset counts 0 (unchecked-subtract-int degree shrink)))))))) (defn swap-buffer [^objects buffer i j] @@ -133,94 +135,106 @@ (aset buffer j xi))) (defn transfer [^objects state] - ((locking state - (try - (loop [i 0] - (if (aget state slot-busy) - (do (aset state slot-busy false) - (let [{:keys [grow degree shrink permutation change]} @(aget state slot-process)] - (ensure-capacity state grow degree shrink) - (let [^objects buffer (aget state slot-buffer) - ^ints counts (aget state slot-counts) - global-degree (aget counts 1) - perm (loop [p permutation - q {}] - (case p - {} (reduce - (fn [q index] - (let [^objects inner (aget buffer index) - ^objects inner (if-some [ps (aget inner inner-slot-process)] - (let [clone (object-array inner-slots)] - (aset clone inner-slot-index index) - (aset inner inner-slot-index nil) - (aset buffer index clone) - (ps) clone) inner)] - (aset state slot-live (inc (aget state slot-live))) - (aset inner inner-slot-process - ((change index) #(inner-ready state inner) #(terminated state))) - (let [k (index-in-counts counts index) - l (aget counts k) - o (compute-offset counts k 0) - s (aget counts 1)] - (p/compose - (->> (range o (unchecked-add-int o l)) - (eduction (map (fn [i] (p/cycle i (unchecked-add-int s i))))) - (reduce p/compose {})) q)))) - q (sort (keys change))) - (let [[i j] (first p) - k2 (index-in-counts counts (max i j)) - k1 (index-in-counts counts (min i j)) - l2 (aget counts k2) - l1 (aget counts k1) - o2 (compute-offset counts k2 l1) - o1 (compute-offset counts k1 l2)] - (swap-buffer buffer i j) - (recur (p/compose p (p/cycle i j)) - (p/compose (p/split-long-swap o1 l1 - (unchecked-subtract-int - (unchecked-subtract-int o2 o1) - l1) l2) q)))))] - (dotimes [i shrink] - (let [index (unchecked-dec-int (unchecked-subtract-int degree i)) - ^objects inner (aget buffer index)] - (aset buffer index nil) - (aset inner inner-slot-index nil) - ((aget inner inner-slot-process)) - (compute-offset counts (index-in-counts counts index) 0))) - (aset state slot-value - (d/combine (aget state slot-value) - {:grow 0 - :degree global-degree - :permutation perm - :shrink (unchecked-subtract global-degree (aget counts 1)) - :change {} - :freeze #{}})))) - (recur i)) - (let [^objects q (aget state slot-ready)] - (if-some [^objects input (aget q i)] - (do (aset q i nil) - (if-some [index (aget input inner-slot-index)] - (let [{:keys [degree shrink] :as d} @(aget input inner-slot-process) - ^ints counts (aget state slot-counts)] - (aset state slot-value - (d/combine (aget state slot-value) - (d/subdiff d (aget counts 1) - (compute-offset counts (index-in-counts counts index) - (unchecked-subtract-int degree shrink)))))) - (try @(aget input inner-slot-process) - (catch #?(:clj Throwable :cljs :default) _))) - (recur (rem (unchecked-inc-int i) (alength q)))) - (do (aset state slot-push nil) - (if (zero? (aget state slot-live)) - (aget state slot-terminator) nop)))))) - (catch #?(:clj Throwable :cljs :default) e - (aset state slot-notifier nil) - (aset state slot-value e) - (cancel state) - (drain state))))) - (let [x (aget state slot-value)] - (aset state slot-value (d/empty-diff (aget ^ints (aget state slot-counts) 1))) - (if (nil? (aget state slot-notifier)) (throw x) x))) + (let [held (enter state)] + (try + (loop [diff (d/empty-diff (aget ^ints (aget state slot-counts) 1))] + (if (aget state slot-ready) + (do (aset state slot-ready false) + (let [{:keys [grow degree shrink permutation change]} @(aget state slot-process)] + (ensure-capacity state grow degree shrink) + (let [^objects buffer (aget state slot-buffer) + ^ints counts (aget state slot-counts) + global-degree (aget counts 1) + perm (loop [p permutation + q {}] + (case p + {} (reduce + (fn [q index] + (aset state slot-alive (inc (aget state slot-alive))) + (let [^objects inner (aget buffer index) + ^objects inner (if-some [ps (aget inner inner-slot-process)] + (do (aset inner inner-slot-index nil) (ps) + (aset buffer index (make-inner state index))) + inner) + ps ((change index) #(inner-ready inner) #(terminated state))] + (aset inner inner-slot-process ps) + (when (aget state slot-cancelled) (ps)) + (let [k (index-in-counts counts index) + l (aget counts k) + o (compute-offset counts k 0) + s (aget counts 1)] + (p/compose + (->> (range o (unchecked-add-int o l)) + (eduction (map (fn [i] (p/cycle i (unchecked-add-int s i))))) + (reduce p/compose {})) q)))) + q (sort (keys change))) + (let [[i j] (first p) + k2 (index-in-counts counts (max i j)) + k1 (index-in-counts counts (min i j)) + l2 (aget counts k2) + l1 (aget counts k1) + o2 (compute-offset counts k2 l1) + o1 (compute-offset counts k1 l2)] + (swap-buffer buffer i j) + (recur (p/compose p (p/cycle i j)) + (p/compose (p/split-long-swap o1 l1 + (unchecked-subtract-int + (unchecked-subtract-int o2 o1) + l1) l2) q)))))] + (dotimes [i shrink] + (let [index (unchecked-dec-int (unchecked-subtract-int degree i)) + ^objects inner (aget buffer index)] + (aset buffer index nil) + (aset inner inner-slot-index nil) + ((aget inner inner-slot-process)) + (compute-offset counts (index-in-counts counts index) 0))) + (recur (d/combine diff + {:grow 0 + :degree global-degree + :permutation perm + :shrink (unchecked-subtract global-degree (aget counts 1)) + :change {} + :freeze #{}}))))) + (if-some [^objects inner (aget state slot-queue)] + (do (aset state slot-queue (aget inner inner-slot-queue)) + (aset inner inner-slot-queue inner) + (recur (if-some [index (aget inner inner-slot-index)] + (let [{:keys [degree shrink] :as d} @(aget inner inner-slot-process) + ^ints counts (aget state slot-counts)] + (d/combine diff + (d/subdiff d (aget counts 1) + (compute-offset counts (index-in-counts counts index) + (unchecked-subtract-int degree shrink))))) + (do (try @(aget inner inner-slot-process) + (catch #?(:clj Throwable :cljs :default) _)) + diff)))) + (do (aset state slot-pending false) + (exit state held) diff)))) + (catch #?(:clj Throwable :cljs :default) e + (aset state slot-step nil) + (let [^objects buffer (aget state slot-buffer) + ^ints counts (aget state slot-counts)] + (dotimes [i (aget counts 0)] + (let [^objects inner (aget buffer i)] + (aset inner inner-slot-index nil) + ((aget inner inner-slot-process))))) + (when-not (aget state slot-cancelled) + (aset state slot-cancelled true) + ((aget state slot-process))) + (loop [] + (if (aget state slot-ready) + (do (aset state slot-ready false) + (try @(aget state slot-process) + (catch #?(:clj Throwable :cljs :default) _)) + (recur)) + (when-some [^objects inner (aget state slot-queue)] + (aset state slot-queue (aget inner inner-slot-queue)) + (aset inner inner-slot-queue inner) + (try @(aget inner inner-slot-process) + (catch #?(:clj Throwable :cljs :default) _)) + (recur)))) + (aset state slot-pending false) + (exit state held) (throw e))))) (deftype Ps [state] IFn @@ -231,15 +245,16 @@ (transfer state))) (defn flow [input] - (fn [n t] + (fn [step done] (let [state (object-array slots)] - (aset state slot-notifier n) - (aset state slot-terminator t) + (aset state slot-step step) + (aset state slot-done done) + (aset state slot-lock #?(:clj (ReentrantLock.) :cljs false)) (aset state slot-buffer (object-array 1)) (aset state slot-counts (a/int-array 2)) - (aset state slot-ready (object-array 1)) - (aset state slot-live (identity 1)) - (aset state slot-busy false) - (aset state slot-value (d/empty-diff 0)) + (aset state slot-alive (identity 1)) + (aset state slot-ready false) + (aset state slot-cancelled false) + (aset state slot-pending false) (aset state slot-process (input #(outer-ready state) #(terminated state))) (->Ps state)))) \ No newline at end of file diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index bf567ac66..99c52782b 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -365,8 +365,7 @@ (with ((l/single {} (tap (do (tap :a) (tap (e/watch !x))))) tap tap) ; Currently, do is not monadic sequence. ; It's an incremental computation so only rerun what changed in our opinion - % := :a - % := 0 + (hash-set % %) := #{:a 0} % := 0 (swap! !x inc) ; no :a @@ -1243,13 +1242,15 @@ (tap (f state)) (tap (f state :b)) (tap (f state :b :c :d)))) tap tap) - % := [0 [:local 0] [:global 0]] - % := [0 :b [:local 0] [:global 0]] - % := [0 :b '(:c :d) [:local 0] [:global 0]] + (hash-set % % %) := + #{[0 [:local 0] [:global 0]] + [0 :b [:local 0] [:global 0]] + [0 :b '(:c :d) [:local 0] [:global 0]]} (swap! !state3 inc) - % := [1 [:local 1] [:global 1]] - % := [1 :b [:local 1] [:global 1]] - % := [1 :b '(:c :d) [:local 1] [:global 1]])) + (hash-set % % %) := + #{[1 [:local 1] [:global 1]] + [1 :b [:local 1] [:global 1]] + [1 :b '(:c :d) [:local 1] [:global 1]]})) (def !state4 (atom 0)) (tests @@ -1314,8 +1315,9 @@ (is-odd? [x] (if (zero? x) false (is-even? (descent x))))] (tap [(is-even? 0) (is-even? 1) (is-even? 2) (is-even? -2)]) (tap [(is-odd? 0) (is-odd? 2) (is-odd? 3) (is-odd? -3)])))) tap tap) - % := [true false true true] - % := [false false true true] + (hash-set % %) := + #{[true false true true] + [false false true true]} % := [false false true true])) (def !state (atom 0)) @@ -1331,13 +1333,15 @@ (tap (f state)) (tap (f state :b)) (tap (f state :b :c :d)))))) tap tap) - % := [0 [:local 0] [:global 0]] - % := [0 :b [:local 0] [:global 0]] - % := [0 :b '(:c :d) [:local 0] [:global 0]] + (hash-set % % %) := + #{[0 [:local 0] [:global 0]] + [0 :b [:local 0] [:global 0]] + [0 :b '(:c :d) [:local 0] [:global 0]]} (swap! !state inc) - % := [1 [:local 1] [:global 1]] - % := [1 :b [:local 1] [:global 1]] - % := [1 :b '(:c :d) [:local 1] [:global 1]])) + (hash-set % % %) := + #{[1 [:local 1] [:global 1]] + [1 :b [:local 1] [:global 1]] + [1 :b '(:c :d) [:local 1] [:global 1]]})) #?(:clj (tests "e/fn is undefined in clojure-land" @@ -1360,7 +1364,8 @@ (tap (try (eval '(l/single {} (fn [] (e/watch (atom :nomatter))))) (catch Throwable e (ex-message (ex-cause e))))) % := "Electric code (hyperfiddle.electric-de/watch) inside a Clojure function")) -(tests "cycle" +;; 0 can be skipped because tap and reset! are concurrent +(skip "cycle" (with ((l/single {} (let [!F (atom (e/fn [] 0))] (tap ($ (e/watch !F))) diff --git a/test/hyperfiddle/incseq/latest_concat_impl_test.cljc b/test/hyperfiddle/incseq/latest_concat_impl_test.cljc new file mode 100644 index 000000000..d08d1fe1a --- /dev/null +++ b/test/hyperfiddle/incseq/latest_concat_impl_test.cljc @@ -0,0 +1,264 @@ +(ns hyperfiddle.incseq.latest-concat-impl-test + (:require [hyperfiddle.incseq :as i] + [hyperfiddle.incseq.latest-concat-impl :refer [flow]] + [clojure.test :refer [deftest is]]) + (:import #?(:clj (clojure.lang IFn IDeref)) + missionary.Cancelled)) + +(defn queue [] + #?(:clj (let [q (java.util.LinkedList.)] + (fn + ([] (.remove q)) + ([x] (.add q x) nil))) + :cljs (let [q (make-array 0)] + (fn + ([] + (when (zero? (alength q)) + (throw (js/Error. "No such element."))) + (.shift q)) + ([x] (.push q x) nil))))) + +(defn error [^String msg] + (new #?(:clj Error :cljs js/Error) msg)) + +(deftype Ps [cancel transfer] + IFn + (#?(:clj invoke :cljs -invoke) [_] + (cancel)) + IDeref + (#?(:clj deref :cljs -deref) [_] + (transfer))) + +(deftest simple-concat + (let [q (queue) + ps ((flow (fn [step done] (step) (->Ps #(q :cancel) q))) + #(q :step) #(q :done))] + (is (= (q) :step)) + (q {:grow 2 + :degree 2 + :shrink 0 + :permutation {} + :freeze #{} + :change {0 (fn [step done] + (step) + (->Ps #(q :cancel) + #(-> {:grow 3 + :degree 3 + :shrink 0 + :permutation {} + :change {0 :x0 + 1 :y0 + 2 :z0} + :freeze #{}}))) + 1 (fn [step done] + (step) + (->Ps #(q :cancel) + #(-> {:grow 2 + :degree 2 + :shrink 0 + :permutation {} + :change {0 :x1 + 1 :y1} + :freeze #{}})))}}) + (is (= @ps {:degree 5 + :grow 5 + :shrink 0 + :permutation {} + :change {0 :x0 + 1 :y0 + 2 :z0 + 3 :x1 + 4 :y1} + :freeze #{}})))) + +(deftest inner-change + (let [q (queue) + ps ((flow (fn [step done] (q step) (step) (->Ps #(q :cancel) q))) + #(q :step) #(q :done)) + step (q)] + (is (= (q) :step)) + (q {:grow 1 + :degree 1 + :shrink 0 + :permutation {} + :freeze #{} + :change {0 (fn [step done] (step) (->Ps #(q :cancel) q))}}) + (q {:grow 1 + :degree 1 + :shrink 0 + :permutation {} + :change {0 :foo} + :freeze #{}}) + (is (= @ps {:grow 1 + :degree 1 + :shrink 0 + :permutation {} + :change {0 :foo} + :freeze #{}})) + (step) + (is (= (q) :step)) + (q {:grow 0 + :degree 1 + :shrink 0 + :permutation {} + :freeze #{} + :change {0 (fn [step done] (step) (->Ps #(q :cancel) q))}}) + (q {:grow 1 + :degree 1 + :shrink 0 + :permutation {} + :change {0 :foo} + :freeze #{}}) + (is (= @ps {:grow 1 + :degree 2 + :shrink 1 + :permutation {0 1, 1 0} + :change {0 :foo} + :freeze #{}})) + (is (= (q) :cancel)))) + +(deftest outer-change + (let [q (queue) + ps ((flow (fn [step done] (q step) (step) (->Ps #(q :cancel) q))) + #(q :step) #(q :done)) + step (q)] + (is (= (q) :step)) + (q {:grow 2 + :degree 2 + :shrink 0 + :permutation {} + :freeze #{} + :change {0 (fn [step done] (step) (->Ps #(q :cancel) q)) + 1 (fn [step done] (step) (->Ps #(q :cancel) q))}}) + (q {:grow 0 + :degree 0 + :shrink 0 + :permutation {} + :change {} + :freeze #{}}) + (q {:grow 0 + :degree 0 + :shrink 0 + :permutation {} + :change {} + :freeze #{}}) + (is (= @ps {:grow 0 + :degree 0 + :shrink 0 + :permutation {} + :change {} + :freeze #{}})) + (step) + (is (= (q) :step)) + (q {:grow 0 + :degree 2 + :shrink 0 + :permutation {} + :freeze #{} + :change {1 (fn [step done] (step) (->Ps #(q :cancel) q))}}) + (q {:grow 1 + :degree 1 + :shrink 0 + :permutation {} + :change {0 "hello"} + :freeze #{}}) + (is (= @ps {:grow 1 + :degree 1 + :shrink 0 + :permutation {} + :change {0 "hello"} + :freeze #{}})) + (is (= (q) :cancel)) + (step) + (is (= (q) :step)) + (q {:grow 0 + :degree 2 + :shrink 0 + :permutation {} + :freeze #{} + :change {0 (fn [step done] (step) (->Ps #(q :cancel) q))}}) + (q {:grow 1 + :degree 1 + :shrink 0 + :permutation {} + :change {0 "hello"} + :freeze #{}}) + (is (= @ps {:grow 1 + :degree 2 + :shrink 0 + :permutation {0 1, 1 0} + :change {0 "hello"} + :freeze #{}})) + (is (= (q) :cancel)))) + +(deftest flush-after-crash + (let [q (queue) + ps ((flow (fn [step done] + (step) + (->Ps #(q :cancel) + (fn [] + (done) + {:grow 2 + :degree 2 + :shrink 0 + :permutation {} + :change {0 (fn [step done] + (step) + (->Ps #(q :cancel0) + (fn [] + (done) + (throw (error "crash0"))))) + 1 (fn [step done] + (step) + (->Ps #(q :cancel1) + (fn [] + (done) + (throw (error "crash1")))))} + :freeze #{}})))) + #(q :step) #(q :done))] + (is (= (q) :step)) + (is (thrown? #?(:clj Error :cljs js/Error) @ps)) + (is (= (hash-set (q) (q) (q)) #{:cancel :cancel0 :cancel1})) + (is (= (q) :done)))) + +(deftest flush-immediately + (let [q (queue) + ps ((flow (fn [step done] + (q step) + (step) + (->Ps #(q :cancel) + (fn [] + (if (q) + {:grow 1 + :degree 1 + :shrink 0 + :permutation {} + :change {0 (fn [step done] + (step) + (q true) + (->Ps #(q :cancel0) + (fn [] + (if (q) + (do (q step) (i/empty-diff 0)) + (do (done) (throw (Cancelled.)))))))}} + (do (done) + {:grow 0 + :degree 1 + :shrink 1 + :permutation {} + :change {} + :freeze #{}})))))) + #(q :step) #(q :done)) + step (q)] + (is (= (q) :step)) + (q true) + (is (= @ps (i/empty-diff 0))) + (let [step0 (q)] + (step) + (is (= (q) :step)) + (q false) + (is (= @ps (i/empty-diff 0))) + (is (= (q) :cancel0)) + (q false) + (step0) + (is (q) :done)))) \ No newline at end of file From 70d03ead558fd097b9f309af54ec91cc00003b2c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Tue, 28 May 2024 18:15:22 +0200 Subject: [PATCH 238/428] update cljs tests for concurrent effects --- test/hyperfiddle/electric_de_test.cljc | 10 ++++------ test/hyperfiddle/js_calls_test_de.cljs | 20 +++++++------------- 2 files changed, 11 insertions(+), 19 deletions(-) diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index 99c52782b..c582e85ee 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -2041,13 +2041,11 @@ (tests "#js" (def !x (atom 0)) (with ((l/single {} (let [x (e/watch !x)] - (tap #js {:x x}) - (tap #js [:x x]))) tap tap) - (.-x %) := 0 - (aget % 1) := 0 + (tap [(.-x #js {:x x}) + (aget #js [:x x] 1)]))) tap tap) + % := [0 0] (swap! !x inc) - (.-x %) := 1 - (aget % 1) := 1))) + % := [1 1]))) #?(:clj (tests "jvm interop" diff --git a/test/hyperfiddle/js_calls_test_de.cljs b/test/hyperfiddle/js_calls_test_de.cljs index bd315fec9..8190b3452 100644 --- a/test/hyperfiddle/js_calls_test_de.cljs +++ b/test/hyperfiddle/js_calls_test_de.cljs @@ -26,18 +26,12 @@ (tests "js scoped call in electric" (with ((l/single {} - (tap call-test/scope.fn) - (tap (call-test/scope.fn)) ; direct access - (tap (.fn call-test/scope)) ; two-step access - (tap (js/hyperfiddle.js_calls_test_de.scope.fn)) ; global access, requires `(call-test/install)` (let [fn (.-fn call-test/scope)] - (tap (undefined? (fn))) - (tap ((.bind fn call-test/scope))))) tap tap) - % := call-test/scope.fn - % := "value" - % := "value" - % := "value" - % := true - % := "value" - )) + (tap [call-test/scope.fn + (call-test/scope.fn) ; direct access + (.fn call-test/scope) ; two-step access + (js/hyperfiddle.js_calls_test_de.scope.fn) ; global access, requires `(call-test/install)` + (undefined? (fn)) + ((.bind fn call-test/scope))]))) tap tap) + % := [call-test/scope.fn "value" "value" "value" true "value"])) From edd5b85c5a3a06639b2b62c635c76e40b9fc3ba3 Mon Sep 17 00:00:00 2001 From: xificurC Date: Wed, 29 May 2024 09:37:04 +0200 Subject: [PATCH 239/428] fix indent hints --- src/hyperfiddle/electric_local_def.cljc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/hyperfiddle/electric_local_def.cljc b/src/hyperfiddle/electric_local_def.cljc index d7cc3b5df..f2a7095bf 100644 --- a/src/hyperfiddle/electric_local_def.cljc +++ b/src/hyperfiddle/electric_local_def.cljc @@ -88,7 +88,7 @@ #?(:clj (defmacro local+ "Single peer loopback system without whitelist. Returns boot task." - {:style/indent 0} + {:style/indent 1} [conf & body] (let [env (e/normalize-env &env) cenv (merge env (->local-config env) {::lang/me :client} conf) @@ -104,7 +104,7 @@ #?(:clj (defmacro single+ "Single peer system without whitelist. Returns boot task." - {:style/indent 0} + {:style/indent 1} [conf & body] (let [env (merge (e/normalize-env &env) (->single-peer-config &env) conf) ir (lang/analyze env `(do ~@body)) From d38f377615cdc862b2db9aa62229fcbc48b7cb92 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Wed, 29 May 2024 13:30:14 +0200 Subject: [PATCH 240/428] mount-point - fix bad insert while reader active --- .../electric/impl/mount_point.cljc | 2 ++ .../electric/impl/mount_point_test.cljc | 19 +++++++++++++++++++ 2 files changed, 21 insertions(+) diff --git a/src/hyperfiddle/electric/impl/mount_point.cljc b/src/hyperfiddle/electric/impl/mount_point.cljc index 145db8961..239c9c0aa 100644 --- a/src/hyperfiddle/electric/impl/mount_point.cljc +++ b/src/hyperfiddle/electric/impl/mount_point.cljc @@ -498,6 +498,8 @@ ^objects children (aget block block-slot-children)] (aset state slot-blocks (assoc blocks frame block)) (aset children index init) + (when-some [reader (aget state slot-reader)] + (insert-block reader block)) (enqueue-exit state block (- index (r/frame-call-count frame)))))))) (update! [_ tag f] (let [frame (r/tag-frame tag) diff --git a/test/hyperfiddle/electric/impl/mount_point_test.cljc b/test/hyperfiddle/electric/impl/mount_point_test.cljc index c87750e8d..42f2d0300 100644 --- a/test/hyperfiddle/electric/impl/mount_point_test.cljc +++ b/test/hyperfiddle/electric/impl/mount_point_test.cljc @@ -78,6 +78,25 @@ (is (thrown? Cancelled @ps)) (is (= (q) :done)))) +(deftest sibling-tags-insert-after-read + (let [q (queue) + p (peer {}) + f (frame p nil 0 nil nil) + mp (mp/create) + ps (mp #(q :step) #(q :done))] + (is (= (q) :step)) + (is (= @ps (d/empty-diff 0))) + (kvs/insert! mp (r/tag f 0) :foo) + (kvs/insert! mp (r/tag f 1) :bar) + (is (= (q) :step)) + (is (= @ps {:grow 2 + :degree 2 + :shrink 0 + :permutation {} + :change {0 :foo + 1 :bar} + :freeze #{}})))) + (deftest cousin-tags (let [q (queue) p (peer {:cdef [(r/cdef 0 [] [] nil (fn [frame] (r/pure nil)))]}) From eb016dae96937fb6de2210cdf0e14feddf026915 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Thu, 20 Jun 2024 10:43:24 +0200 Subject: [PATCH 241/428] mount-point - redesign --- .../electric/impl/mount_point.cljc | 1138 ++++++++++------- src/hyperfiddle/electric/impl/runtime_de.cljc | 28 +- src/hyperfiddle/electric_de.cljc | 12 +- src/hyperfiddle/incseq.cljc | 154 +-- src/hyperfiddle/incseq/fixed_impl.cljc | 138 ++ .../electric/impl/mount_point_test.cljc | 130 +- test/hyperfiddle/electric_de_test.cljc | 30 + test/hyperfiddle/incseq/fixed_impl_test.cljc | 79 ++ 8 files changed, 988 insertions(+), 721 deletions(-) create mode 100644 src/hyperfiddle/incseq/fixed_impl.cljc create mode 100644 test/hyperfiddle/incseq/fixed_impl_test.cljc diff --git a/src/hyperfiddle/electric/impl/mount_point.cljc b/src/hyperfiddle/electric/impl/mount_point.cljc index 239c9c0aa..788221505 100644 --- a/src/hyperfiddle/electric/impl/mount_point.cljc +++ b/src/hyperfiddle/electric/impl/mount_point.cljc @@ -1,85 +1,118 @@ (ns hyperfiddle.electric.impl.mount-point (:require [hyperfiddle.kvs :refer [KVS]] [hyperfiddle.incseq.arrays-impl :as a] + [hyperfiddle.incseq.fixed-impl :as f] [hyperfiddle.incseq.diff-impl :as d] [hyperfiddle.incseq.perm-impl :as p] [hyperfiddle.electric.impl.runtime-de :as r]) #?(:clj (:import (clojure.lang IFn IDeref) - (java.util.concurrent.locks Lock ReentrantLock)))) + (java.util.concurrent.locks ReentrantLock)))) + +;; TODO +;; do not spawn the call until it has two children at least. +;; maintain a weight tree on each call to prevent buffer traversal when computing local block index +;; use mutable hash maps to decrease GC pressure (item store + block store) +;; support concurrent readers (def slot-lock 0) -(def slot-blocks 1) -(def slot-reader 2) -(def slots 3) +(def slot-peer 1) +(def slot-items 2) +(def slot-reader 3) +(def slot-pending 4) +(def slots 5) (def reader-slot-state 0) (def reader-slot-step 1) (def reader-slot-done 2) -(def reader-slot-queue 3) -(def reader-slot-push 4) +(def reader-slot-call-queue 3) +(def reader-slot-item-queue 4) (def reader-slot-root 5) -(def reader-slots 6) - -(def call-slot-reader 0) -(def call-slot-block 1) -(def call-slot-index 2) -(def call-slot-buffer 3) -(def call-slot-weight 4) -(def call-slot-process 5) -(def call-slots 6) - -(def block-slot-parent 0) -(def block-slot-index 1) -(def block-slot-frame 2) -(def block-slot-children 3) -(def block-slot-weights 4) -(def block-slots 5) +(def reader-slot-alive 6) +(def reader-slot-pending 7) +(def reader-slot-blocks 8) ;; a map associating frames to blocks +(def reader-slots 9) + +(def item-slot-parent 0) ;; parent block, nil if not active +(def item-slot-queue 1) ;; next item, nil if last item +(def item-slot-tag 2) ;; static id +(def item-slot-state 3) ;; any value, this after remove +(def item-slots 4) + +(def call-slot-reader 0) ;; the reader instance, immutable +(def call-slot-parent 1) ;; parent block +(def call-slot-queue 2) ;; next call, nil if last item +(def call-slot-buffer 3) ;; current state of incremental sequence +(def call-slot-children 4) ;; head of the doubly-linked list of child blocks +(def call-slot-weight 5) ;; total count of entries in all mounted child frames +(def call-slot-process 6) ;; the flow process instance +(def call-slots 7) + +(def block-slot-parent 0) ;; the parent call +(def block-slot-index 1) ;; position of frame in parent call, nil if unmounted +(def block-slot-frame 2) ;; static frame +(def block-slot-children 3) ;; static array of child calls +(def block-slot-weights 4) ;; static int array representing a complete binary tree of child weights +(def block-slot-prev 5) ;; previous sibling +(def block-slot-next 6) ;; next sibling +(def block-slots 7) (defn enter [^objects state] - (.lock ^Lock (aget state slot-lock))) - -(defn exit [^objects state] - (.unlock ^Lock (aget state slot-lock))) - -(defn frame->block [^objects state frame] - (get (aget state slot-blocks) frame)) - -(defn make-block [frame] - (let [size (r/frame-call-count frame) - children (object-array size)] - (dotimes [index (alength children)] - (when-not (r/frame-call frame index) - (aset children index children))) - (doto (object-array block-slots) - (aset block-slot-frame frame) - (aset block-slot-children children) - (aset block-slot-weights (a/weight-tree size))))) + #?(:clj (let [^ReentrantLock lock (aget state slot-lock) + held (.isHeldByCurrentThread lock)] + (.lock lock) held) + :cljs (let [held (aget state slot-lock)] + (aset state slot-lock true) held))) + +(defn unlock [^objects state held] + #?(:clj (.unlock ^ReentrantLock (aget state slot-lock)) + :cljs (aset state slot-lock held))) + +(defn exit [^objects state held] + (if held + (unlock state held) + (let [pending (aget state slot-pending)] + (aset state slot-pending nil) + (unlock state held) + (loop [^objects reader pending] + (when-not (nil? reader) + (let [pending (aget reader reader-slot-pending)] + (aset reader reader-slot-pending nil) + ((if (zero? (aget reader reader-slot-alive)) + (aget reader reader-slot-done) + (aget reader reader-slot-step))) + (recur pending))))))) (defn ensure-capacity [^objects buffer cap] (let [n (alength buffer)] (if (< n cap) - (let [b (object-array (bit-shift-left n 1))] + (let [b (object-array + (loop [n n] + (let [n (bit-shift-left n 1)] + (if (< n cap) (recur n) n))))] (a/acopy buffer 0 b 0 n) b) buffer))) +(defn call-slot [^objects call] + (r/frame-slot (aget ^objects (aget call call-slot-children) block-slot-frame))) + (defn call-weight [^objects call] (aget call call-slot-weight)) +(defn block-weight [^objects block] + (let [^ints weights (aget block block-slot-weights)] + (aget weights 1))) + (defn local-block-offset [^objects call index] - (let [^objects buffer (aget call call-slot-buffer) - ^objects reader (aget call call-slot-reader) - ^objects state (aget reader reader-slot-state)] + (let [^objects buffer (aget call call-slot-buffer)] (loop [index index offset 0] (if (zero? index) offset (let [index (dec index)] (recur index - (if-some [^objects block (frame->block state (aget buffer index))] - (let [^ints weights (aget block block-slot-weights)] - (unchecked-add-int offset (aget weights 1))) - offset))))))) + (unchecked-add-int offset + (block-weight (aget buffer index))))))))) -(defn local-tag-offset [^objects block index] +(defn local-call-index [^objects block index] (let [^ints weights (aget block block-slot-weights)] (loop [o 0, i (unchecked-add (bit-shift-right (alength weights) 1) index)] (case i @@ -89,489 +122,626 @@ (aget weights (unchecked-dec i)))) (bit-shift-right i 1)))))) -(defn tag-offset [^objects block index] +(defn call-index [^objects block id] (loop [^objects block block - index index + id id offset 0] - (let [offset (unchecked-add-int offset (local-tag-offset block index))] - (if-some [^objects call (aget block block-slot-parent)] - (recur (aget call call-slot-block) (aget call call-slot-index) - (unchecked-add-int offset (local-block-offset call (aget block block-slot-index)))) - offset)))) - -(defn update-local-weights [^ints weights index delta] - (loop [i (unchecked-add (bit-shift-right (alength weights) 1) index)] - (aset weights i (unchecked-add-int (aget weights i) delta)) - (when (< 1 i) (recur (bit-shift-right i 1))))) - -(defn update-weights [^objects block index delta] - (loop [^objects block block] - (update-local-weights (aget block block-slot-weights) index delta) - (when-some [^objects call (aget block block-slot-parent)] - (aset call call-slot-weight (+ delta (aget call call-slot-weight))) - (recur (aget call call-slot-block))))) + (when-some [index (aget block block-slot-index)] + (let [^objects call (aget block block-slot-parent) + ^objects reader (aget call call-slot-reader) + offset (unchecked-add-int + (unchecked-add-int offset + (local-call-index block id)) + (local-block-offset call index))] + (if (identical? call (aget reader reader-slot-root)) + offset (recur (aget call call-slot-parent) + (r/slot-id (call-slot call)) offset)))))) (defn swap-indices [^objects call i j] (let [^objects buffer (aget call call-slot-buffer) - ^objects reader (aget call call-slot-reader) - ^objects state (aget reader reader-slot-state) - fi (aget buffer i) - fj (aget buffer j)] - (aset buffer i fj) - (aset buffer j fi) - (when-some [^objects block (frame->block state fi)] - (aset block block-slot-index j)) - (when-some [^objects block (frame->block state fj)] - (aset block block-slot-index i)))) - -(defn offset-of [^objects call index] - (unchecked-add-int (local-block-offset call index) - (tag-offset (aget call call-slot-block) - (aget call call-slot-index)))) - -(defn block-weight [^objects block] - (let [^ints weights (aget block block-slot-weights)] - (aget weights 1))) + ^objects bi (aget buffer i) + ^objects bj (aget buffer j)] + (aset buffer i bj) + (aset buffer j bi) + (aset bi block-slot-index j) + (aset bj block-slot-index i))) + +(defn block-index [^objects call id] + (let [^objects reader (aget call call-slot-reader) + offset (local-block-offset call id)] + (if (identical? call (aget reader reader-slot-root)) + offset (when-some [to (call-index (aget call call-slot-parent) + (r/slot-id (call-slot call)))] + (unchecked-add-int offset to))))) (defn current-size [^objects reader] - (if-some [root (aget reader reader-slot-root)] - (block-weight root) 0)) + (if-some [^objects call (aget reader reader-slot-root)] + (aget call call-slot-weight) 0)) (defn weight-between [^objects call i j] - (let [^objects buffer (aget call call-slot-buffer) - ^objects reader (aget call call-slot-reader) - ^objects state (aget reader reader-slot-state)] + (let [^objects buffer (aget call call-slot-buffer)] (loop [i i w 0] (let [i (unchecked-inc-int i)] (if (== i j) w (recur i - (if-some [^objects block (frame->block state (aget buffer i))] + (if-some [^objects block (aget buffer i)] (unchecked-add-int w (block-weight block)) w))))))) -(defn drain-exit [^objects reader] - (loop [pull 0] - (let [^objects queue (aget reader reader-slot-queue)] - (when-some [^objects block (aget queue pull)] - (let [pull+ (unchecked-inc-int pull) - index (aget queue pull+) - frame (aget block block-slot-frame) - ^objects children (aget block block-slot-children)] - (when (r/frame-call frame index) - (let [^objects call (aget children index)] - (try @(aget call call-slot-process) - (catch #?(:clj Throwable :cljs :default) _)))) - (recur (rem (unchecked-inc-int pull+) (alength queue))))))) - (aset reader reader-slot-push nil) - (exit (aget reader reader-slot-state))) - -(defn enqueue [^objects reader ^objects block index] - (let [^objects queue (aget reader reader-slot-queue) - cap (alength queue)] - (if-some [i (aget reader reader-slot-push)] - (do (aset reader reader-slot-push - (identity - (if (nil? (aget queue i)) - (let [i+ (unchecked-inc-int i)] - (aset queue i block) - (aset queue i+ index) - (rem (unchecked-inc-int i+) cap)) - (let [n (bit-shift-left cap 1) - q (object-array n)] - (aset reader reader-slot-queue q) - (a/acopy queue i q i - (unchecked-subtract-int cap i)) - (a/acopy queue 0 q cap i) - (let [i (unchecked-add-int i cap) - i+ (unchecked-inc-int i)] - (aset q i block) - (aset q i+ index) - (rem (unchecked-inc-int i+) n)))))) - false) - (do (aset reader reader-slot-push (identity (rem 2 cap))) - (aset queue 0 block) - (aset queue 1 index) - true)))) - -(defn step-exit [^objects reader] - (let [step (aget reader reader-slot-step)] - (exit (aget reader reader-slot-state)) (step))) - -(defn done-exit [^objects reader] - (let [done (aget reader reader-slot-done) - live (aset reader reader-slot-root - (dec (aget reader reader-slot-root)))] - (exit (aget reader reader-slot-state)) - (when (zero? live) (done)))) - -(defn mount-block [^objects reader ^objects block] +(defn reader-pending [^objects reader] + (let [^objects state (aget reader reader-slot-state)] + (aset reader reader-slot-pending (aget state slot-pending)) + (aset state slot-pending reader))) + +(defn terminate [^objects reader] + (when (zero? (aset reader reader-slot-alive + (dec (aget reader reader-slot-alive)))) + (reader-pending reader))) + +(defn reader-event [^objects reader] + (when (identical? reader (aget reader reader-slot-pending)) + (reader-pending reader))) + +(defn enqueue-call [^objects reader ^objects call] + (aset call call-slot-queue (aget reader reader-slot-call-queue)) + (aset reader reader-slot-call-queue call) + (reader-event reader)) + +(defn enqueue-item [^objects reader ^objects item] + (aset item item-slot-queue (aget reader reader-slot-item-queue)) + (aset reader reader-slot-item-queue item) + (reader-event reader)) + +(defn update-local-weights [^ints weights id delta] + (loop [i (unchecked-add (bit-shift-right (alength weights) 1) id)] + (aset weights i (unchecked-add-int (aget weights i) delta)) + (when (< 1 i) (recur (bit-shift-right i 1))))) + +(defn update-weights [^objects block id delta] + (loop [^objects block block + id id] + (when-not (nil? (aget block block-slot-index)) + (update-local-weights (aget block block-slot-weights) id delta) + (let [^objects call (aget block block-slot-parent) + ^objects reader (aget call call-slot-reader)] + (aset call call-slot-weight (+ delta (aget call call-slot-weight))) + (when-not (identical? call (aget reader reader-slot-root)) + (recur (aget call call-slot-parent) (r/slot-id (call-slot call)))))))) + +(defn call-update-weights [^objects call delta] + (let [^objects reader (aget call call-slot-reader)] + (aset call call-slot-weight (+ (aget call call-slot-weight) delta)) + (when-not (identical? call (aget reader reader-slot-root)) + (update-weights (aget call call-slot-parent) + (r/slot-id (call-slot call)) delta)))) + +(defn change [diff ^objects item] + (let [^objects block (aget item item-slot-parent) + ^objects call (aget block block-slot-parent)] + (if-some [index (call-index block (r/tag-index (aget item item-slot-tag)))] + (d/combine diff + {:grow 0 + :degree (current-size (aget call call-slot-reader)) + :shrink 0 + :permutation {} + :change {index (aget item item-slot-state)} + :freeze #{}}) diff))) + +(defn get-block [^objects reader frame] + (get (aget reader reader-slot-blocks) frame)) + +(defn block-release [^objects block] + (let [^objects call (aget block block-slot-parent) + ^objects reader (aget call call-slot-reader)] + (aset reader reader-slot-blocks + (dissoc (aget reader reader-slot-blocks) + (aget block block-slot-frame))))) + +(defn block-mount [^objects block index] + (let [^objects call (aget block block-slot-parent) + ^objects buffer (aget call call-slot-buffer)] + (aset buffer index block) + (aset block block-slot-index index) + (when-not (nil? (aget block block-slot-prev)) + (call-update-weights call (block-weight block))))) + +(defn block-unmount [^objects block] + (let [^objects call (aget block block-slot-parent) + ^objects buffer (aget call call-slot-buffer) + weight (block-weight block)] + (aset buffer (aget block block-slot-index) nil) + (aset block block-slot-index nil) + (if (nil? (aget block block-slot-prev)) + (block-release block) + (call-update-weights call (- weight))))) + +(defn call-release [^objects call] + (let [^objects buffer (aget call call-slot-buffer)] + (loop [i 0] + (when (< i (alength buffer)) + (when-some [^objects block (aget buffer i)] + (block-unmount block) + (recur (inc i))))) + (aset call call-slot-parent nil) + (aset call call-slot-children nil) + ((aget call call-slot-process)))) + +(defn make-block [^objects reader frame] + (let [size (r/frame-call-count frame) + block (object-array block-slots)] + (aset reader reader-slot-blocks + (assoc (aget reader reader-slot-blocks) frame block)) + (aset block block-slot-frame frame) + (aset block block-slot-children (object-array size)) + (aset block block-slot-weights (a/weight-tree size)) + block)) + +(defn make-call [^objects reader ^objects child] + (let [call (object-array call-slots)] + (aset call call-slot-reader reader) + (aset call call-slot-buffer (object-array 1)) + (aset call call-slot-weight (identity 0)) + (aset call call-slot-children child) + (aset child block-slot-prev child) + (aset child block-slot-next child) + (aset child block-slot-parent call) + call)) + +(defn call-discard [^objects call] + (try @(aget call call-slot-process) + (catch #?(:clj Throwable :cljs :default) _))) + +(defn call-spawn [^objects call] + (let [^objects reader (aget call call-slot-reader)] + (aset reader reader-slot-alive + (inc (aget reader reader-slot-alive))) + (aset call call-slot-process + ((if-some [slot (call-slot call)] + (r/flow slot) + (f/flow (r/invariant (aget ^objects (aget call call-slot-children) block-slot-frame)))) + #(let [^objects reader (aget call call-slot-reader) + ^objects state (aget reader reader-slot-state) + held (enter state)] + (if (nil? (aget call call-slot-children)) + (call-discard call) + (enqueue-call reader call)) + (exit state held)) + #(let [^objects reader (aget call call-slot-reader) + ^objects state (aget reader reader-slot-state) + held (enter state)] + (terminate reader) + (exit state held)))))) + +(defn block-attach-to-call [^objects block] + (let [^objects call (aget block block-slot-parent) + ^objects prev (aget call call-slot-children) + ^objects next (aget prev block-slot-next)] + (assert (some? prev)) + (assert (some? next)) + (aset block block-slot-prev prev) + (aset block block-slot-next next) + (aset prev block-slot-next block) + (aset next block-slot-prev block) + call)) + +(defn block-child [^objects block id] + (let [^objects children (aget block block-slot-children)] + (aget children id))) + +(defn block-set-child [^objects block id child] + (let [^objects children (aget block block-slot-children)] + (aset children id child))) + +(defn call-attach-to-block [^objects call ^objects block] + (aset call call-slot-parent block) + (block-set-child block (r/slot-id (call-slot call)) call)) + +(defn block-single-child [^objects block] (let [frame (aget block block-slot-frame) ^objects children (aget block block-slot-children)] - (dotimes [index (alength children)] - (if (r/frame-call frame index) - (when-some [^objects call (aget children index)] - (aset call call-slot-process - ((r/flow (r/->Slot frame index)) - #(let [^objects reader (aget call call-slot-reader) - ^objects state (aget reader reader-slot-state)] - (enter state) - (if (enqueue reader block index) - (if (identical? reader (aget state slot-reader)) - (step-exit reader) - (drain-exit state)) - (exit state))) - #(let [^objects reader (aget call call-slot-reader) - ^objects state (aget reader reader-slot-state)] - (enter state) - (if (identical? reader (aget state slot-reader)) - (do (comment TODO mark as done) (exit state)) - (done-exit reader)))))) - (when-not (identical? children (aget children index)) - (enqueue reader block (- index (r/frame-call-count frame)))))))) - -(defn cancel-calls [^objects reader ^objects block] - (let [^objects state (aget reader reader-slot-state) - frame (aget block block-slot-frame) - ^objects children (aget block block-slot-children) - ^ints weights (aget block block-slot-weights) - offset (bit-shift-right (alength weights) 1)] - (dotimes [index (alength children)] - (update-local-weights weights index - (- (aget weights (unchecked-add-int offset index)))) - (when (r/frame-call frame index) - (when-some [^objects call (aget children index)] - (let [^objects buffer (aget call call-slot-buffer) - process (aget call call-slot-process)] - (aset call call-slot-weight 0) - (aset reader reader-slot-root - (inc (aget reader reader-slot-root))) - (loop [i 0] - (when (< i (alength buffer)) - (when-some [f (aget buffer i)] - (when-some [b (frame->block state f)] - (cancel-calls reader b) - (recur (inc i)))))) - (process))))))) - -(defn unmount-block [^objects reader ^objects block] - (when-some [^objects call (aget block block-slot-parent)] - (let [delta (unchecked-negate-int (block-weight block))] - (aset call call-slot-weight (unchecked-add-int (aget call call-slot-weight) delta)) - (update-weights (aget call call-slot-block) (aget call call-slot-index) delta))) - (cancel-calls reader block)) - -(defn reader-cancel [^objects reader] - (let [^objects state (aget reader reader-slot-state)] - (enter state) - (if (identical? reader (aget state slot-reader)) - (let [root (aget reader reader-slot-root)] - (aset reader reader-slot-root (identity 1)) - (when-not (nil? root) (unmount-block reader root)) - (aset state slot-reader nil) - (if (nil? (aget reader reader-slot-push)) - (do (aset reader reader-slot-push (identity 0)) - (step-exit reader)) - (drain-exit reader))) - (exit state)))) + (loop [r nil + i 0] + (if (< i (alength children)) + (if (nil? (r/frame-call frame i)) + (recur r (unchecked-inc-int i)) + (if-some [c (aget children i)] + (when (nil? r) + (recur c (unchecked-inc-int i))) + (recur r (unchecked-inc-int i)))) r)))) + +(defn call-make-ancestors [call] + (let [^objects reader (aget call call-slot-reader)] + (loop [^objects call call] + (when-some [slot (call-slot call)] + (let [block (make-block reader (r/slot-frame slot))] + (call-attach-to-block call block) + (recur (make-call reader block))))))) + +(defn root-up [^objects call] + (let [^objects reader (aget call call-slot-reader)] + (aset reader reader-slot-root + (loop [^objects root (aget reader reader-slot-root)] + (if (nil? (aget call call-slot-process)) + (let [^objects block (aget root call-slot-parent) + ^objects parent (aget block block-slot-parent)] + (update-local-weights (aget block block-slot-weights) + (r/slot-id (call-slot root)) (aget root call-slot-weight)) + (call-spawn parent) (recur parent)) root))))) + +(defn root-down [^objects call] + (let [^objects reader (aget call call-slot-reader)] + (when (identical? call (aget reader reader-slot-root)) + (aset reader reader-slot-root + (loop [^objects call call] + (let [^objects block (aget call call-slot-children)] + (if (identical? block (aget block block-slot-prev)) + (if-some [^objects child (block-single-child block)] + (let [^objects parent (aget call call-slot-parent)] + (call-attach-to-block (make-call reader block) parent) + (call-release call) + (recur child)) call) call))))))) + +(defn block-attach-to-tree [^objects block ^objects reader] + (loop [^objects block block] + (let [slot (r/frame-slot (aget block block-slot-frame)) + frame (r/slot-frame slot)] + (if-some [^objects parent (get-block reader frame)] + (root-up + (if-some [call (block-child parent (r/slot-id slot))] + (do (aset block block-slot-parent call) + (block-attach-to-call block)) + (let [call (make-call reader block)] + (call-attach-to-block call parent) + (call-spawn call) + (block-attach-to-call parent)))) + (let [parent (make-block reader frame) + call (make-call reader block)] + (call-attach-to-block call parent) + (call-spawn call) + (recur parent)))))) + +(defn attach [diff ^objects item ^objects reader] + (let [tag (aget item item-slot-tag) + frame (r/tag-frame tag) + id (r/tag-index tag) + size-before (current-size reader) + ^objects block (if (nil? (aget reader reader-slot-root)) + (let [block (make-block reader frame) + call (make-call reader block)] + (aset reader reader-slot-root call) + (call-make-ancestors call) + (call-spawn call) + block) + (if-some [block (get-block reader frame)] + (doto block (block-attach-to-call)) + (doto (make-block reader frame) + (block-attach-to-tree reader))))] + (block-set-child block (r/tag-index (aget item item-slot-tag)) item) + (aset item item-slot-parent block) + (update-weights block id 1) + (if-some [index (call-index block id)] + (d/combine diff + {:grow 1 + :degree (inc size-before) + :shrink 0 + :permutation (p/rotation size-before index) + :change {index (aget item item-slot-state)} + :freeze #{}}) diff))) + +(defn block-empty? [^objects block] + (let [^objects children (aget block block-slot-children)] + (loop [i 0] + (if (< i (alength children)) + (if (nil? (aget children i)) + (recur (unchecked-inc-int i)) false) true)))) + +(defn detach-root [^objects block] + (when-not (nil? block) + (let [^objects call (aget block block-slot-parent) + ^objects parent (aget call block-slot-parent)] + (block-set-child block (r/slot-id (r/frame-slot (aget block block-slot-frame))) nil) + (aset call call-slot-parent nil) + (aset call call-slot-children nil) + (aset block block-slot-prev nil) + (aset block block-slot-next nil) + (block-release block) + (recur parent)))) + +(defn detach [diff ^objects item] + (let [^objects block (aget item item-slot-parent) + ^objects call (aget block block-slot-parent) + id (r/tag-index (aget item item-slot-tag)) + size-before (current-size (aget call call-slot-reader)) + diff (if-some [index (call-index block id)] + (d/combine diff + {:grow 0 + :degree size-before + :shrink 1 + :permutation (p/rotation index (dec size-before)) + :change {} + :freeze #{}}) diff)] + (update-weights block id -1) + (aset item item-slot-parent nil) + (aset ^objects (aget block block-slot-children) id nil) + (loop [^objects block block] + (when (block-empty? block) + (when (nil? (aget block block-slot-index)) + (block-release block)) + (let [^objects prev (aget block block-slot-prev) + ^objects next (aget block block-slot-next) + ^objects call (aget block block-slot-parent)] + (if (identical? block prev) + (let [^objects reader (aget call call-slot-reader) + ^objects parent (aget call call-slot-parent)] + (aset block block-slot-prev nil) + (aset block block-slot-next nil) + (call-release call) + (if (identical? call (aget reader reader-slot-root)) + (do (aset reader reader-slot-root nil) + (detach-root parent)) + (do (block-set-child parent (r/slot-id (r/frame-slot (aget block block-slot-frame))) nil) + (recur parent)))) + (do (aset call call-slot-children prev) + (aset prev block-slot-next next) + (aset next block-slot-prev prev) + (root-down call)))))) + diff)) + +(defn apply-permutation [^objects call permutation] + (let [^objects buffer (aget call call-slot-buffer) + ^objects reader (aget call call-slot-reader) + degree (current-size reader) + permutation (loop [p permutation + q {}] + (case p + {} q + (let [[i j] (first p) + k1 (min i j) + k2 (max i j)] + (swap-indices call i j) + (recur (p/compose p (p/cycle i j)) + (if-some [index (block-index call k1)] + (p/compose + (p/split-long-swap index + (block-weight (aget buffer k1)) + (weight-between call k1 k2) + (block-weight (aget buffer k2))) + q) q)))))] + {:grow 0 + :degree degree + :shrink 0 + :permutation permutation + :change {} + :freeze #{}})) + +(defn apply-change [^objects call change] + (let [^objects buffer (aget call call-slot-buffer) + ^objects reader (aget call call-slot-reader)] + (reduce-kv + (fn [diff i f] + (let [diff (if-some [block (aget buffer i)] + (do (block-unmount block) + (if-some [index (block-index call i)] + (let [size-after (current-size reader) + shrink (block-weight block)] + (d/combine diff + {:grow 0 + :degree (unchecked-add-int size-after shrink) + :shrink shrink + :permutation (p/split-swap index shrink + (unchecked-subtract-int size-after index)) + :change {} + :freeze #{}})) + diff)) diff)] + (if-some [block (get-block reader f)] + (do (block-mount block i) + (d/combine diff + (loop [i 0 + p {} + c {}] + (let [degree (current-size reader)] + (if (< i (r/frame-call-count f)) + (if (nil? (r/frame-call f i)) + (if-some [item (block-child block i)] + (do (update-weights block i 1) + (if-some [index (call-index block i)] + (recur (inc i) + (p/compose p (p/rotation degree index)) + (assoc c index (aget item item-slot-state))) + (recur (inc i) p c))) + (recur (inc i) p c)) + (recur (inc i) p c)) + {:grow (count c) + :degree degree + :shrink 0 + :permutation p + :change c + :freeze #{}}))))) + (let [^objects block (make-block reader f)] + (aset block block-slot-parent call) + (block-mount block i) diff)))) + (d/empty-diff (current-size reader)) + change))) + +(defn apply-shrink [^objects call shrink] + (let [^objects buffer (aget call call-slot-buffer) + ^objects reader (aget call call-slot-reader)] + (loop [d (d/empty-diff (current-size reader)) + i 0] + (if (< i shrink) + (recur + (let [degree (current-size reader) + block (aget buffer + (unchecked-subtract-int degree + (unchecked-inc-int i))) + shrink (block-weight block)] + (block-unmount block) + (d/combine d + {:grow 0 + :degree degree + :shrink shrink + :permutation {} + :change {} + :freeze #{}})) + (inc i)) d)))) + +(defn call-transfer [diff ^objects call] + (let [{:keys [degree shrink permutation change]} @(aget call call-slot-process)] + (aset call call-slot-buffer (ensure-capacity (aget call call-slot-buffer) degree)) + (d/combine diff + (apply-permutation call permutation) + (apply-change call change) + (apply-shrink call shrink)))) (defn reader-transfer [^objects reader] - (let [^objects state (aget reader reader-slot-state)] - (enter state) + (let [^objects state (aget reader reader-slot-state) + held (enter state)] (if (identical? reader (aget state slot-reader)) - (loop [pull 0 - diff (d/empty-diff (current-size reader))] - (let [^objects queue (aget reader reader-slot-queue)] - (if-some [^objects block (a/aget-aset queue pull nil)] - (let [pull+ (unchecked-inc-int pull) - index (a/aget-aset queue pull+ nil) - frame (aget block block-slot-frame) - children (aget block block-slot-children) - size-before (current-size reader)] - (recur (rem (unchecked-inc-int pull+) (alength queue)) - (if (neg? index) - (let [index (+ index (r/frame-call-count frame))] - (if (r/frame-call frame index) - (assert false) - (let [state (aget children index) - offset (tag-offset block index)] - (update-weights block index 1) - (d/combine diff - {:grow 1 - :degree (inc size-before) - :shrink 0 - :permutation (p/rotation size-before offset) - :change {offset state} - :freeze #{}})))) - (if (r/frame-call frame index) - (let [^objects call (aget children index) - {:keys [degree shrink permutation change]} @(aget call call-slot-process) - ^objects buffer (aset call call-slot-buffer (ensure-capacity (aget call call-slot-buffer) degree)) - perm (loop [p permutation - q {}] - (case p - {} (reduce-kv - (fn [q i f] - (let [p (aget buffer i) - o (offset-of call i) - l (if-some [^objects block (frame->block state p)] - (do (unmount-block reader block) - (block-weight block)) 0) - r (-> (current-size reader) - (unchecked-subtract-int l) - (unchecked-subtract-int o))] - (aset buffer i f) - (when-some [^objects block (frame->block state f)] - (aset block block-slot-index i) - (mount-block reader block)) - (p/compose (p/split-swap o l r) q))) - q change) - (let [[i j] (first p) - k1 (min i j) - k2 (max i j) - r (p/split-long-swap - (offset-of call k1) - (if-some [^objects block (frame->block state (aget buffer k1))] - (block-weight block) 0) - (weight-between call k1 k2) - (if-some [^objects block (frame->block state (aget buffer k2))] - (block-weight block) 0))] - (swap-indices call i j) - (recur (p/compose p (p/cycle i j)) - (p/compose r q)))))] - (dotimes [i shrink] - (let [i (unchecked-subtract degree - (unchecked-inc-int i)) - f (aget buffer i)] - (aset buffer i nil) - (when-some [^objects block (frame->block state f)] - (unmount-block reader block)))) - (d/combine diff - {:grow 0 - :degree size-before - :shrink (unchecked-subtract size-before - (current-size reader)) - :permutation perm - :change {} - :freeze #{}})) - (let [state (aget children index) - offset (tag-offset block index)] - (d/combine diff - (if (identical? state children) - (do (update-weights block index -1) - {:grow 0 - :degree size-before - :shrink 1 - :permutation (p/rotation offset (dec size-before)) - :change {} - :freeze #{}}) - {:grow 0 - :degree size-before - :shrink 0 - :permutation {} - :change {offset state} - :freeze #{}}))))))) - (do (aset reader reader-slot-push nil) - (exit state) diff)))) - (do (done-exit reader) + (loop [diff (d/empty-diff (current-size reader))] + (if-some [^objects call (aget reader reader-slot-call-queue)] + (do (aset reader reader-slot-call-queue (aget call call-slot-queue)) + (aset call call-slot-queue call) + (recur (if (nil? (aget call call-slot-children)) + (do (call-discard call) diff) + (call-transfer diff call)))) + (if-some [^objects item (aget reader reader-slot-item-queue)] + (do (aset reader reader-slot-item-queue (aget item item-slot-queue)) + (aset item item-slot-queue item) + (recur (if (identical? item (aget item item-slot-state)) + (if (nil? (aget item item-slot-parent)) + diff (detach diff item)) + (if (nil? (aget item item-slot-parent)) + (attach diff item reader) + (change diff item))))) + (do (aset reader reader-slot-pending reader) + (exit state held) diff)))) + (do (aset reader reader-slot-pending reader) + (terminate reader) (exit state held) (throw (missionary.Cancelled.)))))) +(defn item-cancel [^objects item] + (aset item item-slot-parent nil)) + +(defn call-cancel [^objects call] + (let [children (aget call call-slot-children)] + (aset call call-slot-children nil) + (aset call call-slot-parent nil) + (loop [^objects block children] + (let [f (aget block block-slot-frame) + n (aget block block-slot-next)] + (aset block block-slot-parent nil) + (aset block block-slot-prev nil) + (aset block block-slot-next nil) + (loop [i 0] + (when (< i (r/frame-call-count f)) + ((if (nil? (r/frame-call f i)) + item-cancel call-cancel) + (block-child block i)) + (recur (inc i)))) + (when-not (identical? n children) + (recur n)))) + ((aget call call-slot-process)))) + +(defn reader-cancel [^objects reader] + (let [^objects state (aget reader reader-slot-state) + held (enter state)] + (when (identical? reader (aget state slot-reader)) + (aset state slot-reader nil) + (when-some [root (aget reader reader-slot-root)] + (aset reader reader-slot-root nil) + (call-cancel root)) + (loop [] + (when-some [^objects item (aget reader reader-slot-item-queue)] + (aset reader reader-slot-item-queue (aget item item-slot-queue)) + (aset item item-slot-queue item) + (recur))) + (loop [] + (when-some [^objects call (aget reader reader-slot-call-queue)] + (aset reader reader-slot-call-queue (aget call call-slot-queue)) + (aset call call-slot-queue call) + (call-discard call) + (recur))) + (reader-event reader)) + (exit state held))) + (deftype Reader [state] IFn - (#?(:clj invoke :cljs -invoke) [this] + (#?(:clj invoke :cljs -invoke) [_] (reader-cancel state)) IDeref - (#?(:clj deref :cljs -deref) [this] + (#?(:clj deref :cljs -deref) [_] (reader-transfer state))) -(defn subtree [root frame] - (loop [frame frame - path (list)] - (if (identical? root frame) - path (when-some [slot (r/frame-slot frame)] - (recur (r/slot-frame slot) (conj path slot)))))) - -(defn store-block [^objects state frame block] - (aset state slot-blocks (assoc (aget state slot-blocks) frame block))) - -(defn make-call [^objects reader ^objects block index] - (let [^objects children (aget block block-slot-children)] - (aset children index - (doto (object-array call-slots) - (aset call-slot-reader reader) - (aset call-slot-block block) - (aset call-slot-index index) - (aset call-slot-buffer (object-array 1)) - (aset call-slot-weight (identity 0)))))) - -(defn make-block-and-call [^objects reader ^objects call frame id] - (let [block (make-block frame)] - (store-block (aget reader reader-slot-state) frame block) - (aset block block-slot-parent call) - (make-call reader block id))) - -(defn make-blocks-and-calls [^objects reader ^objects call path] - (loop [call call - path path] - (case path - [] call - (let [slot (peek path)] - (recur (make-block-and-call reader call - (r/slot-frame slot) (r/slot-id slot)) - (pop path)))))) - -(defn insert-block [^objects reader block] - (let [^objects state (aget reader reader-slot-state)] - (if-some [root (aget reader reader-slot-root)] - (loop [^objects root root] - (let [root-frame (aget root block-slot-frame)] - (if-some [path (subtree root-frame (aget block block-slot-frame))] - (aset block block-slot-parent - (loop [call nil - path path] - (case path - [] call - (let [slot (peek path) - path (pop path) - frame (r/slot-frame slot) - id (r/slot-id slot)] - (if-some [^objects block (frame->block state frame)] - (let [^objects children (aget block block-slot-children)] - (if-some [^objects call (aget children id)] - (recur call path) - (make-blocks-and-calls reader (make-call reader block id) path))) - (make-blocks-and-calls reader (make-block-and-call reader call frame id) path)))))) - (let [slot (r/frame-slot root-frame) - frame (r/slot-frame slot) - block (make-block frame)] - (store-block state frame block) - (aset reader reader-slot-root block) - (aset root block-slot-parent - (make-call reader block (r/slot-id slot))) - (recur block))))) - (aset reader reader-slot-root block)) - reader)) - (defn reader-spawn [^objects state step done] - (let [reader (object-array reader-slots)] + (let [held (enter state) + reader (object-array reader-slots)] (aset reader reader-slot-state state) (aset reader reader-slot-step step) (aset reader reader-slot-done done) - (aset reader reader-slot-queue (object-array 2)) - (aset reader reader-slot-push (identity 0)) - (enter state) + (aset reader reader-slot-alive (identity 1)) (when (nil? (aget state slot-reader)) (aset state slot-reader reader) - (reduce insert-block reader (vals (aget state slot-blocks))) - (when-some [root (aget reader reader-slot-root)] - (mount-block reader root))) - (exit state) (step) + (aset reader reader-slot-item-queue + (reduce (fn [queue ^objects item] + (aset item item-slot-queue queue) item) + nil (vals (aget state slot-items))))) + (reader-pending reader) + (exit state held) (->Reader reader))) -(defn enqueue-exit [^objects state ^objects block index] - (if-some [^objects reader (aget state slot-reader)] - (if (enqueue reader block index) - (step-exit reader) - (exit state)) - (exit state))) - -(defn failure-exit [^objects state e] - (exit state) (throw e)) - (defn error [^String msg] (new #?(:clj Error :cljs js/Error) msg)) (deftype MountPoint [^objects state] KVS (insert! [_ tag init] - (let [frame (r/tag-frame tag) - index (r/tag-index tag)] - (enter state) - (let [blocks (aget state slot-blocks)] - (if-some [^objects block (get blocks frame)] - (let [^objects children (aget block block-slot-children)] - (if (identical? children (aget children index)) - (do (aset children index init) - (enqueue-exit state block (- index (r/frame-call-count frame)))) - (do (exit state) - (throw (error "Can't insert - tag already present."))))) - (let [^objects block (make-block frame) - ^objects children (aget block block-slot-children)] - (aset state slot-blocks (assoc blocks frame block)) - (aset children index init) - (when-some [reader (aget state slot-reader)] - (insert-block reader block)) - (enqueue-exit state block (- index (r/frame-call-count frame)))))))) + (assert (identical? (r/frame-peer (r/tag-frame tag)) (aget state slot-peer))) + (let [held (enter state) + items (aget state slot-items)] + (if (contains? items tag) + (do (exit state held) + (throw (error "Can't insert - tag already present."))) + (let [item (object-array item-slots)] + (aset state slot-items (assoc items tag item)) + (aset item item-slot-tag tag) + (aset item item-slot-state init) + (if-some [reader (aget state slot-reader)] + (enqueue-item reader item) + (aset item item-slot-queue item)) + (exit state held))))) (update! [_ tag f] - (let [frame (r/tag-frame tag) - index (r/tag-index tag)] - (enter state) - (let [blocks (aget state slot-blocks)] - (if-some [^objects block (get blocks frame)] - (let [^objects children (aget block block-slot-children) - x (aget children index)] - (if (identical? children x) - (failure-exit state (error "Can't update - tag is absent.")) - (if (= x (aset children index (f x))) - (exit state) - (enqueue-exit state block index)))) - (failure-exit state (error "Can't update - tag is absent.")))))) + (assert (identical? (r/frame-peer (r/tag-frame tag)) (aget state slot-peer))) + (let [held (enter state) + items (aget state slot-items)] + (if-some [^objects item (get items tag)] + (let [prev (aget item item-slot-state)] + (when-not (= prev (aset item item-slot-state (f prev))) + (when-some [reader (aget state slot-reader)] + (when (identical? item (aget item item-slot-queue)) + (enqueue-item reader item)))) + (exit state held)) + (do (exit state held) + (throw (error "Can't update - tag is absent.")))))) (remove! [_ tag] - (let [frame (r/tag-frame tag) - index (r/tag-index tag)] - (enter state) - (let [blocks (aget state slot-blocks)] - (if-some [^objects block (get blocks frame)] - (let [^objects children (aget block block-slot-children)] - (if (identical? children (aget children index)) - (failure-exit state (error "Can't remove - tag is absent.")) - (do (aset children index children) - ;; TODO if block becomes empty, remove from store - (enqueue-exit state block index)))) - (failure-exit state (error "Can't remove - tag is absent.")))))) + (assert (identical? (r/frame-peer (r/tag-frame tag)) (aget state slot-peer))) + (let [held (enter state) + items (aget state slot-items)] + (if-some [^objects item (get items tag)] + (do (aset state slot-items (dissoc items tag)) + (aset item item-slot-state item) + (when-some [reader (aget state slot-reader)] + (when (identical? item (aget item item-slot-queue)) + (enqueue-item reader item))) + (exit state held)) + (do (exit state held) + (throw (error "Can't remove - tag is absent.")))))) IFn (#?(:clj invoke :cljs -invoke) [_ step done] (reader-spawn state step done))) -(defn create [] +(defn create [peer] (->MountPoint (doto (object-array slots) - (aset slot-lock #?(:clj (ReentrantLock.) :cljs nil))))) - -#_ -(defn find-block [^objects state frame] - (when-some [root (aget state slot-root)] - (loop [^objects root root] - (when-some [path (subtree root frame)] - (loop [^objects block root - path path] - (case path - [] block - (let [slot (peek path) - path (pop path) - id (r/slot-id slot) - frame (r/slot-frame slot) - ^objects children (aget block block-slot-children)] - (when-some [^objects call (aget children id)] - (when-some [^objects block (get (aget call call-slot-children) frame)] - (recur block path)))))))))) - -#_ -(defn remove-block [^objects reader ^objects block index] - (loop [^objects block block - index index] - (let [^objects children (aget block block-slot-children)] - (aset children index children) - (when (loop [i 0] - (if (identical? children (aget children i)) - (let [i (inc i)] - (if (< i (alength children)) - (recur i) true)) false)) - (if (identical? block (aget reader reader-slot-root)) - (aset reader reader-slot-root nil) - (let [^objects call (aget block block-slot-parent)] - (when (zero? (count (aset call call-slot-children - (dissoc! (aget call call-slot-children) - (aget block block-slot-frame))))) - ;; TODO cancel process - (recur (aget call call-slot-block) - (aget call call-slot-index))))))))) + (aset slot-lock #?(:clj (ReentrantLock.) :cljs false)) + (aset slot-peer peer) + (aset slot-items {})))) \ No newline at end of file diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc index e23ba8eef..7149f2150 100644 --- a/src/hyperfiddle/electric/impl/runtime_de.cljc +++ b/src/hyperfiddle/electric/impl/runtime_de.cljc @@ -284,6 +284,10 @@ T T T -> (EXPR T) [^Peer peer key idx] ((peer-root peer key) idx)) +(defn peer-root-frame [^Peer peer] + (let [^objects state (.-state peer)] + (aget state peer-slot-root))) + (defn port-flow [^objects port] (aget port port-slot-flow)) @@ -874,19 +878,20 @@ T T T -> (EXPR T) Returns a peer definition from given definitions and main key. " [events site defs main & args] (fn [step done] - (let [state (object-array peer-slots) - peer (->Peer site defs step done - (doto (object-array peer-queues) - (aset peer-queue-tap (object-array 1)) - (aset peer-queue-untap (object-array 1)) - (aset peer-queue-toggle (object-array 1)) - (aset peer-queue-ready (object-array 1))) - (a/int-array peer-queues) state) - input (m/stream (m/observe events)) + (let [input (m/stream (m/observe events)) + ^Peer peer (->Peer site defs step done + (doto (object-array peer-queues) + (aset peer-queue-tap (object-array 1)) + (aset peer-queue-untap (object-array 1)) + (aset peer-queue-toggle (object-array 1)) + (aset peer-queue-ready (object-array 1))) + (a/int-array peer-queues) + (object-array peer-slots)) ^Frame root (->> args (eduction (map pure)) (apply dispatch "" ((defs main))) (make-frame peer nil 0 :client)) + ^objects state (.-state peer) handlers {Slot (t/write-handler (fn [_] "slot") (fn [^Slot slot] @@ -929,8 +934,9 @@ Returns a peer definition from given definitions and main key. (fn [[slot rank ctor]] (if (nil? ctor) (if (nil? slot) - root (let [^objects call (frame-call (slot-frame slot) (slot-id slot))] - (get (aget call call-slot-children) rank))) + (aget state peer-slot-root) + (let [^objects call (frame-call (slot-frame slot) (slot-id slot))] + (get (aget call call-slot-children) rank))) (let [frame (make-frame peer slot rank (port-site (slot-port slot)) ctor)] (frame-share frame) frame)))) "join" (t/read-handler diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index a0a16d2fa..5550b2553 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -201,8 +201,16 @@ this tuple. Returns the concatenation of all body results as a single vector. (reduce (cc/fn [ac [nm & fargs]] `(::lang/bindlocal ~nm (hyperfiddle.electric-de/fn ~@fargs) ~ac)) (cons 'do body) sb) sb))) -(defmacro tag [] `(::lang/tag)) -(def mount-point mp/create) +(defmacro tag " +Returns a new tag instance. +" [] `(::lang/tag)) + +(defmacro mount-point " +Returns a new mount point instance. +A mount point can be : +* mutated as a key-value store via the KVS protocol. Keys must be tags generated by the same electric application. +* watched as an incremental sequence. Values will be sorted according to the relative ordering of tags. + " [] `(mp/create (r/frame-peer (frame)))) (hyperfiddle.electric-de/defn Dispatch [F static args] (let [offset (count static) diff --git a/src/hyperfiddle/incseq.cljc b/src/hyperfiddle/incseq.cljc index 381dff84a..102828b35 100644 --- a/src/hyperfiddle/incseq.cljc +++ b/src/hyperfiddle/incseq.cljc @@ -37,7 +37,7 @@ successive sequence diffs. Incremental sequences are applicative functors with ` `latest-concat`. "} hyperfiddle.incseq (:refer-clojure :exclude [cycle]) - (:require [hyperfiddle.incseq.arrays-impl :as a] + (:require [hyperfiddle.incseq.fixed-impl :as f] [hyperfiddle.incseq.perm-impl :as p] [hyperfiddle.incseq.diff-impl :as d] [hyperfiddle.incseq.items-impl :as i] @@ -252,121 +252,7 @@ Returns the diff applying given diffs successively. (def ^{:doc " Returns the incremental sequence defined by the fixed collection of given continuous flows. A collection is fixed iff its size is invariant and its items are immobile. -"} fixed - (let [slot-notifier 0 - slot-terminator 1 - slot-processes 2 - slot-ready 3 - slot-push 4 - slot-live 5 - slot-value 6 - slots 7] - (letfn [(empty-cancel [_]) - (empty-transfer [t] - (t) {:grow 0 - :shrink 0 - :degree 0 - :permutation {} - :change {} - :freeze #{}}) - (empty-coll [n t] - (n) (->Ps t empty-cancel empty-transfer)) - (input-ready [^objects state item] - ((locking state - (let [^objects processes (aget state slot-processes) - ^ints ready (aget state slot-ready) - arity (alength processes) - item (int item)] - (if-some [i (aget state slot-push)] - (do (aset state slot-push (identity (rem (unchecked-inc-int i) arity))) - (aset ready i item) nop) - (do (aset state slot-push (identity (rem 1 arity))) - (if-some [cb (aget state slot-notifier)] - (do (aset ready 0 item) cb) - (loop [item item - i (rem 1 arity)] - (if (neg? item) - (aset state slot-live (dec (aget state slot-live))) - (try @(aget processes item) (catch #?(:clj Throwable :cljs :default) _))) - (let [item (aget ready i)] - (if (== arity item) - (do (aset state slot-push nil) - (if (zero? (aget state slot-live)) - (aget state slot-terminator) nop)) - (do (aset ready i arity) - (recur item (rem (unchecked-inc-int i) arity))))))))))))) - (item-spawn [^objects state item flow] - (let [^objects processes (aget state slot-processes) - arity (alength processes)] - (aset processes item - (flow #(input-ready state item) - #(input-ready state (unchecked-subtract-int item arity))))) - state) - (cancel [^objects state] - (let [^objects processes (aget state slot-processes)] - (dotimes [item (alength processes)] ((aget processes item))))) - (transfer [^objects state] - (let [^objects processes (aget state slot-processes) - ^ints ready (aget state slot-ready) - arity (alength processes) - item (aget ready 0)] - (aset ready 0 arity) - ((locking state - (loop [item item - i (rem 1 arity)] - (if (nil? (aget state slot-notifier)) - (if (neg? item) - (aset state slot-live (dec (aget state slot-live))) - (try @(aget processes item) (catch #?(:clj Throwable :cljs :default) _))) - (let [diff (aget state slot-value)] - (aset state slot-value - (if (neg? item) - (do (aset state slot-live (dec (aget state slot-live))) - (update diff :freeze conj (unchecked-add-int arity item))) - (try (update diff :change assoc item @(aget processes item)) - (catch #?(:clj Throwable :cljs :default) e - (aset state slot-notifier nil) - (cancel state) e)))))) - (let [item (aget ready i)] - (if (== arity item) - (do (aset state slot-push nil) - (if (zero? (aget state slot-live)) - (aget state slot-terminator) nop)) - (do (aset ready i arity) - (recur item (rem (unchecked-inc-int i) arity)))))))) - (let [x (aget state slot-value)] - (aset state slot-value - {:grow 0 - :shrink 0 - :degree arity - :permutation {} - :change {} - :freeze #{}}) - (if (nil? (aget state slot-notifier)) - (throw x) x))))] - (fn - ([] empty-coll) - ([item & items] - (let [items (into [item] items)] - (fn [n t] - (let [state (object-array slots) - arity (count items) - ready (a/int-array arity)] - (dotimes [i arity] (aset ready i arity)) - (aset state slot-notifier n) - (aset state slot-terminator t) - (aset state slot-processes (object-array arity)) - (aset state slot-ready ready) - (aset state slot-live (identity arity)) - (aset state slot-value - {:grow arity - :degree arity - :shrink 0 - :permutation {} - :change {} - :freeze #{}}) - (reduce-kv item-spawn state items) - (->Ps state cancel transfer))))))))) +"} fixed f/flow) (def ^{:arglists '([f & incseqs]) @@ -713,42 +599,6 @@ Returns the size of `incseq` as a continuous flow. (throw (js/Error. "No such element."))) (.shift q)) ([x] (.push q x) nil)))))] - (let [q (queue) - ps ((fixed) #(q :step) #(q :done))] - (q) := :step - @ps := {:degree 0, :grow 0, :shrink 0, :permutation {}, :change {}, :freeze #{}}) - - (let [q (queue) - ps ((fixed (fn [n t] (q n) (n) (->Ps q #(% :cancel) #(%)))) - #(q :step) #(q :done)) - n (q)] - (q) := :step - (q 0) - @ps := {:grow 1, :degree 1, :shrink 0, :permutation {}, :change {0 0}, :freeze #{}} - (n) - (q) := :step - (q 1) - @ps := {:grow 0, :shrink 0, :degree 1, :permutation {}, :change {0 1}, :freeze #{}}) - - (let [q (queue) - ps ((fixed - (fn [n t] (q n) (->Ps q #(% :cancel) #(%))) - (fn [n t] (q n) (->Ps q #(% :cancel) #(%)))) - #(q :step) #(q :done)) - n1 (q) - n2 (q)] - (n1) - (q) := :step - (n2) - (q 0) - (q :a) - @ps := {:grow 2, :degree 2, :shrink 0, :permutation {}, :change {0 0, 1 :a}, :freeze #{}} - (n1) - (q) := :step - (n2) - (q 1) - (q :b) - @ps := {:grow 0, :shrink 0, :degree 2, :permutation {}, :change {0 1, 1 :b}, :freeze #{}}) (let [q (queue) ps ((diff-by identity (fn [n t] (q n) (q t) (->Ps q #(% :cancel) #(%)))) diff --git a/src/hyperfiddle/incseq/fixed_impl.cljc b/src/hyperfiddle/incseq/fixed_impl.cljc new file mode 100644 index 000000000..6d3a09cdb --- /dev/null +++ b/src/hyperfiddle/incseq/fixed_impl.cljc @@ -0,0 +1,138 @@ +(ns hyperfiddle.incseq.fixed-impl + (:require [hyperfiddle.incseq.arrays-impl :as a]) + (:import #?(:clj (clojure.lang IFn IDeref)))) + +(def slot-notifier 0) +(def slot-terminator 1) +(def slot-processes 2) +(def slot-ready 3) +(def slot-push 4) +(def slot-live 5) +(def slot-value 6) +(def slots 7) + +(deftype Empty [t] + IFn + (#?(:clj invoke :cljs -invoke) [_]) + IDeref + (#?(:clj deref :cljs -deref) [_] + (t) {:grow 0 + :shrink 0 + :degree 0 + :permutation {} + :change {} + :freeze #{}})) + +(defn empty-coll [n t] + (n) (->Empty t)) + +(defn nop []) + +(defn input-ready [^objects state item] + ((locking state + (let [^objects processes (aget state slot-processes) + ^ints ready (aget state slot-ready) + arity (alength processes) + item (int item)] + (if-some [i (aget state slot-push)] + (do (aset state slot-push (identity (rem (unchecked-inc-int i) arity))) + (aset ready i item) nop) + (do (aset state slot-push (identity (rem 1 arity))) + (if-some [cb (aget state slot-notifier)] + (do (aset ready 0 item) cb) + (loop [item item + i (rem 1 arity)] + (if (neg? item) + (aset state slot-live (dec (aget state slot-live))) + (try @(aget processes item) (catch #?(:clj Throwable :cljs :default) _))) + (let [item (aget ready i)] + (if (== arity item) + (do (aset state slot-push nil) + (if (zero? (aget state slot-live)) + (aget state slot-terminator) nop)) + (do (aset ready i arity) + (recur item (rem (unchecked-inc-int i) arity))))))))))))) + +(defn item-spawn [^objects state item flow] + (let [^objects processes (aget state slot-processes) + arity (alength processes)] + (aset processes item + (flow #(input-ready state item) + #(input-ready state (unchecked-subtract-int item arity))))) + state) + +(defn cancel [^objects state] + (let [^objects processes (aget state slot-processes)] + (dotimes [item (alength processes)] ((aget processes item))))) + +(defn transfer [^objects state] + (let [^objects processes (aget state slot-processes) + ^ints ready (aget state slot-ready) + arity (alength processes) + item (aget ready 0)] + (aset ready 0 arity) + ((locking state + (loop [item item + i (rem 1 arity)] + (if (nil? (aget state slot-notifier)) + (if (neg? item) + (aset state slot-live (dec (aget state slot-live))) + (try @(aget processes item) (catch #?(:clj Throwable :cljs :default) _))) + (let [diff (aget state slot-value)] + (aset state slot-value + (if (neg? item) + (do (aset state slot-live (dec (aget state slot-live))) + (update diff :freeze conj (unchecked-add-int arity item))) + (try (update diff :change assoc item @(aget processes item)) + (catch #?(:clj Throwable :cljs :default) e + (aset state slot-notifier nil) + (cancel state) e)))))) + (let [item (aget ready i)] + (if (== arity item) + (do (aset state slot-push nil) + (if (zero? (aget state slot-live)) + (aget state slot-terminator) nop)) + (do (aset ready i arity) + (recur item (rem (unchecked-inc-int i) arity)))))))) + (let [x (aget state slot-value)] + (aset state slot-value + {:grow 0 + :shrink 0 + :degree arity + :permutation {} + :change {} + :freeze #{}}) + (if (nil? (aget state slot-notifier)) + (throw x) x)))) + +(deftype Ps [state] + IFn + (#?(:clj invoke :cljs -invoke) [_] + (cancel state)) + IDeref + (#?(:clj deref :cljs -deref) [_] + (transfer state))) + +(defn flow + ([] empty-coll) + ([item & items] + (let [items (into [item] items)] + (fn [n t] + (let [state (object-array slots) + arity (count items) + ready (a/int-array arity)] + (dotimes [i arity] (aset ready i arity)) + (aset state slot-notifier n) + (aset state slot-terminator t) + (aset state slot-processes (object-array arity)) + (aset state slot-ready ready) + (aset state slot-live (identity arity)) + (aset state slot-value + {:grow arity + :degree arity + :shrink 0 + :permutation {} + :change {} + :freeze #{}}) + (reduce-kv item-spawn state items) + (->Ps state)))))) \ No newline at end of file diff --git a/test/hyperfiddle/electric/impl/mount_point_test.cljc b/test/hyperfiddle/electric/impl/mount_point_test.cljc index 42f2d0300..3cc160e94 100644 --- a/test/hyperfiddle/electric/impl/mount_point_test.cljc +++ b/test/hyperfiddle/electric/impl/mount_point_test.cljc @@ -23,9 +23,6 @@ :client (r/effect tag)))) (inc i)) 0 tags) frame)) -(defn slot [frame id] - (r/->Slot frame id)) - (defn queue [] #?(:clj (let [q (LinkedList.)] (fn @@ -41,9 +38,15 @@ (deftest sibling-tags (let [q (queue) - p (peer {}) - f (frame p nil 0 nil nil nil) - mp (doto (mp/create) + _ ((r/peer (fn [_] #()) :client + {:root (fn ([] {0 (r/ctor :root 0)}) + ([idx] + (case idx + 0 (r/cdef 0 [] [nil nil nil] nil (fn [frame] (q frame) (r/pure nil))))))} + :root) + #(q :peer-step) #(q :peer-done)) + f (q) + mp (doto (mp/create (r/frame-peer f)) (kvs/insert! (r/tag f 0) :foo) (kvs/insert! (r/tag f 1) :bar) (kvs/insert! (r/tag f 2) :baz)) @@ -80,9 +83,15 @@ (deftest sibling-tags-insert-after-read (let [q (queue) - p (peer {}) - f (frame p nil 0 nil nil) - mp (mp/create) + _ ((r/peer (fn [_] #()) :client + {:root (fn ([] {0 (r/ctor :root 0)}) + ([idx] + (case idx + 0 (r/cdef 0 [] [nil nil] nil (fn [frame] (q frame) (r/pure nil))))))} + :root) + #(q :peer-step) #(q :peer-done)) + f (q) + mp (mp/create (r/frame-peer f)) ps (mp #(q :step) #(q :done))] (is (= (q) :step)) (is (= @ps (d/empty-diff 0))) @@ -97,70 +106,47 @@ 1 :bar} :freeze #{}})))) -(deftest cousin-tags +(deftest cousin-tags-insert-after-read (let [q (queue) - p (peer {:cdef [(r/cdef 0 [] [] nil (fn [frame] (r/pure nil)))]}) - r (frame p nil 0 - (m/observe (fn [!] (! (d/empty-diff 0)) (q !) #(q :dispose)))) - f1 (frame p (slot r 0) 0 nil) - f2 (frame p (slot r 0) 1 nil) - mp (doto (mp/create) - (kvs/insert! (r/tag f1 0) :foo) - (kvs/insert! (r/tag f2 0) :bar)) + _ ((r/peer (fn [_] #()) :client + {:root (fn ([] {0 (r/ctor :root 0)}) + ([idx] + (case idx + 0 (r/cdef 0 [] [nil] nil + (fn [frame] + (q frame) + (r/define-call frame 0 + (r/effect (m/observe + (fn [!] + (! {:grow 2 + :degree 2 + :shrink 0 + :permutation {} + :change {0 (r/ctor :root 1) + 1 (r/ctor :root 1)} + :freeze #{}}) + #(q :dispose))))) + (r/call frame 0))) + 1 (r/cdef 0 [] [nil] nil + (fn [frame] + (q frame) + (r/pure nil))))))} + :root) + #(q :peer-step) #(q :peer-done)) + f (q) + f1 (q) + f2 (q) + mp (mp/create (r/frame-peer f)) ps (mp #(q :step) #(q :done))] (is (= (q) :step)) (is (= @ps (i/empty-diff 0))) - (let [diff! (q)] - (diff! {:grow 2 - :degree 2 - :shrink 0 - :permutation {} - :change {0 (r/ctor :cdef 0) - 1 (r/ctor :cdef 0)} - :freeze #{}}) - (is (= (q) :step)) - (is (= @ps {:grow 2 - :degree 2 - :shrink 0 - :permutation {} - :change {0 :foo, 1 :bar} - :freeze #{}})) - (diff! {:grow 0 - :degree 2 - :shrink 0 - :permutation {0 1, 1 0} - :change {} - :freeze #{}}) - (is (= (q) :step)) - (is (= @ps {:grow 0 - :degree 2 - :shrink 0 - :permutation {0 1, 1 0} - :change {} - :freeze #{}})) - (diff! {:grow 0 - :degree 2 - :shrink 1 - :permutation {} - :change {} - :freeze #{}}) - (is (= (q) :step)) - (is (= @ps {:grow 0 - :degree 2 - :shrink 1 - :permutation {} - :change {} - :freeze #{}})) - (kvs/update! mp (r/tag f2 0) (constantly :baz)) - (is (= (q) :step)) - (is (= @ps {:grow 0 - :degree 1 - :shrink 0 - :permutation {} - :change {0 :baz} - :freeze #{}})) - (ps) - (is (= (q) :step)) - (is (= (q) :dispose)) - (is (thrown? Cancelled @ps)) - (is (= (q) :done))))) \ No newline at end of file + (kvs/insert! mp (r/tag f1 0) :foo) + (kvs/insert! mp (r/tag f2 0) :bar) + (is (= (q) :step)) + (is (= @ps {:grow 2 + :degree 2 + :shrink 0 + :permutation {} + :change {1 :bar + 0 :foo} + :freeze #{}})))) \ No newline at end of file diff --git a/test/hyperfiddle/electric_de_test.cljc b/test/hyperfiddle/electric_de_test.cljc index c582e85ee..6fdce19db 100644 --- a/test/hyperfiddle/electric_de_test.cljc +++ b/test/hyperfiddle/electric_de_test.cljc @@ -6,6 +6,7 @@ [hyperfiddle.electric.impl.lang-de2 :as lang] [hyperfiddle.electric.impl.runtime-de :as r] [hyperfiddle.incseq :as i] + [hyperfiddle.kvs :as kvs] [contrib.cljs-target :refer [do-browser]] #?(:cljs [hyperfiddle.goog-calls-test-de]) #?(:cljs [hyperfiddle.js-calls-test-de]) @@ -2223,3 +2224,32 @@ (@!c 2) % := false)) ) + +(tests + (defn mount-at [kvs k v] + (m/observe + (fn [!] + (! (i/empty-diff 0)) + (kvs/insert! kvs k v) + #(kvs/remove! kvs k)))) + + (def !x (atom true)) + (def !y (atom true)) + + (with ((l/single {} + (let [mp (e/mount-point)] + (tap (e/as-vec (e/join mp))) + (if (e/watch !x) + (e/join (mount-at mp (e/tag) 0)) + (if (e/input (m/watch !y)) + (e/join (mount-at mp (e/tag) 1)) + (e/join (mount-at mp (e/tag) 2)))) + (e/join (mount-at mp (e/tag) 3)))) + tap tap) + % := [0 3] + (swap! !x not) + % := [1 3] + (swap! !y not) + % := [2 3] + (swap! !x not) + % := [0 3])) \ No newline at end of file diff --git a/test/hyperfiddle/incseq/fixed_impl_test.cljc b/test/hyperfiddle/incseq/fixed_impl_test.cljc new file mode 100644 index 000000000..d25d8273a --- /dev/null +++ b/test/hyperfiddle/incseq/fixed_impl_test.cljc @@ -0,0 +1,79 @@ +(ns hyperfiddle.incseq.fixed-impl-test + (:require [hyperfiddle.incseq.fixed-impl :refer [flow]] + [clojure.test :refer [deftest is]])) + +(defn queue [] + #?(:clj (let [q (java.util.LinkedList.)] + (fn + ([] (.remove q)) + ([x] (.add q x) nil))) + :cljs (let [q (make-array 0)] + (fn + ([] + (when (zero? (alength q)) + (throw (js/Error. "No such element."))) + (.shift q)) + ([x] (.push q x) nil))))) + +(deftype Ps [cancel transfer] + IFn + (#?(:clj invoke :cljs -invoke) [_] + (cancel)) + IDeref + (#?(:clj deref :cljs -deref) [_] + (transfer))) + +(deftest zero + (let [q (queue) + ps ((flow) #(q :step) #(q :done))] + (is (= (q) :step)) + @ps := {:grow 0 + :degree 0 + :shrink 0 + :permutation {} + :change {} + :freeze #{}})) + +(deftest one + (let [q (queue) + ps ((flow (fn [n t] (q n) (n) (->Ps #(q :cancel) q))) + #(q :step) #(q :done)) + n (q)] + (q) := :step + (q 0) + @ps := {:grow 1, :degree 1, :shrink 0, :permutation {}, :change {0 0}, :freeze #{}} + (n) + (q) := :step + (q 1) + @ps := {:grow 0, :shrink 0, :degree 1, :permutation {}, :change {0 1}, :freeze #{}})) + +(deftest two + (let [q (queue) + ps ((flow + (fn [n t] (q n) (->Ps #(q :cancel) q)) + (fn [n t] (q n) (->Ps #(q :cancel) q))) + #(q :step) #(q :done)) + n1 (q) + n2 (q)] + (n1) + (q) := :step + (n2) + (q 0) + (q :a) + @ps := {:grow 2 + :degree 2 + :shrink 0 + :permutation {} + :change {0 0, 1 :a} + :freeze #{}} + (n1) + (q) := :step + (n2) + (q 1) + (q :b) + @ps := {:grow 0 + :degree 2 + :shrink 0 + :permutation {} + :change {0 1, 1 :b} + :freeze #{}})) \ No newline at end of file From 8e2c832df9332e42469ec1b5d8a4d2544913b162 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Thu, 20 Jun 2024 11:05:01 +0200 Subject: [PATCH 242/428] fix cljs regression in i/fixed --- src/hyperfiddle/incseq/fixed_impl.cljc | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/hyperfiddle/incseq/fixed_impl.cljc b/src/hyperfiddle/incseq/fixed_impl.cljc index 6d3a09cdb..77f0602f9 100644 --- a/src/hyperfiddle/incseq/fixed_impl.cljc +++ b/src/hyperfiddle/incseq/fixed_impl.cljc @@ -11,7 +11,7 @@ (def slot-value 6) (def slots 7) -(deftype Empty [t] +(deftype EmptySeq [t] IFn (#?(:clj invoke :cljs -invoke) [_]) IDeref @@ -23,8 +23,8 @@ :change {} :freeze #{}})) -(defn empty-coll [n t] - (n) (->Empty t)) +(defn empty-seq [n t] + (n) (->EmptySeq t)) (defn nop []) @@ -114,7 +114,7 @@ (transfer state))) (defn flow - ([] empty-coll) + ([] empty-seq) ([item & items] (let [items (into [item] items)] (fn [n t] From f6876e7a4db408776ea82d906a646572bf817f0e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Thu, 20 Jun 2024 14:41:37 +0200 Subject: [PATCH 243/428] mount-point design notes --- .../electric/impl/mount_point.cljc | 39 ++++++++++++++++++- 1 file changed, 37 insertions(+), 2 deletions(-) diff --git a/src/hyperfiddle/electric/impl/mount_point.cljc b/src/hyperfiddle/electric/impl/mount_point.cljc index 788221505..1500ac199 100644 --- a/src/hyperfiddle/electric/impl/mount_point.cljc +++ b/src/hyperfiddle/electric/impl/mount_point.cljc @@ -1,5 +1,40 @@ -(ns hyperfiddle.electric.impl.mount-point - (:require [hyperfiddle.kvs :refer [KVS]] +(ns hyperfiddle.electric.impl.mount-point " +A mount-point instance maintains : +* a hash map storing items indexed by tag. An item is a mutable object tracking the lifecycle of each entry in the + resulting incseq. +* a set of active readers. Each mutation of the store sends an invalidation event for the item being touched to the + readers currently active. + +A reader process maintains : +* a call tree isomorphic to the subset of the application's call tree restricted to the ancestors of active items. + Leaves are items, nodes are either blocks or calls, block children are items or calls, call children are blocks, the + root is a call. +* a hash map storing blocks indexed by frame. A block is a mutable object tracking each known frame. A frame is known + when either it's an ancestor of an active item, or it's currently being mounted by a call that is in the common + ancestry of an active item. +* a mailbox for step events on calls and another one for invalidation events on items. Both mailboxes are consumed + during reader process transfer, call events take priority over the item events but ordering of events within a single + mailbox is irrelevant. The processing of each event mutates the call tree and generates a diff, then the concatenation + of successive diffs is returned. When the reader is spawned, an invalidation event is posted for each active item. + +On item invalidation event : +* If the item is inactive : + * If it was attached in the call tree, it is detached from the tree and a shrink is generated if the item was mounted. + * If it was detached from the call tree, nothing happens. +* If the item is active : + * If it was attached in the call tree, a change is generated if the item was mounted. + * If it was detached from the call tree, it is attached to the tree and a grow is generated if the item was mounted. + +On call step event : +1. Apply permutation. The call permutation must be expanded to take into account the offset and length of the call + segment in the current sequence state. +2. Apply changes. For each item change that is not a grow, the block associated to previous frame is unmounted. The new + frame is then associated to its block and mounted. +3. Apply shrinks. The blocks associated with removed frames are unmounted. + +Unmounting a block generates a shrink for each active item having this block's frame as an ancestor. +Mounting a block generates a grow for each active item having this block's frame as an ancestor. +" (:require [hyperfiddle.kvs :refer [KVS]] [hyperfiddle.incseq.arrays-impl :as a] [hyperfiddle.incseq.fixed-impl :as f] [hyperfiddle.incseq.diff-impl :as d] From e40bbe16b73b0db9ebc3b2a19ff7b804f70b9ce4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Fri, 21 Jun 2024 11:09:08 +0200 Subject: [PATCH 244/428] latest-product fix int cast --- src/hyperfiddle/incseq/latest_product_impl.cljc | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/src/hyperfiddle/incseq/latest_product_impl.cljc b/src/hyperfiddle/incseq/latest_product_impl.cljc index 6d77a787c..3bf98b7a2 100644 --- a/src/hyperfiddle/incseq/latest_product_impl.cljc +++ b/src/hyperfiddle/incseq/latest_product_impl.cljc @@ -115,19 +115,16 @@ (range l)))))) (defn freeze! [^ints freezer i] - (let [j (int (bit-shift-right i 5)) - k (int (bit-and i (unchecked-dec (bit-shift-left 1 5))))] - (aset freezer j (int (bit-set (aget freezer j) k))))) + (let [j (bit-shift-right i 5)] + (aset freezer j (unchecked-int (bit-set (aget freezer j) (bit-and i 31)))))) (defn unfreeze! [^ints freezer i] - (let [j (int (bit-shift-right i 5)) - k (int (bit-and i (unchecked-dec (bit-shift-left 1 5))))] - (aset freezer j (int (bit-clear (aget freezer j) k))))) + (let [j (bit-shift-right i 5)] + (aset freezer j (unchecked-int (bit-clear (aget freezer j) (bit-and i 31)))))) (defn frozen? [^ints freezer i] - (let [j (bit-shift-right i 5) - k (bit-and i (unchecked-dec (bit-shift-left 1 5)))] - (bit-test (aget freezer j) k))) + (let [j (bit-shift-right i 5)] + (bit-test (aget freezer j) (bit-and i 31)))) (defn flush-ready [^objects state item pull] (let [^objects processes (aget state slot-processes) From b9dae131d54941dd015d3074deb76112e0346f87 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20NOEL?= Date: Fri, 21 Jun 2024 11:19:12 +0200 Subject: [PATCH 245/428] mount-point fix NPE on cancellation --- src/hyperfiddle/electric/impl/mount_point.cljc | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/hyperfiddle/electric/impl/mount_point.cljc b/src/hyperfiddle/electric/impl/mount_point.cljc index 1500ac199..ac56f5c5a 100644 --- a/src/hyperfiddle/electric/impl/mount_point.cljc +++ b/src/hyperfiddle/electric/impl/mount_point.cljc @@ -669,9 +669,9 @@ Mounting a block generates a grow for each active item having this block's frame (aset block block-slot-next nil) (loop [i 0] (when (< i (r/frame-call-count f)) - ((if (nil? (r/frame-call f i)) - item-cancel call-cancel) - (block-child block i)) + (when-some [child (block-child block i)] + ((if (nil? (r/frame-call f i)) + item-cancel call-cancel) child)) (recur (inc i)))) (when-not (identical? n children) (recur n)))) From 4460c0769c1bce0f7f9ebc9456b1688db1a1dca7 Mon Sep 17 00:00:00 2001 From: Geoffrey Gaillard Date: Wed, 15 May 2024 14:56:22 +0200 Subject: [PATCH 246/428] Rename dom3_efn to dom3 --- src/hyperfiddle/electric_dom3.cljc | 331 +++++++++++------- src/hyperfiddle/electric_dom3_efns.cljc | 427 ------------------------ 2 files changed, 214 insertions(+), 544 deletions(-) delete mode 100644 src/hyperfiddle/electric_dom3_efns.cljc diff --git a/src/hyperfiddle/electric_dom3.cljc b/src/hyperfiddle/electric_dom3.cljc index 284a94d1f..2692d0d50 100644 --- a/src/hyperfiddle/electric_dom3.cljc +++ b/src/hyperfiddle/electric_dom3.cljc @@ -1,12 +1,29 @@ +;; * DONE Replace dom3 by dom3_efn +;; G: diffed both files, LGTM +;; * TODO move event handling to separate ns +;; So we can think clearly +;; We can always merge back later +;; * TODO Implement dom/text +;; * TODO Implement dom/comment +;; * TODO Implement dom/div +;; * TODO Implement dom/div nesting +;; * TODO Implement setting attributes +;; * TODO Implement setting class +;; * TODO Implement setting inline style +;; * TODO Implement event handling + (ns hyperfiddle.electric-dom3 (:refer-clojure :exclude [time class?]) (:require [clojure.string :as str] [contrib.assert :as ca] + [contrib.debug] #?(:cljs goog.dom) #?(:cljs goog.object) #?(:cljs goog.style) [hyperfiddle.electric-de :as e :refer [$]] + [hyperfiddle.electric.impl.lang-de2 :as lang] + [hyperfiddle.incseq :as i] [hyperfiddle.rcf :as rcf :refer [tests]] [missionary.core :as m]) #?(:clj (:import [clojure.lang ExceptionInfo])) @@ -14,14 +31,13 @@ (def node) -;; used as a speed hack during unmount -#?(:cljs (defn ^:no-doc hide [node] (set! (.. node -style -display) "none"))) +#?(:cljs (defn node? [v] (when v (= 1 (.-nodeType v))))) #?(:cljs (defn appending> [elem parent] - (ca/is parent some? "DOM node parent cannot be nil. Maybe dom/node is unbound?") + (ca/is parent node? "DOM node parent is not an HTML Node. Maybe dom/node is unbound?" {:parent parent}) (m/observe (fn [!] (.appendChild parent elem) (! elem) #(.remove elem))))) -(defmacro with [elem & body] `(binding [node (e/input (appending> ~elem node))] node ~@body)) +(e/defn With [elem Body] (binding [node (e/input (appending> elem node))] node ($ Body))) #?(:cljs (defn -googDomSetTextContentNoWarn [node str] ;; Electric says :infer-warning Cannot infer target type in expression, fixme @@ -32,18 +48,12 @@ #?(:cljs (defn text-node? [nd] (= (.-nodeType nd) (.-TEXT_NODE nd)))) #?(:cljs (defn ensure-not-in-text-node! [nd] (ca/is nd (complement text-node?) "Cannot nest dom/text or text nodes in other text nodes"))) -(defmacro text [& strs] - `(do #_(ensure-not-in-text-node! node) ; TODO adding this breaks unmounting - ~@(eduction (map (fn [str] - `(with (->text-node) - (-googDomSetTextContentNoWarn node ~str)))) - strs))) +(e/defn Text [str] ($ With (->text-node) (e/fn [] (-googDomSetTextContentNoWarn node str)))) + +(defmacro text [& strs] `(do (ensure-not-in-text-node! node) ~@(for [s strs] `($ Text ~s)))) -(defmacro comment_ [& strs] - `(do ~@(eduction (map (fn [str] - `(with (.createComment js/document "") - (-googDomSetTextContentNoWarn node ~str)))) - strs))) +(e/defn Comment [str] + ($ With (.createComment js/document "") (e/fn [] (-googDomSetTextContentNoWarn node str)))) (def ^:const SVG-NS "http://www.w3.org/2000/svg") (def ^:const XLINK-NS "http://www.w3.org/1999/xlink") @@ -152,7 +162,7 @@ (e/defn Styles [node kvs] (e/client - (let [[k v] (e/diff-by first kvs)] + (e/cursor [[k v] (e/diff-by first kvs)] ($ Style node k v)))) (defmacro style [m] @@ -198,104 +208,191 @@ ([nd typ f opts] `(listen> ~nd ~typ ~f ~opts))) #?(:cljs (defn ->elem [t] (goog.dom/createElement t))) -(defmacro element {:style/indent 1} [t & body] `(with (->elem ~(name t)) ~@body)) - -(defmacro a {:style/indent 0} [& body] `(element :a ~@body)) -(defmacro abbr {:style/indent 0} [& body] `(element :abbr ~@body)) -(defmacro address {:style/indent 0} [& body] `(element :address ~@body)) -(defmacro area {:style/indent 0} [& body] `(element :area ~@body)) -(defmacro article {:style/indent 0} [& body] `(element :article ~@body)) -(defmacro aside {:style/indent 0} [& body] `(element :aside ~@body)) -(defmacro audio {:style/indent 0} [& body] `(element :audio ~@body)) -(defmacro b {:style/indent 0} [& body] `(element :b ~@body)) -(defmacro bdi {:style/indent 0} [& body] `(element :bdi ~@body)) -(defmacro bdo {:style/indent 0} [& body] `(element :bdo ~@body)) -(defmacro blockquote {:style/indent 0} [& body] `(element :blockquote ~@body)) -(defmacro br {:style/indent 0} [& body] `(element :br ~@body)) -(defmacro button {:style/indent 0} [& body] `(element :button ~@body)) -(defmacro canvas {:style/indent 0} [& body] `(element :canvas ~@body)) -(defmacro cite {:style/indent 0} [& body] `(element :cite ~@body)) -(defmacro code {:style/indent 0} [& body] `(element :code ~@body)) -(defmacro colgroup {:style/indent 0} [& body] `(element :colgroup ~@body)) -(defmacro col {:style/indent 0} [& body] `(element :col ~@body)) -(defmacro data {:style/indent 0} [& body] `(element :data ~@body)) -(defmacro datalist {:style/indent 0} [& body] `(element :datalist ~@body)) -(defmacro del {:style/indent 0} [& body] `(element :del ~@body)) -(defmacro details {:style/indent 0} [& body] `(element :details ~@body)) -(defmacro dfn {:style/indent 0} [& body] `(element :dfn ~@body)) -(defmacro dialog {:style/indent 0} [& body] `(element :dialog ~@body)) -(defmacro div {:style/indent 0} [& body] `(element :div ~@body)) -(defmacro dl "The
HTML element represents a description list. The element encloses a list of groups of terms (specified using the
element) and descriptions (provided by
elements). Common uses for this element are to implement a glossary or to display metadata (a list of key-value pairs)." {:style/indent 0} [& body] `(element :dl ~@body)) -(defmacro dt "The
HTML element specifies a term in a description or definition list, and as such must be used inside a
element. It is usually followed by a
element; however, multiple
elements in a row indicate several terms that are all defined by the immediate next
element." {:style/indent 0} [& body] `(element :dt ~@body)) -(defmacro dd "The
HTML element provides the description, definition, or value for the preceding term (
) in a description list (
)." {:style/indent 0} [& body] `(element :dd ~@body)) -(defmacro em {:style/indent 0} [& body] `(element :em ~@body)) -(defmacro embed {:style/indent 0} [& body] `(element :embed ~@body)) -(defmacro fieldset {:style/indent 0} [& body] `(element :fieldset ~@body)) -(defmacro figure {:style/indent 0} [& body] `(element :figure ~@body)) -(defmacro footer {:style/indent 0} [& body] `(element :footer ~@body)) -(defmacro form {:style/indent 0} [& body] `(element :form ~@body)) -(defmacro h1 {:style/indent 0} [& body] `(element :h1 ~@body)) -(defmacro h2 {:style/indent 0} [& body] `(element :h2 ~@body)) -(defmacro h3 {:style/indent 0} [& body] `(element :h3 ~@body)) -(defmacro h4 {:style/indent 0} [& body] `(element :h4 ~@body)) -(defmacro h5 {:style/indent 0} [& body] `(element :h5 ~@body)) -(defmacro h6 {:style/indent 0} [& body] `(element :h6 ~@body)) -(defmacro header {:style/indent 0} [& body] `(element :header ~@body)) -(defmacro hgroup {:style/indent 0} [& body] `(element :hgroup ~@body)) -(defmacro hr {:style/indent 0} [& body] `(element :hr ~@body)) -(defmacro i {:style/indent 0} [& body] `(element :i ~@body)) -(defmacro iframe {:style/indent 0} [& body] `(element :iframe ~@body)) -(defmacro img {:style/indent 0} [& body] `(element :img ~@body)) -(defmacro input {:style/indent 0} [& body] `(element :input ~@body)) -(defmacro ins {:style/indent 0} [& body] `(element :ins ~@body)) -(defmacro kbd {:style/indent 0} [& body] `(element :kbd ~@body)) -(defmacro label {:style/indent 0} [& body] `(element :label ~@body)) -(defmacro legend {:style/indent 0} [& body] `(element :legend ~@body)) -(defmacro li {:style/indent 0} [& body] `(element :li ~@body)) -(defmacro link {:style/indent 0} [& body] `(element :link ~@body)) -(defmacro main {:style/indent 0} [& body] `(element :main ~@body)) -#_(defmacro map {:style/indent 0} [& body] `(element :map ~@body)) -(defmacro mark {:style/indent 0} [& body] `(element :mark ~@body)) -(defmacro math {:style/indent 0} [& body] `(element :math ~@body)) -(defmacro menu {:style/indent 0} [& body] `(element :menu ~@body)) -(defmacro itemprop {:style/indent 0} [& body] `(element :itemprop ~@body)) -(defmacro meter {:style/indent 0} [& body] `(element :meter ~@body)) -(defmacro nav {:style/indent 0} [& body] `(element :nav ~@body)) -(defmacro noscript {:style/indent 0} [& body] `(element :noscript ~@body)) -(defmacro object {:style/indent 0} [& body] `(element :object ~@body)) -(defmacro ol {:style/indent 0} [& body] `(element :ol ~@body)) -(defmacro option {:style/indent 0} [& body] `(element :option ~@body)) -(defmacro optgroup {:style/indent 0} [& body] `(element :optgroup ~@body)) -(defmacro output {:style/indent 0} [& body] `(element :output ~@body)) -(defmacro p {:style/indent 0} [& body] `(element :p ~@body)) -(defmacro picture {:style/indent 0} [& body] `(element :picture ~@body)) -(defmacro pre {:style/indent 0} [& body] `(element :pre ~@body)) -(defmacro progress {:style/indent 0} [& body] `(element :progress ~@body)) -(defmacro q {:style/indent 0} [& body] `(element :q ~@body)) -(defmacro ruby {:style/indent 0} [& body] `(element :ruby ~@body)) -(defmacro s {:style/indent 0} [& body] `(element :s ~@body)) -(defmacro samp {:style/indent 0} [& body] `(element :samp ~@body)) -(defmacro script {:style/indent 0} [& body] `(element :script ~@body)) -(defmacro section {:style/indent 0} [& body] `(element :section ~@body)) -(defmacro select {:style/indent 0} [& body] `(element :select ~@body)) -(defmacro slot {:style/indent 0} [& body] `(element :slot ~@body)) -(defmacro small {:style/indent 0} [& body] `(element :small ~@body)) -(defmacro span {:style/indent 0} [& body] `(element :span ~@body)) -(defmacro strong {:style/indent 0} [& body] `(element :strong ~@body)) -(defmacro sub {:style/indent 0} [& body] `(element :sub ~@body)) -(defmacro summary {:style/indent 0} [& body] `(element :summary ~@body)) -(defmacro sup {:style/indent 0} [& body] `(element :sup ~@body)) -(defmacro table {:style/indent 0} [& body] `(element :table ~@body)) -(defmacro tbody {:style/indent 0} [& body] `(element :tbody ~@body)) -(defmacro td {:style/indent 0} [& body] `(element :td ~@body)) -(defmacro th {:style/indent 0} [& body] `(element :th ~@body)) -(defmacro thead {:style/indent 0} [& body] `(element :thead ~@body)) -(defmacro tr {:style/indent 0} [& body] `(element :tr ~@body)) -(defmacro template {:style/indent 0} [& body] `(element :template ~@body)) -(defmacro textarea {:style/indent 0} [& body] `(element :textarea ~@body)) -(defmacro time {:style/indent 0} [& body] `(element :time ~@body)) -(defmacro u {:style/indent 0} [& body] `(element :u ~@body)) -(defmacro ul {:style/indent 0} [& body] `(element :ul ~@body)) -(defmacro var {:style/indent 0} [& body] `(element :var ~@body)) -(defmacro video {:style/indent 0} [& body] `(element :video ~@body)) -(defmacro wbr {:style/indent 0} [& body] `(element :wbr ~@body)) + +(defmacro a {:style/indent 0} [& body] `($ With (->elem "a") (e/fn [] ~@body))) +(defmacro abbr {:style/indent 0} [& body] `($ With (->elem "abbr") (e/fn [] ~@body))) +(defmacro address {:style/indent 0} [& body] `($ With (->elem "address") (e/fn [] ~@body))) +(defmacro area {:style/indent 0} [& body] `($ With (->elem "area") (e/fn [] ~@body))) +(defmacro article {:style/indent 0} [& body] `($ With (->elem "article") (e/fn [] ~@body))) +(defmacro aside {:style/indent 0} [& body] `($ With (->elem "aside") (e/fn [] ~@body))) +(defmacro audio {:style/indent 0} [& body] `($ With (->elem "audio") (e/fn [] ~@body))) +(defmacro b {:style/indent 0} [& body] `($ With (->elem "b") (e/fn [] ~@body))) +(defmacro bdi {:style/indent 0} [& body] `($ With (->elem "bdi") (e/fn [] ~@body))) +(defmacro bdo {:style/indent 0} [& body] `($ With (->elem "bdo") (e/fn [] ~@body))) +(defmacro blockquote {:style/indent 0} [& body] `($ With (->elem "blockquote") (e/fn [] ~@body))) +(defmacro br {:style/indent 0} [& body] `($ With (->elem "br") (e/fn [] ~@body))) +(defmacro button {:style/indent 0} [& body] `($ With (->elem "button") (e/fn [] ~@body))) +(defmacro canvas {:style/indent 0} [& body] `($ With (->elem "canvas") (e/fn [] ~@body))) +(defmacro cite {:style/indent 0} [& body] `($ With (->elem "cite") (e/fn [] ~@body))) +(defmacro code {:style/indent 0} [& body] `($ With (->elem "code") (e/fn [] ~@body))) +(defmacro colgroup {:style/indent 0} [& body] `($ With (->elem "colgroup") (e/fn [] ~@body))) +(defmacro col {:style/indent 0} [& body] `($ With (->elem "col") (e/fn [] ~@body))) +(defmacro data {:style/indent 0} [& body] `($ With (->elem "data") (e/fn [] ~@body))) +(defmacro datalist {:style/indent 0} [& body] `($ With (->elem "datalist") (e/fn [] ~@body))) +(defmacro del {:style/indent 0} [& body] `($ With (->elem "del") (e/fn [] ~@body))) +(defmacro details {:style/indent 0} [& body] `($ With (->elem "details") (e/fn [] ~@body))) +(defmacro dfn {:style/indent 0} [& body] `($ With (->elem "dfn") (e/fn [] ~@body))) +(defmacro dialog {:style/indent 0} [& body] `($ With (->elem "dialog") (e/fn [] ~@body))) +(defmacro div {:style/indent 0} [& body] `($ With (->elem "div") (e/fn [] ~@body))) +(defmacro dl "The
HTML element represents a description list. The element encloses a list of groups of terms (specified using the
element) and descriptions (provided by
elements). Common uses for this element are to implement a glossary or to display metadata (a list of key-value pairs)." {:style/indent 0} [& body] `($ With (->elem "dl") (e/fn [] ~@body))) +(defmacro dt "The
HTML element specifies a term in a description or definition list, and as such must be used inside a
element. It is usually followed by a
element; however, multiple
elements in a row indicate several terms that are all defined by the immediate next
element." {:style/indent 0} [& body] `($ With (->elem "dt") (e/fn [] ~@body))) +(defmacro dd "The
HTML element provides the description, definition, or value for the preceding term (
) in a description list (
)." {:style/indent 0} [& body] `($ With (->elem "dd") (e/fn [] ~@body))) +(defmacro em {:style/indent 0} [& body] `($ With (->elem "em") (e/fn [] ~@body))) +(defmacro embed {:style/indent 0} [& body] `($ With (->elem "embed") (e/fn [] ~@body))) +(defmacro fieldset {:style/indent 0} [& body] `($ With (->elem "fieldset") (e/fn [] ~@body))) +(defmacro figure {:style/indent 0} [& body] `($ With (->elem "figure") (e/fn [] ~@body))) +(defmacro footer {:style/indent 0} [& body] `($ With (->elem "footer") (e/fn [] ~@body))) +(defmacro form {:style/indent 0} [& body] `($ With (->elem "form") (e/fn [] ~@body))) +(defmacro h1 {:style/indent 0} [& body] `($ With (->elem "h1") (e/fn [] ~@body))) +(defmacro h2 {:style/indent 0} [& body] `($ With (->elem "h2") (e/fn [] ~@body))) +(defmacro h3 {:style/indent 0} [& body] `($ With (->elem "h3") (e/fn [] ~@body))) +(defmacro h4 {:style/indent 0} [& body] `($ With (->elem "h4") (e/fn [] ~@body))) +(defmacro h5 {:style/indent 0} [& body] `($ With (->elem "h5") (e/fn [] ~@body))) +(defmacro h6 {:style/indent 0} [& body] `($ With (->elem "h6") (e/fn [] ~@body))) +(defmacro header {:style/indent 0} [& body] `($ With (->elem "header") (e/fn [] ~@body))) +(defmacro hgroup {:style/indent 0} [& body] `($ With (->elem "hgroup") (e/fn [] ~@body))) +(defmacro hr {:style/indent 0} [& body] `($ With (->elem "hr") (e/fn [] ~@body))) +(defmacro i {:style/indent 0} [& body] `($ With (->elem "i") (e/fn [] ~@body))) +(defmacro iframe {:style/indent 0} [& body] `($ With (->elem "iframe") (e/fn [] ~@body))) +(defmacro img {:style/indent 0} [& body] `($ With (->elem "img") (e/fn [] ~@body))) +(defmacro input {:style/indent 0} [& body] `($ With (->elem "input") (e/fn [] ~@body))) +(defmacro ins {:style/indent 0} [& body] `($ With (->elem "ins") (e/fn [] ~@body))) +(defmacro kbd {:style/indent 0} [& body] `($ With (->elem "kbd") (e/fn [] ~@body))) +(defmacro label {:style/indent 0} [& body] `($ With (->elem "label") (e/fn [] ~@body))) +(defmacro legend {:style/indent 0} [& body] `($ With (->elem "legend") (e/fn [] ~@body))) +(defmacro li {:style/indent 0} [& body] `($ With (->elem "li") (e/fn [] ~@body))) +(defmacro link {:style/indent 0} [& body] `($ With (->elem "link") (e/fn [] ~@body))) +(defmacro main {:style/indent 0} [& body] `($ With (->elem "main") (e/fn [] ~@body))) +#_(defmacro map {:style/indent 0} [& body] `($ With (->elem "map") (e/fn [] ~@body))) +(defmacro mark {:style/indent 0} [& body] `($ With (->elem "mark") (e/fn [] ~@body))) +(defmacro math {:style/indent 0} [& body] `($ With (->elem "math") (e/fn [] ~@body))) +(defmacro menu {:style/indent 0} [& body] `($ With (->elem "menu") (e/fn [] ~@body))) +(defmacro itemprop {:style/indent 0} [& body] `($ With (->elem "itemprop") (e/fn [] ~@body))) +(defmacro meter {:style/indent 0} [& body] `($ With (->elem "meter") (e/fn [] ~@body))) +(defmacro nav {:style/indent 0} [& body] `($ With (->elem "nav") (e/fn [] ~@body))) +(defmacro noscript {:style/indent 0} [& body] `($ With (->elem "noscript") (e/fn [] ~@body))) +(defmacro object {:style/indent 0} [& body] `($ With (->elem "object") (e/fn [] ~@body))) +(defmacro ol {:style/indent 0} [& body] `($ With (->elem "ol") (e/fn [] ~@body))) +(defmacro option {:style/indent 0} [& body] `($ With (->elem "option") (e/fn [] ~@body))) +(defmacro optgroup {:style/indent 0} [& body] `($ With (->elem "optgroup") (e/fn [] ~@body))) +(defmacro output {:style/indent 0} [& body] `($ With (->elem "output") (e/fn [] ~@body))) +(defmacro p {:style/indent 0} [& body] `($ With (->elem "p") (e/fn [] ~@body))) +(defmacro picture {:style/indent 0} [& body] `($ With (->elem "picture") (e/fn [] ~@body))) +(defmacro pre {:style/indent 0} [& body] `($ With (->elem "pre") (e/fn [] ~@body))) +(defmacro progress {:style/indent 0} [& body] `($ With (->elem "progress") (e/fn [] ~@body))) +(defmacro q {:style/indent 0} [& body] `($ With (->elem "q") (e/fn [] ~@body))) +(defmacro ruby {:style/indent 0} [& body] `($ With (->elem "ruby") (e/fn [] ~@body))) +(defmacro s {:style/indent 0} [& body] `($ With (->elem "s") (e/fn [] ~@body))) +(defmacro samp {:style/indent 0} [& body] `($ With (->elem "samp") (e/fn [] ~@body))) +(defmacro script {:style/indent 0} [& body] `($ With (->elem "script") (e/fn [] ~@body))) +(defmacro section {:style/indent 0} [& body] `($ With (->elem "section") (e/fn [] ~@body))) +(defmacro select {:style/indent 0} [& body] `($ With (->elem "select") (e/fn [] ~@body))) +(defmacro slot {:style/indent 0} [& body] `($ With (->elem "slot") (e/fn [] ~@body))) +(defmacro small {:style/indent 0} [& body] `($ With (->elem "small") (e/fn [] ~@body))) +(defmacro span {:style/indent 0} [& body] `($ With (->elem "span") (e/fn [] ~@body))) +(defmacro strong {:style/indent 0} [& body] `($ With (->elem "strong") (e/fn [] ~@body))) +(defmacro sub {:style/indent 0} [& body] `($ With (->elem "sub") (e/fn [] ~@body))) +(defmacro summary {:style/indent 0} [& body] `($ With (->elem "summary") (e/fn [] ~@body))) +(defmacro sup {:style/indent 0} [& body] `($ With (->elem "sup") (e/fn [] ~@body))) +(defmacro table {:style/indent 0} [& body] `($ With (->elem "table") (e/fn [] ~@body))) +(defmacro tbody {:style/indent 0} [& body] `($ With (->elem "tbody") (e/fn [] ~@body))) +(defmacro td {:style/indent 0} [& body] `($ With (->elem "td") (e/fn [] ~@body))) +(defmacro th {:style/indent 0} [& body] `($ With (->elem "th") (e/fn [] ~@body))) +(defmacro thead {:style/indent 0} [& body] `($ With (->elem "thead") (e/fn [] ~@body))) +(defmacro tr {:style/indent 0} [& body] `($ With (->elem "tr") (e/fn [] ~@body))) +(defmacro template {:style/indent 0} [& body] `($ With (->elem "template") (e/fn [] ~@body))) +(defmacro textarea {:style/indent 0} [& body] `($ With (->elem "textarea") (e/fn [] ~@body))) +(defmacro time {:style/indent 0} [& body] `($ With (->elem "time") (e/fn [] ~@body))) +(defmacro u {:style/indent 0} [& body] `($ With (->elem "u") (e/fn [] ~@body))) +(defmacro ul {:style/indent 0} [& body] `($ With (->elem "ul") (e/fn [] ~@body))) +(defmacro var {:style/indent 0} [& body] `($ With (->elem "var") (e/fn [] ~@body))) +(defmacro video {:style/indent 0} [& body] `($ With (->elem "video") (e/fn [] ~@body))) +(defmacro wbr {:style/indent 0} [& body] `($ With (->elem "wbr") (e/fn [] ~@body))) + +#?(:cljs + ;; TODO starts as empty incseq, later singleton changing value + (defn listen1 [nd typ f opts] + (m/observe (fn [!] + (! nil) + (let [! (comp ! f) , opts (clj->js opts)] + (.addEventListener nd typ ! opts)) #(.removeEventListener nd typ ! opts))))) + +(defmacro listen2 + ([typ] `(listen ~typ identity)) + ([typ f] `(listen node ~typ ~f)) + ([nd typ f] `(listen ~nd ~typ ~f nil)) + ([nd typ f opts] `(e/input (listen1 ~nd ~typ ~f ~opts)))) + +(defn append-only [> js opts)] + (.addEventListener nd typ ! opts)) #(.removeEventListener nd typ ! opts)))))) + +(defmacro event-log + ([typ] `(event-log ~typ identity)) + ([typ f] `(event-log node ~typ ~f)) + ([nd typ f] `(event-log ~nd ~typ ~f nil)) + ([nd typ f opts] `(e/join (event-log* ~nd ~typ ~f ~opts)))) + + +;;;;;;;;;;;;;;;;;;;;;; +;;; NEXT ITERATION ;;; +;;;;;;;;;;;;;;;;;;;;;; + +#?(:cljs (defn listen* + ([node typ] (listen* node typ identity)) + ([node typ f] (listen* node typ f {})) + ([node typ f opts] + (m/observe (fn [!] + (let [! #(! (f %)), opts (clj->js opts)] + (.addEventListener node typ ! opts) + #(.removeEventListener node typ ! opts))))))) + +#?(:cljs (defn listen*-some + ([node typ] (listen*-some node typ identity)) + ([node typ f] (listen*-some node typ f {})) + ([node typ f opts] + (m/observe (fn [!] + (let [! #(some-> (f %) !), opts (clj->js opts)] + (.addEventListener node typ ! opts) + #(.removeEventListener node typ ! opts)))) + #_(m/eduction (filter some?) (listen* node typ f opts))))) + +(defn uf->is [uf] + (m/ap (m/amb (i/empty-diff 0) + (let [!first (atom true) v (m/?> uf)] + (assoc (i/empty-diff 1) :grow (if @!first (do (swap! !first not) 1) 0), :change {0 v}))))) + +(comment + (def !! (atom nil)) + (def ps ((uf->is (m/observe (fn [!] (reset! !! !) #()))) #(prn :step) #(prn :done))) + (def v []) + (alter-var-root #'v i/patch-vec @ps) + (@!! 5) + ) + +(defn event->task [flow] + (uf->is (m/ap + (let [!busy? (atom false) + v (m/?> (m/eduction (remove (fn [_] @!busy?)) flow)) + dfv (m/dfv), done! #(dfv false)] + (m/amb + [v done! (reset! !busy? true)] + [v done! (reset! !busy? (m/? dfv))]))))) + +(defn event->tasks [flow] + (uf->is + (m/ap + (let [S (i/spine)] + (m/amb S + (let [v (m/?> flow), id (random-uuid)] + (S id {} [v #(S id {} nil)]) + (m/amb))))))) diff --git a/src/hyperfiddle/electric_dom3_efns.cljc b/src/hyperfiddle/electric_dom3_efns.cljc deleted file mode 100644 index 85e7bbfba..000000000 --- a/src/hyperfiddle/electric_dom3_efns.cljc +++ /dev/null @@ -1,427 +0,0 @@ -(ns hyperfiddle.electric-dom3-efns - (:refer-clojure :exclude [time class?]) - (:require - [clojure.string :as str] - [contrib.assert :as ca] - [contrib.debug] - #?(:cljs goog.dom) - #?(:cljs goog.object) - #?(:cljs goog.style) - [hyperfiddle.electric-de :as e :refer [$]] - [hyperfiddle.electric.impl.lang-de2 :as lang] - [hyperfiddle.incseq :as i] - [hyperfiddle.rcf :as rcf :refer [tests]] - [missionary.core :as m]) - #?(:clj (:import [clojure.lang ExceptionInfo])) - #?(:cljs (:require-macros [hyperfiddle.electric-dom3-efns]))) - -(def node) - -#?(:cljs (defn node? [v] (when v (= 1 (.-nodeType v))))) - -#?(:cljs (defn appending> [elem parent] - (ca/is parent node? "DOM node parent is not an HTML Node. Maybe dom/node is unbound?" {:parent parent}) - (m/observe (fn [!] (.appendChild parent elem) (! elem) #(.remove elem))))) - -(e/defn With [elem Body] (binding [node (e/input (appending> elem node))] node ($ Body))) - -#?(:cljs (defn -googDomSetTextContentNoWarn [node str] - ;; Electric says :infer-warning Cannot infer target type in expression, fixme - (goog.dom/setTextContent node str))) - -#?(:cljs (defn ->text-node [] (goog.dom/createTextNode ""))) - -#?(:cljs (defn text-node? [nd] (= (.-nodeType nd) (.-TEXT_NODE nd)))) -#?(:cljs (defn ensure-not-in-text-node! [nd] (ca/is nd (complement text-node?) "Cannot nest dom/text or text nodes in other text nodes"))) - -(e/defn Text [str] ($ With (->text-node) (e/fn [] (-googDomSetTextContentNoWarn node str)))) - -(defmacro text [& strs] `(do (ensure-not-in-text-node! node) ~@(for [s strs] `($ Text ~s)))) - -(e/defn Comment [str] - ($ With (.createComment js/document "") (e/fn [] (-googDomSetTextContentNoWarn node str)))) - -(def ^:const SVG-NS "http://www.w3.org/2000/svg") -(def ^:const XLINK-NS "http://www.w3.org/1999/xlink") - -(def alias->ns {"svg" SVG-NS, "xlink" XLINK-NS}) - -(defn attr-alias [attr] (second (re-find #"^([^:]+):" (name attr)))) - -(defn resolve-attr-alias [attr] - (let [attr (name attr)] - (if-let [alias (attr-alias attr)] - (let [attr (-> (str/replace-first attr alias "") - (str/replace-first #"^:" ""))] - [(alias->ns alias) attr]) - [nil attr]))) - -#?(:cljs - (defn set-attribute-ns - ([node attr v] - (let [[ns attr] (resolve-attr-alias attr)] - (set-attribute-ns node ns attr v))) - ([^js node ns attr v] - (.setAttributeNS node ns attr v)))) - -#?(:cljs (defn- css-var? [k] (str/starts-with? k "--"))) -#?(:cljs (defn set-style> [node k v] - (let [k (clj->js k), v (clj->js v) - setter (if (css-var? k) #(.setProperty (.-style node) k %) #(goog.style/setStyle_ node % k))] - (m/observe (fn [!] (setter v) (! v) #(setter nil)))))) - -#?(:cljs (defn set-property> - ([node k v] (set-property> node (.-namespaceURI node) k v)) - ([node ns k v] - (let [k (name k), v (clj->js v) - setter (case k - "list" ; corner case, list (datalist) is set by attribute and readonly as a prop. - #(set-attribute-ns node nil k %) - (if (or (= SVG-NS ns) (some? (goog.object/get goog.dom/DIRECT_ATTRIBUTE_MAP_ k))) - #(set-attribute-ns node k %) - (if (goog.object/containsKey node k) ; is there an object property for this key? - #(goog.object/set node k %) - #(set-attribute-ns node k %))))] - (m/observe (fn [!] (setter v) (! v) #(setter nil))))))) - -(def LAST-PROPS - "Due to a bug in both Webkit and FF, input type range's knob renders in the - wrong place if value is set after `min` and `max`, and `max` is above 100. - Other UI libs circumvent this issue by setting `value` last." - [:value ::value]) - -(defn ordered-props "Sort props by key to ensure they are applied in a predefined order. See `LAST-PROPS`." - [props-map] - (let [props (apply dissoc props-map LAST-PROPS)] - (concat (seq props) (seq (select-keys props-map LAST-PROPS))))) - -(defn parse-class [xs] - (cond (or (string? xs) (keyword? xs) (symbol? xs)) (re-seq #"[^\s]+" (name xs)) - (or (vector? xs) (seq? xs) (list? xs) (set? xs)) (into [] (comp (mapcat parse-class) (distinct)) xs) - (nil? xs) nil - :else (throw (ex-info "don't know how to parse into a classlist" {:data xs})))) - -(tests - (parse-class "a") := ["a"] - (parse-class :a) := ["a"] - (parse-class 'a/b) := ["b"] - (parse-class "a b") := ["a" "b"] - (parse-class ["a"]) := ["a"] - (parse-class ["a" "b" "a"]) := ["a" "b"] - (parse-class ["a" "b"]) := ["a" "b"] - (parse-class ["a b" "c"]) := ["a" "b" "c"] - (parse-class [["a b"] '("c d") #{#{"e"} "f"}]) := ["a" "b" "c" "d" "e" "f"] - (parse-class nil) := nil - (parse-class "") := nil - (parse-class " a") := ["a"] - (try (parse-class 42) (throw (ex-info "" {})) - (catch ExceptionInfo ex (ex-data ex) := {:data 42}))) - -#?(:cljs - (defn register-class! [^js node class] - (let [refs (or (.-hyperfiddle_electric_dom2_class_refs node) {})] - (.add (.-classList node) class) - (set! (.-hyperfiddle_electric_dom2_class_refs node) (update refs class (fn [cnt] (inc (or cnt 0)))))))) - -#?(:cljs - (defn unregister-class! [^js node class] - (let [refs (or (.-hyperfiddle_electric_dom2_class_refs node) {}) - refs (if (= 1 (get refs class)) - (do (.remove (.-classList node) class) - (dissoc refs class)) - (update refs class dec))] - (set! (.-hyperfiddle_electric_dom2_class_refs node) refs)))) - -#?(:cljs - (defn- manage-class> [node class] - (m/relieve {} - (m/observe (fn [!] - (! nil) - (register-class! node class) - #(unregister-class! node class)))))) - -(e/defn ClassList [node classes] - (e/client - (e/input (manage-class> node (e/diff-by identity (parse-class classes)))))) - -(e/defn Style [node k v] (e/client (e/input (set-style> node k v)))) - -(e/defn Styles [node kvs] - (e/client - (e/cursor [[k v] (e/diff-by first kvs)] - ($ Style node k v)))) - -(defmacro style [m] - (if (map? m) ; map = static keyset, no need to diff, cheaper - `(do ~@(map (fn [[k v]] `($ Style node ~k ~v)) m)) - `($ Styles node ~m))) - -(e/defn Attribute [node k v] (e/client (e/input (set-property> node k v)))) - -(def ^:private style? #{:style ::style}) ; TODO disambiguate -(def ^:private class? #{:class ::class}) - -(e/defn Property [node k v] - (e/client - (cond (style? k) ($ Styles node v) - (class? k) ($ ClassList node v) - :else ($ Attribute node k v)))) - -(e/defn Properties [node kvs] - (e/client - (let [[k v] (e/diff-by key (ordered-props kvs))] - ($ Property node k v)))) - -(defmacro props [m] - (if (map? m) ; map = static keyset, no need to diff, cheaper - `(do ~@(eduction (map (fn [[k v]] `($ Property node ~k ~v))) - (ordered-props m))) - `(do (let [[k# v#] (e/diff-by key (ordered-props ~m))] - ($ Property node k# v#)) - nil))) - -#?(:cljs - (defn listen> [nd typ f opts] - (m/observe (fn [!] - (! nil) - (let [! (comp ! f), opts (clj->js opts)] - (.addEventListener nd typ ! opts)) #(.removeEventListener nd typ ! opts))))) - -(defmacro listen - ([typ] `(listen ~typ identity)) - ([typ f] `(listen ~typ ~f node)) - ([nd typ f] `(listen ~nd ~typ ~f nil)) - ([nd typ f opts] `(listen> ~nd ~typ ~f ~opts))) - -#?(:cljs (defn ->elem [t] (goog.dom/createElement t))) - -(defmacro a {:style/indent 0} [& body] `($ With (->elem "a") (e/fn [] ~@body))) -(defmacro abbr {:style/indent 0} [& body] `($ With (->elem "abbr") (e/fn [] ~@body))) -(defmacro address {:style/indent 0} [& body] `($ With (->elem "address") (e/fn [] ~@body))) -(defmacro area {:style/indent 0} [& body] `($ With (->elem "area") (e/fn [] ~@body))) -(defmacro article {:style/indent 0} [& body] `($ With (->elem "article") (e/fn [] ~@body))) -(defmacro aside {:style/indent 0} [& body] `($ With (->elem "aside") (e/fn [] ~@body))) -(defmacro audio {:style/indent 0} [& body] `($ With (->elem "audio") (e/fn [] ~@body))) -(defmacro b {:style/indent 0} [& body] `($ With (->elem "b") (e/fn [] ~@body))) -(defmacro bdi {:style/indent 0} [& body] `($ With (->elem "bdi") (e/fn [] ~@body))) -(defmacro bdo {:style/indent 0} [& body] `($ With (->elem "bdo") (e/fn [] ~@body))) -(defmacro blockquote {:style/indent 0} [& body] `($ With (->elem "blockquote") (e/fn [] ~@body))) -(defmacro br {:style/indent 0} [& body] `($ With (->elem "br") (e/fn [] ~@body))) -(defmacro button {:style/indent 0} [& body] `($ With (->elem "button") (e/fn [] ~@body))) -(defmacro canvas {:style/indent 0} [& body] `($ With (->elem "canvas") (e/fn [] ~@body))) -(defmacro cite {:style/indent 0} [& body] `($ With (->elem "cite") (e/fn [] ~@body))) -(defmacro code {:style/indent 0} [& body] `($ With (->elem "code") (e/fn [] ~@body))) -(defmacro colgroup {:style/indent 0} [& body] `($ With (->elem "colgroup") (e/fn [] ~@body))) -(defmacro col {:style/indent 0} [& body] `($ With (->elem "col") (e/fn [] ~@body))) -(defmacro data {:style/indent 0} [& body] `($ With (->elem "data") (e/fn [] ~@body))) -(defmacro datalist {:style/indent 0} [& body] `($ With (->elem "datalist") (e/fn [] ~@body))) -(defmacro del {:style/indent 0} [& body] `($ With (->elem "del") (e/fn [] ~@body))) -(defmacro details {:style/indent 0} [& body] `($ With (->elem "details") (e/fn [] ~@body))) -(defmacro dfn {:style/indent 0} [& body] `($ With (->elem "dfn") (e/fn [] ~@body))) -(defmacro dialog {:style/indent 0} [& body] `($ With (->elem "dialog") (e/fn [] ~@body))) -(defmacro div {:style/indent 0} [& body] `($ With (->elem "div") (e/fn [] ~@body))) -(defmacro dl "The
HTML element represents a description list. The element encloses a list of groups of terms (specified using the
element) and descriptions (provided by
elements). Common uses for this element are to implement a glossary or to display metadata (a list of key-value pairs)." {:style/indent 0} [& body] `($ With (->elem "dl") (e/fn [] ~@body))) -(defmacro dt "The
HTML element specifies a term in a description or definition list, and as such must be used inside a
element. It is usually followed by a
element; however, multiple
elements in a row indicate several terms that are all defined by the immediate next
element." {:style/indent 0} [& body] `($ With (->elem "dt") (e/fn [] ~@body))) -(defmacro dd "The
HTML element provides the description, definition, or value for the preceding term (
) in a description list (
)." {:style/indent 0} [& body] `($ With (->elem "dd") (e/fn [] ~@body))) -(defmacro em {:style/indent 0} [& body] `($ With (->elem "em") (e/fn [] ~@body))) -(defmacro embed {:style/indent 0} [& body] `($ With (->elem "embed") (e/fn [] ~@body))) -(defmacro fieldset {:style/indent 0} [& body] `($ With (->elem "fieldset") (e/fn [] ~@body))) -(defmacro figure {:style/indent 0} [& body] `($ With (->elem "figure") (e/fn [] ~@body))) -(defmacro footer {:style/indent 0} [& body] `($ With (->elem "footer") (e/fn [] ~@body))) -(defmacro form {:style/indent 0} [& body] `($ With (->elem "form") (e/fn [] ~@body))) -(defmacro h1 {:style/indent 0} [& body] `($ With (->elem "h1") (e/fn [] ~@body))) -(defmacro h2 {:style/indent 0} [& body] `($ With (->elem "h2") (e/fn [] ~@body))) -(defmacro h3 {:style/indent 0} [& body] `($ With (->elem "h3") (e/fn [] ~@body))) -(defmacro h4 {:style/indent 0} [& body] `($ With (->elem "h4") (e/fn [] ~@body))) -(defmacro h5 {:style/indent 0} [& body] `($ With (->elem "h5") (e/fn [] ~@body))) -(defmacro h6 {:style/indent 0} [& body] `($ With (->elem "h6") (e/fn [] ~@body))) -(defmacro header {:style/indent 0} [& body] `($ With (->elem "header") (e/fn [] ~@body))) -(defmacro hgroup {:style/indent 0} [& body] `($ With (->elem "hgroup") (e/fn [] ~@body))) -(defmacro hr {:style/indent 0} [& body] `($ With (->elem "hr") (e/fn [] ~@body))) -(defmacro i {:style/indent 0} [& body] `($ With (->elem "i") (e/fn [] ~@body))) -(defmacro iframe {:style/indent 0} [& body] `($ With (->elem "iframe") (e/fn [] ~@body))) -(defmacro img {:style/indent 0} [& body] `($ With (->elem "img") (e/fn [] ~@body))) -(defmacro input {:style/indent 0} [& body] `($ With (->elem "input") (e/fn [] ~@body))) -(defmacro ins {:style/indent 0} [& body] `($ With (->elem "ins") (e/fn [] ~@body))) -(defmacro kbd {:style/indent 0} [& body] `($ With (->elem "kbd") (e/fn [] ~@body))) -(defmacro label {:style/indent 0} [& body] `($ With (->elem "label") (e/fn [] ~@body))) -(defmacro legend {:style/indent 0} [& body] `($ With (->elem "legend") (e/fn [] ~@body))) -(defmacro li {:style/indent 0} [& body] `($ With (->elem "li") (e/fn [] ~@body))) -(defmacro link {:style/indent 0} [& body] `($ With (->elem "link") (e/fn [] ~@body))) -(defmacro main {:style/indent 0} [& body] `($ With (->elem "main") (e/fn [] ~@body))) -#_(defmacro map {:style/indent 0} [& body] `($ With (->elem "map") (e/fn [] ~@body))) -(defmacro mark {:style/indent 0} [& body] `($ With (->elem "mark") (e/fn [] ~@body))) -(defmacro math {:style/indent 0} [& body] `($ With (->elem "math") (e/fn [] ~@body))) -(defmacro menu {:style/indent 0} [& body] `($ With (->elem "menu") (e/fn [] ~@body))) -(defmacro itemprop {:style/indent 0} [& body] `($ With (->elem "itemprop") (e/fn [] ~@body))) -(defmacro meter {:style/indent 0} [& body] `($ With (->elem "meter") (e/fn [] ~@body))) -(defmacro nav {:style/indent 0} [& body] `($ With (->elem "nav") (e/fn [] ~@body))) -(defmacro noscript {:style/indent 0} [& body] `($ With (->elem "noscript") (e/fn [] ~@body))) -(defmacro object {:style/indent 0} [& body] `($ With (->elem "object") (e/fn [] ~@body))) -(defmacro ol {:style/indent 0} [& body] `($ With (->elem "ol") (e/fn [] ~@body))) -(defmacro option {:style/indent 0} [& body] `($ With (->elem "option") (e/fn [] ~@body))) -(defmacro optgroup {:style/indent 0} [& body] `($ With (->elem "optgroup") (e/fn [] ~@body))) -(defmacro output {:style/indent 0} [& body] `($ With (->elem "output") (e/fn [] ~@body))) -(defmacro p {:style/indent 0} [& body] `($ With (->elem "p") (e/fn [] ~@body))) -(defmacro picture {:style/indent 0} [& body] `($ With (->elem "picture") (e/fn [] ~@body))) -(defmacro pre {:style/indent 0} [& body] `($ With (->elem "pre") (e/fn [] ~@body))) -(defmacro progress {:style/indent 0} [& body] `($ With (->elem "progress") (e/fn [] ~@body))) -(defmacro q {:style/indent 0} [& body] `($ With (->elem "q") (e/fn [] ~@body))) -(defmacro ruby {:style/indent 0} [& body] `($ With (->elem "ruby") (e/fn [] ~@body))) -(defmacro s {:style/indent 0} [& body] `($ With (->elem "s") (e/fn [] ~@body))) -(defmacro samp {:style/indent 0} [& body] `($ With (->elem "samp") (e/fn [] ~@body))) -(defmacro script {:style/indent 0} [& body] `($ With (->elem "script") (e/fn [] ~@body))) -(defmacro section {:style/indent 0} [& body] `($ With (->elem "section") (e/fn [] ~@body))) -(defmacro select {:style/indent 0} [& body] `($ With (->elem "select") (e/fn [] ~@body))) -(defmacro slot {:style/indent 0} [& body] `($ With (->elem "slot") (e/fn [] ~@body))) -(defmacro small {:style/indent 0} [& body] `($ With (->elem "small") (e/fn [] ~@body))) -(defmacro span {:style/indent 0} [& body] `($ With (->elem "span") (e/fn [] ~@body))) -(defmacro strong {:style/indent 0} [& body] `($ With (->elem "strong") (e/fn [] ~@body))) -(defmacro sub {:style/indent 0} [& body] `($ With (->elem "sub") (e/fn [] ~@body))) -(defmacro summary {:style/indent 0} [& body] `($ With (->elem "summary") (e/fn [] ~@body))) -(defmacro sup {:style/indent 0} [& body] `($ With (->elem "sup") (e/fn [] ~@body))) -(defmacro table {:style/indent 0} [& body] `($ With (->elem "table") (e/fn [] ~@body))) -(defmacro tbody {:style/indent 0} [& body] `($ With (->elem "tbody") (e/fn [] ~@body))) -(defmacro td {:style/indent 0} [& body] `($ With (->elem "td") (e/fn [] ~@body))) -(defmacro th {:style/indent 0} [& body] `($ With (->elem "th") (e/fn [] ~@body))) -(defmacro thead {:style/indent 0} [& body] `($ With (->elem "thead") (e/fn [] ~@body))) -(defmacro tr {:style/indent 0} [& body] `($ With (->elem "tr") (e/fn [] ~@body))) -(defmacro template {:style/indent 0} [& body] `($ With (->elem "template") (e/fn [] ~@body))) -(defmacro textarea {:style/indent 0} [& body] `($ With (->elem "textarea") (e/fn [] ~@body))) -(defmacro time {:style/indent 0} [& body] `($ With (->elem "time") (e/fn [] ~@body))) -(defmacro u {:style/indent 0} [& body] `($ With (->elem "u") (e/fn [] ~@body))) -(defmacro ul {:style/indent 0} [& body] `($ With (->elem "ul") (e/fn [] ~@body))) -(defmacro var {:style/indent 0} [& body] `($ With (->elem "var") (e/fn [] ~@body))) -(defmacro video {:style/indent 0} [& body] `($ With (->elem "video") (e/fn [] ~@body))) -(defmacro wbr {:style/indent 0} [& body] `($ With (->elem "wbr") (e/fn [] ~@body))) - -#?(:cljs - ;; TODO starts as empty incseq, later singleton changing value - (defn listen1 [nd typ f opts] - (m/observe (fn [!] - (! nil) - (let [! (comp ! f) , opts (clj->js opts)] - (.addEventListener nd typ ! opts)) #(.removeEventListener nd typ ! opts))))) - -(defmacro listen2 - ([typ] `(listen ~typ identity)) - ([typ f] `(listen node ~typ ~f)) - ([nd typ f] `(listen ~nd ~typ ~f nil)) - ([nd typ f opts] `(e/input (listen1 ~nd ~typ ~f ~opts)))) - -(defn append-only [> js opts)] - (.addEventListener nd typ ! opts)) #(.removeEventListener nd typ ! opts)))))) - -(defmacro event-log - ([typ] `(event-log ~typ identity)) - ([typ f] `(event-log node ~typ ~f)) - ([nd typ f] `(event-log ~nd ~typ ~f nil)) - ([nd typ f opts] `(e/join (event-log* ~nd ~typ ~f ~opts)))) - - -;;;;;;;;;;;;;;;;;;;;;; -;;; NEXT ITERATION ;;; -;;;;;;;;;;;;;;;;;;;;;; - -#?(:cljs (defn listen* - ([node typ] (listen* node typ identity)) - ([node typ f] (listen* node typ f {})) - ([node typ f opts] - (m/observe (fn [!] - (let [! #(! (f %)), opts (clj->js opts)] - (.addEventListener node typ ! opts) - #(.removeEventListener node typ ! opts))))))) - -#?(:cljs (defn listen*-some - ([node typ] (listen*-some node typ identity)) - ([node typ f] (listen*-some node typ f {})) - ([node typ f opts] - (m/observe (fn [!] - (let [! #(some-> (f %) !), opts (clj->js opts)] - (.addEventListener node typ ! opts) - #(.removeEventListener node typ ! opts)))) - #_(m/eduction (filter some?) (listen* node typ f opts))))) - -(defn uf->is [uf] - (m/ap (m/amb (i/empty-diff 0) - (let [!first (atom true) v (m/?> uf)] - (assoc (i/empty-diff 1) :grow (if @!first (do (swap! !first not) 1) 0), :change {0 v}))))) - -(comment - (def !! (atom nil)) - (def ps ((uf->is (m/observe (fn [!] (reset! !! !) #()))) #(prn :step) #(prn :done))) - (def v []) - (alter-var-root #'v i/patch-vec @ps) - (@!! 5) - ) - -(defn event->task [flow] - (uf->is (m/ap - (let [!busy? (atom false) - v (m/?> (m/eduction (remove (fn [_] @!busy?)) flow)) - dfv (m/dfv), done! #(dfv false)] - (m/amb - [v done! (reset! !busy? true)] - [v done! (reset! !busy? (m/? dfv))]))))) - -(defn ->task - ([flow] (->task nil flow)) - ([init flow] - (->> (m/ap (let [v (m/?< flow), dfv (m/dfv), done! #(dfv nil)] - (try (m/amb [v done!] [v (m/? dfv)]) - (catch missionary.Cancelled _ (m/amb))))) - (m/reductions {} [init nil])))) - -(comment - (def !! (atom nil)) - (def ps ((->task (m/observe (fn [!] (reset! !! !) #()))) #(prn :step) #(prn :done))) - @ps - (@!! 2) - ((second *1)) - (ps) - ) - -(defn ->box - ([] (->box nil)) - ([init] (let [o (object-array 1)] - (aset o (int 0) init) - (fn ([] (aget o (int 0))) ([v] (aset o (int 0) v)))))) - -(defn ->backpressured-task - ([flow] (->backpressured-task nil flow)) - ([init flow] - (->> (m/ap - (let [busy? (->box) - v (m/?> (m/eduction (remove (fn [_] (busy?))) flow)) - dfv (m/dfv), done! #(dfv nil)] - (m/amb - [v (busy? done!)] - [v (busy? (m/? dfv))]))) - (m/reductions {} [init nil])))) - -(defn event->latest-task [flow] - (uf->is (m/cp - (let [!busy? (atom false) - v (m/?< flow) - dfv (m/dfv), done! #(dfv false)] - (m/amb - [v done! (reset! !busy? true)] - [v done! (reset! !busy? (m/? dfv))]))))) - -(defn ->tasks [flow] - (m/ap - (let [S (i/spine)] - (m/amb S - (let [v (m/?> flow), id (random-uuid)] - (S id {} [v #(S id {} nil)]) - (m/amb)))))) From 7fba6d241757342bb89195a8a305c6f46fb83111 Mon Sep 17 00:00:00 2001 From: Geoffrey Gaillard Date: Wed, 15 May 2024 14:58:59 +0200 Subject: [PATCH 247/428] Move dom3 event logic to temporary ns --- src/hyperfiddle/dom3_events.cljc | 106 +++++++++++++++++++++++++++++ src/hyperfiddle/electric_dom3.cljc | 102 +-------------------------- 2 files changed, 107 insertions(+), 101 deletions(-) create mode 100644 src/hyperfiddle/dom3_events.cljc diff --git a/src/hyperfiddle/dom3_events.cljc b/src/hyperfiddle/dom3_events.cljc new file mode 100644 index 000000000..fc79e60e6 --- /dev/null +++ b/src/hyperfiddle/dom3_events.cljc @@ -0,0 +1,106 @@ +;; Temporary ns, might be merge to dom3 later + +(ns hyperfiddle.dom3-events) + +#?(:cljs + (defn listen> [nd typ f opts] + (m/observe (fn [!] + (! nil) + (let [! (comp ! f), opts (clj->js opts)] + (.addEventListener nd typ ! opts)) #(.removeEventListener nd typ ! opts))))) + +(defmacro listen + ([typ] `(listen ~typ identity)) + ([typ f] `(listen ~typ ~f node)) + ([nd typ f] `(listen ~nd ~typ ~f nil)) + ([nd typ f opts] `(listen> ~nd ~typ ~f ~opts))) + +;; ---------- + +#?(:cljs + ;; TODO starts as empty incseq, later singleton changing value + (defn listen1 [nd typ f opts] + (m/observe (fn [!] + (! nil) + (let [! (comp ! f) , opts (clj->js opts)] + (.addEventListener nd typ ! opts)) #(.removeEventListener nd typ ! opts))))) + +(defmacro listen2 + ([typ] `(listen ~typ identity)) + ([typ f] `(listen node ~typ ~f)) + ([nd typ f] `(listen ~nd ~typ ~f nil)) + ([nd typ f opts] `(e/input (listen1 ~nd ~typ ~f ~opts)))) + +(defn append-only [> js opts)] + (.addEventListener nd typ ! opts)) #(.removeEventListener nd typ ! opts)))))) + +(defmacro event-log + ([typ] `(event-log ~typ identity)) + ([typ f] `(event-log node ~typ ~f)) + ([nd typ f] `(event-log ~nd ~typ ~f nil)) + ([nd typ f opts] `(e/join (event-log* ~nd ~typ ~f ~opts)))) + + +;;;;;;;;;;;;;;;;;;;;;; +;;; NEXT ITERATION ;;; +;;;;;;;;;;;;;;;;;;;;;; + +#?(:cljs (defn listen* + ([node typ] (listen* node typ identity)) + ([node typ f] (listen* node typ f {})) + ([node typ f opts] + (m/observe (fn [!] + (let [! #(! (f %)), opts (clj->js opts)] + (.addEventListener node typ ! opts) + #(.removeEventListener node typ ! opts))))))) + +#?(:cljs (defn listen*-some + ([node typ] (listen*-some node typ identity)) + ([node typ f] (listen*-some node typ f {})) + ([node typ f opts] + (m/observe (fn [!] + (let [! #(some-> (f %) !), opts (clj->js opts)] + (.addEventListener node typ ! opts) + #(.removeEventListener node typ ! opts)))) + #_(m/eduction (filter some?) (listen* node typ f opts))))) + +(defn uf->is [uf] + (m/ap (m/amb (i/empty-diff 0) + (let [!first (atom true) v (m/?> uf)] + (assoc (i/empty-diff 1) :grow (if @!first (do (swap! !first not) 1) 0), :change {0 v}))))) + +(comment + (def !! (atom nil)) + (def ps ((uf->is (m/observe (fn [!] (reset! !! !) #()))) #(prn :step) #(prn :done))) + (def v []) + (alter-var-root #'v i/patch-vec @ps) + (@!! 5) + ) + +(defn event->task [flow] + (uf->is (m/ap + (let [!busy? (atom false) + v (m/?> (m/eduction (remove (fn [_] @!busy?)) flow)) + dfv (m/dfv), done! #(dfv false)] + (m/amb + [v done! (reset! !busy? true)] + [v done! (reset! !busy? (m/? dfv))]))))) + +(defn event->tasks [flow] + (uf->is + (m/ap + (let [S (i/spine)] + (m/amb S + (let [v (m/?> flow), id (random-uuid)] + (S id {} [v #(S id {} nil)]) + (m/amb))))))) diff --git a/src/hyperfiddle/electric_dom3.cljc b/src/hyperfiddle/electric_dom3.cljc index 2692d0d50..39afd58cb 100644 --- a/src/hyperfiddle/electric_dom3.cljc +++ b/src/hyperfiddle/electric_dom3.cljc @@ -1,6 +1,6 @@ ;; * DONE Replace dom3 by dom3_efn ;; G: diffed both files, LGTM -;; * TODO move event handling to separate ns +;; * DONE move event handling to separate ns ;; So we can think clearly ;; We can always merge back later ;; * TODO Implement dom/text @@ -194,19 +194,6 @@ ($ Property node k# v#)) nil))) -#?(:cljs - (defn listen> [nd typ f opts] - (m/observe (fn [!] - (! nil) - (let [! (comp ! f), opts (clj->js opts)] - (.addEventListener nd typ ! opts)) #(.removeEventListener nd typ ! opts))))) - -(defmacro listen - ([typ] `(listen ~typ identity)) - ([typ f] `(listen ~typ ~f node)) - ([nd typ f] `(listen ~nd ~typ ~f nil)) - ([nd typ f opts] `(listen> ~nd ~typ ~f ~opts))) - #?(:cljs (defn ->elem [t] (goog.dom/createElement t))) (defmacro a {:style/indent 0} [& body] `($ With (->elem "a") (e/fn [] ~@body))) @@ -309,90 +296,3 @@ (defmacro video {:style/indent 0} [& body] `($ With (->elem "video") (e/fn [] ~@body))) (defmacro wbr {:style/indent 0} [& body] `($ With (->elem "wbr") (e/fn [] ~@body))) -#?(:cljs - ;; TODO starts as empty incseq, later singleton changing value - (defn listen1 [nd typ f opts] - (m/observe (fn [!] - (! nil) - (let [! (comp ! f) , opts (clj->js opts)] - (.addEventListener nd typ ! opts)) #(.removeEventListener nd typ ! opts))))) - -(defmacro listen2 - ([typ] `(listen ~typ identity)) - ([typ f] `(listen node ~typ ~f)) - ([nd typ f] `(listen ~nd ~typ ~f nil)) - ([nd typ f opts] `(e/input (listen1 ~nd ~typ ~f ~opts)))) - -(defn append-only [> js opts)] - (.addEventListener nd typ ! opts)) #(.removeEventListener nd typ ! opts)))))) - -(defmacro event-log - ([typ] `(event-log ~typ identity)) - ([typ f] `(event-log node ~typ ~f)) - ([nd typ f] `(event-log ~nd ~typ ~f nil)) - ([nd typ f opts] `(e/join (event-log* ~nd ~typ ~f ~opts)))) - - -;;;;;;;;;;;;;;;;;;;;;; -;;; NEXT ITERATION ;;; -;;;;;;;;;;;;;;;;;;;;;; - -#?(:cljs (defn listen* - ([node typ] (listen* node typ identity)) - ([node typ f] (listen* node typ f {})) - ([node typ f opts] - (m/observe (fn [!] - (let [! #(! (f %)), opts (clj->js opts)] - (.addEventListener node typ ! opts) - #(.removeEventListener node typ ! opts))))))) - -#?(:cljs (defn listen*-some - ([node typ] (listen*-some node typ identity)) - ([node typ f] (listen*-some node typ f {})) - ([node typ f opts] - (m/observe (fn [!] - (let [! #(some-> (f %) !), opts (clj->js opts)] - (.addEventListener node typ ! opts) - #(.removeEventListener node typ ! opts)))) - #_(m/eduction (filter some?) (listen* node typ f opts))))) - -(defn uf->is [uf] - (m/ap (m/amb (i/empty-diff 0) - (let [!first (atom true) v (m/?> uf)] - (assoc (i/empty-diff 1) :grow (if @!first (do (swap! !first not) 1) 0), :change {0 v}))))) - -(comment - (def !! (atom nil)) - (def ps ((uf->is (m/observe (fn [!] (reset! !! !) #()))) #(prn :step) #(prn :done))) - (def v []) - (alter-var-root #'v i/patch-vec @ps) - (@!! 5) - ) - -(defn event->task [flow] - (uf->is (m/ap - (let [!busy? (atom false) - v (m/?> (m/eduction (remove (fn [_] @!busy?)) flow)) - dfv (m/dfv), done! #(dfv false)] - (m/amb - [v done! (reset! !busy? true)] - [v done! (reset! !busy? (m/? dfv))]))))) - -(defn event->tasks [flow] - (uf->is - (m/ap - (let [S (i/spine)] - (m/amb S - (let [v (m/?> flow), id (random-uuid)] - (S id {} [v #(S id {} nil)]) - (m/amb))))))) From e75f6d72182bd4031b4da7afa17492c6b7527f68 Mon Sep 17 00:00:00 2001 From: Geoffrey Gaillard Date: Wed, 15 May 2024 15:49:37 +0200 Subject: [PATCH 248/428] dom3 - dom/text impl --- src/hyperfiddle/dom31.cljc | 70 ++++++++++++++++++++++++++++++ src/hyperfiddle/electric_dom3.cljc | 14 ------ 2 files changed, 70 insertions(+), 14 deletions(-) create mode 100644 src/hyperfiddle/dom31.cljc diff --git a/src/hyperfiddle/dom31.cljc b/src/hyperfiddle/dom31.cljc new file mode 100644 index 000000000..03472bc71 --- /dev/null +++ b/src/hyperfiddle/dom31.cljc @@ -0,0 +1,70 @@ +;; * DONE Replace dom3 by dom3_efn +;; G: diffed both files, LGTM +;; * DONE move event handling to separate ns +;; So we can think clearly +;; We can always merge back later +;; * DONE Implement dom/text +;; * TODO Implement dom/comment +;; * TODO Implement dom/div +;; * TODO Implement dom/div nesting +;; * TODO Implement setting attributes +;; * TODO Implement setting class +;; * TODO Implement setting inline style +;; * TODO Implement event handling + +(ns hyperfiddle.dom31 + (:require + [hyperfiddle.electric-de :as e :refer [$]] + ;; [contrib.assert :as ca] + [missionary.core :as m] + ;; [hyperfiddle.electric.impl.lang-de2 :as lang] + #?(:cljs [goog.dom]))) + +;; e/tag ;; electric clojure only. resolves to an invariant+singleton unique identifier. +;; (e/mount-point) ;; clojure function returning a fresh container associating tags to stateful items which can be observed as an incseq with e/join. The ordering of items reflects the ordering of tags in the program order. + +;; (e/insert! mount-point tag init) ;; add a new item associated with `tag` in `mount-point`, with initial state `init`. +;; (e/update! mount-point tag f & args) ;; change state of item associated with `tag` in `mount-point` by applying function `f` to current state, with optional following arguments `args`. +;; (e/remove! mount-point tag) ;; remove item associated with `tag` in `mount-point`. + +(def node) + +(defn get-mount-point [node] (aget node "mount-point")) + +#?(:cljs + (defn attach! [parent-node tag e] + (assert (instance? js/Node parent-node)) + (m/observe (fn [!] + (! nil) + (let [mount-point (get-mount-point node)] ; TODO could this be inlined? + (e/insert! mount-point tag e) + #(e/remove! mount-point tag e)))))) + +(e/defn Text [str] ; ^::lang/print-clj-source + (e/client + (let [e (goog.dom/createTextNode "")] + (e/input (attach! node (e/tag) e)) + (goog.dom/setTextContent e str)))) + +(defmacro text [& strs] `(do ~@(for [s strs] `($ Text ~s)))) + +(comment + (div + (text "test" + (text (str "hello" "world")))) + ) + + +;; #?(:cljs (defn node? [v] (instance? js/Node v))) +;; +;; #?(:cljs (defn appending> [elem parent] +;; (ca/is parent node? "DOM node parent is not an HTML Node. Maybe dom/node is unbound?" {:parent parent}) +;; (m/observe (fn [!] (.appendChild parent elem) (! elem) #(.remove elem))))) +#_ +(e/defn With [elem Body] + (binding [node (e/input (appending> elem node))] + node ; P: electric is lazy so if no one uses the node it might not mount. + ; This consumes `node` as per do semantics. G: Is this a hack? I don't + ; like (do) being used to force effects. We will revisit after + ; e/mount-point. + ($ Body))) diff --git a/src/hyperfiddle/electric_dom3.cljc b/src/hyperfiddle/electric_dom3.cljc index 39afd58cb..e865db9ee 100644 --- a/src/hyperfiddle/electric_dom3.cljc +++ b/src/hyperfiddle/electric_dom3.cljc @@ -1,17 +1,3 @@ -;; * DONE Replace dom3 by dom3_efn -;; G: diffed both files, LGTM -;; * DONE move event handling to separate ns -;; So we can think clearly -;; We can always merge back later -;; * TODO Implement dom/text -;; * TODO Implement dom/comment -;; * TODO Implement dom/div -;; * TODO Implement dom/div nesting -;; * TODO Implement setting attributes -;; * TODO Implement setting class -;; * TODO Implement setting inline style -;; * TODO Implement event handling - (ns hyperfiddle.electric-dom3 (:refer-clojure :exclude [time class?]) (:require From b93f71adb0a9a64318d30acd9ce34388990a2e1d Mon Sep 17 00:00:00 2001 From: Geoffrey Gaillard Date: Wed, 15 May 2024 16:40:36 +0200 Subject: [PATCH 249/428] dom 3 - add comment --- src/hyperfiddle/dom31.cljc | 50 ++++++++++++++++++++++++++++++-------- 1 file changed, 40 insertions(+), 10 deletions(-) diff --git a/src/hyperfiddle/dom31.cljc b/src/hyperfiddle/dom31.cljc index 03472bc71..62ebe4185 100644 --- a/src/hyperfiddle/dom31.cljc +++ b/src/hyperfiddle/dom31.cljc @@ -4,7 +4,7 @@ ;; So we can think clearly ;; We can always merge back later ;; * DONE Implement dom/text -;; * TODO Implement dom/comment +;; * DONE Implement dom/comment ;; * TODO Implement dom/div ;; * TODO Implement dom/div nesting ;; * TODO Implement setting attributes @@ -13,12 +13,18 @@ ;; * TODO Implement event handling (ns hyperfiddle.dom31 + (:refer-clojure :exclude [comment]) (:require [hyperfiddle.electric-de :as e :refer [$]] ;; [contrib.assert :as ca] [missionary.core :as m] ;; [hyperfiddle.electric.impl.lang-de2 :as lang] - #?(:cljs [goog.dom]))) + ;; #?(:cljs [goog.dom]) + )) + +;;;;;;;;;;;;;;; +;; Reference ;; +;;;;;;;;;;;;;;; ;; e/tag ;; electric clojure only. resolves to an invariant+singleton unique identifier. ;; (e/mount-point) ;; clojure function returning a fresh container associating tags to stateful items which can be observed as an incseq with e/join. The ordering of items reflects the ordering of tags in the program order. @@ -27,6 +33,11 @@ ;; (e/update! mount-point tag f & args) ;; change state of item associated with `tag` in `mount-point` by applying function `f` to current state, with optional following arguments `args`. ;; (e/remove! mount-point tag) ;; remove item associated with `tag` in `mount-point`. + +;;;;;;;;;;;;; +;; General ;; +;;;;;;;;;;;;; + (def node) (defn get-mount-point [node] (aget node "mount-point")) @@ -40,23 +51,38 @@ (e/insert! mount-point tag e) #(e/remove! mount-point tag e)))))) +;;;;;;;;;; +;; Text ;; +;;;;;;;;;; + (e/defn Text [str] ; ^::lang/print-clj-source (e/client - (let [e (goog.dom/createTextNode "")] + (let [e (.createTextNode js/document "")] (e/input (attach! node (e/tag) e)) - (goog.dom/setTextContent e str)))) + (set! (.-textContent e) str)))) (defmacro text [& strs] `(do ~@(for [s strs] `($ Text ~s)))) -(comment - (div - (text "test" - (text (str "hello" "world")))) - ) +;;;;;;;;;;;;; +;; Comment ;; +;;;;;;;;;;;;; + +(e/defn Comment [str] ; ^::lang/print-clj-source + (e/client + (let [e (.createComment js/document "")] + (e/input (attach! node (e/tag) e)) + (set! (.-textContent e) str)))) + +(defmacro comment [& strs] `(do ~@(for [s strs] `($ Comment ~s)))) + + + +(clojure.core/comment "comment var is already taken") + ;; #?(:cljs (defn node? [v] (instance? js/Node v))) -;; +;; ;; #?(:cljs (defn appending> [elem parent] ;; (ca/is parent node? "DOM node parent is not an HTML Node. Maybe dom/node is unbound?" {:parent parent}) ;; (m/observe (fn [!] (.appendChild parent elem) (! elem) #(.remove elem))))) @@ -68,3 +94,7 @@ ; like (do) being used to force effects. We will revisit after ; e/mount-point. ($ Body))) + + +;; * Questions for Leo +;; ** … From bed2401115deb01a303e66162abf13fa48ff9b62 Mon Sep 17 00:00:00 2001 From: Geoffrey Gaillard Date: Wed, 15 May 2024 17:08:13 +0200 Subject: [PATCH 250/428] dom 3 - WIP on element --- src/hyperfiddle/dom31.cljc | 60 +++++++++++++++++++++++++++++++++++++- 1 file changed, 59 insertions(+), 1 deletion(-) diff --git a/src/hyperfiddle/dom31.cljc b/src/hyperfiddle/dom31.cljc index 62ebe4185..95d7be6b6 100644 --- a/src/hyperfiddle/dom31.cljc +++ b/src/hyperfiddle/dom31.cljc @@ -76,8 +76,66 @@ (defmacro comment [& strs] `(do ~@(for [s strs] `($ Comment ~s)))) +;;;;;;;;;;;;; +;; Element ;; +;;;;;;;;;;;;; - +;; TODO this is a sketch, finish impl +(defn mount-items [element {:keys [grow shrink degree permutation change]}] + (let [children (.-childNodes element) + move (i/inverse permutation) + size-before (- degree grow) + size-after (- degree shrink)] + (loop [i size-before + c change] + (if (== i degree) + (reduce-kv + (fn [_ i e] + (.replaceChild element e + (.item children (move i i)))) + nil c) + (let [j (move i i)] + (.appendChild element (c j)) + (recur (inc i) (dissoc c j))))) + (loop [p permutation + i degree] + (if (== i size-after) + (loop [p p] + (when-not (= p {}) + (let [[i j] (first p)] + (.insertBefore element (.item children j) + (.item children (if (< j i) (inc i) i))) + (recur (i/compose p (i/rotation i j)))))) + (let [i (dec i) + j (p i i)] + (.removeChild element (.item children j)) + (recur (i/compose p (i/rotation i j)) i)))) + element)) + +(e/defn Element [tag Body] + (let [e (.createElement js/document (name tag)) + mp (e/mount-point) + tag (e/tag)] + (e/input (attach! node tag e)) ; mount and unmount element in parent + (e/join (e/mount-items e mp)) ; mount children in this node via mount point + (aset e "mount-point" mp) ; expose mount point to children ; TODO namespace and hide prop using js/Symbol + (binding [node e] ; run continuation + (Body.)))) + +(defmacro element [tag & body] + `($ Element tag (e/fn [] (e/amb ~@body)))) + +;; (defmacro element [tag & body] +;; `(let [e# (.createElement js/document ~(name tag)) +;; mp# (e/mount-point) +;; tag# (e/tag) +;; parent# (aget node "mount-point")] +;; (e/insert! parent# tag# e#) ;; mount element in parent +;; (e/on-unmount #(e/remove! parent# tag# e#)) ;; unmount element from parent +;; (e/join (mount-items node mp#)) ;; mount children via mount point +;; (aset e# "mount-point" mp#) ;; expose mount point to children +;; (binding [node e#] ;; run continuation +;; (e/amb ~@body)))) (clojure.core/comment "comment var is already taken") From 07aef05052e3cd6795809f0ed5dbe8d6b9fc2e7c Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 16 May 2024 10:34:23 +0200 Subject: [PATCH 251/428] hidden mount point prop --- src/hyperfiddle/dom31.cljc | 25 +++++++++++++++---------- 1 file changed, 15 insertions(+), 10 deletions(-) diff --git a/src/hyperfiddle/dom31.cljc b/src/hyperfiddle/dom31.cljc index 95d7be6b6..ac0fa6745 100644 --- a/src/hyperfiddle/dom31.cljc +++ b/src/hyperfiddle/dom31.cljc @@ -40,14 +40,18 @@ (def node) -(defn get-mount-point [node] (aget node "mount-point")) +#?(:cljs + (let [key (js/Symbol.for "hyperfiddle.mount-point")] + (defn mount-point + ([node] (aget node key)) + ([node v] (aset node key v))))) #?(:cljs (defn attach! [parent-node tag e] (assert (instance? js/Node parent-node)) (m/observe (fn [!] (! nil) - (let [mount-point (get-mount-point node)] ; TODO could this be inlined? + (let [mount-point (mount-point node)] ; TODO could this be inlined? (e/insert! mount-point tag e) #(e/remove! mount-point tag e)))))) @@ -113,14 +117,15 @@ element)) (e/defn Element [tag Body] - (let [e (.createElement js/document (name tag)) - mp (e/mount-point) - tag (e/tag)] - (e/input (attach! node tag e)) ; mount and unmount element in parent - (e/join (e/mount-items e mp)) ; mount children in this node via mount point - (aset e "mount-point" mp) ; expose mount point to children ; TODO namespace and hide prop using js/Symbol - (binding [node e] ; run continuation - (Body.)))) + (e/client + (let [e (.createElement js/document (name tag)) + mp (e/mount-point) + tag (e/tag)] + (e/input (attach! node tag e)) ; mount and unmount element in parent + (e/join (e/mount-items e mp)) ; mount children in this node via mount point + (mount-point e mp) ; expose mount point to children + (binding [node e] ; run continuation + (Body.))))) (defmacro element [tag & body] `($ Element tag (e/fn [] (e/amb ~@body)))) From a32b284e1b372bb77f9a5e0df077da09233efbf0 Mon Sep 17 00:00:00 2001 From: Geoffrey Gaillard Date: Thu, 16 May 2024 11:41:20 +0200 Subject: [PATCH 252/428] dom 3 - element and mount-items dissection --- src/hyperfiddle/dom31.cljc | 105 ++++++++++++++++++++----------------- 1 file changed, 58 insertions(+), 47 deletions(-) diff --git a/src/hyperfiddle/dom31.cljc b/src/hyperfiddle/dom31.cljc index ac0fa6745..ae2a7ed1d 100644 --- a/src/hyperfiddle/dom31.cljc +++ b/src/hyperfiddle/dom31.cljc @@ -84,36 +84,59 @@ ;; Element ;; ;;;;;;;;;;;;; -;; TODO this is a sketch, finish impl -(defn mount-items [element {:keys [grow shrink degree permutation change]}] - (let [children (.-childNodes element) - move (i/inverse permutation) - size-before (- degree grow) - size-after (- degree shrink)] - (loop [i size-before - c change] - (if (== i degree) - (reduce-kv - (fn [_ i e] - (.replaceChild element e - (.item children (move i i)))) - nil c) - (let [j (move i i)] - (.appendChild element (c j)) - (recur (inc i) (dissoc c j))))) - (loop [p permutation - i degree] - (if (== i size-after) - (loop [p p] - (when-not (= p {}) - (let [[i j] (first p)] - (.insertBefore element (.item children j) - (.item children (if (< j i) (inc i) i))) - (recur (i/compose p (i/rotation i j)))))) - (let [i (dec i) - j (p i i)] - (.removeChild element (.item children j)) - (recur (i/compose p (i/rotation i j)) i)))) +;; TODO Understand this with 100% precision. +;; G: here is my understanding of it (as comments), to be verified. +;; Leo says its done +(defn mount-items + [element ; a dom element to mount children in + + ; an incseq's diff + {:keys [grow ; number of added items + shrink ; number of removed items + degree ; max size of collection (after grow, before shrink) + permutation ; map of indexes movements e.g. "a replaced by b" + change ; map of index -> value + ]}] + (let [children (.-childNodes element) ; current children of the element to mount in + move (i/inverse permutation) ; permutation is "a replaced by b" move is "b replaces a" + size-before (- degree grow) ; current expected child list size + size-after (- degree shrink) ; expected child list size after patch + ] + ;; Step 1 - Additions and replacements by new elements + (loop [i size-before ; start with expected current size and scan left to right, one by one, + ; until diff's degree (before removals) + change change] + (if (not (== i degree)) ; If there are items to add + ;; Addition + (let [j (get move i i)] ; get the index where this item is or went + (.appendChild element (get change j)) ; add children to the list + (recur (inc i) (dissoc change j))) ; continue with next change. + ;; If there are changes but no items to add, then its just in-place changes + (run! (fn [[i element']] ; for each change + (.replaceChild element element' ; replace old child at index i by element' (new child) + (.item children (get move i i)) ; get old child index + )) + change))) + ;; Step 2 - Removals and reorders of existing elements + (loop [permutation permutation + i degree] + (if (not (== i size-after)) ; if there are extra items + ;; Removals + (let [i (dec i) ; move to the penultimate item index + j (get permutation i i)] ; get the place where the item went (it might have been moved left) + (.removeChild element (.item children j)) ; remove child there (causing a shift to the left) + (recur (i/compose permutation (i/rotation i j)) i)) ; continue with next extra item, accounting for the left shift + ;; Nothing to remove, but children to reorder + (loop [permutation permutation] + (when-not (= permutation {}) ; if there are still some swaps to apply + (let [[i j] (first permutation)] ; we will apply the first swap in the list + (.insertBefore element (.item children j) ; insert at target position + (.item children ; the child from origin position + (if (< j i) (inc i) i))) ; due to insertBefore, if j is left of i, insert to the right of the target position. + (recur (i/compose permutation (i/rotation i j))) ; continue with the rotation applied, + ; which cancels out remaining swaps + ; appropriately. + ))))) element)) (e/defn Element [tag Body] @@ -121,26 +144,14 @@ (let [e (.createElement js/document (name tag)) mp (e/mount-point) tag (e/tag)] - (e/input (attach! node tag e)) ; mount and unmount element in parent - (e/join (e/mount-items e mp)) ; mount children in this node via mount point - (mount-point e mp) ; expose mount point to children - (binding [node e] ; run continuation + (e/input (attach! node tag e)) ; mount and unmount element in parent + (e/join (mount-items e mp)) ; interprets diffs to mount and maintain children in correct order + (mount-point e mp) ; expose mount point to children + (binding [node e] ; run continuation (Body.))))) (defmacro element [tag & body] - `($ Element tag (e/fn [] (e/amb ~@body)))) - -;; (defmacro element [tag & body] -;; `(let [e# (.createElement js/document ~(name tag)) -;; mp# (e/mount-point) -;; tag# (e/tag) -;; parent# (aget node "mount-point")] -;; (e/insert! parent# tag# e#) ;; mount element in parent -;; (e/on-unmount #(e/remove! parent# tag# e#)) ;; unmount element from parent -;; (e/join (mount-items node mp#)) ;; mount children via mount point -;; (aset e# "mount-point" mp#) ;; expose mount point to children -;; (binding [node e#] ;; run continuation -;; (e/amb ~@body)))) + `($ Element ~tag (e/fn [] (e/amb ~@body)))) (clojure.core/comment "comment var is already taken") From 75c4ab136d16ae014efe15f25033363be76d46ba Mon Sep 17 00:00:00 2001 From: Geoffrey Gaillard Date: Thu, 16 May 2024 12:13:39 +0200 Subject: [PATCH 253/428] dom 3 - mount-items comments --- src/hyperfiddle/dom31.cljc | 75 +++++++++++++++++++------------------- 1 file changed, 37 insertions(+), 38 deletions(-) diff --git a/src/hyperfiddle/dom31.cljc b/src/hyperfiddle/dom31.cljc index ae2a7ed1d..6aabc3f26 100644 --- a/src/hyperfiddle/dom31.cljc +++ b/src/hyperfiddle/dom31.cljc @@ -88,55 +88,54 @@ ;; G: here is my understanding of it (as comments), to be verified. ;; Leo says its done (defn mount-items - [element ; a dom element to mount children in - - ; an incseq's diff - {:keys [grow ; number of added items - shrink ; number of removed items - degree ; max size of collection (after grow, before shrink) - permutation ; map of indexes movements e.g. "a replaced by b" - change ; map of index -> value + [element ; A dom element to mount children in + + ; An incseq's diff + {:keys [grow ; Number of added items + shrink ; Number of removed items + degree ; Max size of collection (after grow, before shrink) + permutation ; Map of indexes movements e.g. "a replaced by b" + change ; Map of index -> value ]}] - (let [children (.-childNodes element) ; current children of the element to mount in - move (i/inverse permutation) ; permutation is "a replaced by b" move is "b replaces a" - size-before (- degree grow) ; current expected child list size - size-after (- degree shrink) ; expected child list size after patch + (let [children (.-childNodes element) ; Current children of the element to mount in + move (i/inverse permutation) ; Permutation is "a replaced by b" move is "b replaces a" + size-before (- degree grow) ; Current expected child list size + size-after (- degree shrink) ; Expected child list size after patch ] - ;; Step 1 - Additions and replacements by new elements - (loop [i size-before ; start with expected current size and scan left to right, one by one, - ; until diff's degree (before removals) + ;; Step 1 - Additions and replacements by new elements. + ;; Starts with the size before additions and iterates until degree, applying + ;; changes (additions or replacements). + (loop [i size-before change change] - (if (not (== i degree)) ; If there are items to add + (if (not (== i degree)) ; Checks if there are items to add or replace. ;; Addition - (let [j (get move i i)] ; get the index where this item is or went - (.appendChild element (get change j)) ; add children to the list - (recur (inc i) (dissoc change j))) ; continue with next change. - ;; If there are changes but no items to add, then its just in-place changes - (run! (fn [[i element']] ; for each change - (.replaceChild element element' ; replace old child at index i by element' (new child) - (.item children (get move i i)) ; get old child index + (let [j (get move i i)] ; Index of new child. + (.appendChild element (get change j)) ; Appends the new child to the element. + (recur (inc i) (dissoc change j))) ; Continues with the next item, removing the processed item from the change map. + ;; If there are changes but no items to add, then it's just in-place changes. + (run! (fn [[i element']] ; Iterates over the remaining changes and applies replacements. + (.replaceChild element element' ; Replaces the old child at the specified index with the new child. + (.item children (get move i i)) ; Get old child index )) change))) ;; Step 2 - Removals and reorders of existing elements (loop [permutation permutation i degree] - (if (not (== i size-after)) ; if there are extra items + (if (not (== i size-after)) ; If there are extra items ;; Removals - (let [i (dec i) ; move to the penultimate item index - j (get permutation i i)] ; get the place where the item went (it might have been moved left) - (.removeChild element (.item children j)) ; remove child there (causing a shift to the left) - (recur (i/compose permutation (i/rotation i j)) i)) ; continue with next extra item, accounting for the left shift - ;; Nothing to remove, but children to reorder + (let [i (dec i) ; Move to the penultimate item index - next last index after removal + j (get permutation i i)] ; Determines the index of the item to be removed. + (.removeChild element (.item children j)) ; Remove child - causing a left shift + (recur (i/compose permutation (i/rotation i j)) i)) ; Continues with the next item, updating the permutation to reflect the left shift. + ;; Reorders (loop [permutation permutation] - (when-not (= permutation {}) ; if there are still some swaps to apply - (let [[i j] (first permutation)] ; we will apply the first swap in the list - (.insertBefore element (.item children j) ; insert at target position - (.item children ; the child from origin position - (if (< j i) (inc i) i))) ; due to insertBefore, if j is left of i, insert to the right of the target position. - (recur (i/compose permutation (i/rotation i j))) ; continue with the rotation applied, - ; which cancels out remaining swaps - ; appropriately. - ))))) + (when-not (= permutation {}) ; Checks if there are swaps to apply. + (let [[i j] (first permutation)] ; Applies the first swap in the permutation. + (.insertBefore element (.item children j) ; Inserts the item at position j before the item at position i, adjusting if necessary. + (.item children (if (< j i) (inc i) i))) ; Due to insertBefore, if j is left of i, insert to the right of the target position. + ;; Remove applied permutation from permutation map and continue. + ;; Image: a shrinking yarn loop + (recur (i/compose permutation (i/rotation i j)))))))) element)) (e/defn Element [tag Body] From 620d08beb7a641e72a16d1c1e354a2f31052ce0c Mon Sep 17 00:00:00 2001 From: Geoffrey Gaillard Date: Thu, 16 May 2024 12:23:48 +0200 Subject: [PATCH 254/428] dom 3 - div and div nesting --- src/hyperfiddle/dom31.cljc | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/hyperfiddle/dom31.cljc b/src/hyperfiddle/dom31.cljc index 6aabc3f26..90254e0e0 100644 --- a/src/hyperfiddle/dom31.cljc +++ b/src/hyperfiddle/dom31.cljc @@ -5,8 +5,8 @@ ;; We can always merge back later ;; * DONE Implement dom/text ;; * DONE Implement dom/comment -;; * TODO Implement dom/div -;; * TODO Implement dom/div nesting +;; * DONE Implement dom/div +;; * DONE Implement dom/div nesting ;; * TODO Implement setting attributes ;; * TODO Implement setting class ;; * TODO Implement setting inline style @@ -149,8 +149,10 @@ (binding [node e] ; run continuation (Body.))))) -(defmacro element [tag & body] - `($ Element ~tag (e/fn [] (e/amb ~@body)))) +(defn element* [tag forms] `($ Element ~tag (e/fn [] (e/amb ~@forms)))) +(defmacro element [tag & body] (element* tag body)) + +(defmacro div [& body] (element* "div" body)) (clojure.core/comment "comment var is already taken") From a4b5250a87bfea9a4d09e7876a1aea024d81a8a7 Mon Sep 17 00:00:00 2001 From: Geoffrey Gaillard Date: Thu, 16 May 2024 16:15:50 +0200 Subject: [PATCH 255/428] dom 3 - review and comments --- src/hyperfiddle/dom31.cljc | 55 +++++++++++++++++++++++++------------- 1 file changed, 37 insertions(+), 18 deletions(-) diff --git a/src/hyperfiddle/dom31.cljc b/src/hyperfiddle/dom31.cljc index 90254e0e0..e6405039c 100644 --- a/src/hyperfiddle/dom31.cljc +++ b/src/hyperfiddle/dom31.cljc @@ -41,7 +41,7 @@ (def node) #?(:cljs - (let [key (js/Symbol.for "hyperfiddle.mount-point")] + (let [key (js/Symbol.for "hyperfiddle.dom3.mount-point")] (defn mount-point ([node] (aget node key)) ([node v] (aset node key v))))) @@ -59,11 +59,14 @@ ;; Text ;; ;;;;;;;;;; +;; NOTE L:we could implement variadic Text with a conditional on first rest and self recursion (e/defn Text [str] ; ^::lang/print-clj-source (e/client (let [e (.createTextNode js/document "")] (e/input (attach! node (e/tag) e)) - (set! (.-textContent e) str)))) + (set! (.-textContent e) str) + ;; TODO return string? or e? or nil? + ))) (defmacro text [& strs] `(do ~@(for [s strs] `($ Text ~s)))) @@ -79,7 +82,6 @@ (defmacro comment [& strs] `(do ~@(for [s strs] `($ Comment ~s)))) - ;;;;;;;;;;;;; ;; Element ;; ;;;;;;;;;;;;; @@ -87,35 +89,41 @@ ;; TODO Understand this with 100% precision. ;; G: here is my understanding of it (as comments), to be verified. ;; Leo says its done -(defn mount-items +(defn mount-items ;; must not be called on the same element more than once. [element ; A dom element to mount children in ; An incseq's diff {:keys [grow ; Number of added items shrink ; Number of removed items degree ; Max size of collection (after grow, before shrink) - permutation ; Map of indexes movements e.g. "a replaced by b" - change ; Map of index -> value + permutation ; Map of indexes movements e.g. "a replaced by b" "target -> source" + change ; Map of index -> value (dom elements in this case) ]}] (let [children (.-childNodes element) ; Current children of the element to mount in - move (i/inverse permutation) ; Permutation is "a replaced by b" move is "b replaces a" - size-before (- degree grow) ; Current expected child list size + move (i/inverse permutation) ; map of source -> target aka "b replaces a" + size-before (- degree grow) ; Current expected child list size. Should be exactly (alength children) size-after (- degree shrink) ; Expected child list size after patch ] ;; Step 1 - Additions and replacements by new elements. - ;; Starts with the size before additions and iterates until degree, applying + + ;; NOTE that Element's impl mounts nodes in a static order, so no elements + ;; get replaced. But one could replace elements by rebinding dom/node to an + ;; e/watch or conditional value instead. + + ;; Starts with the size before additions and iterates up to degree, applying ;; changes (additions or replacements). (loop [i size-before change change] (if (not (== i degree)) ; Checks if there are items to add or replace. ;; Addition - (let [j (get move i i)] ; Index of new child. + (let [j (get move i i)] ; Index of new child. If the added element has not moved, just use the current index (add it to current slot) (.appendChild element (get change j)) ; Appends the new child to the element. (recur (inc i) (dissoc change j))) ; Continues with the next item, removing the processed item from the change map. ;; If there are changes but no items to add, then it's just in-place changes. - (run! (fn [[i element']] ; Iterates over the remaining changes and applies replacements. - (.replaceChild element element' ; Replaces the old child at the specified index with the new child. - (.item children (get move i i)) ; Get old child index + (run! (fn [[i new-element]] ; Iterates over the remaining changes and applies replacements. + (.replaceChild element new-element ; Replaces the old child at the specified index with the new child. + (.item children ; Get old child object + (get move i i)) ; Get old child index )) change))) ;; Step 2 - Removals and reorders of existing elements @@ -131,7 +139,9 @@ (loop [permutation permutation] (when-not (= permutation {}) ; Checks if there are swaps to apply. (let [[i j] (first permutation)] ; Applies the first swap in the permutation. - (.insertBefore element (.item children j) ; Inserts the item at position j before the item at position i, adjusting if necessary. + ;; If `i` points to the last element, (inc i) would be OOB. but .item would return nil, so insertBefore will interpret nil as insert in last position. + ;; NOTE could we use replaceChild or replaceWith instead? not clear what are pros/cons. + (.insertBefore element (.item children j) ; Inserts the item at position j before the item at position i, adjusting if necessary. (.item children (if (< j i) (inc i) i))) ; Due to insertBefore, if j is left of i, insert to the right of the target position. ;; Remove applied permutation from permutation map and continue. ;; Image: a shrinking yarn loop @@ -144,14 +154,23 @@ mp (e/mount-point) tag (e/tag)] (e/input (attach! node tag e)) ; mount and unmount element in parent - (e/join (mount-items e mp)) ; interprets diffs to mount and maintain children in correct order + (e/input (m/reductions mount-items e mp)) ; interprets diffs to mount and maintain children in correct order (mount-point e mp) ; expose mount point to children - (binding [node e] ; run continuation - (Body.))))) + (binding [node e] ; run continuation, in context of current node. + ($ Body))))) -(defn element* [tag forms] `($ Element ~tag (e/fn [] (e/amb ~@forms)))) +(defn element* [tag forms] `($ Element ~tag (e/fn [] (e/amb ~@forms) ; TODO should we use e/amb or do? return all children, concatenated or just the last as in v2? + ))) (defmacro element [tag & body] (element* tag body)) +(clojure.core/comment + (element :div a b) + ) + +;;;;;;;;;;; +;; Sugar ;; +;;;;;;;;;;; + (defmacro div [& body] (element* "div" body)) (clojure.core/comment "comment var is already taken") From 6cc5bd27c8fed7ce1222e6bb4dd7fee141ced0d7 Mon Sep 17 00:00:00 2001 From: xificurC Date: Thu, 16 May 2024 17:29:11 +0200 Subject: [PATCH 256/428] dom3 classes --- src/hyperfiddle/dom31.cljc | 63 ++++++++++++++++++++++++++++++++++++-- 1 file changed, 61 insertions(+), 2 deletions(-) diff --git a/src/hyperfiddle/dom31.cljc b/src/hyperfiddle/dom31.cljc index e6405039c..04b6fa818 100644 --- a/src/hyperfiddle/dom31.cljc +++ b/src/hyperfiddle/dom31.cljc @@ -17,10 +17,12 @@ (:require [hyperfiddle.electric-de :as e :refer [$]] ;; [contrib.assert :as ca] + [hyperfiddle.rcf :as rcf :refer [tests]] [missionary.core :as m] ;; [hyperfiddle.electric.impl.lang-de2 :as lang] ;; #?(:cljs [goog.dom]) - )) + ) + #?(:clj (:import [clojure.lang ExceptionInfo]))) ;;;;;;;;;;;;;;; ;; Reference ;; @@ -173,7 +175,64 @@ (defmacro div [& body] (element* "div" body)) -(clojure.core/comment "comment var is already taken") +;;;;;;;;;;;;; +;; CLASSES ;; +;;;;;;;;;;;;; + +(defn parse-class [xs] + (cond (or (string? xs) (keyword? xs) (symbol? xs)) (re-seq #"[^\s]+" (name xs)) + (or (vector? xs) (seq? xs) (list? xs) (set? xs)) (into [] (comp (mapcat parse-class) (distinct)) xs) + (nil? xs) nil + :else (throw (ex-info "don't know how to parse into a classlist" {:data xs})))) + +(tests + (parse-class "a") := ["a"] + (parse-class :a) := ["a"] + (parse-class 'a/b) := ["b"] + (parse-class "a b") := ["a" "b"] + (parse-class ["a"]) := ["a"] + (parse-class ["a" "b" "a"]) := ["a" "b"] + (parse-class ["a" "b"]) := ["a" "b"] + (parse-class ["a b" "c"]) := ["a" "b" "c"] + (parse-class [["a b"] '("c d") #{#{"e"} "f"}]) := ["a" "b" "c" "d" "e" "f"] + (parse-class nil) := nil + (parse-class "") := nil + (parse-class " a") := ["a"] + (try (parse-class 42) (throw (ex-info "" {})) + (catch ExceptionInfo ex (ex-data ex) := {:data 42}))) + +#?(:cljs + (defn build-class-signal [node clazz] + (m/signal (m/observe (fn [!] + (! nil) + (.add (.-classList node) clazz) + #(.remove (.-classList node) clazz)))))) +#?(:cljs + (defn get-class-signal [node clazz] + (let [k (js/Symbol.for (str "hyperfiddle.dom3.class-signal-" clazz))] + (or (aget node k) (aset node k (build-class-signal node clazz)))))) + +(e/defn Class [node clazz] (e/client (e/input (get-class-signal node clazz)))) + +;; how to run an e/fn over a clojure sequence +(e/defn MapCSeq [Fn cseq] (e/cursor [[_ v] (e/diff-by first (map-indexed vector cseq))] ($ Fn v))) +(defmacro for-cseq [[b cseq] & body] `(e/cursor [[i# ~b] (e/diff-by first (map-indexed vector ~cseq))] ~@body)) + +(e/defn ClassList [node classes] + (e/client + ($ MapCSeq (e/fn [clazz] ($ Class node clazz)) (parse-class classes)) + #_(for-cseq [clazz (parse-class classes)] ($ Class node clazz)) + )) + + + +(clojure.core/comment + "comment var is already taken" + + + (defn seq->incseq [xs] (apply i/fixed (eduction (map r/invariant) xs))) + + ) ;; #?(:cljs (defn node? [v] (instance? js/Node v))) ;; From 23139f7aaa7e9327928a48d935ce0a34e050db4a Mon Sep 17 00:00:00 2001 From: Geoffrey Gaillard Date: Fri, 17 May 2024 12:10:11 +0200 Subject: [PATCH 257/428] Comments --- src/hyperfiddle/electric_de.cljc | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/src/hyperfiddle/electric_de.cljc b/src/hyperfiddle/electric_de.cljc index 5550b2553..e3e3ff7bb 100644 --- a/src/hyperfiddle/electric_de.cljc +++ b/src/hyperfiddle/electric_de.cljc @@ -83,6 +83,9 @@ Returns the successive states of items described by `incseq`. (let [~@(interleave args (map dget (range)))] ~@body))])) positionals))) +;; mklocal = declare lexical slot +;; bindlocal = bind lexical slot to value by name +;; See compiler walkthrough: electric/impl/lang_de_walkthrough.md (defmacro fn [& args] (let [?nm (first args)] `(check-electric fn @@ -195,6 +198,9 @@ this tuple. Returns the concatenation of all body results as a single vector. ~(rec bindings)) `(do ~@body))) (seq bindings)))) +;; mklocal = declare lexical slot +;; bindlocal = bind lexical slot to value by name +;; See compiler walkthrough: electric/impl/lang_de_walkthrough.md (defmacro letfn [bs & body] (let [sb (reverse bs)] (reduce (cc/fn [ac [nm]] `(::lang/mklocal ~nm ~ac)) @@ -214,15 +220,16 @@ A mount point can be : (hyperfiddle.electric-de/defn Dispatch [F static args] (let [offset (count static) - arity (+ offset (count args))] - (if-some [ctor (F arity)] - (loop [args args + arity (+ offset (count args))] ; final count of all args + (if-some [ctor (F arity)] ; EFns implement IFn and return a constructor given a arg count + (loop [args args ; if we find the constructor for the current arity, just call it static static] (if (< (count static) arity) (recur (next args) (conj static (::lang/pure (first args)))) (cc/apply r/bind-args (r/bind-self ctor) static))) + ;; search for variadic version (let [[fixed map? ctor] (r/get-variadic "apply" F arity)] - (if (< fixed offset) + (if (< fixed offset) ; if variadic arity has more positional args than provided: pop from rest args (loop [args args static static] (let [args (cons (::lang/join (r/incseq (frame) (peek static))) args) @@ -230,7 +237,7 @@ A mount point can be : (if (< fixed (count static)) (recur args static) (cc/apply r/bind-args (r/bind (r/bind-self ctor) fixed (::lang/pure (cc/apply (r/varargs map?) args))) static)))) - (loop [args args + (loop [args args ; if variadic arity has less positional args than provided: push to rest args static static] (if (< (count static) fixed) (recur (next args) (conj static (::lang/pure (first args)))) From 7f1e766f07b72b6567e8c75c29d161b50a7f2032 Mon Sep 17 00:00:00 2001 From: Geoffrey Gaillard Date: Fri, 17 May 2024 12:11:13 +0200 Subject: [PATCH 258/428] dom 3 - WIP on attributes, properties and styles --- src/hyperfiddle/dom31.cljc | 56 +----- src/hyperfiddle/dom31_attributes.cljc | 265 ++++++++++++++++++++++++++ 2 files changed, 269 insertions(+), 52 deletions(-) create mode 100644 src/hyperfiddle/dom31_attributes.cljc diff --git a/src/hyperfiddle/dom31.cljc b/src/hyperfiddle/dom31.cljc index 04b6fa818..40c8139a3 100644 --- a/src/hyperfiddle/dom31.cljc +++ b/src/hyperfiddle/dom31.cljc @@ -7,8 +7,8 @@ ;; * DONE Implement dom/comment ;; * DONE Implement dom/div ;; * DONE Implement dom/div nesting -;; * TODO Implement setting attributes -;; * TODO Implement setting class +;; * WIP Implement setting attributes +;; * DONE Implement setting class ;; * TODO Implement setting inline style ;; * TODO Implement event handling @@ -88,7 +88,8 @@ ;; Element ;; ;;;;;;;;;;;;; -;; TODO Understand this with 100% precision. +;; DONE Understand this with 100% precision. +;; TODO split into simpler components ;; G: here is my understanding of it (as comments), to be verified. ;; Leo says its done (defn mount-items ;; must not be called on the same element more than once. @@ -175,55 +176,6 @@ (defmacro div [& body] (element* "div" body)) -;;;;;;;;;;;;; -;; CLASSES ;; -;;;;;;;;;;;;; - -(defn parse-class [xs] - (cond (or (string? xs) (keyword? xs) (symbol? xs)) (re-seq #"[^\s]+" (name xs)) - (or (vector? xs) (seq? xs) (list? xs) (set? xs)) (into [] (comp (mapcat parse-class) (distinct)) xs) - (nil? xs) nil - :else (throw (ex-info "don't know how to parse into a classlist" {:data xs})))) - -(tests - (parse-class "a") := ["a"] - (parse-class :a) := ["a"] - (parse-class 'a/b) := ["b"] - (parse-class "a b") := ["a" "b"] - (parse-class ["a"]) := ["a"] - (parse-class ["a" "b" "a"]) := ["a" "b"] - (parse-class ["a" "b"]) := ["a" "b"] - (parse-class ["a b" "c"]) := ["a" "b" "c"] - (parse-class [["a b"] '("c d") #{#{"e"} "f"}]) := ["a" "b" "c" "d" "e" "f"] - (parse-class nil) := nil - (parse-class "") := nil - (parse-class " a") := ["a"] - (try (parse-class 42) (throw (ex-info "" {})) - (catch ExceptionInfo ex (ex-data ex) := {:data 42}))) - -#?(:cljs - (defn build-class-signal [node clazz] - (m/signal (m/observe (fn [!] - (! nil) - (.add (.-classList node) clazz) - #(.remove (.-classList node) clazz)))))) -#?(:cljs - (defn get-class-signal [node clazz] - (let [k (js/Symbol.for (str "hyperfiddle.dom3.class-signal-" clazz))] - (or (aget node k) (aset node k (build-class-signal node clazz)))))) - -(e/defn Class [node clazz] (e/client (e/input (get-class-signal node clazz)))) - -;; how to run an e/fn over a clojure sequence -(e/defn MapCSeq [Fn cseq] (e/cursor [[_ v] (e/diff-by first (map-indexed vector cseq))] ($ Fn v))) -(defmacro for-cseq [[b cseq] & body] `(e/cursor [[i# ~b] (e/diff-by first (map-indexed vector ~cseq))] ~@body)) - -(e/defn ClassList [node classes] - (e/client - ($ MapCSeq (e/fn [clazz] ($ Class node clazz)) (parse-class classes)) - #_(for-cseq [clazz (parse-class classes)] ($ Class node clazz)) - )) - (clojure.core/comment diff --git a/src/hyperfiddle/dom31_attributes.cljc b/src/hyperfiddle/dom31_attributes.cljc new file mode 100644 index 000000000..1d543e8b6 --- /dev/null +++ b/src/hyperfiddle/dom31_attributes.cljc @@ -0,0 +1,265 @@ +(ns hyperfiddle.dom31-attributes ; TODO rename to dom31-props + (:refer-clojure :exclude [class?]) + (:require + [clojure.string :as str] + [hyperfiddle.electric-de :as e :refer [$]] + [hyperfiddle.rcf :refer [tests]] + [missionary.core :as m] + #?(:cljs [goog.object]) + )) + +;;;;;;;;;;;;;;;; +;; Attributes ;; +;;;;;;;;;;;;;;;; + +(def ^:const SVG-NS "http://www.w3.org/2000/svg") +(def ^:const XLINK-NS "http://www.w3.org/1999/xlink") + +(def alias->ns {"svg" SVG-NS, "xlink" XLINK-NS}) + +(defn attr-alias [attr] (second (re-find #"^([^:]+):" (name attr)))) + +(defn resolve-attr-alias [attr] + (let [attr (name attr)] + (if-let [alias (attr-alias attr)] + (let [attr (-> (str/replace-first attr alias "") + (str/replace-first #"^:" ""))] + [(alias->ns alias) attr]) + [nil attr]))) + +#?(:cljs + (defn set-attribute-ns + ([node attr v] + (let [[ns attr] (resolve-attr-alias attr)] + (set-attribute-ns node ns attr v))) + ([^js node ns attr v] + (.setAttributeNS node ns attr v)))) + +#?(:cljs + (defn has-attribute-ns? + ([node attr] + (let [[ns attr] (resolve-attr-alias attr)] + (has-attribute-ns? node ns attr))) + ([^js node ns attr] + (.hasAttributeNS node ns attr)))) + +#?(:cljs + (defn remove-attribute-ns + ([node attr] + (let [[ns attr] (resolve-attr-alias attr)] + (remove-attribute-ns node ns attr))) + ([^js node ns attr] + (.removeAttributeNS node ns attr)))) + +(def DIRECT-ATTRIBUTE-MAP + "Map of attributes that should be set using element.setAttribute(key, val) + instead of element[key] = val. Used by goog.dom.setProperties. + Used by set-property!. + From https://github.com/google/closure-library/blob/7818ff7dc0b53555a7fb3c3427e6761e88bde3a2/closure/goog/dom/dom.js#L563" + {"cellpadding" "cellPadding" + "cellspacing" "cellSpacing" + "colspan" "colSpan" + "frameborder" "frameBorder" + "height" "height" + "maxlength" "maxLength" + "nonce" "nonce" + "role" "role" + "rowspan" "rowSpan" + "type" "type" + "usemap" "useMap" + "valign" "vAlign" + "width" "width"}) + +(def DIRECT-ATTRIBUTE (set (keys DIRECT-ATTRIBUTE-MAP))) + +#?(:cljs + (defn set-property! + "Set " + ([node k v] (set-property! node (.-namespaceURI node) k v)) + ([node ns k v] + (let [k (name k) + v (clj->js v)] + (if (and (nil? v) (has-attribute-ns? node k)) + (remove-attribute-ns node k) + (case k + "list" (set-attribute-ns node nil k v) ; corner case, list (datalist) is setted by attribute and readonly as a prop. + (if (or (= SVG-NS ns) + (DIRECT-ATTRIBUTE k)) + (set-attribute-ns node k v) + (if (goog.object/containsKey node k) ; is there an object property for this key? + (goog.object/set node k v) + (set-attribute-ns node k v))))))))) + +#?(:cljs + (defn watch-attributes [node html-attributes] + (let [html-attributes (set html-attributes)] + (m/relieve {} + (m/reductions into (into {} (map (juxt identity #(.getAttribute node %)) html-attributes)) + (m/observe + (fn [!] + (let [observer (js/MutationObserver. (fn [mutation-list _observer] + (! (filter (comp html-attributes first) + (map (fn [mutation] + (let [attrName (.-attributeName mutation)] + [attrName (.getAttribute node attrName)])) + mutation-list)))))] + (.observe observer node #js{:attributes true}) + #(.disconnect observer))))))))) + +(e/defn Attributes + "Watch for attribute changes in `node`. Return a map of latest attribute values. + Only DOM attributes are watchable, not object properties." + [node attribute-names] + (e/client (e/input (watch-attributes node attribute-names)))) + +(e/defn Attribute + "Watch an `attribute`'s value for a given DOM `node`. Only DOM attributes are watchable, not object properties. + Use `Attributes` to watch multiple attributes at once. + If `value` is provided, reactively sets the correponding `node`'s `attribute`or property to `value`. + On unmount: + - if `attribute` defines an actual DOM attribute, remove `attribute` from `node`. + - if `attribute` defines an object property, sets it to nil." + ([node attribute] (get ($ Attributes node #{attribute}) (name attribute))) + ([node attribute value] + (e/client + (set-property! node attribute value) + (e/on-unmount #(set-property! node attribute nil))))) + +;;;;;;;;;;;;; +;; Classes ;; +;;;;;;;;;;;;; + +(defn parse-class [xs] + (cond (or (string? xs) (keyword? xs) (symbol? xs)) (re-seq #"[^\s]+" (name xs)) + (or (vector? xs) (seq? xs) (list? xs) (set? xs)) (into [] (comp (mapcat parse-class) (distinct)) xs) + (nil? xs) nil + :else (throw (ex-info "don't know how to parse into a classlist" {:data xs})))) + +(tests + (parse-class "a") := ["a"] + (parse-class :a) := ["a"] + (parse-class 'a/b) := ["b"] + (parse-class "a b") := ["a" "b"] + (parse-class ["a"]) := ["a"] + (parse-class ["a" "b" "a"]) := ["a" "b"] + (parse-class ["a" "b"]) := ["a" "b"] + (parse-class ["a b" "c"]) := ["a" "b" "c"] + (parse-class [["a b"] '("c d") #{#{"e"} "f"}]) := ["a" "b" "c" "d" "e" "f"] + (parse-class nil) := nil + (parse-class "") := nil + (parse-class " a") := ["a"] + (try (parse-class 42) (throw (ex-info "" {})) + (catch ExceptionInfo ex (ex-data ex) := {:data 42}))) + +#?(:cljs + (defn build-class-signal [node clazz] + (m/signal (m/observe (fn [!] + (! nil) + (.add (.-classList node) clazz) + #(.remove (.-classList node) clazz)))))) + +#?(:cljs + (defn get-class-signal [node clazz] + (let [k (js/Symbol.for (str "hyperfiddle.dom3.class-signal-" clazz))] + (or (aget node k) (aset node k (build-class-signal node clazz)))))) + +(e/defn Class [node clazz] (e/client (e/input (get-class-signal node clazz)))) + +;; how to run an e/fn over a clojure sequence +(e/defn MapCSeq [Fn cseq] ; FIXME find the right name + (e/cursor [[_ v] (e/diff-by first (map-indexed vector cseq))] ($ Fn v))) + +;; Alternative style +#_(defmacro for-cseq [[b cseq] & body] `(e/cursor [[i# ~b] (e/diff-by first (map-indexed vector ~cseq))] ~@body)) +#_(for-cseq [x xs] ($ Foo x)) + +(e/defn ; ^:hyperfiddle.electric.impl.lang-de2/print-clj-source + Partial ;; TODO move to electric core + ;; Impl is a mechanical 1 to 1 transaltion of clojure partial. + ;; generated code is quite large but redundant, so it gzip to 903 bytes. + ;; we could prune this impl to reduce code size (no clear benefit) + ;; We keep this impl as a proof that our lambda abstraction is correct + ;; We might optimise it later if there are perf issues. + "Takes an Electric function F and fewer than the normal arguments to F, and + returns a e/fn that takes a variable number of additional args. When + called, the returned function calls F with args + additional args." + ([F] F) + ([F arg1] + (e/fn + ([] ($ F arg1)) + ([x] ($ F arg1 x)) + ([x y] ($ F arg1 x y)) + ([x y z] ($ F arg1 x y z)) + ([x y z & args] (e/apply F arg1 x y z args)))) + ([F arg1 arg2] + (e/fn + ([] ($ F arg1 arg2)) + ([x] ($ F arg1 arg2 x)) + ([x y] ($ F arg1 arg2 x y)) + ([x y z] ($ F arg1 arg2 x y z)) + ([x y z & args] (e/apply F arg1 arg2 x y z args)))) + ([F arg1 arg2 arg3] + (e/fn + ([] ($ F arg1 arg2 arg3)) + ([x] ($ F arg1 arg2 arg3 x)) + ([x y] ($ F arg1 arg2 arg3 x y)) + ([x y z] ($ F arg1 arg2 arg3 x y z)) + ([x y z & args] (e/apply F arg1 arg2 arg3 x y z args)))) + ([F arg1 arg2 arg3 & more] + (e/fn [& args] (e/apply F arg1 arg2 arg3 (concat more args))))) + +(e/defn ClassList [node classes] + (e/client + ($ MapCSeq ($ Partial Class node) (parse-class classes)))) + +;;;;;;;;;;;;;;;;;;; +;; Inline Styles ;; +;;;;;;;;;;;;;;;;;;; + +;; TODO +(e/defn Style [node style-map]) + +;;;;;;;;;;;;;;;;;;; +;; Generic Props ;; +;;;;;;;;;;;;;;;;;;; + +(def LAST-PROPS + "Due to a bug in both Webkit and FF, input type range's knob renders in the + wrong place if value is set after `min` and `max`, and `max` is above 100. + Other UI libs circumvent this issue by setting `value` last." + [:value ::value]) + +(defn ordered-props "Sort props by key to ensure they are applied in a predefined order. See `LAST-PROPS`." + [props-map] + (let [props (apply dissoc props-map LAST-PROPS)] + (concat (seq props) (seq (select-keys props-map LAST-PROPS))))) + +(def ^:private style? #{:style ::style}) ; Unnamespaced is allowed for simpler code examples +(def ^:private class? #{:class ::class}) ; But we recommend the namespaced variant + +(e/defn Property + "Set a DOM `node`'s attribute or property to `value`" + [node name value] + (e/client + (cond + (style? name) ($ Style node value) + (class? name) ($ ClassList node value) + :else ($ Attribute node name value)))) + +(e/defn Properties + "Take a map of attribute or property name to value and sets each onto `node`. Return nil." + [node kvs] + (e/client + ($ MapCSeq (e/fn [[name value]] ($ Property node name value)) (ordered-props kvs)))) + +(defmacro props + ([m] `(props node ~m)) + ([node m] + (if (map? m) + `(do ~@(map (fn [[k v]] (cond ; static keyset + saves on a conditional + (style? k) `($ Style ~node ~v) + (class? k) `($ ClassList ~node ~v) + :else `($ Property ~node ~k ~v))) + (ordered-props m)) + nil) + `($ Properties ~node ~m)))) From 59936777142ee7f70b2d518424a7df79fbf92916 Mon Sep 17 00:00:00 2001 From: Geoffrey Gaillard Date: Fri, 17 May 2024 13:58:15 +0200 Subject: [PATCH 259/428] dom 3 - inline styles --- src/hyperfiddle/dom31_attributes.cljc | 29 +++++++++++++++++++++++---- 1 file changed, 25 insertions(+), 4 deletions(-) diff --git a/src/hyperfiddle/dom31_attributes.cljc b/src/hyperfiddle/dom31_attributes.cljc index 1d543e8b6..6d4ad9ca2 100644 --- a/src/hyperfiddle/dom31_attributes.cljc +++ b/src/hyperfiddle/dom31_attributes.cljc @@ -216,8 +216,29 @@ ;; Inline Styles ;; ;;;;;;;;;;;;;;;;;;; -;; TODO -(e/defn Style [node style-map]) +;; TODO move to electric-css +#?(:cljs + (defn set-style! [node k v] + (let [k (clj->js k) + v (clj->js v)] + (if (str/starts-with? k "--") ; CSS variable + (.setProperty (.-style node) k v) + (goog.style/setStyle_ node v k))))) + +(e/defn Style + "Set a style `property` name to `value` on `node`." + ;; Multiple call to Style on the same node and same property will race. + ;; First to unmount will clear style. + [node property value] + (e/client + (set-style! node property value) + (e/on-unmount (partial set-style! node property nil)) + value)) + +(e/defn Styles [node kvs] + (e/client + ($ MapCSeq (e/fn [[property value]] ($ Style node property value)) kvs) + kvs)) ;;;;;;;;;;;;;;;;;;; ;; Generic Props ;; @@ -242,7 +263,7 @@ [node name value] (e/client (cond - (style? name) ($ Style node value) + (style? name) ($ Styles node value) (class? name) ($ ClassList node value) :else ($ Attribute node name value)))) @@ -257,7 +278,7 @@ ([node m] (if (map? m) `(do ~@(map (fn [[k v]] (cond ; static keyset + saves on a conditional - (style? k) `($ Style ~node ~v) + (style? k) `($ Styles ~node ~v) (class? k) `($ ClassList ~node ~v) :else `($ Property ~node ~k ~v))) (ordered-props m)) From bcb5b253d1de642cd01a9854927ad5ffb171593a Mon Sep 17 00:00:00 2001 From: Geoffrey Gaillard Date: Fri, 17 May 2024 14:23:31 +0200 Subject: [PATCH 260/428] ECSS - first pass --- src/hyperfiddle/electric_css.cljc | 62 +++++++++++++++++++++++++++++++ 1 file changed, 62 insertions(+) create mode 100644 src/hyperfiddle/electric_css.cljc diff --git a/src/hyperfiddle/electric_css.cljc b/src/hyperfiddle/electric_css.cljc new file mode 100644 index 000000000..456f1902c --- /dev/null +++ b/src/hyperfiddle/electric_css.cljc @@ -0,0 +1,62 @@ +(ns hyperfiddle.electric-css + "Experimental. Use it at your own risk." + (:require [hyperfiddle.electric :as e] + [hyperfiddle.electric-dom2 :as dom] + [missionary.core :as m]) + #?(:cljs (:require-macros [hyperfiddle.electric-css]))) + +(defn get-rule "get a css rule in the node's stylesheet by index" [node index] + (aget (.-cssRules (.-sheet node)) index)) + +#?(:cljs + (defn make-rule "return the created rule index" [node selector] + (let [sheet (.-sheet node)] + (.insertRule sheet (str selector " {}"))))) + +(defn delete-rule "Delete a rule by index in a node's stylesheet" [node index] + (.deleteRule (.-sheet node) index)) + +#?(:cljs + (defn make-rule< [node selector] + (m/relieve (m/observe (fn [!] + (let [idx (make-rule node selector)] + (! (get-rule node idx)) + #(delete-rule node idx))))))) + +(defn set-property [rule key value] (.setProperty rule (dom/to-str key) (dom/to-str value))) + +(e/def scope "") + +(defn scoped [scope selector] + (if-not (empty? scope) + (str "." scope " " selector) + selector)) + +(defn rule* + ([selector declarations] (rule* `dom/node selector declarations)) + ([node selector declarations] + (when (seq declarations) + `(doto (.-style (new (make-rule< ~node (scoped scope ~selector)))) + ~@(map (fn [[key value]] `(set-property ~key ~value)) declarations))))) + +(defmacro rule + ([declarations] (rule* "" declarations)) + ([selector declarations] (rule* selector declarations)) + ([node selector declarations] (rule* node selector declarations))) + +(defmacro style + "Usage: + (dom/div + (dom/props {:class \"my-div\"}) + (css/style + (css/rule \".my-div\" {:color :red}) + (css/rule \".my-div:hover\" {:color :blue}))) + " + [& body] + `(dom/element "style" ~@body)) + +(defmacro scoped-style [& body] + `(style + (binding [scope ~(str (munge (gensym "class_")))] + ~@body + scope))) From 285fef5f876526009b99289b4fbc0249a2a0c54d Mon Sep 17 00:00:00 2001 From: Geoffrey Gaillard Date: Fri, 23 Feb 2024 12:14:47 +0100 Subject: [PATCH 261/428] Fix CSS rule create/delete lifecyle We were deleting rules by index on unmount, but the index was incorrect. --- src/hyperfiddle/electric_css.cljc | 36 +++++++++++++++++++++---------- 1 file changed, 25 insertions(+), 11 deletions(-) diff --git a/src/hyperfiddle/electric_css.cljc b/src/hyperfiddle/electric_css.cljc index 456f1902c..4739cb224 100644 --- a/src/hyperfiddle/electric_css.cljc +++ b/src/hyperfiddle/electric_css.cljc @@ -5,23 +5,37 @@ [missionary.core :as m]) #?(:cljs (:require-macros [hyperfiddle.electric-css]))) -(defn get-rule "get a css rule in the node's stylesheet by index" [node index] - (aget (.-cssRules (.-sheet node)) index)) +;; (defn get-rule "get a css rule in the node's stylesheet by index" [node index] +;; (aget (.-cssRules (.-sheet node)) index)) + +(defn find-rule-index "Find the rule index in the node sheet's CSSRuleList" [node target-rule] + (let [rules (.-cssRules (.-sheet node)) + len (.-length rules)] + (loop [i 0] + (if (< i len) + (if (= target-rule (aget rules i)) + i + (recur (inc i))) + -1)))) #?(:cljs - (defn make-rule "return the created rule index" [node selector] - (let [sheet (.-sheet node)] - (.insertRule sheet (str selector " {}"))))) + (defn make-rule "Create a rule in node's stylesheet, return the created rule." [node selector] + (let [sheet (.-sheet node) + index (.-length (.-cssRules sheet))] + (.insertRule sheet (str selector " {}") index) + (aget (.-cssRules sheet) index)))) -(defn delete-rule "Delete a rule by index in a node's stylesheet" [node index] - (.deleteRule (.-sheet node) index)) +(defn delete-rule "Remove a given rule from node's stylesheet" [node rule] + (let [idx (find-rule-index node rule)] + (when (> idx -1) + (.deleteRule (.-sheet node) idx)))) #?(:cljs - (defn make-rule< [node selector] + (defn make-rule< "Create and emit a rule for `selector` on mount, remove the rule on unmount." [node selector] (m/relieve (m/observe (fn [!] - (let [idx (make-rule node selector)] - (! (get-rule node idx)) - #(delete-rule node idx))))))) + (let [rule (make-rule node selector)] + (! rule) + #(delete-rule node rule))))))) (defn set-property [rule key value] (.setProperty rule (dom/to-str key) (dom/to-str value))) From 5300d554066d394f6fba1048d22c844076956956 Mon Sep 17 00:00:00 2001 From: Geoffrey Gaillard Date: Fri, 23 Feb 2024 17:25:53 +0100 Subject: [PATCH 262/428] Mount all rules in a single stylesheet in --- src/hyperfiddle/electric_css.cljc | 32 ++++++++++++++++++++++--------- 1 file changed, 23 insertions(+), 9 deletions(-) diff --git a/src/hyperfiddle/electric_css.cljc b/src/hyperfiddle/electric_css.cljc index 4739cb224..d0cc53a2d 100644 --- a/src/hyperfiddle/electric_css.cljc +++ b/src/hyperfiddle/electric_css.cljc @@ -1,13 +1,11 @@ (ns hyperfiddle.electric-css - "Experimental. Use it at your own risk." + "- Experimental — Use it at your own risk. + - No support for at-rules yet." (:require [hyperfiddle.electric :as e] [hyperfiddle.electric-dom2 :as dom] [missionary.core :as m]) #?(:cljs (:require-macros [hyperfiddle.electric-css]))) -;; (defn get-rule "get a css rule in the node's stylesheet by index" [node index] -;; (aget (.-cssRules (.-sheet node)) index)) - (defn find-rule-index "Find the rule index in the node sheet's CSSRuleList" [node target-rule] (let [rules (.-cssRules (.-sheet node)) len (.-length rules)] @@ -58,6 +56,21 @@ ([selector declarations] (rule* selector declarations)) ([node selector declarations] (rule* node selector declarations))) +(def stylesheet< "Mount a singleton stylesheet in the documents's to gather all CSS rules" + #?(:cljs + (m/signal ; We only need one top-level stylesheet into which we inject rules and manage their lifecycle. + ;; We could use `document.adoptedStyleSheets`, but: + ;; - Safari support is still young. + ;; - no clear advantage over the current approach. + ;; - only advantage seem to be saving on a `