diff --git a/.clj-kondo/config.edn b/.clj-kondo/config.edn index 95396a9ea..8bb9eff7e 100644 --- a/.clj-kondo/config.edn +++ b/.clj-kondo/config.edn @@ -1,9 +1,6 @@ -{:lint-as {hyperfiddle.electric/def clojure.core/def - hyperfiddle.electric/defn clojure.core/defn - hyperfiddle.electric/for clojure.core/for - hyperfiddle.electric/with-cycle clojure.core/let - hyperfiddle.electric/fn clojure.core/fn - hyperfiddle.electric/fn* clojure.core/fn* - hyperfiddle.electric.impl.array-fields/deffields clojure.core/declare - hyperfiddle.electric.impl.compiler/let-res clojure.core/let} +{:lint-as {hyperfiddle.electric3/defn clojure.core/defn + hyperfiddle.electric3/for clojure.core/let + hyperfiddle.electric3/cursor clojure.core/let + hyperfiddle.electric3/with-cycle clojure.core/let + hyperfiddle.electric3/fn clojure.core/fn} :linters {:redundant-expression {:level :off}}} diff --git a/.clj-kondo/hyperfiddle/electric/config.edn b/.clj-kondo/hyperfiddle/electric/config.edn index 98b38748e..48b7f0d20 100644 --- a/.clj-kondo/hyperfiddle/electric/config.edn +++ b/.clj-kondo/hyperfiddle/electric/config.edn @@ -1,5 +1,7 @@ {:lint-as {hyperfiddle.electric/def clojure.core/def hyperfiddle.electric/defn clojure.core/defn + hyperfiddle.electric-de/defn clojure.core/defn + hyperfiddle.electric-de/cursor clojure.core/for hyperfiddle.electric/for clojure.core/for hyperfiddle.electric/with-cycle clojure.core/let hyperfiddle.electric/fn clojure.core/fn} diff --git a/ci/run_tests_browser.sh b/ci/run_tests_browser.sh index 80187a2e6..10c347b45 100755 --- a/ci/run_tests_browser.sh +++ b/ci/run_tests_browser.sh @@ -1,5 +1,5 @@ #!/bin/sh -x echo "Running Browser tests" -clojure -M:dev:test:browser-test:shadow-cljs compile :browser-test --force-spawn && \ +clojure -M:test:shadow-cljs compile :browser-test --force-spawn && \ ./node_modules/.bin/karma start --single-run $@ # --browsers Chrome diff --git a/ci/run_tests_jvm.sh b/ci/run_tests_jvm.sh index cbe77defb..0939380a5 100755 --- a/ci/run_tests_jvm.sh +++ b/ci/run_tests_jvm.sh @@ -1,14 +1,12 @@ #!/bin/bash echo "Running JVM tests" + +# All namespaces are tested by default to encourage tested code. +# Use :ns-regexp to blacklist specific namespaces. +# ^(?!foo.(bar|baz)).* : includes everything except foo.bar or foo.baz + clojure -X:test \ - :dirs "[\"src\" \"src-docs\" \"test\"]" \ - :patterns \ - "[\"hyperfiddle.electric.impl.*\" \ - \"hyperfiddle.electric-test\" \ - \"hyperfiddle.zero\" \ - \"hyperfiddle.missionary-test\" \ - \"contrib.missionary-contrib-test\" \ - \"contrib.ednish\" \ - \"contrib.sexpr-router\" \ - ]" + :dirs "[\"src\" \"test\"]" \ + :patterns "[\"^(?!hyperfiddle.(api|popover|txn|electric-fulcro|electric-httpkit|spool|spec)|contrib.(datomic|test.datomic)).*\"]" + 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 diff --git a/ci/running_dom_tests.md b/ci/running_dom_tests.md index 912136f9d..ed133eb2b 100644 --- a/ci/running_dom_tests.md +++ b/ci/running_dom_tests.md @@ -4,12 +4,13 @@ Run `./ci/run_tests_browser.sh`. ## Live reloading -1. Start a watch build for `:browser-test`, either: - - in Shadow UI - - at the REPL `(shadow/watch :browser-test)` - - from a shell `shadow-cljs -A:test watch :browser-test` -2. Run `./node_modules/.bin/karma start --browsers Chrome` - Karma will: - - use Chrome if installed - - fallback to Chromium if installed - - download and install Chromium for you otherwise \ No newline at end of file +``` +clojure -M:test:shadow-cljs watch :browser-test +# in another shell: +./node_modules/.bin/karma start +``` + +Karma will: +- use Chrome if installed +- fallback to Chromium if installed +- download and install Chromium for you otherwise diff --git a/deps.edn b/deps.edn index 60ad91373..9635c37bf 100644 --- a/deps.edn +++ b/deps.edn @@ -1,63 +1,32 @@ {:paths ["src"] - :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.33"} - org.clojure/clojure {:mvn/version "1.12.0-alpha5"} - 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"} + :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.35"} + dom-top/dom-top {:mvn/version "1.0.9"} ; for loopr macro + fipp/fipp {:mvn/version "0.6.26"} + org.clojure/clojure {:mvn/version "1.12.0-alpha11"} + org.clojure/clojurescript {:mvn/version "1.11.121"} + 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 - :extra-deps {binaryage/devtools {:mvn/version "1.0.7"} ; for chrome devtools pretty printing - thheller/shadow-cljs {:mvn/version "2.26.2"} - ;; reagent/reagent {:mvn/version "1.1.1"} ; for reagent interop demo - ch.qos.logback/logback-classic {:mvn/version "1.4.14"} ; logging implementation - 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 - :exclusions [org.slf4j/slf4j-api - info.sunng/ring-jetty9-adapter-http3]} ; no need - ;; ring-basic-authentication/ring-basic-authentication {:mvn/version "1.2.0"} - com.datomic/peer {:mvn/version "1.0.7075" :exclusions [org.slf4j/slf4j-nop]} ; for demos TODO can this be removed? - datascript/datascript {:mvn/version "1.4.1"} ; for demos TODO can this be updated/removed? - } - :jvm-opts ["-XX:-OmitStackTraceInFastThrow" ;; RCF - ]} - :test {:extra-paths [#_"src-dev" "test"] - :jvm-opts ["-Dhyperfiddle.rcf.generate-tests=true" - "-XX:-OmitStackTraceInFastThrow" ;; https://archive.md/NNt9r - ] - :extra-deps {org.clojure/core.async {:mvn/version "1.6.681"} ; for interop helpers only - datascript/datascript {:mvn/version "1.4.1"} - ch.qos.logback/logback-classic {:mvn/version "1.4.14"} - io.github.cognitect-labs/test-runner {:git/url "https://github.com/cognitect-labs/test-runner.git" - :sha "cc75980b43011773162b485f46f939dc5fba91e4"}} - :exec-fn cognitect.test-runner.api/test} + :aliases {:shadow-cljs {:extra-deps {thheller/shadow-cljs {:mvn/version "2.26.2"}} + :main-opts ["-m" "shadow.cljs.devtools.cli"]} - :browser-test {:jvm-opts ["-Dhyperfiddle.electric.web-config-peers=client,cljs,server,cljs"]} - - :build {:extra-paths ["src-build"] - :ns-default build - :extra-deps {io.github.clojure/tools.build {:mvn/version "0.9.6"} - slipset/deps-deploy {:mvn/version "0.2.2"}}} - :shadow-cljs {:extra-deps {thheller/shadow-cljs {:mvn/version "2.26.2"}} - :main-opts ["-m" "shadow.cljs.devtools.cli"]} - :prod {:extra-paths ["src-prod" "src-docs" "resources-demo"] - :extra-deps {ch.qos.logback/logback-classic {:mvn/version "1.4.14"} ; logging implementation - 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 - :exclusions [org.slf4j/slf4j-api - info.sunng/ring-jetty9-adapter-http3]} ; no need - ring-basic-authentication/ring-basic-authentication {:mvn/version "1.2.0"} - datascript/datascript {:mvn/version "1.4.1"} ; for demos TODO can this be updated/removed? - com.datomic/peer {:mvn/version "1.0.7075" :exclusions [org.slf4j/slf4j-nop]} ; for demos TODO can this be removed? - }} - - :profile {:extra-deps {criterium/criterium {:mvn/version "0.4.6"} - com.clojure-goes-fast/clj-async-profiler {:mvn/version "1.1.1"}} - :jvm-opts ["-Djdk.attach.allowAttachSelf" - "-XX:+UnlockDiagnosticVMOptions" - "-XX:+DebugNonSafepoints"]}}} + :test {:extra-paths ["test"] + :exec-fn cognitect.test-runner.api/test + :jvm-opts ["-Dhyperfiddle.rcf.generate-tests=true" "-XX:-OmitStackTraceInFastThrow"] ;; https://archive.md/NNt9r + :extra-deps {org.clojure/core.async {:mvn/version "1.6.681"} ; for interop helpers only + ch.qos.logback/logback-classic {:mvn/version "1.4.14"} + io.github.cognitect-labs/test-runner {:git/url "https://github.com/cognitect-labs/test-runner.git" :sha "cc75980b43011773162b485f46f939dc5fba91e4"} + org.clojure/test.check {:mvn/version "1.1.1"} + com.datomic/local {:mvn/version "1.0.285"} ; for hyperfiddle.transaction-test + com.datomic/client-cloud {:mvn/version "1.0.130"} ; for hyperfiddle.transaction-test + thheller/shadow-cljs {:mvn/version "2.26.2"} ; for hooks tests + ring/ring-core {:mvn/version "1.11.0"} + }} + :build {:extra-paths ["src-build"] + :ns-default build + :extra-deps {io.github.clojure/tools.build {:mvn/version "0.9.6"} + slipset/deps-deploy {:mvn/version "0.2.2"}}}}} diff --git a/docs/clojure-compat-matrix.md b/docs/clojure-compat-matrix.md index d48063bdb..42032855e 100644 --- a/docs/clojure-compat-matrix.md +++ b/docs/clojure-compat-matrix.md @@ -4,8 +4,6 @@ We target full Clojure/Script compatibility (say 99%). That means you can take a Gaps: -- no variable e/fn arity yet -- no recursion yet - see workaround in [src-docs/user/electric/electric_recursion](https://github.com/hyperfiddle/electric/blob/master/src-docs/user/electric/electric_recursion.cljc) - reactive multimethods - reactive protocols - ... \ No newline at end of file diff --git a/scratch/.replit b/scratch/.replit deleted file mode 100644 index d878b28e7..000000000 --- a/scratch/.replit +++ /dev/null @@ -1,10 +0,0 @@ -run = "HF_DEMO=user.replit/main clj -A:dev" - -[env] -CLJ_CONFIG = "/home/runner/.clojure" - -[languages.clojure] -pattern = "**/*.clj" - -[languages.clojure.languageServer] -start = ["clojure-lsp"] diff --git a/scratch/viz.clj b/scratch/viz.clj deleted file mode 100644 index 4ced85d89..000000000 --- a/scratch/viz.clj +++ /dev/null @@ -1,72 +0,0 @@ -(ns hyperfiddle.viz - (:require [clojure.java.io :as io] - [clojure.java.shell :as shell] - [dorothy.core :as dot] - [dorothy.jvm :refer [save!]] - [hyperfiddle.trace :as trace]) - (:import hyperfiddle.View - java.io.File)) - -(defn- links - ([ast] (into [] (links nil [] ast))) - ([prev acc ast] - (if-not (:on ast) - [[(:id ast) prev]] - (cond->> (:on ast) - true (mapcat (fn [node'] (links (:id ast) acc node'))) - (some? prev) (cons [(:id ast) prev]))))) - -(defn default-node-renderer [{:keys [id name type frame rank ok ended queued val]}] - {:label (cond-> (str (clojure.core/name type)) - name (str " " name "\n") - (not name) (str " #" id "\n") - true (str "frame " frame ", rank " rank "\n") - ended (str " ended") - queued (str " queued") - true (str val)) - :color (if ok :green :red)}) - -(defn- graph - ([^View >v] (graph default-node-renderer >v)) - ([rendererf, ^View >v] - (let [ast (trace/datafy (.-node >v))] - (dot/digraph (->> (mapv (juxt :id rendererf) (trace/nodes ast)) - (into (links ast))))))) - -(defn view->digraph - ([file-path, ^View >v] (view->digraph default-node-renderer file-path >v)) - ([rendererf, file-path, ^View >v] - (-> (graph rendererf >v) - (dot/dot) - (save! file-path {:format :png})))) - -(defn- delete-files-recursively - "https://gist.github.com/edw/5128978" - [fname & [silently]] - (letfn [(delete-f [file] - (when (.isDirectory file) - (doseq [child-file (.listFiles file)] - (delete-f child-file))) - (io/delete-file file silently))] - (delete-f (io/file fname)))) - -(defn animation [file-path] - (let [n (atom 0) - ^File f (io/file file-path)] - (when (.exists f) (delete-files-recursively file-path)) ;; if he dies, he dies. - (.mkdir f) - [(fn step [^View >v] - (view->digraph (str file-path (File/separator) @n) >v) - (swap! n inc)) - (fn end [] - (let [end-path (str file-path ".gif")] - (when (.exists (io/file end-path)) (io/delete-file end-path)) - (shell/sh "convert" "-dispose" "previous" "-delay" "250" "-loop" "0" "-resize" "800x800" (str file-path "/*") end-path)))])) - -(defmacro capture-gif [file-path >out & puts] - (let [step-sym (gensym "step") - stepf `(~step-sym ~>out) - body (cons stepf (interleave puts (repeat stepf)))] - `(let [[~step-sym end#] (animation ~file-path)] - ~@body - (end#)))) diff --git a/shadow-cljs.edn b/shadow-cljs.edn index 987322a32..a73f03573 100644 --- a/shadow-cljs.edn +++ b/shadow-cljs.edn @@ -1,42 +1,16 @@ -{:builds {:dev {:target :browser - :devtools {:watch-dir "resources-demo/public" ; live reload CSS - :hud #{:errors :progress} - :ignore-warnings true ; warnings don't prevent hot-reload - :loader-mode :default ; faster reload - } - :output-dir "resources-demo/public/js" - :asset-path "/js" - :modules {:main {:entries [user] - :init-fn user/start!}} - :build-hooks [(shadow.cljs.build-report/hook {:output-to "target/build_report.html"}) - (user/rcf-shadow-hook)]} - :test {:target :node-test +;; All namespaces are tested by default to encourage tested code. +;; Use :ns-regexp to blacklist specific namespaces. +;; ^(?!foo.(bar|baz)).* : includes everything except foo.bar or foo.baz + +{:builds {:test {:target :node-test :output-to "out/node-tests.js" - :ns-regexp "^(hyperfiddle.electric-[^dom|fulcro]|contrib.(ednish|sexpr-router|missionary-contrib-test|stacktrace)).*$" + :ns-regexp "^(?!contrib.(electric-codemirror|datomic)|hyperfiddle.(api|popover|spool|spec|electric-fulcro|electric.impl.compiler-test|electric.impl.cljs-file-to-analyze)).*" :build-options {:cache-level :off} - :modules {:main {:entries [hyperfiddle.zero - hyperfiddle.electric - hyperfiddle.electric-test - #_hyperfiddle.missionary-test - contrib.missionary-contrib-test - contrib.ednish - contrib.sexpr-router]}} - :compiler-options {:warnings {:redef-in-file false}}} + :compiler-options {:reader-features #{:node} ; allow #?(:node …, :cljs …), falls back to :cljs. + :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|stacktrace)).*$" + :ns-regexp "^(?!contrib.(electric-codemirror|datomic)|hyperfiddle.(api|popover|spool|spec|electric-fulcro|electric.impl.compiler-test|electric.impl.cljs-file-to-analyze)).*" :build-options {:cache-level :off} - :build-hooks [(hyperfiddle.browser-test-setup/blow-up-tests-on-warnings)] - :modules {:main {:entries [hyperfiddle.zero - hyperfiddle.electric - hyperfiddle.electric-test - #_hyperfiddle.missionary-test - contrib.missionary-contrib-test - contrib.ednish - contrib.sexpr-router]}} - :compiler-options {:warnings-as-errors {:warning-types #{:infer-warning}}}} - :prod {:target :browser - :output-dir "resources-demo/public/js" - :asset-path "/js" - :module-hash-names true - :modules {:main {:entries [prod] :init-fn prod/start!}}}}} + :build-hooks [(hyperfiddle.browser-test-setup/blow-up-tests-on-warnings)] + :compiler-options {:warnings-as-errors {:warning-types #{:infer-warning}}}}}} diff --git a/src-build/build.clj b/src-build/build.clj index babf9315e..5bced7650 100644 --- a/src-build/build.clj +++ b/src-build/build.clj @@ -1,7 +1,6 @@ (ns build "build electric.jar library artifact" (:require [clojure.tools.build.api :as b] - [clojure.java.shell :as sh] [deps-deploy.deps-deploy :as dd])) (def lib 'com.hyperfiddle/electric) @@ -10,21 +9,9 @@ (def class-dir "target/classes") -(defn compile-java [_] - (b/javac {:src-dirs ["src"] - :class-dir "src" - :basis basis - :javac-opts ["-source" "8" "-target" "8"]})) - (def defaults {:src-pom "src-build/pom-template.xml" :lib lib :class-dir class-dir}) -(defn clean-client [_] (b/delete {:path "resources-demo/public/js"})) -(defn clean-server [_] (b/delete {:path "resources-demo/private/electric/server_programs"})) - -(defn clean [opts] - (clean-client opts) - (clean-server opts) - (b/delete {:path "target"})) +(defn clean [opts] (b/delete {:path "target"})) (defn jar [{:keys [version] :or {version version}}] (let [jar-file (format "target/%s-%s.jar" (name lib) version) @@ -38,8 +25,7 @@ (println "Writing pom.xml") (b/write-pom opts) (println "Copying resources to" class-dir) - (b/copy-dir {:src-dirs ["src"] - :target-dir class-dir}) + (b/copy-dir {:src-dirs ["src"], :target-dir class-dir}) (println "Building jar" jar-file) (b/jar opts))) @@ -61,44 +47,10 @@ :pom-file (b/pom-path {:lib lib :class-dir class-dir})} opts))))) -;; Uberjar - -(defn noop [_]) ; to preload mvn deps - -(defn build-client [{:keys [optimize debug verbose version] - :or {optimize true, debug false, verbose false, version version}}] - (println "Building client. Version:" version) - (let [command (->> ["clj" "-M:prod:shadow-cljs" "release" "prod" - (when debug "--debug") - (when verbose "--verbose") - "--config-merge" - (pr-str {:compiler-options {:optimizations (if optimize :advanced :simple)} - :closure-defines {'hyperfiddle.electric-client/VERSION version}})] - (remove nil?))] - (apply println "Running:" command) - (let [{:keys [exit out err]} (apply sh/sh command)] - (when-not (zero? exit) (println "Exit code" exit)) - (when err (println err)) - (when out (println out))))) - - -(defn uberjar [{:keys [jar-name version optimize debug verbose] - :or {version version, optimize true, debug false, verbose false}}] - #_(doseq [[k v] args] (println (pr-str v) (pr-str (type v)))) ; clojure.main option type reader diagnostics - ; https://github.com/clojure/clojure/blob/38524061dcb14c598c239be87184b3378ffc5bac/src/clj/clojure/main.clj#L482-L516 - - (println "Cleaning up before build") - (clean nil) - - (build-client {:optimize optimize, :debug debug, :verbose verbose, :version version}) - - (println "Bundling sources") - (b/copy-dir {:src-dirs ["src" "src-prod" "src-docs" "resources-demo"] - :target-dir class-dir}) - - (println "Building uberjar") - (b/uber {:class-dir class-dir - :uber-file (or (str jar-name) ; defend against shell misquoting causing clj to read "app.jar" without quotes thus as symbol - (format "target/%s-%s-standalone.jar" "electric-demos" version)) - :basis (b/create-basis {:project "deps.edn" - :aliases [:prod]})})) +;; For reference +#_ +(defn compile-java [_] + (b/javac {:src-dirs ["src"] + :class-dir "src" + :basis basis + :javac-opts ["-source" "8" "-target" "8"]})) diff --git a/src-build/build.md b/src-build/build.md index b2b656944..4eba6f1cd 100644 --- a/src-build/build.md +++ b/src-build/build.md @@ -1,20 +1,21 @@ # Build clojars maven artifact -* versioning scheme is: `v2-alpha-0-g9aae7b1b` -* `v2`: brand/marketing major version, prefixed by the literal 'v' -* `alpha`: maturity in {alpha,beta,rc}; see https://clojure.org/releases/devchangelog +* versioning scheme is: `v3-alpha-0-g9aae7b1b` +* `v3`: brand/marketing major version, prefixed by the literal 'v' +* `alpha`: maturity in {alpha,beta,rc}; see https://clojure.org/releases/devchangelog * `0`: number of commits since the tag * `g9aae7b1b`: git sha, prefixed by the literal 'g' ```shell -git tag v2-alpha # manually set a new tag, or skip to use commit distance from current tag -clojure -T:build clean && rm -rf ./resources/public/js +git tag v3-alpha # manually set a new tag, or skip to use commit distance from current tag +clojure -T:build clean #clj -A:dev -T user/release -- distribute sources, lib consumer will build HYPERFIDDLE_ELECTRIC_BUILD=`git describe --tags --long --always --dirty` clojure -T:build jar :version '"'$HYPERFIDDLE_ELECTRIC_BUILD'"' clojure -T:build install :version '"'$HYPERFIDDLE_ELECTRIC_BUILD'"' -clj -A:dev -T user/main :replace-deps '{:deps {com.hyperfiddle/electric {:mvn/version "'$HYPERFIDDLE_ELECTRIC_BUILD'"}}}' # test demos with maven version +# To test in electric-starter-app: +clj -A:dev -X dev/-main -Sdeps '{:deps {com.hyperfiddle/electric {:mvn/version "'$HYPERFIDDLE_ELECTRIC_BUILD'"}}}' # No way to test remote clojars version without rm in .m2/repositories/com/hyperfiddle # Optional: test electric-starter-app with local maven install env $(cat .env | xargs) clojure -T:build deploy :version '"'$HYPERFIDDLE_ELECTRIC_BUILD'"' @@ -24,29 +25,3 @@ env $(cat .env | xargs) clojure -T:build deploy :version '"'$HYPERFIDDLE_ELECTRI - `CLOJARS_PASSWORD` is not your account password, but rather a genareted token granting deploy rights to the target coordinates. - idea: how to run tests cli? (No need, deployed artifacts already passed CI) - -# Continuous deployment of demos - -```shell -clojure -T:build build-client # optimized release build -clojure -T:build uberjar # contains demos and demo server, currently -java -jar target/electric-demos--standalone.jar clojure.main -m prod -docker build --build-arg HYPERFIDDLE_ELECTRIC_SERVER_VERSION=$(git describe --tags --long --always --dirty) -t electric . -NO_COLOR=1 flyctl deploy --build-arg HYPERFIDDLE_ELECTRIC_SERVER_VERSION=$(git describe --tags --long --always --dirty) -``` - -- `NO_COLOR=1` disables docker-cli fancy shell GUI, so that we see the full log (not paginated) in case of exception -- `--build-only` tests the build on fly.io without deploying - -# Java build (skip unless Java code changes) - -* Electric contains <100 LOC of Java that must be compiled -* see `src/hyperfiddle/electric/{Failure,Pending,Remote}.java` -* We commit compiled .class artifacts directly into the repo for these, because they rarely change. -* As of 2023 Feb 10, we still target java8 compatibility. (Note our jetty adapter also targets Java 8.) - -``` -$ clojure -T:build compile-java -warning: [options] bootstrap class path not set in conjunction with -source 8 -``` -The above warning is expected and can be ignored. diff --git a/src-build/build.sh b/src-build/build.sh index c67508e59..e5bf1c1cb 100755 --- a/src-build/build.sh +++ b/src-build/build.sh @@ -1,7 +1,6 @@ #!/bin/sh -clojure -T:build clean && rm -rf ./resources-demo/public/js -#clj -A:dev -X user/release -- distribute sources, lib consumer will build +clojure -T:build clean HYPERFIDDLE_ELECTRIC_BUILD=`git describe --tags --long --always --dirty` clojure -T:build jar :version '"'$HYPERFIDDLE_ELECTRIC_BUILD'"' clojure -T:build install :version '"'$HYPERFIDDLE_ELECTRIC_BUILD'"' diff --git a/src-dev/user.clj b/src-dev/user.clj deleted file mode 100644 index 7a96237a7..000000000 --- a/src-dev/user.clj +++ /dev/null @@ -1 +0,0 @@ -(ns user) diff --git a/src-dev/user.cljs b/src-dev/user.cljs deleted file mode 100644 index 7a96237a7..000000000 --- a/src-dev/user.cljs +++ /dev/null @@ -1 +0,0 @@ -(ns user) diff --git a/src/clj-kondo.exports/hyperfiddle/electric/config.edn b/src/clj-kondo.exports/hyperfiddle/electric/config.edn index 98b38748e..f60547854 100644 --- a/src/clj-kondo.exports/hyperfiddle/electric/config.edn +++ b/src/clj-kondo.exports/hyperfiddle/electric/config.edn @@ -1,5 +1,7 @@ {:lint-as {hyperfiddle.electric/def clojure.core/def hyperfiddle.electric/defn clojure.core/defn + hyperfiddle.electric3/defn clojure.core/defn + hyperfiddle.electric3/cursor clojure.core/for hyperfiddle.electric/for clojure.core/for hyperfiddle.electric/with-cycle clojure.core/let hyperfiddle.electric/fn clojure.core/fn} diff --git a/src/contrib/assert.cljc b/src/contrib/assert.cljc index a1bb579fd..bea8f66f9 100644 --- a/src/contrib/assert.cljc +++ b/src/contrib/assert.cljc @@ -20,6 +20,23 @@ ([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) + ;; 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))) + #_(#?(: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 + ([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/base64.cljc b/src/contrib/base64.cljc index c15029743..55e725d3c 100644 --- a/src/contrib/base64.cljc +++ b/src/contrib/base64.cljc @@ -1,25 +1,19 @@ (ns contrib.base64 - (:require #?(:cljs [goog.crypt.base64 :as base64]) - [clojure.set :refer [map-invert]] + (:require [clojure.set :refer [map-invert]] clojure.string - [hyperfiddle.rcf :refer [tests]]) + [hyperfiddle.rcf :refer [tests]] + #?(:cljs [goog.crypt.base64 :as base64])) #?(:clj (:import (java.util Base64)))) -#?(:cljs - (when (= *target* "nodejs") - (def base64 (js/require "base-64")))) - (defn base64-encode [s] - #?(:clj (.encodeToString (Base64/getEncoder) (.getBytes s)) - :cljs (if (= *target* "nodejs") - (.encode base64 s) - (base64/encodeString s)))) + #?(:clj (.encodeToString (Base64/getEncoder) (.getBytes s)) + :cljs (base64/encodeString s) + :node (.toString (js/Buffer.from s) "base64"))) (defn base64-decode [s] - #?(:clj (String. (.decode (Base64/getDecoder) (.getBytes s))) - :cljs (if (= *target* "nodejs") - (.decode base64 s) - (base64/decodeString s)))) + #?(:clj (String. (.decode (Base64/getDecoder) (.getBytes s))) + :cljs (base64/decodeString s) + :node (.toString (js/Buffer.from s "base64")))) (tests (base64-encode "hello world") := "aGVsbG8gd29ybGQ=" diff --git a/src/contrib/data.cljc b/src/contrib/data.cljc index 2a457322c..f1bec6f7e 100644 --- a/src/contrib/data.cljc +++ b/src/contrib/data.cljc @@ -343,4 +343,13 @@ "directory is omitted if there are no children matching keep?" ((treelister [{:dir "x" :children [{:file "a"} {:file "b"}]}] :children (fn [v needle] (-> v :file #{needle}))) "nope") - (count (vec *1)) := 0) \ No newline at end of file + (count (vec *1)) := 0) + +(defn fn-> + ([f a] (fn [o] (f o a))) + ([f a b] (fn [o] (f o a b))) + ([f a b c] (fn [o] (f o a b c))) + ([f a b c d] (fn [o] (f o a b c d))) + ([f a b c d e] (fn [o] (f o a b c d e)))) + +(defn keep-if [v pred] (when (pred v) v)) diff --git a/src/contrib/debug.cljc b/src/contrib/debug.cljc index 477fb33d2..eb560370a 100644 --- a/src/contrib/debug.cljc +++ b/src/contrib/debug.cljc @@ -2,26 +2,27 @@ #?(:cljs (:require-macros contrib.debug)) (:require [clojure.string :as str]) (:import #?(:clj [clojure.lang IFn IDeref]) - [hyperfiddle.electric Failure])) + #_[hyperfiddle.electric Failure] ; FIXME Update to electric v3 + )) + +(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 '~'==> 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#)) + `(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#)] @@ -33,6 +34,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] @@ -42,11 +50,23 @@ (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) + (if false #_(instance? Failure v) ; FIXME Update to electric v3 (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)))) + +(defmacro js-measure [nm & body] + (if (:js-globals &env) + (let [st (str nm "-start"), fn (str nm "-end")] + `(let [_# (js/performance.mark ~st) + ret# (do ~@body)] + (js/performance.mark ~fn) + (js/performance.measure ~nm ~st ~fn) + ret#)) + `(do ~@body))) diff --git a/src/contrib/electric_codemirror.cljc b/src/contrib/electric_codemirror.cljc index 55613eb79..091662d5d 100644 --- a/src/contrib/electric_codemirror.cljc +++ b/src/contrib/electric_codemirror.cljc @@ -1,11 +1,11 @@ (ns contrib.electric-codemirror - #?(:cljs (:require-macros contrib.electric-codemirror)) + ;; #?(:cljs (:require-macros contrib.electric-codemirror)) (:require [clojure.edn :as edn] [clojure.pprint :as pprint] #?(:clj clojure.tools.logging) - [hyperfiddle.electric :as e] - [hyperfiddle.electric-dom2 :as dom] + [hyperfiddle.electric3 :as e :refer [$]] + [hyperfiddle.electric-dom3 :as dom] [missionary.core :as m] [hyperfiddle.rcf :as rcf :refer [% tap tests with]] #?@(:cljs [["@codemirror/language" :as language] @@ -86,9 +86,9 @@ (e/defn CodeMirror [props readf writef controlled-value] (e/client - (when-some [[!cm >cm-v] (new (codemirror props))] ; stable through cv changes + (when-some [[!cm >cm-v] (e/input (codemirror props))] ; stable through cv changes (some-> !cm (cm-set! (writef controlled-value))) ; guard "when true" bug causing NPE in certain tutorials - (doto (new (m/relieve {} (m/reductions #(readf %2) controlled-value >cm-v))) ; reduction rebuilt if cv changes, which is fine + (doto (e/input (m/relieve {} (m/reductions #(readf %2) controlled-value >cm-v))) ; reduction rebuilt if cv changes, which is fine #_(as-> $ (println 'cm-v (hash $))))))) (defn read-edn [edn-str] @@ -99,8 +99,8 @@ (defn write-edn [edn] (with-out-str (pprint/pprint edn))) -(e/defn edn [v] (new CodeMirror {:parent dom/node} read-edn write-edn v)) -(e/defn string [v] (new CodeMirror {:parent dom/node} identity identity v)) +(e/defn edn [v] ($ CodeMirror {:parent dom/node} read-edn write-edn v)) +(e/defn string [v] ($ CodeMirror {:parent dom/node} identity identity v)) #_ (tests "cm/string" diff --git a/src/contrib/electric_contrib.cljc b/src/contrib/electric_contrib.cljc deleted file mode 100644 index 36f4fda41..000000000 --- a/src/contrib/electric_contrib.cljc +++ /dev/null @@ -1,28 +0,0 @@ -(ns contrib.electric-contrib - (:require [hyperfiddle.electric :as e] - [hyperfiddle.rcf :refer [tests tap % with]] - [missionary.core :as m])) - -(defmacro after - "2-arg: throw Pending for `ms`, then return `form` - 3-arg: return `init` for `ms`, then return `form`" - ([ms form] `(case (new (e/task->cp (m/sleep ~ms))) ~form)) - ([ms init form] `(case (new (e/task->cp (m/sleep ~ms ::done) nil)) ::done ~form ~init))) - -(defmacro keep-for [ms & body] `(when (new (e/task->cp (m/sleep ~ms false) true)) ~@body)) - -(comment - (keep-for 1000 (dom/>>style :border-color "green"))) - -(defmacro always "like constantly, but runs the body every time you call it" - [& body] - (let [self (gensym)] - `(fn ~self - ([] (do ~@body)) - ([a#] (~self)) - ([a# b#] (~self)) - ([a# b# & more#] (~self))))) - -(comment - (constantly (rand-int)) vs (always (rand-int)) - (fn [_] (rand-int)) vs (always (rand-int))) diff --git a/src/contrib/electric_goog_history.cljc b/src/contrib/electric_goog_history.edn similarity index 99% rename from src/contrib/electric_goog_history.cljc rename to src/contrib/electric_goog_history.edn index 73cbe4a2a..4207e3018 100644 --- a/src/contrib/electric_goog_history.cljc +++ b/src/contrib/electric_goog_history.edn @@ -1,3 +1,4 @@ +;; FIXME revisit under v3 (ns contrib.electric-goog-history #?(:cljs (:import goog.history.Html5History diff --git a/src/contrib/element_syntax.cljc b/src/contrib/element_syntax.cljc deleted file mode 100644 index c6904b88d..000000000 --- a/src/contrib/element_syntax.cljc +++ /dev/null @@ -1,129 +0,0 @@ -(ns contrib.element-syntax - "Experimental electric-dom syntax contributed by @tatut. Unsupported, expect breaking changes, - use at your own risk!" - #?(:cljs (:require-macros [contrib.element-syntax :refer [<%]])) - (:require [clojure.string :as str] - [hyperfiddle.electric-dom2 :as dom])) - -(defn element-class-names [elt] - (map second (re-seq #"\.([^.#]+)" (name elt)))) - -(defn element-name [elt] - (keyword (second (re-find #"^([^.#]+)" (name elt))))) - -(defmacro <% - "Create DOM element by giving a keyword name, optional attributes map and content. - - The keyword name can include hiccup-like class definitions. For example the keyword - `:div.listing.text-xl` will create a div element with two classes (listing and text-xl). - - If the second parameter is a compile time map, it is expanded into an `dom/props` call. - Any keys in the map that start with `:on-` will be turned into `dom/on` calls to register - event handlers. If both the attributes map and the keyword contain classes, they are - combined (keyword classes first). - - The rest of the parameters are the contents and other code passed into the body of - `dom/element`. Compile time strings are wrapped `dom/text`, anything else is passed - through as is. - - Full example: - ``` - (<% :ul.my-listing - (e/for [item (get-items)] - (<% :li.my-listing.list-item - {:on-click (e/fn [_] (js/alert (str \"you clicked: \" (:name item)))) - :class (when (= :warning (:type item)) \"red\")} - (dom/text (:name item))))) - ``` - - " - [elt & attrs-and-content] - (let [[attrs content] (if (map? (first attrs-and-content)) - [(first attrs-and-content) (rest attrs-and-content)] - [nil attrs-and-content]) - handlers (keep (fn [[key val]] - (when (str/starts-with? (str key) ":on-") - [(subs (str key) 4) val])) - (seq attrs)) - classes (element-class-names elt) - attrs (cond-> (apply dissoc attrs (map first handlers)) - (seq classes) - (update ::dom/class (fn [class] - (let [class-names (str/join " " classes)] - (if class - `(str ~(str class-names " ") ~class) - class-names))))) - e (element-name elt)] - `(dom/element - ~e - ~(when attrs - `(dom/props ~attrs)) - ~@(for [[h b] handlers] - `(dom/on ~h ~b)) - ~@(for [c content] - (if (string? c) - `(dom/text ~c) - c))))) - -(comment - - ; Gotchas: - ; 1. (dom/style {:background-color "yellow"}) -- can be fixed - ; 2. (dom/text x) needed for non-literal x -- hard to fix - ; 3. overloaded semantics for string literals. What if we want to pass them out the return channel? - - (ns user.demo-4-chat-extended - (:require - contrib.str - [contrib.element-syntax :refer [<%]] - [hyperfiddle.electric :as e] - [hyperfiddle.electric-dom2 :as dom])) - - #?(:clj (defonce !msgs (atom '()))) - (e/def msgs (e/server (reverse (e/watch !msgs)))) - - #?(:clj (defonce !present (atom {}))) ; session-id -> user - (e/def present (e/server (e/watch !present))) - - (e/defn Chat [username] - (<% :p "Present: ") - (<% :ul - (e/server - (e/for [[session-id username] present] - (e/client - (<% :li (dom/text username (str " (session-id: " session-id ")"))))))) - - (<% :hr) - (<% :ul - (e/server - (e/for [{:keys [::username ::msg]} msgs] - (e/client - (<% :li (<% :strong (dom/text username)) " " (dom/text msg)))))) - - (<% :input - {:props {:placeholder "Type a message"} - :on-keydown (e/fn [e] - (when (= "Enter" (.-key e)) - (when-some [v (contrib.str/empty->nil (-> e .-target .-value))] - (dom/style {:background-color "yellow"}) - (e/server (swap! !msgs #(cons {::username username ::msg v} (take 9 %)))) - (set! (.-value dom/node) ""))))})) - - (e/defn App [] - (e/client - (<% :h1 "Multiplayer chat app with auth and presence") - (let [session-id (e/server (get-in e/*http-request* [:headers "sec-websocket-key"])) - username (e/server (get-in e/*http-request* [:cookies "username" :value]))] - (if-not (some? username) - (do (<% :p "Set login cookie here: " (<% :a {:href "/auth"} "/auth") " (blank password)") - (<% :p "Example HTTP endpoint is here: " - (<% :a {:href "https://github.com/hyperfiddle/electric/blob/master/src/hyperfiddle/electric_jetty_server.clj"} - "electric_jetty_server.clj"))) - (do - (e/server - (swap! !present assoc session-id username) - (e/on-unmount #(swap! !present dissoc session-id))) - (<% :p "Authenticated as: " (dom/text username)) - (Chat. username)))))) - - ) \ No newline at end of file diff --git a/src/contrib/gridsheet.cljc b/src/contrib/gridsheet.cljc deleted file mode 100644 index bb16a2ca8..000000000 --- a/src/contrib/gridsheet.cljc +++ /dev/null @@ -1,94 +0,0 @@ -(ns contrib.gridsheet - "todo deprecate, use HFQL grid. Used by datomic-browser and folder-explorer" - #?(:cljs (:require-macros contrib.gridsheet)) - (:require clojure.math - [contrib.assert :refer [check]] - [contrib.data :refer [auto-props round-floor]] - [hyperfiddle.electric :as e] - [hyperfiddle.electric-dom2 :as dom] - [hyperfiddle.electric-ui4 :as ui] - [hyperfiddle.router :as r] ; todo remove - #?(:cljs goog.object))) - -(e/defn GridSheet [xs props] - (let [props (auto-props props - {::row-height 24 - ::page-size 20}) - {:keys [::Format - ::columns - ::grid-template-columns - ::row-height ; px, same unit as scrollTop - ::page-size #_ "tight"]} props - Format (or Format (e/fn [m a] (e/client (dom/text (pr-str (a m)))))) - client-height (* (inc (check number? page-size)) (check number? row-height)) - rows (seq xs) - row-count (count rows)] - (assert columns "gridsheet: ::columns prop is required") - (e/client - (dom/div (dom/props {:role "grid" - :class (e/server (::dom/class props)) - :style (merge (e/server (::dom/style props)) - {:height (str client-height "px") - :display "grid" :overflowY "auto" - :grid-template-columns (or (e/server (::grid-template-columns props)) - (->> (repeat (e/server (count columns)) "1fr") - (interpose " ") (apply str)))})}) - (let [[scroll-top scroll-height client-height'] (new (ui/scroll-state< dom/node)) - max-height (* row-count row-height) - padding-bottom (js/Math.max (- max-height client-height) 0) - - ; don't scroll past the end - clamped-scroll-top (js/Math.min scroll-top padding-bottom) - - start-row (clojure.math/ceil (/ clamped-scroll-top row-height)) - - ; batch pagination to improve latency - ; (does reducing network even help or just making loads happen offscreen?) - ; clamp start to the nearest page - start-row-page-aligned (round-floor start-row page-size)] - #_(println [:scrollTop scroll-top :scrollHeight scroll-height :clientHeight client-height - :padding-bottom padding-bottom - :start-row start-row :start-row-page-aligned start-row-page-aligned - :take page-size :max-height max-height]) - - (e/for [k columns] - (dom/div (dom/props {:role "columnheader" - :style {:position "sticky" #_"fixed" :top (str 0 "px") - :background-color "rgb(248 250 252)" :box-shadow "0 1px gray"}}) - (dom/text (name k)))) - - ; userland could format the row, no need - ; for grid to be aware of columns, it's just vertical scroll. - ; horizontal scroll changes things. - ; except for the tricky styles ... - (e/server - (when (seq rows) (check vector? (first rows))) - (let [xs (vec (->> rows (drop start-row) (take page-size)))] - (e/for [i (range page-size)] - (let [[depth m] (get xs i [0 ::empty])] - (e/client - (dom/div (dom/props {:role "group" :style {:display "contents" - :grid-row (inc i)}}) - (dom/div (dom/props {:role "gridcell" - :style {:padding-left (-> depth (* 15) (str "px")) - :position "sticky" :top (str (* row-height (inc i)) "px") - :height (str row-height "px")}}) - (e/server (case m ::empty nil (Format. m (first columns))))) ; for effect - (e/for [a (rest columns)] - (dom/div (dom/props {:role "gridcell" - :style {:position "sticky" :top (str (* row-height (inc i)) "px") - :height (str row-height "px")}}) - (e/server (case m ::empty nil (Format. m a))))))))))) ; for effect - (dom/div (dom/props {:style {:padding-bottom (str padding-bottom "px")}})))) ; scrollbar - (dom/div (dom/text (pr-str {:count row-count})))))) - -(e/defn Explorer [query-fn props] - (e/client - (let [search (ffirst (::search r/route))] - (ui/input search (e/fn V! [v] (r/ReplaceState!. [(if (seq v) - (assoc r/route ::search v) - (dissoc r/route ::search))])) - (dom/props {:placeholder "Search" :type "search"})) - (dom/hr) - (e/server - (GridSheet. (query-fn search) props))))) \ No newline at end of file diff --git a/src/contrib/missionary_contrib.cljc b/src/contrib/missionary_contrib.cljc index dee43f3fb..96c935994 100644 --- a/src/contrib/missionary_contrib.cljc +++ b/src/contrib/missionary_contrib.cljc @@ -24,21 +24,21 @@ #?(:clj (tests - (def !it (.iterator (.keySet (java.lang.System/getProperties)))) + (def !it (.iterator (.keySet {:a 1, :b 2, :c 3, :d 4}))) (->> (iterator-consumer !it) (m/eduction (take 3)) (m/reduce conj []) m/?) - := ["java.specification.version" "sun.jnu.encoding" "java.class.path"] + := [:a :b :c] ; careful, Java iterator is stateful - (def xs (iterator-seq (.iterator (.keySet (java.lang.System/getProperties))))) - (take 3 xs) := ["java.specification.version" "sun.jnu.encoding" "java.class.path"] + (def xs (iterator-seq (.iterator (.keySet {:a 1, :b 2, :c 3, :d 4})))) + (take 3 xs) := [:a :b :c] (->> (seq-consumer xs) (m/eduction (take 3)) (m/reduce conj []) m/?) - := ["java.specification.version" "sun.jnu.encoding" "java.class.path"])) + := [:a :b :c])) (defn poll-task "derive discrete flow from succession of polled values from a task (or mbox)" diff --git a/src/contrib/oklab.cljc b/src/contrib/oklab.cljc index 8871abe39..27831e868 100644 --- a/src/contrib/oklab.cljc +++ b/src/contrib/oklab.cljc @@ -49,7 +49,7 @@ (oklch->oklab [29.2345 44.2 27]) := [29.2345 39.382488369125866 20.066380088487968] (oklch->oklab [52.2345 72.2 56.2]) := [52.2345 40.164543439122006 59.99707868160651] (oklch->oklab [60.2345 59.2 95.2]) := [60.2345 -5.365448747708576 58.956356398065445] - (oklch->oklab [62.2345 59.2 126.2]) := [62.2345 -34.963855523099575 47.77205047891309] + (oklch->oklab [62.2345 59.2 126.2]) := [62.2345 #?(:clj -34.963855523099575, :cljs -34.96385552309957) 47.77205047891309] ; platform-dependent precision (oklch->oklab [67.2345 42.5 258.2]) := [67.2345 -8.691082203276117 -41.60186402237161] (oklch->oklab [29.69 45.553 327.1]) := [29.69 38.24720368913612 -24.7432257186029] ) diff --git a/src/contrib/str.cljc b/src/contrib/str.cljc index 7f80d5c44..f6995cbdb 100644 --- a/src/contrib/str.cljc +++ b/src/contrib/str.cljc @@ -60,21 +60,31 @@ (any-matches? ["abc"] "d") := nil) -(defn empty? [s] (or (and (string? s) (zero? (count s))) - (nil? s))) +(defn ^:deprecated empty? "Deprecated. Use clojure.core/empty?" [s] + (or (and (string? s) (zero? (count s))) + (nil? s))) (tests - (empty? "") := true - (empty? nil) := true - (empty? " ") := false) + (empty? "") := true + (clojure.core/empty? "") := true + (empty? nil) := true + (clojure.core/empty? nil) := true + (empty? " ") := false + (clojure.core/empty? " ") := false + ) -(defn empty->nil [s] (if (empty? s) nil s)) +(defn ^:deprecated empty->nil "Deprecated. Use clojure.core/not-empty" [s] (if (clojure.core/empty? s) nil s)) (tests - (empty->nil nil) := nil - (empty->nil "") := nil - (empty->nil " ") := " " - (empty->nil "a") := "a") + (empty->nil nil) := nil + (clojure.core/not-empty nil) := nil + (empty->nil "") := nil + (clojure.core/not-empty "") := nil + (empty->nil " ") := " " + (clojure.core/not-empty " ") := " " + (empty->nil "a") := "a" + (clojure.core/not-empty "a") := "a" + ) (defn blank->nil "Nullify empty strings, identity on all other values." [s] (if-not (string? s) diff --git a/src/contrib/test_match.clj b/src/contrib/test_match.clj new file mode 100644 index 000000000..809a21780 --- /dev/null +++ b/src/contrib/test_match.clj @@ -0,0 +1,181 @@ +(ns contrib.test-match + (:require [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 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))) + ;; 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 (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) (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 + (= `_ 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.lang3 :as-alias lang]) + (require '[hyperfiddle.electric.impl.runtime3 :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/trace.cljc b/src/contrib/trace.cljc deleted file mode 100644 index 08c260306..000000000 --- a/src/contrib/trace.cljc +++ /dev/null @@ -1,88 +0,0 @@ -(ns contrib.trace - (:require - [hyperfiddle.electric :as e] - [hyperfiddle.electric-local-def :as l] - [hyperfiddle.rcf :as rcf :refer [% tap tests with]]) - (:import - [hyperfiddle.electric Pending] - [missionary Cancelled]) - #?(:cljs (:require-macros contrib.trace))) - -(e/def listeners '()) -(defmacro with-listener [l & body] `(binding [listeners (conj listeners ~l)] ~@body)) -(e/def stamp (fn [_])) -(e/def ->point-id (fn [_name _parent-id])) -(e/def ->trace-id (fn [_point-id _v])) -(e/def current nil) - -;; https://github.com/cgrand/macrovich/blob/e80fb37cb795201821d0e75f73119802227e9620/src/net/cgrand/macrovich.cljc -(defmacro macro-case [& {:keys [cljs clj]}] - (if (contains? &env '&env) - `(if (:ns ~'&env) ~cljs ~clj) - (if #?(:clj (:ns &env) :cljs true) cljs clj))) - -(defmacro trace [nm & body] - `(let [nm# ~nm, id# (->point-id nm# (or current 0)), point# {::point-id id#, ::name nm#, ::parent (or current ::root)}] - (doseq [l# listeners] (l# point#)) - (let [[typ# v#] (binding [current id#] - (try [::ok (do ~@body)] - (catch ~(macro-case :clj Throwable :cljs :default) e# [::err e#]))) - trace-id# (->trace-id id# v#) - stamp# (stamp v#) - ;; TODO put exception in trace map - tr# {::trace-id trace-id#, ::stamp stamp#, ::type typ#, ::v v#}] - (doseq [l# listeners] (l# id# tr#)) - (case typ# ::ok v# #_else (throw v#))))) - -(defmacro trace* [nm & body] `(when current (trace ~nm ~@body))) - -(defn- test-listener [tap] - (fn - ([point] (tap [:point point])) - ([id trace] (tap [:trace id trace])))) - -(tests "basic behavior" - (with (l/run (try (binding [->point-id #(do (tap [:point-id % %2]) %) - stamp (let [!t (atom 0)] (fn [_] (let [t (swap! !t inc)] (tap [:stamp]) t))) - ->trace-id (fn [id v] (tap [:trace-id id v]) (str (name id) "-1"))] - (with-listener (test-listener tap) - (tap (trace :outer - (trace :inner 0 1))))) - (catch Pending _) - (catch Cancelled _) - (catch #?(:clj Throwable :cljs :default) e (prn :error (ex-message e)) (throw e)))) - % := [:point-id :outer 0] - % := [:point {::point-id :outer, ::name :outer, ::parent ::root}] - % := [:point-id :inner :outer] - % := [:point {::point-id :inner, ::name :inner, ::parent :outer}] - % := [:trace-id :inner 1] - % := [:stamp] - % := [:trace :inner {::trace-id "inner-1", ::stamp 1, ::v 1, ::type ::ok}] - % := [:trace-id :outer 1] - % := [:stamp] - % := [:trace :outer {::trace-id "outer-1" ::stamp 2, ::v 1, ::type ::ok}] - % := 1)) - -(defn monotonic [] (let [!t (atom 0)] (fn [_] (swap! !t inc)))) - -(tests "exceptions" - (with (l/run (try (binding [->point-id (fn [nm _parent] nm), stamp (monotonic), ->trace-id (fn [id _v] (str (name id) "-1"))] - (with-listener (test-listener tap) - (tap (trace :x (throw (ex-info "boom" {})))))) - (catch #?(:clj Throwable :cljs :default) e - (when-not (= "boom" (ex-message e)) (prn [(type e) (ex-message e)]))))) - % := [:point {::point-id :x, ::name :x, ::parent ::root}] - % := [:trace :x {::trace-id "x-1" , ::stamp 1, ::v _, ::type ::err}])) - -(tests "works across e/fn boundaries" - (with (l/run (try (binding [->point-id (fn [nm _parent] nm), stamp (monotonic), ->trace-id (fn [id _v] (str (name id) "-1"))] - (with-listener (test-listener tap) - (trace :outer - (new (e/fn [] (trace :inner 1)))))) - (catch Pending _) - (catch Cancelled _) - (catch #?(:clj Throwable :cljs :default) e (prn :error (ex-message e)) (throw e)))) - % := [:point _] - % := [:point _] - % := [:trace :inner {::trace-id "inner-1" ::stamp 1, ::v 1, ::type ::ok}] - % := [:trace :outer {::trace-id "outer-1", ::stamp 2, ::v 1, ::type ::ok}])) diff --git a/src/contrib/trace/datascript_tracer.cljc b/src/contrib/trace/datascript_tracer.cljc deleted file mode 100644 index f4f12c6a8..000000000 --- a/src/contrib/trace/datascript_tracer.cljc +++ /dev/null @@ -1,197 +0,0 @@ -(ns contrib.trace.datascript-tracer - (:require [clojure.math :as math] - [contrib.trace :as ct] - [hyperfiddle.electric :as e] - [hyperfiddle.electric-local-def :as l] - [hyperfiddle.electric-dom2 :as dom] - [hyperfiddle.electric-ui4 :as ui] - [hyperfiddle.rcf :as rcf :refer [% tap tests with]] - [contrib.crypt :as crypt] - [datascript.core :as d]) - (:import [hyperfiddle.electric Pending]) - #?(:cljs (:require-macros contrib.trace.datascript-tracer))) - -(e/def conn) -(e/def db) - -(def ds-schema {:db/id {:db/unique :db.unique/identity} - ::ct/point-id {:db/unique :db.unique/identity} - ::ct/trace-id {:db/unique :db.unique/identity} - ::ct/traces {:db/cardinality :db.cardinality/many}}) - -(defn- ds-listener [conn] - (fn - ([point] (d/transact! conn [point])) - ([->point-id trace] (d/transact! conn [{::ct/point-id ->point-id ::ct/traces (::ct/trace-id trace)} - (cond-> trace (nil? (::ct/v trace)) (assoc ::ct/v ::nil))])))) -(defn de-nil [v] (if (= ::nil v) nil v)) -(defn textify [v] (cond (nil? v) "nil" - (instance? Pending v) "⌛" - (instance? #?(:clj Throwable :cljs js/Error) v) (ex-message v) - :else v)) - -(defn default-point-id [id parent] (crypt/sha256-base64 [id parent])) -(defn ->default-trace-id [] - (let [!cache (atom {})] - (fn [point-id _v] - (let [nx (get (swap! !cache update point-id (fnil inc 0)) point-id)] - (str point-id "-" nx))))) -(defn ms [_] #?(:clj (System/currentTimeMillis) :cljs (.now js/Date))) - -(tests - (def gen (->default-trace-id)) - (gen "x" nil) := "x-1" - (gen "x" nil) := "x-2" - (gen 123 nil) := "123-1" - (gen 123 nil) := "123-2") - -(defmacro with-defaults [& body] - `(binding [ct/->trace-id (->default-trace-id), ct/stamp ms, ct/->point-id default-point-id - conn (d/create-conn ds-schema)] - (binding [db (e/debounce 50 (e/watch conn))] - (ct/with-listener (ds-listener conn) - ~@body)))) - -(tests "defaults work" - (defn find-points-named [nm -db] - (d/q '[:find (pull ?e [::ct/parent ::ct/traces]) . :in $ ?nm :where [?e ::ct/name ?nm]] -db nm)) - (defn find-traces [pt -db] - (d/q '[:find (pull ?e [::ct/type ::ct/v]) :in $ [?tid ...] :where [?e ::ct/trace-id ?tid]] -db (::ct/traces pt))) - (defn ->trace-time [trace-id -db] (::ct/stamp (d/entity -db [::ct/trace-id trace-id]))) - - (def !conn (atom nil)) - (def !x (atom 3)) - (with (l/run (try (with-defaults (reset! !conn conn) (tap (ct/trace :+ (+ 2 (e/watch !x))))) - (catch #?(:clj Throwable :cljs :default) e (prn [(type e) (ex-message e)])))) - % := 5 - (def -db (d/db @!conn)) - (def point (find-points-named :+ -db)) - (::ct/parent point) := ::ct/root - (-> point ::ct/traces count) := 1 - (< (- (ms nil) (->trace-time (-> point ::ct/traces first) -db)) 10) := true - (find-traces point -db) := [[{::ct/type ::ct/ok, ::ct/v 5}]] - - (swap! !x inc) - % := 6 - (def -db (d/db @!conn)) - (def point (find-points-named :+ -db)) - (::ct/parent point) := ::ct/root - (-> point ::ct/traces count) := 2 - (find-traces point -db) := [[{::ct/type ::ct/ok, ::ct/v 6}] [{::ct/type ::ct/ok, ::ct/v 5}]] - )) - -(defn ds-get [e k db] (get (d/entity db e) k)) -(defn children [parent-id db] (vec (sort (d/q '[:find [?trace ...] :in $ ?parent :where [?trace ::ct/parent ?parent]] db parent-id)))) -(defn ->traces [point db] - (vec (sort (d/q '[:find [?e ...] :in $ ?point :where [?point ::ct/traces ?tid] [?e ::ct/trace-id ?tid]] db point)))) -(defn ->latest [traces _db] (peek traces)) - -(tests - (def -conn (atom nil)) - (with (l/run (with-defaults (reset! -conn conn) (tap (ct/trace :x (+ 1 2))))) - % := 3 - (def -db (d/db @-conn)) - (children ::ct/root -db) := [1] - (->traces 1 -db) := [2])) - -;; rendering tips from Geoffrey: -;; -;; grid1 grid2 -;; ---------|-------------|----------------- -;; Name | Value | History -;; ---------|-------------|----------------- -;; -;; Render the value into these 2 grids -;; - grid2 can have a scrollbar now, fixing that issue -;; - grid1 gets a bit more tricky, we need to render into the cells correctly -;; - collapsing/expanding will also be a bit trickier -;; - a simple boolean might be enough though, to unmount the rows or mark them display:none -;; - row height needs to be static and `=` in both grids -;; - values in time will be position:absolute or relative with an offset - -(e/def RenderPoint) - -(e/defn DSRenderPoint [point db depth] - (e/client - (dom/div (dom/style {:display "contents"}) - (dom/span (dom/style {:margin-left (str (* 8 depth) "px"), :border "1px solid gray", :height "30px"}) - (dom/text (ds-get point ::ct/name db))) - (dom/span (dom/style {:border "1px solid gray", :height "30px"}) - (dom/text (-> point (->traces db) (->latest db) (ds-get ::ct/v db) de-nil textify))) - (dom/div (dom/style {:display "contents"}) - (e/for-by #(ds-get % ::ct/point-id db) [child-point (children (ds-get point ::ct/point-id db) db)] - (RenderPoint. child-point db (inc depth))))))) - -(defn next-measure-state [{:keys [status start]} id] - (case status - (:measured :idle) {:status :began :start id} - (:began) {:status :measured :start start :end id})) - -;; TODO cleanup, 6 args.. Same with later fns -(e/defn DSRenderHistory [traces origin db pixel-secs !measure container-offset] - (e/client - (dom/div (dom/style {:height "30px", :position "relative", :border "1px solid gray" - :padding-right (str (+ container-offset 100) "px")}) - (e/for [trace traces] - (let [stamp (ds-get trace ::ct/stamp db) - ;; 200ms difference - ;; 10px = 1sec = 1000ms - ;; 10px/1000ms = offset/200ms - ;; offset = 200ms*10px/1000ms = 2px - offset (-> stamp (- origin) (* pixel-secs) (quot 1000)) - typ (ds-get trace ::ct/type db) - v (de-nil (ds-get trace ::ct/v db))] - (dom/span (dom/style {:position "absolute" - :left (str offset "px") - :background-color (case typ - ::ct/ok "#c5e8c5" - ::ct/err (if (instance? Pending v) "inherit" "#ffcaca"))}) - (dom/text (textify v)) - (dom/on! "click" (fn [_] (swap! !measure next-measure-state trace))))))))) - -(defn ->origin [db] (reduce min (ms nil) (d/q '[:find [?stamp ...] :where [_ ::ct/stamp ?stamp]] db))) - -(e/def RenderTraces) - -(e/defn DSRenderTraces [point db origin pixel-secs !measure offset] - (e/client - (DSRenderHistory. (->traces point db) origin db pixel-secs !measure offset) - (e/for-by #(ds-get % ::ct/point-id db) [child-point (children (ds-get point ::ct/point-id db) db)] - (RenderTraces. child-point db origin pixel-secs !measure offset)))) - -#?(:cljs (defn scroll-to-end [node _db] (set! (.-scrollLeft node) (.-scrollWidth node)))) - -(defn time-str [ms] (if (> ms 1000) (str (-> ms (/ 10) math/round (/ 100)) "s") (str ms "ms"))) -(defn measure-distance [start end db] (abs (- (ds-get start ::ct/stamp db) (ds-get end ::ct/stamp db)))) - -(defn- calculate-history-container-offset [origin pixel-secs db] - (-> (reduce max (d/q '[:find [?stamp ...] :where [_ ::ct/stamp ?stamp]] db)) - (- origin) (* pixel-secs) (quot 1000))) - -(e/defn DatascriptTraceView [] - (e/client - (binding [RenderPoint DSRenderPoint, RenderTraces DSRenderTraces] - (let [!pixel-secs (atom 1000), pixel-secs (e/watch !pixel-secs) - !measure (atom {:status :idle}), measure (e/watch !measure) - !offset (atom 0), offset (e/watch !offset) - origin (->origin db)] - (dom/div (dom/props {:class "dstrace"}) - (dom/span (dom/text "time granularity: ")) - (ui/range pixel-secs (e/fn [v] (reset! !pixel-secs v)) - (dom/style {:display "inline-block", :width "200px"}) - (dom/props {:min 1, :max 10000})) - (dom/div - (dom/text "distance: " - (when (= :measured (:status measure)) - (time-str (measure-distance (:start measure) (:end measure) db))))) - (dom/div (dom/style {:display "flex"}) - (dom/div (dom/style {:display "inline-grid", :grid-template-columns "1fr 1fr", :min-width "400px"}) - (dom/strong (dom/text "Name")) (dom/strong (dom/text "Value")) - (e/for [root-point (children ::ct/root db)] - (RenderPoint. root-point db 0))) - (dom/div (dom/style {:display "inline-grid", :overflow "scroll", :white-space "nowrap", :flex-grow 1}) - (dom/strong (dom/style {:height "22px"}) (dom/text "History")) - (case (e/for [root-point (children ::ct/root db)] - (RenderTraces. root-point db origin pixel-secs !measure offset)) - (case (reset! !offset (calculate-history-container-offset origin pixel-secs db)) - (scroll-to-end dom/node [db pixel-secs])))))))))) diff --git a/src/contrib/trace3.cljc b/src/contrib/trace3.cljc new file mode 100644 index 000000000..af9fbdcc7 --- /dev/null +++ b/src/contrib/trace3.cljc @@ -0,0 +1,155 @@ +(ns contrib.trace3 + (:require + #?(:clj [contrib.triple-store :as ts]) + [clojure.math :as math] + [contrib.str] + [hyperfiddle.electric3 :as e :refer [$]] + [hyperfiddle.electric-dom3 :as dom] + #?(:cljs [hyperfiddle.electric.impl.runtime3 :refer [Failure]]) + [missionary.core :as m]) + #?(:clj (:import [hyperfiddle.electric.impl.runtime3 Failure])) + #?(:cljs (:require-macros contrib.trace3))) + +(def current nil) +(declare !db db !measure measure !q q) +(let [c (atom {})] + (defn ->trace-id [nm] + [nm (-> (swap! c update nm (fnil inc 0)) (get nm))])) +(defn ->stamp ([] #?(:clj (System/currentTimeMillis) :cljs (.now js/Date))) ([_] (->stamp))) +(let [!i (atom 0)] (defn ->id [_] (swap! !i inc))) + +#?(:clj + (defn insert-trace [db trace] + (if (::id trace) + (cond-> db (not (ts/find db ::id (::id trace))) (ts/add (assoc trace :db/id (->id trace)))) + (ts/add db (assoc trace :db/id (->id trace)))))) + +(defn save-trace [!db trace] #?(:clj (swap! !db insert-trace trace))) +(defn push-trace [!q trace] #?(:cljs (swap! !q conj trace))) + +(defn save-trace! [trace !db !q] + (if (instance? Failure !db) + (push-trace !q trace) + (save-trace !db trace))) + +(defn ->stable-trace-id [v] [v 0]) + +(letfn [(save [!db !q a b c] + (save-trace! a !db !q) + (save-trace! b !db !q) + (save-trace! c !db !q))] + (e/defn Trace + ([nm F] ($ Trace nm identity F)) + ([nm ->pretty F] ($ Trace nm ->trace-id ->pretty F)) + ([nm ->trace-id ->pretty F] + (let [nm (->trace-id nm)] + (save-trace! {::id nm, ::parent current} !db !q) + (save-trace! {::v ::mount, ::v-of nm, ::stamp (->stamp), ::pretty-v "🟢"} !db !q) + (let [v (binding [current nm] ($ F))] + (save-trace! {::v-of nm, ::stamp (->stamp v), ::v v, ::pretty-v (->pretty v)} !db !q) + (e/on-unmount #(save-trace! {::v-of nm, ::stamp (->stamp), ::v ::unmount, ::pretty-v "🔴"} !db !q)) + v))))) + +(defmacro trace + ([nm form] `(trace ~nm identity ~form)) + ([nm ->pretty form] `(trace ~nm ->trace-id ~->pretty ~form)) + ([nm ->trace-id ->pretty form] `($ Trace ~nm ~->trace-id ~->pretty (e/fn [] ~form)))) + +(defn ->queue + ([] #?(:clj clojure.lang.PersistentQueue/EMPTY :cljs #queue [])) + ([& args] (into (->queue) args))) + +#?(:clj (defn save-traces [!db trace+] (swap! !db (fn [db] (reduce insert-trace db trace+))))) + +(e/defn SendClientTraces [ms] + (e/client + (when-some [spend! ($ e/CyclicToken (seq q))] + (case ($ e/Task (m/sleep ms)) + (let [[trace+] (swap-vals! !q (constantly []))] + (spend! (e/server (save-traces !db trace+)))))))) + +(defmacro with-defaults [& body] + `(let [!db# (e/server (atom (ts/->ts))), m# (e/server (atom (->queue nil nil))), q# (e/client (atom []))] + (binding [!db !db#, db (e/server (e/watch !db#)), !measure m#, measure (e/server (e/watch m#)) + !q q#, q (e/client (e/watch q#))] + ($ SendClientTraces 80) + ~@body))) + +#?(:clj (defn get-latest-pretty-v [db id] + (->> (ts/find db ::v-of id) reverse first (ts/->node db) ::pretty-v))) + +(defn ->pretty [v] (if (nil? v) "␀" v)) + +(e/defn RenderPoint [e depth] + (e/client + (let [nd (e/server (ts/->node db e))] + (dom/span + (dom/props {:style {:margin-left (str (* 12 depth) "px")}}) + (dom/text (e/server (-> (::id nd) first name symbol)))) + (dom/span + (dom/text (e/server (->pretty (get-latest-pretty-v db (::id nd)))))) + (e/cursor [c (e/server (e/diff-by identity (ts/find db ::parent (::id nd))))] + ($ RenderPoint c (inc depth)))))) + +(def pixel-secs 1000) + +(e/defn RenderPointHistory [vs-e origin] + (dom/div + (dom/props {:style {:position "relative"}}) + (e/cursor [ve (e/diff-by identity vs-e)] + (let [nd (e/server (ts/->node db ve)) + ;; 200ms difference + ;; 10px = 1sec = 1000ms + ;; 10px/1000ms = offset/200ms + ;; offset = 200ms*10px/1000ms = 2px + offset (-> (e/server (::stamp nd)) (- origin) (* pixel-secs) (quot 1000))] + (dom/span + (dom/props {:style {:position "absolute", :left (str offset "px")} + :title (e/server (contrib.str/pprint-str nd))}) + (dom/text (->pretty (e/server (::pretty-v nd)))) + (when-some [spend! ($ e/Token ($ dom/On "click"))] + (spend! (e/server (swap! !measure (fn [m] (conj (pop m) ve))))))))))) + +(e/defn RenderHistory [e origin] + (let [id (e/server (::id (ts/->node db e)))] + ($ RenderPointHistory (e/server (ts/find db ::v-of id)) origin) + (e/cursor [ce (e/server (e/diff-by identity (ts/find db ::parent id)))] + ($ RenderHistory ce origin)))) + +#?(:clj (defn ->origin [db] (->> db :ave ::stamp keys (reduce min)))) + +(e/defn Header [s] (dom/strong (dom/text s))) + +(def grid-color "repeating-linear-gradient(to bottom, #fff 0, #fff 30px, #e5fff5 30px, #e5fff5 60px)") + +(defn time-str [ms] (if (> ms 1000) (str (-> ms (/ 10) math/round (/ 100)) "s") (str ms "ms"))) +#?(:clj (defn measure-distance [db [starte ende]] + (when ende + (abs (- (::stamp (ts/->node db starte)) (::stamp (ts/->node db ende))))))) + +(e/defn Throttle [ms v] + (let [[v2 spend!] ($ e/StampedToken v)] + (when spend! (spend! ($ e/Task (m/sleep ms)))) + (if spend! v2 v))) + +(e/defn TraceView [] + ;; binding [db ($ Throttle 2000 db)] + (e/client + (dom/div + (dom/props {:class "dstrace"}) + (dom/div (dom/text "Distance: " (e/server (some-> (measure-distance db measure) time-str)))) + (dom/div + (dom/props {:style {:display "flex"}}) + (dom/div + (dom/props {:style {:display "inline-grid", :grid-template-columns "1fr 1fr", :min-width "400px" + :background grid-color, :grid-auto-rows "30px"}}) + ($ Header "Name") ($ Header "Value") + (e/cursor [root-e (e/server (e/diff-by identity (ts/find db ::parent nil)))] + ($ RenderPoint root-e 0))) + (dom/div + (dom/props {:style {:display "inline-grid", :overflow "scroll", :white-space "nowrap", :flex-grow 1 + :background grid-color, :grid-auto-rows "30px"}}) + ($ Header "History") + (let [origin (e/server (->origin @!db))] + (e/cursor [root-e (e/server (e/diff-by identity (ts/find db ::parent nil)))] + ($ RenderHistory root-e origin)))))))) diff --git a/src/contrib/triple_store.clj b/src/contrib/triple_store.clj new file mode 100644 index 000000000..1c92e776d --- /dev/null +++ b/src/contrib/triple_store.clj @@ -0,0 +1,82 @@ +(ns contrib.triple-store + (:refer-clojure :exclude [find]) + (:require [dom-top.core :refer [loopr]] + [clojure.set :as set] + [contrib.assert :as ca])) + +;; 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} CURRENTLY NOT USED/FILLED + +(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) + vea + #_(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) + 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) + 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)) + ] + (->TripleStore (:o ts) eav ave vea))) + +(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)) + +(defn ->datoms [ts] + (loopr [datoms (transient [])] + [[e av] (:eav ts) + [a v] av] + (recur (conj! datoms [e a v])) + (persistent! datoms))) + +;;;;;;;;;;;;;;; +;;; HELPERS ;;; +;;;;;;;;;;;;;;; + +(defn ->node [ts e] (get (:eav ts) e)) +(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/contrib/uri.cljc b/src/contrib/uri.cljc index 655a0839c..802e9cef2 100644 --- a/src/contrib/uri.cljc +++ b/src/contrib/uri.cljc @@ -89,8 +89,8 @@ ; Readers (tests - "clj #user/uri runtime literal readers are auto-wired in clojure from data_readers.cljc" - #?@(:clj ((clojure.core/read-string "#user/uri \"http://localhost:8080/a?b#c\"") := x)) + ;; "clj #user/uri runtime literal readers are auto-wired in clojure from data_readers.cljc" + ;; #?@(:clj ((clojure.core/read-string "#user/uri \"http://localhost:8080/a?b#c\"") := x)) ; no custom data_readers file in this repo "cljs #user/uri runtime literals are NOT auto-wired in cljs reader (the cljs JS runtime reader is always an EDN reader for safety, unlike clj)" diff --git a/src/hyperfiddle/domlike.cljc b/src/hyperfiddle/domlike.cljc new file mode 100644 index 000000000..7b45fbf24 --- /dev/null +++ b/src/hyperfiddle/domlike.cljc @@ -0,0 +1,110 @@ +(ns hyperfiddle.domlike " +A mutable tree implementation with an API isomorphic to a subset of the DOM. +") + +(defn node " +Return a fresh node. +" [] + (doto (object-array 3) + (aset 2 []))) + +(defn parent " +Return `node`'s current parent. +" [^objects node] + (aget node 0)) + +(defn set-parent " +Assign `node`'s parent to `parent`. +" [^objects node parent] + (aset node 0 parent)) + +(defn index " +Return `node`'s current index. +" [^objects node] + (aget node 1)) + +(defn set-index " +Assign `node`'s index to `index`. +" [^objects node index] + (aset node 1 index)) + +(defn children " +Return `node`'s current children. +" [^objects node] + (aget node 2)) + +(defn set-children " +Assign `node`s children to `children`. +" [^objects node children] + (aset node 2 children)) + +(defn nth-child " +Return `node`'s child in position `i`, or `nil` if out of bounds. +" [node i] + (nth (children node) i nil)) + +(defn remove-at [node i] + (let [v (children node)] + (set-children node + (into (subvec v 0 i) + (map (fn [c] (set-index c (dec (index c))) c)) + (subvec v (inc i)))))) + +(defn remove-child " +Remove `child` from `node`'s children and return the removed node. +" [node child] + (when-not (identical? node (parent child)) + (throw (#?(:clj Error. :cljs js/Error.) "not a child"))) + (remove-at node (index child)) + (set-parent child nil) + (set-index child nil) + child) + +(defn replace-child " +Replace `old` by `child` in `node`'s children and return the removed node. +" [node child old] + (when-not (identical? node (parent old)) + (throw (#?(:clj Error. :cljs js/Error.) "not a child"))) + (when-some [p (parent child)] + (remove-at p (index child))) + (set-parent child node) + (set-index child (index old)) + (set-children node + (assoc (children node) + (index old) child)) + (set-parent old nil) + (set-index old nil) + old) + +(defn insert-before " +Insert `child` before `sibling` in `node`s children and return the added node. +" [node child sibling] + (when-not (nil? sibling) + (when (identical? child sibling) + (throw (#?(:clj Error. :cljs js/Error.) "insert before self"))) + (when-not (identical? node (parent sibling)) + (throw (#?(:clj Error. :cljs js/Error.) "not a child")))) + (when-some [p (parent child)] + (remove-at p (index child))) + (let [v (children node) + i (if (nil? sibling) + (count v) + (index sibling))] + (set-parent child node) + (set-index child i) + (set-children node + (-> [] + (into (subvec v 0 i)) + (conj child) + (into (map (fn [c] (set-index c (inc (index c))) c)) + (subvec v i)))) + child)) + +(defn append-child " +Adds `child` at the end of `node`'s children and return the added node. +" [node child] + (insert-before node child nil)) + +(defn tree " +Return a snapshot of the tree rooted at `node`. +" [node] (into [node] (map tree) (children node))) \ No newline at end of file diff --git a/src/hyperfiddle/electric.cljc b/src/hyperfiddle/electric.cljc deleted file mode 100644 index 36ee0b203..000000000 --- a/src/hyperfiddle/electric.cljc +++ /dev/null @@ -1,654 +0,0 @@ -(ns hyperfiddle.electric - (:refer-clojure :exclude [eval def defn fn for partial apply]) - (:require [clojure.core :as cc] - #?(:clj [clojure.tools.logging :as log]) - [clojure.spec.alpha :as s] - contrib.data - [contrib.cljs-target :refer [do-browser]] - [contrib.missionary-contrib :as mx] - [contrib.assert :as ca] - #?(:clj [hyperfiddle.electric.impl.expand :as expand]) - [hyperfiddle.electric.impl.lang :as lang] - [hyperfiddle.electric.impl.runtime :as r] - [hyperfiddle.electric.impl.for :as for] - #?(:clj [hyperfiddle.rcf.analyzer :as ana]) ; todo remove - [missionary.core :as m] - #?(:cljs [hyperfiddle.electric-client]) - [hyperfiddle.electric.impl.io :as io] - [hyperfiddle.electric.debug :as dbg] - [clojure.string :as str] - [contrib.str]) - #?(:cljs (:require-macros - [hyperfiddle.electric :refer [offload-task offload def check-electric - client server fn fn* defn for-by for watch discard with-cycle - partial-dynamic partial on-unmount with-zero-config-entrypoint - snapshot apply for-event for-event-pending - for-event-pending-switch do-event do-event-pending]])) - (:import (hyperfiddle.electric Failure Pending FailureInfo) - (missionary Cancelled))) - -(s/def ::user-version string?) - -;; Equality semantics for Failure and Pending -;; For JVM, defined in java class. -#?(:cljs - (extend-type Pending - IEquiv - (-equiv [this other] - (instance? Pending other)))) - -#?(:cljs - (extend-type Failure - IEquiv - (-equiv [this other] - (and (instance? Failure other) - (= (.-error this) (.-error other)))))) - -#?(:cljs (set! (.. FailureInfo -prototype -__proto__) cljs.core/ExceptionInfo.prototype)) -#?(:cljs - (extend-type FailureInfo - IEquiv - (-equiv [this other] - (and (instance? FailureInfo other) - (= (.-cause this) (.-cause other)))))) -#?(:clj - (do - ;; Optionally, tell RCF not to rewrite Electric programs. - (defmethod ana/macroexpand-hook `hyperfiddle.electric/local [the-var form env args] (reduced `(hyperfiddle.electric/local ~@args))) - - ;; Don't expand cc/binding (prevent infinite loop). Explicit implicit do - (defmethod ana/macroexpand-hook 'clojure.core/binding [_the-var _form _env [bindings & body]] (reduced `(binding ~bindings (do ~@body)))) - (defmethod ana/macroexpand-hook 'cljs.core/binding [_the-var _form _env [bindings & body]] (reduced `(binding ~bindings (do ~@body)))))) - -(def hook r/hook) -(def bind r/bind) ; for when you want to spawn a e/fn without a new -(def with r/with) - -(cc/defn pair [c s] - (m/sp - (let [s->c (m/dfv) - c->s (m/dfv)] - (m/? - (m/join {} - (s (cc/fn [x] (m/sp ((m/? s->c) x))) - (cc/fn [!] (c->s !) #())) - (c (cc/fn [x] (m/sp ((m/? c->s) x))) - (cc/fn [!] (s->c !) #()) - #(throw %))))))) - -(cc/defn normalize-env [env] (if (:js-globals env) env {:locals env, :ns (ns-name *ns*)})) - -#?(:clj (cc/defn read-web-config [conf-str] - (let [args (mapv keyword (str/split conf-str #","))] - {::lang/peers (cc/apply hash-map args), ::lang/current (first args)}))) - -#?(:clj (def web-config - (or (some-> (System/getProperty "hyperfiddle.electric.web-config-peers") read-web-config) - {::lang/peers {:client :cljs :server :clj} - ::lang/current :server}))) - -(defmacro local - "Single peer loopback system without whitelist. Returns boot task." - {:style/indent 0} - [& body] - (let [env (normalize-env &env) - client (lang/analyze (merge env web-config {::lang/me :client}) `(do ~@body)) - client-info (r/compile "clocal" client env) - server (lang/analyze (merge env web-config {::lang/me :server}) `(do ~@body)) - server-info (r/compile "slocal" server env)] - `(pair - (r/main ~client-info) - (r/main ~server-info)))) - -(defmacro run "test entrypoint without whitelist." {:style/indent 0} [& body] `((local ~@body) {} {})) - -(cc/defn failure? [x] (instance? Failure x)) - -#?(:clj - (cc/defn -offload-task [thunk executor] - (->> (m/ap (m/? (m/via executor (thunk)))) ; run once - (m/reductions {} (Failure. (Pending.))) - (m/relieve {})))) - -(defmacro offload-task ; speculative - ([f! executor] `(new (-offload-task ~f! ~executor))) ; rebuild flow and cancel old thread - ; no varadic arity, user should explicitly state unit of work, so no ambiguity about concurrent tasks - ([f!] `(new (-offload-task ~f! m/blk)))) - -#?(:clj (cc/defn -offload [tsk executor] - (m/reductions {} r/pending - (m/ap (try (m/? (m/via-call executor (m/?< (mx/poll-task tsk)))) - (catch Cancelled _ (m/amb))))))) - -(defmacro offload - "run a blocking function (i.e. query) on threadpool specified by `executor` (i.e. m/blk or m/cpu). -IO-bound fns should use m/blk, which is the default. Compute-bound fns should pass m/cpu. Custom -executors are allowed (i.e. to control max concurrency, timeouts etc). Currently JVM only." - ([f! executor] - `(let [mbx# (m/mbx)] - (mbx# ~f!) - (new (-offload mbx# ~executor)))) - ([f!] `(offload ~f! m/blk))) - -(defmacro ^:deprecated wrap "Deprecated. Use `offload` instead." [& body] `(offload #(do ~@body))) - -; Should these be in missionary? -;(def chan-read! contrib.missionary-contrib/chan-read!) -;(def chan->ap contrib.missionary-contrib/chan->ap) -;(def chan->task contrib.missionary-contrib/chan->task) -;(def chan->cp contrib.missionary-contrib/chan->cp) - -(cc/defn task->cp ; leo to review - ([!x] (task->cp !x (Failure. (Pending.)))) ; note Electric dependency - ([!x pending] (->> (m/ap (m/? !x)) (m/reductions {} pending)))) - -; Moved to contrib.missionary-contrib -;(defmacro use-channel ;; TODO rename -; ([chan] `(use-channel nil ~chan)) -; ([init chan] `(new (m/reductions {} ~init (chan->ap ~chan))))) - -#?(:cljs - (deftype Clock [^:mutable ^number raf - ^:mutable callback - terminator] - IFn ; cancel - (-invoke [_] - (if (zero? raf) - (set! callback nil) - (do (.cancelAnimationFrame js/window raf) - (terminator)))) - IDeref ; sample - (-deref [_] - ; lazy clock, only resets once sampled - (if (nil? callback) - (terminator) - (set! raf (.requestAnimationFrame js/window callback))) ; RAF not called until first sampling - ::tick))) - -; cc def, must be above defmacro def -(def ^:no-doc Clock 0 nil t)] - (set! (.-callback cancel) - (cc/fn [_] (set! (.-raf cancel) 0) (n))) - (n) cancel)) - - ; 120 hz server, careful this impacts bandwidth in demo-two-clocks - ; typical UI animation rate is 60 or 120hz, no point in going higher - :clj (m/ap (loop [] (m/amb nil (do (m/? (m/sleep (/ 1000 120))) (recur))))) - #_(m/ap (m/? (m/sleep 1 (m/?> (m/seed (repeat nil)))))))) - -;; -------------------------------------- - -(defmacro def - ([symbol] `(hyperfiddle.electric/def ~symbol [::lang/unbound '~(cc/symbol (str *ns*) (str symbol))])) - ([symbol docstring init] - (assert (string? docstring)) - (#'def &form &env (vary-meta symbol assoc :doc docstring) init)) - ([symbol init] (lang/-def (merge (normalize-env &env) web-config) symbol init))) - -(defmacro check-electric [fn form] - (if expand/*electric* - form - (throw (ex-info (str "Electric code (" fn ") inside a Clojure function") (into {:electric-fn fn} (meta &form)))))) - -(defmacro client {:style/indent 0} [& body] - `(check-electric client - (::lang/toggle :client ~(assoc (meta &form) ::dbg/type :transfer, ::dbg/name ::client) ~@body))) -(defmacro server {:style/indent 0} [& body] - `(check-electric server - (::lang/toggle :server ~(assoc (meta &form) ::dbg/type :transfer, ::dbg/name ::server) ~@body))) - -(cc/defn -get-system-time-ms [& [_]] #?(:clj (System/currentTimeMillis) :cljs (js/Date.now))) - -; DOM event utilities promoted due to visibility-state being critical - -#?(:cljs (cc/defn dom-listener [node typ f opts] - (.addEventListener node typ f (clj->js opts)) - #(.removeEventListener node typ f))) - -#?(:cljs (cc/defn listen> ; we intend to replace this in UI5 workstream - ([node event-type] (listen> node event-type identity {})) - ([node event-type keep-fn!] (listen> node event-type keep-fn! {})) - ([node event-type keep-fn! opts] - (m/relieve {} - (m/observe (cc/fn [!] - (dom-listener node event-type #(when-some [v (keep-fn! %)] - (! v)) opts))))))) - -#?(:cljs (def > (listen> js/document "visibilitychange") - (m/reductions {} (.-visibilityState js/document)) - (m/latest (cc/fn [_] (.-visibilityState js/document))))))) - -(hyperfiddle.electric/def dom-visibility-state (client (new (identity js/document "mousemove"))))) -(hyperfiddle.electric/def dom-mousemove "mousemove events, Pending if unknown" - (client (new (identity ") " with " provided - " argument" (when-not (= 1 provided) "s") " but it has " actual - " positional argument" (when-not (= 1 actual) "s")) - {})))) - -#?(: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/%closure])))) - -#?(:clj (cc/defn- -build-fn-arity [?name args body] - [(count args) - `(binding [lang/rec (::lang/closure - (case (-check-recur-arity lang/%arity ~(count args) '~?name) - (let [~@(interleave args lang/arg-sym)] ~@body)))] - (new lang/rec ~@(take (count args) lang/arg-sym)))])) - -#?(: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 (::lang/closure (case (-check-recur-arity lang/%arity ~(inc npos) '~?name) - (let [~@(interleave unvarargd lang/arg-sym)] ~@body)))] - (new lang/rec ~@(take npos lang/arg-sym) - (let [~v (into [] (drop ~npos) lang/%args)] - (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))))) - -(cc/defn -throw-arity [?name nargs arities] - (throw (ex-info (str "You called " (or ?name "") " with " nargs - " argument" (when (not= nargs 1) "s") " but it only supports " arities) - {}))) - -#?(: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) - arity-set (->narity-set (map first arities)) - {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)) - positional-branches (into [] (map (cc/fn [[args & body]] (-build-fn-arity ?name args body))) positionals)] - (list `check-electric `fn - (list ::lang/closure - (-> `(case lang/%arity - ~@(into [] (comp cat cat) [positional-branches]) - ~@(if (seq varargs) - (conj [(arity-holes arity-set) `(-throw-arity '~?name lang/%arity ~(str/join ", " arity-set))] - (-build-vararg-arity ?name (ffirst varargs) (nfirst varargs))) - [`(-throw-arity '~?name lang/%arity ~(str/join ", " arity-set))]) - #_(-throw-arity '~?name lang/%arity ~(->> arities (eduction (map first)) ->narity-set (str/join ", ")))) - (?bind-self ?name)) - {::dbg/name ?name, ::dbg/type (or (::dbg/type (meta ?name)) :reactive-fn) - ::dbg/meta (merge (select-keys (meta &form) [:file :line]) - (select-keys (meta ?name) [:file :line]) - {::dbg/ns (name (.getName *ns*))})})))) - -(defmacro defn [sym & fdecl] - (let [[_defn sym' & _] (macroexpand `(cc/defn ~sym ~@fdecl))] ; GG: docstring support - `(hyperfiddle.electric/def ~sym' (hyperfiddle.electric/fn ~(vary-meta sym' merge {::dbg/type :reactive-defn} - (meta &form) - (meta sym')) - ~@(if (string? (first fdecl)) ; GG: skip docstring - (rest fdecl) - fdecl))))) - -(defmacro ^:no-doc defn* [sym & fdecl] - (let [[_defn sym' & _] (macroexpand `(cc/defn ~sym ~@fdecl))] ; GG: docstring support - `(hyperfiddle.electric/def ~sym' (hyperfiddle.electric/fn* - ~@(if (string? (first fdecl)) ; GG: skip docstring - (rest fdecl) - fdecl))))) - -(cc/defn- -splicev [args] (if (empty? args) args (into [] cat [(pop args) (peek args)]))) - -(hyperfiddle.electric/defn* Apply* [F args] ; we use `defn*` instead of e/def e/fn* for better stacktraces - (let [spliced (-splicev args)] - (case (count spliced) - 0 (new F) - 1 (new F (nth spliced 0)) - 2 (new F (nth spliced 0) (nth spliced 1)) - 3 (new F (nth spliced 0) (nth spliced 1) (nth spliced 2)) - 4 (new F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3)) - 5 (new F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4)) - 6 (new F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5)) - 7 (new F (nth spliced 0) (nth spliced 1) (nth spliced 2) (nth spliced 3) (nth spliced 4) (nth spliced 5) (nth spliced 6)) - 8 (new 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 (new 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 (new 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 (new 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 (new 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 (new 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 (new 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 (new 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 (new 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 (new 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 (new 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 (new 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 (new 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] - (assert (not (empty? args)) (str `apply " takes and Electric function and at least one argument. Given 0.")) ; matches clojure behavior - `(new Apply* ~F [~@args])) - - -(defmacro for-by - {:style/indent 2} - [kf bindings & body] - (if-some [[s v & bindings] (seq bindings)] - `(let [xs# ~v] - (new (r/bind for/map-by ~kf - (cc/partial (::lang/inject lang/%0) - (::lang/closure - (let [~s lang/%0] - (for-by ~kf ~bindings ~@body)))) - (::lang/lift xs#)))) - (cons `do body))) ; todo, buggy: (e/for [x []] (println 42)) should not print - -(defmacro for - {:style/indent 1} - [bindings & body] - `(hyperfiddle.electric/for-by identity ~bindings ~@body)) - -(cc/defn ^:no-doc watchable? [x] - #?(:clj (instance? clojure.lang.IRef x) - :cljs (satisfies? IWatchable x))) - -(cc/defn ^:no-doc checked-watch [!x] - (->> !x (ca/check watchable?) m/watch)) - -(defmacro watch "Derive a reactive value from a Clojure atom or reference." - [!x] - `(check-electric watch (new (checked-watch ~!x)))) - -(cc/defn debounce-discreet - ([delay flow] (debounce-discreet delay nil flow)) - ([delay init flow] (m/reductions {} init (m/ap (let [x (m/?< flow)] - (try (m/? (m/sleep delay x)) - (catch Cancelled _ (m/amb))))))) ) - -(defmacro ^:deprecated debounce ; immoral? introduces avoidable delays - "Debounce a continous flow by `delay` milliseconds." - [delay flow] - `(new (->> (fn [] ~flow) - (debounce-discreet ~delay) - (m/relieve {})))) - -(cc/defn throttle [dur >in] ; in CLJ, wrong number of args (1) passed to: hyperfiddle.electric-ui4/long --- ????? - (m/ap - (let [x (m/?> (m/relieve {} >in))] - (m/amb x (do (m/? (m/sleep dur)) (m/amb)))))) - -(defmacro flow - "Transform an Electric value into a Missionary flow by \"quoting\" it with e/fn. -Quoting it directly is idiomatic as well." - {:style/indent 0} - [x] `(hyperfiddle.electric/fn [] ~x)) - -(defmacro discard - "Silence \"Unserializable reference transfer\"; inlining `(do ... nil)` is idiomatic as well" - {:style/indent 0} - [& body] `(do ~@body nil)) - -(defmacro with-cycle - "evaluates body with symbol s bound to the previous result of the body evaluation. - the first evaluation binds s to i." - {:style/indent 1} - [[s i] & body] - `(let [a# (atom ~i) ~s (hyperfiddle.electric/watch a#)] - (reset! a# (do ~@body)))) - -(defmacro partial-dynamic - "Return a function calling given function `f` with given dynamic environment." - [bindings f] - `(cc/fn [& args#] (binding ~bindings (cc/apply ~f args#)))) - -(defmacro partial - "Like `cc/partial` for reactive functions. Requires the target function - arity (`argc`) until reactive function supports variadic arguments. - - e.g. (new (partial 2 (e/fn [a b] [a b]) :a) :b) ;; => [:a :b]" - [argc F & args] - (if (= 0 argc) - F - (let [rest-args (map #(symbol (str "arg_" %)) (range (- argc (count args))))] - `(let [F# ~F] - (hyperfiddle.electric/fn ~@(when (symbol? F) [F]) [~@rest-args] - (new F# ~@args ~@rest-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] `(new (on-unmount* ~f))) ; experimental - -(cc/defn log-root-error [exception async-stack-trace] - #?(:clj (let [ex (dbg/empty-client-exception exception) - ex (dbg/clean-jvm-stack-trace! (dbg/remove-async-stack-trace ex)) - ex (dbg/add-async-frames! ex async-stack-trace)] - (if-some [data (not-empty (dissoc (ex-data ex) ::type))] - (log/error ex "Uncaugh exception:" (ex-message ex) "\n" data) - (log/error ex "Uncaugh exception"))) - :cljs (js/console.error exception))) - -#?(:cljs - (cc/defn- client-log-server-error [message async-trace] - (let [err (js/Error. message)] - (set! (.-stack err) (first (str/split-lines (.-stack err)))) - (js/console.error err) ; We'd like to bundle these two messages into one, but chrome refuses to render "\n" after an exception. - ; We would need browser-custom formatting. Not worth it today. - (js/console.log (->> (dbg/render-async-stack-trace async-trace) - (contrib.str/align-regexp #" at ") - (dbg/left-pad-stack-trace 4)) - "\n" "This is a server-side exception. The full exception was printed on the server.")))) - -#?(:cljs - (cc/defn- client-log-client-error [ex async-trace] - (set! (.-stack ex) (dbg/cleanup-js-stack-trace (.-stack ex))) - (js/console.error ex) ; We'd like to bundle these two messages into one, but chrome refuses to render "\n" after an exception. - ; We would need browser-custom formatting. Not worth it today. - (js/console.log (->> (dbg/render-async-stack-trace async-trace) - (contrib.str/align-regexp #" at ") - (dbg/left-pad-stack-trace 4))))) - -(cc/defn- log-on-server-that-error-happened-on-client [] - ;; FIXME should be inlinable, but Electric fails to resolve log/info var in a `server` block. - #?(:clj (log/info "This is a client-side exception. The full exception was printed on the client."))) - -(hyperfiddle.electric/defn ?PrintClientException [msg id] - (server - (let [async-trace (::dbg/trace (ex-data lang/trace))] - (try - (client - (if-some [ex (io/get-original-ex id)] - (do - (client-log-client-error ex async-trace) - (try (server (log-on-server-that-error-happened-on-client)) - (catch Pending _))) - (client-log-server-error msg async-trace))) - (catch Pending _))))) - -(defmacro with-zero-config-entrypoint - {:style/indent 0} - [& body] - `(try - (do ~@body) - (catch Pending _#) ; silently ignore - (catch Cancelled e# (throw e#)) ; bypass catchall, app is shutting down - (catch Throwable err# - (log-root-error (or (io/get-original-ex (dbg/ex-id lang/trace)) err#) (dbg/get-async-trace lang/trace)) - (new ?PrintClientException (ex-message err#) (dbg/ex-id lang/trace))))) - -(defmacro boot-server [opts Main & args] - (let [env (merge (normalize-env &env) web-config {::lang/me :server} opts) - ir (lang/analyze env `(with-zero-config-entrypoint (new ~Main ~@args))) - info (r/compile (gensym) ir env)] - `(r/main ~info))) - -(defmacro boot-client [opts Main & args] - (let [env (merge (normalize-env &env) web-config {::lang/me :client} opts) - ir (lang/analyze env `(with-zero-config-entrypoint (new ~Main ~@args))) - info (r/compile (gensym) ir env)] - `(hyperfiddle.electric-client/reload-when-stale - (hyperfiddle.electric-client/boot-with-retry - (r/main ~info) - hyperfiddle.electric-client/connector)))) - -(hyperfiddle.electric/def http-request "Bound to the HTTP request of the page in which the current Electric program is running." nil) - -(cc/defn -snapshot [flow] (->> flow (m/eduction (contrib.data/take-upto (complement #{r/pending}))))) - -(defmacro snapshot - "Snapshots the first non-Pending value of reactive value `x` and freezes it, -inhibiting all further reactive updates." - [x] `(check-electric snapshot (new (-snapshot (hyperfiddle.electric/fn* [] ~x))))) - -(cc/defn ->Object [] #?(:clj (Object.) :cljs (js/Object.))) ; private - -;; low-level, most powerful, hardest to use -(defmacro for-event - ; Progress in UI is a continuous flow (succession of values) that eventually completes with a final result. - "For each value of >flow, spawn concurrent `body` branches which individually -progress towards completion. Keeps each branch alive to progress in isolation -until it signals completion by returning a reduced value, at which point the branch -is unmounted. Returns active progress values as a vector. Exceptions bubble out." - {:style/indent 1} - [[sym >flow] & body] - `(let [mbx# (m/mbx)] - (new (m/reductions {} nil (m/eduction (map #(mbx# [::mx/add (->Object) %])) ~>flow))) - (for-by first [[progressing-event# ~sym] (new (mx/document (mx/poll-task mbx#)))] - (let [v# (do ~@body)] - (if (reduced? v#) - (do (mbx# [::mx/retract progressing-event#]) nil) - v#))))) - -(def pending (Pending.)) - -;; high-level wrapper of above, returns a union type, waits for non-Pending value -(defmacro for-event-pending - "Like for-event, but each branch completes as soon as a non-Pending value or -exception is available. Returns [::pending e/pending] if there are one or more -uncompleted branches, otherwise returns a 4-colored result corresponding to the -progress of the most recently completed branch." - {:style/indent 1} - [bind & body] - `(let [!state# (atom [::init]), state# (hyperfiddle.electric/watch !state#)] - (if (seq (for-event ~bind - (try (reduced (reset! !state# [::ok (do ~@body)])) - (catch Pending ex#) - (catch Cancelled ex# (reduced nil)) - (catch ~(if (:ns &env) :default `Throwable) ex# - (reduced (reset! !state# [::failed ex#])))))) - [::pending pending] ; save Pending exception for easy re-throw - state#))) - -;; e/for-event-pending-switch is similar to m/?<. -;; When a new event comes in a new branch is immediately spawned and the previous cancelled -;; ok, so these operators are basically the equivalent of m/?< m/?> and m/?= extended into continuous time. -;; one runs events concurrently, one runs events sequentially, and one interrupts -;; for-event-sequence, for-event-concurrent, for-event-interrupt -(defmacro for-event-pending-switch ; for-event?< - "Like for-event, but each new event supersedes the prior event, canceling and -discarding previous it even if in progress. The single active branch completes -on the first non-Pending value. Returns a single four-colored result -corresponding to the progress of the most recent event." - {:style/indent 1} - [[sym >flow :as bind] & body] - `(let [!i# (atom 0), i# (hyperfiddle.electric/watch !i#) - !state# (atom [::init]), state# (hyperfiddle.electric/watch !state#)] - (if (seq (for-event ~bind - (try (when (<= i# (inc @!i#)) - (reset! !state# [::ok (do ~@body)])) - (reduced (swap! !i# inc)) - (catch Pending ex#) - (catch Cancelled ex# (reduced nil)) - (catch ~(if (:ns &env) :default `Throwable) - ex# (reduced (reset! !state# [::failed ex#])))))) - [::pending pending] state#))) - -(defmacro do-event ; for-one-event - "Run `body` continuation in response to next event (silently discarding subsequent -events) until it completes by evaluating to a `reduced` value. On completion, -unmounts the body, returning nil while waiting for a fresh event." - ; Useful for button case because it discards. Not useful for create-new, because it discards. - ; Does this blink-and-clear on completion? - {:style/indent 1} - [[sym >flow] & body] - `(let [!e# (atom nil)] - (new (m/reductions #(swap! !e# (cc/fn [cur#] ; latch first non-nil event - (if (nil? cur#) %2 cur#))) ; discarding events until event processing completes - nil ~>flow)) - (when-some [~sym (hyperfiddle.electric/watch !e#)] ; wait for non-nil event (rising edge), bind in scope for body - (let [v# (do ~@body)] ; nil is insignificant here - (if (reduced? v#) ; never seen - (reset! !e# nil) ; reset, unmount body, wait for fresh event - v#))))) - -(defmacro do-event-pending - "Run `body` continuation in response to next event (silently discarding subsequent -events) until it completes by evaluating to a non-Pending result. On completion, -unmounts the body, latches and returns the 4-colored result while waiting for a -fresh event." - {:style/indent 1} - [[sym >flow :as bind] & body] - `(let [!state# (atom [::init])] - (do-event ~bind - ; D: Why not leave the body alive, is the signal state the same as this explicit latch? - (try (reduced (reset! !state# [::ok (do ~@body)])) ; latch result - (catch Pending ex# (reset! !state# [::pending pending])) ; wait longer - (catch Cancelled ex# (reduced nil)) - (catch ~(if (:ns &env) :default `Throwable) ex# - (reduced (reset! !state# [::failed ex#]))))) ; latch result - (hyperfiddle.electric/watch !state#))) - -(cc/defn -inhibit [>x] (m/reductions nil nil (m/ap (m/?< >x) (m/amb)))) - -(defmacro inhibit "Run body for effects, ignore result. Returns an invariable nil." - {:style/indent 1} - [& body] `(new (-inhibit (hyperfiddle.electric/fn [] ~@body)))) diff --git a/src/hyperfiddle/electric/Failure.class b/src/hyperfiddle/electric/Failure.class deleted file mode 100644 index 579d336ee..000000000 Binary files a/src/hyperfiddle/electric/Failure.class and /dev/null differ diff --git a/src/hyperfiddle/electric/Failure.java b/src/hyperfiddle/electric/Failure.java deleted file mode 100644 index dd6fda323..000000000 --- a/src/hyperfiddle/electric/Failure.java +++ /dev/null @@ -1,10 +0,0 @@ -package hyperfiddle.electric; -public class Failure { - public final Throwable error; - public Failure(Throwable e) { - this.error = e; - } - public boolean equals(Object o){ - return (o instanceof Failure) && (this.error.equals(((Failure) o).error)); - } -} diff --git a/src/hyperfiddle/electric/Failure.js b/src/hyperfiddle/electric/Failure.js deleted file mode 100644 index 2c5c9209e..000000000 --- a/src/hyperfiddle/electric/Failure.js +++ /dev/null @@ -1,8 +0,0 @@ -goog.provide('hyperfiddle.electric.Failure'); - -/** - * @constructor - */ -hyperfiddle.electric.Failure = function(e) { - this.error = e; -}; \ No newline at end of file diff --git a/src/hyperfiddle/electric/FailureInfo.class b/src/hyperfiddle/electric/FailureInfo.class deleted file mode 100644 index c8952d486..000000000 Binary files a/src/hyperfiddle/electric/FailureInfo.class and /dev/null differ diff --git a/src/hyperfiddle/electric/FailureInfo.java b/src/hyperfiddle/electric/FailureInfo.java deleted file mode 100644 index 34f3c5875..000000000 --- a/src/hyperfiddle/electric/FailureInfo.java +++ /dev/null @@ -1,36 +0,0 @@ -package hyperfiddle.electric; -import clojure.lang.IExceptionInfo; -import clojure.lang.IPersistentMap; -import clojure.lang.Util; - -/* - Like ExceptionInfo, but for electric failure. - Does not allocate a stacktrace. - */ -public class FailureInfo extends RuntimeException implements IExceptionInfo{ - public final IPersistentMap data; - public final Object id; - - public FailureInfo(String s, IPersistentMap data, Object id, Throwable throwable) { - super(s, throwable, false, false); - if (data != null) { - this.data = data; - } else { - throw new IllegalArgumentException("Additional data must be non-nil."); - } - this.id = id; - } - - public IPersistentMap getData() { - return data; - } - - public String toString() { - return "hyperfiddle.electric.FailureInfo: " + getMessage() + " " + data.toString(); - } - - public boolean equals(Object o){ - return (o instanceof FailureInfo) && Util.equals(this.getCause(), ((FailureInfo) o).getCause()); - } - -} diff --git a/src/hyperfiddle/electric/FailureInfo.js b/src/hyperfiddle/electric/FailureInfo.js deleted file mode 100644 index a2be1ff96..000000000 --- a/src/hyperfiddle/electric/FailureInfo.js +++ /dev/null @@ -1,11 +0,0 @@ -goog.provide('hyperfiddle.electric.FailureInfo'); - -/** - * @constructor - */ -hyperfiddle.electric.FailureInfo = function(message, data, id, cause) { - this.message = message; - this.data = data; - this.id = id; - this.cause = cause; -}; diff --git a/src/hyperfiddle/electric/Pending.class b/src/hyperfiddle/electric/Pending.class deleted file mode 100644 index da9f28163..000000000 Binary files a/src/hyperfiddle/electric/Pending.class and /dev/null differ diff --git a/src/hyperfiddle/electric/Pending.java b/src/hyperfiddle/electric/Pending.java deleted file mode 100644 index 04e4dc49b..000000000 --- a/src/hyperfiddle/electric/Pending.java +++ /dev/null @@ -1,10 +0,0 @@ -package hyperfiddle.electric; -public class Pending extends Throwable { - public Pending() { - super(null, null, false, false); - } - - public boolean equals(Object o){ - return (o instanceof Pending); - } -} diff --git a/src/hyperfiddle/electric/Pending.js b/src/hyperfiddle/electric/Pending.js deleted file mode 100644 index bf41493ee..000000000 --- a/src/hyperfiddle/electric/Pending.js +++ /dev/null @@ -1,6 +0,0 @@ -goog.provide('hyperfiddle.electric.Pending'); - -/** - * @constructor - */ -hyperfiddle.electric.Pending = function() {}; \ No newline at end of file diff --git a/src/hyperfiddle/electric/Remote.class b/src/hyperfiddle/electric/Remote.class deleted file mode 100644 index 9630dcd08..000000000 Binary files a/src/hyperfiddle/electric/Remote.class and /dev/null differ diff --git a/src/hyperfiddle/electric/Remote.java b/src/hyperfiddle/electric/Remote.java deleted file mode 100644 index bd8b2958f..000000000 --- a/src/hyperfiddle/electric/Remote.java +++ /dev/null @@ -1,2 +0,0 @@ -package hyperfiddle.electric; -public class Remote extends Throwable {} diff --git a/src/hyperfiddle/electric/Remote.js b/src/hyperfiddle/electric/Remote.js deleted file mode 100644 index 0333c807e..000000000 --- a/src/hyperfiddle/electric/Remote.js +++ /dev/null @@ -1,6 +0,0 @@ -goog.provide('hyperfiddle.electric.Remote'); - -/** - * @constructor - */ -hyperfiddle.electric.Remote = function() {}; \ No newline at end of file diff --git a/src/hyperfiddle/electric/debug.cljc b/src/hyperfiddle/electric/debug3.cljc similarity index 56% rename from src/hyperfiddle/electric/debug.cljc rename to src/hyperfiddle/electric/debug3.cljc index 8dfbe3e2e..acbf27f13 100644 --- a/src/hyperfiddle/electric/debug.cljc +++ b/src/hyperfiddle/electric/debug3.cljc @@ -1,14 +1,8 @@ -(ns hyperfiddle.electric.debug +(ns hyperfiddle.electric.debug3 (:require [clojure.string :as str] [contrib.data :as data] - [hyperfiddle.electric.impl.ir :as-alias ir] - [hyperfiddle.rcf :as rcf :refer [tests]] #?(:cljs [contrib.stacktrace :as st]) - [contrib.str]) - (:import #?(:clj (clojure.lang ExceptionInfo)) - (hyperfiddle.electric Failure Pending) - (hyperfiddle.electric FailureInfo) - (missionary Cancelled))) + [contrib.str])) (defn ->id [] #?(:clj (java.util.UUID/randomUUID) @@ -19,43 +13,6 @@ ;; UUID v4 collision probability assumed insignificant for this use case (->id)) -(defn ex-info* - ([message data] (ex-info* message data nil)) - ([message data cause] (ex-info* message data (str (->id)) cause)) - ([message data id cause] (FailureInfo. message (assoc data :hyperfiddle.electric/type ::trace) id cause))) - -(tests "2 traces with equal values are =" - (let [cause #?(:clj (Throwable.) :cljs (js/Error.))] - (ex-info* "" {} cause) := (ex-info* "" {} cause) - nil)) - -(defn ex-id [ex] (.-id ^FailureInfo ex)) - -(defn add-stack-frame [stack-frame exception] - (let [stack-frame (assoc stack-frame ::origin PEER-ID)] - (if (instance? FailureInfo exception) - (ex-info* (ex-message exception) (update (ex-data exception) ::trace conj stack-frame) (ex-id exception) (or (ex-cause exception) exception)) - (ex-info* (ex-message exception) {::trace [stack-frame]} exception)))) - -(defn concat-async-stacks [ex1 ex2] - (assert (instance? FailureInfo ex1)) - (assert (instance? FailureInfo ex2)) - (ex-info* (ex-message ex1) (update (ex-data ex1) ::trace into (::trace (ex-data ex2))) (or (ex-cause ex1) (ex-cause ex2) ex2))) - -(defn error - ([debug-info ^Failure failure] - (error debug-info failure nil)) - ([debug-info ^Failure failure ^FailureInfo context] - (let [err (.-error failure)] - (if (or (instance? Pending err) (instance? Cancelled err)) - failure - (Failure. (cond-> (add-stack-frame debug-info err) - (some? context) (concat-async-stacks context))))))) - -(tests "rewrapping keeps same ID" - (def ex (ex-info* "x" {})) - (ex-id ex) := (ex-id (add-stack-frame {} ex))) - (defn normalize-async-stack-frame [stack-frame] (let [meta (::meta stack-frame) dbg-in-meta (data/select-ns :hyperfiddle.electric.debug (::meta stack-frame))] @@ -72,68 +29,6 @@ (def fail? '#{hyperfiddle.electric.impl.runtime/fail}) -#_ (defn render-frame [frame] - (let [{::keys [remote file line macro scope type name params args meta]} frame] - (->> [" in" - (when remote "remote") - (when macro "macro") - (case scope - :lexical "lexically bound" - :dynamic "dynamically bound" - nil) - - (str/join " " - (case type - :apply (if (fail? name) - ["(throw ...)"] - ["call to" name]) - :eval (if (fail? (::fn frame)) - ["(throw ...)"] - (let [{::keys [action target method args]} frame] - (case action - :field-access ["(" (str ".-" method) target ")"] - :static-call [(str target "/" method)] - :call [(str target "." method)] - :fn-call (if (some? name) - `[(clojure.core/fn ~name [~@params] ~'...)] - `[(clojure.core/fn [~@params] ~'...)]) - #_else (let [f (or (::fn frame) (::ir/form frame) "")] - [(str "call to `" f "`")])))) - :reactive-fn ["reactive" (if (some? name) - `(~'fn ~name ~'...) - `(~'fn ~'...))] - :reactive-defn ["reactive" 'defn (str "`" name "`")] - :try ["(try ...)" ] - :catch [`(~'catch ~'...)] - :finally ["(finally ...)"] - :case-clause [`(~'case ~'...)] - :case-default ["case default branch"] - :transfer ["transfer to" (clojure.core/name name)] - :toggle ["transfer"] - `["" ~(::ir/op frame)] - )) - - (when file (str "in " file)) - (when line (str "line " line)) - ] - (remove nil?) - (str/join " ")))) - -;;; CLJS stack frames - -;; #?(:cljs -;; (defn- get-running-js-script-location [] -;; (let [canonical-frame (->> (.-stack (js/Error.)) -;; (str/split-lines) -;; (first) -;; (st/canonicalize)) -;; [_file url] (str/split canonical-frame #"\sat\s") -;; parsed-url (js/URL. url) -;; origin (.-origin parsed-url) -;; pathname (.-pathname parsed-url) -;; pathname-without-file (str/join "/" (butlast (str/split pathname #"/")))] -;; (str origin pathname-without-file)))) - (defn file->ns [file] (when file (when-let [match (second (re-find #"/?(.*)\..*$" (str file)))] @@ -200,26 +95,11 @@ ;;; ------- -(defn add-async-frames! [exception async-trace] - #?(:clj (let [exception (if (instance? hyperfiddle.electric.FailureInfo exception) (Throwable. (ex-message exception)) exception)] - (.setStackTrace ^Throwable exception (into-array StackTraceElement (concat (.getStackTrace exception) (render-async-stack-trace async-trace)))) - exception) - :cljs (set! (.-stack exception) (str (.-stack exception) "\n" (render-async-stack-trace async-trace))))) - - - - (defn unwrap [exception] (if (= ::trace (:hyperfiddle.electric/type (ex-data exception))) (or (ex-cause exception) exception) exception)) -(defn remove-async-stack-trace [ex] - (unwrap - (cond - (instance? ExceptionInfo ex) (ex-info (ex-message ex) (dissoc (ex-data ex) ::trace) (remove-async-stack-trace (ex-cause ex))) - (instance? FailureInfo ex) (ex-info* (ex-message ex) (dissoc (ex-data ex) ::trace) (remove-async-stack-trace (ex-cause ex))) - :else ex))) #?(:clj (defn stack-element-matches? [regex ^StackTraceElement elem] @@ -320,9 +200,3 @@ (map (fn [line] (str pad line))) (str/join "\n"))))) -(defn empty-client-exception [exception] - #?(:clj - (if (instance? FailureInfo exception) - (doto (Throwable. (ex-message exception)) - (.setStackTrace (into-array StackTraceElement []))) - exception))) diff --git a/src/hyperfiddle/electric/impl/analyzer.clj b/src/hyperfiddle/electric/impl/analyzer.clj deleted file mode 100644 index ec5c8b724..000000000 --- a/src/hyperfiddle/electric/impl/analyzer.clj +++ /dev/null @@ -1,193 +0,0 @@ -(ns hyperfiddle.electric.impl.analyzer - "Utilities to analyze and transform Clojure/Script code (not Electric code). - Use case: support `clojure.core/fn` in an Electric program. - Long term goal is to build a unified Clojure/Script code walker and get rid of tools.analyzer deps." - (:require [clojure.tools.analyzer.passes.jvm.emit-form :as emit-form] - [clojure.tools.analyzer.ast :as clj-ast] - [clojure.tools.analyzer.jvm :as clj] - [cljs.analyzer.api :as cljs] - [cljs.analyzer :as cljs-ana] - [cljs.analyzer.passes :as cljs-ast] - [clojure.tools.logging :as log])) - -(defn var-name [ast] - (if-let [var (:var ast)] - (.toSymbol ^clojure.lang.Var var) - (or (:name ast) - (:form ast)))) - -(defn walk-clj "Prewalk a clj ast" [ast f] (clj-ast/prewalk ast f)) -(defn walk-cljs "Prewalk a cljs ast" [ast f] (cljs-ast/walk ast [(fn [env ast opts] (f ast))])) - -(defn macroexpand-1-clj - ;; like clj/macroexpand-1 except: - ;; - doesn't inline - not needed - ;; - drop tags - not needed and can cause issues in emitted code (Class object in cljs compiler) - ;; - *env* is not ensured - expensive to compute and not needed in this context - "If form represents a macro form, returns its expansion, else returns form." - ([form] (macroexpand-1-clj form (clj/empty-env))) - ([form env] - (cond - (seq? form) - (let [[op & args] form] - (if (clj/specials op) - form - (let [v (clojure.tools.analyzer.utils/resolve-sym op env) - m (meta v) - local? (-> env :locals (get op)) - macro? (and (not local?) (:macro m))] ; locals shadow macros - (cond - macro? (let [res (apply v form (:locals env) (rest form))] ; (m &form &env & args) - (when-not (clj/ns-safe-macro v) - (clj/update-ns-map!)) - (if (clojure.tools.analyzer.utils/obj? res) - (vary-meta res merge (meta form)) - res)) - :else (clj/desugar-host-expr form env))))) - (symbol? form) (clj/desugar-symbol form env) - :else form))) - -(defn analyze-clj "Analyze a clj form to ast without any passes." [env form] - (binding [clj/run-passes identity] - (clj/analyze form env {:bindings {#'clojure.tools.analyzer/macroexpand-1 macroexpand-1-clj}}))) - -(defn analyze-cljs "Analyze a cljs form to ast without any passes." [env form] - (binding [cljs-ana/*cljs-ns* (:name (:ns env)) - cljs-ana/*passes* []] - (cljs/analyze env form #_#_nil {:warning-handlers [(fn [type env info] (prn type))]}))) - -(defn specialize-clj-ast-op [ast] - (update ast :op (fn [op] (case op - :const ::const - op)))) -(defn emit-clj [ast] - (emit-form/emit-form (walk-clj ast specialize-clj-ast-op))) - -(defmethod emit-form/-emit-form ::const - [{:keys [type val] :as ast} opts] - (if (= type :class) - (symbol (.getName ^Class val)) - (emit-form/-emit-form (assoc ast :op :const) opts))) - - -(declare emit-cljs) -(defn emit-cljs-method [{:keys [variadic? params body]}] - (list (if variadic? - (-> (into [] (map :name) (pop params)) - (conj '& (-> params peek :name))) - (into [] (map :name) params)) (emit-cljs body))) - -;; Adapted from leonoel/injure -(defn emit-cljs "Emit cljs code from a cljs.analyzer AST." - [ast] - (case (:op ast) - :let - (list 'let (into [] (mapcat - (fn [{:keys [name init]}] - [name (emit-cljs init)])) - (:bindings ast)) - (emit-cljs (:body ast))) - - :loop - (list 'loop (into [] (mapcat - (fn [{:keys [name init]}] - [name (emit-cljs init)])) - (:bindings ast)) - (emit-cljs (:body ast))) - - :recur - (cons 'recur (map emit-cljs (:exprs ast))) - - :invoke - (map emit-cljs (cons (:fn ast) (:args ast))) - - :fn - (cons 'cljs.core/fn (concat (when-some [l (:local ast)] [(:name l)]) - (map emit-cljs-method (:methods ast)))) - - :letfn - (list 'letfn (into [] (map (fn [{:keys [name init]}] - (cons name (map emit-cljs-method (:methods init))))) - (:bindings ast)) - (emit-cljs (:body ast))) - - :try - `(~'try ~(emit-cljs (:body ast)) - ~@(when-not (= :throw (:op (:catch ast))) - (let [name (get-in ast [:name])] - [(list 'catch :default name (emit-cljs (:catch ast)))])) - ~@(when-some [f (:finally ast)] - [(list 'finally (emit-cljs f))])) - - :throw - (list 'throw (emit-cljs (:exception ast))) - - :new - (cons 'new (map emit-cljs (cons (:class ast) (:args ast)))) - - :def - (list 'def (emit-cljs (:var ast)) (emit-cljs (:init ast))) - - :set! - (list 'set! (emit-cljs (:target ast)) (emit-cljs (:val ast))) - - :js - (list* 'js* (or (:code ast) (apply str (interpose "~{}" (:segs ast)))) (map emit-cljs (:args ast))) - - :do - (cons 'do (conj (mapv emit-cljs (:statements ast)) (emit-cljs (:ret ast)))) - - :map - (zipmap (map emit-cljs (:keys ast)) (map emit-cljs (:vals ast))) - - :set - (into #{} (map emit-cljs) (:items ast)) - - (:vec :vector) - (into [] (map emit-cljs) (:items ast)) - - :list `(list ~@ (map emit-cljs (:items ast))) - - :js-array `(cljs.core/array ~@(map emit-cljs (:items ast))) - :js-object `(cljs.core/js-obj ~@(interleave (:keys ast) (map emit-cljs (:vals ast)))) - - :if - (list 'if (emit-cljs (:test ast)) (emit-cljs (:then ast)) (emit-cljs (:else ast))) - - :case - (list* 'case (emit-cljs (:test ast)) - (-> [] - (into (mapcat (fn [{:keys [tests then]}] - [(map :form tests) (emit-cljs (:then then))])) - (:nodes ast)) - (conj (emit-cljs (:default ast))))) - - :host-field - (list '. (emit-cljs (:target ast)) (symbol (str "-" (name (:field ast))))) - - :host-call - (list* '. (emit-cljs (:target ast)) (:method ast) (map emit-cljs (:args ast))) - - :with-meta `(with-meta ~(emit-cljs (:expr ast)) ~(emit-cljs (:meta ast))) - - :the-var `(var ~(-> ast :var :form)) - (:js-var :var :local :const :quote) (:form ast) - - - ;; :binding ; Handled in let and fn - - ;; :case-node ; Handled in :case - ;; :case-test - ;; :case-then - - ;; :fn-method ; Handled in fn - - ;; :no-op ; Unknown use case - - ;; :defrecord ; Won’t be supported - ;; :ns - ;; :ns* - - - (do (clojure.tools.logging/warn "This cljs form is not supported yet. Please log a ticket." {:op (:op ast) :form (:form ast)}) - (:form ast)))) diff --git a/src/hyperfiddle/electric/impl/array_fields.cljc b/src/hyperfiddle/electric/impl/array_fields.cljc deleted file mode 100644 index 4e35ed8a1..000000000 --- a/src/hyperfiddle/electric/impl/array_fields.cljc +++ /dev/null @@ -1,44 +0,0 @@ -(ns hyperfiddle.electric.impl.array-fields - (:refer-clojure :exclude [get set]) - #?(:cljs (:require-macros hyperfiddle.electric.impl.array-fields)) - (:require [hyperfiddle.rcf :as rcf :refer [tests]])) -;; #?(:clj (set! *warn-on-reflection* true)) -(defmacro deffields [& fields] - `(do ~@(for [[fld idx] (mapv vector fields (range))] - `(def ~fld (int ~idx))))) -(defn swap - ([^objects a k f] (aset a k (f (aget a k)))) - ([^objects a k f x] (aset a k (f (aget a k) x))) - ([^objects a k f x y] (aset a k (f (aget a k) x y))) - ([^objects a k f x y z] (aset a k (f (aget a k) x y z))) - ([^objects a k f x y z & more] (aset a k (apply f (aget a k) x y z more)))) -(defmacro fswap [O k f & args] `(swap (.-state- ~O) ~k ~f ~@args)) -(defn get [^objects a k] (aget a k)) -(defmacro fget [O k] `(get (.-state- ~O) ~k)) -(defmacro set [arr & kvs] - (let [ar (with-meta (gensym "arr") {:tag 'objects})] - `(let [~ar ~arr] - ~@(for [[k v] (partition 2 kvs)] - ;; FIXME better way to fix reflection warning than call `identity`? - `(aset ~ar ~k (identity ~v)))))) -(defmacro fset [O & kvs] `(set (.-state- ~O) ~@kvs)) -(defn getset [^objects a k v] (let [ret (aget a k)] (aset a k v) ret)) -(defmacro fgetset [O k v] `(getset (.-state- ~O) ~k ~v)) -(defn getswap [^objects a k f] (let [ret (aget a k)] (swap a k f) ret)) - -;;; TESTS ;;; -(deftype P [state-]) -(tests - (deffields x y) - (def aP (->P (object-array 2))) - (let [^P aP aP] - (fset aP x 1 y 2) := 2 - [(fget aP x) (fget aP y)] := [1 2] - (fswap aP x inc) := 2 - (swap (.-state- aP) x inc) := 3 - (fgetset aP x 0) := 3 - (getset (.-state- aP) x 100) := 0 - (fget aP x) := 100 - (getswap (.-state- aP) x inc) := 100 - (fget aP x) := 101 - )) diff --git a/src/hyperfiddle/electric/impl/cljs_analyzer2.clj b/src/hyperfiddle/electric/impl/cljs_analyzer2.clj new file mode 100644 index 000000000..314a42448 --- /dev/null +++ b/src/hyperfiddle/electric/impl/cljs_analyzer2.clj @@ -0,0 +1,296 @@ +(ns hyperfiddle.electric.impl.cljs-analyzer2 + (:refer-clojure :exclude [find-var]) + (:require [cljs.analyzer] + [cljs.core] ; for cljs macroexpansion + [cljs.env] + [cljs.repl] + [cljs.tagged-literals] + [clojure.core :as cc] + [clojure.java.io :as io] + [clojure.string :as str] + [clojure.tools.reader.reader-types :as rt] + [contrib.assert :as ca] + [edamame.core :as ed] ; for cljs macroexpansion + [clojure.walk :as walk])) + +(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"))))) + +(defn eval-edamame-read-eval + "Edamame, an edn parser, doesn't fully implement read-eval (aka `#=`). + Edamame expands `#=(foo bar)` to `(edamame.core/read-eval (foo bar))` and + leave the actual eval action's responsibility to the user - + `edamame.core/read-eval` does not resolve to any var. + + The current function takes an edamame-parsed form, walk it and eval parsed #= + forms. Edamame must be invoked with `{:read-eval true, :quote true}` options + to produce a form we can properly eval. + + Doesn't preserve read-time metadata. We don't care about metadata in this + specific case, because we only use this to read ns forms and we are not aware + of any use case for metadata in ns forms applying to Electric" + [form] + (walk/prewalk + (fn [form] (if (and (seq? form) (= 'edamame.core/read-eval (first form))) (eval (second form)) form)) + form)) + +(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, :read-eval true, :quote true, :eof ::done})] + (defn resource-forms [rs] + (with-open [rdr (rt/source-logging-push-back-reader (io/reader rs))] + (loop [v []] + (let [nx (eval-edamame-read-eval (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 _) + (catch Throwable t ; HACK temporary fix. Electric tries to load `.cljc` files assuming it contains clojure code, but fails for cljc files only targeting multip cljs targets (e.g. nextjournal.clojure-mode.util targets :squint + :cljs) + ; Ignoring the failed require seems harmless. Log to keep an eye on it and detect more failing cases. + (print `safe-require "Electric failed to load ns for" sym ":" (ex-message t)))))) + +(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-, cljs.spec.alpha/def} + 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.electric3/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 (try (apply mac o env args) + (catch Throwable e (prn :cannot-expand (::ns-stack env) (cons mac args)) (throw e))))) + 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$ env 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$ env reqk refk [cljs$ :as req$]) + cljs$))))) + +(defn add-requireT [!a ns$ env 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$ env 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 (assoc env :ns {:name ns$}) #_(->cljs-env ns$) req$) + (when (:refer-macros o) + (add-requireT !a ns$ env reqk refk + (into [req$] cat (-> (select-keys o [:as]) (assoc :refer (:refer-macros o)))))))))) + +(defn -add-requiresT [!a ns$ env rs reqk refk] + (run! #(add-requireT !a ns$ env reqk refk %) rs)) + +(defn add-require-macrosT [!a ns$ env rs] (-add-requiresT !a ns$ env rs ::require-macros ::refer-macros)) +(defn add-requiresT [!a ns$ env rs] (-add-requiresT !a ns$ env 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)))))) + +(letfn [(simple [v] (-> v str (str/split #"\.") peek symbol))] + (defn add-1-import [ns$ a v] + (let [add (fn add [a v] (update-in a [::nses ns$ ::imports] (fnil conj #{}) v (simple v)))] + (if (symbol? v) + (add a v) ; java.util.X + (if (next v) ; [java.util X Y] + (reduce (fn [a nx] (add a (mksym (first v) "." nx))) a (next v)) + (add a (first v))))))) ; [java.util.X] + +(defn add-import [!a ns$ args] + (swap! !a (fn [a] (reduce (partial add-1-import ns$) a args)))) + +(defn add-ns-infoT [!a env [_ns ns$ & args]] + (let [args (-> args skip-docstring skip-attr-map)] + (run! (fn [[typ & args]] + (case typ + (:require) (add-requiresT !a ns$ env args) + (:require-macros) (add-require-macrosT !a ns$ env args) + (:use) (add-requiresT !a ns$ env (mapv use->require args)) + (:use-macros) (add-require-macrosT !a ns$ env (mapv use->require args)) + (:refer-clojure) (add-refer-clojure !a ns$ args) + (:import) (add-import !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 env 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$] + (ca/is ns$ (complement #{'hyperfiddle.electric}) "cannot analyze old electric code") + (when-some [rs (some-> ns$ ns->resource)] + (let [env (update env ::ns-stack (fnil conj []) ns$)] + (try (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)))) + (catch Throwable e + (prn :failed-to-analyze (::ns-stack env)) + (throw e)))))) + +(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$))] + (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$))] + (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)))) + +(defn ns-qualify [a sym ns$] + (when-some [qual-ns (keep-if (-> a ::nses (get ns$) ::requires (get (-> sym namespace symbol))) symbol?)] + (symbol (str qual-ns) (name sym)))) + +(def implicit-nses '#{goog goog.object goog.string goog.array Math String}) + +(defn imported? [a sym ns$] + (let [imports (into implicit-nses (-> a ::nses (get ns$) ::imports)) + dot-access (-> sym str (str/replace #"\.[^.]+$" "") symbol)] + (or (get imports dot-access) + (and (qualified-symbol? sym) (get imports (-> sym namespace symbol)))))) + +(defn referred? [a sym ns$] (-> a ::nses (get ns$) ::refers (get sym))) diff --git a/src/hyperfiddle/electric/impl/destructure.cljc b/src/hyperfiddle/electric/impl/destructure.cljc new file mode 100644 index 000000000..8cd035ef5 --- /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.runtime3 :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/env.clj b/src/hyperfiddle/electric/impl/env.clj deleted file mode 100644 index 44f6c7ee3..000000000 --- a/src/hyperfiddle/electric/impl/env.clj +++ /dev/null @@ -1,471 +0,0 @@ -(ns hyperfiddle.electric.impl.env - "Logic to resolve cljs or clj vars (and macros) and to reload source files in dev mode." - (:require [clojure.string :as str] - [clojure.java.io :as io] - [clojure.tools.logging :as log] - [cljs.analyzer :as cljs] - [cljs.env :as env] - [cljs.tagged-literals :as cljs-tags] - [hyperfiddle.rcf :refer [tests]] - [hyperfiddle.electric.impl.compiler :as-alias c]) - (:import (clojure.lang Var) - (java.io FileNotFoundException))) - -;; Dedicated namespace because: -;; - used by both electric compiler and HFQL -;; - non trivial logic which requires the reader to load all the knowledge in their mind -;; Many moving parts which are easier to think about in isolation. -;; Used to be inlined in the compiler namespace - required a lot of scrolling and navigation. - - -;; About ShadowCljs and Hot Code reloading: - -;; By design, shadow recompiles and reload: -;; - the current saved file -;; - all direct dependents of the saved file -;; Shadow does not recompile all transitive dependents by default. - -;; Shadow has a setting `:devtools {:reload-strategy :full}` which will -;; recompile and reload all transitive dependents. -;; https://code.thheller.com/blog/shadow-cljs/2019/08/25/hot-reload-in-clojurescript.html#recompile-logic - -;; This actually doesn’t help us because: -;; - we are custom compiler inside of the cljs compiler compilation phase -;; - we want the current ns to recompile -;; - we want the compiler entrypoint to recompile (and rerun the electric compiler) -;; - recompiling namespaces in between the current ns and the entrypoint won’t impact the compilation. - -;; This is why we need ^:dev/always on the compiler entrypoint. - - - -;; Why did we use to need :require-macros on every namespace? - -;; There are two independent memory environments: -;; - Clojure environnement — result of eval at the REPL -;; - ClojureScript compiler environnement — result of running the CLJS compiler on the codebase - - -;; Given this program: -;; ``` ; foo.cljc -;; (ns foo) ; note: not using a (comment …) form for this example, ns form confuses clj-kondo -;; (def bar 1) -;; ``` - -;; - If loaded at the REPL, will create a `foo` ns and a `bar` var in the Clojure environnement. -;; - If compiled by CLJS compiler, will create a `foo` ns and a `bar` var in the CLJS compiler environment. - - -;; The following program will create `foo` and `bar` in both environments. There -;; will be two `foo` and two `bar`. - -;; ``` ; foo.cljc -;; (ns foo #?(:cljs (:require-macros [foo]))) -;; (def bar 1) -;; ``` - -;; => The electric compiler always resolves vars on the peer defined by -;; `e/client` or `e/server`. But `e/def` is a special case and should be -;; resolved in either environnement no matter the peer. - - -;; When a e/server block is analyzed, it resolves symbols to check if they are -;; macros or e/defs. Vars needs to be loaded in the Clojure Environnement JVM -;; side to be resolvable. :require-macros trigger a clojure `require -;; ns :reload`, loading vars into the Clojure environnement. Instead of -;; requiring users to write :require-macros in every ns, the electric compiler -;; can call `require` just before resolving a var in a clojure ns. This -;; requiring strategy only requires the ns if necessary (if the corresponding -;; source file has been touched). - - -;; How to resolve an alias: -;; - Server -;; - try to resolve a clj alias definition (might be behind a #?:clj flag) -;; - this requires loading the current clj namespace -;; - try to resolve a cljs alias (we might be in cljs file within an e/server block) -;; - try to resolve a cljs macro alias (require-macros) -;; - Client -;; - try to resolve a cljs alias -;; - try to resolve a cljs macro alias (require-macros) - - -;; How to resolve a var: -;; - Server -;; - try to resolve a cljs macro var -;; - if macro found in cljs compiler state, return macro var -;; - only if it’s not a twin var -;; - otherwise -;; - resolve symbol alias based on -;; - cljs compiler current ns info -;; - if not found, retry based ond resolved current clojure namespace -;; - find target ns fully qualified name -;; - call `(require target-ns :reload)` if necessary -;; - find var in target ns -;; - Client -;; - try to resolve symbol in cljs compiler state -;; - otherwise, try to resolve a macro var in cljs compiler state -;; - if var is a local binding var (yes this exists), return nil -;; - try to find a twin clojure var (e.g. inc) -;; - if it exists, return it (why is it needed) -;; - otherwise return current found var - - -;; How to resolve a runtime symbol: -;; - Server -;; - resolve the var -;; - if var is a macro, or an e/def -> return nil -;; - otherwise return the fully qualified var name -;; - Client -;; - if it resolves to a cljs var or clj class -;; - return the fully qualified symbols -;; - if it resolves to a clj var (twin var) -;; - return the cljs var (not twin clj var) fully qualified name - - -;; GG: Abstraction on resolved vars. -;; A symbol may resolve to: -;; - nil -;; - a cljs var description (a map) -;; - a cljs macro var description (a map) -;; - a clojure var (clojure.lang.Var) -;; - which can be a twin of a cljs var (e.g. cljs.core/inc has two versions: a cljs runtime function and a clj macro) -;; - a JVM Class -(defprotocol IVar - (get-var [this]) - (var-name [this]) - (var-meta [this]) - (is-macro [this]) - (is-node [this])) - -(defprotocol ICLJSTwinVar (is-twin [this])) - -(deftype CljVar [var twin?] - IVar - (get-var [_this] var) - (var-name [_this] (let [m (meta var)] (symbol (name (ns-name (:ns m))) (name (:name m))))) - (var-meta [_this] (meta var)) - (is-macro [_this] (.isMacro ^Var var)) - (is-node [this] (contains? (var-meta this) ::c/node)) - ICLJSTwinVar - (is-twin [_this] twin?)) - -(deftype CljsVar [var] - IVar - (get-var [_this] var) - (var-name [_this] (:name var)) - (var-meta [_this] (:meta var)) - (is-macro [this] (:macro (or (var-meta this) var))) - (is-node [this] (contains? (or (var-meta this) var) ::c/node))) - -(deftype CljClass [klass] - IVar - (get-var [_this] klass) - (var-name [_this] (symbol (.getName ^Class klass))) - (var-meta [_this] nil) - (is-macro [_this] false) - (is-node [_this] false)) - -(defn resolve-ns - "Builds a description of a namespace. Returns nil if no namespace can be found for the given symbol. - Does not compute `:interns` because it’s expensive and the Electric compiler - cannot cache it. Use `find-interned-var` to lookup for interns." - ;; `ns-interns` is a filter over `ns-map` (a huge map) while `find-interned-var` is a direct lookup. - [ns-sym] - (when-let [ns (find-ns ns-sym)] - {:mappings (assoc (ns-map ns) - 'in-ns #'clojure.core/in-ns - 'ns #'clojure.core/ns) - :aliases (reduce-kv (fn [a k v] (assoc a k (ns-name v))) - {} (ns-aliases ns)) - :ns (ns-name ns)})) - -(defn ns-filename "Given a symbol identifying a namespace, return the corresponding file path" - [sym] - (-> (name sym) - (str/replace #"\." "/") - (str/replace #"-" "_"))) - -(defn find-file [relative-path] - (when-let [res (io/resource relative-path)] - (try (io/file res) - (catch IllegalArgumentException _ - ;; resource is not a file on the classpath. E.g. jar:// sources are - ;; not files. We also don’t want to reload them. - nil)))) - -(defn resolve-file - "Resolve a source file from namespace symbol. - Precedence: - - cljc, - - cljs if we are compiling clojurescript, - - clj otherwise." - [env ns-sym] - (let [file-name (ns-filename ns-sym) - cljc (find-file (str file-name ".cljc")) - clj (find-file (str file-name ".clj")) - cljs (find-file (str file-name ".cljs"))] - (if (and cljc (.exists cljc)) - cljc - (if (:js-globals env) - (when (and cljs (.exists cljs)) - cljs) - (when (and clj (.exists clj)) - clj))))) - -(defn file-timestamp [^java.io.File file] (when (some? file) (.lastModified file))) -(defn file-extension [^java.io.File file] (when (some? file) (peek (str/split (.getName file) #"\.")))) - -(def !macro-load-cache (atom {})) ; records the last time a source file was loaded - -(defn load-ns! [ns-sym & args] - (try (binding [*data-readers* cljs-tags/*cljs-data-readers*] (apply require ns-sym args)) ; will throw if source code is invalid CLJ(C) - (catch FileNotFoundException _) ; Some namespaces don’t map to files (e.g. Math) - (catch Throwable e ; TODO improve error messages - (log/warn e "Failed to load" ns-sym)))) - -(defn maybe-load-clj-ns! [env ns-sym] - (when-not (re-find #"^hyperfiddle\.electric" (str ns-sym)) ; electric doesn't reload itself - (let [last-loaded (get-in @!macro-load-cache [ns-sym ::last-loaded])] - (if (find-ns ns-sym) ; ns is already loaded on JVM? - (when-let [file (resolve-file env ns-sym)] ; if source is in userland - (when (not= "cljs" (file-extension file)) ; cljs files are not reloadable, homonym reloading is handled by shadow with :require-macros - (let [current-timestamp (file-timestamp file)] - (if (some? last-loaded) - (when (< last-loaded current-timestamp) ; source is newer - (log/debug "reloading" ns-sym) - (load-ns! ns-sym :reload)) - (when (empty? (ns-interns (find-ns ns-sym))) ; FIXME support macros defined in cljs (no need to load corresponding clj ns if cljs macro is available in cljs space) - (log/trace "initial load" ns-sym) - (load-ns! ns-sym))) - (swap! !macro-load-cache assoc-in [ns-sym ::last-loaded] current-timestamp)))) - ;; ns is not loaded - (if-let [file (resolve-file env ns-sym)] ; try to load it from userland source - (when-not (= "cljs" (file-extension file)) ; cljs files are not loadable on the JVM - (let [current-timestamp (file-timestamp file)] - (log/trace "loading source" ns-sym) - (load-ns! ns-sym) - (swap! !macro-load-cache assoc-in [ns-sym ::last-loaded] current-timestamp))) - (do (log/trace "loading external" ns-sym) ; maybe ns-sym refers to a library - (load-ns! ns-sym))))))) - -(defn peer-language - "Given a compiler environment, return :clj or :cljs, according to the peer-config map (set by `e/boot`)" - [env] - (case (::c/local env) - (true nil) (get-in env [::c/peers-config ::c/local]) - false (get-in env [::c/peers-config ::c/remote]))) - -(defn resolve-clj-alias - "Given a symbol, resolve it to a fully qualified symbol according to the current ns definition in `env`." - [env sym] - (if (simple-symbol? sym) sym - (let [ns-sym (if (:js-globals env) (:name (:ns env)) (:ns env))] - (maybe-load-clj-ns! env ns-sym) ; can only resolve a clj alias if the namespace is loaded - (as-> sym $ - (symbol (namespace $)) ; extract namespace part of sym - (get-in (resolve-ns ns-sym) [:aliases $] $) ; expand to fully qualified form - (symbol (str $) (name sym)) - (with-meta $ (meta sym)) - )))) - -(defn resolve-alias "Expand a qualified symbol to its fully qualified form, according to ns aliases." - [env sym] - (case (peer-language env) - :clj (resolve-clj-alias env sym) - :cljs (or (cljs/resolve-ns-alias env sym) (cljs/resolve-macro-ns-alias env sym)))) - -(defn is-cljs-file? [env] (and (:js-globals env) (some-> env :ns :meta :file (str/ends-with? ".cljs")))) - -(defmacro no-warn - "Localy disable a set of cljs compiler warning. - Usage: `(no-warn #{:undeclared-ns} (cljs/resolve env sym))`" - [disabled-warnings & body] - `(binding [cljs/*cljs-warnings* (reduce (fn [r# k#] (assoc r# k# false)) cljs/*cljs-warnings* ~disabled-warnings)] - ~@body)) - -(defn resolve-cljs-var ; GG: adapted from cljs.analyzer.api/resolve, return an IVar. - "Given an analysis environment resolve a var. Analogous to - clojure.core/resolve" - [env sym] - {:pre [(map? env) (symbol? sym)]} - ;; First try to resolve a cljs var, then fallback to resolving a cljs macro var - (when (:js-globals env) - (let [!found? (volatile! true) - ns-sym (:name (:ns env)) - var (when-some [ns (find-ns ns-sym)] - (binding [cljs/*private-var-access-nowarn* true] - (let [klass (clojure.lang.Compiler/maybeResolveIn ns sym)] - (if (class? klass) - (CljClass. klass) - (CljsVar. (no-warn #{:undeclared-ns} (cljs/resolve-var env sym - (fn confirm [env prefix suffix] - (cljs/confirm-var-exists env prefix suffix - (fn missiing-fn [_env _prefix _suffix] - (vreset! !found? false)))))))))))] - (if (and @!found? var) - (if (instance? CljClass var) - var - (cond - (= :local (:op (get-var var))) - (when (cljs/dotted-symbol? sym) ; ignore lexical bindings except dotted symbols - (let [[prefix suffix] (str/split (str sym) #"\." 2)] - (when-some [full-ns (get-in (:ns env) [:imports (symbol prefix)])] - ;; `var` resolved to e.g. {:op :local, :name goog.events.EventType/CLICK} - ;; which is wrong, the name should have .CLICK not /CLICK - ;; Also not sure why shadow-cljs sets :op to :local when cljs analyzer sets it to :var. - ;; Nevertheless both seem to work in this case - ;; https://github.com/thheller/shadow-cljs/blob/faab284fe45b04328639718583a7d70feb613d26/src/main/shadow/build/cljs_hacks.cljc#L308 - ;; https://github.com/clojure/clojurescript/blob/r1.11.60/src/main/clojure/cljs/analyzer.cljc#L1298 - (CljsVar. {:op :local, :name (symbol (str full-ns "." suffix))})))) - - ;; If the symbol is unqualified, the var will resolve in current ns. - ;; The returned value could therefor describe - ;; a :use, :refer, :use-macro, :refer-macro, or :rename. This var - ;; description would only contain the var :name and :ns, missing all - ;; other var info - especially if it is a macro or not. In this case, - ;; we resolve the var again, using the fully qualified name. This - ;; ensures the returned var definition includes all info about the - ;; var. - (and (simple-symbol? sym) (not= ns-sym (namespace (var-name var)))) - (resolve-cljs-var env (var-name var)) - - :else var)) - (when-some [v (cljs/resolve-macro-var env sym)] - (CljsVar. v)))))) - -(defn resolve-cljs - "Resolve a cljs var, which can be either - - a regular cljs var (a map) - - a cljs macro var (a map) - - a cljs twin var (e.g. cljs.core/inc)" - ([env sym] (resolve-cljs env sym true)) - ([env sym include-potential-twin-var?] - (when (:js-globals env) - (let [var (resolve-cljs-var env sym)] ; resolve cljs var decription (a map) - (if-not include-potential-twin-var? - var - (if-let [expander (cljs/get-expander (if (some? var) (var-name var) sym) env)] ; find corresponding clojure var - (CljVar. expander true) ; mark this clj var as a twin - var)))))) - -(defn find-interned-var - "Look up for an interned var in a namespace. Efficient direct lookup." - [^clojure.lang.Namespace ns var-sym] - (let [^clojure.lang.Symbol var-name (if (simple-symbol? var-sym) var-sym (symbol (name var-sym)))] - (.findInternedVar ns var-name))) - -(defn clj-env "Given a cljs compiler env, return a clojure compiler compatible env." - [?cljs-env] - (if (:js-globals ?cljs-env) - (-> ?cljs-env (dissoc :js-globals) (assoc :ns (:name (:ns ?cljs-env)))) - ?cljs-env)) - -(defn resolve-clj-var [env sym] - (if (is-cljs-file? env) - (throw (ex-info "Cannot resolve a Clojure expression from a cljs namespace. Use a .cljc file." {:file (:file (:meta (:ns env)))})) ; TODO is this constraint still up to date? - (let [clj-env (clj-env env) - resolved (if (simple-symbol? sym) - (do (maybe-load-clj-ns! env (:ns clj-env)) - (get-in (resolve-ns (:ns clj-env)) [:mappings sym])) ; resolve in current clj ns - (let [full-ns-sym (resolve-alias env sym) ; expand alias - ns (symbol (namespace full-ns-sym)) - nom (symbol (name full-ns-sym))] - (maybe-load-clj-ns! env ns) - (when-some [clj-ns (find-ns ns)] ; resolve in target ns - (find-interned-var clj-ns nom))))] - (if (some? resolved) - (cond (var? resolved) (CljVar. resolved false) - (class? resolved) (CljClass. resolved) - :else (throw (ex-info "Symbol resolved to an unknow type" {:symbol sym - :type (type resolved) - :value resolved}))) - ;; java.lang is implicit so not listed in ns form or env - (when-some [resolved (clojure.lang.Compiler/maybeResolveIn (the-ns (:ns clj-env)) sym)] - (CljClass. resolved)))))) - -(defn resolve-var - "Given an environment and a symbol, resolve the var." - [env sym] - (case (peer-language env) - ;; Critical to understand: e/defs and macros are already resolved by the cljs compiler. - ;; If we are on the server and there is a suitable cljs var definition available, we use it. - ;; otherwise we fallback to loading the clojure namespace and resolves into it. - ;; This is what saves us from :require-macros everywhere. - :clj (let [cljs-resolved-var (resolve-cljs env sym)] - (if (and (some? cljs-resolved-var) - (instance? CljVar cljs-resolved-var) ; if the resolved var is actually a clojure var and is not a twin, it means it’s a regular macro or an e/def. - (not (is-twin cljs-resolved-var))) - cljs-resolved-var - (resolve-clj-var env sym))) - :cljs (resolve-cljs env sym))) - -(defn resolve-runtime - "Returns the fully qualified symbol of the var resolved by given symbol at runtime, or nil if: - - it cannot be resolved, - - it doesn't exist at runtime (is a macro), - - sym is a special form." - [env sym] - (letfn [(runtime-symbol [var] (when (some? var) - (when-not (or (is-macro var) (is-node var)) - (with-meta (var-name var) (meta sym)))))] - (case (peer-language env) - :clj (runtime-symbol (resolve-var env sym)) - :cljs (if-let [v (resolve-var env sym)] - (cond (instance? CljsVar v) (runtime-symbol v) - (instance? CljClass v) (runtime-symbol v) - ;; GG: if sym resolves to a clojure var, look up for the cljs-specific version. - ;; Why: some vars exist in two versions (e.g. cljs.core/inc) - ;; - the cljs version is a function (available at runtime), - ;; - the clj version is a macro expending to optimized code (compile-time only, AKA a twin var). - ;; The twin doesn’t exists at runtime. - (instance? CljVar v) (runtime-symbol (resolve-cljs env sym false))) - ;; GG: corner case: there is no var for cljs.core/unquote-splicing. - (when (= 'cljs.core/unquote-splicing (:name (cljs/resolve-var env sym))) - 'cljs.core/unquote-splicing))))) - -(defn normalize-env "Given a cljs or clj compiler env, normalizes it into an electric compiler env" - [env] - (let [peers-config (or (::c/peers-config env) (if (:js-globals env) {::c/local :cljs, ::c/remote :cljs} {::c/local :clj, ::c/remote :clj}))] - (if (:js-globals env) - (assoc env ::c/peers-config peers-config) - {:ns (ns-name *ns*) - :locals (dissoc env ::c/peers-config) - ::c/peers-config peers-config}))) - -(tests - "Var resolution" - ;; resolve on the default peer (local) with default compiler env (clj) - (-> (normalize-env {}) - (resolve-var 'inc) - get-var) - := #'clojure.core/inc - - (-> (normalize-env {}) - (resolve-var 'java.lang.Integer) - get-var) - := java.lang.Integer - - (require 'cljs.core) - ;; resolve on the local (cljs) peer - (binding [cljs.env/*compiler* (cljs.env/default-compiler-env)] - (-> (cljs.analyzer/empty-env) - (assoc ::c/peers-config {::c/local :cljs ::c/remote :clj}) - (normalize-env) - (assoc ::c/local true) ; set current peer to local - (resolve-var 'inc) - get-var)) - := (resolve 'cljs.core/inc) - - - ;; resolve on the remote (clj) peer - (binding [cljs.env/*compiler* (cljs.env/default-compiler-env)] - (-> (cljs.analyzer/empty-env) - (assoc-in [:ns :name] (ns-name *ns*)) ; default cljs ns is cljs.user, which is not a thing. - (assoc ::c/peers-config {::c/local :cljs ::c/remote :clj}) - (normalize-env) - (assoc ::c/local false) ; set current peer to remote - (resolve-var 'inc) - get-var)) - := #'clojure.core/inc - ) diff --git a/src/hyperfiddle/electric/impl/eventually.cljc b/src/hyperfiddle/electric/impl/eventually.cljc deleted file mode 100644 index f3edbb5fe..000000000 --- a/src/hyperfiddle/electric/impl/eventually.cljc +++ /dev/null @@ -1,37 +0,0 @@ -(ns hyperfiddle.electric.impl.eventually - #?(:clj (:import (clojure.lang IFn IDeref)))) - -(deftype It [final notifier terminator ^objects state] - IFn - (#?(:clj invoke :cljs -invoke) [_] - ((aget state (int 0)))) - IDeref - (#?(:clj deref :cljs -deref) [it] - (locking it - (if (nil? (aget state (int 1))) - (do (terminator) final) - (try (aset state (int 1) nil) - (let [x @(aget state (int 0))] - (if (nil? (aget state (int 1))) - (aset state (int 1) notifier) - (do (aset state (int 1) nil) - (notifier))) x) - (catch #?(:clj Throwable :cljs :default) e - (if (nil? (aget state (int 1))) - (aset state (int 1) terminator) - (do (aset state (int 1) nil) - (terminator))) (throw e))))))) - -(defn eventually " -Returns a flow producing successive values of given flow, followed by given value if it terminates successfully. -" [x f] - (fn [n t] - (let [state (object-array 2) - it (->It x n t state)] - (locking it - (aset state (int 1) n) - (aset state (int 0) - (f n #(locking it - (if-some [cb (aget state (int 1))] - (do (aset state (int 1) nil) (cb)) - (aset state (int 1) it))))) it)))) \ No newline at end of file diff --git a/src/hyperfiddle/electric/impl/failer.cljc b/src/hyperfiddle/electric/impl/failer.cljc deleted file mode 100644 index 508e4bfde..000000000 --- a/src/hyperfiddle/electric/impl/failer.cljc +++ /dev/null @@ -1,7 +0,0 @@ -(ns hyperfiddle.electric.impl.failer - #?(:clj (:import (clojure.lang IDeref IFn)))) - -(defn run [e n t] - (n) (reify - IFn (#?(:clj invoke :cljs -invoke) [_]) - IDeref (#?(:clj deref :cljs -deref) [_] (t) (throw e)))) \ No newline at end of file diff --git a/src/hyperfiddle/electric/impl/for.cljc b/src/hyperfiddle/electric/impl/for.cljc deleted file mode 100644 index 534a16e96..000000000 --- a/src/hyperfiddle/electric/impl/for.cljc +++ /dev/null @@ -1,268 +0,0 @@ -(ns hyperfiddle.electric.impl.for - (:require [hyperfiddle.electric.impl.gather :refer [gather]] - [hyperfiddle.electric.impl.eventually :refer [eventually]] - [hyperfiddle.electric.impl.runtime :as r] - [missionary.core :as m] - [hyperfiddle.rcf :refer [tests]] - [clojure.string :as str]) - (:import missionary.Cancelled - hyperfiddle.electric.Failure - #?(:clj (clojure.lang MapEntry)))) - -(defn seq-diff [kf] - (fn [rf] - (let [state (object-array 4) ; 4 slots: [previous index, previous list, next index, next list] - append (fn [^objects o k] ; add to a circular doubly linked list + update index. - (let [next-index (aget state (int 2))] - ;; add item to current index - (aset state (int 2) ; set next index - (assoc next-index k (conj (get next-index k []) o))) ; next-index new looks like {k [?o], ...}. Must map to a vector in case of keyfn collision - ;; append item to current list - (if-some [^objects next-head (aget state (int 3))] ; list is not empty - (let [^objects next-tail (aget next-head (int 0))] - (aset o (int 0) next-tail) - (aset o (int 1) next-head) - (aset next-head (int 0) o) - (aset next-tail (int 1) o)) - (do (aset o (int 0) o) ; list is empty - (aset o (int 1) o) - (aset state (int 3) o))))) - scan (fn [r x] - (let [k (kf x) - prev-index (aget state (int 0)) - prev-head (aget state (int 1))] - (if-some [[o & os] (get prev-index k)] - (let [prev (aget o (int 0)) ; element already exists - next (when-not (identical? o prev) ; list is of size 1 - (aset prev (int 1) ; next <- prev and prev <- next - (doto (aget o (int 1)) - (aset (int 0) prev)))) - ;; emit change if needed - r (if (= x (aget o (int 2))) - r (rf r o (aset o (int 2) x))) ; value changed, emit a change operation - r (if (identical? o prev-head) ; item didn't move - (do (aset state (int 1) next) r) ; if item was head, move head forward - (rf r nil [o prev-head]))] ; item moved, emit a move operation - ;; remove from previous index - (aset state (int 0) (assoc prev-index k os)) - (append o k) r) - (let [o (object-array 3)] ; new item -> allocate 3 slots: [previous item, next item, value] - (append o k) - (-> r - (rf o (aset o (int 2) x)) ; emit change operation - (rf nil [o prev-head]) ; emit move operation - )))))] - (fn - ([] (rf)) - ([r] (rf r)) - ([r xs] - (if (instance? Failure xs) - (if-some [prev-head (aget state (int 1))] - (loop [o prev-head, r r] ; iterate tail to head - (let [o (aget o (int 0)) - r (rf r o (aset o (int 2) xs))] ; set branch value to failure instance, then emit change operation. - (if (identical? o prev-head) - r (recur o r)))) r) - (let [r (reduce scan r xs) ; after scan we have a new list and new index - r (if-some [prev-head (aget state (int 1))] ; remaining items in prev list are removals - (loop [o prev-head, r r] ; iterate tail to head - (let [o (aget o (int 0)) - r (rf r nil [o o])] ; emit removal operation - (if (identical? o prev-head) ; are we at the end of the list? - r (recur o r)))) r)] - (aset state (int 0) (aget state (int 2))) - (aset state (int 1) (aget state (int 3))) - (aset state (int 2) nil) - (aset state (int 3) nil) - r))))))) - -(defn entry [k v] - #?(:clj (MapEntry. k v) - :cljs (->MapEntry k v nil))) - -(tests - (let [alice-caramail {:id "alice" :email "alice@caramail.com"} - alice-gmail {:id "alice" :email "alice@gmail.com"} - bob {:id "bob" :email "bob@yahoo.com"} - alice-msn {:id "alice" :email "alice@msn.com"}] - (sequence (comp (seq-diff :id) (map entry)) - [[alice-caramail] - [alice-gmail bob] - [alice-gmail alice-msn bob] - [alice-gmail bob alice-msn] - [bob alice-msn] - []]) := - [ ; first change (initial) - [?a alice-caramail] ; set value of ?a to be {:id "alice", :email "..."} - [nil [?a nil]] ; if first element is nil -> movement, if it's an object -> event on an item - ; second element is a pair: - ; - first element is an identifier for the object we are moving - ; - second element is the target where to move it, nil means append at the end - ; second change - [?a alice-gmail] ; set value of ?a again (email changed) - [?b bob] ; set value of ?b to bob - [nil [?b nil]] ; a new object appears at the end of the list - ; third change - [?c alice-msn] ; set ?c to alice-msn - [nil [?c ?b]] ; insert new object ?c before ?b - ; fourth change - [nil [?b ?c]] ; insert ?b before ?c (bob before 2nd alice) - ; Fifth change - [nil [?b ?a]] ; insert ?b before ?a - [?a alice-msn] ; set ?a to be alice-msn - [nil [?c ?c]] ; remove ?c - ; Last change - [nil [?a ?a]] ; drop ?a - [nil [?b ?b]] ; drop ?b - ])) - -(defn insert-before [tier] - (fn [rf] - (let [state (doto (object-array 2) - (aset (int 0) {}) ;; key -> pos - (aset (int 1) []))] ;; pos -> key - (fn - ([] (rf)) - ([r] (rf r)) - ([r [target anchor]] - (let [r (let [k->p (aget state (int 0))] - (if (contains? k->p target) - r (do (aset state (int 0) (assoc k->p target (count k->p))) - (aset state (int 1) (conj (aget state (int 1)) target)) - (rf r [target])))) - k->p (aget state (int 0)) - start-position (k->p target) ; get start position from identifier - anchor-position (if (= anchor target) ; means removal - (count k->p) ; end of the vector - (case anchor - nil (count k->p) ; means target is moved to the end of the vector - (k->p anchor))) - final-position (if (< start-position anchor-position) - (dec anchor-position) anchor-position) - step (compare final-position start-position) ; 1, 0, or -1. In which way are we rotating? Do we iterate LTR or RTL? - r (case step - 0 r ; if we move a before b in [a b c], a is already just before b, nothing to do. - (loop [ks [target], i start-position] ; start in start-position, end in final-position - (let [j (+ i step) ; move one step to the left or right - k (nth (aget state (int 1)) j) - ks (conj ks k)] - (aset state (int 0) (assoc (aget state (int 0)) k i)) - (aset state (int 1) (assoc (aget state (int 1)) i k)) - (if (== j final-position) - (do (aset state (int 0) (assoc (aget state (int 0)) target j)) - (aset state (int 1) (assoc (aget state (int 1)) j target)) - (rf r ks)) (recur ks j)))))] - (if (= anchor target) - (do (aset state (int 0) (dissoc (aget state (int 0)) target)) - (aset state (int 1) (pop (aget state (int 1)))) - (r/move tier start-position start-position) - (rf r [target])) - (do (when-not (== start-position final-position) - (r/move tier start-position final-position)) r)))))))) - -;; TODO fix the test, requires to mock a tier :/ -(comment - (sequence insert-before [[:a nil]]) := - [[:a]] - - (sequence insert-before [[:a nil] [:b nil] [:c :a]]) := - [[:a] [:b] [:c] [:c :b :a]] - - (sequence insert-before [[:a nil] [:b nil] [:c nil] [:a :a]]) := - [[:a] [:b] [:c] [:a :b :c] [:a]] - - (sequence insert-before [[:b nil] [:c nil] [:a :b]]) := - [[:b] [:c] [:a] [:a :c :b]]) - -(defn apply-cycle [{:keys [vals index failed] :as r} [x & ys]] - (if-some [[y & ys] ys] - (let [i (index x) - v (vals i)] - (loop [index index - vals vals - i i - y y - ys ys] - (let [j (index y) - index (assoc index y i) - vals (assoc vals i (vals j))] - (if-some [[y & ys] ys] - (recur index vals j y ys) - (assoc r - :index (assoc index x j) - :vals (assoc vals j v)))))) - (if-some [i (index x)] - (do (assert (== (inc i) (count index))) - (assoc r - :failed (disj failed x) - :index (dissoc index x) - :vals (pop vals))) - (assoc r - :index (assoc index x (count index)) - :vals (conj vals nil))))) - -(defn apply-change [{:keys [vals index failed] :as r} k v] - (if-some [i (index k)] ; look up branch id (?a, ?b, ...) in [id -> position] index map - (assoc r - :vals (assoc vals i v) - :failed ((if (instance? Failure v) ; if v is a Failure, store its corresponding branch position in :failed set - conj disj) failed k)) r)) - -(defn values [{:keys [vals index failed]}] ; Either Failure | [value] - (if-some [[i] (seq (sort (mapv index failed)))] ; Sorted because we want to report the first error in the same order as the input collection. - (vals i) ; error value produced by branch k. An instance of Failure. - vals)) - -(defn seq-patch - ([] {:vals [] ; vector of each branch result (result of the for) - :index {} ; map of [branch id -> position in vector] - :failed #{}}) ; Set of positions of branches in an error state. - ([r] r) - ([r diff] - (reduce-kv apply-change - (reduce apply-cycle r (get diff nil)) - (dissoc diff nil)))) - -(tests - (reduce seq-patch (seq-patch) - [{nil [[:a]] - :a {:id "alice", :email "alice@caramail.com"}} - {nil [[:b]] - :a {:id "alice", :email "alice@gmail.com"} - :b {:id "bob", :name "bob@yahoo.com"}} - {nil [[:c]] - :c {:id "alice", :email "alice@msn.com"}} - {nil [[:c]]}]) - := - {:vals [{:id "alice", :email "alice@gmail.com"} - {:id "bob", :name "bob@yahoo.com"}] - :index {:a 0 :b 1} - :failed #{}}) - -(defn map-by " -Given a function and a continuous flow of collections, returns a continuous flow of vectors of the same size as input -collection, where values are produced by the continuous flow returned by the function when called with the continuous -flow of values matching the identity provided by key function, defaulting to identity." - ([tier f >xs] (map-by tier identity f >xs)) - ([tier k f >xs] - (->> >xs - (m/eduction (seq-diff k) (map entry)) - (m/group-by key) - (m/sample (fn [[id >x]] - (case id - nil (->> >x - (m/eduction - (map val) - (insert-before tier) - (map vector)) - (m/relieve into) - (m/sample (partial hash-map id))) - (->> >x - (m/eduction (map val)) - (m/relieve {}) - (f) - (r/with tier) - (m/latest (partial hash-map id)))))) - (gather merge) - (m/reductions seq-patch) - (m/latest values)))) diff --git a/src/hyperfiddle/electric/impl/gather.cljc b/src/hyperfiddle/electric/impl/gather.cljc deleted file mode 100644 index af0b698f1..000000000 --- a/src/hyperfiddle/electric/impl/gather.cljc +++ /dev/null @@ -1,162 +0,0 @@ -(ns hyperfiddle.electric.impl.gather - (:require [hyperfiddle.electric.impl.failer :as failer]) - #?(:clj (:import (clojure.lang IDeref IFn))) - #?(:cljs (:require-macros [hyperfiddle.electric.impl.gather :refer [aget-aset]]))) - -#?(:clj - (defmacro aget-aset [arr idx val] - `(let [a# ~arr - i# ~idx - x# (aget a# i#)] - (aset a# i# ~val) x#))) - -;; 0: iterator -;; 1: prev in linked list -;; 2: next in linked list -;; 3: next in transfer stack -;; 4: true if input is ready -;; 5: true if output can be notified -;; 6: count of non-terminated flows - -(defn ^:static done! [^objects main terminator] - (when (zero? (aset main (int 6) (dec (aget main (int 6))))) (terminator))) - -(defn ^:static cancel! [^objects main] - (when-some [item (aget main (int 2))] - (loop [^objects item item] - (when-not (identical? item main) - (let [n (aget item (int 2))] - (aset item (int 1) nil) - (aset item (int 2) nil) - ((aget item (int 0))) - (recur n)))) - (aset main (int 1) nil) - (aset main (int 2) nil) - ((aget main (int 0))))) - -(defn ^:static flush! [item] - (loop [^objects item item] - (when (some? item) - (let [next (aget-aset item (int 3) nil)] - (try @(aget item (int 0)) - (catch #?(:clj Throwable :cljs :default) _)) - (recur next))))) - -(defn ^:static fail! [^objects main ^objects item error] - (cancel! main) - (flush! (aget-aset main (int 3) nil)) - (flush! item) - (throw error)) - -(defn ^:static sample! [^objects main rf notifier] - (let [^boolean idle (aget-aset main (int 5) false) - ^objects head (aget-aset main (int 3) nil)] - (loop [^objects item (aget-aset head (int 3) nil) - r (try @(aget head (int 0)) - (catch #?(:clj Throwable :cljs :default) e - (fail! main item e)))] - (if (nil? item) - (do (if (aget main (int 5)) - (when idle (notifier)) - (aset main (int 5) ^Object idle) - ;; ^ Reflection optimization: no static method RT.aset - ;; for (^objects ^int ^boolean), target (^objects ^int ^object) - ;; instead. - ) - r) - (let [next (aget-aset item (int 3) nil)] - (recur next - (try (rf r @(aget item (int 0))) - (catch #?(:clj Throwable :cljs :default) e - (fail! main next e))))))))) - -(deftype It [main rf notifier terminator] - IFn - (#?(:clj invoke :cljs -invoke) [it] - (locking it (cancel! main))) - IDeref - (#?(:clj deref :cljs -deref) [it] - (locking it (sample! main rf notifier)))) - -(defn ^:static transfer! [^It it] - (let [^objects main (.-main it)] - (while (aset main (int 4) (not (aget main (int 4)))) - (if-some [^objects prev (aget main (int 1))] - (let [item (object-array (int 4)) - ^boolean idle (aget-aset main (int 5) false)] - (aset main (int 6) (inc (aget main (int 6)))) - (aset item (int 1) prev) - (aset prev (int 2) item) - (aset main (int 1) item) - (aset item (int 2) main) - (let [n #(locking it - (if (nil? (aget item (int 1))) - (try @(aget item (int 0)) - (catch #?(:clj Throwable - :cljs :default) _)) - (if-some [^objects curr (aget-aset main (int 3) item)] - (aset item (int 3) curr) - (if (aget main (int 5)) - ((.-notifier it)) - (aset main (int 5) true))))) - t #(locking it - (when-some [^objects prev (aget item (int 1))] - (let [^objects next (aget item (int 2))] - (aset next (int 1) prev) - (aset prev (int 2) next) - (aset item (int 1) nil) - (aset item (int 2) nil))) - (done! main (.-terminator it)))] - (aset item (int 0) - (try (@(aget main (int 0)) n t) - (catch #?(:clj Throwable :cljs :default) e - (failer/run e n t)))) - (if (aget main (int 5)) - (when idle ((.-notifier it))) - (aset main (int 5) idle)))) - (try @(aget main (int 0)) - (catch #?(:clj Throwable - :cljs :default) _)))))) - -(defn gather " -Given a commutative function and a flow of flows, returns a flow concurrently running the flow with flows produced by -this flow and producing values produced by nested flows, reduced by the function if more than one can be transferred -simultaneously. -" [rf >>x] - (fn [n t] - (let [main (object-array (int 7)) - it (->It main rf n t)] - (doto main - (aset (int 1) main) - (aset (int 2) main) - (aset (int 4) true) - (aset (int 5) true) - (aset (int 6) 1)) - (locking it - (aset main (int 0) - (>>x #(locking it (transfer! it)) - #(locking it (done! main t)))) - (transfer! it) it)))) - -(comment - (require '[missionary.core :as m]) - (def !xs (repeatedly 5 #(atom 0))) - (def it ((gather + (m/seed (map m/watch !xs))) - #(prn :ready) #(prn :done))) - @it - (swap! (nth !xs 1) inc) - (it) - - (def failer (m/ap (throw (ex-info "error" {})))) - - (def it ((gather + (m/seed [(m/watch (nth !xs 0)) - failer - (m/watch (nth !xs 1)) - (m/observe (fn [!] (def e! !) #(prn :cancelled)))])) - #(prn :ready) #(prn :done))) - @it - - (def it ((gather + failer) #(prn :ready) #(prn :done))) - @it - - ) diff --git a/src/hyperfiddle/electric/impl/io.cljc b/src/hyperfiddle/electric/impl/io.cljc deleted file mode 100644 index 3e7bd4f90..000000000 --- a/src/hyperfiddle/electric/impl/io.cljc +++ /dev/null @@ -1,278 +0,0 @@ -;; Facilities for encoding/decoding of Electric protocol messages. -;; * Data frames can be arbitrary clojure data or Electric failures. Serialization is done via transit json, the failure -;; error is preserved if it's an instance of `hyperfiddle.electric.Pending` or `hyperfiddle.electric.Cancelled`, otherwise -;; the error is logged and turned into an instance of `hyperfiddle.electric.Remote`. -;; * Control frames are vectors of signed integers. Serialization is the concatenation of the binary representation of -;; these numbers as fixed-length 32-bit, big endian. - -(ns ^:no-doc hyperfiddle.electric.impl.io - (:require [missionary.core :as m] - [cognitect.transit :as t] - #?(:clj [clojure.tools.logging :as log]) - [hyperfiddle.electric.debug :as dbg] - [hyperfiddle.rcf :as rcf :refer [tests with tap %]] - #?(:cljs [com.cognitect.transit.types]) - [hyperfiddle.electric.impl.array-fields :as a]) - (:import (missionary Cancelled) - (hyperfiddle.electric Failure Pending Remote FailureInfo) - #?(:clj (java.nio ByteBuffer)) - #?(:clj (java.io ByteArrayInputStream ByteArrayOutputStream)) - #?(:clj (clojure.lang IReduceInit)))) - -#?(:cljs (extend-type com.cognitect.transit.types/UUID IUUID)) ; https://github.com/hyperfiddle/hyperfiddle/issues/728 - -(def default-write-handler ; Intercepts unserializable values, logs and return nil - (t/write-handler ; Adapted from `com.cognitect.transit.impl.WriteHandlers.NullWriteHandler` - (fn [x] - (def -last-unserializable-for-repl x) - (#?(:clj log/info, :cljs js/console.log) "Unserializable reference transfer:" (pr-str (type x)) (str x)) - "_") - (fn [x] nil) - (fn [_] ""))) - -(defn ->cache "Builds a minimal, cljc map/bounded-queue cache. - One slot per key (map). - Reaching `size` pops oldest value (bounded-queue)." [size] - (doto (object-array (inc (* size 2))) (a/set (* size 2) 0))) -(defn cache-add [cache k v] - (when-not (loop [i 0] - (when (< i (dec (count cache))) - (if (= k (a/get cache i)) - (do (a/set cache (inc i) v) true) - (recur (+ i 2))))) - (let [widx (a/getswap cache (dec (count cache)) #(mod (+ % 2) (dec (count cache))))] - (a/set cache widx k, (inc widx) v)))) -(defn cache-get [cache k] - (loop [i 0] - (when (< i (dec (count cache))) - (if (= k (a/get cache i)) - (a/get cache (inc i)) - (recur (+ i 2)))))) -(defn cache->map [cache] - (loop [i 0, ac (transient {})] - (if (< i (dec (count cache))) - (recur (+ i 2) (assoc! ac (a/get cache i) (a/get cache (inc i)))) - (persistent! ac)))) - -(tests "keyed cache" - (def !c (->cache 1)) - (cache-add !c 1 2) (cache-get !c 1) := 2 - (cache-add !c 1 3) (cache-get !c 1) := 3 - (cache-add !c 2 4) (cache-get !c 2) := 4 - (cache->map !c) := {2 4} - - "size 2" - (def !c (->cache 2)) - (cache-add !c 1 1) - (cache-add !c 2 2) - (cache-add !c 2 2) - (cache->map !c) := {1 1, 2 2}) - -(def !ex-cache (->cache 16)) -(defn save-original-ex! [fi] - (let [id (dbg/ex-id fi)] - (when-some [cause (ex-cause fi)] - (when-not (instance? FailureInfo cause) - (cache-add !ex-cache id cause))) - id)) -(defn get-original-ex [id] (cache-get !ex-cache id)) - -(def ^:dynamic *write-handlers* nil) - -(def failure-writer (t/write-handler - (fn [_] "failure") - (fn [x] - (let [err (.-error ^Failure x)] - (cond (instance? Cancelled err) [:cancelled] - (instance? Pending err) [:pending] - (instance? Remote err) [:remote (ex-data err)] - :else [:exception (ex-message err) (ex-data err) - (save-original-ex! err)]))))) - -(defn write-opts [] - {:handlers (merge *write-handlers* - {Failure failure-writer - :default default-write-handler}) ; cljs - :default-handler default-write-handler}) ; clj - -(def ^:dynamic *read-handlers* nil) - -(def failure-reader (t/read-handler - (fn [[tag & args]] - (case tag - :exception (let [[message data id] args] - (Failure. (dbg/ex-info* message data id nil))) - :remote (let [[data] args] - (Failure. (dbg/ex-info* "Remote error" (or data {})))) - :pending (Failure. (Pending.)) - :cancelled (Failure. (Cancelled.)))))) - -(defn read-opts [] {:handlers (merge *read-handlers* {"failure" failure-reader})}) - -(def set-ints - (partial reduce-kv - (fn [r i n] - (let [offset (bit-shift-left i 2)] - #?(:clj (.putInt ^ByteBuffer r offset n) - :cljs (doto r (.setInt32 offset n))))))) - -(defn encode-numbers - "Encode a control frame to a binary segment." - [xs] - (let [required (bit-shift-left (count xs) 2)] ; size of bytebuffer is 4 × (count xs), so shift by 2 - #?(:clj (set-ints (ByteBuffer/allocate required) xs) - :cljs (doto (js/ArrayBuffer. required) - (-> (js/DataView.) (set-ints xs)))))) - -(defn decode-numbers - "Decode a control frame from a binary segment." - [b] - (vec - (reify - #?(:clj IReduceInit :cljs IReduce) - #?(:clj (reduce [_ rf r] - (let [l (.limit ^ByteBuffer b)] - (loop [r r, i (int 0)] - (if (< i l) - (recur (rf r (.getInt ^ByteBuffer b i)) - (unchecked-add-int i 4)) r)))) - :cljs (-reduce [_ rf r] - (let [l (.-byteLength b) - v (js/DataView. b)] - (loop [r r, i 0] - (if (< i l) - (recur (rf r (.getInt32 v i)) - (+ i 4)) r)))))))) - - -;; #?(:cljs (def transit-writer (t/writer :json (write-opts)))) -#?(:cljs (let [!cache (atom {:write-handlers *write-handlers*, :writer nil})] - (defn transit-writer [] - (:writer (swap! !cache (fn [{:keys [write-handlers writer] :as cache}] - (if (= write-handlers *write-handlers*) - (if writer - cache - (assoc cache :writer (t/writer :json (write-opts)))) - {:write-handlers *write-handlers* - :writer (t/writer :json (write-opts))}))))))) - -(defn encode - "Encode a data frame to transit json" - [x] - #?(:clj (let [out (ByteArrayOutputStream.)] - (t/write (t/writer out :json (write-opts)) x) - (.toString out)) - :cljs (t/write (transit-writer) x))) - -;; #?(:cljs (def transit-reader (t/reader :json (read-opts)))) -#?(:cljs (let [!cache (atom {:read-handlers *read-handlers*, :reader nil})] - (defn transit-reader [] - (:reader (swap! !cache (fn [{:keys [read-handlers reader] :as cache}] - (if (= read-handlers *read-handlers*) - (if reader - cache - (assoc cache :reader (t/reader :json (read-opts)))) - {:read-handlers *read-handlers* - :reader (t/reader :json (read-opts))}))))))) - - -(defn decode - "Decode a data frame from transit json" - [^String s] - #?(:clj (t/read (t/reader (ByteArrayInputStream. (.getBytes s "UTF-8")) :json (read-opts))) - :cljs (t/read (transit-reader) s))) - -(defn decode-str [x] - (try (doto (decode x) (->> (#?(:clj log/trace, :cljs js/console.debug) "🔽"))) - (catch #?(:clj Throwable :cljs :default) t - (throw (ex-info "Failed to decode" {:value x} t))))) - -(tests "FailureInfo" - (def cause (ex-info "boom" {})) - (def ex (dbg/ex-info* "x" {} cause)) - (def sent (-> ex Failure. encode decode .-error)) - "keeps the ID across the wire" - (dbg/ex-id ex) := (dbg/ex-id sent) - "can restore cause" - (get-original-ex (dbg/ex-id sent)) := cause - nil) - -; Jetty rejects websocket payloads larger than 65536 bytes by default -; We’ll chop messages if needed -(def chunk-size (bit-shift-right 65536 2)) - -(defn ^:deprecated message-reader [?read] - "Returns a discrete flow of read Electric messages from provided task, emitting individual frames." - (m/sp - (loop [data (transient [])] - (let [x (m/? ?read)] - (if (string? x) - (recur (conj! data (decode-str x))) - (persistent! - (conj! data - (loop [x x - control (transient [])] - (let [xs (decode-numbers x) - control (reduce conj! control xs)] - (if (< (count xs) chunk-size) ; final frame - (persistent! control) - (recur (m/? ?read) control))))))))))) - - -(defn ^:deprecated message-writer - "Returns a function taking an Electric message and returning a task writing it as individual frames using provided - function. Might cut a message into chunks if its size would exceed the server payload limit. - An empty message (0b) is written to notify the end of frame." - [write] - #(m/sp - (loop [xs (seq (pop %))] - (if-some [[x & xs] xs] - (do (#?(:clj log/trace, :cljs js/console.debug) "🔼" x) - (m/? (write - (try (encode x) - (catch #?(:clj Throwable :cljs :default) t - (throw (ex-info "Failed to encode" {:value x} t)))))) - (recur xs)) - (loop [xs (peek %)] - (if (>= (count xs) chunk-size) - (do (m/? (write (encode-numbers (subvec xs 0 chunk-size)))) - (recur (subvec xs chunk-size))) - (m/? (write (encode-numbers xs))))))))) - -(defn ^:deprecated decoder - "A transducer partitioning a sequence of network messages into Electric events." - [rf] - (let [data (doto (object-array 2) - (aset 0 []) (aset 1 []))] - (fn - ([] (rf)) - ([r] - (assert (= [] (aget data 0) (aget data 1))) - (rf r)) - ([r x] - (if (string? x) - (do (assert (= [] (aget data 1))) - (aset data 0 (conj (aget data 0) (decode-str x))) r) - (let [xs (decode-numbers x)] - (aset data 1 (into (aget data 1) xs)) - (if (< (count xs) chunk-size) ; final frame - (let [x (conj (aget data 0) (aget data 1))] - (aset data 0 []) - (aset data 1 []) - (rf r x)) r))))))) - -(defn ^:deprecated encoder - "A transducer expanding Electric events to a sequence of network messages." - [rf] - (fn - ([] (rf)) - ([r] (rf r)) - ([r x] - (let [r (reduce rf r (eduction (map encode) (pop x))) - r (reduce rf r (eduction (partition-all chunk-size) (map encode-numbers) (peek x)))] - (case (mod (count (peek x)) chunk-size) - 0 (rf r (encode-numbers [])) r))))) - -(defn foreach - ([r] r) - ([r x] (r x) r)) diff --git a/src/hyperfiddle/electric/impl/ir.cljc b/src/hyperfiddle/electric/impl/ir.cljc deleted file mode 100644 index f6df14fbc..000000000 --- a/src/hyperfiddle/electric/impl/ir.cljc +++ /dev/null @@ -1,68 +0,0 @@ -(ns hyperfiddle.electric.impl.ir - (:refer-clojure :exclude [apply eval])) - -(defn sub [idx] - {::op ::sub - ::index idx}) - -(defn pub [init inst] - {::op ::pub - ::init init - ::inst inst}) - -(defn constant [init] - {::op ::constant - ::init init}) - -(defn target [deps] - {::op ::target - ::deps deps}) - -(defn apply [f & args] - (cond-> {::op ::apply ::fn f ::args args} - (::tag f) (assoc ::tag (::tag f)))) - -(defn variable [init] - {::op ::variable - ::init init}) - -(def source - {::op ::source}) - -(defn input [deps] - {::op ::input - ::deps deps}) - -(defn output [init] - {::op ::output - ::init init}) - -(defn inject [slot] - {::op ::def - ::slot slot}) - -(defn eval [form] - {::op ::eval - ::form form}) - -(defn node [slot] - {::op ::node - ::slot slot}) - -(defn bind [slot index inst] - {::op ::bind - ::slot slot - ::index index - ::inst inst}) - -(defn lift [inst] - {::op ::lift - ::init inst}) - -(defn do [deps inst] - {::op ::do - ::deps deps - ::inst inst}) - -(def nop - {::op ::nop}) diff --git a/src/hyperfiddle/electric/impl/ir_utils.cljc b/src/hyperfiddle/electric/impl/ir_utils.cljc deleted file mode 100644 index 1b8243b5c..000000000 --- a/src/hyperfiddle/electric/impl/ir_utils.cljc +++ /dev/null @@ -1,73 +0,0 @@ -(ns hyperfiddle.electric.impl.ir-utils - (:require [hyperfiddle.electric.impl.ir :as ir]) - #?(:clj (:import [clojure.lang IReduce]))) - -(defn reduce* [ir f init] - (loop [ac init, todos (list ir)] - (if (or (reduced? ac) (empty? todos)) - (unreduced ac) - (let [[ir & todos] (seq todos)] - (case (::ir/op ir) - (::ir/sub ::ir/global ::ir/source ::ir/def ::ir/eval ::ir/node ::ir/nop) - (recur (f ac ir) todos) - - (::ir/target ::ir/input) - (recur (f ac ir) (concat (::ir/deps ir) todos)) - - (::ir/pub) - (recur (f ac ir) (conj todos (::ir/inst ir) (::ir/init ir))) - - (::ir/constant ::ir/variable ::ir/output ::ir/lift) - (recur (f ac ir) (conj todos (::ir/init ir))) - - (::ir/apply) - (recur (f ac ir) (concat (list (::ir/fn ir)) (::ir/args ir) todos)) - - (::ir/bind) - (recur (f ac ir) (conj todos (::ir/inst ir))) - - (::ir/do) - (recur (f ac ir) (concat (::ir/deps ir) (list (::ir/inst ir)) todos)) - - #_else (throw (ex-info "what IR op is this?" {:inst ir}))))))) - -(defn ->reducible [ir] - (reify IReduce - (#?(:clj reduce :cljs -reduce) [_ f init] (reduce* ir f init)) - (#?(:clj reduce :cljs -reduce) [_ f] (reduce* ir f (f))))) - -(defn unwrite [i] - (let [ret (case (::ir/op i) - ::ir/sub (list 'ir/sub (::ir/index i)) - ::ir/pub (list 'ir/pub - (unwrite (::ir/init i)) (unwrite (::ir/inst i))) - ::ir/constant (list 'ir/constant (unwrite (::ir/init i))) - ::ir/target (list 'ir/target (mapv unwrite (::ir/deps i))) - ::ir/apply (list* 'ir/apply (unwrite (::ir/fn i)) (map unwrite (::ir/args i))) - ::ir/global (list 'ir/global (::ir/name i)) - ::ir/variable (list 'ir/variable (unwrite (::ir/init i))) - ::ir/source (list 'ir/source) - ::ir/input (list 'ir/input (mapv unwrite (::ir/deps i))) - ::ir/output (list 'ir/output (unwrite (::ir/init i))) - ::ir/def (list 'ir/inject (::ir/slot i)) - ::ir/eval (list 'ir/eval (::ir/form i)) - ::ir/node (list 'ir/node (::ir/slot i)) - ::ir/bind (list 'ir/bind (::ir/slot i) (::ir/index i) (unwrite (::ir/inst i))) - ::ir/lift (list 'ir/lift (unwrite (::ir/init i))) - ::ir/do (list 'ir/do (mapv unwrite (::ir/deps i)) (unwrite (::ir/inst i))) - ::ir/nop (list 'ir/nop) - #_else (throw (ex-info "what IR op is this?" {:inst i})))] - (if-some [form (:hyperfiddle.electric.impl.lang/form i)] - (list* (first ret) :form form (next ret)) - ret))) - -(defn postwalk [ir f] - (f (case (::ir/op ir) - (::ir/sub ::ir/source ::ir/def ::ir/eval ::ir/node ::ir/nop) ir - (::ir/pub) (-> ir (update ::ir/inst postwalk f) (update ::ir/init postwalk f)) - (::ir/constant ::ir/variable ::ir/output ::ir/lift) (update ir ::ir/init postwalk f) - (::ir/target ::ir/input) (update ir ::ir/deps (partial mapv #(postwalk % f))) - (::ir/apply) (-> ir (update ::ir/args (partial mapv #(postwalk % f))) (update ::ir/fn postwalk f)) - (::ir/bind) (update ir ::ir/inst postwalk f) - (::ir/do) (-> ir (update ::ir/deps (partial mapv #(postwalk % f))) (update ::ir/inst postwalk f)) - #_else (throw (ex-info (str "what IR op is " ir) {:inst ir}))))) diff --git a/src/hyperfiddle/electric/impl/lang.clj b/src/hyperfiddle/electric/impl/lang.clj deleted file mode 100644 index 17f44c7f8..000000000 --- a/src/hyperfiddle/electric/impl/lang.clj +++ /dev/null @@ -1,727 +0,0 @@ -(ns hyperfiddle.electric.impl.lang - (:require - [clojure.string :as str] - [clojure.pprint :as pp] - [cljs.analyzer] - [contrib.data] - [hyperfiddle.electric :as-alias e] - [hyperfiddle.electric.impl.analyzer :as ana] - [hyperfiddle.electric.impl.expand :as expand] - [hyperfiddle.electric.impl.ir :as ir] - [hyperfiddle.electric.impl.ir-utils :as ir-utils] - [hyperfiddle.electric.impl.runtime :as r] - [hyperfiddle.electric.debug :as dbg] - [hyperfiddle.rcf :refer [tests]])) - -(def ^{::type ::node, :doc "for loop/recur impl"} rec) -(def ^{::type ::node, :doc "for runtime arity check"} %arity) -(def ^{::type ::node, :doc "for runtime varargs"} %args) -(def ^{::type ::node, :doc "for self-recur"} %closure) -(def ^{::type ::node, :doc "for try/catch"} exception) -(def ^{::type ::node, :doc "for case"} %case-test) -(def ^{::type ::node, :doc "In a `catch` block, bound by the runtime to the current stacktrace. An Electric stacktrace is an ExceptionInfo. Use `hyperfiddle.electric.debug/stack-trace` to get a string representation."} - trace {:fn (fn [_frame _vars _env] (r/pure nil)), - :get-used-nodes #(), :var-name `trace - :noutput 0, :ninput 0, :nvariable 0, :nsource 0, :ntarget 0, :dynamic '[], :nconstant 0}) - -(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) - -(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 with-local - ([env sym] (with-local env sym nil)) - ([env sym v] - (let [peer (::current env) - i (get (::index env) peer 0)] - (-> env - (update ::index assoc peer (inc i)) - (update :locals update sym assoc ::pub i, ::peer peer, ::meta (cond-> (meta sym) - (::ir/tag v) (assoc :tag (::ir/tag v)))))))) - -(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 causal [stmt expr] - (ir/apply (ir/eval '{}) stmt expr)) - -(defn causal-publish - ([init inst] (causal-publish init inst nil)) - ([init inst ?sym] (cond-> (ir/pub init (causal (ir/sub 1) inst)) ?sym (assoc ::form ?sym)))) - -(defn- ensure-seq [v] (if (seq? v) v (seq [v]))) -(defn- ->case-picker-map [test-constants-coll] - (into {} (map-indexed (fn [i v] (zipmap (ensure-seq v) (repeat i)))) test-constants-coll)) - -(tests - (->case-picker-map '((1 2) 4)) := {1 0, 2 0, 4 1} - (->case-picker-map '([a b])) := {'[a b] 0}) - -(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 (expand/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 (expand/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 analyze-binding [env bs f & args] - ((fn rec [env bs ns] - (if-some [[node form & bs] bs] - (let [init (analyze-me env form) - inst (rec (update env ::index update (::current env) (fnil inc 0)) bs (conj ns node))] - (if (::non-causal env) - (cond-> (ir/pub init inst) node (assoc ::form node)) - (causal-publish init inst node))) - (reduce-kv (fn [res i n] - (if-some [qualified-sym (find-node-signifier n env)] - (ir/bind (signifier->node qualified-sym env) (- (count ns) i) res) - (if-some [qualified-sym (find-node n env)] - (ir/bind qualified-sym (- (count ns) i) res) - (fail! env (str "Not an electric e/def: " n) {:symbol n})))) - (apply f env args) ns))) env (seq bs) [])) - -(defn analyze-case [env expr clauses] - (let [clauses (vec clauses) - [default-clause clauses] (if (even? (count clauses)) - [`(r/case-default-throw %case-test) clauses] - [(peek clauses) (pop clauses)]) - picker-map (->case-picker-map (take-nth 2 clauses))] - (analyze-binding env [`%case-test expr] - (fn [env] - (ir/variable - (apply ir/apply (ir/eval `r/pick-case-branch) (ir/eval (list 'quote picker-map)) - (analyze-me env `%case-test) - (analyze-me env (list ::closure default-clause {::dbg/type :case-default})) - (mapv (fn [[test form]] - (analyze-me env `(::closure ~form {::dbg/type :case-clause - ::dbg/meta ~(meta form)}))) - (partition 2 clauses)))))))) - -(defn cat-them [& xs] (into [] cat xs)) -(defn ->them [base deps] (assoc base ::ir/deps deps)) - -(defn analyze-them-case [env expr clauses] - (let [clauses (vec clauses) - [default-clause clauses] (if (even? (count clauses)) - [`(r/case-default-throw %case-test) clauses] - [(peek clauses) (pop clauses)])] - (if (::in-interop-fn? env) - (apply cat-them (analyze-them env expr) (eduction (take-nth 2) (map #(analyze-them env %)) (rest clauses))) - (apply cat-them [(assoc ir/source ::form (list 'case expr))] - (analyze-them env expr) - (analyze-them env (list ::closure default-clause {::dbg/type :case-default})) - (eduction (partition-all 2) (map (fn [[test form]] - (analyze-them env `(::closure ~form {::dbg/type :case-clause - ::dbg/meta ~(meta form)})))) - clauses))))) - -(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- expand-try [args env] - (let [[forms catches finally] - (reduce - (fn [[forms catches finally] form] - (case finally - nil (let [[op & args] (when (seq? form) form)] - (case op - catch [forms (conj catches args) finally] - finally [forms catches (vec args)] - (case catches - [] [(conj forms form) catches finally] - (fail! env "Invalid try block - unrecognized clause.")))) - (fail! env "Invalid try block - finally must be in final position."))) - [[] [] nil] args) - body `(::closure (do ~@forms) {::dbg/type :try})] - (expand/all env - `(new ~(reduce - (fn [r f] `(r/latest-first ~r (::closure ~f {::dbg/type :finally}))) - (case catches - [] body - `(r/bind r/recover - (some-fn - ~@(map (fn [[c s & body]] - (let [f `(partial (::inject exception) - (::closure (let [~s (dbg/unwrap exception)] - (binding [trace exception] - ~@body)) - {::dbg/type :catch}))] - (case c - (:default Throwable) - `(r/clause ~f) - `(r/clause ~f ~c)))) catches)) - ~body)) finally))))) - -(defn ->class-method-call [clazz method method-args env] - (apply ir/apply (assoc (ir/eval (let [margs (repeatedly (count method-args) gensym)] - `(fn [~@margs] (. ~clazz ~method ~@margs)))) - ::dbg/action :static-call, ::dbg/target clazz, ::dbg/method method) - (mapv #(analyze-me env %) method-args))) - -(defn ->obj-method-call [o method method-args env] - (apply ir/apply (assoc (ir/eval (let [margs (repeatedly (count method-args) gensym) - oo (with-meta (gensym "o") (->meta o env))] - `(fn [~oo ~@margs] (. ~oo ~method ~@margs)))) - ::dbg/action :call, ::dbg/target o, ::dbg/method method) - (analyze-me env o) - (mapv #(analyze-me env %) method-args))) - -(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 source-map - ([env debug-info] - (let [file (if (:js-globals env) (:file (:meta (:ns env))) - (some-> env :ns find-ns meta :file))] - (if (some? file) - (merge {:file file} debug-info) - (or debug-info {}))))) - -(defn keep-if [pred v] (when (pred v) v)) - -(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-me [env form] - (when (::trace env) (prn :analyze (if (and (seq? form) (seq form)) (first form) form))) - (let [env (store env form)] - (cond - (and (seq? form) (seq form)) - (let [[op & args] form] - (case op - (let*) ((fn rec [env bs] - (if-some [[s i & bs] bs] - (let [v (analyze-me env i)] - (cond-> (if (::non-causal env) - (cond-> (ir/pub v (rec (with-local env s v) bs)) s (assoc ::form s)) - (causal-publish v (rec (with-local env s v) bs) s)) - (::ir/tag v) (assoc ::ir/tag (::ir/tag v)))) - (analyze-me env (cons `do (next args))))) - env (seq (first args))) - - (do) (if-some [[x & xs] args] - ((fn rec [x xs] - (let [r (analyze-me env x)] - (if-some [[y & ys] xs] - (causal r (rec y ys)) - r))) x xs) - (ir/eval nil)) - - (case) (analyze-case env (first args) (rest args)) - (if) (let [[test then else] args] (analyze-case env test (list '(nil false) else then))) - - (quote) (ir/eval (list 'quote (first args))) - - (js*) (if-some [[f & args] args] - (apply ir/apply (assoc (ir/eval (let [args (repeatedly (count args) gensym)] - `(fn [~@args] (~'js* ~f ~@args)))) - ::dbg/action :js-call) - (mapv #(analyze-me env %) args)) - (fail! env "Wrong number of arguments - js*" )) - - (fn*) (let [[env arities] (if (symbol? (first args)) - [(update env :locals assoc (first args) true) (next args)] - [env args]) - env (assoc env ::in-interop-fn? true)] - (doseq [[bs & body] arities] ; checks for invalid calls, may throw - (analyze-me (with-interop-locals env bs) (cons 'do body))) - (let [[form refs] (closure env (cons 'fn* args))] - (apply ir/apply (assoc (ir/eval form) - ::dbg/action :fn-call, ::dbg/name (keep-if symbol? (first args))) - (eduction (map #(analyze-me env %)) refs)))) - - ;; (letfn* [foo (fn* foo ([x] x))] ...) - (letfn*) (let [fnenv (with-interop-locals env (take-nth 2 (first args)))] - (doseq [[_fn* _nm & arities] (take-nth 2 (nfirst args))] ; checks for invalid calls, may throw - (doseq [[bs & body] arities] - (analyze-me (with-interop-locals fnenv bs) (cons 'do body)))) - (let [[bs & body] args] - (recur env (expand/all env `(let [~(vec (take-nth 2 bs)) (::letfn ~bs)] ~@body))))) - - (::letfn) (let [bs (first args), [form refs] (closure env `(letfn* ~bs ~(vec (take-nth 2 bs))))] - (apply ir/apply (assoc (ir/eval form) ::dbg/type :letfn) (mapv #(analyze-me env %) refs))) - - (set!) (when-not (::in-interop-fn? env) - (recur env (expand/all env `((fn [v#] (set! ~(nth form 1) v#)) ~(nth form 2))))) - - (new) (if-some [[f & args] args] - (if (class-constructor-call? env f) - (cond-> (apply ir/apply (ir/eval (let [args (repeatedly (count args) gensym)] ; class constructor call - `(fn [~@args] (new ~f ~@args)))) - (mapv #(analyze-me env %) args)) - (= "js" (namespace f)) (assoc ::ir/tag 'js)) - (analyze-binding env ; electric join - (list* `%closure f `%arity (count args) (interleave arg-sym args)) - (fn [env] - #_(ir/variable (ir/sub (+ 2 (count args)))) - (analyze-binding env [`%args `[~@(take (count args) arg-sym)]] - (fn [_] (ir/variable (ir/sub (+ 3 (count args))))))))) - (fail! env "Wrong number of arguments - new" {})) - - ;; (. 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? (first args)) (class? (resolve env (first args)))) - (if (seq? (second args)) - (let [[clazz [method & method-args]] args] - (->class-method-call clazz method method-args env)) - (let [[clazz x & xs] args] - (if (seq xs) - (->class-method-call clazz x xs env) - (ir/eval form)))) - (if (seq? (second args)) - (let [[o [method & method-args]] args] - (->obj-method-call o method method-args env)) - (let [[o x & xs] args] - (if (seq xs) - (->obj-method-call o x xs env) - (ir/apply (ir/eval - (let [oo (with-meta (gensym "o") (->meta o env))] - `(fn [~oo] (. ~oo ~x)))) (analyze-me env o)))))) - - (throw) (recur env (expand/all env `(r/fail ~(first args) trace))) - - (try) (recur env (expand-try args env)) - - (loop*) (let [[bs & body] args] - (recur env (expand/all env - `(binding [rec (::closure (let [~@(interleave (take-nth 2 bs) arg-sym)] ~@body))] - (new rec ~@(take-nth 2 (next bs))))))) - - (recur) (recur env `(new rec ~@args)) - - (def) (let [[sym v] args] - (if (or (find-node sym env) (find-node-signifier sym env)) - (fail! env "Cannot `def` a reactive var" {:var sym}) - (when-not (::in-interop-fn? env) - (recur env (expand/all env - (if (= :cljs (get (::peers env) (::current env))) - (let [ns (-> env :ns :name)] - (swap! @(requiring-resolve 'cljs.env/*compiler*) - assoc-in [:cljs.analyzer/namespaces ns :defs sym] {:name sym}) - `(set! ~sym ~v)) - `((fn [x#] (def ~sym x#)) ~v))))))) - - (::lift) (ir/lift (analyze-me env (first args))) - - (::closure) (let [[form debug-info] args] - (merge (ir/constant (analyze-me env (expand/all env form))) debug-info)) - - (::toggle) (let [[peer debug-info & body] args] - (if (= peer (::current env)) - (recur env (cons 'do body)) - (->them {::ir/op ::ir/input, ::dbg/meta (source-map env debug-info), ::dbg/type :toggle} - (analyze-them (assoc env ::current peer) (cons 'do body))))) - - (::inject) (ir/inject (let [sym (first args)] - (if-some [qualified-sym (find-node-signifier sym env)] - (signifier->node qualified-sym env) - (if-some [qualified-sym (find-node sym env)] - qualified-sym - (fail! env (str "Not a node: " sym) {:sym sym}))))) - - (binding) (if (::in-interop-fn? env) - (run! #(analyze-me env %) (eduction cat [(eduction (take-nth 2) (nfirst args)) (next args)])) - (analyze-binding env (first args) analyze-me (cons `do (next args)))) - - (clojure.core/unquote-splicing) (->them {::ir/op ::ir/input , ::dbg/meta (meta form), ::dbg/type :toggle} - (analyze-them (toggle env) (next form))) - - #_else (apply ir/apply - (if-let [resolved (and (symbol? op) (= :cljs (get (::peers env) (::current env))) - (->> (expand/resolve-cljs env op) (keep-if (comp '#{js} :ns)) :name))] - (assoc (ir/eval (bound-js-fn resolved)) ::ir/tag 'js) - (assoc (analyze-me env op) ::dbg/name op ::dbg/file (:file (meta op)) ::dbg/line (:line (meta op)))) - (mapv #(analyze-me env %) args)))) - - (node-signifier? (meta form)) - (ir/node (ns-qualify form)) - - (instance? cljs.tagged_literals.JSValue form) - (let [o (.-val ^cljs.tagged_literals.JSValue form)] - (if (map? o) - (recur env (expand/all env (cons 'cljs.core/js-obj (into [] (mapcat (fn [[k v]] [(name k) v])) o)))) - (recur env (expand/all env (cons 'array o))))) - - (symbol? form) - (if-some [local (find-local form env)] - (if (::pub local) - (let [debug-info {::dbg/name (with-meta form nil), ::dbg/scope :lexical, ::dbg/meta (meta form)}] - (if (= (::peer local) (::current env)) - (merge (ir/sub (- (get (::index env) (::current env)) (::pub local))) debug-info) - (->them (assoc debug-info ::ir/op ::ir/input) (analyze-them env (list ::toggle (::peer local) form))))) - (ir/eval form)) - (if-some [qualified-sym (find-node-signifier form env)] - (let [node (signifier->node qualified-sym env)] - (if (case (get (::peers env) (::current env)) - :clj (resolve node) - :cljs (expand/resolve-cljs env node)) - (assoc (ir/node node) ::dbg/name qualified-sym, ::dbg/scope :dynamic) - (cannot-resolve! env form))) - (if-some [qualified-sym (find-node form env)] - (assoc (ir/node qualified-sym) ::dbg/name qualified-sym, ::dbg/scope :dynamic) - (if (case (get (::peers env) (::current env)) - :clj (or (resolve-static-field form) (resolve form)) - :cljs (expand/resolve-cljs env form)) - (ir/eval form) - (cannot-resolve! env form))))) - - (vector? form) (recur env (cons `vector form)) - (map? form) (recur env (if-let [m (meta form)] - (list `with-meta (cons `hash-map (eduction cat form)) m) - (cons `hash-map (eduction cat form)))) - (set? form) (recur env (cons `hash-set form)) - - :else (ir/eval form)))) - -(defn analyze-them [env form] - (let [env (store env form)] - (cond - (and (seq? form) (seq form)) - (let [[op & args] form] - (case op - (let*) (loop [env env, bs (seq (first args)), ret []] - (if-some [[s i & bs] bs] - (recur (with-local env s) bs (conj ret (analyze-them env i))) - (apply cat-them (conj ret (analyze-them env (cons `do (next args))))))) - - (do) (apply cat-them (eduction (map #(analyze-them env %)) args)) - - (case) (analyze-them-case env (first args) (rest args)) - (if) (let [[test then else] args] (analyze-them-case env test (list '(nil false) else then))) - - (quote) nil - (js*) (apply cat-them (eduction (map #(analyze-them env %)) args)) - - (fn*) (let [[env arities] (if (symbol? (first args)) - [(update env :locals assoc (first args) true) (next args)] - [env args]) - env (assoc env ::in-interop-fn? true)] - (apply cat-them (eduction (map (fn [[bs & body]] - (analyze-them (with-interop-locals env bs) - (cons 'do body)))) arities))) - - ;; (letfn* [foo (fn* foo ([x] x))] ...) - (letfn*) - (let [[fns & body] args - fnenv (-> env (with-interop-locals (take-nth 2 fns)) - (assoc ::in-interop-fn? true)) - fns-ret (apply cat-them (eduction (take-nth 2) (map #(analyze-them fnenv %)) (next fns))) - env (with-interop-locals env (take-nth 2 fns))] - (cat-them fns-ret (analyze-them env (cons 'do body)))) - - (set!) (cat-them (analyze-them env (nth form 1)) (analyze-them env (nth form 2))) - - (new) (if-some [[f & fargs] args] - (if (or (::in-interop-fn? env) (class-constructor-call? env f)) - (apply cat-them (eduction (map #(analyze-them env %)) fargs)) - (apply cat-them - [(assoc ir/source ::form (list 'new (cond-> f (seq? f) first)))] - (eduction (map #(analyze-them env %)) args))) - (fail! env "Wrong number of arguments - new" {})) - - (.) (apply cat-them (eduction (map #(analyze-them env %)) args)) - - (throw) (recur env (expand/all env `(r/fail ~(first args) trace))) - - (try) (recur env (expand-try args env)) - - (loop*) (let [[bs & body] args] - (recur env (expand/all env - `(binding [rec (::closure (let [~@(interleave (take-nth 2 bs) arg-sym)] ~@body))] - (new rec ~@(take-nth 2 (next bs))))))) - - (recur) (recur env `(new rec ~@args)) - - (def) (recur env (nth form 2)) - - (::lift) (recur env (first args)) - - (::closure) [(->them {::ir/op ::ir/target, ::form :closure} (analyze-them env (first args)))] - - (::toggle) (let [[peer debug-info & body] args] - (if (= peer (::me env)) - [(ir/output (analyze-me (assoc env ::current peer) (cons 'do body)))] - (analyze-them env (cons 'do body)))) - - (::inject) nil - - (binding) (let [[bs & body] args] - (apply cat-them (eduction cat (map #(analyze-them env %)) - [(eduction (take-nth 2) (next bs)) body]))) - - (clojure.core/unquote-splicing) [(ir/output (analyze-me (toggle env) (next form)))] - - #_else (apply cat-them (eduction (map #(analyze-them env %)) form)))) - - (instance? cljs.tagged_literals.JSValue form) - (let [o (.-val ^cljs.tagged_literals.JSValue form)] - (if (map? o) - (recur env (expand/all env (cons 'cljs.core/js-obj (into [] (mapcat (fn [[k v]] [(name k) v])) o)))) - (recur env (expand/all env (cons 'array o))))) - - (symbol? form) - (if-some [local (find-local form env)] - (let [debug-info {::dbg/name (with-meta form nil), ::dbg/scope :lexical, ::dbg/meta (meta form)}] - (when (and (::pub local) (= (::me env) (::peer local))) - [(ir/output (merge (analyze-me (assoc env ::current (::me env)) form) debug-info))])) - (when-some [qualified-sym (find-node-signifier form env)] - (let [node (signifier->node qualified-sym env)] - (if (case (get (::peers env) (::me env)) - :clj (resolve node) - :cljs (expand/resolve-cljs env node)) - [(assoc (ir/node node) ::dbg/name qualified-sym, ::dbg/scope :dynamic)] - (cannot-resolve! env form))))) - - (vector? form) (recur env (cons `vector form)) - (map? form) (recur env (if-let [m (meta form)] - (list `with-meta (cons `hash-map (eduction cat form)) m) - (cons `hash-map (eduction cat form)))) - (set? form) (recur env (cons `hash-set form)) - - :else nil))) - -(defn analyze [env form] - (binding [expand/*electric* true] - (let [expanded (expand/all env form)] - (when (::pprint-expansion env) - (println "---" (::sym env) "EXPANSION ---") - (pp/pprint expanded)) - (let [ret (if (= (::me env) (::current env)) - (analyze-me env expanded) - (->them {::ir/op ::ir/do, ::ir/inst ir/nop} (analyze-them env expanded)))] - (when (::pprint-ir env) - (println "---" (::sym env) "IR ---") - (pp/pprint (ir-utils/unwrite ret))) - ret)))) - - -(defn electric-only [& args] - (throw (ex-info "I'm an electric value and you called me outside of electric." {:args args}))) - -(defn -def - ([env name-sym init] - (when-not (::has-edef? (meta *ns*)) - (alter-meta! *ns* assoc ::has-edef? true)) - (let [lang (if (:js-globals env) :cljs :clj) - env (merge env (contrib.data/select-ns 'hyperfiddle.electric.impl.lang (meta name-sym))) - configs (get-configs-to-compile env lang)] - `(do (def ~(as-node-signifier name-sym) electric-only) - ~@(for [config configs] - (let [env (merge env config {::def name-sym}) - sym (signifier->node name-sym env) - fullsym (symbol (str *ns*) (str sym)) - _ (when (::print-defs (meta name-sym)) (prn 'defining fullsym)) - env (assoc env ::sym sym) - ir (analyze env init) - info (r/compile name-sym ir env)] - (list `def (as-node sym) (assoc info :var-name (list 'quote fullsym))))))))) diff --git a/src/hyperfiddle/electric/impl/lang.cljs b/src/hyperfiddle/electric/impl/lang.cljs deleted file mode 100644 index ea1b5cd34..000000000 --- a/src/hyperfiddle/electric/impl/lang.cljs +++ /dev/null @@ -1,38 +0,0 @@ -(ns hyperfiddle.electric.impl.lang - (:require [hyperfiddle.electric.impl.runtime :as r]) - (:require-macros [hyperfiddle.electric.impl.lang])) - -(def ^{::type ::node, :doc "for loop/recur impl"} rec) -(def ^{::type ::node, :doc "for runtime arity check"} %arity) -(def ^{::type ::node, :doc "for runtime varargs"} %args) -(def ^{::type ::node, :doc "for self-recur"} %closure) -(def ^{::type ::node, :doc "for try/catch"} exception) -(def ^{::type ::node, :doc "for case"} %case-test) -(def ^{::type ::node, :doc "In a `catch` block, bound by the runtime to the current stacktrace. An Electric stacktrace is an ExceptionInfo. Use `hyperfiddle.electric.debug/stack-trace` to get a string representation."} - trace {:fn (fn [_frame _vars _env] (r/pure nil)), - :get-used-nodes #(), :var-name `trace - :noutput 0, :ninput 0, :nvariable 0, :nsource 0, :ntarget 0, :dynamic '[], :nconstant 0}) - -(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) - -(defn electric-only [& args] - (throw (ex-info "I'm an electric value and you called me outside of electric." {:args args}))) diff --git a/src/hyperfiddle/electric/impl/lang3.clj b/src/hyperfiddle/electric/impl/lang3.clj new file mode 100644 index 000000000..2b0b166f3 --- /dev/null +++ b/src/hyperfiddle/electric/impl/lang3.clj @@ -0,0 +1,1410 @@ +(ns hyperfiddle.electric.impl.lang3 + (:refer-clojure :exclude [compile]) + (:require [cljs.analyzer] + [cljs.env] + [clojure.string :as str] + [contrib.assert :as ca] + [contrib.data :refer [keep-if]] + [clojure.set :as set] + [contrib.triple-store :as ts] + [dom-top.core :refer [loopr]] + [fipp.edn] + [hyperfiddle.electric3 :as-alias e] + [hyperfiddle.electric.impl.cljs-analyzer2 :as cljs-ana] + [hyperfiddle.electric.impl.destructure :as dst] + [hyperfiddle.electric.impl.runtime3 :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 ->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] (ca/is (-> env :ns :name) some? "No ns found in environment map" {:env env})) + +(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 _)))) + +(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}))))) + +;;;;;;;;;;;;;;;; +;;; EXPANDER ;;; +;;;;;;;;;;;;;;;; + +(defn- fn-> [f a] (fn [o] (f o a))) + +(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 (?expand-clj-method-call o) + (catch ClassNotFoundException _ o)))) ; e.g. (goog.color/hslToHex ..) won't expand on clj + +(def !a (cljs-ana/->!a)) + +(comment + (cljs-ana/purge-ns !a 'hyperfiddle.electric3-test) + ) + +(defn ->peer-type [env] (get (::peers env) (::current env))) + +(defn qualify-sym [sym env] + (if (= :cljs (->peer-type env)) + (some-> (cljs-ana/find-var @!a sym (get-ns env)) ::cljs-ana/name) + (do (serialized-require (ns-name *ns*)) + (some-> (resolve env sym) symbol)))) + +(defn expand-macro [env o] + (let [[f & args] o, n (name f), e (dec (count n))] + (cond (= "." n) o + (and (not= ".." n) (= \. (nth n e))) `(new ~(symbol (namespace f) (subs n 0 e)) ~@args) + (re-find #"^\.[^.]" n) (list* '. (first args) (symbol (subs n 1)) (rest args)) + (= :cljs (->peer-type 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) + :else (macroexpand-clj o env)))) + +(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] + (if (instance? clojure.lang.IObj o) + (cond-> o (meta metao) (vary-meta #(merge (meta metao) %))) + o)) + +(declare -expand-all -expand-all-foreign -expand-all-foreign-try) + +(defn traceable [f] (case (namespace f) ("hyperfiddle.electric.impl.runtime3" "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 js-uppercase-sym? [sym] (re-matches #"^js/(Math|String).*$" (str sym))) + +(defn electric-sym? [sym] + (let [s (name sym)] + (and (pos? (.length s)) + (Character/isUpperCase (.charAt s 0)) + (not (re-matches #"G__\d+" s)) ; default gensym generated symbols + (not (js-uppercase-sym? sym)) + (not= 'RCF__tap sym)))) + +(defn ?expand-macro [o env caller] + (if (symbol? (first o)) + (let [o2 (?meta o (expand-macro env o))] + (if (identical? o o2) + (if (electric-sym? (first o)) + (recur (?meta o (cons `e/$ o)) env caller) + (?meta o (cond->> (?meta o (list* (first o) (mapv (fn-> caller env) (rest o)))) + (and (or (::trace env) (::e/trace env)) (some-> (qualify-sym (first o) env) (traceable))) + (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)))))) + +(defmacro $ [F & args] + `(::call ((::static-vars r/dispatch) '~F ~F ~@(map (fn [arg] `(::pure ~arg)) args)))) + +(defn -expand-let-bindings [bs env] + (loopr [bs2 [], env2 env] + [[sym v] (eduction (partition-all 2) bs)] + (recur (conj bs2 sym (-expand-all-foreign v env2)) (add-local env2 sym)))) + +(defn jvm-type? [sym] (try (.getJavaClass (clojure.lang.Compiler$VarExpr. nil sym)) (catch Throwable _))) + +(declare analyze-cljs-symbol) + +(def base-js-types '#{objects ints longs floats doubles chars shorts bytes booleans + int long float double char short byte + clj-nil any? + js/Object object js/String string js/Array array + js/Number number js/Function function js/Boolean boolean}) +(defn js-type-hint? [sym] (or (= 'js sym) (= "js" (namespace sym)))) +(defn js-type? [sym env] (or (contains? base-js-types sym) (js-type-hint? sym) (analyze-cljs-symbol sym env))) + +(defn- replace-incompatible-type-hint [sym] + (vary-meta sym update :tag #(keyword "electric.unresolved" (name %)))) + +(defn ?untag [sym env] + (if-some [tag (keep-if (-> sym meta :tag) symbol?)] + (case (->env-type env) + (:clj) (cond-> sym (not (jvm-type? tag)) replace-incompatible-type-hint) + (:cljs) (cond-> sym (not (js-type? tag env)) replace-incompatible-type-hint)) + sym)) + +(defn -expand-fn-arity [[bs & body :as o] env] + (let [bs (mapv #(?untag % env) bs)] + (?meta o (list bs (-expand-all-foreign (?meta body (cons 'do body)) (reduce add-local env bs)))))) + +(defn -expand-all-foreign [o env] + (cond + (and (seq? o) (seq o)) + (if (find-local-entry env (first o)) + (?meta o (list* (first o) (mapv (fn-> -expand-all-foreign env) (rest o)))) + (case (first o) + (do) (if (nnext o) + (?meta o (cons 'do (eduction (map (fn-> -expand-all-foreign env)) (next o)))) + (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* loop*) (let [[call bs & body] o, [bs2 env2] (-expand-let-bindings bs env)] + (?meta o (list call bs2 (-expand-all-foreign (?meta body (cons 'do body)) env2)))) + + (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 (list* (into (if ?name ['fn* ?name] ['fn*]) (map (fn-> -expand-fn-arity env)) arities)))) + + (letfn*) (let [[_ bs & body] o + env2 (reduce add-local env (eduction (take-nth 2) bs)) + bs2 (->> bs (into [] (comp (partition-all 2) + (mapcat (fn [[sym v]] [sym (-expand-all-foreign v env2)])))))] + (?meta o `(letfn* ~bs2 ~(-expand-all-foreign (cons 'do body) env2)))) + + (try) (list* 'try (mapv (fn-> -expand-all-foreign-try env) (rest o))) + + (set!) (let [[_ t v] o] (list 'set! + (-expand-all-foreign t (dissoc env ::trace)) + (-expand-all-foreign v 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-foreign v env)]))) bs) + (-expand-all-foreign (cons 'do body) env)))) + + #_else (?expand-macro o env -expand-all-foreign))) + + (instance? cljs.tagged_literals.JSValue o) + (cljs.tagged_literals.JSValue. (-expand-all-foreign (.-val ^cljs.tagged_literals.JSValue o) env)) + + (map-entry? o) (clojure.lang.MapEntry. (-expand-all-foreign (key o) env) (-expand-all-foreign (val o) env)) + (coll? o) (?meta (meta o) (into (empty o) (map (fn-> -expand-all-foreign env)) o)) + :else o)) + +(defn -expand-all-foreign-try [o env] + (if (seq? o) + (if (find-local-entry env (first o)) + (?meta o (list* (first o) (mapv (fn-> -expand-all-foreign env) (rest o)))) + (case (first o) + (catch) (let [[_ typ sym & body] o] + (list* 'catch typ sym (mapv (fn-> -expand-all-foreign (add-local env sym)) body))) + #_else (-expand-all-foreign o env))) + (-expand-all-foreign o env))) + +(defn -expand-all [o env] + (cond + (and (seq? o) (seq o)) + (if (find-local-entry env (first o)) + (if (electric-sym? (first o)) + (recur (?meta o (cons `$ o)) env) + (?meta 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 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] (loopr [bs2 [] , env2 env] + [[sym v] (eduction (partition-all 2) bs)] + (let [sym (?untag sym env2)] + (recur (conj bs2 sym (-expand-all v env2)) (add-local env2 sym))))] + (?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 `(::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 `(::call (r/bind-args (::lookup :recur) ~@(map (fn [arg] `(::pure ~arg)) (next o))))) env) + + (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))))))) + + (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 + + (fn*) (-expand-all-foreign o (dissoc env ::electric)) + + (letfn*) (let [[_ bs & body] o + env2 (reduce add-local env (take-nth 2 bs)) + bs2 (->> bs (into [] (comp (partition-all 2) + (mapcat (fn [[sym v]] [sym (-expand-all-foreign v 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))) + + (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) + (-expand-all (cons 'do body) env)))) + + (set!) (recur (?meta o `((fn* [v#] (set! ~(nth o 1) v#)) ~(nth o 2))) env) + + (::ctor) (?meta o (list ::ctor (list ::site nil (-expand-all (second o) env)))) + + (::site) (?meta o (seq (conj (into [] (take 2) o) + (-expand-all (cons 'do (drop 2 o)) (assoc env ::current (second o)))))) + + #_else (?expand-macro o env -expand-all))) + + (instance? cljs.tagged_literals.JSValue o) + (cljs.tagged_literals.JSValue. (-expand-all (.-val ^cljs.tagged_literals.JSValue 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)) + +#_(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))) + +(defn expand-all [env o] + (cljs-ana/analyze-nsT !a env (get-ns env)) + (-expand-all o (assoc env ::electric true))) + +;;;;;;;;;;;;;;;; +;;; COMPILER ;;; +;;;;;;;;;;;;;;;; + +(defn fail! + ([env msg] (fail! env msg {})) + ([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)) + +(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 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 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-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? (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] + (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 node? [mt] (::node 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))) + :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) + {::type ::static, ::sym sym} + (when-some [v (some-> (find-ns ns$) (ns-resolve sym))] + (if (var? v) {::type ::var, ::sym (symbol v) ::meta (meta v)} {::type ::static, ::sym sym})))) + +(def implicit-cljs-nses '#{goog goog.object goog.string goog.array Math String}) + +(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)), ::meta (::cljs-ana/meta v)} + (if-some [quald (when (qualified-symbol? sym) (cljs-ana/ns-qualify @!a sym (get-ns env)))] + {::type ::static, ::sym quald} + (if (or (cljs-ana/referred? @!a sym (get-ns env)) (cljs-ana/js-call? @!a sym (get-ns env))) + {::type ::static, ::sym sym} + (when (cljs-ana/imported? @!a sym (get-ns env)) + {::type ::static, ::sym sym}))))) + +(defn resolve-symbol [sym env] + (if-some [local (-> env :locals (get sym))] + (if-some [uid (::electric-let local)] + {::lang nil, ::type ::localref, ::sym sym, ::ref uid} + {::lang nil, ::type ::local, ::sym sym}) + (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 (let [v (analyze-cljs-symbol sym env)] + (case v nil (cannot-resolve! env sym) #_else (assoc v ::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 (or (analyze-cljs-symbol sym env) {::type ::var, ::sym `r/cannot-resolve}) + :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))) + + +(defn get-ret-e [ts e] + (let [nd (get (:eav ts) e)] + (case (::type nd) + (::bindlocal) (recur ts (->bindlocal-body-e ts e)) + (::site ::mklocal) (recur ts (get-child-e ts e)) + #_else e))) + +(defn find-sitable-point-e [ts e] + (loop [e e] + (when-some [nd (ts/->node ts e)] + (case (::type nd) + (::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 {}))))))) + +(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) + #_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)] + (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)) + +(declare analyze analyze-foreign wrap-foreign-for-electric) + +(defn add-literal [{{::keys [->id]} :o :as ts} v e pe] + (-> ts (ts/add {:db/id e, ::parent pe, ::type ::pure}) + (ts/add {:db/id (->id), ::parent e, ::type ::literal, ::v v}))) + +(defn add-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)}) + #_(add-literal f ce e) + (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 [f (let [margs (repeatedly (count method-args) gensym), meth (symbol (str clazz) (str method))] + `(fn [~@margs] (~meth ~@margs)))] + (add-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}))))) + +(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)] + (?untag (with-meta g (merge mt (meta k))) env))) + +(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)))] + (add-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*) + assoc-in [:cljs.analyzer/namespaces ns :defs sym] {:name sym})) + +(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))) + +(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 field-access? [sym] (str/starts-with? (str sym) "-")) + +(defn analyze [form pe env {{::keys [->id ->uid]} :o :as ts}] + (let [env (?update-meta env form)] + (cond + (and (seq? form) (seq form)) + (case (first form) + (let*) (let [[_ bs bform] form] + (recur (?meta form + (reduce (fn [ac [k v]] + (let [g (with-meta (gensym k) (meta 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) + 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 {}] + [[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 [current (get (::peers env) (::current env)) + [f & arg*] (wrap-foreign-for-electric (analyze-foreign form env))] + (if (or (nil? current) (= (->env-type env) current)) + (if f + (add-ap-literal f arg* pe (->id) env ts) + (add-literal ts form (->id) pe)) + (recur `[~@arg*] pe env ts))) + (::cc-letfn) (let [current (get (::peers env) (::current env)) + [_ bs] form, lfn* `(letfn* ~bs ~(vec (take-nth 2 bs))), e (->id) + [f & arg*] (wrap-foreign-for-electric (analyze-foreign lfn* env))] + (if (or (nil? current) (= (->env-type env) current)) + (if f + (add-ap-literal f arg* pe e env (?add-source-map ts e form)) + (add-literal ts lfn* e pe)) + (recur `[~@arg*] pe env ts))) + (new) (let [[_ f & args] form] + (if (my-turn? env) + (let [f (case (->env-type env) + :clj (if (and (symbol? f) (jvm-type? f)) f 'Object) + :cljs (if (and (symbol? f) (js-type? f env)) f 'js/Object)) + f (let [gs (repeatedly (count args) gensym)] `(fn [~@gs] (new ~f ~@gs)))] + (add-ap-literal f args pe (->id) env ts)) + (recur `[~@args] pe env ts))) + ;; (. 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) + (.) (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)) + + (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) + (if (field-access? x) + (add-ap-literal `(fn [oo#] (. oo# ~x)) [o] pe (->id) env ts) + (->obj-method-call o x [] pe 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)))] + (::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)) + (add-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 (second form) + 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, ::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 [pure (with-meta (gensym "pure") {::dont-inline true})] + (recur `(let* [~pure ~(second form)] (::pure-gen ~pure)) pe env ts)) + (::pure-gen) (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, current (::current env), env2 (assoc env ::current site)] + (if (or (nil? site) (= site current) (= ::bindlocal (::type (ts/->node ts pe)))) + (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. + (let [g (gensym "site-local")] + (recur `(::mklocal ~g (::bindlocal ~g ~form ~g)) pe env2 ts)))) + (::frame) (let [e (->id)] (-> ts + (ts/add {:db/id e, ::parent pe, ::type ::pure}) + (ts/add {:db/id (->id), ::parent e, ::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) + (::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?)) + (add-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)] + (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) + (::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})) + (::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})) + (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 add-foreign-local [env sym] (update env :locals update sym assoc ::electric-let nil)) + +(defn ->->id [] (let [!i (long-array [-1])] (fn [] (aset !i 0 (unchecked-inc (aget !i 0)))))) + +(defn addf [{{::keys [->id]} :o :as ts} u p ->i more] + (ts/add ts (assoc more :db/id (->id), ::u u, ::p p, ::i (->i)))) + +(defn- add-invoke [{{::keys [->u]} :o :as ts} form env p ->i] + (let [ap-u (->u), ->ap-i (->->id)] + (reduce (fn [ts nx] (analyze-foreign ts nx env ap-u ->ap-i)) + (addf ts ap-u p ->i {::t ::invoke}) form))) + +(defn analyze-foreign + ([form env] (analyze-foreign (ts/->ts {::->id (->->id), ::->u (->->id)}) form env -1 (->->id))) + ([{{::keys [->u]} :o :as ts} form env p ->i] + (cond (and (seq? form) (seq form)) + (case (first form) + (let* loop*) + (let [[l bs & body] form, let*-u (->u) + ts (addf ts let*-u p ->i {::t (case l (let*) ::let* (loop*) ::loop*)}) + ->sym-i (->->id) + [ts2 env2] (loopr [ts2 ts, env2 env] + [[sym v] (eduction (partition-all 2) bs)] + (let [sym-u (->u)] + (recur (-> ts2 (addf sym-u let*-u ->sym-i {::t ::let*-sym, ::sym sym}) + (analyze-foreign v env2 sym-u (->->id))) + (add-foreign-local env2 sym)))) + body-u (->u), ->body-i (->->id)] + (reduce (fn [ts nx] (analyze-foreign ts nx env2 body-u ->body-i)) + (addf ts2 body-u let*-u (->->id) {::t ::body}) body)) + + (binding clojure.core/binding) + (let [[_ bs & body] form, bind-u (->u) + ts (addf ts bind-u p ->i {::t ::binding}) + ->sym-i (->->id) + ts (reduce (fn [ts [sym v]] + (let [sym-u (->u)] + (-> ts (addf sym-u bind-u ->sym-i {::t ::binding-sym, ::sym sym}) + (analyze-foreign v env sym-u (->->id))))) + ts (eduction (partition-all 2) bs)) + body-u (->u), ->body-i (->->id)] + (reduce (fn [ts nx] (analyze-foreign ts nx env body-u ->body-i)) + (addf ts body-u bind-u (->->id) {::t ::body}) body)) + + (quote) (addf ts (->u) p ->i {::t ::quote, ::v form}) + + (fn*) (let [[?name arity+] (if (symbol? (second form)) [(second form) (nnext form)] [nil (next form)]) + env2 (cond-> env ?name (add-foreign-local ?name)) + fn*-u (->u), ->arity-i (->->id) + ts (addf ts fn*-u p ->i (cond-> {::t ::fn*} ?name (assoc ::name ?name)))] + (reduce (fn [ts [args & body]] + (let [arity-u (->u), ->body-i (->->id) + ts (addf ts arity-u fn*-u ->arity-i {::t ::fn*-arity, ::args args}) + env3 (reduce add-foreign-local env2 args)] + (reduce (fn [ts nx] (analyze-foreign ts nx env3 arity-u ->body-i)) ts body))) + ts arity+)) + + (letfn*) (let [[_ bs & body] form + env (reduce add-foreign-local env (eduction (take-nth 2) bs)) + letfn*-u (->u), ->fn-i (->->id) + ts (addf ts letfn*-u p ->i {::t ::letfn*}) + ts (reduce (fn [ts f] (analyze-foreign ts f env letfn*-u ->fn-i)) + ts (eduction (take-nth 2) (next bs))) + body-u (->u), ->body-i (->->id)] + (reduce (fn [ts nx] (analyze-foreign ts nx env body-u ->body-i)) + (addf ts body-u letfn*-u ->i {::t ::body}) body)) + + (.) (cond (and (symbol? (second form)) + (or (implicit-cljs-nses (second form)) + (class? (resolve env (second form))))) + ;; (. Instant (ofEpochMilli 1)) vs. (. Instant ofEpochMilli 1) + (let [[method & args] (if (symbol? (nth form 2)) (drop 2 form) (nth form 2)) + class-u (->u), ->class-i (->->id)] + (reduce (fn [ts nx] (analyze-foreign ts nx env class-u ->class-i)) + (addf ts class-u p ->i {::t ::class-method-call, ::class (second form), ::method method}) + args)) + + (and (empty? (drop 3 form)) (symbol? (nth form 2))) ; (. pt x) + (let [x (nth form 2)] + (if (field-access? x) + (let [field-u (->u)] + (recur (addf ts field-u p ->i {::t ::field-access, ::field (nth form 2)}) + (second form) env field-u (->->id))) + (let [method-u (->u)] + (recur (addf ts method-u p ->i {::t ::method-call, ::method x}) + (second form) env method-u (->->id))))) + + :else ; (. i1 isAfter i2) vs. (. i1 (isAfter i2)) + (let [[method & args] (if (symbol? (nth form 2)) (drop 2 form) (nth form 2)) + method-u (->u), ->method-i (->->id)] + (reduce (fn [ts nx] (analyze-foreign ts nx env method-u ->method-i)) + (addf ts method-u p ->i {::t ::method-call, ::method method}) + (cons (second form) args)))) + + (def) (let [u (->u)] + (recur (addf ts u p ->i {::t ::def, ::sym (second form)}) (nth form 2) env u (->->id))) + + (set!) (let [set-u (->u), ->set-i (->->id)] + (reduce (fn [ts nx] (analyze-foreign ts nx env set-u ->set-i)) + (addf ts set-u p ->i {::t ::set!}) (next form))) + + (new) (let [new-u (->u), ->new-i (->->id)] + (reduce (fn [ts nx] (analyze-foreign ts nx env new-u ->new-i)) + (addf ts new-u p ->i {::t ::new}) (next form))) + + (do) (let [do-u (->u), ->do-i (->->id)] + (reduce (fn [ts nx] (analyze-foreign ts nx env do-u ->do-i)) + (addf ts do-u p ->i {::t ::do}) (next form))) + + (js*) (let [js*-u (->u), ->js*-i (->->id)] + (reduce (fn [ts nx] (analyze-foreign ts nx env js*-u ->js*-i)) + (addf ts js*-u p ->i {::t ::js*}) (next form))) + + (try) (let [try-u (->u), ->try-i (->->id)] + (reduce (fn [ts nx] (analyze-foreign ts nx env try-u ->try-i)) + (addf ts try-u p ->i {::t ::try}) (next form))) + + (catch) (if (= ::try (::t (ts/->node ts p))) + (let [[_ typ sym & body] form + cu (->u), ->c-i (->->id)] + (reduce (fn [ts nx] (analyze-foreign ts nx (add-foreign-local env sym) cu ->c-i)) + (addf ts cu p ->i {::t ::catch, ::ex-type typ, ::sym sym}) body)) + (add-invoke ts form env p ->i)) + + (finally) (if (= ::try (::t (ts/->node ts (ts/find1 ts ::p p)))) + (let [fu (->u), ->f-i (->->id)] + (reduce (fn [ts nx] (analyze-foreign ts nx env fu ->f-i)) + (addf ts fu p ->i {::t ::finally}))) + (add-invoke ts form env p ->i)) + + (if) (let [if-u (->u), ->if-i (->->id)] + (reduce (fn [ts nx] (analyze-foreign ts nx env if-u ->if-i)) + (addf ts if-u p ->i {::t ::if}) (next form))) + + (var) (let [u (->u)] (recur (addf ts u p ->i {::t ::builtin-var}) (second form) env u (->->id))) + + (throw) (let [u (->u)] (recur (addf ts u p ->i {::t ::throw}) (second form) env u (->->id))) + + (recur) (let [u (->u), ->id (->->id)] + (reduce (fn [ts nx] (analyze-foreign ts nx env u ->id)) + (addf ts u p ->i {::t ::recur}) (next form))) + + #_else (add-invoke ts form env p ->i)) + + (instance? cljs.tagged_literals.JSValue form) + (let [o (.-val ^cljs.tagged_literals.JSValue form)] + (if (map? o) + (let [map-u (->u), ->map-i (->->id)] + (reduce (fn [ts nx] (analyze-foreign ts nx env map-u ->map-i)) + (addf ts map-u p ->i {::t ::js-map}) (eduction cat o))) + (let [vec-u (->u), ->vec-i (->->id)] + (reduce (fn [ts nx] (analyze-foreign ts nx env vec-u ->vec-i)) + (addf ts vec-u p ->i {::t ::js-array}) o)))) + + (map? form) (let [map-u (->u), ->map-i (->->id)] + (reduce (fn [ts nx] (analyze-foreign ts nx env map-u ->map-i)) + (addf ts map-u p ->i {::t ::map}) (eduction cat form))) + + (set? form) (let [set-u (->u), ->set-i (->->id)] + (reduce (fn [ts nx] (analyze-foreign ts nx env set-u ->set-i)) + (addf ts set-u p ->i {::t ::set}) form)) + + (vector? form) (let [vector-u (->u), ->vector-i (->->id)] + (reduce (fn [ts nx] (analyze-foreign ts nx env vector-u ->vector-i)) + (addf ts vector-u p ->i {::t ::vector}) form)) + + (symbol? form) (let [ret (resolve-symbol form env)] + (case (::type ret) + (::localref) (addf ts (->u) p ->i + {::t ::electric-local, ::sym form + ::resolved (::sym ret), ::ref (::ref ret)}) + (::local) (addf ts (->u) p ->i + {::t ::local, ::sym form, ::resolved (::sym ret)}) + (::static) (addf ts (->u) p ->i + {::t ::static, ::sym form, ::resolved (::sym ret)}) + (::self ::node) (throw (ex-info "Cannot pass electric defns to clojure(script) interop" + {:var form})) + (::var) (addf ts (->u) p ->i + {::t ::var, ::sym form ::resolved (::sym ret), ::meta (::meta ret)}) + #_else (throw (ex-info (str "unknown symbol type " (::type ret)) (or ret {}))))) + + :else (addf ts (->u) p ->i {::t ::literal, ::v form})))) + +(defn emit-foreign + ([ts] (emit-foreign ts (::u (ts/->node ts (ts/find1 ts ::p -1))))) + ([ts u] + (letfn [(->node [u] (ts/->node ts (ts/find1 ts ::u u))) + (e->u [e] (::u (ts/->node ts e))) + (order [u*] (sort-by (comp ::i ->node) u*)) + (find [& kvs] (order (eduction (map e->u) (apply ts/find ts kvs)))) + (find1 [& kvs] (e->u (apply ts/find1 ts kvs))) + (? [u k] (get (->node u) k)) + (emit-foreign-arity [u] (cons (? u ::args) (eduction (map emit) (find ::p u)))) + (unname [v] (cond-> v (instance? clojure.lang.Named v) name)) + (emit-1 [sym u] (list sym (find1 ::p u))) + (emit-n [sym u] (list* sym (eduction (map emit) (find ::p u)))) + (emit [u] + (let [nd (->node u)] + (case (::t nd) + (::let*) (let [{sym* ::let*-sym, body ::body} (group-by #(? % ::t) (find ::p u))] + (list* 'let* (into [] (mapcat (fn [u] [(? u ::sym) (emit (find1 ::p u))])) sym*) + (eduction (map emit) (find ::p (first body))))) + (::loop*) (let [{sym* ::let*-sym, body ::body} (group-by #(? % ::t) (find ::p u))] + (list* 'loop* (into [] (mapcat (fn [u] [(? u ::sym) (emit (find1 ::p u))])) sym*) + (eduction (map emit) (find ::p (first body))))) + (::binding) (let [{sym* ::binding-sym, body ::body} (group-by #(? % ::t) (find ::p u))] + (list* 'binding (into [] (mapcat (fn [u] [(? u ::sym) (emit (find1 ::p u))])) sym*) + (eduction (map emit) (find ::p (first body))))) + (::quote) (::v nd) + (::literal) (::v nd) + (::fn*) (list* (into (cond-> ['fn*] (::name nd) (conj (::name nd))) + (map emit-foreign-arity (find ::t ::fn*-arity, ::p u)))) + (::letfn*) (let [{f* ::fn*, body ::body} (group-by #(? % ::t) (find ::p u))] + (list* 'letfn* (into [] (mapcat (fn [u] [(? u ::name) (emit u)])) f*) + (eduction (map emit) (find ::p (first body))))) + ;; (Math/abs -1) expands to (. Math abs -1) but the dot form fails on cljs + ;; so we generate (Math/abs -1) + (::class-method-call) (list* (symbol (str (::class nd)) (str (::method nd))) + (eduction (map emit) (find ::p u))) + (::field-access) (list '. (emit (find1 ::p u)) (::field nd)) + (::method-call) (let [[o & arg*] (find ::p u)] + (list* '. (emit o) (::method nd) (eduction (map emit) arg*))) + (::def) (list 'def (? u ::sym) (emit (find1 ::p u))) + (::set!) (emit-n 'set! u) + (::new) (emit-n 'new u) + (::do) (emit-n 'do u) + (::try) (emit-n 'try u) + (::catch) (list* 'catch (::ex-type nd) (::sym nd) (eduction (map emit) (find ::p u))) + (::finally) (emit-n 'finally u) + (::throw) (emit-1 'throw u) + (::if) (emit-n 'if u) + (::builtin-var) (emit-1 'var u) + (::recur) (emit-n 'recur u) + (::js*) (emit-n 'js* u) + (::invoke) (map emit (find ::p u)) + (::js-map) (list* 'js-object (eduction (map emit) (map unname) (find ::p u))) + (::js-array) (list* 'array (eduction (map emit) (map unname) (find ::p u))) + (::map) (apply hash-map (eduction (map emit) (find ::p u))) + (::set) (set (eduction (map emit) (find ::p u))) + (::vector) (vec (eduction (map emit) (find ::p u))) + (::electric-local ::local ::static ::var) (::sym nd))))] + (emit u)))) + +(defn wrap-foreign-for-electric + ([ts] (wrap-foreign-for-electric ts gensym)) + ([ts gen] + (letfn [(->node [u] (ts/->node ts (ts/find1 ts ::u u))) + (e->u [e] (::u (ts/->node ts e))) + (order [u*] (sort-by (comp ::i ->node) u*)) + (find [& kvs] (order (eduction (map e->u) (apply ts/find ts kvs)))) + (? [u k] (get (->node u) k))] + (let [[ts arg* val* dyn*] + (loopr [ts ts, arg* [], val* [], dyn* [], seen {}] + [u (remove #(let [nd (->node %)] (and (zero? (::i nd)) + (not= -1 (::p nd)) + (= ::set! (? (::p nd) ::t)))) + (find ::t ::var))] + (let [nd (->node u), r (::resolved nd), s (::sym nd)] + (if (:dynamic (::meta nd)) + (if (seen r) + (recur ts arg* val* dyn* seen) + (let [lex (gen (name r))] + (recur ts (conj arg* lex) (conj val* r) (into dyn* [s lex]) (assoc seen r true)))) + (if-some [lex (seen r)] + (recur (ts/asc ts (:db/id nd) ::sym lex) arg* val* dyn* seen) + (let [lex (gen (name s))] + (recur (ts/asc ts (:db/id nd) ::sym lex) + (conj arg* lex) (conj val* r) dyn* (assoc seen r lex))))))) + code (cond->> (emit-foreign ts) (seq dyn*) (list 'binding dyn*)) + e-local* (into [] (comp (map #(? % ::sym)) (distinct)) (find ::t ::electric-local))] + (when (or (seq arg*) (seq e-local*)) + (list* (list 'fn* (into arg* e-local*) code) (into val* e-local*))))))) + +(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- ts->reducible* [ts f init] + (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] + (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 ->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)] + (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/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 ((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] + (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 (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))) + ::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 "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) (->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)) + (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-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-uid] + (->> (ts/find ts ::ctor-node ctor-uid) (sort-by #(::node-idx (ts/->node ts %))))) + +(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) + ts + (do (vswap! seen conj e) + (case (::type nd) + (::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) (-> 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-program-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)) + 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 (->localv-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 (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 + ;; (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] + (let [seen (volatile! #{}) + ret (volatile! (sorted-set)) + 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 ::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)) + (::localref) (recur ts (->> (::ref nd) (->localv-e ts) (get-ret-e ts))) + (::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] + (let [nd (get (:eav ts) e)] + (case (::type nd) + ::ap (map rec (get-children-e ts e)) + (::pure ::site) (rec (get-child-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))) + ::localref (recur (->> (::ref nd) (->localv-e ts) (get-ret-e ts)))))) + e)) + +(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))) + +(def pure-fns '#{clojure.core/vector clojure.core/hash-map clojure.core/get clojure.core/boolean + hyperfiddle.electric.impl.runtime3/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)] + (-> 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 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)))) + collapse-ap-with-only-pures + (fn collapse-ap-with-only-pures [ts] + (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) + (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 (eduction (map #(e->uid ts %)) (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 ::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)) + (::ctor) (if (::ctor-idx nd) + ts + (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-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] + (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 #(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 #(::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 %))))) + 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 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] + (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))) + 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 ::frame) ts + (::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) + (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 (= mklocal-e e) + ac + (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) + ts (cond-> ts (::dont-inline (meta (::k mklocal-nd))) + (ensure-node mklocal-uid)) + 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)) + (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-local-site 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 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! #{}) + 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 ::ctor ::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)) + (::call) (if (::ctor-call nd) + ts + (-> (mark-used-calls ts ctor-e (get-child-e ts 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))] + (recur ts (find-ctor-e ts nx-e) nx-e)) + #_else (throw (ex-info (str "cannot mark-used-calls on " (::type nd)) (or nd {}))))))) + 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)))) + 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)) + +(defn compile* [nm env ts] + (let [ts (analyze-electric env ts) + ret `(fn + ([] {0 (r/ctor ~nm 0)}) + ([idx#] + (case idx# + ~@(->> (get-ordered-ctors-e ts) + (map #(emit-ctor ts % env nm)) + (interleave (range))))))] + (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)})) + +(defn compile [nm form env] + (compile* nm env + (analyze (expand-all env `(::ctor ~form)) + '_ env (->ts)))) + +(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)) + 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))) + ([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)) + source)) diff --git a/src/hyperfiddle/electric/impl/lang3.cljs b/src/hyperfiddle/electric/impl/lang3.cljs new file mode 100644 index 000000000..59b0402a4 --- /dev/null +++ b/src/hyperfiddle/electric/impl/lang3.cljs @@ -0,0 +1,2 @@ +(ns hyperfiddle.electric.impl.lang3) + diff --git a/src/hyperfiddle/electric/impl/lang_3_walkthrough.md b/src/hyperfiddle/electric/impl/lang_3_walkthrough.md new file mode 100644 index 000000000..baf5692b0 --- /dev/null +++ b/src/hyperfiddle/electric/impl/lang_3_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. diff --git a/src/hyperfiddle/electric/impl/local.cljc b/src/hyperfiddle/electric/impl/local.cljc deleted file mode 100644 index 14caa3f70..000000000 --- a/src/hyperfiddle/electric/impl/local.cljc +++ /dev/null @@ -1,17 +0,0 @@ -(ns hyperfiddle.electric.impl.local - #?(:cljs (:require-macros [hyperfiddle.electric.impl.local :refer [local get-local set-local with-local]]))) - -(defmacro local [] - (if (:js-globals &env) `(volatile! nil) `(ThreadLocal.))) - -(defmacro get-local [l] - (if (:js-globals &env) `(deref ~l) `(.get ~(with-meta l (assoc (meta l) :tag `ThreadLocal))))) - -(defmacro set-local [l x] - (if (:js-globals &env) `(vreset! ~l ~x) `(doto ~x (->> (.set ~(with-meta l (assoc (meta l) :tag `ThreadLocal))))))) - -(defmacro with-local [l i & body] - `(let [prev# (get-local ~l)] - (set-local ~l ~i) - (try [(do ~@body) (get-local ~l)] - (finally (set-local ~l prev#))))) diff --git a/src/hyperfiddle/electric/impl/mount_point.cljc b/src/hyperfiddle/electric/impl/mount_point.cljc new file mode 100644 index 000000000..85ab6b5a7 --- /dev/null +++ b/src/hyperfiddle/electric/impl/mount_point.cljc @@ -0,0 +1,800 @@ +(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] + [hyperfiddle.incseq.perm-impl :as p] + [hyperfiddle.electric.impl.runtime3 :as r]) + #?(:clj (:import (clojure.lang IFn IDeref) + (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 +;; prevent state reset on root-up + +(def slot-lock 0) +(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-call-queue 3) +(def reader-slot-item-queue 4) +(def reader-slot-root 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] + #?(: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 + (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)] + (loop [index index + offset 0] + (if (zero? index) + offset + (let [index (dec index)] + (recur index + (if-some [block (aget buffer index)] + (unchecked-add-int offset + (block-weight block)) + offset))))))) + +(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 + 1 o + (recur (if (even? i) + o (unchecked-add o + (aget weights (unchecked-dec i)))) + (bit-shift-right i 1)))))) + +(defn call-index [^objects block id] + (loop [^objects block block + id id + offset 0] + (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 bi (aget buffer i) + ^objects bj (aget buffer j)] + (aset buffer i bj) + (aset buffer j bi) + (when-not (nil? bi) + (aset bi block-slot-index j)) + (when-not (nil? bj) + (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 [^objects call (aget reader reader-slot-root)] + (aget call call-slot-weight) 0)) + +(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] + (update-local-weights (aget block block-slot-weights) id delta) + (when-not (nil? (aget block block-slot-index)) + (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 [^objects item diff] + (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 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)] + (aset block block-slot-index nil) + (aset buffer i nil) + (block-release 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) + ^objects state (aget reader reader-slot-state)] + (aset reader reader-slot-alive + (inc (aget reader reader-slot-alive))) + (aset call call-slot-process + ((if-some [slot (call-slot call)] + (r/incseq (r/peer-root-frame (aget state slot-peer)) 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-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)] + (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 diff] + (let [^objects reader (aget call call-slot-reader) + ^objects root (aget reader reader-slot-root)] + (if (nil? (aget call call-slot-process)) + (let [^objects block (aget root call-slot-parent)] + (loop [^objects block block] + (let [^objects parent (aget block block-slot-parent)] + (call-spawn parent) + (if (nil? (aget call call-slot-process)) + (recur (aget parent call-slot-parent)) + (aset reader reader-slot-root parent)))) + (update-local-weights (aget block block-slot-weights) + (r/slot-id (call-slot root)) (call-weight root)) + (d/combine diff + {:grow 0 + :degree (aget root call-slot-weight) + :shrink (aget root call-slot-weight) + :permutation {} + :change {} + :freeze #{}})) + diff))) + +(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-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)] + (aset block block-slot-prev prev) + (aset block block-slot-next next) + (aset prev block-slot-next block) + (aset next block-slot-prev block))) + +(defn block-attach-to-tree [^objects block ^objects reader diff] + (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)] + (do (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))) + (when (nil? (aget parent block-slot-prev)) + (block-attach-to-call parent)) + (root-up (aget parent block-slot-parent) diff)) + (let [parent (make-block reader frame) + call (make-call reader block)] + (call-attach-to-block call parent) + (call-spawn call) + (recur parent)))))) + +(defn item-attach-to-block [^objects item ^objects block id diff] + (let [^objects call (aget block block-slot-parent) + ^objects reader (aget call call-slot-reader) + size-before (current-size reader)] + (block-set-child block id 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 item-attach-to-tree [^objects item ^objects reader diff] + (let [tag (aget item item-slot-tag) + frame (r/tag-frame tag) + id (r/tag-index tag)] + (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) + (item-attach-to-block item block id diff)) + (if-some [block (get-block reader frame)] + (do (when (nil? (aget block block-slot-prev)) + (block-attach-to-call block)) + (item-attach-to-block item block id diff)) + (let [block (make-block reader frame)] + (->> diff + (block-attach-to-tree block reader) + (item-attach-to-block item block id))))))) + +(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 id] + (let [^objects call (aget block block-slot-parent) + ^objects parent (aget call call-slot-parent)] + (block-set-child block id 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) + (when-not (nil? parent) + (recur parent (r/slot-id (r/frame-slot (aget block block-slot-frame))))))) + +(defn item-detach-from-tree [^objects item diff] + (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) + slot (r/frame-slot (aget block block-slot-frame))] + (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) + (when-not (nil? parent) + (detach-root parent (r/slot-id slot)))) + (do (block-set-child parent (r/slot-id slot) 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 diff] + (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) + i1 (block-index call k1) + i2 (block-index call k2) + w1 (if-some [b (aget buffer k1)] + (block-weight b) 0) + w2 (if-some [b (aget buffer k2)] + (block-weight b) 0)] + (swap-indices call i j) + (recur (p/compose p (p/cycle i j)) + (if (nil? i1) + q (if (nil? i2) + q (p/compose (p/split-long-swap i1 w1 (- i2 i1 w1) w2) + q)))))))] + (d/combine diff + {:grow 0 + :degree degree + :shrink 0 + :permutation permutation + :change {} + :freeze #{}}))) + +(defn block-unmount [^objects block diff] + (let [^objects call (aget block block-slot-parent) + ^objects reader (aget call call-slot-reader) + ^objects buffer (aget call call-slot-buffer) + shrink (block-weight block) + i (aget block block-slot-index)] + (aset block block-slot-index nil) + (aset buffer i nil) + (if (nil? (aget block block-slot-prev)) + (block-release block) + (call-update-weights call (- shrink))) + (if-some [index (block-index call i)] + (let [size-after (current-size reader)] + (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))) + +(defn block-mount [^objects block offset diff] + (let [frame (aget block block-slot-frame)] + (loop [i 0 + o offset + d diff] + (if (< i (r/frame-call-count frame)) + (if (nil? (r/frame-call frame i)) + (if-some [^objects item (block-child block i)] + (recur (inc i) (inc o) + (let [size-before (- (:degree d) (:shrink d))] + (d/combine d + {:grow 1 + :degree (inc size-before) + :shrink 0 + :permutation (p/rotation size-before o) + :change {o (aget item item-slot-state)} + :freeze #{}}))) + (recur (inc i) o d)) + (if-some [^objects call (block-child block i)] + (let [^objects buffer (aget call call-slot-buffer)] + (recur (inc i) (+ o (aget call call-slot-weight)) + (loop [i 0 + o o + d d] + (if (< i (alength buffer)) + (if-some [^objects block (aget buffer i)] + (let [w (block-weight block)] + (recur (inc i) (+ o w) + (if (pos? w) (block-mount block o d) d))) + d) d)))) + (recur (inc i) o d))) d)))) + +(defn apply-change [^objects call change diff] + (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)] + (block-unmount block diff) diff)] + (if-some [block (get-block reader f)] + (do (aset block block-slot-index i) + (aset buffer i block) + (call-update-weights call (block-weight block)) + (if-some [index (block-index call i)] + (block-mount block index diff) diff)) + (let [^objects block (make-block reader f)] + (aset block block-slot-parent call) + (aset block block-slot-index i) + (aset buffer i block) diff)))) + diff change))) + +(defn apply-shrink [^objects call degree shrink diff] + (let [^objects buffer (aget call call-slot-buffer)] + (loop [d diff + i 0] + (if (< i shrink) + (recur + (block-unmount + (aget buffer + (unchecked-subtract-int degree + (unchecked-inc-int i))) d) + (inc i)) d)))) + +(defn call-transfer [^objects call diff] + (let [{:keys [degree shrink permutation change]} @(aget call call-slot-process)] + (aset call call-slot-buffer (ensure-capacity (aget call call-slot-buffer) degree)) + (->> diff + (apply-permutation call permutation) + (apply-change call change) + (apply-shrink call degree shrink)))) + +(defn reader-transfer [^objects reader] + (let [^objects state (aget reader reader-slot-state) + held (enter state)] + (if (identical? reader (aget state slot-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 call diff)))) + (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 (item-detach-from-tree item diff)) + (if (nil? (aget item item-slot-parent)) + (item-attach-to-tree item reader diff) + (change item diff))))) + (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)) + (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)))) + ((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) [_] + (reader-cancel state)) + IDeref + (#?(:clj deref :cljs -deref) [_] + (reader-transfer state))) + +(defn reader-spawn [^objects state step done] + (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-alive (identity 1)) + (when (nil? (aget state slot-reader)) + (aset state slot-reader reader) + (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 error [^String msg] + (new #?(:clj Error :cljs js/Error) msg)) + +(deftype MountPoint [^objects state] + KVS + (insert! [_ tag init] + (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] + (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] + (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 [peer] + (->MountPoint + (doto (object-array slots) + (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.cljc b/src/hyperfiddle/electric/impl/runtime.cljc deleted file mode 100644 index 5ccd2b179..000000000 --- a/src/hyperfiddle/electric/impl/runtime.cljc +++ /dev/null @@ -1,1207 +0,0 @@ -(ns ^:no-doc hyperfiddle.electric.impl.runtime - (:refer-clojure :exclude [compile]) - (:require [hyperfiddle.electric.impl.yield2 :refer [yield]] - [hyperfiddle.electric.impl.failer :as failer] - [hyperfiddle.electric.impl.lang :as-alias lang] - [hyperfiddle.electric.impl.local :as l] - [hyperfiddle.electric.impl.ir :as ir] - [hyperfiddle.electric.debug :as dbg] - [missionary.core :as m] - [hyperfiddle.rcf :refer [tests]] - [clojure.pprint :as pp] - [clojure.string :as str] - [contrib.data :as data] - [contrib.assert :as ca] - [hyperfiddle.electric.impl.ir-utils :as ir-utils]) - (:import missionary.Cancelled - (hyperfiddle.electric Failure Pending Remote) - #?(:clj (clojure.lang IFn IDeref Atom)))) - -;; An Electric program is a tree, which structure is dynamically maintained. -;; Two peers are synchronized (through a protocol) such that the tree structure is identicaly on both peers. -;; Two type of nodes: -;; [Frames] : A piece of DAG with a static structure. Won't be rearanged at runtime. (AKA Static Frame) -;; - A set of compiled s-expressions + a set of signals weaving these expressions + N inputs + N outputs -;; - A frame has 2 instances, one on client, one on server. -;; - Server's outputs are client's inputs and vice-versa. -;; - Frames are processes. -;; - Image: a stackframe but for a DAG. A stackframe is allocated to compute the result of a function. -;; It is volatile (disposable) in a stack-based program. Since Electric is reactive, the frame is not disposable. -;; «ReactiveFrame» «Distributed Reactive Frame» -;; [Tiers] : For each `new` in a frame, a managed process is created. Tiers are child processes of frames. (AKA Dynamic Frame) -;; - Parent process of a tier is always a frame. -;; - Parent process of a frame is alawys a tier. -;; - Specificity: Frames have a fixed set of children, tiers have a dynamic set of children, they can spawn new frames anytime. -;; Child frames of a tier are positioned (there is a well defined traversal order) -;; Node order (positions) can change at runtime because tiers can spawn dynamically (e.g.: p/for). -;; - Some tiers don't have child frames : e.g. (new (m/watch .)), no child frames, no input, no output -;; - Some frames don't have child tiers : e.g. a frame without any `new`, no variability. -;; - (image: an ordered tree with different kind of nodes at each generation) - -;; Network protocol -;; Each peer streams events to its remote peer via a bidirectional channel. An event is a clojure map with 4 entries : -;; * :acks is a non-negative integer counting the number of non-empty changesets received by the peer sending the event -;; since the previous event was sent. -;; * :tree is a vector of tree instructions. Order of instructions matters. A tree instruction describes an atomic mutation of the tree, it is a map -;; with a mandatory :op entry defining the instruction type and defining the rest of the keyset. Instructions are : -;; * :create appends a new frame at the end of a tier, owned by the peer sending the event. The frame constructor is -;; defined by the entry :target, the endpoint is defined by the entry :source. Both are ordered pairs of two -;; numbers, the frame id and the position of the target or the source in the frame. -;; * :rotate performs of cyclic permutation of frames in a tier, owned by the peer sending the event. The frame -;; identified by the :frame entry is moved to position defined by the :position entry. If the cycle is trivial (A -> A), the -;; frame is removed. -;; * :remove dissociates a frame from the index. legacy hack, should be removed. -;; * :change is a map associating ports with values. A port is absolute for the system, inputs and output relative terms for a port (it only make sense from a single peer perspective). -;; A port is represented as an ordered pair of two numbers, a frame id -;; and the position of this port in the frame. The value is the new state of port. (:assign could be a synonym) -;; * :freeze is a set of ports. Each port present in this set must be considered terminated (i.e. its state won't ever -;; change again). -;; A frame id is negative if the frame is owned by the peer sending the event, positive if the frame is owned by the -;; peer receiving the event, zero is the root frame. - -(defn fail [exception _in-scope-stacktrace] - ;; When throwing from a `catch` block, we want to throw an exception while preserving the stack trace of the exception that triggered the catch block. - ;; first arg is the exception we want to throw - ;; second arg is the exception in scope (if we are in a catch block) or nil - ;; second arg is ignored here, but being part of the arguments, it will be - ;; visible to `latest-apply` and so be part of the async stack trace. - ;; See `handle-apply-error`. - (throw exception)) - -(def failure (some-fn #(when (instance? Failure %) %))) - -(def pending (Failure. (Pending.))) - -(defn error [^String msg] ; Could be ex-info (ExceptionInfo inherits Error or js/Error) - (#?(:clj Error. :cljs js/Error.) msg)) - -(defn pst [e] - #?(:clj (.printStackTrace ^Throwable e) - :cljs (js/console.error e))) - -(defn select-debug-info [debug-info] - (merge (select-keys debug-info [::ir/op]) (data/select-ns :hyperfiddle.electric.debug debug-info))) - -(defn check-failure [debug-info It input input-cancel input-transfer)))))) - -(defn check-unbound-var [_debug-info FrameIterator f - ( context - (aget context-slot-frame-store) - ^objects (get target-frame) - ^objects (aget frame-slot-targets) - (aget target-slot)) - (-> context - (aget context-slot-frame-store) - ^objects (get source-frame) - ^objects (aget frame-slot-sources) - (aget source-slot)) - (aswap context context-slot-remote-id dec))) - :rotate (-> context - (aget context-slot-frame-store) - (get (:frame inst)) - (frame-rotate (:position inst))) - :remove (aswap context context-slot-frame-store dissoc! (:frame inst))) - context) - -(defn eval-change-inst [^objects context [id slot] value] - (-> context - (aget context-slot-frame-store) - ^objects (get id) - ^objects (aget frame-slot-inputs) - ^objects (aget slot) - (input-change value)) - context) - -(defn eval-freeze-inst [^objects context [id slot]] - (-> context - (aget context-slot-frame-store) - ^objects (get id) - ^objects (aget frame-slot-inputs) - ^objects (aget slot) - (input-freeze)) - context) - -(defn parse-event [^objects context {:keys [acks tree change freeze]}] - (try (dotimes [_ acks] (context-ack context)) - (reduce eval-tree-inst context tree) - (when-not (= {} change) - (update-event context :acks inc) - (reduce-kv eval-change-inst context change)) - (reduce eval-freeze-inst context freeze) - #?(:clj (catch ArrayIndexOutOfBoundsException _ ; Misaligned client/server DAG - ;; Heavy message on purpose, to help users diagnose the issue. - ;; When this happens, both users and us are *highly* confused - ;; and it usually triggers a meeting. - (throw (ex-info (str "A mismatch between client and server's programs was detected. The connection was closed and the client was instructed to not attempt to reconnect. Commonly, 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. This should not happen in prod. See `https://github.com/hyperfiddle/electric-starter-app/` for a reference configuration.") - {:hyperfiddle.electric/type :hyperfiddle.electric/misaligned-dag})))) - (catch #?(:clj Throwable :cljs :default) e (#?(:clj prn :cljs js/console.error) e) (throw e)))) - -(defn process-incoming-events [^objects context >incoming] - (m/sample (partial reduce parse-event context) >incoming)) - -(defn write-outgoing-events [write >events] - (m/ap (let [e (m/?> >events)] - (when-not (= e empty-event) - (m/? (write e)))))) - -(defn peer [dynamic variable-count source-count constant-count target-count output-count input-count ctor get-used-nodes nm env] - (fn rec - ([write ?read] (rec write ?read pst)) - ([write ?read on-error] - (m/reactor - (let [^objects context (make-context)] - (m/stream! - (write-outgoing-events write - (m/stream! - (fn [n t] - (aset context context-slot-notifier n) - (aset context context-slot-terminator t) - (when-some [
It context context-cancel context-transfer))))) - (m/stream! (process-incoming-events context (m/stream! (m/relieve into (m/sample vector (m/observe ?read))))))))))) - -(defn collapse [s n f & args] - (->> (iterate pop s) - (transduce (comp (map peek) (take n)) conj args) - (apply f) - (conj (nth (iterate pop s) n)))) - -(defn snapshot [env f & args] - (update env :stack conj (apply f env args))) - -(defn reverse-index [m] - (reduce-kv (fn [v x i] (assoc v i x)) - (vec (repeat (count m) nil)) m)) - -(def empty-frame - {:variable 0 - :source 0 - :constant 0 - :target 0 - :output 0 - :input 0 - :free #{} - :static {} - :dynamic {}}) - -;; TODO move me -;; `new` creates a local variable and a remote source -;; `p/fn` creates a local constant and a remote target -;; Same duality with input and output, if there is 3 inputs locally, there is 3 outputs remotely. -;; There is no instruction to create inputs and outputs, they are infered from unquote-splicing. - -(defn sym [& args] - (symbol (str/join "-" args))) - -(defn find-nodes [ir] - (transduce (distinct) - (completing (fn [ac nx] (cond-> ac (= ::ir/node (::ir/op nx)) (conj (::ir/slot nx))))) - [] (ir-utils/->reducible ir))) - -(defn remove-dep-nodes [ir] - (ir-utils/postwalk ir - (fn [v] (cond-> v (::ir/deps v) (update ::ir/deps #(filterv (comp not #{::ir/node} ::ir/op) %)))))) - -(tests - (remove-dep-nodes (ir/input [(ir/node 'x) (ir/output ir/nop)])) := (ir/input [(ir/output ir/nop)])) - -(defn tag-sym [sym jvm-hint js-hint] - #?(:clj (when jvm-hint (vary-meta sym assoc :tag jvm-hint)) - :cljs (when js-hint (vary-meta sym assoc :tag js-hint)))) - -(defn compile [prefix inst e] - (let [nodes (find-nodes inst) - inst (remove-dep-nodes inst) - frame (sym prefix 'frame) - vars (sym prefix 'vars) - ctor-at (fn [i] (sym prefix 'ctor i)) - expr-at (fn [i] (sym prefix 'expr i)) - restore-free (fn [env free] - (reduce-kv (fn [env i f] (assoc env f (list `aget (sym prefix 'env) i))) env free)) - capture-free (fn [env free] - `(doto (object-array ~(count free)) - ~@(eduction (map-indexed (fn [i f] (list `aset i (env f)))) free))) - emit-exprs (fn [exprs] - (list `fn [frame vars (tag-sym (sym prefix 'env) "[Ljava.lang.Object;" nil)] - (list `let - (into [] (comp (map-indexed (fn [i expr] [(expr-at i) expr])) cat) (pop exprs)) - (peek exprs)))) - update-current (fn [ctors f & args] (conj (pop ctors) (apply f (peek ctors) args))) - from-last-expr (fn [exprs f & args] (conj exprs (apply f (expr-at (dec (count exprs))) args))) - add-many (fn [ctors env args] - (reduce - (fn [[ctors args] arg] - (let [ctors (arg ctors env)] - [ctors (conj args (expr-at (dec (count (peek ctors)))))])) - [ctors []] args))] - (-> ((fn walk [env off idx dyn inst] - (case (::ir/op inst) - ::ir/nop (update env :stack conj (fn [ctors _env] (update-current ctors conj nil))) - ::ir/sub (let [p (- idx (::ir/index inst))] - (if (< p off) - (let [f (:static env) - i (f p (count f))] - (-> env - (update :free conj p) - (assoc :static (assoc f p i)) - (update :stack conj (fn [ctors _env] - (update-current ctors conj `(static ~frame ~i)))))) - (update env :stack conj (fn [ctors env] (update-current ctors conj (env p)))))) - ::ir/pub (-> env - (walk off idx dyn (::ir/init inst)) - (walk off (inc idx) dyn (::ir/inst inst)) - (update :stack collapse 2 (fn [form cont idx] - (fn [ctors env] - (let [ctors (form ctors env)] - (-> ctors - (update-current from-last-expr (fn [x] `(signal ~x))) - (cont (assoc env idx (expr-at (count (peek ctors))))))))) - idx)) - ::ir/do (let [deps (::ir/deps inst)] - (-> (reduce (fn [env arg] (walk env off idx dyn arg)) env deps) - (update :stack collapse (count deps) vector) - (walk off idx dyn (::ir/inst inst)) - (update :stack collapse 2 (fn [deps form] - (fn [ctors env] - (let [[ctors deps] (add-many ctors env deps)] - (-> ctors - (update-current conj `(make-input ~frame ~deps)) - (form env)))))))) - ::ir/def (let [symb (::ir/slot inst)] - (-> env - (update :stack conj (fn [ctors _env] - (update-current ctors conj `(pure (inject '~symb))))))) - ::ir/lift (-> env - (walk off idx dyn (::ir/init inst)) - (update :stack collapse 1 (fn [f] - (fn [ctors env] - (-> ctors - (f env) - (update-current from-last-expr (fn [x] `(pure ~x)))))))) - ::ir/eval (update env :stack conj (fn [ctors _env] - (update-current ctors conj `(pure ~(::ir/form inst))))) - ::ir/node (let [symb (::ir/slot inst)] - (if (dyn symb) - (update env :stack conj (fn [ctors _env] - (update-current ctors conj `(get (deref ~vars) '~symb)))) - (let [d (:dynamic env) - i (d symb (count d))] - (-> env - (assoc :dynamic (assoc d symb i)) - (update :stack conj - (fn [ctors _env] - (update-current ctors conj - `(dynamic ~frame '~symb '~(assoc (select-debug-info inst) - ::dbg/sym symb, ::dbg/slot i))))))))) - ::ir/bind (let [v (::ir/slot inst)] - (-> env - (walk off idx (conj dyn v) (::ir/inst inst)) - (update :stack collapse 1 - (fn [form symb idx] - (fn [ctors env] - (-> ctors - (update-current conj `(get (deref ~vars) '~symb) `(swap! ~vars assoc '~symb ~(env idx))) - (form env) - (update-current conj `(swap! ~vars assoc '~symb ~(expr-at (count (peek ctors))))) - (update-current (fn [exprs] (conj exprs (expr-at (- (count exprs) 2)))))))) - v (- idx (::ir/index inst))))) - ::ir/apply (let [f (::ir/fn inst) - args (::ir/args inst) - debug-info (select-debug-info (loop [f f] - (case (::ir/op f) - ::ir/global (assoc f ::dbg/type :apply, ::dbg/name (symbol (::ir/name f))) - ::ir/node (assoc f ::dbg/type :apply) - ::ir/eval (cond-> (assoc f ::dbg/type :eval) - (not (::dbg/name f)) (assoc ::dbg/form (::ir/form f))) - ::ir/sub (assoc f ::dbg/type :apply) - ::ir/input (assoc f ::dbg/type :apply) - ::ir/apply (recur (::ir/fn f)) - {::dbg/type :unknown-apply, :op f})))] - (if (and (= (ir/eval '{}) f) (= 2 (count args))) - (-> (reduce (fn [env inst] (walk env off idx dyn inst)) env args) - (update :stack collapse 2 - (fn [a b] - (fn [ctors env] - (let [[ctors [a b]] (add-many ctors env [a b])] - (update-current ctors conj `(causal '~debug-info ~a ~b))))))) - (-> (reduce (fn [env inst] (walk env off idx dyn inst)) env (cons f args)) - (update :stack collapse (inc (count args)) - (fn [& forms] - (fn [ctors env] - (let [[ctors forms] (add-many ctors env forms)] - (update-current ctors conj `(latest-apply '~debug-info ~@forms))))))))) - ::ir/input (let [deps (::ir/deps inst)] - (-> (reduce (fn [env arg] (walk env off idx dyn arg)) env deps) - (update :stack collapse (count deps) vector) - (update :input inc) - (update :stack collapse 1 - (fn [deps] - (fn [ctors env] - (let [[ctors deps] (add-many ctors env deps)] - (update-current ctors conj `(input-spawn ~frame ~deps)))))))) - ::ir/output (-> env - (walk off idx dyn (::ir/init inst)) - (update :output inc) - (update :stack collapse 1 - (fn [form] - (fn [ctors env] - (-> ctors - (form env) - (update-current from-last-expr - (fn [x] `(make-output ~frame (check-failure '~(select-debug-info inst) ~x))))))))) - ::ir/variable (-> env - (walk off idx dyn (::ir/init inst)) - (update :variable inc) - (update :stack collapse 1 - (fn [form] - (fn [ctors env] - (-> ctors - (form env) - (update-current from-last-expr (fn [x] (list `variable frame vars x)))))))) - ::ir/source (-> env - (update :source inc) - (update :stack conj (fn [ctors _env] - (update-current ctors conj (list `source frame vars))))) - ::ir/constant (-> env - (merge empty-frame) - (walk idx idx #{} (::ir/init inst)) - (snapshot (comp vec :free)) - (snapshot (comp reverse-index :static)) - (snapshot (comp reverse-index :dynamic)) - (snapshot :variable) - (snapshot :source) - (snapshot :constant) - (snapshot :target) - (snapshot :output) - (snapshot :input) - (update :free (partial into (:free env) (filter #(< % off)))) - (merge (select-keys env (keys (dissoc empty-frame :free)))) - (update :constant inc) - (update :stack collapse 10 - (fn [form free static dynamic variable-count source-count constant-count target-count output-count input-count] - (fn [ctors env] - (let [exprs (peek ctors) - ctors (-> (pop ctors) - (conj []) - (form (restore-free env free)))] - (-> ctors - (update-current from-last-expr - (fn [x] `(check-failure '~(select-debug-info inst) ~x))) - (update-current - (fn [exprs] - (list `constructor (list 'quote dynamic) - variable-count source-count - constant-count target-count - output-count input-count - (emit-exprs exprs)))) - (conj exprs) - (update-current conj - (list `constant frame - (list (ctor-at (dec (count ctors))) - (capture-free env free) (mapv env static)))))))))) - ::ir/target (let [deps (::ir/deps inst)] - (-> (reduce (fn [env inst] (walk env idx idx #{} inst)) - (merge env empty-frame) deps) - (update :stack collapse (count deps) vector) - (snapshot (comp vec :free)) - (snapshot (comp reverse-index :static)) - (snapshot (comp reverse-index :dynamic)) - (snapshot :variable) - (snapshot :source) - (snapshot :constant) - (snapshot :target) - (snapshot :output) - (snapshot :input) - (update :free (partial into (:free env) (filter #(< % off)))) - (merge (select-keys env (keys (dissoc empty-frame :free)))) - (update :target inc) - (update :stack collapse 10 - (fn [deps free static dynamic variable-count source-count constant-count target-count output-count input-count] - (fn [ctors env] - (let [exprs (peek ctors) - [ctors deps] (-> (pop ctors) - (conj []) - (add-many (restore-free env free) deps))] - (-> ctors - (update-current conj `(make-input ~frame ~deps)) - (update-current - (fn [exprs] - (list `constructor (list 'quote dynamic) - variable-count source-count - constant-count target-count - output-count input-count - (emit-exprs exprs)))) - (conj exprs) - (update-current conj - (list `target frame - (list (ctor-at (dec (count ctors))) - (capture-free env free) (mapv env static))))))))))) - (throw (ex-info (str "unknown instruction: " inst) {:inst inst})))) - empty-frame 0 0 #{} inst) - (snapshot (comp reverse-index :dynamic)) - (snapshot :variable) - (snapshot :source) - (snapshot :constant) - (snapshot :target) - (snapshot :output) - (snapshot :input) - (:stack) - (collapse 8 - (fn [form dynamic nvariable nsource nconstant ntarget noutput ninput] - (let [code (let [ctors (form [[]] {})] - (list `let (into [] (comp (map-indexed (fn [i ctor] [(ctor-at i) ctor])) cat) (pop ctors)) - (emit-exprs (peek ctors))))] - (when (::lang/pprint-source e) - (println "---" (::lang/sym e) "SOURCE ---") - (pp/pprint code)) - {:fn code, :dynamic `'~dynamic, :nvariable nvariable :nsource nsource, :get-used-nodes `(fn [] ~nodes) - :nconstant nconstant, :ntarget ntarget, :noutput noutput, :ninput ninput}))) - (peek)))) - -(defn- get-used-nodes-recursively [info] - (loop [walked #{}, unwalked (seq [info])] - (if-some [[to-walk & unwalked] unwalked] - (if (map? to-walk) ; skip unbound nodes - (if (walked to-walk) - (recur walked unwalked) - (recur (conj walked to-walk) (into unwalked ((:get-used-nodes to-walk))))) - (recur walked unwalked)) - walked))) - -(defn main [info] - (let [info (cond-> info (var? info) deref) - all-nodes (get-used-nodes-recursively info) - {:keys [nvariable nsource nconstant ntarget noutput ninput]} - (apply merge-with + - (eduction (map #(select-keys % [:nvariable :nsource :nconstant :ntarget :noutput :ninput])) - all-nodes))] - (peer (:dynamic info) nvariable nsource nconstant ntarget noutput ninput (:fn info) (:get-used-nodes info) (:var-name info) nil))) - -;; used indirectly in compiler `analyze-case` -(defn case-default-throw [v] (throw (new #?(:clj IllegalArgumentException :cljs js/Error) (str "No matching clause: " v)))) -(defn pick-case-branch [picker-map v default-branch & branches] - (if-some [i (picker-map v)] (nth branches i) default-branch)) diff --git a/src/hyperfiddle/electric/impl/runtime3.cljc b/src/hyperfiddle/electric/impl/runtime3.cljc new file mode 100644 index 000000000..4f40614f0 --- /dev/null +++ b/src/hyperfiddle/electric/impl/runtime3.cljc @@ -0,0 +1,1410 @@ +(ns hyperfiddle.electric.impl.runtime3 + (:refer-clojure :exclude [resolve]) + (:require [hyperfiddle.incseq :as i] + [missionary.core :as m] + [cognitect.transit :as t]) + (:import missionary.Cancelled + #?(:clj (clojure.lang IFn IDeref)) + #?(:clj (java.io ByteArrayInputStream ByteArrayOutputStream Writer)) + #?(:clj (java.util.concurrent.locks ReentrantLock)))) + +#?(: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))) + +(def peer-slot-busy 0) +(def peer-slot-root 1) +(def peer-slot-site 2) +(def peer-slot-defs 3) +(def peer-slot-remote 4) +(def peer-slot-sub-ready 5) +(def peer-slot-channel-ready 6) +(def peer-slots 7) + +(def remote-slot-peer 0) +(def remote-slot-events 1) +(def remote-slot-channel 2) +(def remote-slot-inputs 3) ;; hash map of remote ports currently pushed to local peer, indexed by port slot +(def remote-slot-outputs 4) ;; hash map of local port subscriptions pushed to remote peer, indexed by port slot +(def remote-slot-ready 5) +(def remote-slot-ackq 6) +(def remote-slot-freeze 7) +(def remote-slot-acks 8) +(def remote-slot-toggle 9) +(def remote-slots 10) + +(def ack-slot-prev 0) +(def ack-slot-next 1) +(def ack-slot-convicted-inputs 2) +(def ack-slot-convicted-outputs 3) +(def ack-slots 4) + +(def output-slot-remote 0) +(def output-slot-port 1) +(def output-slot-requested 2) ;; true iff remote input has at least one incseq depending on it - updated by remote toggle events +(def output-slot-refcount 3) ;; count of active inputs depending on this output - updated by local incseqs +(def output-slot-convicted 4) +(def output-slot-process 5) +(def output-slot-ready 6) +(def output-slots 7) + +(def channel-slot-remote 0) +(def channel-slot-events 1) +(def channel-slot-process 2) +(def channel-slot-busy 3) +(def channel-slot-over 4) +(def channel-slot-step 5) +(def channel-slot-done 6) +(def channel-slot-alive 7) +(def channel-slot-ready 8) +(def channel-slot-shared 9) +(def channel-slot-reader-opts 10) +(def channel-slot-writer-opts 11) +(def channel-slots 12) + +(def port-slot-slot 0) +(def port-slot-site 1) +(def port-slot-deps 2) +(def port-slot-flow 3) +(def port-slots 4) + +(def input-slot-remote 0) ;; this is only required for peer access +(def input-slot-port 1) +(def input-slot-diff 2) +(def input-slot-frozen 3) +(def input-slot-subs 4) +(def input-slot-refcount 5) +(def input-slot-requested 6) +(def input-slot-convicted 7) +(def input-slot-prev 8) +(def input-slot-next 9) +(def input-slots 10) + +(def input-sub-slot-input 0) +(def input-sub-slot-step 1) +(def input-sub-slot-done 2) +(def input-sub-slot-prev 3) +(def input-sub-slot-next 4) +(def input-sub-slot-diff 5) +(def input-sub-slot-ready 6) +(def input-sub-slots 7) + +(def call-slot-port 0) +(def call-slot-rank 1) +(def call-slots 2) + +;; Pure | Ap | Join | Slot +(defprotocol Expr + (deps [_ rf r site]) ;; emits ports + (flow [_])) ;; returns incseq + +(defn expr-deps [rf r site expr] + (deps expr rf r site)) + +(deftype Failure [info]) + +(defn failure-info [^Failure f] + (.-info f)) + +(defn failure? [x] + (instance? Failure x)) + +(defn invariant [x] (m/cp x)) + +(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 value))))) + #?(:cljs IEquiv) + (#?(:clj equals :cljs -equiv) [_ other] + (and (instance? Pure other) + (= value (.-value ^Pure other)))) + Expr + (deps [_ _ r _] r) + (flow [_] + (if (failure? value) + (m/latest #(throw (ex-info "Illegal access." {:info (failure-info value)}))) + (i/fixed (invariant value))))) + +(defn pure " +-> (EXPR VOID) +T -> (EXPR T) +T T -> (EXPR T) +T T T -> (EXPR T) +" [value] + (->Pure value nil)) + +(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))) + +;; 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) + #?(: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 [_ rf r site] + (reduce (fn [r x] (deps x rf r site)) r inputs)) + (flow [_] + (apply i/latest-product invoke (map flow inputs)))) + +(defn ap " +(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)) + +(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 [_ rf r site] (deps input rf r site)) + (flow [_] (i/latest-concat (flow input)))) + +(defn join " +(EXPR (IS T)) -> (EXPR T) +" [input] (->Join input nil)) + +(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 " +-> (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 " +(IS T) -> (IS VOID) +" [incseq] + (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) + :cljs (js/Error. msg))) + +(deftype Failer [done e] + IFn + (#?(:clj invoke :cljs -invoke) [_]) + IDeref + (#?(:clj deref :cljs -deref) [_] + (done) (throw 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 [_ _ r _] r) + (flow [_] + (fn [step done] + (step) (->Failer done (error (str "Unbound electric var lookup - " (pr-str key))))))) + +(deftype Cdef [frees nodes calls result build]) + +(def cdef ->Cdef) + +(declare slot-port) + +(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) + ([[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 bind-self [ctor] + (bind ctor :recur (pure ctor))) + +(defn arity-mismatch [nm arity] + (throw (error (str nm ": wrong number of args (" arity ")")))) + +(defn get-variadic [nm F arity] + (if-some [[fixed map? ctor] (F -1)] + (if (< arity fixed) + (arity-mismatch nm arity) + [fixed map? ctor]) + (arity-mismatch nm 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 [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 nm F arity)] + (bind (apply bind-args (bind-self ctor) (take fixed args)) + fixed (apply ap (pure (varargs map?)) (drop fixed args))))))) + +(defn peer-defs [^objects peer] + (aget peer peer-slot-defs)) + +(defn peer-site [^objects peer] + (aget peer peer-slot-site)) + +(defn peer-root [^objects peer key] + (let [defs (peer-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." + {:tag Cdef} + [^objects peer key idx] + ((peer-root peer key) idx)) + +(defn port-flow [^objects port] + (aget port port-slot-flow)) + +(defn port-deps [rf r ^objects port] + (reduce-kv + (fn [r port n] + (reduce rf r (repeat n port))) + r (aget port port-slot-deps))) + +(declare incseq frame-result-slot) + +(deftype Frame [peer slot rank site ctor ^objects nodes ^objects tags + ^:unsynchronized-mutable ^:mutable hash-memo] + #?(:clj Object) + #?(:cljs IHash) + (#?(:clj hashCode :cljs -hash) [_] + (if-some [h hash-memo] + 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 + (#?(:clj invoke :cljs -invoke) [this step done] + ((incseq this (frame-result-slot 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." + [^Frame frame] + (.-ctor frame)) + +(defn frame-peer + "Returns the peer of given frame." + [^Frame frame] + (.-peer frame)) + +(defn frame-cdef + "Returns the cdef of given frame." + {:tag Cdef} + [^Frame 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-site + "Returns the site of given frame." + [^Frame frame] + (.-site frame)) + +(declare port-slot) + +(defn enter [^objects peer] + #?(:clj (let [^ReentrantLock r (aget peer peer-slot-busy)] + (if (.isHeldByCurrentThread r) + true (do (.lock r) false))) + :cljs (if (aget peer peer-slot-busy) + true (do (aset peer peer-slot-busy true) false)))) + +(defn exit [^objects peer busy] + (when-not busy + (let [s (aget peer peer-slot-sub-ready) + c (aget peer peer-slot-channel-ready)] + (aset peer peer-slot-sub-ready nil) + (aset peer peer-slot-channel-ready nil) + #?(:clj (.unlock ^ReentrantLock (aget peer peer-slot-busy)) + :cljs (aset peer peer-slot-busy false)) + (loop [^objects sub s] + (when-not (nil? sub) + (let [s (aget sub input-sub-slot-ready)] + (aset sub input-sub-slot-ready nil) + ((if-some [step (aget sub input-sub-slot-step)] + step (aget sub input-sub-slot-done))) + (recur s)))) + (loop [^objects chan c] + (when-not (nil? chan) + (let [c (aget chan channel-slot-ready)] + (aset chan channel-slot-ready nil) + ((if-some [step (aget chan channel-slot-step)] + step (aget chan channel-slot-done))) + (recur c))))))) + +(defn channel-output-event [^objects channel] + (when (identical? channel (aget channel channel-slot-ready)) + (let [^objects remote (aget channel channel-slot-remote) + ^objects peer (aget remote remote-slot-peer)] + (aset channel channel-slot-ready (aget peer peer-slot-channel-ready)) + (aset peer peer-slot-channel-ready channel)))) + +(defn channel-terminated [^objects channel] + (when (zero? (aset channel channel-slot-alive + (dec (aget channel channel-slot-alive)))) + (when (identical? channel (aget channel channel-slot-ready)) + (aset channel channel-slot-step nil) + (let [^objects remote (aget channel channel-slot-remote) + ^objects peer (aget remote remote-slot-peer)] + (aset channel channel-slot-ready (aget peer peer-slot-channel-ready)) + (aset peer peer-slot-channel-ready channel))))) + +(defn port-site [^objects port] + (aget port port-slot-site)) + +(defn input-sub-cancel [^objects sub] + (let [^objects input (aget sub input-sub-slot-input) + ^objects remote (aget input input-slot-remote) + ^objects peer (aget remote remote-slot-peer) + busy (enter peer)] + (when-some [^objects prv (aget sub input-sub-slot-prev)] + (aset input input-slot-subs + (when-not (identical? prv sub) + (let [^objects nxt (aget sub input-sub-slot-next)] + (aset prv input-sub-slot-next nxt) + (aset nxt input-sub-slot-prev prv)))) + (aset sub input-sub-slot-prev nil) + (aset sub input-sub-slot-next nil) + (if (nil? (aget sub input-sub-slot-diff)) + (do (aset sub input-sub-slot-ready (aget peer peer-slot-sub-ready)) + (aset peer peer-slot-sub-ready sub)) + (aset sub input-sub-slot-diff nil))) + (exit peer busy))) + +(defn input-sub-transfer [^objects sub] + (let [^objects input (aget sub input-sub-slot-input) + ^objects remote (aget input input-slot-remote) + ^objects peer (aget remote remote-slot-peer) + busy (enter peer)] + (if-some [diff (aget sub input-sub-slot-diff)] + (do (aset sub input-sub-slot-diff nil) + (if (nil? (aget sub input-sub-slot-prev)) + (do (aset sub input-sub-slot-step nil) + (aset sub input-sub-slot-ready (aget peer peer-slot-sub-ready)) + (aset peer peer-slot-sub-ready sub)) + (aset sub input-sub-slot-ready sub)) + (exit peer busy) diff) + (do (aset sub input-sub-slot-step nil) + (aset sub input-sub-slot-ready (aget peer peer-slot-sub-ready)) + (aset peer peer-slot-sub-ready sub) + (exit peer busy) + (throw (Cancelled. "Remote port cancelled.")))))) + +(deftype InputSub [sub] + IFn + (#?(:clj invoke :cljs -invoke) [_] + (input-sub-cancel sub)) + IDeref + (#?(:clj deref :cljs -deref) [_] + (input-sub-transfer sub))) + +(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 rf r site] + (let [port (slot-port this)] + (if (= site (port-site port)) + (port-deps rf r port) + (rf r port)))) + (flow [this] + (port-flow (slot-port this)))) + +(defn port-slot + {:tag Slot} + [^objects port] + (aget port port-slot-slot)) + +(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 (aget ^objects (.-tags frame) id) call-slot-port)))) + +(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 frame)])) + (vec path)))) + +(defn port-coordinates [^objects port] + (let [slot (port-slot port)] + [(frame-path (.-frame slot)) (.-id slot)])) + +(defn input-check-create [^objects remote port] + (let [slot (port-slot port)] + (if-some [^objects input (get (aget remote remote-slot-inputs) slot)] + input (let [input (object-array input-slots)] + (aset input input-slot-remote remote) + (aset input input-slot-port port) + (aset input input-slot-requested (identity 0)) + (aset input input-slot-refcount (identity 0)) + (aset input input-slot-diff (i/empty-diff 0)) + (aset input input-slot-frozen false) + (aset input input-slot-convicted input) + (aset remote remote-slot-inputs + (assoc (aget remote remote-slot-inputs) slot input)) + input)))) + +(defn input-sub [^objects port] + (fn [step done] + (let [^Slot slot (port-slot port) + ^objects peer (frame-peer (.-frame slot)) + busy (enter peer) + ^objects remote (aget peer peer-slot-remote) + ^objects input (input-check-create remote port) + sub (object-array input-sub-slots)] + (aset sub input-sub-slot-input input) + (aset sub input-sub-slot-step step) + (aset sub input-sub-slot-done done) + (aset sub input-sub-slot-diff (aget input input-slot-diff)) + (when-not (aget input input-slot-frozen) + (if-some [^objects prv (aget input input-slot-subs)] + (let [^objects nxt (aget prv input-sub-slot-next)] + (aset prv input-sub-slot-next sub) + (aset nxt input-sub-slot-prev sub) + (aset sub input-sub-slot-prev prv) + (aset sub input-sub-slot-next nxt)) + (do (aset input input-slot-subs sub) + (aset sub input-sub-slot-prev sub) + (aset sub input-sub-slot-next sub)))) + (aset sub input-sub-slot-ready (aget peer peer-slot-sub-ready)) + (aset peer peer-slot-sub-ready sub) + (exit peer busy) + (->InputSub sub)))) + +(defn make-port [^Slot slot site deps flow] + (let [port (object-array port-slots) + peer (frame-peer (.-frame slot))] + (aset port port-slot-slot slot) + (aset port port-slot-site site) + (aset port port-slot-deps deps) + (aset port port-slot-flow + (if (= site (peer-site peer)) + (m/signal i/combine flow) + (input-sub port))) + port)) + +(defn update-inc [m k] + (assoc m k (inc (m k 0)))) + +(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) + id (- -1 id)] + (if (= id (count nodes)) + (.-result cdef) (nodes id)))] + site (frame-site frame)) + port (if (instance? Slot expr) + (slot-port expr) + (make-port slot site + (deps expr update-inc {} site) + (flow expr)))] + (aset ^objects (.-nodes frame) (- -1 id) port) nil)) + +(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 (node frame id) expr)) + +(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 frame-slot [^Frame frame] + (.-slot frame)) + +(defn make-frame [^objects peer ^Slot slot rank site ctor] + (let [[key idx _ _] ctor + cdef (peer-cdef peer key idx) + nodec (count (.-nodes cdef)) + callc (count (.-calls cdef)) + frame (->Frame peer slot rank site ctor + (object-array (inc nodec)) (object-array callc) nil)] + (define-slot (->Slot frame (- -1 nodec)) ((.-build cdef) frame)) frame)) + +(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 input-dispose [^objects input] + (let [^objects remote (aget input input-slot-remote)] + (aset remote remote-slot-inputs + (dissoc (aget remote remote-slot-inputs) + (port-slot (aget input input-slot-port)))))) + +(defn channel-output-sub [^objects channel ^objects output] + (aset channel channel-slot-alive + (inc (aget channel channel-slot-alive))) + (aset output output-slot-process + ((port-flow (aget output output-slot-port)) + #(let [^objects remote (aget output output-slot-remote) + ^objects peer (aget remote remote-slot-peer) + busy (enter peer)] + (if (nil? (aget output output-slot-port)) + (try @(aget output output-slot-process) + (catch #?(:clj Throwable :cljs :default) _)) + (do (aset output output-slot-ready (aget remote remote-slot-ready)) + (aset remote remote-slot-ready output) + (channel-output-event channel))) + (exit peer busy)) + #(let [^objects remote (aget output output-slot-remote) + ^objects peer (aget remote remote-slot-peer) + busy (enter peer)] + (if (nil? (aget output output-slot-port)) + (channel-terminated channel) + (do (aset channel channel-slot-alive + (dec (aget channel channel-slot-alive))) + (aset remote remote-slot-freeze + (conj (aget remote remote-slot-freeze) + (port-slot (aget output output-slot-port)))) + (channel-output-event channel))) + (exit peer busy)))) + channel) + +(defn output-dispose [^objects output] + (let [^objects remote (aget output output-slot-remote)] + (aset remote remote-slot-outputs + (dissoc (aget remote remote-slot-outputs) + (port-slot (aget output output-slot-port)))) + (aset output output-slot-port nil) + ((aget output output-slot-process)))) + +(defn reset-diff [n] + {:grow 0, + :degree n, + :shrink n, + :permutation {}, + :change {}, + :freeze #{}}) + +(defn input-reset [^objects input] + (when-some [^objects sub (aget input input-slot-subs)] + (loop [^objects s sub] + (if-some [{:keys [grow degree]} (aget s input-sub-slot-diff)] + (aset s input-sub-slot-diff (reset-diff (- degree grow))) + (let [^objects remote (aget input input-slot-remote) + ^objects peer (aget remote remote-slot-peer)] + (aset s input-sub-slot-diff (reset-diff (:degree (aget input input-slot-diff)))) + (when (identical? s (aget s input-sub-slot-ready)) + (aset s input-sub-slot-ready (aget peer peer-slot-sub-ready)) + (aset peer peer-slot-sub-ready s)))) + (let [n (aget s input-sub-slot-next)] + (when-not (identical? n sub) (recur n))))) + (aset input input-slot-diff (i/empty-diff 0))) + +(defn output-check-create [^objects remote ^objects local-port] + (let [slot (port-slot local-port) + outputs (aget remote remote-slot-outputs)] + (if-some [output (get outputs slot)] + output (let [output (object-array output-slots)] + (aset output output-slot-remote remote) + (aset output output-slot-port local-port) + (aset output output-slot-refcount (identity 0)) + (aset output output-slot-requested false) + (aset output output-slot-ready output) + (aset output output-slot-convicted output) + (aset remote remote-slot-outputs + (assoc (aget remote remote-slot-outputs) slot output)) + (when-some [channel (aget remote remote-slot-channel)] + (channel-output-sub channel output)) + output)))) + +(defn remote-ack [^objects remote] + (let [^objects channel (aget remote remote-slot-channel) + ^objects ack (aget remote remote-slot-ackq) + ^objects nxt (aget ack ack-slot-next) + ^objects prv (aget ack ack-slot-prev)] + (aset remote remote-slot-ackq + (when-not (identical? ack prv) + (aset nxt ack-slot-prev prv) + (aset prv ack-slot-next nxt))) + (loop [^objects input (aget ack ack-slot-convicted-inputs)] + (when-not (nil? input) + (let [x (aget input input-slot-convicted)] + (aset input input-slot-convicted input) + (when (zero? (aget input input-slot-refcount)) + (if (zero? (aget input input-slot-requested)) + (input-dispose input) + (input-reset input))) + (recur x)))) + (loop [^objects output (aget ack ack-slot-convicted-outputs)] + (when-not (nil? output) + (let [x (aget output output-slot-convicted) + port (aget output output-slot-port) + refcount (aget output output-slot-refcount)] + (aset output output-slot-convicted output) + (when-not (aget output output-slot-requested) + (output-dispose output) + (when-not (zero? refcount) + (let [output (object-array output-slots)] + (aset output output-slot-remote remote) + (aset output output-slot-port port) + (aset output output-slot-refcount refcount) + (aset output output-slot-requested false) + (aset output output-slot-ready output) + (aset output output-slot-convicted output) + (aset remote remote-slot-outputs + (assoc (aget remote remote-slot-outputs) + (port-slot port) output)) + (channel-output-sub channel output)))) + (when (identical? channel (aget output output-slot-ready)) + (aset output output-slot-ready (aget remote remote-slot-ready)) + (aset remote remote-slot-ready output)) + (recur x)))))) + +(defn remote-change [^objects remote ^Slot slot diff] + (let [^objects input (get (aget remote remote-slot-inputs) slot) + ^objects remote (aget input input-slot-remote) + ^objects peer (aget remote remote-slot-peer)] + (aset input input-slot-diff (i/combine (aget input input-slot-diff) diff)) + (when-some [^objects sub (aget input input-slot-subs)] + (loop [^objects s sub] + (if-some [prev (aget s input-sub-slot-diff)] + (aset s input-sub-slot-diff (i/combine prev diff)) + (do (aset s input-sub-slot-diff diff) + (when (identical? s (aget s input-sub-slot-ready)) + (aset s input-sub-slot-ready (aget peer peer-slot-sub-ready)) + (aset peer peer-slot-sub-ready s)))) + (let [n (aget s input-sub-slot-next)] + (when-not (identical? n sub) (recur n)))))) + remote) + +(defn remote-freeze [^objects remote ^Slot slot] + (let [^objects input (get (aget remote remote-slot-inputs) slot) + ^objects remote (aget input input-slot-remote) + ^objects peer (aget remote remote-slot-peer)] + (aset input input-slot-frozen true) + (when-some [^objects sub (aget input input-slot-subs)] + (aset input input-slot-subs nil) + (loop [^objects s sub] + (when (nil? (aget s input-sub-slot-diff)) + (aset s input-sub-slot-step nil) + (aset s input-sub-slot-ready (aget peer peer-slot-sub-ready)) + (aset peer peer-slot-sub-ready s)) + (let [n (aget s input-sub-slot-next)] + (aset s input-sub-slot-next nil) + (aset s input-sub-slot-prev nil) + (when-not (identical? n sub) (recur n)))))) + remote) + +(defn remote-port-tap [^objects remote ^objects port] + (let [^objects input (input-check-create remote port) + refcount (aget input input-slot-refcount)] + (aset input input-slot-refcount (inc refcount))) + remote) + +(defn remote-port-untap [^objects remote ^objects port] + (let [^objects input (get (aget remote remote-slot-inputs) (port-slot port)) + refcount (dec (aget input input-slot-refcount))] + (aset input input-slot-refcount refcount) + (when (zero? refcount) + (when (zero? (aget input input-slot-requested)) + (input-dispose input)))) + remote) + +(defn output-down [^objects output] + (aset output output-slot-requested false) + (port-deps remote-port-untap (aget output output-slot-remote) (aget output output-slot-port)) + (when (zero? (aget output output-slot-refcount)) + (output-dispose output))) + +(defn output-up [^objects output] + (aset output output-slot-requested true) + (port-deps remote-port-tap (aget output output-slot-remote) (aget output output-slot-port))) + +(defn input-dequeue [^objects input] + (let [^objects remote (aget input input-slot-remote) + ^objects prv (aget input input-slot-prev) + ^objects nxt (aget input input-slot-next)] + (aset input input-slot-prev nil) + (aset input input-slot-next nil) + (aset remote remote-slot-toggle + (when-not (identical? prv input) + (aset prv input-slot-next nxt) + (aset nxt input-slot-prev prv))))) + +(defn input-enqueue [^objects input] + (let [^objects remote (aget input input-slot-remote)] + (if-some [^objects prv (aget remote remote-slot-toggle)] + (let [^objects nxt (aget prv input-slot-next)] + (aset prv input-slot-next input) + (aset nxt input-slot-prev input) + (aset input input-slot-prev prv) + (aset input input-slot-next nxt)) + (do (aset remote remote-slot-toggle input) + (aset input input-slot-prev input) + (aset input input-slot-next input))))) + +(defn channel-crash [^objects channel] + (let [^objects remote (aget channel channel-slot-remote)] + (aset remote remote-slot-channel nil) + (aset remote remote-slot-acks (identity 0)) + (aset remote remote-slot-freeze #{}) + (loop [] + (when-not (nil? (aget remote remote-slot-ackq)) + (remote-ack remote) + (recur))) + (loop [] + (when-some [^objects input (aget remote remote-slot-toggle)] + (input-dequeue input) + (recur))) + (loop [] + (when-some [^objects output (aget remote remote-slot-ready)] + (aset remote remote-slot-ready (aget output output-slot-ready)) + (aset output output-slot-ready output) + (try @(aget output output-slot-process) + (catch #?(:clj Throwable :cljs :default) _)) + (recur))) + (reduce-kv (fn [_ slot ^objects output] + (when (aget output output-slot-requested) + (output-down output))) + nil (aget remote remote-slot-outputs)) + (reduce-kv (fn [_ slot ^objects input] + (input-reset input) + (when-not (zero? (aget input input-slot-requested)) + (input-enqueue input))) + nil (aget remote remote-slot-inputs)))) + +(defn tap-output [^objects convicted ^objects port] + (let [slot (port-slot port) + ^objects peer (frame-peer (slot-frame slot)) + ^objects remote (aget peer peer-slot-remote) + ^objects output (output-check-create remote port) + refcount (aget output output-slot-refcount)] + (aset output output-slot-refcount (inc refcount)) + convicted)) + +(defn untap-output [^objects convicted ^objects port] + (let [slot (port-slot port) + ^objects peer (frame-peer (slot-frame slot)) + ^objects remote (aget peer peer-slot-remote) + ^objects output (get (aget remote remote-slot-outputs) slot) + refcount (dec (aget output output-slot-refcount))] + (aset output output-slot-refcount refcount) + (if (zero? refcount) + (if (aget output output-slot-requested) + convicted + (do (aset output output-slot-convicted convicted) output)) + convicted))) + +(defn channel-cancel [^objects channel] + ((aget channel channel-slot-process))) + +(defn channel-transfer [^objects channel] + (let [^objects remote (aget channel channel-slot-remote) + ^objects peer (aget remote remote-slot-peer) + busy (enter peer)] + (try (if (identical? channel (aget remote remote-slot-channel)) + (let [^objects ack (object-array ack-slots)] + (loop [toggle #{} + change {}] + (if-some [^objects input (aget remote remote-slot-toggle)] + (let [^objects port (aget input input-slot-port)] + (input-dequeue input) + (if (zero? (aget input input-slot-requested)) + (do (aset ack ack-slot-convicted-outputs + (port-deps untap-output + (aget ack ack-slot-convicted-outputs) port)) + (when (zero? (aget input input-slot-refcount)) + (aset input input-slot-convicted (aget ack ack-slot-convicted-inputs)) + (aset ack ack-slot-convicted-inputs input))) + (aset ack ack-slot-convicted-outputs + (port-deps tap-output + (aget ack ack-slot-convicted-outputs) port))) + (recur (conj toggle (port-slot port)) change)) + (if-some [^objects output (aget remote remote-slot-ready)] + (do (aset remote remote-slot-ready (aget output output-slot-ready)) + (recur toggle + (if (identical? output (aget output output-slot-convicted)) + (let [ps (aget output output-slot-process)] + (aset output output-slot-ready output) + (if-some [port (aget output output-slot-port)] + (let [slot (port-slot port), diff @ps] + (assoc change slot (if-some [p (change slot)] (i/combine p diff) diff))) + (do (try @ps (catch #?(:clj Throwable :cljs :default) _)) change))) + (do (aset output output-slot-ready channel) change)))) + (let [acks (aget remote remote-slot-acks) + freeze (aget remote remote-slot-freeze)] + (aset remote remote-slot-acks (identity 0)) + (aset remote remote-slot-freeze #{}) + (when (pos? (+ (count toggle) (count change) (count freeze))) + (if-some [^objects nxt (aget remote remote-slot-ackq)] + (let [^objects prv (aget nxt ack-slot-prev)] + (aset ack ack-slot-next nxt) + (aset ack ack-slot-prev prv) + (aset prv ack-slot-next ack) + (aset nxt ack-slot-prev ack)) + (do (aset remote remote-slot-ackq ack) + (aset ack ack-slot-prev ack) + (aset ack ack-slot-next ack)))) + (encode [acks toggle change freeze] + (aget channel channel-slot-writer-opts))))))) + (let [e (aget channel channel-slot-shared)] + (aset channel channel-slot-shared nil) + (throw e))) + (catch #?(:clj Throwable :cljs :default) e + (channel-crash channel) + (throw e)) + (finally + (if (zero? (aget channel channel-slot-alive)) + (do (aset channel channel-slot-step nil) + (aset channel channel-slot-ready (aget peer peer-slot-channel-ready)) + (aset peer peer-slot-channel-ready channel)) + (aset channel channel-slot-ready channel)) + (exit peer busy))))) + +(defn remote-toggle [^objects remote ^Slot slot] + (let [^objects output (output-check-create remote (slot-port slot))] + ((if (aget output output-slot-requested) + output-down output-up) output) remote)) + +(defn channel-ready [^objects channel busy] + (let [^objects remote (aget channel channel-slot-remote) + ^objects peer (aget remote remote-slot-peer)] + (while (aset channel channel-slot-busy + (not (aget channel channel-slot-busy))) + (if (aget channel channel-slot-over) + (channel-terminated channel) + (if (identical? channel (aget remote remote-slot-channel)) + (try + (let [[acks toggle change freeze] + (decode @(aget channel channel-slot-process) + (aget channel channel-slot-reader-opts))] + (reduce remote-toggle remote toggle) + (reduce-kv remote-change remote change) + (reduce remote-freeze remote freeze) + (dotimes [_ acks] (remote-ack remote)) + (when (pos? (+ (count toggle) (count change) (count freeze))) + (aset remote remote-slot-acks + (inc (aget remote remote-slot-acks))) + (channel-output-event channel))) + (catch #?(:clj Throwable :cljs :default) e + (channel-crash channel) + (aset channel channel-slot-shared e) + (channel-output-event channel))) + (try @(aget channel channel-slot-process) + (catch #?(:clj Throwable :cljs :default) _))))) + (exit peer busy))) + +(deftype Channel [state] + IFn + (#?(:clj invoke :cljs -invoke) [_] + (channel-cancel state)) + IDeref + (#?(:clj deref :cljs -deref) [_] + (channel-transfer state))) + +(defn channel-writer-opts [opts ^objects channel] + (let [handlers (merge + (::t/write-handlers opts {}) + {Slot (t/write-handler + (fn [_] "slot") + (fn [^Slot slot] + [(.-frame slot) (.-id slot)])) + Frame (t/write-handler + (fn [_] "frame") + (fn [^Frame frame] + (let [slot (.-slot frame) + rank (.-rank frame) + shared (aget channel channel-slot-shared)] + [slot rank + (when-not (nil? slot) + (when-not (contains? shared [slot rank]) + (aset channel channel-slot-shared + (assoc shared [slot rank] 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)])) + Unbound (t/write-handler + (fn [_] "unbound") + (fn [^Unbound unbound] + [(.-key unbound)]))}) + default (t/write-handler + (fn [v] (prn :unserializable v) "unserializable") + (fn [_]))] + #?(:clj {:handlers handlers :default-handler default} + :cljs {:handlers (assoc handlers :default default)}))) + +(defn channel-reader-opts [opts ^objects channel] + {:handlers (merge + (::t/read-handlers opts {}) + {"slot" (t/read-handler + (fn [[frame id]] + (->Slot frame id))) + "frame" (t/read-handler + (fn [[slot rank ctor]] + (let [^objects remote (aget channel channel-slot-remote) + ^objects peer (aget remote remote-slot-peer) + shared (aget channel channel-slot-shared)] + (if (nil? ctor) + (if (nil? slot) + (aget peer peer-slot-root) + (get shared [slot rank])) + (let [frame (make-frame peer slot rank (port-site (slot-port slot)) ctor)] + (aset channel channel-slot-shared + (assoc shared [slot rank] 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 [[value]] + (->Pure value nil))) + "unbound" (t/read-handler + (fn [[key]] + (->Unbound key nil))) + "unserializable" (t/read-handler + (fn [_] + (->Failure :unserializable)))})}) + +(defn remote-handler [opts ^objects peer] + (fn [events] + (fn [step done] + (let [busy (enter peer) + ^objects remote (aget peer peer-slot-remote)] + (if (nil? (aget remote remote-slot-channel)) + (let [channel (object-array channel-slots)] + (aset remote remote-slot-channel channel) + (aset channel channel-slot-remote remote) + (aset channel channel-slot-step step) + (aset channel channel-slot-done done) + (aset channel channel-slot-busy true) + (aset channel channel-slot-over false) + (aset channel channel-slot-events events) + (aset channel channel-slot-alive (identity 1)) + (aset channel channel-slot-shared {}) + (aset channel channel-slot-writer-opts (channel-writer-opts opts channel)) + (aset channel channel-slot-reader-opts (channel-reader-opts opts channel)) + (aset channel channel-slot-ready (aget peer peer-slot-channel-ready)) + (aset peer peer-slot-channel-ready channel) + (aset channel channel-slot-process + ((aget remote remote-slot-events) + #(let [^objects remote (aget channel channel-slot-remote)] + (channel-ready channel (enter (aget remote remote-slot-peer)))) + #(let [^objects remote (aget channel channel-slot-remote)] + (aset channel channel-slot-over true) + (channel-ready channel (enter (aget remote remote-slot-peer)))))) + (reduce channel-output-sub channel (vals (aget remote remote-slot-outputs))) + (channel-ready channel busy) + (->Channel channel)) + (do (exit peer busy) (step) + (->Failer done (error "Can't connect - remote already up.")))))))) + +(defn input-toggle-event [^objects input] + (let [^objects remote (aget input input-slot-remote)] + ((if (nil? (aget input input-slot-prev)) + input-enqueue input-dequeue) input) + (when-some [^objects channel (aget remote remote-slot-channel)] + (channel-output-event channel)))) + +(defn dep-attach [^objects port] + (let [slot (port-slot port) + ^objects peer (frame-peer (slot-frame slot)) + busy (enter peer) + ^objects remote (aget peer peer-slot-remote) + ^objects input (input-check-create remote port) + requested (aget input input-slot-requested)] + (aset input input-slot-requested (inc requested)) + (when (zero? requested) (input-toggle-event input)) + (exit peer busy))) + +(defn dep-detach [^objects port] + (let [slot (port-slot port) + ^objects peer (frame-peer (slot-frame slot)) + busy (enter peer) + ^objects remote (aget peer peer-slot-remote) + ^objects input (input-check-create remote port) + requested (dec (aget input input-slot-requested))] + (aset input input-slot-requested requested) + (when (zero? requested) (input-toggle-event input)) + (exit peer busy))) + +(defn with-dep [flow ^objects port] + (fn [step done] + (dep-attach port) + (flow step + #(do (dep-detach port) + (done))))) + +;; is expr always a slot ? if true, we can specialize to ports +(deftype Incseq [peer expr] + IFn + (#?(:clj invoke :cljs -invoke) [_ step done] + ((deps expr with-dep (flow expr) (peer-site peer)) step done))) + +(defn incseq-expr [^Incseq incseq] + (.-expr incseq)) + +(defn incseq [^Frame frame expr] + (->Incseq (frame-peer frame) expr)) + +(defn frame-result-slot [^Frame frame] + (let [^objects nodes (.-nodes frame)] + (node frame (dec (alength nodes))))) + +(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 create-call [^Slot slot site expr] + (let [^Frame parent (.-frame slot) + ^objects peer (.-peer parent) + call (object-array call-slots)] + (aset call call-slot-port + (make-port slot site + (deps expr update-inc {} site) + (i/latest-product + (fn [ctor] + (let [rank (aget call call-slot-rank) + frame (make-frame peer slot rank site ctor)] + (aset call call-slot-rank (inc rank)) frame)) + (flow expr)))) + (aset call call-slot-rank (identity 0)) + call)) + +(defn define-call + "Defines call site id for given frame." + [^Frame frame id expr] + (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 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 nil))) + ([^Frame frame key nf] + (loop [frame frame] + (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 [[_ _ free _] (frame-ctor frame)] + (free id))) + +(defn make-remote [^objects peer] + (let [^objects remote (object-array remote-slots)] + (aset remote remote-slot-peer peer) + (aset remote remote-slot-inputs {}) + (aset remote remote-slot-outputs {}) + (aset remote remote-slot-acks (identity 0)) + (aset remote remote-slot-freeze #{}) + (aset remote remote-slot-events + (m/stream + (m/observe + (fn [!] + (let [^objects channel (aget remote remote-slot-channel) + events (aget channel channel-slot-events)] + (aset channel channel-slot-events nil) + (events !)))))) + remote)) + +(defn make-peer " +Returns a new peer instance for given site, from given definitions and main key and optional extra arguments to the +entrypoint. +" [site defs main args] + (let [^objects peer (object-array peer-slots) + ^objects remote (make-remote peer)] + (aset peer peer-slot-busy #?(:clj (ReentrantLock.) :cljs false)) + (aset peer peer-slot-site site) + (aset peer peer-slot-defs defs) + (aset peer peer-slot-remote remote) + (aset peer peer-slot-root + (->> args + (eduction (map pure)) + (apply dispatch "" ((defs main))) + (make-frame peer nil 0 :client))) peer)) + +(defn peer-root-frame [^objects peer] + (aget peer peer-slot-root)) + +(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[") + (print-method (.-frame slot) w) + (.write w " ") + (print-method (.-id slot) 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] + (.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 "]")) + :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 "]")))) + +(defn get-destructure-map [gmap] + (if (seq? gmap) + (if (next gmap) + (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}))) + +(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))) + +(defn client " +Allocates a new client peer and returns a task consuming its return value using given connector as its server +communication channel. `connector` must be a function taking the remote handler as an argument and returning +a task managing the lifecycle of the channel. + +The remote handler is a function taking a subject and returning a flow. The flow emits outgoing events and reads +incoming events on the subject. +" [opts connector defs main & args] + (let [peer (make-peer :client defs main args)] + (m/reduce (comp reduced {}) nil + (m/ap + (m/amb= (m/? (connector (remote-handler opts peer))) + (m/? (m/reduce (constantly nil) (peer-root-frame peer)))))))) + +(defn server " +Allocates a new server peer and returns its remote handler. +" [opts defs main & args] + (remote-handler opts (make-peer :server defs main args))) diff --git a/src/hyperfiddle/electric/impl/sampler.cljc b/src/hyperfiddle/electric/impl/sampler.cljc deleted file mode 100644 index bf77d4485..000000000 --- a/src/hyperfiddle/electric/impl/sampler.cljc +++ /dev/null @@ -1,37 +0,0 @@ -(ns hyperfiddle.electric.impl.sampler - #?(:clj (:import (clojure.lang IFn IDeref))) - #?(:cljs (:require-macros [hyperfiddle.electric.impl.sampler :refer [lock]]))) - -#?(:clj - (defmacro lock [& args] - (cons (if (:js-globals &env) `do `locking) args))) - -(deftype Sampler [deref] - IDeref - (#?(:clj deref :cljs -deref) [this] (deref this))) - -; flow is a continuous flow -; repl operator with two features -; as lazy as the original flow, or maybe the lazyness is controlled -; you control when the flow is actually sampled -; memoized, so don't need to remember if flow is ready -(defn sampler! [cb flow] - (let [memo (int 0) - iter (int 1) - slots (object-array 2) - sampler (->Sampler - #(lock % - (let [x (aget slots memo)] - (if (identical? x slots) - (loop [] - (aset slots memo nil) - (let [x @(aget slots iter)] - (if (identical? slots (aget slots memo)) - (recur) (aset slots memo x)))) - x))))] - (aset slots iter (flow #(lock sampler - (if (identical? slots (aget slots memo)) - (cb sampler) (aset slots memo slots))) #())) - (lock sampler - (if (identical? slots (aget slots memo)) - (cb sampler) (aset slots memo slots))) sampler)) \ No newline at end of file diff --git a/src/hyperfiddle/electric/impl/yield.cljc b/src/hyperfiddle/electric/impl/yield.cljc deleted file mode 100644 index a7c1e39ad..000000000 --- a/src/hyperfiddle/electric/impl/yield.cljc +++ /dev/null @@ -1,149 +0,0 @@ -(ns hyperfiddle.electric.impl.yield - (:require - [missionary.core :as m] - [hyperfiddle.rcf :as rcf :refer [tests with tap %]]) - #?(:clj (:import (clojure.lang IFn IDeref)))) - -;; Superseded by yield2 namespace, which adds work skipping - -(defn aswap - ([^objects arr slot f] (aset arr slot (f (aget arr slot)))) - ([^objects arr slot f a] (aset arr slot (f (aget arr slot) a))) - ([^objects arr slot f a b] (aset arr slot (f (aget arr slot) a b))) - ([^objects arr slot f a b c] (aset arr slot (f (aget arr slot) a b c))) - ([^objects arr slot f a b c & ds] (aset arr slot (apply f (aget arr slot) a b c ds)))) - -(def iterator (int 0)) -(def busy (int 1)) ; boolean, true when the process is ready to ready -(def done (int 2)) ; boolean, true when the main flow (arg 2 to yield, the input) is terminated -(def alive (int 3)) ; number, count of child processes still alive -(def active (int 4)) ; state array of the currently focused flow - -(declare cancel transfer) -(deftype Yield [check notifier terminator state] - IFn - (#?(:clj invoke :cljs -invoke) [this] - (locking this (cancel state))) - IDeref - (#?(:clj deref :cljs -deref) [this] - (locking this (transfer this)))) - -(defn ready [^Yield main ^objects child_] - (let [^objects main_ (.-state main)] - (loop [] - (when (aset child_ busy (not (aget child_ busy))) - (if (aget child_ done) - (do (when (zero? (aswap main_ alive dec)) - ((.-terminator main))) (recur)) - (let [^objects active_ (aget main_ active)] - (if (identical? child_ active_) - ((.-notifier main)) - (if (and (identical? child_ main_) (some? active_)) - ;; FIXME don't cancel the child immediately, defer due to work skipping - (let [it (aget active_ iterator)] - (aset main_ active main_) (it) - (if (aget active_ busy) - (do (try @it (catch #?(:clj Throwable :cljs :default) _)) - (ready main active_)) ((.-notifier main)))) - (let [it (aget child_ iterator)] - (try @it (catch #?(:clj Throwable :cljs :default) _)) - (recur)))))))))) - -(defn cancel [^objects s] - ((aget s iterator))) - -(defn transfer [^Yield r] - (let [^objects s (.-state r) - ^objects f (aget s active)] - (try - (let [x @(aget f iterator)] - (if (identical? f s) - ;; TODO if x = current don't run below, just return x - (if-some [>e ((.-check r) x)] - (let [f (doto (object-array 3) - (aset busy true) - (aset done false)) - i (>e #(locking r (ready r f)) - #(locking r - (aset f done true) - (ready r f)))] - (aset f iterator i) - (aset s active f) - (aswap s alive inc) - (doto (aswap f busy not) - (assert "Initialization failure.")) - (try @i (finally (ready r f)))) x) x)) - (catch #?(:clj Throwable :cljs :default) e - (cancel s) (aset s active nil) (throw e)) - (finally (ready r f))))) - -(defn yield " -Returns a continuous flow producing values produced by continuous flow >x, passing each sampled value to function f. -If the result is nil, the value is returned as is, otherwise the result is run as a flow and its values are output -until the input flow becomes ready again, at which point the recovery flow is cancelled." - [f >x] - (fn [n t] - (let [main_ (doto (object-array 5) - (aset busy true) - (aset done false) - (aset alive 1)) - r (->Yield f n t main_)] - (aset main_ active main_) - (aset main_ iterator - (>x #(locking r (ready r main_)) - #(locking r - (aset main_ done true) - (ready r main_)))) - (doto r (ready main_))))) - -(comment - (def !e (atom "odd")) - (def !x (atom 0)) - (def it - ((yield - (fn [x] (when (odd? x) (m/watch !e))) - (m/watch !x)) - #(prn :ready) #(prn :done))) - (it) - @it := 0 - (swap! !x inc) - @it := "odd" - (reset! !e "ODD") - @it := "ODD" - (swap! !x inc) - @it := 2 - - ) - -(tests "work skipping" - (def !e (atom "odd")) - (def !x (atom 0)) - (def it - ((yield - ;; TODO test m/watch is not cancelled - (fn [x] (tap x) (when (odd? x) (m/watch !e))) - (m/watch !x)) - #(do) #(do))) - @it := 0, % := 0 - (swap! !x inc) - @it := "odd", % := 1 - (swap! !x identity) - @it := "odd", % := 1 ; this 1 shouldn't happen, work skipping - (it) - ) - -(tests "child not cancelled on duplicate" - (def !x (atom 0)) - (def it - ((yield - (fn [x] (tap x) (when (odd? x) (m/observe (fn [!] (! :init) #(tap :cancelled))))) - (m/watch !x)) - #(do) #(do))) - @it := 0, % := 0 - (swap! !x inc) - @it := :init, % := 1 - (swap! !x identity) - % := :cancelled ; wrong - @it := :init, % := 1 - (it) - ) diff --git a/src/hyperfiddle/electric/impl/yield2.cljc b/src/hyperfiddle/electric/impl/yield2.cljc deleted file mode 100644 index 1af2b6506..000000000 --- a/src/hyperfiddle/electric/impl/yield2.cljc +++ /dev/null @@ -1,175 +0,0 @@ -(ns hyperfiddle.electric.impl.yield2 - #?(:cljs (:require-macros hyperfiddle.electric.impl.yield2)) - (:import [missionary Cancelled] - #?(:clj [clojure.lang IFn IDeref ExceptionInfo])) - (:require [hyperfiddle.rcf :as rcf :refer [tests tap %]] - [hyperfiddle.electric.impl.array-fields :as a] - [missionary.core :as m])) -;; #?(:clj (set! *warn-on-reflection* true)) -(declare cancel transfer) -(a/deffields input recover children last-in last-out) ; Yield's array fields -(deftype Yield [checker notifier terminator state-] - IFn (#?(:clj invoke :cljs -invoke) [this] (locking this (cancel this))) - IDeref (#?(:clj deref :cljs -deref) [this] (locking this (transfer this)))) -(a/deffields iterator notified? on-notify) ; a child's array fields -(defn input-notified [^Yield Y] - (when-not (or (a/getset (a/fget Y input) notified? true) (some-> (a/fget Y recover) (a/get notified?))) - ((.-notifier Y)))) -(defn recover-notified [^Yield Y] - (when-not (or (a/getset (a/fget Y recover) notified? true) (a/get (a/fget Y input) notified?)) - ((.-notifier Y)))) -(defn terminated [^Yield Y] (when (zero? (a/fswap Y children dec)) ((.-terminator Y)))) -(defn swallow [o] (try @(a/get o iterator) (catch #?(:clj Throwable :cljs :default) _))) -(defn trash [o] (a/set o on-notify #(swallow o)) ((a/get o iterator)) (when (a/getset o notified? false) (swallow o))) -(defn cancel [^Yield Y] ((a/get (a/fget Y input) iterator)) (when-some [rec (a/fget Y recover)] (trash rec))) -(defn create-recover [^Yield Y >r] - (when-some [rec (a/fget Y recover)] (trash rec)) - (a/fswap Y children inc) - (let [me (a/fset Y recover (object-array 3))] - (a/set me on-notify #(a/set me notified? true), iterator (>r #((a/get me on-notify)) #(terminated Y))))) -(defn transfer-loop [o] (a/set o notified? false) (let [v @(a/get o iterator)] (if (a/get o notified?) (recur o) v))) -(defn transfer-recover [^Yield Y] (a/fset Y last-out (transfer-loop (a/fget Y recover)))) -(defn transfer-input [^Yield Y] - (let [in (transfer-loop (a/fget Y input))] - (if (= in (a/fget Y last-in)) - (if (some-> (a/fget Y recover) (a/get notified?)) - (transfer-recover Y) - (a/fget Y last-out)) - (if-some [>recover ((.-checker Y) in)] - (let [out (do (create-recover Y >recover) (transfer-recover Y))] - (a/set (a/fget Y recover) on-notify #(recover-notified Y)) - (a/fset Y last-in in, last-out out)) - (do (a/fset Y last-in ::none) (when-some [rec (a/fget Y recover)] (trash rec)) in))))) -(defn transfer [^Yield Y] - (try (a/fswap Y children inc) - (cond (a/get (a/fget Y input) notified?) (transfer-input Y) - (a/get (a/fget Y recover) notified?) (transfer-recover Y) - :else (throw (ex-info "You cannot transfer a value if I haven't notified you" {}))) - (catch #?(:clj Throwable :cljs :default) e - (trash (a/fget Y input)) (when-some [rec (a/fget Y recover)] (trash rec)) (throw e)) - (finally (terminated Y)))) -(defn yield [checker >input] - (fn [n t] - (let [^Yield Y (->Yield checker n t (object-array 5)) - me (a/fset Y children 1, last-in ::none, input (object-array 3))] - (a/set me on-notify #(input-notified Y), iterator (>input #((a/get me on-notify)) #(terminated Y))) - Y))) -;;; TESTS ;;; -(tests "input flow with nil checker is noop" - (def !x (atom 0)) - (def it ((yield (constantly nil) (m/watch !x)) - #(tap :notified) #(tap :terminated))) - #_start % := :notified, @it := 0 - (swap! !x inc) % := :notified, @it := 1 - (swap! !x inc) % := :notified, @it := 2 - (it) % := :notified, @it :throws Cancelled, % := :terminated) -(tests "input flow runs recovery" - (def !x (atom 0)) - (def !recover (atom 10)) - (def it ((yield (constantly (m/watch !recover)) (m/watch !x)) #(tap :notified) #(tap :terminated))) - #_start % := :notified, @it := 10 - (swap! !x inc) % := :notified, @it := 10 - (swap! !recover inc) % := :notified, @it := 11 - (it) % := :notified, @it :throws Cancelled, % := :terminated) -(tests "oscillate" - (def !e (atom "odd")) - (def !x (atom 0)) - (def it ((yield (fn [x] (when (odd? x) (m/watch !e))) (m/watch !x)) #(do) #(do))) - #_start @it := 0 - (swap! !x inc) @it := "odd" - (reset! !e "ODD") @it := "ODD" - (swap! !x inc) @it := 2 - (it)) -(tests "work skipping" - (def !e (atom "odd")) - (def !x (atom 0)) - (def it ((yield (fn [x] (tap x) (when (odd? x) (m/watch !e))) (m/watch !x)) #(do) #(do))) - #_start @it := 0, % := 0 - (swap! !x inc) @it := "odd", % := 1 - (swap! !x identity) @it := "odd" ; nothing tapped, work skipped - (reset! !e "ODD") @it := "ODD" ; recovery flow is still alive - (swap! !x inc) @it := 2, % := 2 - (it)) -(tests "work skipping, initially in recovery" - (def !e (atom "odd")) - (def !x (atom 1)) - (def it ((yield (fn [x] (tap x) (when (odd? x) (m/watch !e))) (m/watch !x)) #(do) #(do))) - #_start @it := "odd", % := 1 - (swap! !x identity) @it := "odd" ; nothing tapped, work skipped - (reset! !e "ODD") @it := "ODD" ; recovery flow is still alive - (swap! !x inc) @it := 2, % := 2 - (it)) -(tests "work skipping m/cp" - (def !x (atom 1)) - (def it ((yield (fn [x] (tap x) (when (odd? x) (m/cp "odd"))) (m/watch !x)) #(do) #(do))) - #_start @it := "odd", % := 1 - (swap! !x identity) @it := "odd" ; nothing tapped, work skipped - (swap! !x inc) @it := 2, % := 2 - (it)) -(tests "recovery flows are cleaned up" - (def !x (atom 0)) - (let [->recover (m/observe (fn [!] (! :init) #(tap :unmounted)))] - (def it ((yield (fn [x] (when (pos? x) ->recover)) (m/watch !x)) #(do) #(tap :terminated)))) - #_start @it := 0 - (swap! !x inc) @it := :init ; first recovery starts - (swap! !x inc) @it := :init, % := :unmounted ; second starts, first unmounts - (it) @it :throws Cancelled, % := :unmounted, % := :terminated) -(tests "an immediately ready input works" - (def it ((yield (fn [x] (when (pos? x) (m/cp :recover))) (m/seed [0 1 2])) #(do) #(tap :terminated))) - ;; 0 and 1 are not seen because of the consecutive transfer - @it := :recover, (it), % := :terminated) -(tests "an immediately ready recovery works" - (def it ((yield (fn [_] (m/seed [0 1 2])) (m/cp :hi)) #(do) #(tap :terminated))) - ;; 0 and 1 are not seen because of the consecutive transfer - @it := 2, (it), % := :terminated) -(tests "input throws" - (def !x (atom 0)) - (def it ((yield (constantly nil) (m/latest #(if (pos? %) (throw (ex-info "pos" {})) %) (m/watch !x))) - #(tap :notified) #(tap :terminated))) - % := :notified, @it := 0 - (swap! !x inc) % := :notified, @it :throws ExceptionInfo, % := :terminated) -(tests "recovery throws" - (def !x (atom 0)) - (def it ((yield (fn [x] (when (pos? x) (m/cp (throw (ex-info "boom" {}))))) (m/watch !x)) - #(tap :notified) #(tap :terminated))) - #_start % := :notified, @it := 0 - (swap! !x inc), % := :notified, @it :throws ExceptionInfo, % := :terminated) -(tests "recovery unmounts when we switch back to input" - (def !x (atom 0)) - (let [->recover (m/observe (fn [!] (! :init) #(tap :unmounted)))] - (def it ((yield (fn [x] (when (odd? x) ->recover)) (m/watch !x)) #(do) #(tap :terminated)))) - #_start @it := 0 - (swap! !x inc) @it := :init ; recovery starts - (swap! !x inc) @it := 2, % := :unmounted ; back to input, recovery stops - (it) @it :throws Cancelled, % := :terminated) -(tests "work skipping is invalidated after successful input" - (def !x (atom 0)) - (def it ((yield (fn [x] (when (odd? x) (tap :recover) (m/cp :recover))) (m/watch !x)) #(do) #(tap :terminated))) - #_start @it := 0 - (swap! !x inc) @it := :recover, % := :recover - (swap! !x inc) @it := 2 - "same input but good input in between, so won't work skip" - (swap! !x dec) @it := :recover, % := :recover - (it) @it :throws Cancelled, % := :terminated) -(tests "initial nil isn't work skipped" - (def it ((yield (fn [_] (tap :recover) nil) (m/cp nil)) #(do) #(do))) - @it := nil, % := :recover) -(tests "cache updates on recover values" - (def !in (atom 0)) - (def !x (atom 0)) - (def it ((yield (fn [_] (m/watch !x)) (m/watch !in)) #(do) #(do))) - #_start @it := 0 - (swap! !x inc) @it := 1 - (swap! !in identity) @it := 1) -(tests "yield stays alive as long as the recover is alive" - (def !x (atom 0)) - (def it ((yield (fn [_] (m/watch !x)) (m/cp)) #(tap :notified) #(tap :terminated))) - #_start % := :notified, @it := 0 - (swap! !x inc) % := :notified, @it := 1) -(tests "if same input arrives and recover notified recover is re-transferred" - (def !x (atom 0)) - (def !err (atom 100)) - (def it ((yield (fn [_] (m/watch !err)) (m/watch !x)) #(tap :notified) #(tap :terminated))) - #_start % := :notified, @it := 100 - (swap! !err inc) (swap! !x identity) % := :notified, @it := 101 - (swap! !err inc) % := :notified, @it := 102) diff --git a/src/hyperfiddle/electric/shadow_cljs/hooks.clj b/src/hyperfiddle/electric/shadow_cljs/hooks.clj deleted file mode 100644 index e924a77f0..000000000 --- a/src/hyperfiddle/electric/shadow_cljs/hooks.clj +++ /dev/null @@ -1,131 +0,0 @@ -(ns hyperfiddle.electric.shadow-cljs.hooks - (:require [hyperfiddle.electric :as-alias e] - [hyperfiddle.electric.impl.lang :as lang] - [clojure.string :as str] - [hyperfiddle.electric.impl.expand :as expand])) - -(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] - (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! expand/!cljs-ns-cache dissoc ns-sym) - (require ns-sym :reload)))))) - build-state)) - -(defmacro when-class-available - "Expands to `body` in a java class named by `class-sym` is available on the classpath at compile time. - Expands to nil otherwise." - [class-sym & body] - (when (try (Class/forName (name class-sym)) - (catch ClassNotFoundException _ false)) - `(do ~@body))) - -(defn jackson-version [] - (when-class-available com.fasterxml.jackson.core.json.PackageVersion - (bean com.fasterxml.jackson.core.json.PackageVersion/VERSION))) - -(defn is-jackson-limiting-string-size? - "Read Jackson’s version and return: - - ::no-limit if version is older than 2.15, - - ::limited if version is 2.15 or 2.15.1, - - ::configurable if version is at least 2.15.2, - - ::unavailable if Jackson is not on the classpath." [] - (if-let [version (jackson-version)] - (let [{:keys [majorVersion minorVersion patchLevel]} version] - (cond - (and (<= majorVersion 2) (< minorVersion 15)) ::no-limit ; < 2.15, no string size limit, we are good. - (and (<= majorVersion 2) (<= minorVersion 15) (< 2 patchLevel)) ::limited ; < 2.15.2, with hard-coded limits (non-configurable) - :else ::configurable ; > 2.15.2, limits can be configured, we are good. - )) - ::unavailable)) - - -(let [!jackson-string-size-limit-setting (atom nil)] - (defn allow-large-shadow-cache - "Allows large shadow-cljs cache files. - - This Shadow hook will expand Jackson’s default max string size by `factor`. - - Shadow-cljs caches compiled cljs namespaces into transit-encoded json files. - Electric e/def(n) can expand to a lot of clojure/script code. The Hyperfiddle - team is working on improving the generated code size. In the meantime, we argue - large code size is not an actual issue because: - - server-side code size is not a constraint for the use case of Electric - (long-living web apps), - - client-side code size is efficiently optimized away by the Google Closure - advanced compilation mode (e.g. shadow release), - - gzip compression outshines most code size optimizations. - - However, code size matters in dev mode (e.g. shadow watch). Shadow will cache - compiled cljs namespaces in transit-JSON format. Shadow caches the entire - compiled js file as a JSON string. Transit reads and writes JSON with the - Jackson library. - - Since Jackson 2.15, strings larger than 5Mb were rejected¹. The community - quickly asked for this limit to be raised to 20Mb² and to be configurable³. - These changes were released in Jackson 2.15.2. - - As of December 2023, Transit-java (and so Transit-clj) does not set a max string - size and relies on defaults. We can therefore safely alter defaults for the - extent of a shadow compilation. - - For each compilation (dev and release), this shadow hook will: - - Before compilation: - - capture the current Jackson max string size limit, - - set the limit to `default × factor`. - - After compilation: - - restore the captured max string size limit. - - - ¹ https://github.com/FasterXML/jackson/wiki/Jackson-Release-2.15#processing-limits - ² https://github.com/FasterXML/jackson-core/issues/1014 - ³ https://github.com/FasterXML/jackson-core/pull/1019 - " - {:shadow.build/stages #{:compile-prepare :flush}} - ([build-state] - (allow-large-shadow-cache build-state 1)) - ([build-state factor] - (assert (nat-int? factor) "Cache size factor should be a positive integer.") - (when-class-available com.fasterxml.jackson.core.StreamReadConstraints - (case (:shadow.build/stage build-state) - :compile-prepare (case (is-jackson-limiting-string-size?) - ::unavailable nil - ::no-limit nil - ::limited (println "Your Shadow-cljs setup is too old or one of you dependencies pulled in a version of Jackson older than 2.15.2 ." - "Electric Clojure hot code reload and recompilation might be slow due to Shadow failing to read large cache files." - "Update your dependencies to get Jackson >= 2.15.2 for Electric Clojure to benefit from Shadow-cljs caching." - "See `hyperfiddle.electric.shadow-cljs.hooks/allow-large-shadow-cache`") ; TODO permalink to github source - ::configurable - (swap! !jackson-string-size-limit-setting - (fn [current-default-setting] - (if (some? current-default-setting) - (do (println "Electric Clojure detected two concurrent Shadow-cljs compilations. Client and Server programs might be misaligned.") - current-default-setting) ; another compilation is in progress, don’t race with it. - (let [current-defaults (com.fasterxml.jackson.core.StreamReadConstraints/defaults) - {:keys [maxNestingDepth maxNumberLength maxStringLength]} (bean current-defaults)] - #_(println "Snapshoting default jackson limits" (dissoc (bean current-defaults) :class)) - (com.fasterxml.jackson.core.StreamReadConstraints/overrideDefaultStreamReadConstraints - (.build (doto (com.fasterxml.jackson.core.StreamReadConstraints/builder) - (.maxStringLength (* factor maxStringLength)) - (.maxNumberLength maxNumberLength) - (.maxNestingDepth maxNestingDepth)))) - current-defaults))))) - :flush (swap! !jackson-string-size-limit-setting - (fn [current-default-setting] - (when current-default-setting - #_(println "restoring default jackson settings " (dissoc (bean current-default-setting) :class)) - (com.fasterxml.jackson.core.StreamReadConstraints/overrideDefaultStreamReadConstraints current-default-setting) - nil))) - nil)) - build-state))) diff --git a/src/hyperfiddle/electric/shadow_cljs/hooks3.clj b/src/hyperfiddle/electric/shadow_cljs/hooks3.clj new file mode 100644 index 000000000..6390249db --- /dev/null +++ b/src/hyperfiddle/electric/shadow_cljs/hooks3.clj @@ -0,0 +1,26 @@ +(ns hyperfiddle.electric.shadow-cljs.hooks3 + (:require [shadow.build.compiler] + [hyperfiddle.electric.impl.lang3 :as lang] + [hyperfiddle.electric.impl.cljs-analyzer2 :as cljs-ana])) + +;; 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) diff --git a/src/hyperfiddle/electric3.cljc b/src/hyperfiddle/electric3.cljc new file mode 100644 index 000000000..60f8c8b39 --- /dev/null +++ b/src/hyperfiddle/electric3.cljc @@ -0,0 +1,445 @@ +(ns hyperfiddle.electric3 + (:refer-clojure :exclude [fn defn apply letfn for]) + (:require [hyperfiddle.electric.impl.lang3 :as lang] + [hyperfiddle.electric.impl.runtime3 :as r] + [hyperfiddle.incseq :as i] + [hyperfiddle.electric.impl.mount-point :as mp] + [clojure.core :as cc] + [clojure.string :as str] + [contrib.data] + [hyperfiddle.rcf :as rcf :refer [tests]] + #?(:clj [contrib.triple-store :as ts]) + #?(:clj [fipp.edn]) + [missionary.core :as m] + [contrib.missionary-contrib :as mx] + [clojure.math :as math]) + (:import [missionary Cancelled]) + #?(:cljs (:require-macros hyperfiddle.electric3))) + +(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)))) + +(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 call [F & args] `(check-electric $ (lang/$ ~F ~@args))) +(defmacro $ [F & args] `(call ~F ~@args)) ; compat + +(defmacro frame [] `(::lang/frame)) + +(defmacro pure " +Syntax : +```clojure +(pure table) +``` +Returns the incremental sequence describing `table`. +" [expr] `((::lang/static-vars r/incseq) (frame) (::lang/pure ~expr))) + +(defmacro join " +Syntax : +```clojure +(join incseq) +``` +Returns the successive states of items described by `incseq`. +" [flow] `(::lang/join ~flow)) + +#?(:clj (cc/defn- varargs? [args] (boolean (and (seq args) (= '& (-> args pop peek)))))) + +#?(: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))] + (into (if-some [[args & body] (first varargs)] + (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 + (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_3_walkthrough.md +(defmacro fn [& args] + (let [?nm (first args)] + `(check-electric fn + ~(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)))) + +#?(:clj (tests + (ns-qualify 'foo) := `foo + (ns-qualify 'a/b) := 'a/b)) + +(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) {::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 ~nm2 ~source))) + +(defmacro amb " +Syntax : +```clojure +(amb table1 table2 ,,, tableN) +``` +Returns the concatenation of `table1 table2 ,,, tableN`. +" [& exprs] `(::lang/call (join (i/fixed ~@(map #(list `r/invariant (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] `(check-electric watch (input (m/watch ~ref)))) + +(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] `(->> (pure ~xs) (m/reductions i/patch-vec) (m/latest (partial eduction cat)) (i/diff-by ~f) (join))) + +(defmacro drain " +Syntax : +```clojure +(drain expr) +``` +Samples and discards `expr` synchronously with changes. Returns nothing. +" [expr] `(join (r/drain (pure ~expr)))) + +(defmacro client [& body] `(check-electric client (::lang/site :client ~@body))) +(defmacro server [& body] `(check-electric server (::lang/site :server ~@body))) + +(defmacro for " +Syntax : +```clojure +(for [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] (cc/apply map vector (partition-all 2 bindings))] + `(::lang/call + (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)))))) + +(defmacro cursor [bindings & body] `(for ~bindings ~@body)) ; compat + +(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)))) + +;; mklocal = declare lexical slot +;; bindlocal = bind lexical slot to value by name +;; See compiler walkthrough: electric/impl/lang_3_walkthrough.md +(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.electric3/fn ~@fargs) ~ac)) (cons 'do body) sb) + sb))) + +(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.electric3/defn Dispatch [eF static args] + (let [offset (count static) + arity (+ offset (count args))] ; final count of all args + (if-some [ctor (eF 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" eF arity)] + (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) + static (pop static)] + (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 ; 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)))) + (cc/apply r/bind-args (r/bind (r/bind-self ctor) fixed (::lang/pure (cc/apply (r/varargs map?) args))) static)))))))) + +(hyperfiddle.electric3/defn Apply + ([F a] + (::lang/call ($ Dispatch F [] a))) + ([F a b] + (::lang/call ($ Dispatch F [(::lang/pure a)] b))) + ([F a b c] + (::lang/call ($ Dispatch F [(::lang/pure a) (::lang/pure b)] c))) + ([F a b c d] + (::lang/call ($ Dispatch F [(::lang/pure a) (::lang/pure b) (::lang/pure c)] d))) + ([F a b c d & es] + (::lang/call ($ Dispatch F [(::lang/pure a) (::lang/pure b) (::lang/pure c) (::lang/pure d)] (concat (butlast es) (last es)))))) + +(defmacro apply [& args] `($ Apply ~@args)) + +(hyperfiddle.electric3/defn ; ^:hyperfiddle.electric.impl.lang3/print-clj-source + Partial + "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." + ;; 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. + ([F] F) + ([F arg1] + (hyperfiddle.electric3/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] (hyperfiddle.electric3/apply F arg1 x y z args)))) + ([F arg1 arg2] + (hyperfiddle.electric3/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] (hyperfiddle.electric3/apply F arg1 arg2 x y z args)))) + ([F arg1 arg2 arg3] + (hyperfiddle.electric3/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] (hyperfiddle.electric3/apply F arg1 arg2 arg3 x y z args)))) + ([F arg1 arg2 arg3 & more] + (hyperfiddle.electric3/fn [& args] + (hyperfiddle.electric3/apply F arg1 arg2 arg3 (concat more 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 + +(hyperfiddle.electric3/defn OnUnmount [f] (input (on-unmount* f))) + +(defmacro boot-server [opts Main & args] + (let [env (merge (lang/normalize-env &env) web-config opts) + source (lang/->source env ::Main `(fn [] ($ ~Main ~@args)))] + `(r/server ~(select-keys opts [:cognitect.transit/read-handlers :cognitect.transit/write-handlers]) + (r/->defs {::Main ~source}) ::Main))) + +(defmacro boot-client [opts Main & args] + (let [env (merge (lang/normalize-env &env) web-config opts) + source (lang/->source env ::Main `(fn [] ($ ~Main ~@args)))] + `(r/client ~(select-keys opts [:cognitect.transit/read-handlers :cognitect.transit/write-handlers]) + (hyperfiddle.electric-client3/connector hyperfiddle.electric-client3/*ws-server-url*) + (r/->defs {::Main ~source}) ::Main ))) + +(defmacro boot-single [opts Main & args] + (let [env (merge (lang/normalize-env &env) web-config opts) + source (lang/->source env ::Main `(fn [] ($ ~Main ~@args)))] + `(r/client {} (constantly m/never) + (r/->defs {::Main ~source}) ::Main))) + +;; (cc/defn -snapshot [flow] (->> flow (m/eduction (contrib.data/take-upto (complement #{r/pending}))))) +(cc/defn -snapshot [flow] (->> flow (m/eduction (contrib.data/take-upto (comp pos-int? :degree))))) + +(defmacro snapshot + "Snapshots the first non-Pending value of reactive value `x` and freezes it, +inhibiting all further reactive updates." + [x] `(check-electric snapshot (join (-snapshot (pure ~x))))) + +(hyperfiddle.electric3/defn Snapshot [v] (join (-snapshot (pure v)))) + +(let [->spend-fn (cc/fn [!spend!] (cc/fn f ([] (f nil)) ([ret] (reset! !spend! nil) ret))) + step (cc/fn [!spend! v on?] (when (on? v) (compare-and-set! !spend! nil (->spend-fn !spend!))))] + (hyperfiddle.electric3/defn Token + ([v] ($ Token v some?)) + ([v on?] (let [!spend! (atom nil)] (step !spend! v on?) (watch !spend!))))) + +(let [->spend-fn (cc/fn [!spend!] (cc/fn f ([] (f nil)) ([ret] (reset! !spend! nil) ret))) + step (cc/fn [!spend! _spend! v on?] (when (on? v) (compare-and-set! !spend! nil (->spend-fn !spend!))))] + (hyperfiddle.electric3/defn CyclicToken + ([v] ($ CyclicToken v some?)) + ([v on?] (let [!spend! (atom nil), spend! (watch !spend!)] (step !spend! spend! v on?) spend!)))) + +(let [->spend-fn (cc/fn [!held] (cc/fn f ([] (f nil)) ([ret] (swap! !held assoc 1 nil) ret))) + step (cc/fn [!held v on?] + (let [[_ spend! :as held] @!held] + (when (and (not spend!) (on? v)) + (compare-and-set! !held held [v (->spend-fn !held)]))))] + (hyperfiddle.electric3/defn StampedToken + ([v] ($ StampedToken v some?)) + ([v on?] (let [!held (atom [nil nil])] (step !held v on?) (watch !held))))) + +(let [->spend-fn (cc/fn [!held] (cc/fn f ([] (f nil)) ([ret] (swap! !held assoc 1 nil) ret))) + step (cc/fn [!held _held v on?] + (let [[_ next! :as held] @!held] + (when (and (not next!) (on? v)) + (compare-and-set! !held held [v (->spend-fn !held)]))))] + (hyperfiddle.electric3/defn StampedCyclicToken + ([v] ($ StampedCyclicToken v some?)) + ([v on?] (let [!held (atom [nil nil]), held (watch !held)] (step !held held v on?) held)))) + +(cc/letfn [(->unlatch-fn [!latched?] (cc/fn f ([] (f nil)) ([v] (reset! !latched? false) v))) + (->latch-fn [!latched? unlatch!] (cc/fn f ([] (reset! !latched? unlatch!)) ([_] (f))))] + (hyperfiddle.electric3/defn Latchable [v] + (let [!latched? (atom false), unlatch! (->unlatch-fn !latched?)] + [(if (watch !latched?) ($ Snapshot v) v) (->latch-fn !latched? unlatch!)]))) + +(cc/defn capture-fn + "Captures variability of a function under a stable identity. + Return a proxy to the captured function. + Use case: prevent unmount and remount when a cc/fn argument updates due to an inner variable dependency." + [] + (let [!state (object-array 1) + ret (cc/fn [& args] (cc/apply (aget !state 0) args))] + (cc/fn [x] + (aset !state 0 x) + ret))) + +#?(:cljs + (deftype Clock [^:mutable ^number raf + ^:mutable callback + terminator] + IFn ; cancel + (-invoke [_] + (if (zero? raf) + (set! callback nil) + (do (.cancelAnimationFrame js/window raf) + (terminator)))) + IDeref ; sample + (-deref [_] + ; lazy clock, only resets once sampled + (if (nil? callback) + (terminator) + (set! raf (.requestAnimationFrame js/window callback))) ; RAF not called until first sampling + ::tick))) + +(def ^:no-doc Clock 0 nil t)] + (set! (.-callback cancel) + (cc/fn [_] (set! (.-raf cancel) 0) (n))) + (n) cancel)) + + ; 120 hz server, careful this impacts bandwidth in demo-two-clocks + ; typical UI animation rate is 60 or 120hz, no point in going higher + :clj (m/ap (loop [] (m/amb nil (do (m/? (m/sleep (/ 1000 120))) (recur))))) + #_(m/ap (m/? (m/sleep 1 (m/?> (m/seed (repeat nil)))))))) + +;; TODO add back dom visibility check +(cc/defn -get-system-time-ms [& [_]] #?(:clj (System/currentTimeMillis) :cljs (js/Date.now))) + +(def system-time-ms (m/signal (m/sample -get-system-time-ms 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}))))) + +(cc/letfn [(task->is [t] (uf->is (m/ap (m/? t)))) + (initialized [t init-v] (m/relieve {} (m/ap (m/amb= init-v (m/? t)))))] + (hyperfiddle.electric3/defn Task + ([t] (join (task->is t))) + ([t init-v] (input (initialized t init-v))))) + +#?(:clj (cc/defn -offload [tsk executor] + (uf->is (m/ap (try (m/? (m/via-call executor (m/?< (mx/poll-task tsk)))) + (catch Cancelled _ (m/amb))))))) + + +(hyperfiddle.electric3/defn Offload + ([f!] ($ Offload f! m/blk)) + ([f! executor] (server (let [mbx (m/mbx)] (mbx f!) (join (-offload mbx executor)))))) + + +(def http-request "Bound to the HTTP request of the page in which the current Electric program is running." nil) diff --git a/src/hyperfiddle/electric_client.cljs b/src/hyperfiddle/electric_client.cljs deleted file mode 100644 index cd37c1f46..000000000 --- a/src/hyperfiddle/electric_client.cljs +++ /dev/null @@ -1,182 +0,0 @@ -(ns hyperfiddle.electric-client - (:require [contrib.cljs-target :refer [do-browser]] - [missionary.core :as m] - [hyperfiddle.electric.impl.runtime :as r] - [hyperfiddle.electric.impl.io :as io]) - (: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 (io/encode (m/?> msgs)))))))) - -(defn handle-hf-heartbeat [ws cb] - (fn [msg] - (if (= msg "HEARTBEAT") - (send! ws "HEARTBEAT") - (cb (io/decode msg))))) - -(defn connector " -server : the server part of the program -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)) - (m/ap - (.log js/console "Connected.") - (let [r (m/rdv)] - (m/amb= - (do (m/? (client r (r/subject-at s 0))) - (m/amb)) - (loop [] - (if-some [x (m/? r)] - (m/amb x (recur)) - (m/amb)))))))))] - (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_client3.cljs b/src/hyperfiddle/electric_client3.cljs new file mode 100644 index 000000000..7cd973362 --- /dev/null +++ b/src/hyperfiddle/electric_client3.cljs @@ -0,0 +1,163 @@ +(ns hyperfiddle.electric-client3 + (:require [contrib.cljs-target :refer [do-browser]] + [missionary.core :as m] + [hyperfiddle.electric.impl.runtime3 :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 ws-subject [ws] + (fn [cb] + (set! (.-onmessage ws) (comp (handle-hf-heartbeat ws cb) payload)) + #(set! (.-onmessage ws) nil))) + +(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 connector [url] + (fn [handler] + (m/sp + (loop [delays retry-delays] + (.log js/console "Connecting...") + (when-some [[delay & delays] + (if-some [ws (m/? (connect url))] + (when-some [{:keys [code] :as info} + (try + (m/? (m/race (send-all ws (handler (ws-subject ws))) + (wait-for-close ws))) + (finally + (when-not (= (.-CLOSED js/WebSocket) (.-readyState ws)) + (.close ws) (m/? (m/compel wait-for-close)))))] + (when (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)) + (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_css3.cljc b/src/hyperfiddle/electric_css3.cljc new file mode 100644 index 000000000..50f48ffb3 --- /dev/null +++ b/src/hyperfiddle/electric_css3.cljc @@ -0,0 +1,254 @@ +(ns hyperfiddle.electric-css3 + "Dom3 compatible electric-css + - Experimental — Use it at your own risk. + - Partial at-rules support (only @keyframes ATM) + " + (:require [hyperfiddle.electric3 :as e :refer [$]] + [clojure.string :as str] + #?(:cljs [missionary.core :as m]) + #?(:cljs [goog.style])) + #?(:cljs (:require-macros [hyperfiddle.electric-css3])) + ) + +(defprotocol StyledElement + "Define an object containing CSS rules" + (sheet [this]) + (css-rules [this]) + (find-rule [this rule]) + (add-rule [this rule] [this rule index]) + (delete-rule [this rule])) + +(defn rule-index "Find the rule index in the node sheet's CSSRuleList" [styled-element target-rule] + (let [rules (css-rules styled-element) + len (.-length rules)] + (loop [i 0] + (if (< i len) + (if (= target-rule (aget rules i)) + i + (recur (inc i))) + -1)))) + +#?(:node nil + :cljs + (extend-protocol StyledElement + js/HTMLStyleElement + (sheet [^js this] (.-sheet this)) + (css-rules [^js this] (css-rules (sheet this))) + (find-rule [this rule] (rule-index this rule)) + (add-rule + ([this rule] (add-rule (sheet this) rule)) + ([this rule index] (add-rule (sheet this) rule index))) + js/CSSStyleSheet + (sheet [this] this) + (css-rules [^js this] (.-cssRules this)) + (find-rule [this rule] (rule-index this rule)) + (add-rule + ([this rule] (add-rule this rule (count (css-rules this)))) ; add at the end + ([^js this rule index] (.insertRule this rule index))) + (delete-rule [^js this rule] + (let [idx (find-rule this rule)] + (when (> idx -1) + (.deleteRule this idx)))) + js/CSSGroupingRule + (sheet [this] this) + (css-rules [^js this] (.-cssRules this)) + (find-rule [this rule] (rule-index this rule)) + (add-rule + ([this rule] (add-rule this rule (count (css-rules this)))) ; add at the end + ([^js this rule index] (.insertRule this rule index))) + (delete-rule [^js this rule] + (let [idx (find-rule this rule)] + (when (> idx -1) + (.deleteRule this idx)))) + js/CSSKeyframesRule ; not a subclass of CSSGroupingRule + (sheet [this] this) + (css-rules [^js this] (.-cssRules this)) + (find-rule [^js this rule] (.findRule this (.-keyText rule))) ; identity? + (add-rule + ([this rule] (add-rule this rule nil)) ; no support for index-based insert + ([^js this rule _] (.appendRule this rule))) + (delete-rule [^js this rule] (.deleteRule this (.-keyText rule))))) + +(defprotocol StyleRule + "Interface over a CSS rule" + (set-property [this key value])) + +(defn to-str [x] ((if (keyword? x) name str) x)) +(defn css-compatible-value [x] (if (keyword? x) (name x) x)) + +#?(:node nil + :cljs + (extend-protocol StyleRule + js/HTMLElement + (set-property [^js this key value] (set-property (.-style this) key value)) + js/SVGElement + (set-property [^js this key value] (set-property (.-style this) key value)) + js/CSSStyleRule + (set-property [^js this key value] (set-property (.-style this) key value)) + js/CSSKeyframeRule ; not a subclass of CSSStyleRule + (set-property [^js this key value] (set-property (.-style this) key value)) + js/CSSStyleDeclaration + (set-property [^js this key value] + (let [key (to-str key) + value (css-compatible-value value)] + (if (str/starts-with? key "--") ; CSS variable + (.setProperty this key value) + (when-some [property (goog.style/getVendorJsStyleName_ js/document.body key)] ; normalize property names + (aset this property value))))))) + +#?(:cljs + (defn make-rule "Create a rule in node's stylesheet, return the created rule." [styled-element selector] + (let [sheet (sheet styled-element) + index (.-length (css-rules sheet))] + (add-rule sheet (str (to-str selector) " {}") index) + (aget (css-rules sheet) index)))) + +#?(:cljs + (defn make-rule< "Create and emit a rule for `selector` on mount, remove the rule on unmount." [styled-element selector] + (m/relieve {} (m/observe (fn [!] + (let [rule (make-rule styled-element selector)] + (! rule) + #(delete-rule styled-element rule))))))) + +(defn rule* [styled-element selector declarations] + (when (seq declarations) + `(doto (e/input (make-rule< ~styled-element ~selector)) + ~@(map (fn [[key value]] `(set-property ~key ~value)) declarations)))) + +(def selector "") + +(defn concat-selectors [selectorA selectorB] + (if (empty? selectorA) + selectorB + (str selectorA + (let [selectorB (str/trim selectorB)] + (if (str/starts-with? selectorB "&") + (str/replace-first selectorB "&" "") + (str " " selectorB)))))) + +(def scope "") + +(defn scoped [scope selector] + (if-not (empty? scope) + (concat-selectors (str "." scope) selector) + selector)) + +(defmacro rule [selector & declarations] + (let [[selector declarations] (if (map? selector) ["&" (cons selector declarations)] [selector declarations])] + `(binding [selector (scoped scope (concat-selectors selector ~selector))] + ~@(map #(rule* `hyperfiddle.electric-dom3/node `selector %) (filter map? declarations)) + ~@(remove map? declarations)))) + +(comment + (rule {:color :red}) + (rule "foo" {:color :red :height 2} {:width 1}) + (rule "foo" {:color :red} + (rule "&.bar" {:color :blue})) + ) + +(defmacro keyframes "Create an @keyframes rule group. Note @keyframes are always + global, even if defined in a scoped style. Can only contain `keyframe` rules." + [animation-name & keyframes] + `(binding [hyperfiddle.electric-dom3/node (e/input (make-rule< hyperfiddle.electric-dom3/node ~(str "@keyframes " animation-name)))] + ~@keyframes)) + +(defmacro keyframe + "Take a `stop` string (e.g. \"from\", \"to\", \"0%\", \"50%\", etc...) and a map of css declarations to apply at the given `stop`. + Will add the animation stop to the current `keyframes`. Can only be used in a `keyframes` block. + Note that adding or removing a `keyframe` at runtime resets running animations, but changing a keyframe's content doesn't. " + [stop declarations] + (rule* `hyperfiddle.electric-dom3/node stop 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 `