Repository: hyperfiddle/rcf Branch: master Commit: 5d81fde08ce3 Files: 38 Total size: 93.2 KB Directory structure: gitextract_sxhcwvab/ ├── .cljfmt.edn ├── .github/ │ └── workflows/ │ ├── tests_babashka.yml │ ├── tests_browser.yml │ ├── tests_clj.yml │ └── tests_node.yml ├── .gitignore ├── License.md ├── README.md ├── bb/ │ └── runner.clj ├── bb.edn ├── build.clj ├── build.md ├── ci/ │ ├── run_tests_all.sh │ ├── run_tests_browser.sh │ ├── run_tests_jvm.sh │ └── run_tests_node.sh ├── deps.edn ├── example/ │ ├── dev_entrypoint.cljc │ └── example.cljc ├── out/ │ └── index.html ├── package.json ├── pom.xml ├── run_dev_repl.sh ├── shadow-cljs.edn ├── src/ │ └── hyperfiddle/ │ ├── rcf/ │ │ ├── analyzer.clj │ │ ├── impl.clj │ │ ├── queue.clj │ │ ├── queue.cljs │ │ ├── reporters.clj │ │ ├── reporters.cljs │ │ ├── time.cljc │ │ └── unify.cljc │ └── rcf.cljc └── test/ └── hyperfiddle/ ├── rcf/ │ ├── analyzer_test.clj │ ├── cljs_test.cljs │ ├── example_test.clj │ └── unify_test.cljc └── rcf_test.cljc ================================================ FILE CONTENTS ================================================ ================================================ FILE: .cljfmt.edn ================================================ {:indents ^:replace {#"^." [[:inner 0]]} :test-code [(sui/ui-grid {:columns 2} (sui/ui-grid-row {} (sui/ui-grid-column {:width 12} ...))) (let [foo bar] (str "foo" "bar"))]} ================================================ FILE: .github/workflows/tests_babashka.yml ================================================ name: Babashka on: [push, pull_request] jobs: babashka: runs-on: [ubuntu-latest] steps: - name: Checkout uses: actions/checkout@v2 - name: Prepare java uses: actions/setup-java@v1 with: java-version: 1.8 - name: Install clojure tools uses: DeLaGuardo/setup-clojure@10.1 with: cli: 1.10.1.727 bb: latest - name: Run tests run: bb test:bb ================================================ FILE: .github/workflows/tests_browser.yml ================================================ name: Browser on: [push, pull_request] jobs: browser: runs-on: [ubuntu-latest] steps: - name: Checkout uses: actions/checkout@v2 - name: Prepare java uses: actions/setup-java@v1 with: java-version: 1.8 - name: Install clojure tools uses: DeLaGuardo/setup-clojure@3.4 with: cli: 1.10.1.727 - name: Use Node.js uses: actions/setup-node@v2 with: node-version: 17.8.0 - name: Install Shadow run: npm install --also dev - name: Run Tests run: ./ci/run_tests_browser.sh ================================================ FILE: .github/workflows/tests_clj.yml ================================================ name: JVM on: [push, pull_request] jobs: clojure: runs-on: [ubuntu-latest] steps: - name: Checkout uses: actions/checkout@v2 - name: Prepare java uses: actions/setup-java@v1 with: java-version: 1.8 - name: Install clojure tools uses: DeLaGuardo/setup-clojure@3.4 with: cli: 1.10.1.727 - name: Run tests run: ./ci/run_tests_jvm.sh ================================================ FILE: .github/workflows/tests_node.yml ================================================ name: NodeJS on: [push, pull_request] jobs: node: runs-on: [ubuntu-latest] steps: - name: Checkout uses: actions/checkout@v2 - name: Prepare java uses: actions/setup-java@v1 with: java-version: 1.8 - name: Install clojure tools uses: DeLaGuardo/setup-clojure@3.4 with: cli: 1.10.1.727 - name: Use Node.js uses: actions/setup-node@v2 with: node-version: 17.8.0 - name: Install Shadow run: npm install shadow-cljs - name: Run Tests run: ./ci/run_tests_node.sh ================================================ FILE: .gitignore ================================================ .cpcache/ .nrepl-port .cljs_node_repl/ .shadow-cljs/ .rebel_readline_history .idea out/js *.js *.js.map *.DS_Store node_modules /target .clj-kondo/ .lsp/ scratch/ .calva/ ================================================ FILE: License.md ================================================ Copyright 2021 Hyperfiddle, Inc. Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ================================================ FILE: README.md ================================================ # RCF – REPL-first async test macro for Clojure/Script RCF turns your Rich Comment Forms into tests (in the same file as your functions). Send form or file to REPL to run tests and it squirts dopamine ✅✅✅. It's good, try it! ![](https://i.imgur.com/nBOOZq7.png) Features * Clojure/Script * async tests * zero boilerplate * natural REPL workflow * one key-chord to run tests, no hotkey configuring * same-file tests (examples are better than docstrings) * no file watchers, no extra windows, no beeping, no latency * notebook support – [example NextJournal notebook](https://nextjournal.com/dustingetz/missionary-relieve-backpressure) * it's fun! ✅✅✅ RCF is specifically engineered to support [Electric Clojure](https://github.com/hyperfiddle/electric), which we test, document and teach with RCF. Hype quotes: * "RCF has changed my habits with regards to tests. It is so much easier than flipping back and forth between files, you get my preferred work habits - work in a comment block until something works. But before RCF I never took the time to turn comment blocks into an automated test" * "I use RCF to do leetcode style questions as 'fun practice.' It certainly didn't feel fun before!" * "I think people make the mistake of comparing this with other methods of inlining tests near their function definitions. The integration with the REPL, low syntax/interface, reduces friction and makes testing more attractive as a language of communication and verification." * "I used RCF in a successful interview. RCF was a massive help in communication and a fast tool for thought whilst under the conditions of technical interview." # Dependency Project maturity: CLJ is stable, CLJS is experimental, bb is experimental. ```clojure {:deps {com.hyperfiddle/rcf {:mvn/version "20220926-202227"}}} ``` Changelog * :throws * babashka support (experimental) * **breaking** don't return final result return nil like comment * `20220926-202227` `!` is deprecated, use `tap` instead * `20220827-151056` async test forms no longer guaranteed return final result * `20220405` maven group-id renamed from `hyperfiddle` to `com.hyperfiddle` for security * 2021 Dec 18: clojurescript dependency is now under the :cljs alias, see #25 * 2021 Oct 20: custom reporters now dispatch on qualified keywords, see #19 Current dev priority is improving complex async tests in ClojureScript. [![JVM](https://github.com/hyperfiddle/rcf/actions/workflows/tests_clj.yml/badge.svg?branch=master)](https://github.com/hyperfiddle/rcf/actions/workflows/tests_clj.yml) [![NodeJS](https://github.com/hyperfiddle/rcf/actions/workflows/tests_node.yml/badge.svg?branch=master)](https://github.com/hyperfiddle/rcf/actions/workflows/tests_node.yml) [![Browser](https://github.com/hyperfiddle/rcf/actions/workflows/tests_browser.yml/badge.svg?branch=master)](https://github.com/hyperfiddle/rcf/actions/workflows/tests_browser.yml) # Usage `(tests)` blocks erase by default (macroexpanding to nothing), which avoids a startup time performance penalty as well as keeps tests out of prod. It's an easy one-liner to turn on tests in your dev entrypoint: ```clojure (ns user ; user ns is loaded by REPL startup (:require [hyperfiddle.rcf])) (hyperfiddle.rcf/enable!) ``` Tests are run when you send a file or form to your Clojure/Script REPL. ```clojure (ns example (:require [hyperfiddle.rcf :refer [tests tap %]])) (tests "equality" (inc 1) := 2 "wildcards" {:a :b, :b [2 :b]} := {:a _, _ [2 _]} "unification" {:a :b, :b [2 :b]} := {:a ?b, ?b [2 ?b]} "unification on reference types" (def x (atom nil)) {:a x, :b x} := {:a ?x, :b ?x} "multiple tests on one value" (def xs [:a :b :c]) (count xs) := 3 (last xs) := :c (let [xs (map identity xs)] (last xs) := :c (let [] (last xs) := :c)) "exceptions" (assert false "boom") :throws java.lang.AssertionError (tests "nested tests (is there a strong use case?)" 1 := 1) (tests "REPL bindings work" (keyword "a") := :a (keyword "b") := :b (keyword "c") := :c *1 := :c *2 := :b *3 := :a *1 := :c ; inspecting history does not affect history (keyword "d") := :d *1 := :d *2 := :c *3 := :b (symbol *2) := 'c ; this does affect history (symbol *2) := 'd)) ``` ```text Loading src/example.cljc... ✅✅✅✅✅✅✅✅✅✅✅✅✅✅✅✅✅✅Loaded ``` # Async tests ```Clojure (ns example (:require [clojure.core.async :refer [chan >! go go-loop ! c :hello) (>! c :world)) % := :hello % := :world (close! c)) (tests "missionary" (def !x (atom 0)) (def dispose ((m/reactor (m/stream! (m/ap (! (inc (m/?< (m/watch !x))))))) (fn [_] #_(prn ::done)) #(prn ::crash %))) % := 1 (swap! !x inc) (swap! !x inc) % := 2 % := 3 (dispose))) ``` # CI To run in CI, configure a JVM flag for RCF to generate clojure.test deftests, and then run them with clojure.test. [Github actions example](https://github.com/hyperfiddle/rcf/tree/master/.github/workflows). ```Clojure ; deps.edn {:aliases {:test {:jvm-opts ["-Dhyperfiddle.rcf.generate-tests=true"]}}} ``` ```bash % clj -M:test -e "(require 'example)(clojure.test/run-tests 'example)" Testing example ✅✅✅✅✅✅✅✅ Ran 1 tests containing 8 assertions. 0 failures, 0 errors. {:test 1, :pass 8, :fail 0, :error 0, :type :summary} ``` # ClojureScript configuration For CLJS tests to run, `rcf/enable!` must be true **in both CLJ (shadow-cljs macroexpansion time) and CLJS (JS runtime)**. Reports may be printed to **browser console instead of the REPL**, because browser REPLs donn't intercept the async println. ```Clojure (ns dev-entrypoint (:require [example] ; transitive inline tests will erase [hyperfiddle.rcf :refer [tests]])) ; wait to enable tests until after app namespaces are loaded (hyperfiddle.rcf/enable!) ; subsequent REPL interactions will run tests ; prevent test execution during cljs hot code reload #?(:cljs (defn ^:dev/before-load stop [] (hyperfiddle.rcf/enable! false))) #?(:cljs (defn ^:dev/after-load start [] (hyperfiddle.rcf/enable!))) ``` # FAQ *One of my tests threw an exception, but the stack trace is empty?* — you want `{:jvm-opts ["-XX:-OmitStackTraceInFastThrow"]}` [explanation](https://web.archive.org/web/20190416091616/http://yellerapp.com/posts/2015-05-11-clojure-no-stacktrace.html) (this may be JVM specific) *I see no output* — RCF is off by default, run `(hyperfiddle.rcf/enable!)` *Emacs has no output and tests are enabled* — check if your emacs supports emojis *How do I customize what’s printed at the REPL?* — see [reporters.clj](https://github.com/hyperfiddle/rcf/blob/03c821c3875c3dfe647c945430ecdc5a7c8b594f/src/hyperfiddle/rcf/reporters.clj), [reporters.cljs](https://github.com/hyperfiddle/rcf/blob/03c821c3875c3dfe647c945430ecdc5a7c8b594f/src/hyperfiddle/rcf/reporters.cljs) # Community #hyperfiddle @ clojurians.net ![Scroll Of Truth meme saying "you do not really understand something until you can explain it as a passing test".](./doc/meme.jpg) ================================================ FILE: bb/runner.clj ================================================ (ns runner (:require [clojure.test :as test] [hyperfiddle.rcf :as rcf])) (defn run-tests [_] (alter-var-root (var rcf/*generate-tests*) (constantly true)) (let [test-nses '[hyperfiddle.rcf-test hyperfiddle.rcf.analyzer-test ;; needs missionary, doesn't work due to missing reactive streams Java lib: #_hyperfiddle.rcf.unify-test ;; needs missionary: #_hyperfiddle.rcf.example-test ]] (apply require test-nses) (let [{:keys [fail error]} (apply test/run-tests test-nses)] (when (and fail error (pos? (+ fail error))) (throw (ex-info "Tests failed" {:babasha/exit 1})))))) ================================================ FILE: bb.edn ================================================ {:paths ["bb" "src"] :tasks {test:bb {:extra-paths ["test"] :extra-deps {nubank/matcher-combinators {:mvn/version "3.5.1"}} :task (exec 'runner/run-tests)}}} ================================================ FILE: build.clj ================================================ (ns build (:require [org.corfield.build :as bb])) (def defaults {:src-pom "pom.xml" :lib 'com.hyperfiddle/rcf}) ; maven group-id and library name (defn clean [opts] (bb/clean opts)) (defn jar [opts] (bb/jar (merge defaults opts))) (defn install [opts] (bb/install (merge defaults opts))) (defn deploy [opts] (bb/deploy (merge defaults opts))) ================================================ FILE: build.md ================================================ Build ```shell HYPERFIDDLE_RCF_DATE=`date -u '+%Y%m%d-%H%M%S'` git tag v$HYPERFIDDLE_RCF_DATE clojure -T:build clean clojure -T:build jar :version '"'$HYPERFIDDLE_RCF_DATE'"' clojure -T:build install :version '"'$HYPERFIDDLE_RCF_DATE'"' ``` Test local maven repo: ```clojure {:deps {org.clojure/clojure {:mvn/version "1.10.3"} com.hyperfiddle/rcf {:mvn/version $HYPERFIDDLE_RCF_DATE}}} ``` # echo clj :replace-deps '{:deps {com.hyperfiddle/photon {:mvn/version "'$HYPERFIDDLE_RCF_DATE'"}}}' Deploy ```shell CLOJARS_PASSWORD= \ CLOJARS_USERNAME=dustingetz \ clojure -T:build deploy :version '"'$HYPERFIDDLE_RCF_DATE'"' ``` ================================================ FILE: ci/run_tests_all.sh ================================================ #!/bin/bash ./run_tests_jvm.sh ./run_tests_node.sh ./run_tests_browser.sh ================================================ FILE: ci/run_tests_browser.sh ================================================ #!/bin/sh echo "Running Browser tests" ./node_modules/.bin/shadow-cljs -A:cljs:test release :browser-test ./node_modules/.bin/karma start --single-run ================================================ FILE: ci/run_tests_jvm.sh ================================================ #!/bin/sh echo "Running JVM tests" clojure -X:test :dirs "[\"test\" \"example\"]" :patterns "[\"example.*\" \"hyperfiddle.rcf.*-test\"]" ================================================ FILE: ci/run_tests_node.sh ================================================ #!/bin/sh echo "Running NodeJS tests" ./node_modules/.bin/shadow-cljs -A:cljs:test release :test node out/node-tests.js ================================================ FILE: deps.edn ================================================ {:paths ["src"] :deps {org.clojure/clojure {:mvn/version "1.10.3"}} :aliases {:cljs {:extra-deps {org.clojure/clojurescript {:mvn/version "1.10.896"}}} :dev {:extra-deps {thheller/shadow-cljs {:mvn/version "2.16.8"}}} :test {:jvm-opts ["-XX:-OmitStackTraceInFastThrow" "-Dhyperfiddle.rcf.generate-tests=true"] :extra-paths ["test" "example"] :extra-deps {thheller/shadow-cljs {:mvn/version "2.16.8"} nubank/matcher-combinators {:mvn/version "3.5.1"} missionary/missionary {:mvn/version "b.26"} org.clojure/core.async {:mvn/version "1.5.648"} 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} :build {:deps {io.github.seancorfield/build-clj {:git/tag "v0.8.0" :git/sha "9bd8b8a"}} :ns-default build}}} ================================================ FILE: example/dev_entrypoint.cljc ================================================ (ns dev-entrypoint (:require [example] [hyperfiddle.rcf :as rcf :refer [tests]])) ; enable tests after app namespaces are loaded (intended for subsequent REPL interactions) (comment (rcf/enable!) ) ; prevent test execution during cljs hot code reload #?(:cljs (defn ^:dev/before-load stop [] (rcf/enable! false))) #?(:cljs (defn ^:dev/after-load start [] (rcf/enable! true))) ================================================ FILE: example/example.cljc ================================================ (ns example (:require [clojure.core.async :refer [chan >! go go-loop ! c :hello) (>! c :world)) % := :hello % := :world (close! c)) (tests "missionary" (def !x (atom 0)) (def dispose ((m/reactor (m/stream! (m/ap (tap (inc (m/?< (m/watch !x))))))) (fn [_] #_(prn ::done)) #(prn ::crash %))) % := 1 (swap! !x inc) (swap! !x inc) % := 2 % := 3 (dispose)) ================================================ FILE: out/index.html ================================================

Check your javascript console.

================================================ FILE: package.json ================================================ { "name": "rcf", "dependencies": {}, "devDependencies": { "karma": "6.3.17", "karma-chrome-launcher": "3.1.1", "karma-cljs-test": "0.1.0", "puppeteer": "13.5.2", "shadow-cljs": "2.16.8" } } ================================================ FILE: pom.xml ================================================ 4.0.0 jar > > > rcf RCF – a REPL-first, async test macro for Clojure/Script https://github.com/hyperfiddle/rcf scm:git:git://github.com/hyperfiddle/rcf.git scm:git:ssh://git@github.com/hyperfiddle/rcf.git org.clojure clojure 1.10.3 src clojars https://repo.clojars.org/ ================================================ FILE: run_dev_repl.sh ================================================ #!/bin/bash npx shadow-cljs -d nrepl/nrepl:0.9.0-beta4 -d cider/cider-nrepl:0.27.2 -A:dev:test:cljs server ================================================ FILE: shadow-cljs.edn ================================================ {:deps {:aliases [:cljs]} :dev-http {8000 "out"} :builds {:browser {:target :browser :modules {:main {:entries [dev-entrypoint]}} :output-dir "out/js"} :test {:target :node-test :output-to "out/node-tests.js" :ns-regexp "^(hyperfiddle.rcf.*-test|example)" } :browser-test {:target :karma :output-to "out/karma-tests.js" :ns-regexp "^(hyperfiddle.rcf.*|example.*)"}}} ================================================ FILE: src/hyperfiddle/rcf/analyzer.clj ================================================ ;; A simpler tools.analyzer for the restricted use case of RCF ;; Adapted from https://github.com/clojure/tools.analyzer (ns hyperfiddle.rcf.analyzer (:refer-clojure :exclude [macroexpand-1 macroexpand update-vals]) (:import (clojure.lang IObj))) (defn cljs? [env] (some? (:js-globals env))) (defn empty-env "Returns an empty env" [] {:locals {} :namespaces {} :ns (ns-name *ns*)}) (defn to-env [&env] (if (:js-globals &env) &env (assoc (empty-env) :locals (or &env {})))) (defn build-ns-map [] {:namespaces (into {} (mapv #(vector (ns-name %) {:mappings (merge (ns-map %) {'in-ns #'clojure.core/in-ns}) :aliases (reduce-kv (fn [a k v] (assoc a k (ns-name v))) {} (ns-aliases %)) :ns (ns-name %)}) (all-ns)))}) (def ^:dynamic *global-env* nil) (defn global-env [] (or *global-env* (build-ns-map))) (defn resolve-local [env sym] (get-in env [:locals sym])) (defn resolve-ns "Resolves the ns mapped by the given sym in the global env" [ns-sym {:keys [ns]}] (when ns-sym (let [namespaces (:namespaces (global-env))] (or (get-in namespaces [ns :aliases ns-sym]) (:ns (namespaces ns-sym)))))) (defn var?' [maybe-var] (or (var? maybe-var) (= ::var (type maybe-var)))) (defn to-var [{:keys [macro meta ns name]}] (with-meta {:ns ns, :name name} (assoc meta :type ::var))) (defmacro no-warn "Localy disable a set of cljs compiler warning. Usage: `(no-warn #{:undeclared-ns} (cljs/resolve env sym))`" [disabled-warnings & body] ;; Cannot use `cc/binding` as it relies on var which does a read-time resolve, ;; while we want a runtime var resolve. `(do (push-thread-bindings {(resolve 'cljs.analyzer/*cljs-warnings*) (reduce (fn [r# k#] (assoc r# k# false)) (deref (resolve 'cljs.analyzer/*cljs-warnings*)) ~disabled-warnings)}) (try ~@body (finally (pop-thread-bindings))))) (defn cljs-resolve [env sym] (require '[cljs.analyzer.api]) (require '[cljs.analyzer]) ;; RCF should try to resolve like the repl does, but is not in charge of ;; handling invalid userland forms. (no-warn #{:undeclared-ns} ((resolve 'cljs.analyzer.api/resolve) env sym))) (defn resolve-sym "Resolves the value mapped by the given sym in the global env" [sym {:keys [ns] :as env}] (when (symbol? sym) (if (cljs? env) (let [resolved (cljs-resolve env sym)] (if (or (:macro resolved) (= :var (:op resolved))) (resolve-sym (:name resolved) (dissoc env :js-globals)) (to-var resolved))) (let [sym-ns (when-let [ns (namespace sym)] (symbol ns)) full-ns (resolve-ns sym-ns env)] (when (or (not sym-ns) full-ns) (let [name (if sym-ns (-> sym name symbol) sym)] (-> (global-env) :namespaces (get (or full-ns ns)) :mappings (get name)))))))) (def specials "Set of special forms common to every clojure variant" ;; TODO replace with cc/special-symbol? '#{do if new quote set! try var catch throw finally def . let* letfn* loop* recur fn*}) (defn var-sym [v] (cond (var? v) (symbol v) (var?' v) (symbol (str (:ns v)) (str (:name v))))) (defmulti macroexpand-hook (fn [the-var _&form _&env _args] (var-sym the-var))) (defmethod macroexpand-hook :default [the-var &form &env args] (if (cljs? &env) (if (:cljs.analyzer/numeric (meta the-var)) (reduced &form) (let [mform (apply the-var &form &env args)] (if (and (seq? mform) (= 'js* (first mform))) (reduced &form) mform))) (apply the-var &form (:locals &env) args))) (defn has-meta? [o] (instance? clojure.lang.IMeta o)) (defmulti -parse (fn [_env form] (and (seq? form) (first form)))) (defn parse ([] (parse (empty-env))) ([env] (partial parse env)) ([env form] {:pre (map? env)} (-parse env form))) (defn classify "Returns a keyword describing the form type" [form] (cond ;; (nil? form) :nil ;; (boolean? form) :bool ;; (keyword? form) :keyword (symbol? form) :symbol ;; (string? form) :string ;; (number? form) :number ;; (type? form) :type ;; (record? form) :record (map? form) :map (vector? form) :vector (set? form) :set (seq? form) :seq ;; (char? form) :char ;; (regex? form) :regex ;; (class? form) :class (var? form) :var :else :const)) (defmulti -analyze (fn [env form] {:pre (map? env)} (classify form))) (defn analyze ([env] (partial analyze env)) ([env form] (-analyze env form))) (defn obj? [x] (instance? IObj x)) (defn- analyze-const [env form] {:op :const :env env :form form}) (defmethod -analyze :const [env form] (analyze-const env form)) (defn analyze-body [env body] ;; :body is used by emit-form to remove the artificial 'do (assoc (parse env (cons 'do body)) :body? true)) ;; default (defn wrapping-meta [{:keys [form env] :as expr}] (let [meta (meta form)] (if (and (obj? form) (seq meta)) {:op :with-meta :env env :form form :meta meta :expr expr :children [:meta :expr]} expr))) (defmethod -analyze :vector [env form] (let [items (mapv (analyze env) form)] (wrapping-meta {:op :vector :env env :items items :form form :children [:items]}))) (defmethod -analyze :map [env form] (wrapping-meta {:op :map :env env :keys (mapv (analyze env) (keys form)) :vals (mapv (analyze env) (vals form)) :form form :children [:keys :vals]})) (defmethod -analyze :set [env form] (wrapping-meta {:op :set :env env :items (mapv (analyze env) form) :form form :children [:items]})) (defmethod -analyze :seq [env form] (if (not (seq form)) (analyze-const env form) (parse env form))) (defmethod -analyze :symbol [env sym] (let [local? (some? (resolve-local env sym))] {:op :symbol :local? local? :env env :form sym :ns (namespace sym) :name (name sym)})) (defmethod -analyze :var [env form] {:op :the-var :env env :var form}) ;; -------- (defn valid-binding-symbol? [s] (and (symbol? s) (not (namespace s)) (not (re-find #"\." (name s))))) (defn source-info "Returns the available source-info keys from a map" [m] (when (:line m) (select-keys m #{:file :line :column :end-line :end-column :source-span}))) (defn -source-info "Returns the source-info of x" [env x] (merge (source-info env) (source-info (meta x)) (when-let [file (and (not= *file* "NO_SOURCE_FILE") *file*)] {:file file}))) (defn validate-bindings [[op bindings & _ :as form] env] (when-let [error-msg (cond (not (vector? bindings)) (str op " requires a vector for its bindings, had: " (class bindings)) (not (even? (count bindings))) (str op " requires an even number of forms in binding vector, had: " (count bindings)))] (throw (ex-info error-msg (merge {:form form :bindings bindings} (-source-info env form)))))) (defn dissoc-env [ast] (dissoc ast :env)) (defn analyze-let [env [_ bindings & body :as form]] (validate-bindings env form) (loop [bindings bindings env env binds []] (if-let [[name init & bindings] (seq bindings)] (if (not (valid-binding-symbol? name)) (throw (ex-info (str "Bad binding form: " name) (merge {:form form :sym name} (-source-info form env)))) (let [bind-expr {:op :binding :env env :name name :init (analyze env init) :form name :local :let :children [:init]}] (recur bindings (assoc-in env [:locals name] (dissoc-env bind-expr)) (conj binds bind-expr)))) {:body (analyze-body env body) :bindings binds :children [:bindings :body]}))) (defn analyze-fn-method [{:keys [locals local] :as env} [params & body :as form]] (when-not (vector? params) (throw (ex-info "Parameter declaration should be a vector" (merge {:params params :form form} (-source-info form env) (-source-info params env))))) (when (not-every? valid-binding-symbol? params) (throw (ex-info (str "Params must be valid binding symbols, had: " (mapv class params)) (merge {:params params :form form} (-source-info form env) (-source-info params env))))) ;; more specific (let [variadic? (boolean (some '#{&} params)) params-names (if variadic? (conj (pop (pop params)) (peek params)) params) env (dissoc env :local) arity (count params-names) params-expr (mapv (fn [name id] {:op :binding :env env :form name :name name :variadic? (and variadic? (= id (dec arity))) :arg-id id :local :arg}) params-names (range)) fixed-arity (if variadic? (dec arity) arity) body-env (update-in env [:locals] merge (zipmap params-names (map dissoc-env params-expr))) body (analyze-body body-env body)] (when variadic? (let [x (drop-while #(not= % '&) params)] (when (contains? #{nil '&} (second x)) (throw (ex-info "Invalid parameter list" (merge {:params params :form form} (-source-info form env) (-source-info params env))))) (when (not= 2 (count x)) (throw (ex-info (str "Unexpected parameter: " (first (drop 2 x)) " after variadic parameter: " (second x)) (merge {:params params :form form} (-source-info form env) (-source-info params env))))))) (merge {:op :fn-method :form form :env env :variadic? variadic? :params params-expr :fixed-arity fixed-arity :body body :children [:params :body]} (when local {:local (dissoc-env local)})))) (defmethod -parse 'do [env [_ & exprs :as form]] {:op :do :env env :form form :statements (mapv (analyze env) exprs) :children [:statements]}) (defmethod -parse 'if [env [_ test then else :as form]] {:op :if :form form :env env :test (analyze env test) :then (analyze env then) :else (analyze env else) :children [:test :then :else]}) (defmethod -parse 'quote [env form] {:op :quote ;; :expr (analyze env expr) ;; maybe not needed :form form :env env :children []}) (defmethod -parse 'try [env [_ & body :as form]] (let [catches (filter (every-pred seq? #(= 'catch (first %))) body) finallies (filter (every-pred seq? #(= 'finally (first %))) body) body (remove (into #{} (concat catches finallies)) body)] {:op :try :env env :form form :body (analyze-body env body) :catches (mapv (partial -parse env) catches) :finally (mapv (partial -parse env) finallies) :children [:body :catches :finally]})) (defmethod -parse 'catch [env [_ etype ename & body :as form]] (let [local {:op :binding :env env :form ename :name ename :local :catch ;; maybe not needed }] {:op :catch :class (analyze (assoc env :locals {}) etype) :local local :env env :form form :body (analyze-body (assoc-in env [:locals ename] (dissoc-env local)) body) :children [:local :body]})) (defmethod -parse 'let* [env form] (into {:op :let :form form :env env} (analyze-let env form))) (defmethod -parse 'loop* [env form] (into {:op :loop :form form :env env} (analyze-let env form))) (defmethod -parse :default [env form] (if (seq? form) (let [[f & args] form] {:op :invoke :form form :env env :fn (analyze env f) :args (mapv (analyze env) args) :children [:fn :args]}) (analyze env form))) (defn ns-sym [ns] (cond (symbol? ns) ns (map? ns) (:name ns) :else (ns-name ns))) (defn unquote' [form] (if (and (seq? form) (= 'quote (first form))) (second form) form)) (defn update-vals "Applies f to all the vals in the map" [m f] (reduce-kv (fn [m k v] (assoc m k (f v))) {} (or m {}))) (defmacro if-bb [then else] (if (System/getProperty "babashka.version") then else)) (defn create-var "Creates a Var for sym and returns it. The Var gets interned in the env namespace." [sym {:keys [ns] :as env}] (let [v (get-in (global-env) [:namespaces ns :mappings (symbol (name sym))])] (if (some? v) (cond (class? v) v (and (var? v) (= ns (ns-name (if-bb (:ns (meta v)) (.ns ^clojure.lang.Var v))))) (do (when-some [m (meta sym)] (if-bb (alter-meta! v (constantly (update-vals m unquote'))) (.setMeta v (update-vals m unquote')))) v) :else (throw (ex-info (str "(def " sym " ...) resolved to an existing mapping of an unexpected type.") {:sym sym :ns ns :resolved-to v :type (type v)}))) (let [meta (-> (dissoc (meta sym) :inline :inline-arities #_:macro) (update-vals unquote')) #_#_meta (if-let [arglists (:arglists meta)] (assoc meta :arglists (qualify-arglists arglists)) meta)] (intern (ns-sym ns) (with-meta sym meta)))))) (defn- to-cljs-var [var] (let [m (-> (meta var)) m (as-> m $ (update $ :ns ns-name) (assoc $ :name (symbol (str (:ns $)) (str (:name $)))))] (assoc m :meta m))) (defn- intern-cljs-var! [cljs-var] (require 'cljs.env) (let [ns (:ns cljs-var) name (symbol (name (:name cljs-var))) *compiler* (deref (resolve 'cljs.env/*compiler*))] (swap! *compiler* assoc-in [:cljs.analyzer/namespaces ns :defs name] cljs-var) nil)) (defmethod -parse 'def [{:keys [ns] :as env} [_ sym & expr :as form]] (let [pfn (fn ([]) ([init] {:init init}) ([doc init] {:pre [(string? doc)]} {:init init :doc doc})) args (apply pfn expr) env (if (some? (namespace sym)) env ;; Can't intern namespace-qualified symbol, ignore (let [var (create-var sym env)] ;; side effect, FIXME should be a pass (when (cljs? env) (intern-cljs-var! (to-cljs-var var))) (assoc-in env [:namespaces ns :mappings sym] var))) args (when-let [[_ init] (find args :init)] (assoc args :init (analyze env init)))] (merge {:op :def :env env :form form :name sym :doc (or (:doc args) (-> sym meta :doc)) :children (into [] (when (:init args) [:init]))} args))) (defmethod -parse 'fn* [env [op & args :as form]] (wrapping-meta (let [[n meths] (if (symbol? (first args)) [(first args) (next args)] [nil (seq args)]) name-expr {:op :binding :env env :form n :local :fn :name n} e (if n (assoc (assoc-in env [:locals n] (dissoc-env name-expr)) :local name-expr) env) once? (-> op meta :once boolean) menv (assoc e :once once?) meths (if (vector? (first meths)) (list meths) meths) ;;turn (fn [] ...) into (fn ([]...)) methods-exprs (mapv #(analyze-fn-method menv %) meths)] (merge {:op :fn :env env :form form :methods methods-exprs :once once?} (when n {:local name-expr}) {:children (conj (if n [:local] []) :methods)})))) (defmethod -parse 'letfn* [env [_ bindings & body :as form]] (validate-bindings env form) (let [bindings (apply array-map bindings) ;; pick only one local with the same name, if more are present. fns (keys bindings) binds (reduce (fn [binds name] (assoc binds name {:op :binding :env env :name name :form name :local :letfn})) {} fns) e (update-in env [:locals] merge binds) ;; pre-seed locals binds (reduce-kv (fn [binds name bind] (assoc binds name (merge bind {:init (analyze e (bindings name)) :children [:init]}))) {} binds) e (update-in env [:locals] merge (update-vals binds dissoc-env))] {:op :letfn :env env :form form :bindings (vec (vals binds)) ;; order is irrelevant :body (analyze-body e body) :children [:bindings :body]})) ;;;;;;;;;; ;; EMIT ;; ;;;;;;;;;; (def ^:dynamic *emit-options* {:simplify-do false}) ;; FIXME :simplify-* should be passes (defmulti -emit (fn [ast] (:op ast))) (defn emit [ast] (-emit ast)) (defmethod -emit :const [ast] (:form ast)) (defmethod -emit :symbol [ast] (:form ast)) (defmethod -emit :var [ast] (:form ast)) (defn emit-invoke [ast] (list* (emit (:fn ast)) (mapv emit (:args ast)))) (defmethod -emit :invoke [ast] (emit-invoke ast)) (defmethod -emit :do [ast] (if (and (:simplify-do *emit-options*) (= 1 (count (:statements ast)))) (emit (first (:statements ast))) (list* 'do (mapv emit (:statements ast))))) (defmethod -emit :vector [ast] (mapv emit (:items ast))) (defmethod -emit :set [ast] (set (mapv emit (:items ast)))) (defmethod -emit :map [ast] (zipmap (mapv emit (:keys ast)) (mapv emit (:vals ast)))) (defmethod -emit :with-meta [ast] (with-meta (emit (:expr ast)) (:meta ast))) (defmethod -emit :try [ast] (list* 'try (emit (:body ast)) (concat (mapv emit (:catches ast)) (mapv emit (:finally ast))))) (defmethod -emit :catch [ast] (list 'catch (emit (:class ast)) (emit (:local ast)) (emit (:body ast)))) (defmethod -emit :binding [ast] (case (:local ast) :catch (:form ast) (:let :letfn) [(:name ast) (emit (:init ast))] :fn (:name ast) :arg (if (:variadic? ast) ['& (:name ast)] [(:name ast)]))) (defmethod -emit :quote [ast] (:form ast)) (defmethod -emit :if [ast] (list 'if (emit (:test ast)) (emit (:then ast)) (emit (:else ast)))) (defmethod -emit :def [ast] (if-let [init (:init ast)] (list 'def (:name ast) (emit init)) (list 'def (:name ast)))) (defmethod -emit :let [ast] (list* 'let* (vec (mapcat identity (mapv emit (:bindings ast)))) (if (:simplify-do *emit-options*) ;; FIXME should be a pass (mapv emit (:statements (:body ast))) (list (emit (:body ast)))))) (defmethod -emit :loop [ast] (list 'loop* (vec (mapcat identity (mapv emit (:bindings ast)))) (emit (:body ast)))) (defmethod -emit :fn [ast] (let [methods (mapv emit (:methods ast))] (if-let [name (some-> (:local ast) emit)] `(~'fn* ~name ~@methods) `(~'fn* ~@methods)))) (defmethod -emit :fn-method [ast] (list (vec (mapcat emit (:params ast))) (emit (:body ast)))) (defmethod -emit :letfn [ast] (list 'letfn* (vec (mapcat identity (mapv emit (:bindings ast)))) (emit (:body ast)))) ;; AST walk (defn walk [inner outer ast] (when (some? ast) (if (reduced? ast) ast (outer (reduce (fn [ast child-key] (if (sequential? (get ast child-key)) (update ast child-key (partial mapv inner)) (update ast child-key inner))) ast (:children ast)))))) (defn postwalk [f ast] (unreduced (walk (partial postwalk f) f ast))) (defn prewalk [f ast] (unreduced (walk (partial prewalk f) identity (f ast)))) (defn only-nodes [pred f] ;; use with *walk to skip some nodes (let [pred (if (set? pred) (comp pred :op) pred)] (fn [ast] (if (pred ast) (f ast) ast)))) (defn children [ast] (when (some? ast) (mapcat (fn [child] (let [child-ast (get ast child)] (if (sequential? child-ast) child-ast (list child-ast)))) (:children ast)))) (defn ast-seq "Equivalent of `cc/tree-seq` on AST nodes" [ast] (when (some? ast) (cons ast (mapcat ast-seq (children ast))))) ;; Passes (defn resolve-sym-node [{:keys [env] :as ast}] (assert (= :symbol (:op ast))) (if (:local? ast) ast (if-let [v (resolve-sym (:form ast) env)] (if (var?' v) (assoc ast :op :var, :var v) ast) ast))) (defn resolve-syms-pass [ast] (prewalk (only-nodes #{:symbol} resolve-sym-node) ast)) (defn- tag-with-form [ast parent form] (assoc ast :raw-forms (conj (:raw-forms parent ()) (list 'quote form)))) (defn macroexpand-node [{:keys [env] :as ast}] (let [{:keys [op var]} (:fn ast) [f & args :as form] (:form ast)] (if (and (= :var op) (:macro (meta var)) (not (::prevent-macroexpand (meta f)))) (let [ mform (macroexpand-hook var form env args) var' (when (seq? mform) (resolve-sym (first mform) env))] (cond (= form mform) (reduced ast) (reduced? mform) (reduced (tag-with-form (parse env (unreduced mform)) ast form)) (= var var') (let [[f & args] mform f (if (contains? (methods macroexpand-hook) f) (vary-meta f assoc ::prevent-macroexpand true) f)] (tag-with-form (analyze env (cons f args)) ast form)) :else (tag-with-form (analyze env mform) ast form))) ast))) (defn macroexpand-pass ([ast] (macroexpand-pass ##Inf ast)) ([n ast] (let [state (atom n)] (prewalk (only-nodes #{:invoke} (fn rec [ast] (if-not (pos? @state) (reduced ast) ;; stop walking (let [ast' (macroexpand-node ast)] (binding [*global-env* (build-ns-map)] (let [ast'-resolved (resolve-syms-pass (unreduced ast'))] (cond (reduced? ast') (reduced ast'-resolved) (= ast ast') ast'-resolved :else (if (pos? (swap! state dec)) (if (= :invoke (:op ast'-resolved)) (rec ast'-resolved) ast'-resolved) ast'-resolved)))))))) ast)))) (defn macroexpand-n ([n form] (macroexpand-n n (empty-env) form)) ([n env form] (binding [*global-env* (build-ns-map)] (->> (analyze env form) (resolve-syms-pass) (macroexpand-pass n) (emit))))) (defn macroexpand-all ([form] (macroexpand-all (empty-env) form)) ([env form] (macroexpand-n ##Inf env form))) (defn macroexpand-1 ([form] (macroexpand-1 (empty-env) form)) ([env form] (macroexpand-n 1 env form))) ================================================ FILE: src/hyperfiddle/rcf/impl.clj ================================================ (ns hyperfiddle.rcf.impl (:require [clojure.string :as str] [clojure.test :as t] [clojure.walk :as walk] [hyperfiddle.rcf.analyzer :as ana] [hyperfiddle.rcf.queue :as q] [hyperfiddle.rcf.time :as time] [hyperfiddle.rcf.unify :as u] [hyperfiddle.rcf.reporters])) (defn rewrite-doc [env ast] (ana/prewalk (ana/only-nodes #{:do} (fn [do-ast] (assoc do-ast :statements (loop [[s & ss] (:statements do-ast) r []] (if (nil? s) r (if (and (string? (:form s)) (seq ss)) (let [testing-ast (ana/analyze env `(~`t/testing ~(:form s)))] (->> (assoc do-ast :statements (vec ss)) (update testing-ast :args conj) (conj r))) (recur ss (conj r s)))))))) ast)) (defn rewrite-star [env ast] (ana/postwalk (ana/only-nodes #{:var} (fn [var-ast] (if-let [index (condp = (:var var-ast) #'*1 0, #'*2, 1 #'*3 2, nil)] (-> (ana/analyze env `(~'RCF__peek! ~index)) (assoc :raw-forms (list (:form var-ast))) (assoc ::star true)) var-ast))) ast)) (defn star? [ast] (or (::star ast) (and (= :var (:op ast)) (#{#'*1 #'*2 #'*3} (:var ast))))) (defn has-stars? [ast] (some? (first (filter star? (ana/ast-seq ast))))) (defn maybe-add-stars-support [env ast] (if (has-stars? ast) (-> (ana/analyze env `(let [[~'RCF__push! ~'RCF__peek!] (hyperfiddle.rcf/binding-queue)])) (ana/resolve-syms-pass) (ana/macroexpand-pass) (update-in [:body :statements] conj ast)) ast)) (defn make-queue [timeout-value] `(let [q# (q/queue) start# (time/current-time) timeout# (atom hyperfiddle.rcf/*timeout*)] [(fn [x#] (q/offer! q# x#) x#) (fn ([] (q/poll! q# start# (deref timeout#) ~timeout-value)) ; blocking ([n# cb#] (q/poll-n! q# start# (deref timeout#) ~timeout-value n# cb#)) ; non blocking ) (partial reset! timeout#)])) (defn %? [ast] (and (= :var (:op ast)) (= 'hyperfiddle.rcf/% (ana/var-sym (:var ast))))) (defn has-%? [ast] (some? (first (filter %? (ana/ast-seq ast))))) (defn maybe-add-queue-support [env ast] (if (has-%? ast) (-> (ana/analyze env `(let [[~'RCF__tap ~'RCF__% ~'RCF__set-timeout!] (hyperfiddle.rcf/make-queue :hyperfiddle.rcf/timeout)])) (ana/resolve-syms-pass) (ana/macroexpand-pass) (update-in [:body :statements] conj ast)) ast)) (defn rewrite-tap-% [env ast] (if-not (has-%? ast) ast (ana/postwalk (ana/only-nodes #{:var} (fn [var-ast] (condp = (ana/var-sym (:var var-ast)) 'hyperfiddle.rcf/tap (assoc var-ast :form 'RCF__tap) 'hyperfiddle.rcf/! (assoc var-ast :form 'RCF__tap) 'hyperfiddle.rcf/set-timeout! (assoc var-ast :form 'RCF__set-timeout!) 'hyperfiddle.rcf/% (if (ana/cljs? env) var-ast (-> (ana/analyze env `(~'RCF__%)) (assoc :raw-forms (list (:form var-ast))))) var-ast))) ast))) (defn- inspect-star-only? [ast] (and (= `t/is (:form (:fn ast))) (let [[left right] (some-> ast :args first :args)] (or (and (star? left) (not (has-stars? right))) (and (star? right) (not (has-stars? left))))))) (defn rewrite-repl [env ast] (ana/prewalk (ana/only-nodes #{:do} (fn [do-ast] (if-not (has-stars? do-ast) do-ast (assoc do-ast :statements (loop [[s & ss] (:statements do-ast) r []] (cond (nil? s) r (empty? ss) (recur ss (conj r s)) :else (if-not (inspect-star-only? s) (let [invoke-ast (-> (ana/analyze env '(RCF__push!)) (update :args conj s))] (recur ss (conj r invoke-ast))) (recur ss (conj r s))))))))) ast)) (defmulti replace-sigil identity) (defmethod replace-sigil :default [sym] sym) (defmethod replace-sigil := [_sym] :hyperfiddle.rcf/=) (defmethod replace-sigil 'thrown? [_sym] 'hyperfiddle.rcf/thrown?) (defmethod replace-sigil :throws [_sym] 'hyperfiddle.rcf/thrown?) (defn replace-sigil* [sym] (let [sym' (replace-sigil sym)] (if (= sym sym') sym' (recur sym')))) (defn make-is [env a b c] (let [sigil (replace-sigil* (:form b)) inner-ast (-> (ana/analyze env `(~sigil)) (update :args conj a c))] (-> (ana/analyze env `(t/is)) (update :args conj inner-ast)))) (defn lvar? [ast] (and (#{:var :symbol} (:op ast)) (or (= '_ (:form ast)) (str/starts-with? (str (:form ast)) "?")))) (defn has-lvars? [ast] (some? (first (filter lvar? (ana/ast-seq ast))))) (defn simplify-sigil [left center right] (cond (and (= := (:form center)) (not (has-lvars? left)) (not (has-lvars? right))) 'hyperfiddle.rcf/= :else (:form center))) (defmulti rewrite-infix (fn [_env _left center _right] (:form center))) (defmethod rewrite-infix :default [env l c r] (let [sigil-ast (ana/analyze env (replace-sigil* (simplify-sigil l c r)))] (make-is env l sigil-ast r))) (defn sigil? [ast] (let [methods (methods t/assert-expr) sigil (replace-sigil* (if (= :var (:op ast)) (ana/var-sym (:var ast)) (:form ast)))] (or (contains? methods sigil) (when (or (keyword? sigil) (symbol? sigil)) (contains? methods (symbol (name sigil))))))) (defn rewrite-infix-pass [env ast] (ana/prewalk (ana/only-nodes #{:do} (fn [do-ast] (assoc do-ast :statements (loop [ss (:statements do-ast) r []] (if (>= (count ss) 3) (let [[?actual ?op ?expected] ss] (if (sigil? ?op) (recur (drop 3 ss) (conj r (rewrite-infix env ?expected ?op ?actual))) (recur (rest ss) (conj r ?actual)))) (into r ss)))))) ast)) (defn autoquote-lvars [env ast] ;; Rewrites ?a and _ in t/is assertions ;; It could be handled by t/is directly, but we already have a full AST here, ;; no need to serialize it only to reparse it all on the next macroexpand. (ana/prewalk (ana/only-nodes #{:invoke} (fn [ast] (if-not (and (= `t/is (:form (:fn ast))) (sigil? (-> ast :args first :fn)) ) ast (ana/postwalk (ana/only-nodes #{:var :symbol} (fn [ast] (if (lvar? ast) (-> (update ast :form #(list 'quote %)) (update :raw-forms (fnil conj ()) (:form ast))) ast))) ast)))) ast)) (defn rewrite-is-support [env ast] (ana/prewalk (ana/only-nodes #{:invoke} (fn [ast] (if-not (= `t/is (:form (:fn ast))) ast (update-in ast [:args 0 :fn :form] replace-sigil*)))) ast)) (defn rewrite-cljs-test [env ast] (if-not (ana/cljs? env) ast (ana/prewalk (ana/only-nodes #{:var :symbol} (fn [ast] (if (and (symbol? (:form ast)) (= "clojure.test" (namespace (:form ast)))) (assoc ast :form (symbol "cljs.test" (name (:form ast)))) ast))) ast))) (defn make-poll-n [n env ast] (let [syms (take n (map #(symbol (str "%-" (inc %))) (range n))) ast (let [!syms (atom syms)] (ana/postwalk (ana/only-nodes #{:var} (fn [var-ast] (if (empty? @!syms) (reduced var-ast) (condp = (ana/var-sym (:var var-ast)) 'hyperfiddle.rcf/% (let [sym (first @!syms)] (swap! !syms rest) (-> (ana/analyze env sym) (assoc :raw-forms (list (:form var-ast))))) var-ast)))) ast)) f (-> (ana/analyze env `(fn [~@syms])) (ana/resolve-syms-pass) (ana/macroexpand-pass) (update-in [:methods 0 :body :statements] conj ast))] (-> (ana/analyze env `(~'RCF__% ~n)) (update-in [:args] conj f)))) (defn assertion? [ast] (and (= :invoke (:op ast)) (= `t/is (:form (:fn ast))))) (defn rewrite-async-assert [env ast] (if-not (ana/cljs? env) ast (ana/prewalk (ana/only-nodes #{:do} (fn [ast] (assoc ast :statements (loop [r [] [s & ss] (:statements ast)] (cond (nil? s) r (not (assertion? s)) (recur (conj r s) ss) :else (let [%-count (count (filter %? (ana/ast-seq s)))] (if (zero? %-count) (recur (conj r s) ss) (let [s' (-> (ana/analyze (ana/empty-env) '(do)) (update :statements into (cons s ss)))] (conj r (make-poll-n %-count env s')))))))))) ast))) (defn rewrite-overload-is [env ast] (ana/prewalk (ana/only-nodes #{:invoke} (fn [ast] (if (#{`t/is 'cljs.test/is} (:form (:fn ast))) (assoc-in ast [:fn :form] 'hyperfiddle.rcf/is) ast))) ast)) (defn add-done-support [env ast] (let [count-is (count (filter (fn [ast] (and (= :invoke (:op ast)) (= `t/is (:form (:fn ast))))) (ana/ast-seq ast)))] (if (zero? count-is) ast (let [done-sym (gensym "done-") body (-> (ana/analyze env `(let [~'RCF__done! (hyperfiddle.rcf/async-notifier ~count-is ~done-sym)])) (ana/resolve-syms-pass) (ana/macroexpand-pass) (update-in [:body :statements] conj ast))] (-> (ana/analyze env `(~'hyperfiddle.rcf/async ~done-sym)) (update-in [:args] conj body)))))) (defn rewrite [env ast] (->> ast (maybe-add-stars-support env) (maybe-add-queue-support env) (rewrite-tap-% env) (rewrite-infix-pass env) (rewrite-async-assert env) (rewrite-doc env) (rewrite-star env) (rewrite-repl env) (autoquote-lvars env) (rewrite-is-support env) (add-done-support env) (rewrite-cljs-test env) (rewrite-overload-is env))) (defn tests-cljs* [env exprs] (let [env (ana/to-env env)] (binding [ana/*emit-options* {:simplify-do true}] (->> (cons 'do exprs) (ana/analyze env) (ana/resolve-syms-pass) (ana/macroexpand-pass) (rewrite env) (ana/emit))))) (defn tests* ([exprs] (tests* nil exprs)) ([env exprs] (if (ana/cljs? env) (tests-cljs* env exprs) `(binding [*ns* ~*ns*] ~(let [env (ana/to-env env)] (binding [ana/*emit-options* {:simplify-do true}] (->> (cons 'do exprs) (ana/analyze env) (ana/resolve-syms-pass) (ana/macroexpand-pass) (rewrite env) (ana/emit)))))))) ;; Nested test support (defmethod ana/macroexpand-hook `hyperfiddle.rcf/tests [_the-var _&form _&env args] `(do ~@args)) ;; clojure.test/is support (defmethod ana/macroexpand-hook `t/is [_the-var _&form _&env args] `(t/is ~@args)) ;; Skip these DSLs, their macroexpansion is not rewritable as clojure. (defmethod ana/macroexpand-hook 'clojure.core/case [_ _ _ args] `(case ~@args)) (defmethod ana/macroexpand-hook 'cljs.core/case [_ _ _ args] `(case ~@args)) (defmethod ana/macroexpand-hook 'clojure.core.async/go [_ _ _ args] (reduced `(clojure.core.async/go (do ~@args)))) (defmethod ana/macroexpand-hook 'cljs.core.async/go [_ _ _ args] (reduced `(cljs.core.async/go (do ~@args)))) (defn quoted? [form] (and (seq? form) (= 'quote (first form)))) (defn original-form [form] (walk/prewalk (fn [form] (if (ana/has-meta? form) (if-some [form (::ana/macroexpanded (meta form))] (if (quoted? form) (second form) form) form) form)) form)) ;; Tag asserted forms with the original user input (form before macroexpand) ;; so t/is can report it as typed by user, not as rewritten by RCF. (defmethod ana/-emit :invoke [ast] (if (sigil? (:fn ast)) (list* (ana/emit (:fn ast)) (map (fn [arg] (let [form (ana/emit arg)] (if-some [original-form (some-> arg :raw-forms seq last)] (with-meta form {::ana/macroexpanded original-form}) form))) (:args ast))) (ana/emit-invoke ast))) (defn- stacktrace-file-and-line [stacktrace] (if (seq stacktrace) (let [^StackTraceElement s (first stacktrace) file-name (.getFileName s) file-name (if (= "NO_SOURCE_FILE" file-name) (str (ns-name *ns*)) file-name)] {:file file-name :line (.getLineNumber s)}) {:file nil :line nil})) (defn do-report* [m] (t/report (case (:type m) (:fail :hyperfiddle.rcf/fail) (merge (stacktrace-file-and-line (drop-while #(let [cl-name (.getClassName ^StackTraceElement %)] (or (str/starts-with? cl-name "java.lang.") (str/starts-with? cl-name "clojure.test$") (str/starts-with? cl-name "clojure.core$ex_info") (str/starts-with? cl-name "hyperfiddle.rcf"))) (.getStackTrace (Thread/currentThread)))) m) (:error :hyperfiddle.rcf/error) (merge (stacktrace-file-and-line (.getStackTrace ^Throwable (:actual m))) m) m))) (defmacro do-report [m] (if (:js-globals &env) `(cljs.test/do-report ~m) `(do-report* ~m))) (defmethod t/assert-expr 'hyperfiddle.rcf/thrown? [msg form] ;; (is (thrown? c expr)) ;; Asserts that evaluating expr throws an exception of class c. ;; Returns the exception thrown. (let [[klass body] (rest form)] `(try ~body (do-report {:type :hyperfiddle.rcf/fail, :message ~msg, :expected '~form, :actual nil}) (catch ~klass e# (do-report {:type :hyperfiddle.rcf/pass, :message ~msg, :expected '~form, :actual e#}) e#)))) (defn test-var "Like `clojure.test/test-var` but return actual result." [v] (when-let [t (:test (meta v))] (binding [t/*testing-vars* (conj t/*testing-vars* v)] (do-report {:type :begin-test-var, :var v}) (t/inc-report-counter :test) (try (t) (catch Throwable e (do-report {:type :error, :message "Uncaught exception, not in assertion." :expected nil, :actual e})) (finally (do-report {:type :end-test-var, :var v})))))) ================================================ FILE: src/hyperfiddle/rcf/queue.clj ================================================ (ns hyperfiddle.rcf.queue (:require [hyperfiddle.rcf.time :as time]) (:import (java.util.concurrent LinkedBlockingQueue TimeUnit))) (defn queue [] (LinkedBlockingQueue.)) (defn get-queue [^LinkedBlockingQueue q] (map :value q)) (defn poll! ([^LinkedBlockingQueue q, start, timeout, timeout-value] (let [now (time/current-time)] (if (time/timeout? now start timeout) timeout-value (:value (.poll q (time/remaining now start timeout) TimeUnit/MILLISECONDS) timeout-value)))) ([^LinkedBlockingQueue q, start, timeout, timeout-value, callback] ;; TODO leverage this arity for non-blocking poll? call callback in (cc/future …)? (callback (poll! q start timeout timeout-value)))) (defn poll-n! [q start timeout missing-value n callback] (assert (nat-int? n)) (poll! q start timeout missing-value (fn [x] (if (= 1 n) (callback x) (poll-n! q start timeout missing-value (dec n) (partial callback x)))))) (defn offer! [^LinkedBlockingQueue q, val] (.offer q {:value val}) val) ================================================ FILE: src/hyperfiddle/rcf/queue.cljs ================================================ (ns hyperfiddle.rcf.queue (:require [hyperfiddle.rcf.time :as time])) (defprotocol IObservableQueue (put! [this val]) (take! [this]) (-empty? [this]) (observe! [this callback]) (unobserve! [this callback])) (deftype ObservableArray [^js arr, observers] IObservableQueue (put! [this val] (if-let [observer (.shift observers)] (observer val) (.push arr val)) this) (take! [_this] (.shift arr)) (-empty? [_this] (= 0 (.-length arr))) (observe! [_this callback] (.push observers callback)) (unobserve! [_this callback] (let [idx (.indexOf observers callback)] (when (> idx -1) (.splice observers idx 1))))) (defn queue [] (ObservableArray. #js [] #js [])) (defn get-queue [^js q] (seq (.-arr q))) (defn poll! ([_ _ _ _] (throw (ex-info "Blocking poll not available on a JS runtime." {}))) ([^js q start timeout missing-value callback] (let [now (time/current-time)] (if (time/timeout? now start timeout) (callback missing-value) (let [resolved? (volatile! false) resolve (fn [val] (when-not @resolved? (vreset! resolved? true) (callback val)))] (if (-empty? q) (do (observe! q resolve) (js/setTimeout (fn [] (unobserve! q resolve) (resolve missing-value)) (time/remaining now start timeout))) (resolve (take! q)))))))) (defn poll-n! [^js q start timeout missing-value n callback] (assert (nat-int? n)) (poll! q start timeout missing-value (fn [x] (if (= 1 n) (callback x) (poll-n! q start timeout missing-value (dec n) (partial callback x)))))) (defn offer! [q v] (put! q v) v) ================================================ FILE: src/hyperfiddle/rcf/reporters.clj ================================================ (ns hyperfiddle.rcf.reporters (:require [clojure.test :as t] [clojure.string :as str])) (defmethod t/report :hyperfiddle.rcf/pass [_m] (t/with-test-out (t/inc-report-counter :pass) (print "✅") (flush))) (defmethod t/report :hyperfiddle.rcf/fail [m] (print "❌ ") (print (str/triml (with-out-str (binding [t/*test-out* *out*] (t/report (assoc m :type :fail))))))) ================================================ FILE: src/hyperfiddle/rcf/reporters.cljs ================================================ (ns hyperfiddle.rcf.reporters (:require [cljs.test :as t])) (defn testing-vars-str "Returns a string representation of the current test. Renders names in *testing-vars* as a list, then the source file and line of current assertion." [m] (let [{:keys [file line column]} m] (str file ":" line (when column (str ":" column))))) ;; For js console. (defmethod t/report [::t/default :hyperfiddle.rcf/pass] [m] (t/inc-report-counter! :pass) (js/console.log "✅")) (defmethod t/report [::t/default :hyperfiddle.rcf/fail] [m] (t/report (assoc m :type :fail))) ;; Shadow cljs + karma test runner (defmethod t/report [:shadow.test.karma/karma :hyperfiddle.rcf/pass] [m] (t/report (assoc m :type :pass))) (defmethod t/report [:shadow.test.karma/karma :hyperfiddle.rcf/fail] [m] (t/report (assoc m :type :fail))) ================================================ FILE: src/hyperfiddle/rcf/time.cljc ================================================ (ns hyperfiddle.rcf.time) (defn current-time [] #?(:clj (System/currentTimeMillis) :cljs (js/Date.now))) (defn timeout? [now start timeout] (> now (+ start timeout))) (defn remaining [now start timeout] (- (+ start timeout) now)) ================================================ FILE: src/hyperfiddle/rcf/unify.cljc ================================================ ;; Adapted from `https://github.com/clojure/core.unify` which was not cljs ;; compatible out of the box. (ns hyperfiddle.rcf.unify (:require [clojure.walk :as walk] [clojure.set :as set])) (defn wildcard? [x] (= '_ x)) (defn &? [form] (and (seqable? form) (= '& (first form)))) (defn lvar? [x] (and (symbol? x) (= \? (first (name x))))) (defn failed? [env] (contains? env ::fail)) (defn unify-in-env [x y env] (if (contains? env x) (let [y' (get env x)] (if (= y y') env (if (lvar? y') (unify-in-env y' y env) (assoc env ::fail {x [y' y]})))) (assoc env x y))) (defn wildcard-in-env [v env] (if (contains? env '_) (update-in env ['_] conj v) (assoc env '_ [v]))) (defn resolve* ([env k] (resolve* [] env k)) ([path env k] (if (= k (first path)) ::cycle (let [v (get env k)] (if (lvar? v) (resolve* (conj path k) env v) v))))) (defn ground [env] (if (map? env) (let [env (reduce-kv (fn [env k _v] (assoc env k (resolve* env k))) env env)] (if (contains? env '_) (update env '_ (fn [xs] (mapv (fn [x] (if (lvar? x) (get env x) x)) xs))) env)) env)) (declare unify) (defn unify-set [xs ys env] (if (seq (set/intersection xs ys)) (unify-set (set/difference xs ys) (set/difference ys xs) env) (let [env (unify (first xs) (first ys) env)] (if (failed? env) env (unify (rest xs) (rest ys) env))))) (defn replace-keys [m ks-map] (reduce-kv (fn [r k v] (-> (dissoc r k) (assoc (if (= k '_) (or (first (set/difference (set (get ks-map '_)) (set (keys r)))) '_) (get ks-map k k)) v))) m m)) (defn unify-map [xs ys env] (let [env (unify-set (set (keys xs)) (set (keys ys)) env) xs (replace-keys xs env) ys (replace-keys ys env)] (if (= xs ys) env (reduce (fn [env k] (let [env (unify (find xs k) (find ys k) env)] (if (failed? env) (reduced env) env))) env (set/union (set (keys xs)) (set (keys ys))))))) ;; Javascript do not have chars. So iterating a string always produce more strings -> StackOverflow. (defn collection? [x] (and (seqable? x) (not (string? x)))) (defn unify ([x y] (unify x y {})) ([x y env] (let [env (cond (failed? env) env (wildcard? x) (wildcard-in-env y env) (wildcard? y) (wildcard-in-env x env) (= x y) env (&? x) (if (seq y) (unify (second x) (seq y) env) env) (&? y) (if (seq x) (unify (second y) (seq x) env) env) (lvar? x) (unify-in-env x y env) (lvar? y) (unify-in-env y x env) (and (set? x) (set y)) (unify-set x y env) (and (map? x) (map? y)) (unify-map x y env) (every? collection? [x y]) (let [env (unify (first x) (first y) env)] (if (failed? env) env (unify (rest x) (rest y) env))) :else (assoc env ::fail {::root [x y]}))] (if (failed? env) (update env ::path (fnil conj ()) x) env)))) (defn subst [form env] (let [idx (volatile! -1) get-idx! (fn [] (vswap! idx inc))] (if (map? env) (walk/prewalk (fn [expr] (cond (lvar? expr) (get env expr expr) (wildcard? expr) (get-in env ['_ (get-idx!)] '_) :else expr)) form) form))) (defn unifier* [x y] (let [env (unify x y)] (if (failed? env) [::fail env] (let [env (ground env)] [(subst y env) env])))) (def unifier (comp first unifier*)) (defn explain [env] (when-let [fail (::fail env)] (str "Failed to unify " (if-some [[a b] (::root fail)] (str (pr-str a) " and " (pr-str b)) (let [[lvar [a b]] (first fail)] (str (pr-str lvar) " with " (pr-str a) " and " (pr-str b)))) (when-some [path (seq (->> (::path env) (filter map-entry?) (map key)))] (str " in " (into [] path)))))) ================================================ FILE: src/hyperfiddle/rcf.cljc ================================================ (ns hyperfiddle.rcf (:refer-clojure :exclude [=]) #?(:cljs (:require-macros [hyperfiddle.rcf :refer [tests deftest async]] [hyperfiddle.rcf.impl :refer [make-queue]])) (:require #?(:clj [hyperfiddle.rcf.impl :as impl]) #?(:clj [clojure.test :as t] :cljs [cljs.test :as t]) #?(:clj [hyperfiddle.rcf.analyzer :as ana]) #?(:clj [clojure.walk :as walk]) #?(:clj [clojure.java.io :as io]) [clojure.string :as str] [hyperfiddle.rcf.reporters] [hyperfiddle.rcf.queue] [hyperfiddle.rcf.time] [hyperfiddle.rcf.unify :as u])) (def = clojure.core/=) #?(:cljs (goog-define ^boolean ENABLED false)) #?(:cljs (goog-define ^boolean TIMEOUT 400)) ;; "Set to true if you want to generate clojure.test compatible tests. This ;; will define testing functions in your namespace using `deftest`. Defaults to ;; `false`. #?(:clj (defonce ^:dynamic *enabled* (= "true" (System/getProperty "hyperfiddle.rcf.enabled"))) :cljs (def ^boolean ^:dynamic *enabled* ENABLED)) (defn enable! [& [v]] #?(:clj (alter-var-root #'*enabled* (constantly (if (some? v) v true))) :cljs (set! *enabled* (if (some? v) v true)))) #?(:clj (def ^:dynamic *timeout* (or (System/getProperty "hyperfiddle.rcf.timeout") 1000)) :cljs (def ^:dynamic *timeout* TIMEOUT)) (defn set-timeout! [ms] #?(:clj (alter-var-root #'*timeout* (constantly ms)) :cljs (set! *timeout* ms))) #?(:clj (def ^:dynamic *generate-tests* (= "true" (System/getProperty "hyperfiddle.rcf.generate-tests")))) (def ^{:doc " Function to push value to async queue, e.g. `(tap 42)`. RCF redefines this var in tests context. For REPL convenience, defaults to println outside of tests context."} tap (fn [x] (doto x println))) (def ^{:doc "Deprecated alias for `tap`." :deprecated true} ! tap) (comment "tap outside of tests macro" (is (= (with-out-str (tap 1)) "1\n"))) (def ^{:doc "Queue behaving as a value. Assert `% := _` to pop from it. Async, will time out after `:timeout` option, default to 1000 (ms)."} %) (defn- push-binding [q d] (let [[c b _a] q] [d c b])) (defn binding-queue [] (let [!q (atom [nil nil nil]) push! (partial swap! !q push-binding) peek! #(get (deref !q) %)] [push! peek!])) (defn gen-name [form] (let [{:keys [line _column]} (meta form) file (str/replace (name (ns-name *ns*)) #"[-\.]" "_")] (symbol (str "generated__" file "_" line)))) (defn ns-filename "Given a symbol identifying a namespace, return the corresponding file path" [sym] (-> (name sym) (str/replace #"\." "/") (str/replace #"-" "_"))) #?(:clj (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))))) #?(:clj (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)))))) #?(:clj (defn is-ns-in-current-project? [env ns-sym] (let [current-dir (System/getProperty "user.dir")] (when-some [file (resolve-file env ns-sym)] (str/starts-with? (.getPath file) current-dir))))) (defmacro tests [& body] (let [body `(~@body nil) ; return nil like comment, unlike do name (gen-name &form) ns (if (:js-globals &env) (:name (:ns &env)) (:ns &env (ns-name *ns*)))] (cond (and *generate-tests* (is-ns-in-current-project? &env ns)) `(deftest ~name ~@body) *enabled* (if (:js-globals &env) `(do (defn ~name [] ~(impl/tests* &env body)) (when *enabled* (cljs.test/run-block (cljs.test/test-var-block* (var ~name) ~name)))) (impl/tests* &env body)) :else nil))) (defmacro deftest "When *load-tests* is false, deftest is ignored." [name & body] (if (:js-globals &env) `(do (cljs.test/deftest ~name ~(impl/tests* &env body)) (when *enabled* (~name))) (when t/*load-tests* `(do (def ~(vary-meta name assoc :test `(fn [] ~(impl/tests* &env body))) (fn [] (impl/test-var (var ~name)))) (when *enabled* (~name)))))) (defn done []) (defmacro async [done & body] (if (ana/cljs? &env) `(cljs.test/async ~done ~@body) `(let [~done (constantly nil)] ~@body))) (defn async-notifier [n done] (let [!seen (atom 0)] (fn [] (swap! !seen inc) (when (= @!seen n) (done))))) (defmacro make-queue [& args] (apply impl/make-queue args)) (defmacro is ([form] `(is ~form nil)) ([form msg] `(try-expr ~msg ~form))) (defmacro try-expr [msg form] (let [cljs? (ana/cljs? &env) {:keys [file line end-line column end-column]} (meta form)] `(try ~(t/assert-expr msg form) (catch ~(if cljs? :default 'Throwable) t# (do-report {:type :error, :message ~msg, :file ~file :line ~line :end-line ~end-line :column ~column :end-column ~end-column :expected '~form, :actual t#})) (finally (~'RCF__done!))))) ;; Same as default `=` behavior, but returns the first argument instead of a boolean. (defmacro do-report [m] (if (:js-globals &env) `(cljs.test/do-report ~m) `(impl/do-report ~m))) #?(:clj (defn- assert-= [menv msg form] (let [[_= & args] form form (cons '= (map impl/original-form args))] `(let [values# (list ~@args) result# (apply = values#)] (if result# (do-report {:type :hyperfiddle.rcf/pass :message ~msg, :expected '~form :actual (cons '= values#)}) (do-report {:type :hyperfiddle.rcf/fail :message ~msg, :expected '~form :actual (list '~'not (cons '~'= values#))})) (first values#))))) #?(:clj (defmethod t/assert-expr 'hyperfiddle.rcf/= [msg form] (assert-= nil msg form))) #?(:clj (defn- assert-unify [menv msg form] (let [[_= & args] form form (cons := (map impl/original-form args))] `(let [lhs# (identity ~(first args)) rhs# (identity ~(second args)) [result# env#] (u/unifier* lhs# rhs#)] (if-not (u/failed? env#) (do (do-report {:type :hyperfiddle.rcf/pass :message ~msg, :expected '~form :actual result#}) result#) (do (do-report {:type :hyperfiddle.rcf/fail :message ~msg, :expected '~form :actual (u/explain env#)}) lhs#)))))) #?(:clj (defmethod t/assert-expr :hyperfiddle.rcf/= [msg form] (assert-unify nil msg form))) (defmacro with "Resource cleanup helper, based on missionary's dependency-free Task protocol, see https://github.com/leonoel/task" [dispose-fn & body] `(let [dispose# ~dispose-fn] (try (do ~@body) (finally (dispose#))))) ================================================ FILE: test/hyperfiddle/rcf/analyzer_test.clj ================================================ (ns hyperfiddle.rcf.analyzer-test (:require [hyperfiddle.rcf.analyzer :as ana] [clojure.test :as t :refer [deftest are testing]])) (defn roundtrip ([form] (roundtrip (ana/empty-env) form)) ([env form] (ana/emit (ana/analyze env form)))) (deftest roundtrips (testing "hf.analyzer should parse and unparse clojure code transparently." (are [x y] (= y x) (roundtrip 1) '1 (roundtrip '1) 1 (roundtrip ''1) ''1 (roundtrip :ns/a) :ns/a (roundtrip '(inc 1)) '(inc 1) (roundtrip [1]) [1] (roundtrip #{1}) #{1} (roundtrip ()) () (roundtrip '(1)) '(1) (roundtrip {:a 1}) {:a 1} (roundtrip '(do 1)) '(do 1) (roundtrip '(do (def a 1) a)) '(do (def a 1) a) (roundtrip '((def a identity) 1)) '((def a identity) 1) (-> (roundtrip '(def ^:macro a 1)) (second) (meta)) {:macro true} (roundtrip '(if true a b)) '(if true a b) (roundtrip '(if true a)) '(if true a nil) (roundtrip '(let [a 1 b 2] a)) '(let [a 1, b 2] a) (roundtrip '(loop* [a 1] (recur a))) '(loop* [a 1] (do (recur a))) (roundtrip '(fn* [])) '(fn* ([] (do))) (roundtrip '(fn* f [])) '(fn* f ([] (do))) (roundtrip '(fn* [a] a)) '(fn* ([a] (do a))) (roundtrip '(fn* ([a] a) ([a b] a))) '(fn* ([a] (do a)) ([a b] (do a))) (roundtrip '(fn [a] a)) '(fn [a] a) (roundtrip '(fn f [])) '(fn f []) (roundtrip '(letfn* [foo (fn* foo ([a] (inc a)))] 1)) '(letfn* [foo (fn* foo ([a] (do (inc a))))] (do 1)) (roundtrip '(try 1)) '(try (do 1)) (roundtrip '(try 1 (catch Err e# 2))) '(try (do 1) (catch Err e# (do 2))) (roundtrip '(try 1 (catch Err e# 2) (catch Err2 e# 3) (finally 4))) '(try (do 1) (catch Err e# (do 2)) (catch Err2 e# (do 3)) (finally 4)) ))) (comment (ana/analyze (ana/empty-env) '(do 1)) ) ================================================ FILE: test/hyperfiddle/rcf/cljs_test.cljs ================================================ (ns hyperfiddle.rcf.cljs-test (:require [clojure.core.async :refer [chan >! go go-loop ! c :hello) (>! c :world)) % := :hello % := :world (close! c)) (tests "missionary" (def !x (atom 0)) (def dispose ((m/reactor (m/stream! (m/ap (tap (inc (m/?< (m/watch !x))))))) (fn [_] #_(prn ::done)) #(prn ::crash %))) % := 1 (swap! !x inc) (swap! !x inc) % := 2 % := 3 (dispose)) ================================================ FILE: test/hyperfiddle/rcf/example_test.clj ================================================ (ns hyperfiddle.rcf.example-test (:require [clojure.core.async :refer [chan >! go go-loop ! c :hello) (>! c :world)) % := :hello % := :world (close! c)) (tests (def task (fn [success! failure!] (success! 1) (fn cancel [] (tap ::dispose)))) (with (task tap tap) % := 1) % := ::dispose) ================================================ FILE: test/hyperfiddle/rcf/unify_test.cljc ================================================ (ns hyperfiddle.rcf.unify-test (:require [hyperfiddle.rcf :refer [deftest tests]] [hyperfiddle.rcf.unify :as u]) #?(:cljs (:require-macros [hyperfiddle.rcf :refer [deftest tests]]))) (tests '(do 1) := '(do 1)) (tests (u/unify 1 _) := '{_ [1]}) (tests "Basics" (u/unify 1 1) := {} (u/failed? (u/unify 1 2)) := true (u/unify 1 _) := '{_ [1]} (u/unify 1 ?a) := '{?a 1} (u/unify [1 2 3] '[_ _ ?a]) := '{_ [1 2], ?a 3} "Both sides" (u/unify '[?a 1] '[?a ?a]) := '{?a 1} "Cycle" (u/unify '[?a ?b] '[?b ?a]) := '{?a ?b, ?b ?a} "Transitive" (u/unify '[?a ?b 1] '[?b _ ?a]) := '{?a ?b, _ [?b], ?b 1}) (tests "Ground" "Cycle" (u/ground (u/unify '[?a ?b] '[?b ?a])) := '{?a ::u/cycle, ?b ::u/cycle} "Transitive" (u/ground (u/unify '[?a ?b 1] '[?b _ ?a])) := '{?a 1, _ [1], ?b 1}) (tests "Composite" (u/unify {:first ?first :last ?last :genre :giallo} {:first "Dario" :last "Argento" :genre :giallo}) := '{?first "Dario", ?last "Argento"} (u/unify '[(?a * ?x | 2) + (?b * ?x) + ?c] '[?z + (4 * 5) + 3]) := '{?c 3, ?x 5, ?b 4, ?z (?a * ?x | 2)} (u/unify '[(?a * ?x | 2) + (?b * ?x) + ?c] '[(?a * 5 | 2) + (4 * 5) + 3]) := '{?c 3, ?b 4, ?x 5} (u/unify '[(?a * 5 | 2) + (4 * 5) + 3] '[?z + (4 * 5) + 3]) := '{?z (?a * 5 | 2)} (u/unify '[?a ?a] [1 2]) := {'?a 1, ::u/fail {'?a [1 2]} ::u/path _} "Spread" (u/unify [1 2 3] '[?x & ?more]) := '{?more (2 3), ?x 1} (u/unify [1 2 3] '[_ _ _ & ?more]) := '{_ [1 2 3]} (u/unify [1 2 3 4 5] '[_ _ _ & ?more]) := '{_ [1 2 3] ?more (4 5)} (u/unify [1 2 3 4 5] '[_ ?b _ & ?more]) := '{_ [1 3], ?more (4 5), ?b 2} (u/unify [:foo 1 2] '[?head & _]) := '{?head :foo, _ [(1 2)]}) (tests (u/unifier '[?first "Argento"] '["Dario" ?last]) := ["Dario" "Argento"] (u/unifier '[(?a * ?x | 2) + (?b * ?x) + ?c] '[?z + (4 * 5) + 3]) := '[(?a * 5 | 2) + (4 * 5) + 3] (u/unifier '{?a 1 :b :a} '{?b 1 :b ?a}) := {:a 1, :b :a} (u/unifier {:a 1, :b 2} '{?a ?b, ?b ?a}) := ::u/fail (u/unifier '[?a ?b] '[?b ?a]) := [::u/cycle ::u/cycle]) ================================================ FILE: test/hyperfiddle/rcf_test.cljc ================================================ (ns hyperfiddle.rcf-test (:require [clojure.test :as t :refer [deftest is testing]] [hyperfiddle.rcf :as rcf :refer [tests]] [matcher-combinators.test] #_[hyperfiddle.rcf.analyzer :as ana]) #?(:clj (:import [clojure.lang ExceptionInfo])) #?(:cljs (:require-macros [hyperfiddle.rcf-test]))) (deftest tap-outside-tests (is (= (with-out-str (rcf/tap 1)) "1\n")) (is (= (rcf/tap 1) 1))) (defmacro my-def [x] `(def ~(vary-meta x assoc :form3 (inc 1) ; evaluated now :form4 (quote (inc 1)) ; interpreted as if evaluated after code emission :form5 (quote (quote (inc 1))) ; escaping interpretation ))) #?(:clj (tests "Custom var meta on def symbol are interpreted as if they were evaluated after emission." ;; CLJ only, no vars in cljs. (my-def ^{:form1 (quote (inc 1)) :form2 (inc 1)} ; read and evaluated as usual x) (:form1 (meta #'x)) := '(inc 1) (:form2 (meta #'x)) := 2 (:form3 (meta #'x)) := 2 (:form4 (meta #'x)) := 2 (:form5 (meta #'x)) := '(inc 1))) (tests "Support for variadic fn" ; issue #65 (let [f (fn ([a] [a]) ; also check multi arity ([a b] [a b]) ([a b & cs] [a b cs])) g (fn [& args] args) h #(vector %&)] (f 1) := [1] (f 1 2) := [1 2] (f 1 2 3 4) := [1 2 '(3 4)] (g 1 2) := [1 2] (h 1 2) := ['(1 2)] )) (tests "Inline letfn support" (letfn [(descent [x] (cond (pos? x) (dec x) (neg? x) (inc x) :else x)) (is-even? [x] (if (zero? x) true (is-odd? (descent x)))) (is-odd? [x] (if (zero? x) false (is-even? (descent x))))] [(is-even? 0) (is-even? 1) (is-even? 2) (is-even? -2)] := [true false true true] [(is-odd? 0) (is-odd? 2) (is-odd? 3) (is-odd? -3)] := [false false true true])) (tests "! still works" (rcf/! 5) rcf/% := 5) (tests ":throws works in clj(s)" ;; inlining `thrower` leads to "unreachable code" warning (let [thrower #(throw (ex-info "boom" {}))] (thrower) :throws ExceptionInfo)) ; fixme #_(tests "matcher-combinators match? works infix" {:a {:b 1}} match? {:a {:b int?}}) (tests "`with` discards in presence of exceptions, too" (try (rcf/with #(rcf/tap :ran) (throw (ex-info "" {}))) (catch ExceptionInfo _)) rcf/% := :ran ) ;; For an unknown reason, `macroexpand-1` acts as identity when runnning ;; tests without a repl. ;; (defn disable-ci [f] ;; (let [gen rcf/*generate-tests* ;; enabled rcf/*enabled*] ;; (alter-var-root #'rcf/*generate-tests* (constantly (not gen))) ;; (alter-var-root #'rcf/*enabled* (constantly (not enabled))) ;; (f) ;; (alter-var-root #'rcf/*generate-tests* (constantly gen)) ;; (alter-var-root #'rcf/*enabled* (constantly enabled)))) ;; ;; (t/use-fixtures :once disable-ci) ;; ;; (defn tests' [& [body]] ;; (apply #'tests nil nil body)) ;; ;; (deftest block-behavior ;; (testing "`tests` behaves like" ;; (testing "`cc/comment` when RCF is disabled." ;; (binding [rcf/*enabled* false] ;; (is (nil? (tests' '(1 := 1)))))) ;; (testing "`cc/do` when RCF is enabled." ;; (is (= '(do) (tests'))) ;; (is (= '1 (tests' '(1)))) ;; (is (= '(do 1 2) (tests' '(1 2))))))) ;; ;; (deftest nesting ;; (testing "Nested `tests` flattens" ;; (is (= '(do) (tests' '((tests))))) ;; (is (= '(do 1 2) (tests' '(1 (tests 2))))))) ;; ;; #_(deftest documentation-behavior ;; (testing "`tests` behaves like `t/testing` when a string litteral is followed by an expression." ;; (is (= `(t/testing "a" 1) ;; (macroexpand-1 '(tests "a" 1)))))) ;; ;; #_(deftest basic-assertion ;; (testing "Assertion sigils are listed by `t/assert-expr`." ;; (is (contains? (methods t/assert-expr) :default))) ;; (testing "Infix sigils desugares to `is`" ;; (is (= `(t/is (:default 1 1)) ;; (macroexpand-1 '(tests 1 :default 1))))) ;; (testing "RCF rewrites some sigils to avoid conflicts" ;; extensible by a multimethod ;; (is (= '(clojure.test/is (:hyperfiddle.rcf/= '_ '_)) ;; (macroexpand-1 '(tests _ := _)))))) ;; ;; (comment ;; (alter-var-root #'rcf/*generate-tests* (constantly false)) ;; (rcf/enable! true)) ;; (deftest repl-behavior ;; (testing "`tests` behaves like a REPL" ;; (testing "where *1, *2, *3 referers to previous results." ;; (is (= '(i/repl 1 *1 *2 *3) (tests* 1 *1 *2 *3)))) ;; (testing "where a `def` form is immediately available after being evaluated." ;; (is (= '(i/repl (def a 1) a) (tests* (def a 1) a))) ;; (is (= '(i/repl ((def a identity) 1)) ;; (tests* ((def a identity) 1))))))) ;; ;; (deftest async-behavior ;; (testing "`tests` can probe for values using `!`" ;; (is (= '(let [[! %] (i/queue)] ;; (! 1)) ;; (tests* (! 1))))) ;; (testing "`tests` can inspect probed values using `%`" ;; (is (= '(let [[! %] (i/queue)] ;; (! 1) ;; (%)) ;; (tests* (! 1) %))) ;; (is (= '(let [[! %] (i/queue)] ;; (! 1) ;; (% (fn [result] (i/is (:= result 1))))) ;; (tests* (! 1) % := 1))))) ;; ;; (deftest repl-macro ;; (testing "RCF repl behavior" ;; (testing "supports *1 *2 *3" ;; (is (= '(let [[push! peek] (i/binding-queue)] ;; (push! 1) ;; (push! (peek 0)) ;; (push! (peek 1)) ;; (peek 2)) ;; '(i/repl 1 *1 *2 *3)))) ;; (testing "handles the Gilardi scenario" ;; (is (= '(do (def a 1) a) ;; (tests* (def a 1) a))) ;; (is (= '(do (def a identity) (a 1)) ;; (tests* ((def a identity) 1))))))) ;; ;; (macroexpand-1 `(tests* 1 := 1)) ;; (macroexpand-1 `(tests* (do (rcf/! 1) rcf/% := 1)))