├── .clj-kondo └── config.edn ├── dev.cljs.edn ├── run-chrome.sh ├── src └── active │ └── clojure │ ├── debug.clj │ ├── macro.cljc │ ├── test_condition_cljs.cljc │ ├── record.clj │ ├── cljs │ └── record.cljc │ ├── test_condition.cljc │ ├── condition_hooks.clj │ ├── dynj.clj │ ├── mock_monad.cljc │ ├── record_runtime.cljc │ ├── functions.cljc │ ├── record_spec.cljc │ ├── validation.cljc │ ├── record_helper.cljc │ ├── sum_type.cljc │ └── record_clj_internals.clj ├── figwheel-main.edn ├── .gitignore ├── dev ├── active │ └── clojure │ │ ├── figwheel_test_runner.cljs │ │ └── figwheel.clj └── insert-define-record-type.el ├── test.cljs.edn ├── .github ├── actions │ └── install-leiningen │ │ └── action.yml └── workflows │ └── clojure.yml ├── resources └── clj-kondo.exports │ └── de.active-group │ └── active-clojure │ ├── hooks │ ├── dynj.clj │ ├── sum_type.clj │ ├── condition.clj │ ├── monad.clj │ └── record.clj │ └── config.edn ├── test └── active │ └── clojure │ ├── record_nongenerative_test.cljc │ ├── debug_test.cljc │ ├── macro_test.cljc │ ├── record_data_test.cljc │ ├── sum_type_data_test.cljc │ ├── test_deps.cljs │ ├── test_condition_test.cljc │ ├── functions_test_util.clj │ ├── dynj_test.clj │ ├── mock_monad_test.cljc │ ├── functions_test.cljc │ ├── condition_test.cljc │ ├── record_runtime_test.cljc │ ├── record_spec_test.cljc │ ├── sum_type_test.cljc │ ├── validation_test.cljc │ └── freer_monad_test.cljc ├── project.clj └── LICENSE /.clj-kondo/config.edn: -------------------------------------------------------------------------------- 1 | {:config-paths ["../resources/clj-kondo.exports/de.active-group/active-clojure"]} 2 | -------------------------------------------------------------------------------- /dev.cljs.edn: -------------------------------------------------------------------------------- 1 | ^{:auto-testing true 2 | :watch-dirs ["src" "test"]} 3 | {:main active.clojure.test-runner} 4 | -------------------------------------------------------------------------------- /run-chrome.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | 3 | CHROME_BIN="${CHROME_BIN:-chromium}" 4 | exec "$CHROME_BIN" --no-sandbox --headless --disable-gpu --repl $1 5 | -------------------------------------------------------------------------------- /src/active/clojure/debug.clj: -------------------------------------------------------------------------------- 1 | (ns active.clojure.debug) 2 | 3 | (defmacro pret [x] 4 | "Print and return the argument." 5 | `(let [x# ~x] 6 | (println x#) 7 | x#)) 8 | -------------------------------------------------------------------------------- /figwheel-main.edn: -------------------------------------------------------------------------------- 1 | {:target-dir "resources" 2 | :log-level :info 3 | :open-url false 4 | :auto-testing true 5 | :watch-dirs ["src" "test" "dev"] 6 | :extra-main-files {:testing {:main signatures.figwheel-test-runner}}} 7 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.class 2 | *.jar 3 | *~ 4 | .rebel_readline_history 5 | /.cljs_rhino_repl 6 | /.lein-* 7 | /.lsp 8 | /.nrepl-port 9 | /checkouts 10 | /classes 11 | /target 12 | node_modules/ 13 | pom.xml 14 | pom.xml.asc 15 | resources/public/cljs-out 16 | -------------------------------------------------------------------------------- /dev/active/clojure/figwheel_test_runner.cljs: -------------------------------------------------------------------------------- 1 | (ns active.clojure.figwheel-test-runner 2 | (:require [figwheel.main.testing :refer-macros [run-tests-async]] 3 | [active.clojure.test-deps])) 4 | 5 | (defn -main [& args] 6 | (run-tests-async 10000)) 7 | -------------------------------------------------------------------------------- /test.cljs.edn: -------------------------------------------------------------------------------- 1 | ^{;:launch-js "headless-chrome" 2 | :ring-server-options {:port 9550} 3 | :open-url "http://[[server-hostname]]:[[server-port]]/test" 4 | :ring-handler active.clojure.figwheel/figwheel-test-handler 5 | :repl-eval-timeout 60000} 6 | {:main active.clojure.figwheel-test-runner} 7 | -------------------------------------------------------------------------------- /dev/active/clojure/figwheel.clj: -------------------------------------------------------------------------------- 1 | (ns ^:no-doc active.clojure.figwheel 2 | (:require [compojure.core :as compojure])) 3 | 4 | (def figwheel-test-handler 5 | (do 6 | (compojure/routes 7 | (compojure/GET "/test" 8 | [] 9 | "

Test host page

")))) 10 | -------------------------------------------------------------------------------- /.github/actions/install-leiningen/action.yml: -------------------------------------------------------------------------------- 1 | name: "install Leiningen" 2 | runs: 3 | using: composite 4 | steps: 5 | - name: add pwd to PATH 6 | shell: bash 7 | run: echo "$(pwd)" >> "$GITHUB_PATH" 8 | - name: install Leiningen 9 | shell: bash 10 | run: | 11 | curl -LSs https://raw.githubusercontent.com/technomancy/leiningen/stable/bin/lein -o lein 12 | chmod +x lein 13 | -------------------------------------------------------------------------------- /resources/clj-kondo.exports/de.active-group/active-clojure/hooks/dynj.clj: -------------------------------------------------------------------------------- 1 | (ns hooks.dynj 2 | (:require [clj-kondo.hooks-api :as api])) 3 | 4 | (defn declare-dynj 5 | [{:keys [node]}] 6 | (let [[name _second & _more] (rest (:children node)) 7 | new-node (api/list-node 8 | (list (api/token-node 'do) 9 | (api/list-node [(api/token-node 'declare) name])))] 10 | {:node new-node})) 11 | -------------------------------------------------------------------------------- /test/active/clojure/record_nongenerative_test.cljc: -------------------------------------------------------------------------------- 1 | (ns active.clojure.record-nongenerative-test 2 | (:require #?(:clj [active.clojure.record :refer [define-record-type]]) 3 | #?(:cljs [active.clojure.cljs.record])) 4 | #?(:cljs 5 | (:require-macros [active.clojure.cljs.record :refer [define-record-type]]))) 6 | 7 | (define-record-type NonGROtherNS 8 | {:nongenerative "NonGROtherNS"} 9 | (make-ngrons field) 10 | ngrons? 11 | [field ngrons-field]) 12 | -------------------------------------------------------------------------------- /src/active/clojure/macro.cljc: -------------------------------------------------------------------------------- 1 | (ns active.clojure.macro 2 | "Macro helpers.") 3 | 4 | ;; Repeated in numerous projects 5 | 6 | (clojure.core/defn cljs-env? 7 | "Take the &env from a macro, and tell whether we are expanding into cljs." 8 | [env] 9 | (boolean (:ns env))) 10 | 11 | (defmacro if-cljs 12 | "Return then if we are generating cljs code and else for Clojure code. 13 | https://groups.google.com/d/msg/clojurescript/iBY5HaQda4A/w1lAQi9_AwsJ" 14 | [then else] 15 | (if (cljs-env? &env) then else)) 16 | -------------------------------------------------------------------------------- /test/active/clojure/debug_test.cljc: -------------------------------------------------------------------------------- 1 | (ns active.clojure.debug-test 2 | (:require #?(:clj [active.clojure.debug :as dbg]) 3 | #?(:clj [clojure.test :refer :all]) 4 | #?(:cljs [cljs.test])) 5 | #?(:cljs 6 | (:require-macros [cljs.test 7 | :refer (is deftest run-tests testing)] 8 | [active.clojure.debug :as dbg]))) 9 | 10 | #?(:cljs 11 | (enable-console-print!)) 12 | 13 | (deftest pret 14 | (let [v [4 8 15 16 23 42 108]] 15 | (is (= v (dbg/pret v))))) 16 | -------------------------------------------------------------------------------- /test/active/clojure/macro_test.cljc: -------------------------------------------------------------------------------- 1 | (ns active.clojure.macro-test 2 | (:require #?(:clj [clojure.test :refer :all]) 3 | #?(:clj [active.clojure.macro :refer [if-cljs]]) 4 | #?(:cljs [cljs.test])) 5 | #?(:cljs 6 | (:require-macros [active.clojure.macro :refer [if-cljs]] 7 | [cljs.test :refer (is deftest run-tests testing)]))) 8 | 9 | (deftest if-cljs-test 10 | #?(:cljs 11 | (is (= 1 12 | (if-cljs 1 0))) 13 | :clj 14 | (is (= 0 15 | (if-cljs 1 0))))) 16 | -------------------------------------------------------------------------------- /resources/clj-kondo.exports/de.active-group/active-clojure/hooks/sum_type.clj: -------------------------------------------------------------------------------- 1 | (ns hooks.sum-type 2 | (:require [clj-kondo.hooks-api :as api])) 3 | 4 | (defn define-sum-type 5 | [expr] 6 | (update expr :node 7 | (fn [node] 8 | (let [[sum-type-name predicate] (rest (:children node))] 9 | (api/list-node 10 | (list (api/token-node 'do) 11 | (api/list-node [(api/token-node 'declare) sum-type-name]) 12 | (api/list-node [(api/token-node 'declare) predicate]))))))) 13 | 14 | -------------------------------------------------------------------------------- /test/active/clojure/record_data_test.cljc: -------------------------------------------------------------------------------- 1 | (ns active.clojure.record-data-test 2 | (:require #?(:clj [active.clojure.record :refer [define-record-type]] 3 | :cljs [active.clojure.cljs.record :refer-macros [define-record-type]]))) 4 | 5 | (define-record-type IntInt 6 | {:spec ::IntInt} 7 | (make-int-int fst snd) 8 | int-int? 9 | [^{:spec int?} fst int-int-fst 10 | ^{:spec int?} snd int-int-snd]) 11 | 12 | (define-record-type Container 13 | {:spec ::Container} 14 | (make-container value) 15 | container? 16 | [^{:spec ::IntInt} value container-value]) 17 | -------------------------------------------------------------------------------- /test/active/clojure/sum_type_data_test.cljc: -------------------------------------------------------------------------------- 1 | (ns active.clojure.sum-type-data-test 2 | (:require #?(:clj [active.clojure.record :as record]) 3 | #?(:cljs [active.clojure.cljs.record :as record :include-macros true]))) 4 | 5 | 6 | (record/define-record-type circle 7 | #?(:clj {:java-class? false} 8 | :cljs {:rtd-record? true}) 9 | (make-circle radius) circle? 10 | [radius circle-radius]) 11 | 12 | (record/define-record-type square 13 | #?(:clj {:java-class? false} 14 | :cljs {:rtd-record? true}) 15 | (make-square height width) square? 16 | [height square-height 17 | width square-width]) 18 | -------------------------------------------------------------------------------- /test/active/clojure/test_deps.cljs: -------------------------------------------------------------------------------- 1 | (ns active.clojure.test-deps 2 | (:require [active.clojure.condition-test] 3 | [active.clojure.config-test] 4 | [active.clojure.debug-test] 5 | [active.clojure.freer-monad-test] 6 | [active.clojure.functions-test] 7 | [active.clojure.lens-test] 8 | [active.clojure.macro-test] 9 | [active.clojure.mock-monad-test] 10 | [active.clojure.monad-test] 11 | [active.clojure.record-runtime-test] 12 | [active.clojure.record-spec-test] 13 | [active.clojure.record-test] 14 | [active.clojure.sum-type-test] 15 | [active.clojure.validation-test])) 16 | -------------------------------------------------------------------------------- /test/active/clojure/test_condition_test.cljc: -------------------------------------------------------------------------------- 1 | (ns active.clojure.test-condition-test 2 | #?(:cljs (:require-macros [active.clojure.test-condition] 3 | [cljs.test :refer (is deftest run-tests testing)])) 4 | (:require [active.clojure.test-condition] 5 | #?(:clj [clojure.test :refer :all]) 6 | #?(:cljs [cljs.test]) 7 | [active.clojure.condition :as c])) 8 | 9 | ;; deactivate the tests here, as they are intended to fail 10 | ;; uncomment if you want to run them 11 | (defn test-ns-hook [] 12 | ) 13 | 14 | ;; Note: should be doable on cljs, but does not work there currently. 15 | #?(:clj (deftest is-test 16 | (is 17 | (raised? c/error? 18 | (c/raise (c/make-error) "random error"))) 19 | 20 | ;; failure is success 21 | (is 22 | (raised? c/error? 23)) 23 | 24 | (is 25 | (raised? c/error? (c/raise (c/make-warning) "not an error"))))) 26 | -------------------------------------------------------------------------------- /resources/clj-kondo.exports/de.active-group/active-clojure/config.edn: -------------------------------------------------------------------------------- 1 | {:linters {:monad/empty {:level :error}} 2 | :hooks {:analyze-call {active.clojure.condition/define-condition-type hooks.condition/define-condition-type 3 | active.clojure.condition/guard hooks.condition/guard 4 | active.clojure.dynj/declare-dynj hooks.dynj/declare-dynj 5 | active.clojure.monad/monadic hooks.monad/monadic 6 | active.clojure.cljs.record/define-record-type hooks.record/define-record-type 7 | active.clojure.cljs.record/define-singleton-type hooks.record/define-singleton-type 8 | active.clojure.sum-type/define-sum-type hooks.sum-type/define-sum-type 9 | active.clojure.record/define-record-type hooks.record/define-record-type 10 | active.clojure.record/define-singleton-type hooks.record/define-singleton-type}} 11 | :lint-as {active.clojure.dynj/binding clojure.core/binding 12 | active.clojure.dynj/defn-dynj clojure.core/defn}} 13 | -------------------------------------------------------------------------------- /test/active/clojure/functions_test_util.clj: -------------------------------------------------------------------------------- 1 | (ns active.clojure.functions-test-util) 2 | 3 | (defmacro generate-tests [name repl orig fargs-list rargs-list] 4 | ;; Note that 'is' must be emitted unhygienic, because we want to pickup cljs.test/is resp. clojure.test/is 5 | `(do 6 | ~@(concat 7 | (map (fn [fargs] 8 | ;; comparability is given: 9 | `(let [args# ~fargs] 10 | (~'is (= (apply ~repl args#) 11 | (apply ~repl args#)) 12 | (str ~name " returns equal objects for equal arguments")))) 13 | fargs-list) 14 | (mapcat (fn [fargs] 15 | (map (fn [rargs] 16 | ;; functionality same as original: 17 | `(~'is (= (apply (apply ~repl ~fargs) ~rargs) 18 | (apply (apply ~orig ~fargs) ~rargs)) 19 | (str ~name " returns something that works the same as clojure.core equivalent"))) 20 | rargs-list)) 21 | fargs-list)))) 22 | -------------------------------------------------------------------------------- /.github/workflows/clojure.yml: -------------------------------------------------------------------------------- 1 | name: ci 2 | on: [push, workflow_dispatch] 3 | 4 | jobs: 5 | test: 6 | runs-on: ubuntu-latest 7 | steps: 8 | - uses: actions/checkout@v4 9 | - uses: ./.github/actions/install-leiningen 10 | - name: install Clojure dependencies 11 | run: lein deps 12 | - name: run Clojure tests 13 | run: lein test 14 | - run: lein figtest-headless 15 | 16 | codox: 17 | runs-on: ubuntu-latest 18 | steps: 19 | - uses: actions/checkout@v4 20 | - uses: ./.github/actions/install-leiningen 21 | - run: lein codox 22 | 23 | notify-test-failures: 24 | runs-on: ubuntu-latest 25 | needs: [test, codox] 26 | if: failure() && github.ref == 'refs/heads/main' 27 | steps: 28 | - env: 29 | SECRET: ${{ secrets.MATTERMOST_WEBHOOK_URL }} 30 | CHANNEL: "active-clojure" 31 | USERNAME: "GitHub" 32 | run: | 33 | URL=https://github.com/${GITHUB_REPOSITORY}/commit/${GITHUB_SHA} 34 | curl -i --data-urlencode "payload={\"channel\":\"${CHANNEL}\", \"username\":\"${USERNAME}\",\"text\":\"Failure in tests: ${URL}\"}" ${SECRET} 35 | -------------------------------------------------------------------------------- /src/active/clojure/test_condition_cljs.cljc: -------------------------------------------------------------------------------- 1 | (ns active.clojure.test-condition-cljs 2 | (:require #?(:clj [clojure.test :as ct]) 3 | #?(:cljs [cljs.test :as ct]) 4 | [active.clojure.condition :as c])) 5 | 6 | #?(:clj 7 | (defmethod ct/assert-expr 'raised? [_env ?msg ?form] 8 | (let [[_raised? ?condition-predicate ?expr] ?form] 9 | `(c/guard [con# 10 | (~?condition-predicate con#) 11 | (ct/do-report {:type :pass :message ~?msg 12 | :expected ~?condition-predicate}) 13 | 14 | 15 | :else 16 | (ct/do-report {:type :fail 17 | :message "invalid condition" 18 | :expected (list ~?condition-predicate con#) 19 | :actual (list 'not (list ~?condition-predicate con#))})] 20 | 21 | 22 | (let [val# ~?expr] 23 | (ct/do-report {:type :fail 24 | :message "condition expected" 25 | :expected ~?condition-predicate 26 | :actual val#})))))) 27 | -------------------------------------------------------------------------------- /resources/clj-kondo.exports/de.active-group/active-clojure/hooks/condition.clj: -------------------------------------------------------------------------------- 1 | (ns hooks.condition 2 | (:require [clj-kondo.hooks-api :as api])) 3 | 4 | (defn define-condition-type 5 | [{:keys [:node]}] 6 | (let [[_ condition _super ctor pred & [field-specs]] (:children node) 7 | accessors (map second (partition 2 (:children field-specs))) 8 | new-node (api/list-node 9 | (list* (api/token-node 'do) 10 | (api/list-node [(api/token-node 'declare) condition]) 11 | (api/list-node [(api/token-node 'declare) pred]) 12 | (api/list-node [(api/token-node 'declare) ctor]) 13 | (map (fn [t] (api/list-node [(api/token-node 'declare) t])) 14 | accessors)))] 15 | {:node new-node})) 16 | 17 | (defn guard 18 | [{:keys [:node]}] 19 | (let [[_ condition+clauses & body] (:children node) 20 | [condition & clauses] (:children condition+clauses)] 21 | {:node 22 | (api/list-node 23 | (list* 24 | (api/token-node 'do) 25 | (api/list-node 26 | [(api/token-node 'let) 27 | (api/vector-node [condition (api/token-node 'nil)]) 28 | (api/list-node 29 | (list* 30 | (api/token-node 'do) 31 | clauses))]) 32 | body))})) 33 | -------------------------------------------------------------------------------- /resources/clj-kondo.exports/de.active-group/active-clojure/hooks/monad.clj: -------------------------------------------------------------------------------- 1 | (ns hooks.monad 2 | (:require [clj-kondo.hooks-api :as api])) 3 | 4 | (defn monadic 5 | [{:keys [:node]}] 6 | (letfn [(rewrite-monadic-form 7 | [forms] 8 | (if (empty? forms) 9 | forms 10 | (let [form (first forms) 11 | forms (rest forms)] 12 | (cond 13 | (= :vector (:tag form)) 14 | (api/list-node 15 | (list (api/token-node 'let) 16 | form 17 | (rewrite-monadic-form forms))) 18 | (and (= :list (:tag form)) 19 | (= 2 (count (:children form))) 20 | (= "let" (:string-value (first (:children form))))) 21 | (api/list-node 22 | (list (first (:children form)) 23 | (second (:children form)) 24 | (rewrite-monadic-form forms))) 25 | :else 26 | (if (empty? forms) 27 | form 28 | (api/list-node 29 | (list (api/token-node 'do) 30 | form 31 | (rewrite-monadic-form forms))))))))] 32 | (let [[& forms] (rest (:children node))] 33 | (if (empty? forms) 34 | (api/reg-finding! (assoc (meta node) 35 | :message "monadic must not be empty" 36 | :type :monad/empty)) 37 | (let [new-node (rewrite-monadic-form forms)] 38 | {:node new-node}))))) 39 | -------------------------------------------------------------------------------- /src/active/clojure/record.clj: -------------------------------------------------------------------------------- 1 | (ns active.clojure.record 2 | (:require [active.clojure.record-helper :as r-help] 3 | [active.clojure.record-runtime :as record-runtime] 4 | [active.clojure.record-clj-internals :refer [emit-java-record-definition]])) 5 | 6 | ;; TODO: clojure.lang.IEditableCollection would be nice 7 | 8 | (defmacro define-record-type 9 | [?type ?second & ?params] 10 | ;; Only emit a new record-definition, when there isn't already one 11 | ;; (only, when :nongenerative option is truthy) 12 | (when-let [[type options constructor constructor-args predicate field-triples opt+specs] 13 | (r-help/prepare-arguments! &form *ns* ?type ?second ?params)] 14 | ;; Note: rtd-record? used to be only for cljs; now an alternative option. 15 | (if (or (:rtd-record? options) (false? (:java-class? options))) 16 | (r-help/emit-own-record-definition type options constructor constructor-args 17 | predicate field-triples opt+specs) 18 | (emit-java-record-definition type options constructor constructor-args 19 | predicate field-triples opt+specs)))) 20 | 21 | 22 | (defmacro define-singleton-type 23 | "Defines a record type without fields. Instead of a constructor, the single value of this type is bound to `var-name`." 24 | [type-name var-name & [predicate-name]] 25 | (let [ctor (gensym "ctor")] 26 | `(do (active.clojure.record/define-record-type ~type-name {:java-class? false} 27 | (~ctor) 28 | ~(or predicate-name (gensym "predicate")) 29 | []) 30 | (def ~var-name (~ctor))))) 31 | 32 | (defn record-type 33 | "Returns the record type of the given record value. 34 | 35 | ``` 36 | (define-record-type Foo foo? (make-foo a)) 37 | 38 | (= Foo (record-type (make-foo :b))) 39 | ``` 40 | " 41 | [v] 42 | (if (record-runtime/record? v) 43 | (record-runtime/record-rtd v) 44 | (type v))) 45 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject de.active-group/active-clojure "0.46-SNAPSHOT" 2 | :description "Active Clojure: Various Clojure utilities in use at Active Group" 3 | :url "http://github.com/active-group/active-clojure" 4 | :license {:name "Eclipse Public License" 5 | :url "http://www.eclipse.org/legal/epl-v10.html"} 6 | :dependencies [[org.clojure/clojure "1.10.0" :scope "provided"] 7 | [org.clojure/clojurescript "1.10.238" :scope "provided"] 8 | [io.aviso/pretty "1.1.1"] 9 | [org.clojure/core.match "1.0.0"] 10 | [org.clojure/test.check "0.10.0-alpha4"]] 11 | 12 | :generated-paths ["target"] 13 | 14 | :profiles {:dev {:dependencies [[com.bhauman/figwheel-main "0.2.0"] 15 | [com.bhauman/rebel-readline-cljs "0.1.4"] 16 | [compojure "1.6.1"]] 17 | :source-paths ["src" "dev"] 18 | :clean-targets ^{:protect false} ["resources/public/js/compiled" 19 | "resources/public/cljs-out" 20 | :target-path]} 21 | :codox {:dependencies [[codox-theme-rdash "0.1.2"]]}} 22 | 23 | :aliases {"fig" ["trampoline" "with-profile" "+dev,+test" "run" "-m" "figwheel.main" "-b" "dev" "-r"] 24 | "figtest" ["run" "-m" "figwheel.main" "-co" "test.cljs.edn" "-m" active.clojure.figwheel-test-runner] 25 | "figtest-headless" ["run" "-m" "figwheel.main" "-fwo" "{:launch-js [\"run-chrome.sh\" :open-url]}" "-co" "test.cljs.edn" "-m" active.clojure.figwheel-test-runner]} 26 | 27 | :plugins [[lein-codox "0.10.8"]] 28 | 29 | :codox {:language :clojure 30 | :metadata {:doc/format :markdown} 31 | :themes [:rdash] 32 | :src-uri "http://github.com/active-group/active-clojure/blob/main/" 33 | :src-linenum-anchor-prefix "L"} 34 | 35 | :global-vars {*warn-on-reflection* true}) 36 | -------------------------------------------------------------------------------- /dev/insert-define-record-type.el: -------------------------------------------------------------------------------- 1 | (defun un-camelcase-string (s &optional sep start) 2 | "Convert CamelCase string S to lower case with word separator SEP. 3 | Default for SEP is a hyphen \"-\". 4 | 5 | If third argument START is non-nil, convert words after that 6 | index in STRING." 7 | (let ((case-fold-search nil)) 8 | (while (string-match "[A-Z]" s (or start 1)) 9 | (setq s (replace-match (concat (or sep "-") 10 | (downcase (match-string 0 s))) 11 | t nil s))) 12 | (downcase s))) 13 | 14 | 15 | (defun field->field-tuple (field name) 16 | (list field 17 | " " 18 | (concat name "-" field) 19 | "\n ")) 20 | 21 | (defun create-field-tuples (fields name) 22 | (let* ((field-tuples (mapcar (lambda (field) 23 | (field->field-tuple field name)) 24 | fields)) 25 | (last-tuple (butlast (car (last field-tuples)))) 26 | (field-tuples2 (append (butlast field-tuples) 27 | (list last-tuple)))) 28 | (apply #'concat (append '("[") 29 | (apply #'append field-tuples2) 30 | '("]"))))) 31 | 32 | (defun create-constructor (name) 33 | (concat "make-" name)) 34 | 35 | (defun create-predicate (name) 36 | (concat name "?")) 37 | 38 | (defun insert-define-record-type () 39 | (interactive) 40 | (let* ((type-name (read-string "type-name: ")) 41 | (name (un-camelcase-string type-name)) 42 | (fields (seq-filter (lambda (elt) (not (string= "" elt))) (split-string (read-string "fields: ") " "))) 43 | (field-tuples (create-field-tuples fields name))) 44 | (insert (concat "(define-record-type " type-name 45 | "\n " 46 | (create-constructor name) 47 | "\n " 48 | (create-predicate name) 49 | "\n " 50 | field-tuples ")")))) 51 | -------------------------------------------------------------------------------- /src/active/clojure/cljs/record.cljc: -------------------------------------------------------------------------------- 1 | (ns active.clojure.cljs.record 2 | (:require [active.clojure.record-helper :as r-help] 3 | [active.clojure.record-runtime :as record-runtime] 4 | #?(:clj [active.clojure.cljs.record-cljs-internals :refer [emit-javascript-record-definition]]) 5 | )) 6 | 7 | #?(:clj 8 | (defmacro define-record-type 9 | [?type ?second & ?params] 10 | ;; Only emit a new record-definition, when there isn't already one 11 | ;; (only, when :nongenerative option is truthy) 12 | (when-let [[type options constructor constructor-args predicate field-triples opt+specs] 13 | (r-help/prepare-arguments! &form *ns* ?type ?second ?params)] 14 | ;; Note: java-class? used to be only for clj; now an alternative option. 15 | (if (or (:rtd-record? options) (false? (:java-class? options))) 16 | (r-help/emit-own-record-definition type options constructor constructor-args 17 | predicate field-triples opt+specs) 18 | (emit-javascript-record-definition &env type options constructor constructor-args 19 | predicate field-triples opt+specs))))) 20 | 21 | 22 | #?(:clj 23 | (defmacro define-singleton-type 24 | "Defines a record type without fields. Instead of a constructor, the single value of this type is bound to `var-name`." 25 | [type-name var-name & [predicate-name]] 26 | (let [ctor (gensym "ctor")] 27 | `(do (active.clojure.cljs.record/define-record-type ~type-name {:rtd-record? true} 28 | (~ctor) 29 | ~(or predicate-name (gensym "predicate")) 30 | []) 31 | (def ~var-name (~ctor)))))) 32 | 33 | (defn record-type 34 | "Returns the record type of the given record value. 35 | 36 | ``` 37 | (define-record-type Foo foo? (make-foo a)) 38 | 39 | (= Foo (record-type (make-foo :b))) 40 | ``` 41 | " 42 | [v] 43 | (if (record-runtime/record? v) 44 | (record-runtime/record-rtd v) 45 | (type v))) 46 | -------------------------------------------------------------------------------- /resources/clj-kondo.exports/de.active-group/active-clojure/hooks/record.clj: -------------------------------------------------------------------------------- 1 | (ns hooks.record 2 | (:require [clj-kondo.hooks-api :as api])) 3 | 4 | (defn- options-projection-lens-constructor [opts] 5 | (or (:projection-lens-constructor opts) 6 | (:projection-lens opts))) 7 | 8 | (defn define-record-type 9 | [{:keys [:node]}] 10 | (let [[record-name & more] (rest (:children node)) 11 | [constructor-spec predicate field-specs] (if (api/map-node? (first more)) 12 | ;; remove options 13 | (rest more) 14 | more) 15 | [constructor & _fields] (if-let [ch (:children constructor-spec)] 16 | ch 17 | [constructor-spec]) 18 | accessors (map second (partition 2 (:children field-specs))) 19 | new-node 20 | (api/list-node 21 | (list* (api/token-node 'do) 22 | (api/list-node [(api/token-node 'declare) record-name]) 23 | (api/list-node [(api/token-node 'declare) predicate]) 24 | (api/list-node [(api/token-node 'declare) constructor]) 25 | (map (fn [t] (api/list-node [(api/token-node 'declare) t])) 26 | (if-let [projection-lens (and (api/map-node? (first more)) 27 | (options-projection-lens-constructor (api/sexpr (first more))))] 28 | (conj accessors (api/token-node projection-lens)) 29 | accessors))))] 30 | {:node new-node})) 31 | 32 | (defn define-singleton-type 33 | [expr] 34 | (update expr :node 35 | (fn [node] 36 | (let [[record-name singleton predicate] (rest (:children node))] 37 | (api/list-node 38 | (list (api/token-node 'do) 39 | (api/list-node [(api/token-node 'declare) record-name]) 40 | (api/list-node [(api/token-node 'declare) singleton]) 41 | (api/list-node [(api/token-node 'declare) predicate]))))))) 42 | -------------------------------------------------------------------------------- /test/active/clojure/dynj_test.clj: -------------------------------------------------------------------------------- 1 | (ns active.clojure.dynj-test 2 | (:require [active.clojure.dynj :as dynj] 3 | [clojure.test :as t])) 4 | 5 | (dynj/declare-dynj foo "Foo" [bar]) 6 | 7 | (t/deftest declare-dynj-test 8 | ;; (t/is (:dynamic (meta #'foo))) 9 | (t/is (= "Foo" (:docstring (meta #'foo))))) 10 | 11 | (t/deftest binding-test 12 | (t/is (thrown? Exception (foo 4))) 13 | 14 | (dynj/binding [foo (fn [x] (* x 2))] 15 | (t/is (= 8 (foo 4))))) 16 | 17 | (t/deftest threading-test 18 | ;; threads 'inherit' current bindings 19 | (dynj/binding [foo (fn [x] (* x 2))] 20 | (t/is (= 8 @(future (foo 4)))))) 21 | 22 | (t/deftest bound-fn*-test 23 | ;; bind a function to current bindings 24 | (let [f (dynj/binding [foo (fn [x] (* x 2))] 25 | (dynj/bound-fn* (fn [v] 26 | (foo v))))] 27 | (t/is (= 8 (f 4)))) 28 | ;; it would be "unbound" otherwise 29 | (let [f (dynj/binding [foo (fn [x] (* x 2))] 30 | (fn [v] (foo v)))] 31 | (t/is (thrown? Exception (f 4))))) 32 | 33 | (t/deftest bind-fn*-test 34 | (let [bindings {#'foo #'str} 35 | f (fn [x] (foo (inc x))) 36 | bound (dynj/bind-fn* bindings f)] 37 | (t/is (= "5" (bound 4))))) 38 | 39 | (t/deftest with-bindings*-test 40 | (t/is 41 | (= 7 42 | (dynj/with-bindings* 43 | ;; just "foo" doesn't work here; Var is expected 44 | {#'foo (fn [x] (+ x 4))} 45 | ;; expects a thunk 46 | (fn [] (foo 3)))))) 47 | 48 | (t/deftest with-bindings-test 49 | (t/is 50 | (= 11 51 | (dynj/with-bindings 52 | {#'foo (fn [x] (+ x 4))} 53 | (foo 7))))) 54 | 55 | (dynj/defn-dynj bar [arg] 56 | (* 3 arg)) 57 | 58 | (t/deftest defn-dynj-default-implementation-test 59 | (t/is (= 9 (bar 3)))) 60 | 61 | (t/deftest merge-dynjs-test 62 | (let [b1 {#'foo #'inc} 63 | b2 {#'bar (fn [x] (str x "foo"))} 64 | bindings (dynj/merge-dynjs b1 b2)] 65 | (t/is "17foo" 66 | (dynj/with-bindings bindings 67 | (bar (foo 16)))) 68 | (dynj/merge-dynjs b1 b2)) 69 | (t/is 70 | (thrown? AssertionError 71 | (dynj/merge-dynjs {#'println (fn [s] (str s "foo"))} 72 | {#'foo #'inc})))) 73 | -------------------------------------------------------------------------------- /src/active/clojure/test_condition.cljc: -------------------------------------------------------------------------------- 1 | (ns active.clojure.test-condition ; we don't call this condition-test so we don't get mistaken for a test suite 2 | "Support for using `clojure.test` and conditions together." 3 | (:require #?(:clj [clojure.test :as ct]) 4 | #?(:cljs [cljs.test :as ct]) 5 | [active.clojure.condition :as c]) 6 | #?(:cljs (:require-macros [active.clojure.test-condition-cljs]))) 7 | 8 | #?(:clj 9 | (defmethod ct/assert-expr 'raised? [?msg ?form] 10 | (let [[_raised? ?condition-predicate ?expr] ?form] 11 | `(c/guard [con# 12 | (~?condition-predicate con#) 13 | (ct/do-report {:type :pass :message ~?msg 14 | :expected ~?condition-predicate}) 15 | 16 | 17 | :else 18 | (ct/do-report {:type :fail 19 | :message "invalid condition" 20 | :expected (list ~?condition-predicate con#) 21 | :actual (list 'not (list ~?condition-predicate con#))})] 22 | 23 | 24 | (let [val# ~?expr] 25 | (ct/do-report {:type :fail 26 | :message "condition expected" 27 | :expected ~?condition-predicate 28 | :actual val#}))))) 29 | :cljs 30 | (when (exists? js/cljs.test$macros) 31 | (defmethod js/cljs.test$macros.assert_expr 'raised? [_env ?msg ?form] 32 | (let [[_raised? ?condition-predicate ?expr] ?form] 33 | `(c/guard [con# 34 | (~?condition-predicate con#) 35 | (ct/do-report {:type :pass :message ~?msg 36 | :expected ~?condition-predicate}) 37 | 38 | 39 | :else 40 | (ct/do-report {:type :fail 41 | :message "invalid condition" 42 | :expected (list ~?condition-predicate con#) 43 | :actual (list 'not (list ~?condition-predicate con#))})] 44 | 45 | 46 | (let [val# ~?expr] 47 | (ct/do-report {:type :fail 48 | :message "condition expected" 49 | :expected ~?condition-predicate 50 | :actual val#})))))) 51 | ) 52 | -------------------------------------------------------------------------------- /test/active/clojure/mock_monad_test.cljc: -------------------------------------------------------------------------------- 1 | (ns active.clojure.mock-monad-test 2 | #?(:cljs (:require-macros [cljs.test :refer (is deftest run-tests testing)])) 3 | (:require [active.clojure.monad :as monad] 4 | #?(:clj [active.clojure.mock-monad :as mock] 5 | :cljs [active.clojure.mock-monad :as mock :include-macros true]) 6 | #?(:clj [clojure.test :refer :all]) 7 | #?(:cljs [cljs.test]))) 8 | 9 | (defrecord Ask [prompt]) 10 | (defn ask [prompt] (Ask. prompt)) 11 | (defn ask? [x] (instance? Ask x)) 12 | 13 | (defrecord Tell [msg]) 14 | (defn tell [msg] (Tell. msg)) 15 | (defn tell? [x] (instance? Tell x)) 16 | 17 | (defn ex1 18 | [] 19 | (monad/monadic 20 | [first (ask "what's your first name?") 21 | last (ask "what's your last name?")] 22 | (let [s (str "Hello, " first " " last)]) 23 | (tell s))) 24 | 25 | (deftest mock-run 26 | (let [result 27 | (mock/mock-run-monad 28 | [(mock/mock-result (ask "what's your first name?") 29 | "first") 30 | (mock/mock-result (ask "what's your last name?") 31 | "last") 32 | (mock/mock-result (tell "Hello, first last") 33 | "I don't care, I am mocking you.")] 34 | (ex1))] 35 | (is (= "I don't care, I am mocking you." result)))) 36 | 37 | (deftest mock-run-nested 38 | (let [result 39 | (mock/mock-run-monad 40 | [[(mock/mock-result (ask "what's your first name?") 41 | "first") 42 | (mock/mock-result (ask "what's your last name?") 43 | "last") 44 | (mock/mock-result (tell "Hello, first last") 45 | "I don't care, I am mocking you.")] 46 | [(mock/mock-result (ask "what's your first name?") 47 | "first") 48 | (mock/mock-result (ask "what's your last name?") 49 | "last") 50 | (mock/mock-result (tell "Hello, first last") 51 | "I don't care, I am mocking you.")]] 52 | (monad/monadic 53 | (ex1) 54 | (ex1)))] 55 | (is (= "I don't care, I am mocking you." result)))) 56 | 57 | (def reified-command 58 | (monad/reify-as (ask nil) ::reification)) 59 | 60 | (deftest mock-reified 61 | (let [result 62 | (mock/mock-run-monad 63 | [(mock/mock-result ::reification true)] 64 | reified-command)] 65 | (is (true? result)))) 66 | -------------------------------------------------------------------------------- /src/active/clojure/condition_hooks.clj: -------------------------------------------------------------------------------- 1 | (ns active.clojure.condition-hooks 2 | (:require [active.clojure.condition :as c] 3 | [clojure.main :as main] 4 | [clojure.test :refer :all] 5 | [clojure.stacktrace :as stack])) 6 | 7 | (defn repl-caught 8 | [& [e]] 9 | (let [e (or e *e)] 10 | (if (c/condition? e) 11 | (c/print-condition e *err*) 12 | (main/repl-caught e)))) 13 | 14 | ;; This trick (if it is one) stolen from humane-test-output 15 | 16 | (defonce activation-body 17 | (delay 18 | (defmethod report :error [m] 19 | [m] 20 | (with-test-out 21 | (inc-report-counter :error) 22 | (println "\nERROR in" (testing-vars-str m)) 23 | (when (seq *testing-contexts*) (println (testing-contexts-str))) 24 | (when-let [message (:message m)] (println message)) 25 | (println "expected:" (pr-str (:expected m))) 26 | (print " actual: ") 27 | (let [actual (:actual m)] 28 | (cond 29 | (c/condition? actual) (c/print-condition actual *out*) 30 | 31 | (instance? Throwable actual) 32 | (stack/print-cause-trace actual *stack-trace-depth*) 33 | 34 | :else (prn actual))))))) 35 | 36 | (defn activate-clojure-test! [] 37 | @activation-body) 38 | 39 | (defn root-cause 40 | "Returns the initial cause of an exception or error by peeling off all of 41 | its wrappers" 42 | [^Throwable t] 43 | (loop [cause t] 44 | (if (and (instance? clojure.lang.Compiler$CompilerException cause) 45 | (not= (.source ^clojure.lang.Compiler$CompilerException cause) "NO_SOURCE_FILE")) 46 | (.getCause cause)) ; one level up ... 47 | (if-let [cause (.getCause cause)] 48 | (recur cause) 49 | cause))) 50 | 51 | (defn print-stack-trace-of 52 | [^Throwable exc] 53 | (let [st (.getStackTrace exc)] 54 | (if-let [e (first st)] 55 | (clojure.stacktrace/print-trace-element e) 56 | (print "[empty stack trace]")) 57 | (newline) 58 | (doseq [e (rest st)] 59 | (print " ") 60 | (clojure.stacktrace/print-trace-element e) 61 | (newline)))) 62 | 63 | (defn install-default-uncaught-exception-handler! 64 | "Install an exception handler of last resort that will print a stack trace." 65 | [] 66 | (Thread/setDefaultUncaughtExceptionHandler 67 | (reify Thread$UncaughtExceptionHandler 68 | (uncaughtException [this t e0] 69 | (let [e (root-cause e0)] 70 | (if (c/condition? e) 71 | (do 72 | (c/print-condition e *err*) 73 | (.flush ^java.io.PrintWriter *err*)) 74 | (binding [*out* *err*] 75 | (println (.getSimpleName (class e)) (.getMessage ^Exception e)) 76 | (print-stack-trace-of e) 77 | (.flush ^java.io.PrintWriter *err*)))))))) 78 | -------------------------------------------------------------------------------- /test/active/clojure/functions_test.cljc: -------------------------------------------------------------------------------- 1 | (ns active.clojure.functions-test 2 | (:require [active.clojure.functions :as f] 3 | #?(:clj [active.clojure.functions-test-util :as u]) 4 | #?(:clj [clojure.test :refer :all]) 5 | #?(:cljs [cljs.test :refer-macros [deftest is testing]])) 6 | #?(:cljs (:require-macros [active.clojure.functions-test-util :as u]))) 7 | 8 | (deftest partial-test 9 | (u/generate-tests "partial" f/partial partial 10 | [[+] [list 0]] 11 | [[] [42] [1 2 3 4]]) 12 | 13 | ;; Clojurescript bug: https://dev.clojure.org/jira/browse/CLJS-3024 14 | #(:clj 15 | ;; all (critical) arities of our IFn: 16 | (u/generate-tests "partial" f/partial partial 17 | [[list -2 -1]] 18 | [[0] [1] 19 | [0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17] 20 | [0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18] 21 | [0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19] 22 | [0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20] 23 | [0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21]]))) 24 | 25 | (deftest constantly-test 26 | (u/generate-tests "constantly" f/constantly constantly 27 | [[1] [2]] 28 | [[] [4 5 6]])) 29 | 30 | (deftest comp-test 31 | (u/generate-tests "comp" f/comp comp 32 | [[]] 33 | [[1]]) 34 | (u/generate-tests "comp" f/comp comp 35 | [[-] [- *]] 36 | [[5 7] [1 3]]) 37 | (u/generate-tests "comp" f/comp comp 38 | [[reverse reverse]] 39 | [[[]] [[1 2 3]]])) 40 | 41 | (deftest complement-test 42 | (u/generate-tests "complement" f/complement complement 43 | [[nil?] [boolean]] 44 | [[nil] [42]])) 45 | 46 | (deftest juxt-test 47 | (u/generate-tests "juxt" f/juxt juxt 48 | [[first count]] 49 | [["Hello"] [[1 2 3]]])) 50 | 51 | (deftest fnil-test 52 | (u/generate-tests "fnil" f/fnil fnil 53 | [[list 42] [list 42 21]] 54 | [[nil 1] [nil 2 3] [1 2 3]])) 55 | 56 | (deftest every-pred-test 57 | (u/generate-tests "every-pred" f/every-pred every-pred 58 | [[odd?] [even? #(> % 5)]] 59 | [[] [1] [1 2 3]])) 60 | 61 | (deftest some-fn-test 62 | (u/generate-tests "some-fn" f/some-fn some-fn 63 | [[even? #(< % 10)]] 64 | [[] [1 2 3]])) 65 | 66 | (deftest completing-test 67 | (u/generate-tests "completing" f/completing completing 68 | [[concat] [concat reverse]] 69 | [[[1]] [[1] [2]]])) 70 | 71 | ;; I don't think bound-fn* is doing much in clojurescript anyway 72 | 73 | #?(:clj 74 | (deftest bound-fn*-test 75 | (def ^:dynamic *some-var* nil) 76 | (defn bound-fn*-test-f [res] (deliver res *some-var*)) 77 | 78 | (u/generate-tests "bound-fn*" f/bound-fn* bound-fn* 79 | [[list]] 80 | []) 81 | (let [res (promise)] 82 | (binding [*some-var* "goodbye"] 83 | (let [g (f/bound-fn* bound-fn*-test-f)] 84 | (.start (Thread. (fn [] 85 | (g res)))))) 86 | 87 | (is (= (deref res 1000 :timeout) 88 | "goodbye"))))) 89 | -------------------------------------------------------------------------------- /test/active/clojure/condition_test.cljc: -------------------------------------------------------------------------------- 1 | (ns active.clojure.condition-test 2 | #?(:clj (:require [clojure.test :refer [deftest is testing]] 3 | [active.clojure.condition :as c]) 4 | :cljs (:require [cljs.test :refer-macros [is deftest testing]] 5 | [active.clojure.condition :as c :include-macros true :refer [Throwable]]))) 6 | 7 | #?(:cljs 8 | (enable-console-print!)) 9 | 10 | (c/define-condition-type &c c/&condition 11 | make-c c? 12 | [x c-x]) 13 | 14 | (c/define-condition-type &c1 &c 15 | make-c1 c1? 16 | [a c1-a]) 17 | 18 | (c/define-condition-type &c2 &c 19 | make-c2 c2? 20 | [b c2-b]) 21 | 22 | (def v1 (make-c1 "V1" "a1")) 23 | 24 | (deftest c1 25 | (is (c? v1)) 26 | (is (c1? v1)) 27 | (is (not (c2? v1))) 28 | (is (= "V1" (c-x v1))) 29 | (is (= "a1" (c1-a v1)))) 30 | 31 | (def v2 (make-c2 "V2" "b2")) 32 | 33 | (deftest c2 34 | (is (c? v2)) 35 | (is (not (c1? v2))) 36 | (is (c2? v2)) 37 | (is (= "V2" 38 | (c-x v2))) 39 | (is (= "b2" 40 | (c2-b v2)))) 41 | 42 | (def v3 (c/combine-conditions 43 | (make-c1 "V3/1" "a3") 44 | (make-c2 "V3/2" "b3"))) 45 | 46 | (deftest compound1 47 | (is (c? v3)) 48 | (is (c1? v3)) 49 | (is (c2? v3)) 50 | (is (= "V3/1" 51 | (c-x v3))) 52 | (is (= "a3" 53 | (c1-a v3))) 54 | (is (= "b3" 55 | (c2-b v3)))) 56 | 57 | (def v4 (c/combine-conditions v1 v2)) 58 | 59 | (deftest compound2 60 | (is (c? v4)) 61 | (is (c1? v4)) 62 | (is (c2? v4)) 63 | (is (= "V1" 64 | (c-x v4))) 65 | (is (= "a1" 66 | (c1-a v4))) 67 | (is (= "b2" 68 | (c2-b v4)))) 69 | 70 | (def v5 (c/combine-conditions v2 v3)) 71 | 72 | (deftest compound3 73 | (is (c? v5)) 74 | (is (c1? v5)) 75 | (is (c2? v5)) 76 | (is (= "V2" 77 | (c-x v5))) 78 | (is (= "a3" 79 | (c1-a v5))) 80 | (is (= "b2" 81 | (c2-b v5)))) 82 | 83 | (deftest condition-types 84 | (testing "condition types are recognized by their respective predicates" 85 | (mapv 86 | (fn [[e pred?]] 87 | (is (pred? e)) 88 | (try (throw e) 89 | (catch Throwable caught 90 | (is (= e caught))))) 91 | [[(c/make-message-condition "the message") c/message-condition?] 92 | [(c/make-warning) c/warning?] 93 | [(c/make-serious-condition) c/serious-condition?] 94 | [(c/make-error) c/error?] 95 | [(c/make-violation) c/violation?] 96 | [(c/make-assertion-violation) c/assertion-violation?] 97 | [(c/make-irritants-condition ["eins" "zwei"]) c/irritants-condition?] 98 | [(c/make-who-condition "them") c/who-condition?]]))) 99 | 100 | (deftest guard-test 101 | (testing "can guard against conditions" 102 | (is (= :error 103 | (c/guard [con 104 | (c/error? con) :error 105 | (c/violation? con) :violation] 106 | (throw (c/make-error)))))) 107 | (testing "unguarded conditions bubble up" 108 | (is (thrown? Throwable 109 | (c/guard [con 110 | (c/error? con) :error] 111 | (throw (c/make-violation)))))) 112 | (testing ":else guards against unspecified conditions" 113 | (is (= :something-else 114 | (c/guard [con 115 | (c/violation? con) :violation 116 | :else :something-else] 117 | (throw (c/make-error)))))) 118 | (testing "can use the binding in consequent" 119 | (is (c/message-condition? 120 | (c/guard [con 121 | (c/message-condition? con) con 122 | :else :something-else] 123 | (throw (c/make-message-condition "the msg"))))))) 124 | 125 | #?(:clj 126 | (deftest java-throwables 127 | (let [c (c/->condition (Throwable. "foo"))] 128 | (is (c/throwable? c)) 129 | (is (not (c/error? c))) 130 | (is (not (c/assertion-violation? c)))) 131 | 132 | (let [c (c/->condition (Error. "foo"))] 133 | (is (c/throwable? c)) 134 | (is (not (c/error? c))) 135 | (is (c/assertion-violation? c))) 136 | 137 | (let [c (c/->condition (Exception. "foo"))] 138 | (is (c/throwable? c)) 139 | (is (c/error? c)) 140 | (is (not (c/assertion-violation? c)))))) 141 | 142 | (deftest combine-nil 143 | (is (c/error? (c/combine-conditions false (c/make-error) nil)))) 144 | 145 | (deftest exception-in-macro 146 | (try (or false (c/assertion-violation `exception-in-macro "I should throw.")) 147 | #?(:clj 148 | (catch Exception ^Exception e 149 | (is (= "I should throw." (.getMessage e)))) 150 | :cljs 151 | (catch js/Error e 152 | (is (= "I should throw." (.-message e))))))) 153 | -------------------------------------------------------------------------------- /src/active/clojure/dynj.clj: -------------------------------------------------------------------------------- 1 | (ns active.clojure.dynj 2 | "Thin layer over dynamic vars for implicit dependency injection. *Dynjs* can be 3 | used to have better control over side effects, to abstract over different 4 | possible interpretations of an aspect of a program or to make things easier 5 | for testing. 6 | 7 | ### Example 8 | 9 | First we declare a *dynj* named `eff`, which expects a single argument. 10 | 11 | ``` 12 | (declare-dynj eff [a]) 13 | ``` 14 | 15 | Note that `eff` itself can already be called, but it's \"abstract\" in the 16 | sense that without a bound implementation/interpreter, it cannot do anything. 17 | Hence the following will throw an exception: 18 | 19 | ``` 20 | (eff 2) 21 | ``` 22 | 23 | Let's say `foo` is a usage site of `eff`. (Of course, calling `foo` now will 24 | still throw the same exception as above.) 25 | 26 | ``` 27 | (defn foo [s] 28 | (assert (= 4 (eff 2)))) 29 | ``` 30 | 31 | With `binding` we can interpret `eff` as, say, a `square` function locally. 32 | 33 | ``` 34 | (defn square [a] (* a a)) 35 | 36 | (binding [eff square] 37 | (foo 5)) ;; => this works now 38 | ``` 39 | " 40 | (:refer-clojure :rename {bound-fn* clj-bound-fn* 41 | binding clj-binding 42 | with-bindings* clj-with-bindings* 43 | with-bindings clj-with-bindings})) 44 | 45 | (defn- dynj-name [dynj] 46 | #_(symbol (name (ns-name (:ns (meta dynj)))) 47 | (name (:name (meta dynj)))) 48 | ;; TODO: nicer 49 | (str dynj)) 50 | 51 | (defn ^:no-doc not-implemented [dynj] 52 | (ex-info (str "Dynj var " (dynj-name dynj) " not implemented.") {:dynj dynj :type ::not-implemented})) 53 | 54 | (defmacro defn-dynj 55 | "Declares `name` as a dynamic injection point, to be bound to an 56 | implementation/value later via [[binding]], and adds a default implementation. 57 | Typically you would throw a helpful exception in `body`." 58 | [name params & body] 59 | (let [[docstring params body] 60 | (if (string? params) 61 | [params (first body) (rest body)] 62 | [nil params body])] 63 | 64 | `(do (defn ~name [~@params] ~@body) 65 | (alter-meta! (var ~name) assoc 66 | :dynamic true 67 | ::dynj true 68 | :docstring ~docstring) 69 | ;; Note: adding :dynamic meta data is not enough in clojure :-/ need to call clojure.lang.Var/setDynamic. 70 | (.setDynamic (var ~name)) 71 | (var ~name)))) 72 | 73 | (defmacro declare-dynj 74 | "Declares `name` as a dynamic injection point, to be bound to an 75 | implementation/value later via [[binding]]. `params` and `docstring` 76 | are for documentation purposes." 77 | ([name params] 78 | `(defn-dynj ~name ~params 79 | (throw (not-implemented ~name)))) 80 | ([name docstring params] 81 | `(defn-dynj ~name ~docstring ~params 82 | (throw (not-implemented ~name))))) 83 | 84 | (defn- dynj-var? [v] 85 | (and (var? v) 86 | (contains? (meta v) ::dynj))) 87 | 88 | (defmacro binding 89 | "Binds one or more dynjs to implementations during the evaluation of `body`. 90 | 91 | ``` 92 | (declare-dynj add-user! [user]) 93 | 94 | (binding [add-user! db-add-user!] 95 | ...) 96 | ``` 97 | " 98 | [bindings & body] 99 | `(clj-binding ~bindings 100 | ~@body)) 101 | 102 | (defn with-bindings* 103 | "Calls `(thunk)` and binds implementations via a map of 104 | dynj vars during the evaluation of `(thunk)`." 105 | [binding-map thunk] 106 | (assert (every? dynj-var? (keys binding-map))) 107 | (clj-with-bindings* binding-map thunk)) 108 | 109 | (defmacro with-bindings 110 | "Executes `body` using implementations defined via a map of dynj vars." 111 | [binding-map & body] 112 | `(with-bindings* ~binding-map (fn [] ~@body))) 113 | 114 | (defn merge-dynjs 115 | "Like merge, but asserts that all keys are dynj vars, and the same 116 | vars are not bound to different implementations." 117 | [binding-map & more] 118 | (assert (every? #(every? dynj-var? (keys %)) (cons binding-map more))) 119 | (apply merge-with (fn [v1 v2] 120 | (assert (= v1 v2) (str "Conflicting dynj implementations: " v1 v2)) 121 | v2) 122 | (cons binding-map more))) 123 | 124 | (defn bound-fn* 125 | "Returns a function that will call `f` with the same dynj implementations in 126 | place as there are now. Passes all arguments through to f." 127 | [f] 128 | (clj-bound-fn* f)) 129 | 130 | (defn bind-fn* 131 | "Returns a function that will call `f` with the given map of dynj 132 | implementations in place. Note that the returned function can then 133 | be called on other threads, too." 134 | [binding-map f] 135 | (with-bindings* binding-map 136 | (fn [] 137 | (bound-fn* f)))) 138 | -------------------------------------------------------------------------------- /test/active/clojure/record_runtime_test.cljc: -------------------------------------------------------------------------------- 1 | (ns active.clojure.record-runtime-test 2 | (:require #?(:clj [clojure.test :refer :all]) 3 | [active.clojure.record-runtime :as r :include-macros true] 4 | #?(:cljs [active.clojure.cljs.record]) 5 | #?(:cljs [cljs.test])) 6 | #?(:cljs 7 | (:require-macros [cljs.test :refer (is deftest run-tests testing)]))) 8 | 9 | (def rtd0 (r/make-record-type-descriptor `rtd0 nil [])) 10 | (def rtd1 (r/make-record-type-descriptor `rtd1 nil [(r/make-record-field "f1")])) 11 | (def rtd2 (r/make-record-type-descriptor `rtd2 nil [(r/make-record-field "f1") 12 | (r/make-record-field "f2")])) 13 | (def rtd100 (r/make-record-type-descriptor `rtd100 nil 14 | (map #(str "f" %) (range 100)))) 15 | 16 | (deftest t-make-record-simple 17 | (let [r0 (r/make-record rtd0) 18 | r1 (r/make-record rtd1 1) 19 | r2 (r/make-record rtd2 1 2)] 20 | (is (r/record? r0)) 21 | (is (r/record-of-type? r0 rtd0)) 22 | (is (not (r/record-of-type? r0 rtd1))) 23 | (is (r/record? r1)) 24 | (is (= 1 (r/record-get rtd1 r1 0))) 25 | (is (r/record? r2)) 26 | (is (= 1 (r/record-get rtd2 r2 0))) 27 | (is (= 2 (r/record-get rtd2 r2 1))))) 28 | 29 | (deftest t-make-record-100 30 | (let [r100 (apply r/make-record rtd100 (range 100))] 31 | (doseq [i (range 100)] 32 | (is (= i (r/record-get rtd100 r100 i)))))) 33 | 34 | (deftest t-record-update 35 | (let [r2 (r/make-record rtd2 1 2) 36 | r2a (r/record-update rtd2 r2 1 5)] 37 | (is (= 1 (r/record-get rtd2 r2a 0))) 38 | (is (= 5 (r/record-get rtd2 r2a 1))))) 39 | 40 | (deftest t-record-check 41 | (let [r2 (r/make-record rtd2 1 2)] 42 | (is (thrown? #?(:clj Error :cljs js/Error) 43 | (r/record-get rtd0 r2 0))) 44 | (is (thrown? #?(:clj Error :cljs js/Error) 45 | (r/record-update rtd0 r2 0 :new))))) 46 | 47 | (deftest to-string-test 48 | (let [r0 (r/make-record rtd0) 49 | r1 (r/make-record rtd1 1) 50 | r2 (r/make-record rtd2 1 2)] 51 | (testing "str / toString" 52 | (is (= "active.clojure.record-runtime-test/rtd0{}" 53 | (str r0))) 54 | (is (= "active.clojure.record-runtime-test/rtd1{:f1 1}" 55 | (str r1))) 56 | (is (= "active.clojure.record-runtime-test/rtd2{:f1 1, :f2 2}" 57 | (str r2)))) 58 | (testing "pr-str / print-method" 59 | (is (= "active.clojure.record-runtime-test/rtd0{}" 60 | (pr-str r0))) 61 | (is (= "active.clojure.record-runtime-test/rtd1{:f1 1}" 62 | (pr-str r1))) 63 | (is (= "active.clojure.record-runtime-test/rtd2{:f1 1, :f2 2}" 64 | (pr-str r2)))))) 65 | 66 | 67 | (defrecord NotRTDRecord [a b]) 68 | (def rtd0-2 (r/make-record-type-descriptor `rtd0-2 nil [])) 69 | (def rtd2-2 (r/make-record-type-descriptor `rtd2-2 nil [(r/make-record-field "f1") 70 | (r/make-record-field "f2")])) 71 | 72 | ;; generate regexp for the expected error message 73 | ;; Todo: sth like escape for the cljs-regexp, \Q and \E is not available in JavaScript. 74 | (defn expected-check-rtd!-throw-error-message [wrong-rec] 75 | (let [tstr (pr-str wrong-rec) 76 | res-str #?(:clj (str "^\\QNot a record of the correct type [[active.clojure.record-runtime-test/rtd2]]:" tstr "\\E$") 77 | :cljs (str "^Not a record of the correct type \\[\\[active.clojure.record-runtime-test/rtd2\\]\\]:" tstr "$"))] 78 | (println res-str) 79 | (re-pattern res-str))) 80 | 81 | 82 | (deftest record-check-rtd!-throws-when-wrong-record-type 83 | (testing "not even an rtd-record" 84 | (is (thrown-with-msg? 85 | #?(:clj Error :cljs js/Error) 86 | (expected-check-rtd!-throw-error-message 4) 87 | (r/record-check-rtd! ^RecordTypeDescriptor rtd2 4))) 88 | (is (thrown-with-msg? 89 | #?(:clj Error :cljs js/Error) 90 | (expected-check-rtd!-throw-error-message "blub") 91 | (r/record-check-rtd! rtd2 "blub"))) 92 | (is (thrown-with-msg? 93 | #?(:clj Error :cljs js/Error) 94 | (expected-check-rtd!-throw-error-message (->NotRTDRecord 1 2)) 95 | (r/record-check-rtd! rtd2 (->NotRTDRecord 1 2))))) 96 | (testing "wrong rtd-record" 97 | (is (thrown-with-msg? 98 | #?(:clj Error :cljs js/Error) 99 | (expected-check-rtd!-throw-error-message (r/make-record rtd0)) 100 | (r/record-check-rtd! rtd2 (r/make-record rtd0)))) 101 | (is (thrown-with-msg? 102 | #?(:clj Error :cljs js/Error) 103 | (expected-check-rtd!-throw-error-message (r/make-record rtd1)) 104 | (r/record-check-rtd! rtd2 (r/make-record rtd1)))) 105 | (is (thrown-with-msg? 106 | #?(:clj Error :cljs js/Error) 107 | (expected-check-rtd!-throw-error-message (r/make-record rtd2-2)) 108 | (r/record-check-rtd! rtd2 (r/make-record rtd2-2)))) 109 | (is (thrown-with-msg? 110 | #?(:clj Error :cljs js/Error) 111 | (expected-check-rtd!-throw-error-message (r/make-record rtd0-2)) 112 | (r/record-check-rtd! rtd2 (r/make-record rtd0-2))))) 113 | (testing "correct record, shouldnt throw" 114 | (is (nil? (r/record-check-rtd! rtd0 (r/make-record rtd0))))) 115 | (testing "correct record, shouldnt throw" 116 | (is (nil? (r/record-check-rtd! rtd2 (r/make-record rtd2 1 2)))))) 117 | -------------------------------------------------------------------------------- /test/active/clojure/record_spec_test.cljc: -------------------------------------------------------------------------------- 1 | (ns active.clojure.record-spec-test 2 | #?@ 3 | (:clj 4 | [(:require 5 | [active.clojure.lens :as lens] 6 | [active.clojure.record-spec :refer [define-record-type]] 7 | [clojure.spec.alpha :as s] 8 | [clojure.spec.test.alpha :as stest] 9 | [clojure.test :as t])] 10 | :cljs 11 | [(:require 12 | [active.clojure.lens :as lens] 13 | [active.clojure.record-spec :refer-macros [define-record-type]] 14 | [cljs.spec.alpha :as s :include-macros true] 15 | [cljs.spec.test.alpha :as stest :include-macros true] 16 | [cljs.test :as t :include-macros true])])) 17 | 18 | (s/def ::k int?) 19 | (s/def ::v string?) 20 | 21 | (define-record-type kv 22 | (make-kv k v) kv? 23 | [^{:spec ::k} k kv-k 24 | (^{:spec ::v} v kv-v kv-v-lens)]) 25 | 26 | (define-record-type kv-store 27 | (make-kv-store store) kv-store? 28 | [(^{:doc "Set of all kvs stored." 29 | :spec (s/coll-of ::kv :into #{})} 30 | store kv-store-store kv-store-lens)]) 31 | 32 | (defrecord FakeKV [k v]) 33 | 34 | (t/deftest simple-kv-tests 35 | (let [kv-1 (make-kv 1 "foo") 36 | kv-2 (make-kv 2 "bar") 37 | kv-store (make-kv-store #{kv-1 kv-2}) 38 | kv-fake (FakeKV. 1 "foo")] 39 | (t/is (kv? kv-1)) 40 | (t/is (kv? kv-2)) 41 | (t/is (kv-store? kv-store)) 42 | (t/is (= 1 (kv-k kv-1))) 43 | (t/is (= "foo" (kv-v kv-1))) 44 | (t/is (= #{kv-1 kv-2} (kv-store-store kv-store))) 45 | (t/is (not= kv-1 kv-fake)))) 46 | 47 | (t/deftest with-instrumentation 48 | (t/testing "without instrumentation, spec errors are not detected" 49 | (let [kv (make-kv "foo" :bar)] 50 | (t/is (= "foo" (kv-k kv))) 51 | (t/is (= :bar (kv-v kv))))) 52 | #?(:clj 53 | (t/testing "after instrumentation, this throws an error" 54 | (stest/instrument) 55 | (try (make-kv "foo" :bar) 56 | (catch Exception e 57 | (t/is (clojure.string/includes? 58 | (.getMessage e) 59 | "Call to #'active.clojure.record-spec-test/make-kv did not conform to spec"))))))) 60 | 61 | (define-record-type Dith 62 | (make-dith tso) 63 | dith? 64 | [^{:spec string?} tso dith-tso]) 65 | 66 | (define-record-type Xom 67 | (make-xom baz dith) 68 | xom? 69 | [^{:spec integer?} baz xom-baz 70 | ^{:spec ::Dith} dith xom-dith]) 71 | 72 | (t/deftest record-spec-tests 73 | (t/testing "Selector spec validity" 74 | (t/is (s/valid? ::Xom-dith (make-dith "dith"))) 75 | (t/is (not (s/valid? ::Dith-tso 31947)))) 76 | (t/testing "Record spec validity" 77 | (t/is (s/valid? ::Dith (make-dith "some string"))) 78 | (t/is (s/valid? 79 | ::Xom 80 | (make-xom 1000 (make-dith "five")))) 81 | (t/is (not (s/valid? ::Dith (make-dith :a)))) 82 | (t/is (not (s/valid? 83 | ::Xom 84 | (make-xom "wrong" (make-dith "correct"))))) 85 | (t/is (not (s/valid? 86 | ::Xom 87 | (make-xom 23 (make-dith 128))))))) 88 | 89 | ;; taken from record-test 90 | 91 | (define-record-type Pare 92 | (kons a b) 93 | pare? 94 | [a kar 95 | b kdr]) 96 | 97 | (defrecord FakePare [a b]) 98 | 99 | (t/deftest simple 100 | (let [r (kons 1 2)] 101 | (t/is (pare? r)) 102 | (t/is (= 1 (kar r))) 103 | (t/is (= 2 (kdr r))))) 104 | 105 | #?(:clj 106 | (t/deftest unique 107 | (t/is (thrown? Throwable 108 | (kar (FakePare. 1 2)))))) 109 | 110 | (define-record-type Pu 111 | (make-pu c a) 112 | pu? 113 | [a pua 114 | b pub 115 | c puc]) 116 | 117 | (t/deftest constructor 118 | (let [p (make-pu 1 2)] 119 | (t/is (pu? p)) 120 | (t/is (not (pare? p))) 121 | (t/is (= 2 (pua p))) 122 | (t/is (= 1 (puc p))) 123 | (t/is (nil? (pub p))))) 124 | 125 | ;; Records with lenses 126 | 127 | (defn law-1-holds [l data v] 128 | ;; you get back what you put in 129 | (t/is (= v 130 | (lens/yank (lens/shove data l v) l)))) 131 | 132 | (defn law-2-holds [l data] 133 | ;; putting back what you got doesn't change anything 134 | (t/is (= data 135 | (lens/shove data l (lens/yank data l))))) 136 | 137 | (defn law-3-holds [l data v1 v2] 138 | ;; second set wins, or setting once is the same as setting twice 139 | (t/is (= (lens/shove data l v1) 140 | (lens/shove (lens/shove data l v2) l v1)))) 141 | 142 | (defn lens-laws-hold [l data v1 v2] 143 | (and (law-1-holds l data v1) 144 | (law-2-holds l data) 145 | (law-3-holds l data v1 v2))) 146 | 147 | (define-record-type ^{:doc "Lens example"} LensPare 148 | (lens-kons a b) 149 | lens-pare? 150 | [(^{:doc "a field"} a lens-kar lens-kar-lens) 151 | (^{:doc "b field"} b lens-kdr lens-kdr-lens)]) 152 | 153 | (t/deftest pare-lens 154 | (lens-laws-hold lens-kar-lens (lens-kons 1 2) 23 42) 155 | (lens-laws-hold lens-kdr-lens (lens-kons 1 2) 23 42) 156 | (t/is (= (lens-kons "a" 42) 157 | (lens/shove (lens-kons 23 42) lens-kar-lens "a"))) 158 | (t/is (= (lens-kons 23 "b") 159 | (lens/shove (lens-kons 23 42) lens-kdr-lens "b")))) 160 | 161 | (define-record-type Quadruple 162 | (quadruple a b c d) 163 | quadruple? 164 | [(a quadruple-one quadruple-one-lens) 165 | b quadruple-two 166 | (c quadruple-three quadruple-three-lens) 167 | d quadruple-four]) 168 | 169 | (t/deftest quadruple-lens 170 | (lens-laws-hold quadruple-one-lens (quadruple 'a 'b 'c 'd) 12 78) 171 | (lens-laws-hold quadruple-three-lens (quadruple 'a 'b 'c 'd) 12 78) 172 | (t/is (= (quadruple 4 8 15 16) 173 | (lens/shove (quadruple 108 8 15 16) quadruple-one-lens 4)))) 174 | -------------------------------------------------------------------------------- /src/active/clojure/mock_monad.cljc: -------------------------------------------------------------------------------- 1 | (ns active.clojure.mock-monad 2 | "Mock monadic programs" 3 | (:require [active.clojure.monad :as monad] 4 | #?(:clj [active.clojure.record :refer :all]) 5 | #?(:clj [active.clojure.macro :refer [if-cljs]]) 6 | #?(:clj [clojure.test :refer :all]) 7 | #?(:cljs [active.clojure.cljs.record :refer-macros [define-record-type]]) 8 | #?(:cljs [active.clojure.macro :refer-macros [if-cljs]]) 9 | #?(:cljs [cljs.test :refer-macros [is]]))) 10 | 11 | (define-record-type Mock 12 | ^{:doc "Run `(check! m)` a command `m`, then execute `(replace m)` instead. 13 | 14 | `check!` should contain `is` assertions - it's not enough to return a 15 | boolean."} 16 | (mock check! get-result) 17 | mock? 18 | [check! mock-check! 19 | get-result mock-get-result]) 20 | 21 | (defn- mocked-result [mock m] 22 | ((mock-get-result mock) m)) 23 | 24 | (defn- check-mock! [mock m] 25 | ((mock-check! mock) m)) 26 | 27 | (defn- run-mock-commands [run-any env state m] 28 | (let [[mock & r-mocks] (::mocks state)] 29 | (cond 30 | (vector? mock) 31 | (let [[mk & mks] mock] 32 | (check-mock! mk m) 33 | (let [nstate (assoc state ::mocks (concat mks r-mocks))] 34 | (run-any env nstate (mocked-result mk m)))) 35 | 36 | mock 37 | (do (check-mock! mock m) 38 | (let [nstate (assoc state ::mocks r-mocks)] 39 | (run-any env nstate (mocked-result mock m)))) 40 | 41 | :else 42 | (do 43 | (is (= nil (monad/reify-command m)) "Unexpected command after end of mock list.") 44 | monad/unknown-command)))) 45 | 46 | (defn mock-commands [mocks] 47 | (monad/make-monad-command-config 48 | run-mock-commands 49 | {} 50 | {::mocks mocks})) 51 | 52 | ;; clojure-check assertions as a monadic command: 53 | ;; NOTE Don't use this in CLJS 54 | (def check-mocks-empty 55 | (monad/monadic 56 | [mocks (monad/get-state-component ::mocks)] 57 | (let [rmocks (map monad/reify-command mocks)]) 58 | (if-cljs 59 | ;; We must be careful here to call the function version in CLJS 60 | ;; (otherwise, it expands to clojure.test/is and not cljs.test/is) 61 | (monad/return (cljs.test/is (empty? rmocks) "Did not see expected mocked commands.")) 62 | (monad/return (clojure.test/is (empty? rmocks) "Did not see expected mocked commands."))) 63 | (monad/return nil))) 64 | 65 | (defn mock-effect 66 | "If `(= m-expected m)` returns true for a command `m`, then execute `m-replacement` instead." 67 | [m-expected m-replacement] 68 | (mock (fn [m] 69 | (if-cljs 70 | (cljs.test/is (= (monad/reify-command m-expected) 71 | (monad/reify-command m))) 72 | (clojure.test/is (= (monad/reify-command m-expected) 73 | (monad/reify-command m))))) 74 | (constantly m-replacement))) 75 | 76 | (defn mock-result 77 | "If `(= m-expected m)` returns true for a command `m`, then return `value` instead." 78 | [m-expected value] 79 | (mock-effect m-expected (monad/return value))) 80 | 81 | (def mock-ignore 82 | ^{:doc "Replace the next (unhandled) command by `(return nil)`, no matter what it is."} 83 | (mock (constantly nil) (constantly (monad/return nil)))) 84 | 85 | ;; FIXME This should be renamed to `mock-run-monad` 86 | (defn mock-execute-monad 87 | ([mocks m] 88 | (mock-execute-monad (monad/null-monad-command-config {} {}) mocks m)) 89 | ([command-config mocks m] 90 | (monad/run-free-reader-state-exception 91 | (monad/combine-monad-command-configs command-config 92 | (mock-commands mocks)) 93 | (monad/monadic 94 | [res m] 95 | ;; check that mock stack is empty at 'end' 96 | check-mocks-empty 97 | (monad/return res))))) 98 | 99 | ;; FIXME This should be renamed to `mock-execute-monad` 100 | (defn mock-run-monad 101 | "Run m under the given monad command configs, and the given mocked commands, returning the result of m. 102 | `mocks` should be a sequence, whose values can be created by the 103 | `mock`, `mock-result` or `mock-effect` and other functions above, and are 104 | expected to appear in that order while executing `m`." 105 | ([mocks m] 106 | (mock-run-monad (monad/null-monad-command-config {} {}) mocks m)) 107 | ([command-config mocks m] 108 | (first (mock-execute-monad command-config mocks m)))) 109 | 110 | (defn with-mock-run-monad 111 | "Immediately calls f with a function of two arguments, `mocks` and 112 | `m`, which can be repeatedly called to evaluate monadic commands 113 | `m`, with mocked commands like in `test-run-monad`. The monad state 114 | is preserved from call to call. Returns `[result state]`." 115 | [command-config f] 116 | (let [state (atom {})] 117 | (f (fn [mocks m] 118 | (let [st1 @state 119 | [r st2] 120 | (mock-run-monad command-config 121 | mocks 122 | (monad/monadic 123 | (monad/put-state! (assoc st1 ::mocks mocks)) 124 | [r m] 125 | [st2 (monad/get-state)] 126 | (monad/return [r st2])))] 127 | (reset! state st2) 128 | [r st2]))))) 129 | 130 | (defn is-mocked-state 131 | "Takes an `expectation` and the `monad-command-config-state` after running a mock. 132 | Applies `is` to the `=` of both, dissocing the ::mocks from the returned state." 133 | [expectation mock-result-state] 134 | (#?(:clj clojure.test/is :cljs cljs.test/is) 135 | (= expectation (dissoc mock-result-state ::mocks)))) 136 | -------------------------------------------------------------------------------- /src/active/clojure/record_runtime.cljc: -------------------------------------------------------------------------------- 1 | (ns ^:no-doc active.clojure.record-runtime 2 | (:refer-clojure :exclude [record?]) 3 | #?(:cljs (:require-macros [active.clojure.record-runtime :refer [really-make-record record-check-rtd!]])) 4 | #?(:cljs (:require [goog.array]))) 5 | 6 | (defrecord RecordField [name]) 7 | 8 | (defn make-record-field 9 | [name] 10 | (RecordField. name)) 11 | 12 | (defrecord RecordTypeDescriptor [name uid fields]) 13 | 14 | (defn make-record-type-descriptor 15 | [name uid fields] 16 | (RecordTypeDescriptor. name uid (vec fields))) 17 | 18 | (defn record-type-descriptor? 19 | [x] 20 | (instance? RecordTypeDescriptor x)) 21 | 22 | (defn record-type-descriptor-field-index 23 | [^RecordTypeDescriptor rtd name] 24 | (loop [i 0 25 | fields (.-fields rtd)] 26 | (if (empty? fields) 27 | ;; FIXME: more expressive exception 28 | (throw #?(:clj (new Error (str "field " name "not found in rtd " (.-name rtd))) 29 | :cljs (js/Error. (str "field " name "not found in rtd " (.-name rtd))))) 30 | (let [^RecordField field (first fields)] 31 | (if (= (.-name field) name) 32 | i 33 | (recur (inc i) 34 | (rest fields))))))) 35 | 36 | (defn ^:no-doc rtd= [this-rtd other-rtd] 37 | ;; Note: this assures that record-type definitions can be reloaded and still 'work' (non-generative) 38 | #?(:clj (.equals ^RecordTypeDescriptor this-rtd ^RecordTypeDescriptor other-rtd)) 39 | #?(:cljs (= this-rtd other-rtd))) 40 | 41 | (deftype Record 42 | [^RecordTypeDescriptor rtd 43 | ^{:tag #?(:clj "[Ljava.lang.Object;" 44 | :cljs "js/Object")} slots] 45 | #?@(:clj 46 | [java.lang.Object 47 | (equals [this other] 48 | (if (instance? Record other) 49 | (let [this-rtd ^RecordTypeDescriptor (.rtd this) 50 | this-slots ^{:tag "[Ljava.lang.Object;"} (.slots ^Record this) 51 | other-rtd ^RecordTypeDescriptor (.rtd ^Record other) 52 | other-slots ^{:tag "[Ljava.lang.Object;"} (.slots ^Record other)] 53 | (and (rtd= this-rtd other-rtd) 54 | (every? true? (map = this-slots other-slots)))) 55 | false)) ; must be `false`, `nil` is no Java value 56 | 57 | (hashCode [this] 58 | (hash-combine (hash (.rtd this)) 59 | (hash (seq (.slots this))))) 60 | ;; deftype types implement this by default, it seems; better override it: 61 | clojure.lang.IHashEq 62 | (hasheq [this] 63 | (.hashCode this))] 64 | :cljs 65 | [IEquiv 66 | (-equiv [this other] 67 | (if (instance? Record other) 68 | (let [this-rtd ^RecordTypeDescriptor (.-rtd this) 69 | this-slots (.-slots this) 70 | other-rtd ^RecordTypeDescriptor (.-rtd other) 71 | other-slots (.-slots other)] 72 | (and (= ^RecordTypeDescriptor this-rtd ^RecordTypeDescriptor other-rtd) 73 | (.equals goog.array 74 | this-slots 75 | other-slots 76 | -equiv))) 77 | false)) 78 | IHash 79 | (-hash [this] 80 | (hash-combine (hash (.-rtd this)) 81 | (hash (array-seq (.-slots this)))))]) 82 | Object 83 | (toString [^Record this] 84 | (let [rtd (.-rtd this) 85 | rtd-fields (map (comp keyword :name) (seq (:fields rtd))) 86 | rtd-name (:name rtd) 87 | slots (seq (.-slots this))] 88 | (str rtd-name 89 | (into {} (mapv vector rtd-fields slots)))))) 90 | 91 | ;; overriding default printing 92 | #?(:clj 93 | (defmethod clojure.core/print-method Record [^Record rec ^java.io.Writer writer] 94 | (.write writer (str rec))) 95 | :cljs 96 | (extend-protocol IPrintWithWriter 97 | Record 98 | (-pr-writer [rec writer _] 99 | (write-all writer (str rec))))) 100 | 101 | (defmacro really-make-record 102 | [rtd & vs] 103 | (let [a `a#] 104 | `(let [~a (object-array ~(count vs))] 105 | ~@(map-indexed (fn [i v] 106 | `(aset ~a ~i ~v)) 107 | vs) 108 | (Record. ~rtd ~a)))) 109 | 110 | (defn make-record 111 | ([^RecordTypeDescriptor rtd] 112 | (Record. rtd (object-array 0))) 113 | ([^RecordTypeDescriptor rtd v0] 114 | (really-make-record rtd v0)) 115 | ([^RecordTypeDescriptor rtd v0 v1] 116 | (really-make-record rtd v0 v1)) 117 | ([^RecordTypeDescriptor rtd v0 v1 v2] 118 | (really-make-record rtd v0 v1 v2)) 119 | ([^RecordTypeDescriptor rtd v0 v1 v2 v3] 120 | (really-make-record rtd v0 v1 v2 v3)) 121 | ([^RecordTypeDescriptor rtd v0 v1 v2 v3 v4] 122 | (really-make-record rtd v0 v1 v2 v3 v4)) 123 | ([^RecordTypeDescriptor rtd v0 v1 v2 v3 v4 v5] 124 | (really-make-record rtd v0 v1 v2 v3 v4 v5)) 125 | ([^RecordTypeDescriptor rtd v0 v1 v2 v3 v4 v5 v6] 126 | (really-make-record rtd v0 v1 v2 v3 v4 v5 v6)) 127 | ([^RecordTypeDescriptor rtd v0 v1 v2 v3 v4 v5 v6 v7] 128 | (really-make-record rtd v0 v1 v2 v3 v4 v5 v6 v7)) 129 | ([^RecordTypeDescriptor rtd v0 v1 v2 v3 v4 v5 v6 v7 v8] 130 | (really-make-record rtd v0 v1 v2 v3 v4 v5 v6 v7 v8)) 131 | ([^RecordTypeDescriptor rtd v0 v1 v2 v3 v4 v5 v6 v7 v8 v9] 132 | (really-make-record rtd v0 v1 v2 v3 v4 v5 v6 v7 v8 v9)) 133 | ;; FIXME: more 134 | ([^RecordTypeDescriptor rtd v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 & vs] 135 | (let [a (object-array (+ 11 (count vs)))] 136 | (aset a 0 v0) 137 | (aset a 1 v1) 138 | (aset a 2 v2) 139 | (aset a 3 v3) 140 | (aset a 4 v4) 141 | (aset a 5 v5) 142 | (aset a 6 v6) 143 | (aset a 7 v7) 144 | (aset a 8 v8) 145 | (aset a 9 v9) 146 | (aset a 10 v10) 147 | (loop [vs vs 148 | i 11] 149 | (when-not (empty? vs) 150 | (aset a i (first vs)) 151 | (recur (rest vs) (inc i)))) 152 | (Record. rtd a)))) 153 | 154 | (defn record? 155 | [x] 156 | (instance? Record x)) 157 | 158 | (defn record-rtd 159 | [^Record r] 160 | (.-rtd r)) 161 | 162 | (defn record-of-type? 163 | [r ^RecordTypeDescriptor rtd] 164 | (and (record? r) 165 | (rtd= rtd (.-rtd ^Record r)))) 166 | 167 | (defn record-type-predicate [^RecordTypeDescriptor rtd] 168 | (fn [x] 169 | (record-of-type? x rtd))) 170 | 171 | ; assumes that ?r, ?rtd are identifiers alerady 172 | (defmacro record-check-rtd! 173 | "Checks, if a given element is an rtd-record and if that's the case, 174 | if it has the same rtd as the given. 175 | 176 | Note: To prevent reflection warnings, we had to add the record symbol, 177 | which has a type hint attached. 178 | The outer if condition is needed, because primitive types can't be type hinted." 179 | [^RecordTypeDescriptor ?rtd ^Record ?r] 180 | (let [error (if (:ns &env) 181 | `(js/Error. (str "Not a record of the correct type [[" (:name ~?rtd) "]]" ":" (pr-str ~?r))) 182 | `(new Error (str "Not a record of the correct type [[" (:name ~?rtd) "]]" ":" (pr-str ~?r)))) 183 | record (vary-meta (gensym) assoc :tag `Record)] 184 | (if (or (symbol? ?r) (list? ?r)) 185 | `(do 186 | (when-not (and (record? ~?r) 187 | (let [~record ~?r] 188 | (rtd= ~?rtd (.-rtd ~record)))) 189 | (throw ~error))) 190 | `(throw ~error)))) 191 | 192 | (defn record-get 193 | [^RecordTypeDescriptor rtd ^Record r ^long index] 194 | (record-check-rtd! rtd r) 195 | (aget ^{:tag "[Ljava.lang.Object;"} (.-slots r) index)) 196 | 197 | (defn record-update 198 | [^RecordTypeDescriptor rtd ^Record r ^long index v] 199 | (record-check-rtd! rtd r) 200 | (let [slots 201 | (aclone ^{:tag "[Ljava.lang.Object;"} (.-slots r))] 202 | (aset slots index v) 203 | (Record. (.-rtd r) slots))) 204 | 205 | ;; FIXME: lens 206 | ;; FIXME: serialization 207 | -------------------------------------------------------------------------------- /test/active/clojure/sum_type_test.cljc: -------------------------------------------------------------------------------- 1 | (ns active.clojure.sum-type-test 2 | (:require #?(:clj [active.clojure.record :refer (define-record-type)]) 3 | #?(:clj [clojure.test :refer :all]) 4 | [active.clojure.sum-type :as st :include-macros true] 5 | [active.clojure.sum-type-data-test :as data] 6 | #?(:cljs [active.clojure.cljs.record]) 7 | #?(:cljs [cljs.test]) 8 | [clojure.string :as str]) 9 | #?(:cljs 10 | (:require-macros [cljs.test :refer (is deftest run-tests testing)] 11 | [active.clojure.sum-type-test :refer [throws-exception?]] 12 | [active.clojure.cljs.record :refer [define-record-type]]))) 13 | 14 | (define-record-type red 15 | #?(:clj {:java-class? false} 16 | :cljs {:rtd-record? true}) 17 | (make-red saturation) red? 18 | [saturation red-saturation]) 19 | 20 | (define-record-type green 21 | #?(:clj {:java-class? false} 22 | :cljs {:rtd-record? true}) 23 | (make-green saturation) green? 24 | [saturation green-saturation]) 25 | 26 | (define-record-type blue 27 | #?(:clj {:java-class? false} 28 | :cljs {:rtd-record? true}) 29 | (make-blue saturation) blue? 30 | [saturation blue-saturation]) 31 | 32 | 33 | (st/define-sum-type rgb-color rgb-color? [red green blue]) 34 | 35 | 36 | 37 | (def red-inst (make-red 0.4)) 38 | (def green-inst (make-green 1.0)) 39 | (def blue-inst (make-blue 0.2)) 40 | 41 | 42 | (define-record-type ultra-violet 43 | #?(:clj {:java-class? false} 44 | :cljs {:rtd-record? true}) 45 | (make-ultra-violet wave-length) ultra-violet? 46 | [wave-length ultra-violet-wave-length]) 47 | 48 | (define-record-type infra-red 49 | #?(:clj {:java-class? false} 50 | :cljs {:rtd-record? true}) 51 | (make-infra-red wave-length) infra-red? 52 | [wave-length infra-red-wave-length]) 53 | 54 | (def ultra-violet-inst (make-ultra-violet 42)) 55 | (def infra-red-inst (make-infra-red 43)) 56 | 57 | 58 | (st/define-sum-type invisible 59 | invisible? 60 | [ultra-violet infra-red]) 61 | 62 | 63 | (st/define-sum-type all 64 | all? 65 | [rgb-color invisible]) 66 | 67 | 68 | 69 | (deftest sum-type-predicate 70 | (is (rgb-color? red-inst)) 71 | (is (rgb-color? green-inst)) 72 | (is (rgb-color? blue-inst)) 73 | 74 | (is (not (invisible? red-inst))) 75 | (is (not (invisible? green-inst))) 76 | (is (not (invisible? blue-inst))) 77 | 78 | (is (invisible? infra-red-inst)) 79 | (is (invisible? ultra-violet-inst)) 80 | 81 | (is (not (rgb-color? infra-red-inst))) 82 | (is (not (rgb-color? ultra-violet-inst))) 83 | 84 | (is (all? red-inst)) 85 | (is (all? green-inst)) 86 | (is (all? blue-inst)) 87 | (is (all? infra-red-inst)) 88 | (is (all? ultra-violet-inst))) 89 | 90 | 91 | (defn match-rgb [rgb-color-inst] 92 | (st/match rgb-color rgb-color-inst 93 | red? (red-saturation rgb-color-inst) 94 | green? (green-saturation rgb-color-inst) 95 | blue? (blue-saturation rgb-color-inst))) 96 | 97 | (deftest working-matching 98 | (is (= (match-rgb red-inst) 0.4)) 99 | (is (= (match-rgb green-inst) 1.0)) 100 | (is (= (match-rgb blue-inst) 0.2))) 101 | 102 | 103 | (deftest working-matching-default 104 | (letfn [(foo [rgb-color-inst] 105 | (st/match rgb-color rgb-color-inst 106 | red? "Hello" 107 | :default "Bye!"))] 108 | (is (= (foo red-inst) "Hello")) 109 | (is (= (foo blue-inst) "Bye!")))) 110 | 111 | ;; (deftest wrong-argument-type 112 | ;; (is (thrown? Throwable (match-rgb 2)))) 113 | 114 | 115 | (deftest combined-sum-type 116 | 117 | (letfn [(foo [color] 118 | (st/match all color 119 | red? "Visible" 120 | blue? "Visible" 121 | green? "Visible" 122 | infra-red? "Invisible" 123 | ultra-violet? "Invisible"))] 124 | (is (= (foo red-inst) "Visible")) 125 | (is (= (foo blue-inst) "Visible")) 126 | (is (= (foo infra-red-inst) "Invisible"))) 127 | 128 | (letfn [(foo [color] 129 | (st/match all color 130 | red? "Red" 131 | blue? "Blue" 132 | green? "Green" 133 | invisible? "Opaque"))] 134 | (is (= (foo red-inst) "Red")) 135 | (is (= (foo blue-inst) "Blue")) 136 | (is (= (foo infra-red-inst) "Opaque")))) 137 | 138 | 139 | (deftest extractor-tests 140 | (letfn [(desaturate [color] 141 | (st/match all color 142 | (make-red s) (make-red (/ s 2)) 143 | (make-green s) (make-green (/ s 2)) 144 | (make-blue s) (make-blue (/ s 2)) 145 | invisible? color))] 146 | (is (= 6 (red-saturation (desaturate (make-red 12))))) 147 | (is (= 6 (green-saturation (desaturate (make-green 12))))) 148 | (is (= 6 (blue-saturation (desaturate (make-blue 12))))) 149 | (is (= 123 (ultra-violet-wave-length (desaturate (make-ultra-violet 123))))))) 150 | 151 | 152 | (deftest nested-extractor 153 | (letfn [(crazy [color] 154 | (st/match all color 155 | 156 | (make-ultra-violet containing-color) 157 | (st/match rgb-color containing-color 158 | (make-red a) (str "You got red with " a) 159 | (make-blue b) (str "You got blue with " b) 160 | (make-green _) (str "Oh, this is green!")) 161 | 162 | all? 163 | "It wasn rgb in invisible disguise :("))] 164 | 165 | (is (= "You got red with green" (crazy (make-ultra-violet (make-red "green"))))) 166 | (is (= "You got blue with green" (crazy (make-ultra-violet (make-blue "green"))))) 167 | (is (= "Oh, this is green!" (crazy (make-ultra-violet (make-green "green"))))) 168 | (is (= "It wasn rgb in invisible disguise :(" (crazy (make-infra-red 123)))))) 169 | 170 | 171 | (st/define-sum-type forms&colors forms&colors? [data/circle data/square rgb-color]) 172 | 173 | (deftest sum-type-descriptor-test 174 | (is (st/sum-type-descriptor? forms&colors)) 175 | 176 | (is (st/value-of-sum-type? (data/make-square 0 0) forms&colors)) 177 | (is (st/value-of-sum-type? (make-red 0) forms&colors))) 178 | 179 | 180 | (deftest from-other-ns 181 | 182 | (letfn [(form-or-color [foc] 183 | (st/match forms&colors foc 184 | data/circle? "It's a circle!" 185 | (data/make-square a b) (str "It's a square with " a " and " b) 186 | rgb-color? "It's a color!"))] 187 | 188 | (is (= "It's a circle!" (form-or-color (data/make-circle 12)))) 189 | (is (= "It's a square with 12 and 42" (form-or-color (data/make-square 12 42)))) 190 | (is (= "It's a color!" (form-or-color (make-red 42)))))) 191 | 192 | 193 | #?(:clj (defmacro throws-exception? 194 | [msg form] 195 | (try 196 | (eval form) 197 | (catch Exception e 198 | (or 199 | (clojure.string/includes? (str e) msg) 200 | (clojure.string/includes? (.getMessage (.getCause e)) msg)))))) 201 | 202 | 203 | (deftest throws-when-unexhaustive-test 204 | (is (throws-exception? 205 | "Arguments of the following types will fail matching of type `" 206 | (st/match forms&colors foc 207 | data/circle? 12)))) 208 | 209 | 210 | (deftest throws-when-wrong-function-test 211 | (is (throws-exception? 212 | "The following functions don't belong to records or sum-types of type `" 213 | (st/match forms&colors foc 214 | odd? 12))) 215 | 216 | (is (throws-exception? 217 | "The following functions don't belong to records or sum-types of type `" 218 | (st/match forms&colors foc 219 | (odd? a) 12)))) 220 | 221 | 222 | (deftest throws-when-misplaced-default 223 | (is (throws-exception? 224 | "Default clause only allowed as last clause" 225 | (st/match rgb-color red-inst 226 | red? 1 227 | blue? 2 228 | :default 3 229 | green? 4)))) 230 | 231 | (deftest throws-when-uneven-clauses 232 | (is (throws-exception? 233 | "even number of clauses" 234 | (st/match rgb-color red-inst 235 | red? 1 236 | blue? 2 237 | 3)))) 238 | 239 | (deftest throws-when-no-symbol 240 | (is (throws-exception? 241 | "must be a symbol" 242 | (st/match 12 red-inst 243 | red? 1 244 | blue? 2 245 | 3)))) 246 | 247 | (deftest throws-when-no-sum-type 248 | (let [a 12] 249 | (is (throws-exception? 250 | "is no sum-type" 251 | (st/match a red-inst 252 | red? 1 253 | blue? 2))))) 254 | 255 | 256 | (deftest throws-when-argument-wrong-type 257 | (is (thrown? 258 | #?(:cljs js/Object 259 | :clj IllegalArgumentException) 260 | (match-rgb 12)))) 261 | 262 | 263 | (define-record-type chaotic 264 | #?(:clj {:java-class? false} 265 | :cljs {:rtd-record? true}) 266 | (make-chaotic a b) chaotic? 267 | [b chaotic-b 268 | a chaotic-a]) 269 | 270 | (st/define-sum-type chaotics chaotics? [chaotic]) 271 | 272 | 273 | (deftest extracts-differently-ordered-args 274 | (letfn [(cm [a] 275 | (st/match chaotics a 276 | (make-chaotic a _) a))] 277 | (is (= 1 (cm (make-chaotic 1 2)))))) 278 | -------------------------------------------------------------------------------- /src/active/clojure/functions.cljc: -------------------------------------------------------------------------------- 1 | (ns active.clojure.functions 2 | "Redefines higher order functions and function combinators from 3 | clojure.core via applicable records (ifn? but not fn?). The 4 | advantage is, that those objects compare = if they are created from 5 | equal arguments. Disadvantages are that they are probably a bit 6 | slower. They also don't implement some additional protocols like 7 | Runnable yet." 8 | (:refer-clojure :exclude [partial constantly comp complement juxt fnil every-pred some-fn bound-fn* 9 | completing])) 10 | 11 | #?(:cljs 12 | (defrecord ^:no-doc Partial [f_ args] 13 | IFn 14 | (-invoke [this] (apply f_ args)) 15 | (-invoke [this a] (apply f_ (concat args (list a)))) 16 | (-invoke [this a b] (apply f_ (concat args (list a b)))) 17 | (-invoke [this a b c] (apply f_ (concat args (list a b c)))) 18 | (-invoke [this a b c d] (apply f_ (concat args (list a b c d)))) 19 | (-invoke [this a b c d e] (apply f_ (concat args (list a b c d e)))) 20 | (-invoke [this a b c d e f] (apply f_ (concat args (list a b c d e f)))) 21 | (-invoke [this a b c d e f g] (apply f_ (concat args (list a b c d e f g)))) 22 | (-invoke [this a b c d e f g h] (apply f_ (concat args (list a b c d e f g h)))) 23 | (-invoke [this a b c d e f g h i] (apply f_ (concat args (list a b c d e f g h i)))) 24 | (-invoke [this a b c d e f g h i j] (apply f_ (concat args (list a b c d e f g h i j)))) 25 | (-invoke [this a b c d e f g h i j k] (apply f_ (concat args (list a b c d e f g h i j k)))) 26 | (-invoke [this a b c d e f g h i j k l] (apply f_ (concat args (list a b c d e f g h i j k l)))) 27 | (-invoke [this a b c d e f g h i j k l m] (apply f_ (concat args (list a b c d e f g h i j k l m)))) 28 | (-invoke [this a b c d e f g h i j k l m n] (apply f_ (concat args (list a b c d e f g h i j k l m n)))) 29 | (-invoke [this a b c d e f g h i j k l m n o] (apply f_ (concat args (list a b c d e f g h i j k l m n o)))) 30 | (-invoke [this a b c d e f g h i j k l m n o p] (apply f_ (concat args (list a b c d e f g h i j k l m n o p)))) 31 | (-invoke [this a b c d e f g h i j k l m n o p q] (apply f_ (concat args (list a b c d e f g h i j k l m n o p q)))) 32 | (-invoke [this a b c d e f g h i j k l m n o p q r] (apply f_ (concat args (list a b c d e f g h i j k l m n o p q r)))) 33 | (-invoke [this a b c d e f g h i j k l m n o p q r s] (apply f_ (concat args (list a b c d e f g h i j k l m n o p q r s)))) 34 | (-invoke [this a b c d e f g h i j k l m n o p q r s t] (apply f_ (concat args (list a b c d e f g h i j k l m n o p q r s t)))) 35 | (-invoke [this a b c d e f g h i j k l m n o p q r s t rest] (apply f_ (concat args (list a b c d e f g h i j k l m n o p q r s t) rest))))) 36 | 37 | #?(:clj 38 | (defrecord ^:no-doc Partial [f_ args] 39 | clojure.lang.IFn 40 | (applyTo [this arglist] (apply f_ (concat args arglist))) 41 | (invoke [this] (apply f_ args)) 42 | (invoke [this a] (apply f_ (concat args (list a)))) 43 | (invoke [this a b] (apply f_ (concat args (list a b)))) 44 | (invoke [this a b c] (apply f_ (concat args (list a b c)))) 45 | (invoke [this a b c d] (apply f_ (concat args (list a b c d)))) 46 | (invoke [this a b c d e] (apply f_ (concat args (list a b c d e)))) 47 | (invoke [this a b c d e f] (apply f_ (concat args (list a b c d e f)))) 48 | (invoke [this a b c d e f g] (apply f_ (concat args (list a b c d e f g)))) 49 | (invoke [this a b c d e f g h] (apply f_ (concat args (list a b c d e f g h)))) 50 | (invoke [this a b c d e f g h i] (apply f_ (concat args (list a b c d e f g h i)))) 51 | (invoke [this a b c d e f g h i j] (apply f_ (concat args (list a b c d e f g h i j)))) 52 | (invoke [this a b c d e f g h i j k] (apply f_ (concat args (list a b c d e f g h i j k)))) 53 | (invoke [this a b c d e f g h i j k l] (apply f_ (concat args (list a b c d e f g h i j k l)))) 54 | (invoke [this a b c d e f g h i j k l m] (apply f_ (concat args (list a b c d e f g h i j k l m)))) 55 | (invoke [this a b c d e f g h i j k l m n] (apply f_ (concat args (list a b c d e f g h i j k l m n)))) 56 | (invoke [this a b c d e f g h i j k l m n o] (apply f_ (concat args (list a b c d e f g h i j k l m n o)))) 57 | (invoke [this a b c d e f g h i j k l m n o p] (apply f_ (concat args (list a b c d e f g h i j k l m n o p)))) 58 | (invoke [this a b c d e f g h i j k l m n o p q] (apply f_ (concat args (list a b c d e f g h i j k l m n o p q)))) 59 | (invoke [this a b c d e f g h i j k l m n o p q r] (apply f_ (concat args (list a b c d e f g h i j k l m n o p q r)))) 60 | (invoke [this a b c d e f g h i j k l m n o p q r s] (apply f_ (concat args (list a b c d e f g h i j k l m n o p q r s)))) 61 | (invoke [this a b c d e f g h i j k l m n o p q r s t] (apply f_ (concat args (list a b c d e f g h i j k l m n o p q r s t)))))) 62 | 63 | 64 | (defn partial 65 | "Takes a function f and fewer than the normal arguments to f, and 66 | returns a fn that takes a variable number of additional args. When 67 | called, the returned function calls f with args + additional args." 68 | [f & args] 69 | (Partial. f args)) 70 | 71 | (letfn [(_lift-variadic [f fargs & args] 72 | (apply (apply f fargs) args))] 73 | ;; Note: this is most easiest way to lift a higher-order fn f, but often not the most efficient 74 | (defn lift-variadic [f & fargs] 75 | (partial _lift-variadic f fargs))) 76 | 77 | (letfn [(_constantly [v & args] 78 | v)] 79 | (defn constantly 80 | "Returns a function that takes any number of arguments and returns x." 81 | [v] 82 | (partial _constantly v))) 83 | 84 | (defn comp 85 | "Takes a set of functions and returns a fn that is the composition 86 | of those fns. The returned fn takes a variable number of args, 87 | applies the rightmost of fns to the args, the next 88 | fn (right-to-left) to the result, etc." 89 | ([] identity) 90 | ([f] f) 91 | ([f g & fs] 92 | (apply lift-variadic clojure.core/comp f g fs))) 93 | 94 | (defn complement 95 | "Takes a fn f and returns a fn that takes the same arguments as f, 96 | has the same effects, if any, and returns the opposite truth value." 97 | [f] 98 | (lift-variadic clojure.core/complement f)) 99 | 100 | (defn juxt 101 | "Takes a set of functions and returns a fn that is the juxtaposition 102 | of those fns. The returned fn takes a variable number of args, and 103 | returns a vector containing the result of applying each fn to the 104 | args (left-to-right). 105 | ((juxt a b c) x) => [(a x) (b x) (c x)]" 106 | [f & fns] 107 | (apply lift-variadic clojure.core/juxt f fns)) 108 | 109 | (defn fnil 110 | "Takes a function f, and returns a function that calls f, replacing 111 | a nil first argument to f with the supplied value x. Higher arity 112 | versions can replace arguments in the second and third 113 | positions (y, z). Note that the function f can take any number of 114 | arguments, not just the one(s) being nil-patched." 115 | ([f x] (lift-variadic clojure.core/fnil f x)) 116 | ([f x y] (lift-variadic clojure.core/fnil f x y)) 117 | ([f x y z] (lift-variadic clojure.core/fnil f x y z))) 118 | 119 | (defn every-pred 120 | "Takes a set of predicates and returns a function f that returns true if all of its 121 | composing predicates return a logical true value against all of its arguments, else it returns 122 | false. Note that f is short-circuiting in that it will stop execution on the first 123 | argument that triggers a logical false result against the original predicates." 124 | [p & ps] 125 | (apply lift-variadic clojure.core/every-pred p ps)) 126 | 127 | 128 | (defn some-fn 129 | "Takes a set of predicates and returns a function f that returns the first logical true value 130 | returned by one of its composing predicates against any of its arguments, else it returns 131 | logical false. Note that f is short-circuiting in that it will stop execution on the first 132 | argument that triggers a logical true result against the original predicates." 133 | [p & ps] 134 | (apply lift-variadic clojure.core/some-fn p ps)) 135 | 136 | #?(:clj 137 | (letfn [(_bound-fn* [bindings f & args] 138 | (apply with-bindings* bindings f args))] 139 | (defn bound-fn* 140 | "Returns a function, which will install the same bindings in effect as in 141 | the thread at the time bound-fn* was called and then call f with any given 142 | arguments. This may be used to define a helper function which runs on a 143 | different thread, but needs the same bindings in place." 144 | [f] 145 | ;; Note: this cannot be done with lift-variadic, because 146 | ;; get-thread-bindings is side-effectful, and has to be called 147 | ;; now, not later. 148 | (let [bindings (get-thread-bindings)] 149 | (partial _bound-fn* bindings f))))) 150 | 151 | (defn completing 152 | "Takes a reducing function f of 2 args and returns a fn suitable for 153 | transduce by adding an arity-1 signature that calls cf (default - 154 | identity) on the result argument." 155 | ([f] (completing f identity)) 156 | ([f cf] (lift-variadic clojure.core/completing f cf))) 157 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE PUBLIC 2 | LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF THE PROGRAM 3 | CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. 4 | 5 | 1. DEFINITIONS 6 | 7 | "Contribution" means: 8 | 9 | a) in the case of the initial Contributor, the initial code and 10 | documentation distributed under this Agreement, and 11 | 12 | b) in the case of each subsequent Contributor: 13 | 14 | i) changes to the Program, and 15 | 16 | ii) additions to the Program; 17 | 18 | where such changes and/or additions to the Program originate from and are 19 | distributed by that particular Contributor. A Contribution 'originates' from 20 | a Contributor if it was added to the Program by such Contributor itself or 21 | anyone acting on such Contributor's behalf. Contributions do not include 22 | additions to the Program which: (i) are separate modules of software 23 | distributed in conjunction with the Program under their own license 24 | agreement, and (ii) are not derivative works of the Program. 25 | 26 | "Contributor" means any person or entity that distributes the Program. 27 | 28 | "Licensed Patents" mean patent claims licensable by a Contributor which are 29 | necessarily infringed by the use or sale of its Contribution alone or when 30 | combined with the Program. 31 | 32 | "Program" means the Contributions distributed in accordance with this 33 | Agreement. 34 | 35 | "Recipient" means anyone who receives the Program under this Agreement, 36 | including all Contributors. 37 | 38 | 2. GRANT OF RIGHTS 39 | 40 | a) Subject to the terms of this Agreement, each Contributor hereby grants 41 | Recipient a non-exclusive, worldwide, royalty-free copyright license to 42 | reproduce, prepare derivative works of, publicly display, publicly perform, 43 | distribute and sublicense the Contribution of such Contributor, if any, and 44 | such derivative works, in source code and object code form. 45 | 46 | b) Subject to the terms of this Agreement, each Contributor hereby grants 47 | Recipient a non-exclusive, worldwide, royalty-free patent license under 48 | Licensed Patents to make, use, sell, offer to sell, import and otherwise 49 | transfer the Contribution of such Contributor, if any, in source code and 50 | object code form. This patent license shall apply to the combination of the 51 | Contribution and the Program if, at the time the Contribution is added by the 52 | Contributor, such addition of the Contribution causes such combination to be 53 | covered by the Licensed Patents. The patent license shall not apply to any 54 | other combinations which include the Contribution. No hardware per se is 55 | licensed hereunder. 56 | 57 | c) Recipient understands that although each Contributor grants the licenses 58 | to its Contributions set forth herein, no assurances are provided by any 59 | Contributor that the Program does not infringe the patent or other 60 | intellectual property rights of any other entity. Each Contributor disclaims 61 | any liability to Recipient for claims brought by any other entity based on 62 | infringement of intellectual property rights or otherwise. As a condition to 63 | exercising the rights and licenses granted hereunder, each Recipient hereby 64 | assumes sole responsibility to secure any other intellectual property rights 65 | needed, if any. For example, if a third party patent license is required to 66 | allow Recipient to distribute the Program, it is Recipient's responsibility 67 | to acquire that license before distributing the Program. 68 | 69 | d) Each Contributor represents that to its knowledge it has sufficient 70 | copyright rights in its Contribution, if any, to grant the copyright license 71 | set forth in this Agreement. 72 | 73 | 3. REQUIREMENTS 74 | 75 | A Contributor may choose to distribute the Program in object code form under 76 | its own license agreement, provided that: 77 | 78 | a) it complies with the terms and conditions of this Agreement; and 79 | 80 | b) its license agreement: 81 | 82 | i) effectively disclaims on behalf of all Contributors all warranties and 83 | conditions, express and implied, including warranties or conditions of title 84 | and non-infringement, and implied warranties or conditions of merchantability 85 | and fitness for a particular purpose; 86 | 87 | ii) effectively excludes on behalf of all Contributors all liability for 88 | damages, including direct, indirect, special, incidental and consequential 89 | damages, such as lost profits; 90 | 91 | iii) states that any provisions which differ from this Agreement are offered 92 | by that Contributor alone and not by any other party; and 93 | 94 | iv) states that source code for the Program is available from such 95 | Contributor, and informs licensees how to obtain it in a reasonable manner on 96 | or through a medium customarily used for software exchange. 97 | 98 | When the Program is made available in source code form: 99 | 100 | a) it must be made available under this Agreement; and 101 | 102 | b) a copy of this Agreement must be included with each copy of the Program. 103 | 104 | Contributors may not remove or alter any copyright notices contained within 105 | the Program. 106 | 107 | Each Contributor must identify itself as the originator of its Contribution, 108 | if any, in a manner that reasonably allows subsequent Recipients to identify 109 | the originator of the Contribution. 110 | 111 | 4. COMMERCIAL DISTRIBUTION 112 | 113 | Commercial distributors of software may accept certain responsibilities with 114 | respect to end users, business partners and the like. While this license is 115 | intended to facilitate the commercial use of the Program, the Contributor who 116 | includes the Program in a commercial product offering should do so in a 117 | manner which does not create potential liability for other Contributors. 118 | Therefore, if a Contributor includes the Program in a commercial product 119 | offering, such Contributor ("Commercial Contributor") hereby agrees to defend 120 | and indemnify every other Contributor ("Indemnified Contributor") against any 121 | losses, damages and costs (collectively "Losses") arising from claims, 122 | lawsuits and other legal actions brought by a third party against the 123 | Indemnified Contributor to the extent caused by the acts or omissions of such 124 | Commercial Contributor in connection with its distribution of the Program in 125 | a commercial product offering. The obligations in this section do not apply 126 | to any claims or Losses relating to any actual or alleged intellectual 127 | property infringement. In order to qualify, an Indemnified Contributor must: 128 | a) promptly notify the Commercial Contributor in writing of such claim, and 129 | b) allow the Commercial Contributor tocontrol, and cooperate with the 130 | Commercial Contributor in, the defense and any related settlement 131 | negotiations. The Indemnified Contributor may participate in any such claim 132 | at its own expense. 133 | 134 | For example, a Contributor might include the Program in a commercial product 135 | offering, Product X. That Contributor is then a Commercial Contributor. If 136 | that Commercial Contributor then makes performance claims, or offers 137 | warranties related to Product X, those performance claims and warranties are 138 | such Commercial Contributor's responsibility alone. Under this section, the 139 | Commercial Contributor would have to defend claims against the other 140 | Contributors related to those performance claims and warranties, and if a 141 | court requires any other Contributor to pay any damages as a result, the 142 | Commercial Contributor must pay those damages. 143 | 144 | 5. NO WARRANTY 145 | 146 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS PROVIDED ON 147 | AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER 148 | EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR 149 | CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A 150 | PARTICULAR PURPOSE. Each Recipient is solely responsible for determining the 151 | appropriateness of using and distributing the Program and assumes all risks 152 | associated with its exercise of rights under this Agreement , including but 153 | not limited to the risks and costs of program errors, compliance with 154 | applicable laws, damage to or loss of data, programs or equipment, and 155 | unavailability or interruption of operations. 156 | 157 | 6. DISCLAIMER OF LIABILITY 158 | 159 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR ANY 160 | CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, 161 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION 162 | LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 163 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 164 | ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE 165 | EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY 166 | OF SUCH DAMAGES. 167 | 168 | 7. GENERAL 169 | 170 | If any provision of this Agreement is invalid or unenforceable under 171 | applicable law, it shall not affect the validity or enforceability of the 172 | remainder of the terms of this Agreement, and without further action by the 173 | parties hereto, such provision shall be reformed to the minimum extent 174 | necessary to make such provision valid and enforceable. 175 | 176 | If Recipient institutes patent litigation against any entity (including a 177 | cross-claim or counterclaim in a lawsuit) alleging that the Program itself 178 | (excluding combinations of the Program with other software or hardware) 179 | infringes such Recipient's patent(s), then such Recipient's rights granted 180 | under Section 2(b) shall terminate as of the date such litigation is filed. 181 | 182 | All Recipient's rights under this Agreement shall terminate if it fails to 183 | comply with any of the material terms or conditions of this Agreement and 184 | does not cure such failure in a reasonable period of time after becoming 185 | aware of such noncompliance. If all Recipient's rights under this Agreement 186 | terminate, Recipient agrees to cease use and distribution of the Program as 187 | soon as reasonably practicable. However, Recipient's obligations under this 188 | Agreement and any licenses granted by Recipient relating to the Program shall 189 | continue and survive. 190 | 191 | Everyone is permitted to copy and distribute copies of this Agreement, but in 192 | order to avoid inconsistency the Agreement is copyrighted and may only be 193 | modified in the following manner. The Agreement Steward reserves the right to 194 | publish new versions (including revisions) of this Agreement from time to 195 | time. No one other than the Agreement Steward has the right to modify this 196 | Agreement. The Eclipse Foundation is the initial Agreement Steward. The 197 | Eclipse Foundation may assign the responsibility to serve as the Agreement 198 | Steward to a suitable separate entity. Each new version of the Agreement will 199 | be given a distinguishing version number. The Program (including 200 | Contributions) may always be distributed subject to the version of the 201 | Agreement under which it was received. In addition, after a new version of 202 | the Agreement is published, Contributor may elect to distribute the Program 203 | (including its Contributions) under the new version. Except as expressly 204 | stated in Sections 2(a) and 2(b) above, Recipient receives no rights or 205 | licenses to the intellectual property of any Contributor under this 206 | Agreement, whether expressly, by implication, estoppel or otherwise. All 207 | rights in the Program not expressly granted under this Agreement are 208 | reserved. 209 | 210 | This Agreement is governed by the laws of the State of New York and the 211 | intellectual property laws of the United States of America. No party to this 212 | Agreement will bring a legal action under this Agreement more than one year 213 | after the cause of action arose. Each party waives its rights to a jury trial 214 | in any resulting litigation. 215 | -------------------------------------------------------------------------------- /src/active/clojure/record_spec.cljc: -------------------------------------------------------------------------------- 1 | (ns active.clojure.record-spec 2 | "A re-implementation of `active.clojure.record` that makes use of 3 | Clojure's new spec library. Define records the same ways as in the old 4 | implementation or use the new syntax to automatically generate specs. 5 | If a field has no explicit spec, defaults to `any?`." 6 | #?@ 7 | (:clj 8 | [(:require 9 | [active.clojure.condition :as c] 10 | [active.clojure.lens :as lens] 11 | [active.clojure.macro :refer [if-cljs]] 12 | [clojure.spec.alpha :as s] 13 | [clojure.spec.gen.alpha :as gen])] 14 | :cljs 15 | [(:require 16 | [active.clojure.condition :as c] 17 | [cljs.spec.alpha :as s :include-macros true] 18 | [cljs.spec.gen.alpha :as gen :include-macros true] 19 | [clojure.set :as set]) 20 | (:require-macros [active.clojure.macro :refer [if-cljs]])])) 21 | 22 | (defn throw-illegal-argument-exception 23 | [msg] 24 | (c/assertion-violation `throw-illegal-argument-exception "Illegal argument" msg)) 25 | 26 | ;; Only needed in ClojureScript, does nothing in Clojure 27 | (defn check-type 28 | [type rec] 29 | #?(:clj (do)) 30 | #?(:cljs 31 | (when-not (instance? type rec) 32 | (throw (js/Error. (str "Wrong record type passed to accessor." rec type)))))) 33 | 34 | (defn ns-keyword 35 | "Takes a symbol or string `the-name-sym` and returns a namespaced keyword 36 | based on that symbol. 37 | 38 | Example: `(ns-keyword 'foo) => :calling.name.space/foo`" 39 | [the-name-sym] 40 | (if the-name-sym 41 | (keyword (str (ns-name *ns*)) (str the-name-sym)) 42 | (c/assertion-violation `ns-keyword "argument must not be nil" the-name-sym))) 43 | 44 | (defmacro s-def 45 | [& args] 46 | `(if-cljs (cljs.spec.alpha/def ~@args) 47 | (clojure.spec.alpha/def ~@args))) 48 | 49 | (s-def :active.clojure.record-spec/pass (constantly true)) 50 | 51 | (defmacro s-fdef 52 | [& args] 53 | `(if-cljs (cljs.spec.alpha/fdef ~@args) 54 | (clojure.spec.alpha/fdef ~@args))) 55 | 56 | (defmacro s-and 57 | [& args] 58 | `(if-cljs (cljs.spec.alpha/and ~@args) 59 | (clojure.spec.alpha/and ~@args))) 60 | 61 | (defmacro s-cat 62 | [& args] 63 | `(if-cljs (cljs.spec.alpha/cat ~@args) 64 | (clojure.spec.alpha/cat ~@args))) 65 | 66 | (defmacro s-spec 67 | [& args] 68 | `(if-cljs (cljs.spec.alpha/spec ~@args) 69 | (clojure.spec.alpha/spec ~@args))) 70 | 71 | (defmacro s-keys 72 | [& args] 73 | `(if-cljs (cljs.spec.alpha/keys ~@args) 74 | (clojure.spec.alpha/keys ~@args))) 75 | 76 | (defmacro s-gen 77 | [& args] 78 | `(if-cljs (cljs.spec.alpha/gen ~@args) 79 | (clojure.spec.alpha/gen ~@args))) 80 | 81 | (defmacro s-fmap 82 | [& args] 83 | `(if-cljs (cljs.spec.gen.alpha/fmap ~@args) 84 | (clojure.spec.gen.alpha/fmap ~@args))) 85 | 86 | (defmacro s-valid? 87 | [& args] 88 | `(if-cljs (cljs.spec.alpha/valid? ~@args) 89 | (clojure.spec.alpha/valid? ~@args))) 90 | 91 | #?(:clj 92 | (defmacro define-record-type 93 | "Attach doc properties to the type and the field names to get reasonable docstrings." 94 | [?type ?constructor-call ?predicate ?field-specs & ?opt+specs] 95 | (when-not (and (list? ?constructor-call) 96 | (not (empty? ?constructor-call))) 97 | (throw-illegal-argument-exception (str "constructor call must be a list in " *ns* " " (meta &form)))) 98 | (when-not (vector? ?field-specs) 99 | (throw-illegal-argument-exception (str "field specs must be a vector in " *ns* " " (meta &form)))) 100 | (when-not (even? (count (remove seq? ?field-specs))) 101 | (throw-illegal-argument-exception (str "odd number of elements in field specs in " *ns* " " (meta &form)))) 102 | (when-not (every? true? (map #(= 3 (count %)) (filter seq? ?field-specs))) 103 | (throw-illegal-argument-exception (str "wrong number of elements in field specs with lens in " *ns* " " (meta &form)))) 104 | (let [?field-triples (loop [specs (seq ?field-specs) 105 | triples '()] 106 | (if (empty? specs) 107 | (reverse triples) 108 | (let [spec (first specs)] 109 | 110 | (cond 111 | (list? spec) 112 | (do 113 | (when-not (and (= 3 (count spec)) 114 | (every? symbol spec)) 115 | (IllegalArgumentException. (str "invalid field spec " spec " in " *ns* " " (meta &form)))) 116 | (recur (rest specs) (list* spec triples))) 117 | 118 | (symbol? spec) 119 | (do 120 | (when (empty? (rest specs)) 121 | (throw (IllegalArgumentException. (str "incomplete field spec for " spec " in " *ns* " " (meta &form))))) 122 | (when-not (symbol? (fnext specs)) 123 | (throw (IllegalArgumentException. (str "invalid accessor " (fnext specs) " for " spec " in " *ns* " " (meta &form))))) 124 | (recur (nnext specs) 125 | (list* [spec (fnext specs) nil] triples))) 126 | 127 | :else 128 | (throw (IllegalArgumentException. (str "invalid field spec " spec " in " *ns* " " (meta &form)))))))) 129 | ?constructor (first ?constructor-call) 130 | ?constructor-args (rest ?constructor-call) 131 | ?constructor-args-set (set ?constructor-args) 132 | document (fn [n doc] 133 | (vary-meta n 134 | (fn [m] 135 | (if (contains? m :doc) 136 | m 137 | (assoc m :doc doc))))) 138 | document-with-arglist (fn [n arglist doc] 139 | (vary-meta n 140 | (fn [m] 141 | (let [m (if (contains? m :doc) 142 | m 143 | (assoc m :doc doc))] 144 | (if (contains? m :arglists) 145 | m 146 | (assoc m :arglists `'(~arglist))))))) 147 | name-doc (fn [field] 148 | (if-let [doc (:doc (meta field))] 149 | (str " (" doc ")") 150 | "")) 151 | 152 | ?field-names (map first ?field-triples) 153 | reference (fn [name] 154 | (str "[[" (ns-name *ns*) "/" name "]]")) 155 | ?docref (str "See " (reference ?constructor) ".")] 156 | (let [?field-names-set (set ?field-names)] 157 | (doseq [?constructor-arg ?constructor-args] 158 | (when-not (contains? ?field-names-set ?constructor-arg) 159 | (throw-illegal-argument-exception (str "constructor argument " ?constructor-arg " is not a field in " *ns* " " (meta &form)))))) 160 | `(do 161 | (defrecord ~?type 162 | [~@(map first ?field-triples)] 163 | ~@?opt+specs) 164 | (def ~(document-with-arglist ?predicate '[thing] (str "Is object a `" ?type "` record? " ?docref)) 165 | (fn [x#] 166 | (instance? ~?type x#))) 167 | (def ~(document-with-arglist ?constructor 168 | (vec ?constructor-args) 169 | (str "Construct a `" ?type "`" 170 | (name-doc ?type) 171 | " record.\n" 172 | (apply str 173 | (map (fn [[?field ?accessor ?lens]] 174 | (str "\n`" ?field "`" (name-doc ?field) ": access via " (reference ?accessor) 175 | (if ?lens 176 | (str ", lens " (reference ?lens)) 177 | ""))) 178 | ?field-triples)))) 179 | (fn [~@?constructor-args] 180 | (new ~?type 181 | ~@(map (fn [[?field _]] 182 | (if (contains? ?constructor-args-set ?field) 183 | `~?field 184 | `nil)) 185 | ?field-triples)))) 186 | (declare ~@(map (fn [[?field ?accessor ?lens]] ?accessor) ?field-triples)) 187 | ~@(mapcat (fn [[?field ?accessor ?lens]] 188 | (let [?rec (with-meta `rec# {:tag ?type})] 189 | `((def ~(document-with-arglist ?accessor (vector ?type) (str "Access `" ?field "` field" 190 | (name-doc ?field) 191 | " from a [[" ?type "]] record. " ?docref)) 192 | (fn [~?rec] 193 | (check-type ~?type ~?rec) 194 | (. ~?rec ~(symbol (str "-" ?field))))) 195 | ~@(if ?lens 196 | (let [?data `data# 197 | ?v `v#] 198 | `((def ~(document ?lens (str "Lens for the `" ?field "` field" 199 | (name-doc ?field) 200 | " from a [[" ?type "]] record." ?docref)) 201 | (lens/lens ~?accessor 202 | (fn [~?data ~?v] 203 | (~?constructor ~@(map 204 | (fn [[?shove-field ?shove-accessor]] 205 | (if (= ?field ?shove-field) 206 | ?v 207 | `(~?shove-accessor ~?data))) 208 | ?field-triples))))))))))) 209 | ?field-triples) 210 | ;; specs 211 | ~(letfn [(spec-or-true [?field] 212 | (or (:spec (meta ?field)) '(constantly true)))] 213 | (let [?field-specs (mapv (fn [[?field _ _]] (ns-keyword (str ?type "-" ?field))) ?field-triples)] 214 | ;; Generate a spec for each constructor arg. Uses each constructor arg and prepends the type name + "-" as the name. 215 | `(do 216 | ~@(mapv (fn [[?field _ _] ?field-spec] 217 | `(s-def ~?field-spec ~(spec-or-true ?field))) 218 | ?field-triples ?field-specs) 219 | (s-def ~(ns-keyword ?type) 220 | (s-spec 221 | (s-and ~?predicate 222 | ~@(mapv (fn [[?field ?accessor _] ?field-spec] 223 | `#(s-valid? ~?field-spec (~?accessor %))) 224 | ?field-triples ?field-specs)) 225 | :gen (fn [] 226 | (->> (s-gen (s-keys :req [~@(map #(ns-keyword (str ?type "-" %)) 227 | ?constructor-args)])) 228 | (s-fmap (fn [ks#] 229 | (~(symbol (str "map->" ?type)) 230 | (clojure.set/rename-keys 231 | ks# 232 | ~(into {} (for [constructor-arg ?constructor-args] 233 | [(ns-keyword (str ?type "-" constructor-arg)) 234 | (keyword constructor-arg)])))))))))) 235 | (s-fdef ~?constructor 236 | :args (s-cat 237 | ~@(apply concat 238 | (for [[?field ?spec] (map (fn [constructor-arg] 239 | (let [field (first (filter #(= constructor-arg %) (map first ?field-triples)))] 240 | [field (spec-or-true field)])) 241 | ?constructor-args)] 242 | [(keyword ?field) ?spec]))) 243 | :ret ~(ns-keyword ?type)) 244 | ~@(mapv (fn [[?field ?accessor _]] 245 | `(s-fdef ~?accessor 246 | :args (s-cat ~(keyword ?type) ~(ns-keyword ?type)) 247 | :ret ~(spec-or-true ?field))) 248 | ?field-triples)))))))) 249 | -------------------------------------------------------------------------------- /test/active/clojure/validation_test.cljc: -------------------------------------------------------------------------------- 1 | (ns active.clojure.validation-test 2 | (:require #?(:clj [active.clojure.record :refer [define-record-type]] 3 | :cljs [active.clojure.cljs.record :refer-macros [define-record-type]]) 4 | #?(:clj [clojure.test :as t] 5 | :cljs [cljs.test :as t :include-macros true]) 6 | [active.clojure.validation :as v])) 7 | 8 | (t/deftest fmap-success-test 9 | (let [failure (v/make-validation-failure 10 | [(v/make-validation-error "candidate" "message" nil)]) 11 | success (v/make-validation-success "candidate")] 12 | (t/is (= failure (v/fmap-success clojure.string/upper-case failure))) 13 | (t/is (= (v/make-validation-success "CANDIDATE") 14 | (v/fmap-success clojure.string/upper-case success))))) 15 | 16 | (t/deftest fmap-result-test 17 | (letfn [(f [validation-result] 18 | (v/fmap-result str (fn [error] (v/validation-error-label error :new-label)) validation-result))] 19 | (t/is (= (v/make-validation-success "42") (f (v/validate-pos-int 42)))) 20 | (t/is (= (v/make-validation-failure [(v/make-validation-error -23 ::v/pos-int :new-label)]) 21 | (f (v/validate-pos-int -23)))))) 22 | 23 | (t/deftest seq-validation-test 24 | (let [failure (v/make-validation-failure 25 | [(v/make-validation-error "candidate" "message" nil)]) 26 | failure-2 (v/make-validation-failure 27 | [(v/make-validation-error "candidate-2" "message-2" nil)]) 28 | flat-success (v/make-validation-success "candidate")] 29 | (t/testing "failures are concatenated" 30 | (t/is (= (v/make-validation-failure 31 | [(v/make-validation-error "candidate" "message" nil) 32 | (v/make-validation-error "candidate-2" "message-2" nil)]) 33 | (v/seq-validation failure failure-2)))) 34 | (t/testing "one failure leads to failure" 35 | (t/is (= failure 36 | (v/seq-validation (v/pure-validation identity) failure)))) 37 | (t/testing "two successes lead to success" 38 | (t/is (= flat-success 39 | (v/seq-validation (v/pure-validation identity) flat-success)))))) 40 | 41 | (t/deftest curry-n-test 42 | (t/is (= 42 ((v/curry-n (fn [] 42) 0)))) 43 | (t/is (= 42 (((v/curry-n (fn [a b] (+ a b)) 2) 1) 41))) 44 | (t/is (= 42 ((((v/curry-n (fn [a b c] (+ a b c)) 3) 1) 40) 1)))) 45 | 46 | (define-record-type Person {:rtd-record? true} 47 | make-person person? 48 | [name person-name 49 | age person-age]) 50 | 51 | (defn- validate-person 52 | [[name age]] 53 | (v/validation make-person 54 | (v/validate-string name) 55 | (v/validate-pos-int age))) 56 | 57 | (defn- validate-person-with-labels 58 | [[name age]] 59 | (v/validation make-person 60 | (v/validate-string name :name) 61 | (v/validate-pos-int age :age))) 62 | 63 | (t/deftest validation-test 64 | (t/is (= (v/make-validation-success (make-person "Mimi" 1)) 65 | (validate-person ["Mimi" 1]))) 66 | (t/is (= (v/make-validation-success (make-person "Mimi" 1)) 67 | (validate-person-with-labels ["Mimi" 1]))) 68 | (t/testing "every failure is collected in the result" 69 | (t/is (= (v/make-validation-failure 70 | [(v/make-validation-error 1 ::v/string nil) 71 | (v/make-validation-error "Mimi" ::v/pos-int nil)]) 72 | (validate-person [1 "Mimi"]))) 73 | (t/is (= (v/make-validation-failure 74 | [(v/make-validation-error 1 ::v/string :name) 75 | (v/make-validation-error "Mimi" ::v/pos-int :age)]) 76 | (validate-person-with-labels [1 "Mimi"]))))) 77 | 78 | (t/deftest validate-string-test 79 | (t/is (= (v/make-validation-failure 80 | [(v/make-validation-error 42 ::v/string nil)]) 81 | (v/validate-string 42))) 82 | (t/is (= (v/make-validation-success "string") 83 | (v/validate-string "string")))) 84 | 85 | (t/deftest validate-non-empty-string-test 86 | (t/is (= (v/make-validation-failure 87 | [(v/make-validation-error 42 ::v/non-empty-string nil)]) 88 | (v/validate-non-empty-string 42))) 89 | (t/is (= (v/make-validation-failure 90 | [(v/make-validation-error "" ::v/non-empty-string nil)]) 91 | (v/validate-non-empty-string ""))) 92 | (t/is (= (v/make-validation-success "string") 93 | (v/validate-non-empty-string "string")))) 94 | 95 | (t/deftest validate-int-test 96 | (t/is (= (v/make-validation-failure 97 | [(v/make-validation-error "string" ::v/int nil)]) 98 | (v/validate-int "string"))) 99 | (t/is (= (v/make-validation-success 42) 100 | (v/validate-int 42)))) 101 | 102 | (t/deftest pos-int-validation-test 103 | (t/is (= (v/make-validation-failure 104 | [(v/make-validation-error "string" ::v/pos-int nil)]) 105 | (v/validate-pos-int "string"))) 106 | (t/is (= (v/make-validation-failure 107 | [(v/make-validation-error -23 ::v/pos-int nil)]) 108 | (v/validate-pos-int -23))) 109 | (t/is (= (v/make-validation-success 42) 110 | (v/validate-pos-int 42)))) 111 | 112 | (t/deftest validate-boolean-test 113 | (t/is (= (v/make-validation-failure 114 | [(v/make-validation-error "string" ::v/boolean nil)]) 115 | (v/validate-boolean "string"))) 116 | (t/is (= (v/make-validation-success true) 117 | (v/validate-boolean true))) 118 | (t/is (= (v/make-validation-success false) 119 | (v/validate-boolean false)))) 120 | 121 | (t/deftest validate-keyword-test 122 | (t/is (= (v/make-validation-failure 123 | [(v/make-validation-error 42 ::v/keyword nil)]) 124 | (v/validate-keyword 42))) 125 | (t/is (= (v/make-validation-success :keyword) 126 | (v/validate-keyword :keyword)))) 127 | 128 | (t/deftest validate-one-of-test 129 | (t/is (= (v/make-validation-failure 130 | [(v/make-validation-error 42 [::v/one-of #{:a :b :c}] nil)]) 131 | (v/validate-one-of [:a :b :c] 42))) 132 | (t/is (= (v/make-validation-success :a) 133 | (v/validate-one-of [:a :b :c] :a))) 134 | (t/is (= (v/make-validation-success :c) 135 | (v/validate-one-of [:a :b :c] :c)))) 136 | 137 | (t/deftest validate-list-test 138 | (t/is (= (v/make-validation-failure 139 | [(v/make-validation-error 42 ::v/list nil)]) 140 | (v/validate-list 42))) 141 | (t/testing "vectors are not lists" 142 | (t/is (= (v/make-validation-failure 143 | [(v/make-validation-error [1 2 3] ::v/list nil)]) 144 | (v/validate-list [1 2 3])))) 145 | (t/is (= (v/make-validation-success (list 1 2 3)) 146 | (v/validate-list (list 1 2 3))))) 147 | 148 | (t/deftest validate-vector-test 149 | (t/is (= (v/make-validation-failure 150 | [(v/make-validation-error 42 ::v/vector nil)]) 151 | (v/validate-vector 42))) 152 | (t/testing "lists are not vectors" 153 | (t/is (= (v/make-validation-failure 154 | [(v/make-validation-error (list 1 2 3) ::v/vector nil)]) 155 | (v/validate-vector (list 1 2 3))))) 156 | (t/is (= (v/make-validation-success [1 2 3]) 157 | (v/validate-vector [1 2 3])))) 158 | 159 | (t/deftest validate-map-test 160 | (t/is (= (v/make-validation-failure 161 | [(v/make-validation-error 42 ::v/map nil)]) 162 | (v/validate-map 42))) 163 | (t/is (= (v/make-validation-success {:a "b"}) 164 | (v/validate-map {:a "b"})))) 165 | 166 | (t/deftest validate-set-test 167 | (t/is (= (v/make-validation-failure 168 | [(v/make-validation-error 42 ::v/set nil)]) 169 | (v/validate-set 42))) 170 | (t/is (= (v/make-validation-success #{:a :b :c}) 171 | (v/validate-set #{:a :b :c})))) 172 | 173 | (t/deftest validate-sequential-test 174 | (t/is (= (v/make-validation-failure 175 | [(v/make-validation-error 42 ::v/sequential nil)]) 176 | (v/validate-sequential 42))) 177 | (t/is (= (v/make-validation-success (list 1 2 3)) 178 | (v/validate-sequential (list 1 2 3)))) 179 | (t/is (= (v/make-validation-success [1 2 3]) 180 | (v/validate-sequential [1 2 3])))) 181 | 182 | (t/deftest optional-test 183 | (let [validate-optional-string (v/optional v/validate-string)] 184 | (t/is (= (v/make-validation-success "string") 185 | (validate-optional-string "string"))) 186 | (t/is (= (v/make-validation-success nil) 187 | (validate-optional-string nil))) 188 | (t/is (= (v/make-validation-failure 189 | [(v/make-validation-error 42 [::v/optional ::v/string] nil)]) 190 | (validate-optional-string 42))))) 191 | 192 | (define-record-type Node {:rtd-record? true} 193 | make-node node? 194 | [label node-label 195 | neighbors node-neighbors]) 196 | 197 | (defn- validate-node 198 | [[label neighbors]] 199 | (v/validation make-node 200 | (v/validate-non-empty-string label :label) 201 | (v/sequence-of validate-node neighbors :neighbors))) 202 | 203 | (t/deftest sequence-of-test 204 | (t/testing "an empty collection is always a valid `sequence-of`" 205 | (t/is (= (v/make-validation-success []) 206 | (v/sequence-of v/validate-non-empty-string [])))) 207 | (t/is (= (v/make-validation-success ["a" "b" "c"]) 208 | (v/sequence-of v/validate-non-empty-string ["a" "b" "c"]))) 209 | (t/is (= (v/make-validation-failure 210 | [(v/make-validation-error nil ::v/non-empty-string [::v/seq 0]) 211 | (v/make-validation-error 32 ::v/non-empty-string [::v/seq 2])]) 212 | (v/sequence-of v/validate-non-empty-string [nil "b" 32]))) 213 | (t/testing "labels are used correctly" 214 | (t/is (= (v/make-validation-failure 215 | [(v/make-validation-error nil ::v/non-empty-string [::some-name 0]) 216 | (v/make-validation-error 32 ::v/non-empty-string [::some-name 2])]) 217 | (v/sequence-of v/validate-non-empty-string [nil "b" 32] ::some-name)))) 218 | (t/testing "sequential validations can be nested" 219 | (t/testing "one level deep" 220 | (t/is (= (v/make-validation-success 221 | (make-node "a" [])) 222 | (validate-node ["a" []]))) 223 | (t/is (= (v/make-validation-success 224 | (make-node "a" [(make-node "b" []) (make-node "c" [])])) 225 | (validate-node ["a" [["b" []] ["c" []]]]))) 226 | (t/is (= (v/make-validation-failure 227 | [(v/make-validation-error "" ::v/non-empty-string [[:neighbors 1] :label])]) 228 | (validate-node ["a" [["b" []] ["" []]]])))) 229 | (t/testing "multiple levels deep" 230 | (t/is (= (v/make-validation-success 231 | (make-node "a" [(make-node "b" [(make-node "c" [])]) 232 | (make-node "d" [(make-node "e" [(make-node "f" [])])])])) 233 | (validate-node ["a" [["b" [["c" []]]] 234 | ["d" [["e" [["f" []]]]]]]]))) 235 | (t/is (= (v/make-validation-failure 236 | [(v/make-validation-error :e ::v/non-empty-string [[:neighbors 1] [[:neighbors 0] :label]]) 237 | (v/make-validation-error :f ::v/non-empty-string [[:neighbors 1] [[:neighbors 0] [[:neighbors 0] :label]]])]) 238 | (validate-node ["a" [["b" [["c" []]]] 239 | ["d" [[:e [[:f []]]]]]]])))))) 240 | 241 | (t/deftest validate-choice-test 242 | (let [validate-string-or-int (fn [candidate & [label]] 243 | (v/validate-choice [v/validate-string 244 | v/validate-int] 245 | candidate 246 | label))] 247 | (t/testing "an empty choice can never have a valid result" 248 | (t/is (= (v/make-validation-failure 249 | [(v/make-validation-error 42 [::v/choice ::v/no-validators] :label)]) 250 | (v/validate-choice [] 42 :label)))) 251 | (t/testing "exactly one success leads to success" 252 | (t/is (= (v/make-validation-success "string") 253 | (validate-string-or-int "string"))) 254 | (t/is (= (v/make-validation-success 42) 255 | (validate-string-or-int 42)))) 256 | (t/testing "every error is returned" 257 | (t/is (= (v/make-validation-failure 258 | [(v/make-validation-error :key ::v/string nil) 259 | (v/make-validation-error :key ::v/int nil)]) 260 | (validate-string-or-int :key))))) 261 | 262 | (t/testing "more than one success is a failure, too" 263 | (let [validate-even 264 | (fn [candidate & [label]] 265 | (v/make-validator candidate even? ::even label)) 266 | 267 | validate-either-even-or-positive-number 268 | (fn [candidate & [label]] 269 | (v/validate-choice [v/validate-pos-int 270 | validate-even] 271 | candidate 272 | label))] 273 | (t/is (= (v/make-validation-failure 274 | [(v/make-validation-error 2 [::v/choice ::v/more-than-one-success] nil)]) 275 | (validate-either-even-or-positive-number 2))) 276 | 277 | (t/testing "more than once success is a failure combined with other failures" 278 | (let [v (fn [candidate & [label]] 279 | (v/validate-choice [v/validate-pos-int 280 | validate-even 281 | v/validate-boolean 282 | v/validate-keyword] 283 | candidate 284 | label))] 285 | (t/is (= (v/make-validation-failure 286 | [(v/make-validation-error 2 [::v/choice ::v/more-than-one-success] nil) 287 | (v/make-validation-error 2 ::v/boolean nil) 288 | (v/make-validation-error 2 ::v/keyword nil)]) 289 | (v 2)))))))) 290 | 291 | (t/deftest validate-all-test 292 | (let [v (fn [c] 293 | (v/validate-all [v/validate-non-empty-string 294 | (fn [candidate & [label]] 295 | (if (= candidate "clojure") 296 | (v/make-validation-success candidate) 297 | (v/make-validation-failure [(v/make-validation-error candidate ::not-clojure label)])))] 298 | c 299 | :non-empty-and-clojure))] 300 | (t/testing "validating with an empty seq of validators is always successful" 301 | (t/is (= (v/make-validation-failure 302 | [(v/make-validation-error 42 [::v/all ::v/no-validators] :label)]) 303 | (v/validate-all [] 42 :label)))) 304 | (t/is (= (v/make-validation-failure 305 | [(v/make-validation-error "" ::v/non-empty-string :non-empty-and-clojure) 306 | (v/make-validation-error "" ::not-clojure :non-empty-and-clojure)]) 307 | (v ""))) 308 | (t/is (= (v/make-validation-failure 309 | [(v/make-validation-error "clj" ::not-clojure :non-empty-and-clojure)]) 310 | (v "clj"))) 311 | (t/is (= (v/make-validation-success "clojure") (v "clojure"))))) 312 | 313 | (t/deftest sequence-test 314 | (t/testing "the empty sequence" 315 | (t/is (= (v/make-validation-success []) 316 | (v/sequence [])))) 317 | (t/testing "only successes" 318 | (t/is (= (v/make-validation-success ['a 'b]) 319 | (v/sequence [(v/make-validation-success 'a) 320 | (v/make-validation-success 'b)])))) 321 | (t/testing "mixed success and failure" 322 | (t/is (= (v/make-validation-failure 323 | [(v/make-validation-error 'a :msg :label)]) 324 | (v/sequence [(v/make-validation-failure [(v/make-validation-error 'a :msg :label)]) 325 | (v/make-validation-success 'b)])))) 326 | (t/testing "only failure" 327 | (t/is (= (v/make-validation-failure 328 | [(v/make-validation-error 'a :msg :label) 329 | (v/make-validation-error 'b :msg :label) 330 | (v/make-validation-error 'c :msg :label)]) 331 | (v/sequence [(v/make-validation-failure [(v/make-validation-error 'a :msg :label)]) 332 | (v/make-validation-failure [(v/make-validation-error 'b :msg :label) 333 | (v/make-validation-error 'c :msg :label)])]))))) 334 | -------------------------------------------------------------------------------- /test/active/clojure/freer_monad_test.cljc: -------------------------------------------------------------------------------- 1 | (ns active.clojure.freer-monad-test 2 | #?(:cljs (:require-macros [active.clojure.freer-monad :refer (monadic)] 3 | [cljs.test :refer (is deftest run-tests testing)])) 4 | (:require #?(:clj [active.clojure.freer-monad :refer :all]) 5 | #?(:cljs [active.clojure.freer-monad :refer (return return? return-result 6 | bind bind? bind-first-action bind-continuations apply-continuations 7 | call-cc call-cc? 8 | with-handler signal 9 | get-state put-state! 10 | get-env get-env-component with-env-component with-env 11 | and-finally bind-except sequ sequ_ 12 | make-exception-value exception-value? 13 | unknown-command unknown-command? 14 | make-monad-command-config 15 | combine-monad-command-configs 16 | null-monad-command-config 17 | run-freer-reader-state-exception execute-freer-reader-state-exception 18 | run-monadic execute-monadic 19 | monad-command-config-run-command 20 | reify-command reify-as 21 | put-state-component!)]) 22 | [active.clojure.condition :as c] 23 | #?(:clj [clojure.test :refer :all]) 24 | #?(:cljs [cljs.test]))) 25 | 26 | (defrecord Ask [prompt]) 27 | (defn ask [prompt] (Ask. prompt)) 28 | (defn ask? [x] (instance? Ask x)) 29 | 30 | (defrecord Tell [msg]) 31 | (defn tell [msg] (Tell. msg)) 32 | (defn tell? [x] (instance? Tell x)) 33 | 34 | (defn run 35 | [m mp] 36 | (loop [m m 37 | msgs []] 38 | (cond 39 | (return? m) [(return-result m) msgs] 40 | 41 | (bind? m) 42 | (let [m1 (bind-first-action m) 43 | conts (bind-continuations m)] 44 | (cond 45 | (ask? m1) 46 | (if-let [ans (get mp (:prompt m1))] 47 | (recur (apply-continuations conts ans) msgs) 48 | (c/assertion-violation `run "unknown question" (:prompt m1) m1)) 49 | 50 | (tell? m1) 51 | (recur (apply-continuations conts nil) (conj msgs (:msg m1))))) 52 | 53 | (ask? m) 54 | (if-let [ans (get mp (:prompt m))] 55 | [ans msgs] 56 | (c/assertion-violation `run "unknown question" (:prompt m))) 57 | 58 | (tell? m) 59 | [nil (conj msgs (:msg m))]))) 60 | 61 | (defn ex1 62 | [] 63 | (monadic [first (ask "what's your first name?") 64 | last (ask "what's your last name?")] 65 | (let [s (str "Hello, " first " " last)]) 66 | (tell s))) 67 | 68 | (deftest test-run 69 | (is (= [nil ["Hello, Mike Sperber"]] 70 | (run (ex1) 71 | {"what's your first name?" "Mike" 72 | "what's your last name?" "Sperber"})))) 73 | 74 | (defn tester-ask 75 | [prompt] 76 | (fn [mp] 77 | (if-let [ans (get mp prompt)] 78 | [[] ans] 79 | (c/assertion-violation `tester-ask "unknown question" prompt mp)))) 80 | 81 | (defn tester-tell 82 | [msg] 83 | (fn [mp] 84 | [[msg] nil])) 85 | 86 | (defn tester-throw 87 | [ex] 88 | (fn [mp] 89 | [[] (make-exception-value ex)])) 90 | 91 | (defn tester-with-handler 92 | [handler body] 93 | (fn [mp] 94 | (let [[o1 a :as res] (body mp)] 95 | (if (exception-value? a) 96 | ((handler (:exception a)) mp) 97 | res)))) 98 | 99 | (defn run-tester 100 | [m mp] 101 | (m mp)) 102 | 103 | (defn interact->tester 104 | [m] 105 | (cond 106 | (ask? m) (tester-ask (:prompt m)) 107 | (tell? m) (tester-tell (:msg m)))) 108 | 109 | (defn run-ask-tell 110 | [run-any env state comp] 111 | (cond 112 | (ask? comp) 113 | [(get (::answers env) (:prompt comp)) state] 114 | 115 | (tell? comp) 116 | [nil (update state ::output #(conj % (:msg comp)))] 117 | 118 | :else unknown-command)) 119 | 120 | 121 | (defn run-ask-tell-config 122 | [qas] 123 | (make-monad-command-config run-ask-tell {::answers qas} {::output []})) 124 | 125 | 126 | (defn ex2 127 | [] 128 | (monadic [first (ask "what's your first name?")] 129 | (if (= first "Mike") 130 | (signal "It's Mike") 131 | (monadic 132 | [last (ask "what's your last name?")] 133 | (tell (str "Hello, " first " " last)))))) 134 | 135 | ;; FIXME DELETEME 136 | #_(deftest test2-freer->m-exception 137 | (is (= [[] (make-exception-value "It's Mike")] 138 | (run-tester (free->tester-m (ex2)) 139 | {"what's your first name?" "Mike" 140 | "what's your last name?" "Sperber"})))) 141 | 142 | (defn ex3 143 | [] 144 | (let [first-name 145 | (monadic [first (ask "what's your first name?")] 146 | (if (= first "Mike") 147 | (signal "It's Mike") 148 | (return first)))] 149 | (monadic [first (with-handler (fn [ex] 150 | (if (= "It's Mike" ex) 151 | (return "Michael") 152 | (return "Unknown"))) 153 | first-name) 154 | last (ask "what's your last name?")] 155 | (tell (str "Hello, " first " " last))))) 156 | 157 | (deftest frse-ex3 158 | (is (= [nil {::output ["Hello, David Frese"]}] 159 | (run-freer-reader-state-exception (run-ask-tell-config 160 | {"what's your first name?" "David" 161 | "what's your last name?" "Frese"}) 162 | (ex3))))) 163 | (deftest frse-ex3-with-handler 164 | (is (= [nil {::output ["Hello, Michael Sperber"]}] 165 | (run-freer-reader-state-exception (run-ask-tell-config 166 | {"what's your first name?" "Mike" 167 | "what's your last name?" "Sperber"}) 168 | (ex3))))) 169 | 170 | (deftest with-handler-state 171 | (is (= [nil {::with-handler-state true}] 172 | (run-freer-reader-state-exception (null-monad-command-config nil nil) 173 | (monadic 174 | (with-handler 175 | (fn [exn] 176 | (put-state-component! ::with-handler-state true)) 177 | (monadic 178 | (signal 'something)))))))) 179 | 180 | (deftest test-and-finally 181 | (is (= [(make-exception-value "It's Mike") {::output ["Hello"]}] 182 | (run-freer-reader-state-exception (run-ask-tell-config 183 | {"what's your first name?" "Mike" 184 | "what's your last name?" "Doe"}) 185 | (and-finally (ex2) 186 | (tell "Hello")))))) 187 | 188 | (deftest test-bind-except 189 | (is (= [nil {::output ["Hello"]}] 190 | ;; ex2 causes exception, so only handler is called 191 | (run-freer-reader-state-exception (run-ask-tell-config 192 | {"what's your first name?" "Mike" 193 | "what's your last name?" "Doe"}) 194 | (bind-except (ex2) 195 | (fn [e] (tell "Hello")) 196 | (fn [v] (tell "Hola")))))) 197 | 198 | (is (= [nil {::output ["Hola"]}] 199 | ;; return does not cause exception, so body is called with result 200 | (run-freer-reader-state-exception (run-ask-tell-config {}) 201 | (bind-except (return "Hola") 202 | (fn [e] (tell "Hello")) 203 | (fn [v] (tell v))))))) 204 | (defn ex4 205 | [] 206 | (sequ [(monadic (tell "hello") 207 | (return 1)) 208 | (monadic (tell "world") 209 | (return 2))])) 210 | 211 | (deftest tsequ 212 | (is (= [[1 2] {::output ["hello" "world"]}] 213 | (run-freer-reader-state-exception (run-ask-tell-config {}) 214 | (ex4))))) 215 | 216 | 217 | (defn ex5 218 | [] 219 | (sequ_ [(monadic (tell "hello") 220 | (return 1)) 221 | (monadic (tell "world") 222 | (return 2))])) 223 | 224 | 225 | (deftest tsequ_ 226 | (is (= [nil {::output ["hello" "world"]}] 227 | (run-freer-reader-state-exception (run-ask-tell-config {}) 228 | (ex5)))) 229 | (testing "sequ_ does not consume stack" 230 | (is (= [nil nil] 231 | (run-freer-reader-state-exception (null-monad-command-config nil nil) 232 | (sequ_ (repeat 20000 (return "hello")))))))) 233 | 234 | 235 | (deftest frse-trivial 236 | (is (= ["Hola" nil] 237 | (run-freer-reader-state-exception (null-monad-command-config nil nil) (return "Hola")))) 238 | (is (= ["Hola" nil] 239 | (run-freer-reader-state-exception (null-monad-command-config nil nil) 240 | (bind (return "Hola") 241 | (fn [x] 242 | (return x))))))) 243 | 244 | (deftest frse-ask-tell 245 | (is (= [nil {::output ["Hello, Mike Sperber"]}] 246 | (run-freer-reader-state-exception (run-ask-tell-config 247 | {"what's your first name?" "Mike" 248 | "what's your last name?" "Sperber"}) 249 | (ex1))))) 250 | 251 | 252 | (deftest frse-with-handler 253 | (is (= [nil {::output ["Hello, David Frese"]}] 254 | (run-freer-reader-state-exception (run-ask-tell-config 255 | {"what's your first name?" "David" 256 | "what's your last name?" "Frese"}) 257 | (ex2))))) 258 | 259 | (deftest frse-exception 260 | (is (= [(make-exception-value "It's Mike") {::output []}] 261 | (run-freer-reader-state-exception (run-ask-tell-config 262 | {"what's your first name?" "Mike" 263 | "what's your last name?" "Sperber"}) 264 | (ex2))))) 265 | 266 | (deftest frse-env 267 | (is (= [['foo 'bar] nil] 268 | (run-freer-reader-state-exception (null-monad-command-config 'foo nil) 269 | (monadic [x (get-env) 270 | y (with-env (constantly 'bar) 271 | (get-env))] 272 | (return [x y])))))) 273 | 274 | (deftest frse-env-component 275 | (is (= [['foo 'bar] nil] 276 | (run-freer-reader-state-exception (null-monad-command-config {::stuff 'foo} nil) 277 | (monadic [x (get-env-component ::stuff) 278 | y (with-env-component ::stuff (constantly 'bar) 279 | (get-env-component ::stuff))] 280 | (return [x y])))))) 281 | 282 | (deftest frse-state 283 | (is (= [{:x 'foo} {:x 'bar}] 284 | (run-freer-reader-state-exception (null-monad-command-config 'nil {:x 'foo}) 285 | (monadic [x (get-state)] 286 | (put-state! {:x 'bar}) 287 | (return x)))))) 288 | 289 | (deftest null-config 290 | (let [c (null-monad-command-config nil nil)] 291 | (is (unknown-command? ((monad-command-config-run-command c) 292 | (constantly nil) nil nil 293 | 'foo))))) 294 | 295 | 296 | (defrecord Incr []) 297 | (defn incr [] (Incr.)) 298 | (defn incr? [x] (instance? Incr x)) 299 | 300 | (defn run-incr 301 | [run-any env state comp] 302 | (cond 303 | (incr? comp) 304 | [(::count state) (update state ::count inc)] 305 | 306 | :else unknown-command)) 307 | 308 | (defn run-incr-config 309 | [initial] 310 | (make-monad-command-config run-incr {} {::count initial})) 311 | 312 | (deftest combined 313 | (let [c (combine-monad-command-configs 314 | (run-ask-tell-config {"what's your first name?" "Mike" 315 | "what's your last name?" "Sperber"}) 316 | (run-incr-config 15))] 317 | (is (= [15 {::output [] ::count 16}] 318 | (run-freer-reader-state-exception c (incr)))) 319 | (is (= [15 {::output ["Hello, Mike Sperber"] ::count 16}] 320 | (run-freer-reader-state-exception c 321 | (monadic 322 | (ex1) 323 | (incr))))))) 324 | 325 | #?(:clj 326 | (deftest execute 327 | (is 328 | (thrown? Exception 329 | (execute-freer-reader-state-exception (combine-monad-command-configs) 330 | (signal (Exception. "foo"))))))) 331 | 332 | (deftest reify-command-test 333 | (let [m (return 42)] 334 | (is (= :blub 335 | (reify-command (reify-as m :blub)))) 336 | (is (= m 337 | (reify-command m))))) 338 | 339 | ; inlining this results in no metadata; go figure 340 | (defn fake-return 341 | [result] 342 | `(return ~result)) 343 | 344 | (deftest metadata-test 345 | (let [stmt (monadic 346 | [a (fake-return 42)] ; plain return will collapse everything to a single return 347 | [b (fake-return 21)] 348 | (return 10))] 349 | (let [base (meta stmt)] 350 | (is (= #{:line :column :statement} 351 | (set (keys (select-keys base #{:line :column :statement}))))) 352 | 353 | (is (= '[a (fake-return 42)] 354 | (:statement base))) 355 | 356 | (is (= {:statement '[b (fake-return 21)] 357 | :column (:column base) 358 | :line (inc (or (:line base) -1))} 359 | (select-keys (meta (apply-continuations (bind-continuations stmt) nil)) #{:line :column :statement}))))) 360 | 361 | ;; and we don't need/want metadata on this: 362 | (is (= nil 363 | (meta (monadic (return 42))))) 364 | (is (= (return 42) 365 | (monadic (return 42))))) 366 | 367 | (deftest call-cc-test 368 | (testing "non-tail escape call" 369 | (let [f (fn [cont] (monadic 370 | (cont 42) 371 | (return 23)))] 372 | (is (= [23 nil] 373 | (execute-monadic 374 | (null-monad-command-config nil nil) 375 | (f return)))) 376 | (is (= [42 nil] 377 | (execute-monadic 378 | (null-monad-command-config nil nil) 379 | (monadic 380 | [r (call-cc f)] 381 | (return r))))) 382 | (is (= [42 nil] 383 | (execute-monadic 384 | (null-monad-command-config nil nil) 385 | (call-cc f)))))) 386 | (testing "tail escape call" 387 | (let [f (fn [cont] (cont 42))] 388 | (is (= [42 nil] 389 | (execute-monadic 390 | (null-monad-command-config nil nil) 391 | (f return)))) 392 | (is (= [42 nil] 393 | (execute-monadic 394 | (null-monad-command-config nil nil) 395 | (monadic 396 | [r (call-cc f)] 397 | (return r))))) 398 | (is (= [42 nil] 399 | (execute-monadic 400 | (null-monad-command-config nil nil) 401 | (call-cc f))))))) 402 | -------------------------------------------------------------------------------- /src/active/clojure/validation.cljc: -------------------------------------------------------------------------------- 1 | (ns active.clojure.validation 2 | "This namespace provides the utilities for applicative data validation. 3 | Chiefly, it provides the [[validation]] function that defines a data 4 | validation. It also provides predefined data validators for common 5 | use-cases (ints, strings, booleans, ...). 6 | 7 | Example: 8 | ``` 9 | (defn example-validation 10 | [id name] 11 | (validation (fn [id name] {:id id :name name}) 12 | (validate-pos-int id :id) 13 | (validate-string name))) 14 | 15 | (example-validation [42 \"name\"]) 16 | ;; => active.clojure.validation/ValidationSuccess{:candidate {:id 42, :name \"name\"}} 17 | (example-validation [42 23]) 18 | ;; => active.clojure.validation/ValidationFailure{:errors 19 | ;; [active.clojure.validation/ValidationError{:candidate 23, 20 | ;; :message :active.clojure.validation/string, 21 | ;; :label nil}]} 22 | (example-validation [\"name\" 42]) 23 | ;; => phoenix.common.validation/ValidationFailure{:errors 24 | ;; (active.clojure.validation/ValidationError{:candidate \"name\", 25 | ;; :message :active.clojure.validation/pos-int, 26 | ;; :label :id} 27 | ;; active.clojure.validation/ValidationError{:candidate 42, 28 | ;; :message :active.clojure.validation/string, 29 | ;; :label nil})} 30 | ``` 31 | " 32 | (:require #?(:clj [active.clojure.record :refer [define-record-type]] 33 | :cljs [active.clojure.cljs.record :refer-macros [define-record-type]]) 34 | [active.clojure.condition :as condition] 35 | [active.clojure.lens :as lens]) 36 | (:refer-clojure :exclude [sequence])) 37 | 38 | ;;; A ValidationResult is one of the following 39 | ;; - a ValidationSuccess 40 | ;; - a ValidationFailure. 41 | (define-record-type ^{:doc "Signifies a failured validation. Holds 42 | the [[ValidationError]]."} 43 | ValidationFailure 44 | make-validation-failure validation-failure? 45 | [^{:doc "A sequence of [[ValidationError]] that lead to the failed 46 | validation."} 47 | errors validation-failure-errors]) 48 | 49 | (define-record-type ^{:doc "Signifies a successful validation. Holds 50 | the candidate value that was being validated."} 51 | ValidationSuccess 52 | make-validation-success validation-success? 53 | [^{:doc "The candidate value that was beign validated."} 54 | candidate validation-success-candidate]) 55 | 56 | (defn validation-result? 57 | "Checks if `thing` is a validation result." 58 | [thing] 59 | (or (validation-failure? thing) 60 | (validation-success? thing))) 61 | 62 | (defn with-validation-result 63 | "Takes a validation `result` and applies `f-success` to the whole 64 | result if it is a [[ValidationSuccess]], otherwise applies 65 | `f-failure` to the whole [[ValidationFailure]]." 66 | [f-success f-failure result] 67 | (cond 68 | (validation-failure? result) (f-failure result) 69 | (validation-success? result) (f-success result))) 70 | 71 | ;; Functor 72 | (defn fmap-success 73 | "fmap for validation success: Apply `f` to `e`'s candidate iff e is 74 | a [[ValidationSuccess]]." 75 | [f e] 76 | (cond 77 | (validation-failure? e) e 78 | (validation-success? e) 79 | (make-validation-success (f (validation-success-candidate e))))) 80 | 81 | (defn fmap-failure 82 | "fmap for validation errors: Apply `f` to each of `e`'s errors iff e is a [[ValidationFailure]]" 83 | [f e] 84 | (cond 85 | (validation-failure? e) (make-validation-failure (map f (validation-failure-errors e))) 86 | (validation-success? e) e)) 87 | 88 | (defn fmap-result 89 | "fmap over the result of a validation. Applies `(fmap-success 90 | f-success result`) if `result` is a [[ValidationSuccess]] 91 | and `(fmap-failure f-failure result)` if `result` is 92 | a [[ValidationFailure]]" 93 | [f-success f-failure result] 94 | (cond 95 | (validation-failure? result) (fmap-failure f-failure result) 96 | (validation-success? result) (fmap-success f-success result))) 97 | 98 | ;; Validation specifics 99 | (define-record-type ^{:doc "Signifies a the error of a failed 100 | validation. Holds the candidate value that was being validated, the 101 | corresponding error message and an arbitrary label."} 102 | ValidationError 103 | make-validation-error validation-error? 104 | [^{:doc "The candidate value that was being validated."} 105 | candidate validation-error-candidate 106 | ^{:doc "A message signifying what kind of error occured. It should 107 | be possible for the user to interpret the message as they please, so 108 | usually a namespaced keyword representing the error works well."} 109 | message validation-error-message 110 | ^{:doc "Arbitrary data that can be added to an error."} 111 | label validation-error-label]) 112 | 113 | (defn override-error-labels 114 | "override validation error labels with `new-label` in each of `e`'s 115 | error iff `e` is a [[ValidationFailure]]" 116 | [e new-label] 117 | (fmap-failure #(validation-error-label % new-label) e)) 118 | 119 | (defn override-error-messages 120 | "override validation error messages with `new-message` in each of 121 | `e`'s error iff `e` is a [[ValidationFailure]]" 122 | [e new-message] 123 | (fmap-failure #(validation-error-message % new-message) e)) 124 | 125 | (defn mappend-validation-failure 126 | "mappend the [[validation-failure-errors]] of 127 | two [[ValidationFailure]]s." 128 | [vf1 vf2] 129 | (make-validation-failure (concat (validation-failure-errors vf1) 130 | (validation-failure-errors vf2)))) 131 | 132 | ;;; Applicative 133 | (def pure-validation 134 | "Lift a value into the validation applicative." 135 | make-validation-success) 136 | 137 | (defn- assert-validation-result [e] 138 | (condition/assert (validation-result? e) 139 | (str "not a validation-result" (pr-str e)))) 140 | 141 | (defn seq-validation 142 | "Apply two validations sequentially, from left to right. Analogous 143 | to `Either` where `ValidationFailure` is `Left` and 144 | `ValidationSuccess` is `Right`." 145 | [v-1 v-2] 146 | (assert-validation-result v-1) 147 | (assert-validation-result v-2) 148 | (cond 149 | (and (validation-failure? v-1) 150 | (validation-failure? v-2)) 151 | (mappend-validation-failure v-1 v-2) 152 | 153 | (validation-failure? v-1) 154 | v-1 155 | 156 | (validation-success? v-1) 157 | (fmap-success (validation-success-candidate v-1) v-2))) 158 | 159 | (defn- bind 160 | ;; Apply validations in sequence (aka monadic bind). Takes a validation 161 | ;; `e` and a function `f` and applies `e`'s candidate iff `e` is 162 | ;; a [[ValidationSuccess]]. 163 | [e f] 164 | (assert-validation-result e) 165 | (cond 166 | (validation-failure? e) e 167 | (validation-success? e) (f (validation-success-candidate e)))) 168 | 169 | (defn and-then 170 | "Apply validations in sequence. Takes a validation `e` and a function 171 | `f` and applies `e`'s candidate iff `e` is a [[ValidationSuccess]]." 172 | [e f] 173 | (bind e f)) 174 | 175 | (defn curry-n 176 | "Curry a function `f` of arity `n`." 177 | [f n] 178 | (if (or (zero? n) (= n 1)) 179 | ;; There's nothing to do. 180 | f 181 | ;; Partially apply f to x and 'wait' for the rest of the args. 182 | (fn [x] 183 | (curry-n (partial f x) (dec n))))) 184 | 185 | (defn validation 186 | "Takes a result construtor function and a sequence of validations. 187 | If all validations success, constructs a result from the validated 188 | values via `make-result`, wrapped in a `ValidationSuccess`. The 189 | arguments will be supplied to `make-result` in the order in which 190 | they were validated. 191 | 192 | If any one validation fails, returns a `ValidationFailure`, 193 | containing _all_ failures. 194 | 195 | The number of arguments `make-result` expects must match the `(count 196 | validations`). Supplying a wrong number of arguments considered 197 | undefined behaviour." 198 | [make-result & validations] 199 | (reduce (fn [res v] (seq-validation res v)) 200 | (pure-validation (curry-n make-result (count validations))) 201 | validations)) 202 | 203 | (defn- augment-validation-error-message 204 | [validation-error msg] 205 | (lens/overhaul validation-error validation-error-message (fn [m] [msg m]))) 206 | 207 | (defn- augment-validation-error-label 208 | [validation-error label] 209 | (lens/overhaul validation-error validation-error-label (fn [l] (if l 210 | [label l] 211 | label)))) 212 | 213 | (defn- augment-validation-failure-errors 214 | [validation-failure f] 215 | (make-validation-failure (mapv f (validation-failure-errors validation-failure)))) 216 | 217 | (defn- augment-validation-failure-error-messages 218 | [validation-failure message] 219 | (augment-validation-failure-errors validation-failure 220 | #(augment-validation-error-message % message))) 221 | 222 | (defn sequence 223 | "Takes a vector of validation results ([[ValidationSuccess]] 224 | or [[ValidationFailure]]) and returns a [[ValidationSuccess]] of all 225 | candidates as a vector iff all are [[ValidationSuccess]]. 226 | Else it returns a [[ValidationFailure]] with all errors accumulated. " 227 | [validation-results] 228 | (if (empty? validation-results) 229 | (make-validation-success []) 230 | (apply validation vector validation-results))) 231 | 232 | ;; Combinators 233 | 234 | (defn sequence-of 235 | ;; TODO chose a better name that doesnt remind johannes of monads. 236 | 237 | "Takes a validation function and a sequence of candidates and 238 | validates each candidate and returns the combined result. 239 | 240 | If any one validation fails, returns a 241 | `ValidationFailure`, containing _all_ failures. 242 | 243 | All failures' [[validation-error-label]]s are prepended with a tuple 244 | of `label` if present (otherwise, defaults to `::seq`) and the index 245 | of the value that could not be validated." 246 | [validation candidates & [label]] 247 | (sequence 248 | (map-indexed 249 | (fn [idx candidate] 250 | (->> (validation candidate) 251 | (fmap-failure #(augment-validation-error-label % [(or label ::seq) idx])))) 252 | candidates))) 253 | 254 | (defn validate-choice 255 | "Takes a sequence of `validation` functions and a `candidate` 256 | and applies each validation function to the `candidate`. 257 | 258 | If `validations` is empty, the validation will always fail with the 259 | `[::choice ::no-validators]` message. 260 | 261 | If exactly one validation succeeds, returns a [[ValidationSuccess]]. 262 | Otherwise, returns a [[ValidationFailure]] with all failed 263 | validations. 264 | 265 | All failures' [[validation-error-label]]s are prepended with a tuple 266 | of `label` if present (otherwise, defaults to `::choice`) and the 267 | index of the value that could not be validated." 268 | [validators candidate & [label]] 269 | ;; Choice is interesting because we need to have exactly one 270 | ;; validator successfully validate the candidate. 271 | (if (empty? validators) 272 | (make-validation-failure 273 | [(make-validation-error candidate [::choice ::no-validators] label)]) 274 | (let [validation-results (mapv (fn [validate] (validate candidate label)) validators) 275 | groups (group-by validation-success? validation-results) 276 | successes (get groups true) 277 | [error & errors] (get groups false) 278 | ;; All validation errors combined. 279 | base-failure (reduce mappend-validation-failure error errors)] 280 | (cond 281 | ;; We get a success if we have exactly one successful match. 282 | (= 1 (count successes)) 283 | (first successes) 284 | 285 | ;; More than one success is a failure. Communicate the cause 286 | ;; (::more-than-one-success) and append the rest of the 287 | ;; failures (`base-failure`). 288 | (< 1 (count successes)) 289 | (let [choice-failure (make-validation-failure 290 | [(make-validation-error candidate [::choice ::more-than-one-success] label)])] 291 | (if (nil? error) 292 | choice-failure 293 | (mappend-validation-failure choice-failure base-failure))) 294 | 295 | :else ;; There was no success at all, return the base failure. 296 | base-failure)))) 297 | 298 | (declare succeed) 299 | 300 | (defn validate-all 301 | "Takes a sequence of `validations` and a `candidate` and applies all 302 | `validations` to `candidate` sequentially. Collects either 303 | all [[ValidationFailure]]s or returns a [[ValidationSuccess]] for 304 | the candidate." 305 | [validations candidate & [label]] 306 | (if (empty? validations) 307 | (make-validation-failure 308 | [(make-validation-error candidate [::all ::no-validators] label)]) 309 | ;; missing labels 310 | (let [labelled-validations (mapv (fn [v] (fn [c] (v c label))) validations) 311 | validated ((apply juxt labelled-validations) candidate)] 312 | (and-then (apply validation vector validated) 313 | (constantly (succeed candidate)))))) 314 | 315 | (defn optional 316 | "Takes a validation function `validate` and returns a validation 317 | function that accepts what `validate` accepts plus `nil`." 318 | [validate] 319 | (fn [candidate & [label]] 320 | (if (nil? candidate) 321 | (make-validation-success candidate) 322 | (let [v (validate candidate label)] 323 | (cond 324 | (validation-success? v) v 325 | (validation-failure? v) 326 | (augment-validation-failure-error-messages v ::optional)))))) 327 | 328 | ;; Some frequently used validators. 329 | 330 | (defn make-validator 331 | "Takes a `candidate` value and a `predicate` the candidate will be 332 | applied to. If `(predicate candidate)` returns false, returns 333 | a [[ValidationFailure]] with `error-message` as 334 | the [[ValidationError]], using `label` as the label if provided." 335 | [candidate predicate error-message & [label]] 336 | (if (predicate candidate) 337 | (make-validation-success candidate) 338 | (make-validation-failure [(make-validation-error candidate error-message label)]))) 339 | 340 | (defn succeed 341 | "Validator that always succeeds." 342 | [candidate & [label]] 343 | (make-validator candidate (constantly true) ::any label)) 344 | 345 | (defn validate-string 346 | "Validates that a candidate is a String." 347 | [s & [label]] 348 | (make-validator s string? ::string label)) 349 | 350 | (defn validate-non-empty-string 351 | "Validates that a candidate is a non-empty String." 352 | [s & [label]] 353 | (make-validator s #(and (string? %) (seq %)) ::non-empty-string label)) 354 | 355 | (defn validate-int 356 | "Validates that a candidate is an integer." 357 | [i & [label]] 358 | (make-validator i int? ::int label)) 359 | 360 | (defn validate-pos-int 361 | "Validates that a candidate is a positive integer." 362 | [i & [label]] 363 | (make-validator i pos-int? ::pos-int label)) 364 | 365 | (defn validate-boolean 366 | "Validates that a candidate is a boolean" 367 | [b & [label]] 368 | (make-validator b (some-fn true? false?) ::boolean label)) 369 | 370 | (defn validate-keyword 371 | "Validates that a candidate is a boolean" 372 | [k & [label]] 373 | (make-validator k keyword? ::keyword label)) 374 | 375 | (defn validate-one-of 376 | "Validates that a candidate is exatly one of `elems`." 377 | [elems k & [label]] 378 | (let [s (into #{} elems)] 379 | (make-validator k #(contains? s %) [::one-of s] label))) 380 | 381 | (defn validate-none-of 382 | "Validates that a candidate is anything except one of `elems`." 383 | [elems k & [label]] 384 | (let [s (into #{} elems)] 385 | (make-validator k #(not (contains? s %)) [::none-of s] label))) 386 | 387 | (defn validate-list 388 | "Validates that a candidate is a list." 389 | [xs & [label]] 390 | (make-validator xs list? ::list label)) 391 | 392 | (defn validate-vector 393 | "Validates that a candidate is a vector." 394 | [xs & [label]] 395 | (make-validator xs vector? ::vector label)) 396 | 397 | (defn validate-map 398 | "Validates that a candidate is a map." 399 | [m & [label]] 400 | (make-validator m map? ::map label)) 401 | 402 | (defn validate-set 403 | "Validates that a candidate is a set." 404 | [s & [label]] 405 | (make-validator s set? ::set label)) 406 | 407 | (defn validate-sequential 408 | "Validates that a candidate is sequential." 409 | [s & [label]] 410 | (make-validator s sequential? ::sequential label)) 411 | -------------------------------------------------------------------------------- /src/active/clojure/record_helper.cljc: -------------------------------------------------------------------------------- 1 | (ns ^:no-doc active.clojure.record-helper 2 | (:require [active.clojure.lens :as lens] 3 | [active.clojure.condition :as c] 4 | [clojure.spec.alpha :as spec] 5 | [active.clojure.functions :as f] 6 | [active.clojure.record-runtime :as rrun])) 7 | 8 | 9 | 10 | ;;; Nongenerative stuff 11 | ;; Maps from nongenerative-id to {:ns *ns* :form define-record-form} 12 | #?(:clj 13 | (defonce global-record-type-registry (atom {}))) 14 | 15 | #?(:clj 16 | (defn remove-record-type 17 | [nongenerative-id] 18 | (swap! global-record-type-registry 19 | (fn [old-reg] (dissoc old-reg nongenerative-id))))) 20 | 21 | 22 | #?(:clj 23 | (defn throw-illegal-argument-exception 24 | [msg] 25 | (c/assertion-violation `throw-illegal-argument-exception 26 | (str "Illegal argument: " msg) 27 | msg))) 28 | 29 | 30 | #?(:clj 31 | (defn prepare-arguments! 32 | "Checks validity of arguments and prepares them for `define-record-type` call. 33 | Returns vector of arguments: 34 | [type options constructor constructor-args predicate field-triples opt+specs]. 35 | 36 | If :nongenerative option is truthy, the given nongenerative-id is registered in 37 | the global-record-type-registry. If this id already exists, but the definitions 38 | are different, an error is thrown. Otherwise `nil` is returned." 39 | [form ns ?type ?second ?params] 40 | (let [?options (when (map? ?second) ?second) 41 | ?constructor-call (if ?options (first ?params) ?second) 42 | ?predicate (if ?options (second ?params) (first ?params)) 43 | ?field-tuples (if ?options (nth ?params 2) (second ?params)) 44 | ?opt+specs (if ?options (drop 3 ?params) (drop 2 ?params))] 45 | 46 | (when-not (or (and (list? ?constructor-call) 47 | (not (empty? ?constructor-call))) 48 | (symbol? ?constructor-call)) 49 | (throw (throw-illegal-argument-exception (str "constructor call must be a list in " ns " " (meta form))))) 50 | 51 | (when-not (vector? ?field-tuples) 52 | (throw (throw-illegal-argument-exception (str "field tuples must be a vector in " ns " " (meta form))))) 53 | 54 | (when-not (even? (count (remove seq? ?field-tuples))) 55 | (throw (throw-illegal-argument-exception (str "odd number of elements in field tuples in " ns " " (meta form))))) 56 | 57 | (when-not (every? true? (map #(= 3 (count %1)) (filter seq? ?field-tuples))) 58 | (throw (throw-illegal-argument-exception (str "wrong number of elements in field tuples with lens in " ns " " (meta form))))) 59 | 60 | (let [field-tuples (loop [?tuples (seq ?field-tuples) 61 | acc '()] 62 | (if (empty? ?tuples) 63 | (reverse acc) 64 | 65 | (let [tuple (first ?tuples)] 66 | (cond 67 | (not (symbol? tuple)) 68 | (throw (throw-illegal-argument-exception (str "invalid field tuple " tuple " in " ns " " (meta form)))) 69 | 70 | (empty? (rest ?tuples)) 71 | (throw (throw-illegal-argument-exception (str "incomplete field tuple for " tuple " in " ns " " (meta form)))) 72 | 73 | (not (symbol? (fnext ?tuples))) 74 | (throw (throw-illegal-argument-exception (str "invalid accessor " (fnext ?tuples) " for " tuple " in " ns " " (meta form)))) 75 | 76 | :default 77 | (recur (nnext ?tuples) 78 | (list* [tuple (fnext ?tuples)] acc)))))) 79 | 80 | [?constructor & ?constructor-args] (cond 81 | (list? ?constructor-call) 82 | ?constructor-call 83 | 84 | (symbol? ?constructor-call) 85 | (concat [?constructor-call] 86 | (map first field-tuples))) 87 | ;; Rename for nongenerative test 88 | new-ns ns 89 | new-form form] 90 | 91 | ;;; Check if constructor-args are in field-names 92 | (let [?field-names-set (set (map first field-tuples))] 93 | (doseq [?constructor-arg ?constructor-args] 94 | (when-not (contains? ?field-names-set ?constructor-arg) 95 | (throw (throw-illegal-argument-exception (str "Constructor argument `" ?constructor-arg "` is not a field in " *ns* " " (meta form))))))) 96 | 97 | ;;; Check nongenerative option 98 | (if-let [non-g-id (:nongenerative ?options)] 99 | ;; nongenerative 100 | (if-let [{:keys [ns form]} (get @global-record-type-registry non-g-id)] 101 | (if (and (= ns new-ns) (= form new-form)) 102 | ;; non-g-id exists, but definitions are the same 103 | nil 104 | (throw (Exception. "This record type definition already exists with different arguments."))) 105 | ;; nongenerative, but id doesn't exist. Register id and return arguments. 106 | (let [non-g-id (if (= true non-g-id) (str new-ns "/" ?type) non-g-id)] ; default non-g-id when key is `true` 107 | (swap! global-record-type-registry 108 | (fn [old-reg] (assoc old-reg non-g-id {:ns new-ns :form new-form}))) 109 | [?type ?options ?constructor ?constructor-args ?predicate field-tuples ?opt+specs])) 110 | ;; generative, just return arguments. 111 | [?type ?options ?constructor ?constructor-args ?predicate field-tuples ?opt+specs]))) 112 | )) 113 | 114 | 115 | ;;; record_*_internals helpers 116 | #?(:clj 117 | (defn report-lens-deprecation [type] 118 | (println (str "active.clojure.record WARNING for record-type `" type 119 | "`: the explicit definition of lenses is deprecated in favor of regular " 120 | "accessors already being lenses")))) 121 | 122 | #?(:clj 123 | (defn reference 124 | [name] 125 | (str "[[" (ns-name *ns*) "/" name "]]"))) 126 | 127 | #?(:clj 128 | (defn name-spec 129 | [field] 130 | (or (:spec (meta field)) 131 | `any?))) 132 | 133 | #?(:clj 134 | (defn name-doc 135 | [field] 136 | (if-let [doc (:doc (meta field))] 137 | (str " (" doc ")") 138 | ""))) 139 | 140 | #?(:clj 141 | (defn document-with-arglist 142 | [n arglist doc] 143 | (vary-meta n 144 | (fn [m] 145 | (let [m (if (contains? m :doc) 146 | m 147 | (assoc m :doc doc))] 148 | (if (contains? m :arglists) 149 | m 150 | (assoc m :arglists `'(~arglist)))))))) 151 | 152 | #?(:clj 153 | (defn add-meta 154 | [sym meta-info] 155 | (vary-meta sym (fn [m] (merge meta-info m))))) 156 | 157 | #?(:clj 158 | (defn validate-fields! 159 | "Checks if magics are used in field-names, throws if present" 160 | [fields] 161 | (let [specials '#{__meta __hash __hasheq __extmap}] 162 | (when (some specials fields) 163 | (throw (AssertionError. (str "The names in " specials " cannot be used as field names for types or records."))))))) 164 | 165 | ;;; Helper functions for emit-*-record-defintion 166 | #?(:clj 167 | (defn add-predicate-doc [type predicate docref] 168 | (document-with-arglist predicate '[thing] (str "Is object a `" type "` record? " docref)))) 169 | 170 | 171 | #?(:clj 172 | (defn add-constructor-doc [constructor constructor-args type field-tuples] 173 | (document-with-arglist 174 | constructor 175 | (vec constructor-args) 176 | (str "Construct a `" type "`" 177 | (name-doc type) 178 | " record.\n" 179 | (apply str 180 | (map (fn [[?field ?accessor]] 181 | (str "\n`" ?field "`" (name-doc ?field) ": access via " (reference ?accessor))) 182 | field-tuples)))))) 183 | 184 | #?(:clj 185 | (defn add-accessor-doc [accessor type field docref] 186 | (document-with-arglist accessor 187 | (vector type) 188 | (str "Lens for the `" field "` field" 189 | (name-doc field) 190 | " from a [[" type "]] record. " docref)))) 191 | 192 | #?(:clj 193 | (defn add-spec-code [spec-name predicate field-triples constructor-args constructor] 194 | `(do 195 | ;; Spec for a record type 196 | (spec/def ~spec-name 197 | (spec/and ~predicate 198 | ~@(map (fn [[?field ?accessor _]] 199 | `#(spec/valid? ~(name-spec ?field) (~?accessor %))) 200 | field-triples))) 201 | ;; Spec for constructor function 202 | ~(let [c-specs (mapcat (fn [constructor-arg] 203 | (let [field (first (filter #(= constructor-arg %) 204 | (map first field-triples)))] 205 | [(keyword constructor-arg) (name-spec field)])) 206 | constructor-args)] 207 | `(spec/fdef ~constructor 208 | :args (spec/cat ~@c-specs) 209 | :ret ~spec-name))))) 210 | 211 | 212 | 213 | #?(:clj 214 | (defn make-get-accessor-from-field-tuple-fn 215 | "Creating helper function for rtd-record generation" 216 | [type docref constructor field-tuples fields rtd-symbol meta-info] 217 | (fn [[field accessor]] 218 | (let [?rec `rec# 219 | ?data `data# 220 | ?v `v#] 221 | `(do 222 | (def ~(add-meta (add-accessor-doc accessor type field docref) meta-info) 223 | (lens/lens (fn [~?rec] 224 | ;; Get index of field, at commpile time 225 | ~(let [field-index-map (into {} (map-indexed (fn [i f] [f i]) fields)) 226 | i (field-index-map field)] 227 | `(println ~i) 228 | `(rrun/record-get ~rtd-symbol ~?rec ~i))) 229 | (fn [~?data ~?v] 230 | ;; can't be ~constructor because constructor may take fewer arguments 231 | (rrun/make-record ~rtd-symbol 232 | ~@(map (fn [[shove-field shove-accessor]] 233 | (if (= field shove-field) 234 | ?v 235 | `(~shove-accessor ~?data))) 236 | field-tuples)))))) 237 | )))) 238 | 239 | 240 | 241 | #?(:clj 242 | (defn define-record-type-descriptor [meta-data type fields rtd-symbol] 243 | (let [meta+doc (merge meta-data {:doc (str "record-type-descriptor for type " type)}) 244 | record-type-symbol (symbol (str (ns-name *ns*)) (str type)) 245 | record-fields (mapv rrun/make-record-field fields)] 246 | `(def ~(add-meta rtd-symbol meta+doc) 247 | (rrun/make-record-type-descriptor '~record-type-symbol nil '~record-fields))))) 248 | 249 | (def record-identifier ::record) 250 | 251 | #?(:clj 252 | (defn define-type-function [type rtd-symbol predicate constructor args field-tuples] 253 | (let [sym-fn (fn [a] (str *ns* "/" a)) 254 | field-tuples-sym (mapv (fn [[name accessor]] [(str name) (sym-fn accessor)]) field-tuples) 255 | additional-meta {:t record-identifier 256 | :rtd (sym-fn rtd-symbol) 257 | :predicate (sym-fn predicate) 258 | :constructor (sym-fn constructor) 259 | :args (mapv str args) 260 | :field-tuples field-tuples-sym}] 261 | 262 | `(def ~(add-meta type additional-meta) 263 | ~rtd-symbol)))) 264 | 265 | 266 | (defn throw-different-args-count 267 | [constructor-symbol constructor-args-count given-args-count] 268 | (let [exception-string (str constructor-symbol " takes " constructor-args-count 269 | " arguments. Got: " given-args-count ".")] 270 | #?(:clj (throw (Exception. exception-string)) 271 | :cljs (throw (js/Error. exception-string))))) 272 | 273 | #?(:clj 274 | (defn define-constructor-rtd 275 | "Defines a constructor based on a record-constructor-fn. This function takes one argument, a list of field symbols." 276 | [type make-record constructor-symbol constructor-args-symbols field-tuples meta-data] 277 | (let [sym-with-meta+doc (-> constructor-symbol 278 | (add-constructor-doc constructor-args-symbols type field-tuples) 279 | (add-meta meta-data))] 280 | 281 | `(def ~sym-with-meta+doc 282 | ~(if (> (count constructor-args-symbols) 20) 283 | `(fn [~'& many-args#] 284 | (when (not= ~(count constructor-args-symbols) 285 | (count many-args#)) 286 | (throw-different-args-count ~constructor-symbol ~(count constructor-args-symbols) (count many-args#))) 287 | (apply ~make-record 288 | many-args#)) 289 | `(fn [~@constructor-args-symbols] 290 | (~make-record 291 | ~@(map (fn [[field _]] 292 | (if (contains? (set constructor-args-symbols) field) 293 | `~field 294 | nil)) 295 | field-tuples)))))))) 296 | 297 | (let [p-yank (fn p-yank [constructor lenses v] 298 | (apply constructor (map #(lens/yank v %) lenses))) 299 | p-shove (fn p-shove [field-lenses lenses data v] 300 | (reduce (fn [data [lens value]] 301 | (lens/shove data lens value)) 302 | data 303 | (map (fn [lens flens] 304 | [lens (lens/yank v flens)]) 305 | lenses 306 | field-lenses)))] 307 | (defn into-record-projection-lens 308 | "Construtor for a lens that projects a data structure into a record with 309 | `constructor` and `field-lenses`. 310 | Returns a function that accepts `lenses` that will to map the `field-lenses` 311 | in the projection." 312 | [constructor & field-lenses] 313 | (fn [& lenses] 314 | (assert (= (count lenses) (count field-lenses))) 315 | (lens/lens (f/partial p-yank constructor lenses) 316 | (f/partial p-shove field-lenses lenses))))) 317 | 318 | (defn options-projection-lens-constructor [opts] 319 | (or (:projection-lens-constructor opts) 320 | (:projection-lens opts))) 321 | 322 | #?(:clj 323 | (defn emit-own-record-definition [type options constructor constructor-args predicate field-tuples opt+specs] 324 | 325 | (let [?docref (str "See " (reference constructor) ".") 326 | fields (mapv first field-tuples) 327 | _ (validate-fields! fields) 328 | rtd-symbol (gensym (str type "-rtd-gensym-")) 329 | meta-data (meta type) 330 | 331 | field-triple->accessor (make-get-accessor-from-field-tuple-fn 332 | type ?docref constructor field-tuples fields rtd-symbol meta-data)] 333 | 334 | 335 | `(do 336 | ~(when-let [projection-lens (options-projection-lens-constructor options)] 337 | `(declare ~projection-lens)) 338 | (declare ~@(map second field-tuples)) 339 | 340 | ~(define-record-type-descriptor meta-data type fields rtd-symbol) 341 | 342 | 343 | ;; Predicate 344 | (def ~(add-meta (add-predicate-doc type predicate ?docref) meta-data) 345 | (rrun/record-type-predicate ~rtd-symbol)) 346 | 347 | ;; Constructor 348 | ;; We are defining a anonymous function for the define constructor function. 349 | ;; Since this function cannot be constructed in clj, we need to it at runtime. 350 | ;; To make the symbol `a` known to both, we define it before-hand in macro expansion 351 | ~(let [a (gensym)] 352 | `(let [~a (fn [& x#] (apply rrun/make-record ~rtd-symbol x#))] 353 | ~(define-constructor-rtd type 354 | a constructor constructor-args field-tuples meta-data))) 355 | 356 | ;; Accessors 357 | ~@(map field-triple->accessor field-tuples) 358 | 359 | ;; Specs 360 | ~(when-let [spec-name (:spec options)] 361 | (add-spec-code spec-name predicate field-tuples constructor-args constructor)) 362 | 363 | ~(define-type-function type rtd-symbol predicate constructor constructor-args field-tuples) 364 | 365 | ;; Projection lens 366 | ~(when-let [projection-lens (options-projection-lens-constructor options)] 367 | `(def ~(vary-meta (symbol projection-lens) (fn [m] (merge meta-data m))) 368 | (into-record-projection-lens ~constructor ~@(mapv second field-tuples)))))))) 369 | -------------------------------------------------------------------------------- /src/active/clojure/sum_type.cljc: -------------------------------------------------------------------------------- 1 | (ns active.clojure.sum-type 2 | (:require 3 | #?(:clj [active.clojure.record :as record] 4 | :cljs [active.clojure.cljs.record :as record :include-macros true]) 5 | [active.clojure.record-helper :as record-helper] 6 | [active.clojure.record-runtime :as record-runtime] 7 | #?(:clj [active.clojure.lens :as lens] 8 | :cljs [active.clojure.lens :as lens :include-macros true]))) 9 | 10 | 11 | (def ^:private sum-type-identifier ::sum-type) 12 | 13 | (defn- debug-info-str [debug-info] 14 | (str "in " (:ns debug-info) ", line: " (:line debug-info) ", column: " (:column debug-info))) 15 | 16 | #?(:clj 17 | (defn- throw-illegal-argument-exception [^java.lang.String msg] 18 | (throw (new java.lang.IllegalArgumentException msg)))) 19 | 20 | #?(:clj 21 | (defn- metadata 22 | "Returns metadata depending on the environment, clj or cljs. 23 | If cljs, env is defined, else we assume clj." 24 | [t env] 25 | (if (:ns env) 26 | ;; we resolve cljs.analyzer.api here to make utilizing the 27 | ;; same source file possible for both, cljs & clj 28 | (:meta ((resolve 'cljs.analyzer.api/resolve) env t)) 29 | (meta (resolve t))))) 30 | 31 | 32 | #?(:clj 33 | (defn- resolve-qualified-str 34 | "Returns a string representing the namespace-qualified symbol 35 | depending on the environment, clj or cljs. 36 | If cljs, env is defined, else we assume clj." 37 | [t env] 38 | (if (:ns env) 39 | ;; we resolve cljs.analyzer.api here to make utilizing the 40 | ;; same source file possible for both, cljs & clj 41 | (str (:name ((resolve 'cljs.analyzer.api/resolve) env t))) 42 | (str (:ns (meta (resolve t))) "/" (:name (meta (resolve t))))))) 43 | 44 | (record/define-record-type ^:no-doc SumTypeDescriptor 45 | (make-sum-type-descriptor name sub-types) 46 | sum-type-descriptor? 47 | [name sum-type-descriptor-name 48 | sub-types sum-type-descriptor-sub-types]) 49 | 50 | (defn ^:no-doc value-of-sum-type? [v sum-type] 51 | (boolean (some (fn [t] 52 | (cond 53 | (sum-type-descriptor? t) (value-of-sum-type? v t) 54 | (record-runtime/record-type-descriptor? t) (record-runtime/record-of-type? v t) 55 | :else 56 | (do (assert false t) false) ;; should not happen? 57 | )) 58 | (sum-type-descriptor-sub-types sum-type)))) 59 | 60 | 61 | ;; a clause is one of the following: 62 | ;; - ClauseWithPredicate, describing a matching clause based on a prediate 63 | ;; - DefaultClause, describing a matching clause based on the special form :default 64 | ;; - ClauseWithExtraction, describing a matching clause based on a constructor 65 | 66 | (record/define-record-type ^:private ClauseWithPredicate 67 | (make-clause-with-predicate predicate body) clause-with-predicate? 68 | [predicate clause-with-predicate-predicate 69 | body clause-with-predicate-body]) 70 | 71 | (record/define-record-type ^:private DefaultClause 72 | (make-default-clause body) default-clause? 73 | [body default-clause-body]) 74 | 75 | (record/define-record-type ^:private ClauseWithExtraction 76 | (make-clause-with-extraction constructor-symbol named-params body) clause-with-extraction? 77 | [constructor-symbol clause-with-extraction-constructor-symbol 78 | named-params clause-with-extraction-named-params 79 | body clause-with-extraction-body]) 80 | 81 | 82 | 83 | 84 | 85 | (defn- order-accessors-1 [args field-tuples] 86 | (let [accessor-map (into {} field-tuples)] 87 | (mapv #(vector % (get accessor-map %)) args))) 88 | 89 | (defn- order-accessors 90 | "Orders the accessors `:field-tuples` according to the args in `:args`. 91 | Does nothing if sum-type meta instead of record meta passed. 92 | Returns a meta." 93 | [meta] 94 | (if (= sum-type-identifier (:t meta)) 95 | meta 96 | (let [args (:args meta) 97 | field-tuples (:field-tuples meta)] 98 | (assoc meta :field-tuples 99 | (order-accessors-1 args field-tuples))))) 100 | 101 | 102 | #?(:clj 103 | (defn- get-predicate [s env] 104 | (:predicate (metadata s env)))) 105 | 106 | 107 | (defn- sum-type-meta? [meta] 108 | (= sum-type-identifier (:t meta))) 109 | 110 | (defn- record-type-meta? [meta] 111 | (= record-helper/record-identifier (:t meta))) 112 | 113 | (defn- record-or-sum-type-meta? [meta] 114 | (or 115 | (record-type-meta? meta) 116 | (sum-type-meta? meta))) 117 | 118 | 119 | 120 | #?(:clj 121 | (defn- find-illegal-types [type-symbols env] 122 | (filter 123 | (fn [t] (not (record-or-sum-type-meta? (metadata t env)))) 124 | type-symbols))) 125 | 126 | 127 | #?(:clj 128 | (defn- throw-illegal-types! [t] 129 | (throw-illegal-argument-exception 130 | (apply str "rtd-record or sum-type required, found: " (clojure.string/join ", " t))))) 131 | 132 | #?(:clj 133 | (defn- throw-when-illegal-types! [type-symbols env] 134 | (let [illegal-types (find-illegal-types type-symbols env)] 135 | (when-not (empty? illegal-types) 136 | (throw-illegal-types! illegal-types))))) 137 | 138 | 139 | #?(:clj 140 | (defn- add-meta 141 | [sym meta-info] 142 | (vary-meta sym (fn [m] (merge meta-info m))))) 143 | 144 | 145 | #?(:clj 146 | (defmacro define-sum-type [type-name predicate type-symbols] 147 | 148 | 149 | (let [sym-fn (fn [a] (str *ns* "/" a)) 150 | resolved-type-symbols (mapv (comp symbol #(resolve-qualified-str % &env)) type-symbols) 151 | sum-type-meta {:predicate (sym-fn predicate) 152 | :t sum-type-identifier 153 | 154 | :sub-types 155 | (mapv #(-> (metadata % &env) 156 | (order-accessors) 157 | (dissoc :file) 158 | (dissoc :meta) 159 | (dissoc :end-line) 160 | (dissoc :end-column) 161 | (dissoc :name) ; this leads to a crash in clj 162 | (dissoc :column)) type-symbols)} 163 | arg (gensym "arg")] 164 | 165 | (throw-when-illegal-types! type-symbols &env) 166 | 167 | 168 | `(do 169 | (defn ~predicate [~arg] 170 | ;; we could use [[value-of-sum-type?]], but this is an optimized compiled version: 171 | (or ~@(map (fn [p] (list p arg)) 172 | (mapv #(symbol (get-predicate % &env)) resolved-type-symbols)))) 173 | 174 | (def ~(add-meta type-name sum-type-meta) 175 | (make-sum-type-descriptor '~type-name (vector ~@resolved-type-symbols))))))) 176 | 177 | 178 | 179 | 180 | #?(:clj 181 | (defn- parse-clauses 182 | "Translates clauses into an internal representation" 183 | [paired-clauses] 184 | (mapv 185 | (fn [[condition body]] 186 | (cond 187 | (list? condition) 188 | (make-clause-with-extraction (first condition) (vec (rest condition)) body) 189 | 190 | (= :default condition) 191 | (make-default-clause body) 192 | 193 | :else 194 | (make-clause-with-predicate condition body))) 195 | 196 | paired-clauses))) 197 | 198 | 199 | 200 | #?(:clj 201 | (defn- has-default? [parsed-clauses debug] 202 | ;; checks if clauses contains default clause and if it is the last clause 203 | ;; throws if position of default (last) is violated 204 | ;; returns true if default is found iff in last position, false else 205 | (if (some default-clause? parsed-clauses) 206 | (do 207 | (if-not (default-clause? (last parsed-clauses)) 208 | (throw (IllegalArgumentException. (str "Default clause only allowed as last clause " (debug-info-str debug)))) 209 | true)) 210 | false))) 211 | 212 | 213 | (defn- collect-constr-symbols [parsed-clauses] 214 | (->> parsed-clauses 215 | (filter clause-with-extraction?) 216 | (map clause-with-extraction-constructor-symbol))) 217 | 218 | 219 | (defn- collect-pred-symbols [parsed-clauses] 220 | (->> parsed-clauses 221 | (filter clause-with-predicate?) 222 | (map clause-with-predicate-predicate))) 223 | 224 | 225 | (defn- expand-default-clause-cljs [clause] 226 | (let [body (default-clause-body clause)] 227 | [:default body])) 228 | 229 | 230 | (defn- expand-clause-with-predicate-cljs [arg clause] 231 | (let [pred-sym (clause-with-predicate-predicate clause) 232 | body (clause-with-predicate-body clause)] 233 | [(list pred-sym arg) body])) 234 | 235 | 236 | (defn- expand-clause-with-extraction-cljs [constr-lookup arg clause] 237 | (let [constr-sym (clause-with-extraction-constructor-symbol clause) 238 | body (clause-with-extraction-body clause) 239 | constr-args (clause-with-extraction-named-params clause) 240 | pred (:predicate (get constr-lookup constr-sym)) 241 | accessors (mapv second (:field-tuples (get constr-lookup constr-sym)))] 242 | 243 | [(list (symbol pred) arg) 244 | (list 'let 245 | (vec 246 | (mapcat identity 247 | (map-indexed (fn [idx constr-arg] [constr-arg (list 'active.clojure.lens/yank arg 248 | (symbol (accessors idx)))]) 249 | constr-args))) 250 | body)])) 251 | 252 | 253 | (defn- expand-clause-cljs [constr-lookup arg clause] 254 | (cond 255 | (default-clause? clause) 256 | (expand-default-clause-cljs clause) 257 | 258 | (clause-with-predicate? clause) 259 | (expand-clause-with-predicate-cljs arg clause) 260 | 261 | (clause-with-extraction? clause) 262 | (expand-clause-with-extraction-cljs constr-lookup arg clause))) 263 | 264 | 265 | #?(:clj 266 | (def ^:no-doc runtime-error throw-illegal-argument-exception) 267 | 268 | :cljs 269 | (defn ^:no-doc runtime-error [msg] 270 | (throw (js/Error. msg)))) 271 | 272 | 273 | (defn- expand-clauses-cljs [constr-lookup arg parsed-clauses st] 274 | (let [arg-symbol (gensym) 275 | constr-lookup-sym (gensym)] 276 | (list 'let [arg-symbol arg] 277 | (list 'if (list (symbol (:predicate st)) arg-symbol) 278 | (apply list 'cond 279 | (mapcat #(expand-clause-cljs constr-lookup arg-symbol %) parsed-clauses)) 280 | (list 'active.clojure.sum-type/runtime-error `(str "Argument not of type " ~(:predicate st) 281 | ". Argument: " ~arg-symbol)))))) 282 | 283 | 284 | #?(:clj 285 | (defn- resolved-symbol-lookup 286 | "Creates a map from symbol to namespace qualified symbol strings" 287 | [symbols env] 288 | (into {} (mapv (fn [s] [s (resolve-qualified-str s env)]) symbols)))) 289 | 290 | 291 | (defn- filter-tree 292 | "Finds nodes matching predicate in the type-tree" 293 | [predicate tree] 294 | (concat 295 | (if (predicate tree) [tree] []) 296 | (mapcat #(filter-tree predicate %) (:sub-types tree)))) 297 | 298 | 299 | (defn- filter-predicate 300 | "Finds a node containing the given predicate symbol string in the type-tree" 301 | [pred-symbol tree] 302 | (first (filter-tree #(= pred-symbol (:predicate %)) tree))) 303 | 304 | (defn- filter-constructor 305 | "Finds a node containing the given constructor symbol string in the type-tree" 306 | [constr-symbol tree] 307 | (first (filter-tree #(= constr-symbol (:constructor %)) tree))) 308 | 309 | 310 | #?(:clj 311 | (defn- throw-non-type-functions! [t st debug] 312 | (throw-illegal-argument-exception 313 | (apply str "The following functions don't belong to records or sum-types of type `" 314 | st "`: " (clojure.string/join ", " t) 315 | " " (debug-info-str debug))))) 316 | 317 | 318 | (defn- find-non-type-functions [tree symbols] 319 | (filter #(not (or (filter-constructor % tree) (filter-predicate % tree))) symbols)) 320 | 321 | 322 | #?(:clj 323 | (defn- throw-when-non-type-functions! 324 | "Throws if fun-symbols contains functions that are neither 325 | a predicate nor a constructor in the type-tree" 326 | [tree fun-symbols t debug] 327 | (let [non-type-functions (find-non-type-functions tree fun-symbols)] 328 | (when-not (empty? non-type-functions) 329 | (throw-non-type-functions! non-type-functions t debug))))) 330 | 331 | 332 | (defn- constr-or-pred?-fn [sym] 333 | (fn [tree] 334 | (or 335 | (= sym (:constructor tree)) 336 | (= sym (:predicate tree))))) 337 | 338 | 339 | (defn- colorize 340 | "Colorizes a node if pred matches (that is, setting colored? to `true`" 341 | [pred tree] 342 | (let [t (if (pred tree) 343 | (assoc tree :colored? true) 344 | tree) 345 | children (:sub-types t)] 346 | (if children 347 | (assoc t :sub-types (map #(colorize pred %) children)) 348 | t))) 349 | 350 | 351 | (defn- find-non-colored-leafs 352 | "Finds non-colored leafs by recursion. Stops descending if colored intermediate node occurs" 353 | [tree] 354 | (cond 355 | (:colored? tree) [] 356 | (:sub-types tree) (mapcat find-non-colored-leafs (:sub-types tree)) 357 | :default [tree])) 358 | 359 | 360 | (defn- find-not-covered 361 | "Finds all predicates in the type-tree that are not covered by symbols" 362 | [tree symbols] 363 | (->> symbols 364 | (reduce (fn [tree sym] (colorize (constr-or-pred?-fn sym) tree)) tree) 365 | (find-non-colored-leafs) 366 | (map :predicate))) 367 | 368 | #?(:clj 369 | (defn- throw-not-exhaustive! [t st debug] 370 | (throw-illegal-argument-exception 371 | (apply str "Arguments of the following types will fail matching of type `" st 372 | "`: " (clojure.string/join ", " t) " " (debug-info-str debug))))) 373 | 374 | 375 | #?(:clj 376 | (defn- throw-when-not-exhaustive! 377 | "Throws IllegalArgumentException if matching is not exhaustive" 378 | [tree symbols t debug] 379 | (let [not-covered (find-not-covered tree symbols)] 380 | (when-not (empty? not-covered) 381 | (throw-not-exhaustive! not-covered t debug))))) 382 | 383 | 384 | #?(:clj 385 | (defn- throw-when-not-sum-type-meta 386 | "Throws IllegalArgumentException if first param is no sum-type" 387 | [m sym debug] 388 | (when-not (sum-type-meta? m) 389 | (throw-illegal-argument-exception (str "First param `" sym "` is no sum-type " (debug-info-str debug)))))) 390 | 391 | #?(:clj 392 | (defn- throw-when-not-even 393 | "Throws IllegalArgumentException if clauses has no even length" 394 | [clauses debug] 395 | (when-not (zero? (mod (count clauses) 2)) 396 | (throw-illegal-argument-exception (str "`match` takes an even number of clauses " (debug-info-str debug)))))) 397 | 398 | #?(:clj 399 | (defn- throw-when-not-a-symbol 400 | "Throws IllegalArgumentException if ?sym is not a symbol" 401 | [?sym debug] 402 | (when-not (symbol? ?sym) 403 | (throw-illegal-argument-exception (str ?sym " must be a symbol " (debug-info-str debug)))))) 404 | 405 | #?(:clj 406 | (defn- debug-info [form ns] 407 | (assoc (meta form) :ns (str ns)))) 408 | 409 | 410 | #?(:clj 411 | (defmacro match 412 | "Takes a sum-type, a argument and a list of clauses, and expands it to a cond form. 413 | `sum-type` is a type identifier, as defined by `define-sum-type`. 414 | `arg` is the argument to be matched upon. 415 | `clauses` are pairs of conditions and bodies, e.g.: 416 | 417 | `(match rgb-color a 418 | red? \"red\" 419 | (make-green a) (str \"Green with \" a) 420 | blue? \"blue\") 421 | ` 422 | 423 | There is also a default clause, denoted by the keyword `:default` as the condition. 424 | 425 | This macro throws at compile time if (ordered): 426 | - `sum-type` is no symbol 427 | - `sum-type` doesn't resolve to a sum-type 428 | - an uneven number of clauses is passed 429 | - conditions contain a non-related function, that is, not a predicate or constructor of 430 | the passed sum-type in `sum-type`. 431 | - The matching is not exhaustive, i.e. a particular predicate/constrcutor is missing. 432 | 433 | The resulting form throws at runtime if the passed argument is not of type `sum-type`" 434 | 435 | [sum-type arg & clauses] 436 | 437 | (let [debug (debug-info &form *ns*) 438 | _ (throw-when-not-a-symbol sum-type debug) 439 | sum-type-meta (metadata sum-type &env) 440 | _ (throw-when-not-sum-type-meta sum-type-meta sum-type debug) 441 | _ (throw-when-not-even clauses debug) 442 | paired-clauses (partition 2 clauses) 443 | parsed-clauses (parse-clauses paired-clauses) 444 | pred-symbols (collect-pred-symbols parsed-clauses) 445 | constr-symbols (collect-constr-symbols parsed-clauses) 446 | resolved-pred-symbols (map #(resolve-qualified-str % &env) pred-symbols) 447 | resolved-constr-symbol-lookup (resolved-symbol-lookup constr-symbols &env) 448 | constr->predicate-lookup (->> resolved-constr-symbol-lookup 449 | (mapv (fn [[k v]] 450 | [k (filter-constructor v sum-type-meta)])) 451 | (into {})) 452 | 453 | resolved-function-symbols (concat resolved-pred-symbols 454 | (map second resolved-constr-symbol-lookup))] 455 | 456 | 457 | (throw-when-non-type-functions! sum-type-meta resolved-function-symbols sum-type debug) 458 | 459 | (when (not (has-default? parsed-clauses debug)) 460 | (throw-when-not-exhaustive! sum-type-meta resolved-function-symbols sum-type debug)) 461 | 462 | (expand-clauses-cljs constr->predicate-lookup arg parsed-clauses sum-type-meta)))) 463 | -------------------------------------------------------------------------------- /src/active/clojure/record_clj_internals.clj: -------------------------------------------------------------------------------- 1 | (ns ^:no-doc active.clojure.record-clj-internals 2 | (:require [active.clojure.condition :as c] 3 | [active.clojure.record-helper :as r-help]) 4 | (:import clojure.lang.IPersistentMap 5 | clojure.lang.RT 6 | java.lang.IllegalArgumentException)) 7 | 8 | 9 | 10 | #_(defrecord RecordMeta 11 | ;; unresolved store for record related symbols. May not leak outside this 12 | ;; namespace. Contains ns to allow post-macro qualification; see `record-meta` function. 13 | [predicate constructor ordered-accessors]) 14 | 15 | (defmacro resolve* 16 | [& args] 17 | `(resolve ~@args)) 18 | 19 | (defmacro intern* 20 | [& args] 21 | `(intern ~@args)) 22 | 23 | #_(defmacro make-record-meta 24 | [?predicate ?constructor ?constructor-args ?field-triples] 25 | ;; we need to internalize symbols to ns resolve them 26 | (intern* *ns* ?predicate) 27 | (intern* *ns* ?constructor) 28 | (->RecordMeta 29 | (resolve* ?predicate) (resolve* ?constructor) 30 | (mapv (fn [constr] 31 | (let [accessor (second (first (filter #(= (first %) constr) ?field-triples)))] 32 | (intern* *ns* accessor) 33 | (resolve* accessor))) 34 | ?constructor-args))) 35 | 36 | (defn- document 37 | [n doc] 38 | (vary-meta n 39 | (fn [m] 40 | (if (contains? m :doc) 41 | m 42 | (assoc m :doc doc))))) 43 | 44 | (defn ns-keyword 45 | "Takes a symbol or string `the-name-sym` and returns a namespaced keyword 46 | based on that symbol. 47 | 48 | Example: `(ns-keyword 'foo) => :calling.name.space/foo`" 49 | [the-name-sym] 50 | (if the-name-sym 51 | (keyword (str (ns-name *ns*)) (str the-name-sym)) 52 | (c/assertion-violation `ns-keyword "argument must not be nil" the-name-sym))) 53 | 54 | (defn ^{:private true} 55 | maybe-destructured 56 | [params body] 57 | (if (every? symbol? params) 58 | (cons params body) 59 | (loop [params params 60 | new-params (with-meta [] (meta params)) 61 | lets []] 62 | (if params 63 | (if (symbol? (first params)) 64 | (recur (next params) (conj new-params (first params)) lets) 65 | (let [gparam (gensym "p__")] 66 | (recur (next params) (conj new-params gparam) 67 | (-> lets (conj (first params)) (conj gparam))))) 68 | `(~new-params 69 | (let ~lets 70 | ~@body)))))) 71 | 72 | (defn- parse-opts [s] 73 | (loop [opts {} [k v & rs :as s] s] 74 | (if (keyword? k) 75 | (recur (assoc opts k v) rs) 76 | [opts s]))) 77 | 78 | (defn- parse-impls [specs] 79 | (loop [ret {} s specs] 80 | (if (seq s) 81 | (recur (assoc ret (first s) (take-while seq? (next s))) 82 | (drop-while seq? (next s))) 83 | ret))) 84 | 85 | (defn- parse-opts+specs [opts+specs] 86 | (let [[opts specs] (parse-opts opts+specs) 87 | impls (parse-impls specs) 88 | 89 | interfaces+methods 90 | (into {} (for [[i methods] impls] 91 | [(if (var? (resolve i)) 92 | (:on (deref (resolve i))) 93 | i) 94 | (map (fn [[name params & body]] 95 | (cons name (maybe-destructured params body))) 96 | methods)]))] 97 | (when-let [bad-opts (seq (remove #{:no-print :load-ns} (keys opts)))] 98 | (let [^String msg (apply print-str "Unsupported option(s) -" bad-opts)] 99 | (throw (IllegalArgumentException. msg)))) 100 | [interfaces+methods opts])) 101 | 102 | (defn- imap-cons 103 | [^IPersistentMap this o] 104 | (cond 105 | (map-entry? o) 106 | (let [^java.util.Map$Entry pair o] 107 | (.assoc this (.getKey pair) (.getValue pair))) 108 | (instance? clojure.lang.IPersistentVector o) 109 | (let [^clojure.lang.IPersistentVector vec o] 110 | (.assoc this (.nth vec 0) (.nth vec 1))) 111 | :else (loop [this this 112 | o o] 113 | (if (seq o) 114 | (let [^java.util.Map$Entry pair (first o)] 115 | (recur (.assoc this (.getKey pair) (.getValue pair)) (rest o))) 116 | this)))) 117 | 118 | (defn- override-default-methods 119 | [default-interfaces+methods provided-interfaces+methods] 120 | (into {} 121 | (for [[i ms] default-interfaces+methods] 122 | (if-let [new-methods (get provided-interfaces+methods i)] 123 | [i 124 | ;; Remove methods that are provided and concat the provided ones 125 | (concat (remove (fn [[name & rest]] 126 | (some #(= (clojure.core/name name) %) 127 | (map (comp clojure.core/name first) new-methods))) 128 | ms) 129 | new-methods)] 130 | [i ms])))) 131 | 132 | (defn- add-provided-interfaces+methods 133 | [default-interfaces+methods provided-interfaces+methods] 134 | (merge default-interfaces+methods 135 | (into {} 136 | (remove (fn [[i ms]] 137 | (get default-interfaces+methods i)) 138 | provided-interfaces+methods)))) 139 | 140 | (defn- emit-defrecord 141 | "Do not use this directly - use defrecord" 142 | {:added "1.2"} 143 | [tagname cname fields interfaces+methods opts] 144 | (let [classname (with-meta (symbol (str (namespace-munge *ns*) "." cname)) (meta cname)) 145 | interfaces (vec (keys interfaces+methods)) 146 | methods (vec (vals interfaces+methods)) 147 | interface-set (set (map resolve interfaces)) 148 | methodname-set (set (map first (apply concat methods))) 149 | hinted-fields fields 150 | fields (vec (map #(with-meta % nil) fields)) 151 | base-fields fields 152 | fields (conj fields '__meta '__extmap 153 | '^:unsynchronized-mutable __hash 154 | '^:unsynchronized-mutable __hasheq) 155 | type-hash (hash classname)] 156 | (when (some #{:volatile-mutable :unsynchronized-mutable} (mapcat (comp keys meta) hinted-fields)) 157 | (throw (IllegalArgumentException. ":volatile-mutable or :unsynchronized-mutable not supported for record fields"))) 158 | (let 159 | [gs (gensym) 160 | 161 | default-interfaces+methods 162 | {'clojure.lang.IRecord [] 163 | 164 | 'clojure.lang.IHashEq 165 | [`(hasheq [this#] 166 | (let [hq# ~'__hasheq] 167 | (if (zero? hq#) 168 | (let [h# (int (bit-xor ~type-hash (clojure.lang.APersistentMap/mapHasheq this#)))] 169 | (set! ~'__hasheq h#) 170 | h#) 171 | hq#))) 172 | `(hashCode [this#] 173 | (let [hash# ~'__hash] 174 | (if (zero? hash#) 175 | (let [h# (clojure.lang.APersistentMap/mapHash this#)] 176 | (set! ~'__hash h#) 177 | h#) 178 | hash#))) 179 | `(equals [this# ~gs] (clojure.lang.APersistentMap/mapEquals this# ~gs))] 180 | 181 | 'clojure.lang.IObj 182 | [`(meta [this#] ~'__meta) 183 | `(withMeta [this# ~gs] (new ~tagname ~@(replace {'__meta gs} fields)))] 184 | 185 | 'clojure.lang.ILookup 186 | [`(valAt [this# k#] (.valAt this# k# nil)) 187 | `(valAt [this# k# else#] 188 | (case k# ~@(mapcat (fn [fld] [(keyword fld) fld]) 189 | base-fields) 190 | (get ~'__extmap k# else#))) 191 | `(getLookupThunk [this# k#] 192 | (let [~'gclass (class this#)] 193 | (case k# 194 | ~@(let [hinted-target (with-meta 'gtarget {:tag tagname})] 195 | (mapcat 196 | (fn [fld] 197 | [(keyword fld) 198 | `(reify clojure.lang.ILookupThunk 199 | (get [~'thunk ~'gtarget] 200 | (if (identical? (class ~'gtarget) ~'gclass) 201 | (. ~hinted-target ~(symbol (str "-" fld))) 202 | ~'thunk)))]) 203 | base-fields)) 204 | nil)))] 205 | 206 | 'clojure.lang.IKeywordLookup [] 207 | 208 | 'clojure.lang.IPersistentMap 209 | [`(count [this#] (+ ~(count base-fields) (count ~'__extmap))) 210 | `(empty [this#] (throw (UnsupportedOperationException. (str "Can't create empty: " ~(str classname))))) 211 | `(cons [this# e#] ((var imap-cons) this# e#)) 212 | `(equiv [this# ~gs] 213 | (boolean 214 | (or (identical? this# ~gs) 215 | (when (identical? (class this#) (class ~gs)) 216 | (let [~gs ~(with-meta gs {:tag tagname})] 217 | (and ~@(map (fn [fld] `(= ~fld (. ~gs ~(symbol (str "-" fld))))) base-fields) 218 | (= ~'__extmap (. ~gs ~'__extmap)))))))) 219 | `(containsKey [this# k#] (not (identical? this# (.valAt this# k# this#)))) 220 | `(entryAt [this# k#] (let [v# (.valAt this# k# this#)] 221 | (when-not (identical? this# v#) 222 | (clojure.lang.MapEntry/create k# v#)))) 223 | `(seq [this#] (seq (concat [~@(map #(list `clojure.lang.MapEntry/create (keyword %) %) base-fields)] 224 | ~'__extmap))) 225 | `(iterator [~gs] 226 | (clojure.lang.RecordIterator. ~gs [~@(map keyword base-fields)] (RT/iter ~'__extmap))) 227 | `(assoc [this# k# ~gs] 228 | (condp identical? k# 229 | ~@(mapcat (fn [fld] 230 | [(keyword fld) (list* `new tagname (replace {fld gs} (remove '#{__hash __hasheq} fields)))]) 231 | base-fields) 232 | (new ~tagname ~@(remove '#{__extmap __hash __hasheq} fields) (assoc ~'__extmap k# ~gs)))) 233 | `(without [this# k#] (if (contains? #{~@(map keyword base-fields)} k#) 234 | (dissoc (with-meta (into {} this#) ~'__meta) k#) 235 | (new ~tagname ~@(remove '#{__extmap __hash __hasheq} fields) 236 | (not-empty (dissoc ~'__extmap k#)))))] 237 | 238 | 'java.util.Map 239 | [`(size [this#] (.count this#)) 240 | `(isEmpty [this#] (= 0 (.count this#))) 241 | `(containsValue [this# v#] (boolean (some #{v#} (vals this#)))) 242 | `(get [this# k#] (.valAt this# k#)) 243 | `(put [this# k# v#] (throw (UnsupportedOperationException.))) 244 | `(remove [this# k#] (throw (UnsupportedOperationException.))) 245 | `(putAll [this# m#] (throw (UnsupportedOperationException.))) 246 | `(clear [this#] (throw (UnsupportedOperationException.))) 247 | `(keySet [this#] (set (keys this#))) 248 | `(values [this#] (vals this#)) 249 | `(entrySet [this#] (set this#))] 250 | 251 | 'java.io.Serializable [] 252 | } 253 | 254 | new-interfaces+methods 255 | (-> (override-default-methods default-interfaces+methods interfaces+methods) 256 | (add-provided-interfaces+methods interfaces+methods) 257 | ;; Remove not wanted interfaces 258 | ((fn [i+m] (apply dissoc i+m (concat (when (= false (:map-protocol? opts)) 259 | ['java.util.Map 'clojure.lang.IPersistentMap]) 260 | (:remove-interfaces opts)))))) 261 | 262 | ;; Remove `java.lang.Object` from interfaces. It isn't an interface 263 | interfaces (vec (remove #{'Object 'java.lang.Object} (keys new-interfaces+methods))) 264 | methods (apply concat (vec (vals new-interfaces+methods)))] 265 | `(deftype* ~(symbol (name (ns-name *ns*)) (name tagname)) ~classname 266 | ~(conj hinted-fields '__meta '__extmap 267 | '^int ^:unsynchronized-mutable __hash 268 | '^int ^:unsynchronized-mutable __hasheq) 269 | :implements ~interfaces 270 | ~@(mapcat identity opts) 271 | ~@methods)))) 272 | 273 | 274 | (defn- build-positional-factory 275 | "Used to build a positional factory for a given type/record. Because of the 276 | limitation of 20 arguments to Clojure functions, this factory needs to be 277 | constructed to deal with more arguments. It does this by building a straight 278 | forward type/record ctor call in the <=20 case, and a call to the same 279 | ctor pulling the extra args out of the & overage parameter. Finally, the 280 | arity is constrained to the number of expected fields and an ArityException 281 | will be thrown at runtime if the actual arg count does not match." 282 | [nom classname fields meta-data] 283 | (let [fn-name (symbol (str '-> nom)) 284 | [field-args over] (split-at 20 fields) 285 | field-count (count fields) 286 | arg-count (count field-args) 287 | over-count (count over) 288 | docstring (str "Positional factory function for class " classname ".")] 289 | `(defn ~(vary-meta fn-name (fn [m] (merge meta-data m))) 290 | ~docstring 291 | [~@field-args ~@(if (seq over) '[& overage] [])] 292 | ~(if (seq over) 293 | `(if (= (count ~'overage) ~over-count) 294 | (new ~classname 295 | ~@field-args 296 | ~@(for [i (range 0 (count over))] 297 | (list `nth 'overage i))) 298 | (throw (clojure.lang.ArityException. (+ ~arg-count (count ~'overage)) (name '~fn-name)))) 299 | `(new ~classname ~@field-args))))) 300 | 301 | 302 | ;;; Emit-*-record-definitions 303 | 304 | (defn make-get-accessor-from-field-tuple-fn 305 | [type docref constructor field-tuples meta-info] 306 | (fn [[field accessor lens]] 307 | (let [?rec (with-meta `rec# {:tag type}) 308 | ?data `data# 309 | ?v `v#] 310 | ;; Note that a two-arity function like this is a lens as defined by active.clojure.lens. 311 | `(defn ~(r-help/add-meta (r-help/add-accessor-doc accessor type field docref) meta-info) 312 | ([~?rec] 313 | (. ~?rec ~(symbol (str "-" field)))) 314 | ([~?data ~?v] 315 | ;; can't be ~constructor because constructor may take fewer arguments 316 | (new ~type ~@(map 317 | (fn [[?shove-field ?shove-accessor]] 318 | (if (= field ?shove-field) 319 | ?v 320 | `(~?shove-accessor ~?data))) 321 | field-tuples))))))) 322 | 323 | (defn emit-java-record-definition 324 | [type options constructor constructor-args predicate field-tuples opt+specs] 325 | (let [?docref (str "See " (r-help/reference constructor) ".") 326 | constructor-args-set (set constructor-args) 327 | meta-data (meta type)] 328 | `(do 329 | ~(when-let [projection-lens (r-help/options-projection-lens-constructor options)] 330 | `(declare ~projection-lens)) 331 | ;; This block is copy pasted from the original defrecord implementation & slightly altered 332 | (declare ~@(map (fn [[?field ?accessor ?lens]] ?accessor) field-tuples)) 333 | ~(let [fields (mapv first field-tuples) 334 | _ (r-help/validate-fields! fields) 335 | [interfaces+methods opts] (parse-opts+specs opt+specs) 336 | opts (merge opts options) 337 | ns-part (namespace-munge *ns*) 338 | classname (symbol (str ns-part "." type)) 339 | hinted-fields fields 340 | fields (vec (map #(with-meta % nil) fields))] 341 | `(do 342 | (declare ~(symbol (str '-> type))) 343 | (declare ~(symbol (str 'map-> type))) 344 | ~(emit-defrecord type type (vec hinted-fields) interfaces+methods opts) 345 | (import ~classname) 346 | ;; Create arrow constructor 347 | (when-not (= false (:arrow-constructor? ~options)) 348 | ~(build-positional-factory type classname fields meta-data)) 349 | (defn ~(vary-meta (symbol (str 'map-> type)) (fn [m] (merge meta-data m))) 350 | ~(str "Factory function for class " classname ", taking a map of keywords to field values.") 351 | ([m#] (~(symbol (str classname "/create")) 352 | (if (instance? clojure.lang.MapEquivalence m#) m# (into {} m#))))) 353 | ~classname)) 354 | 355 | 356 | ;; Predicate 357 | (def ~(r-help/add-meta (r-help/add-predicate-doc type predicate ?docref) meta-data) 358 | (partial instance? ~type)) 359 | 360 | 361 | ;; Constructor 362 | ;; We cannot use define-constructor here, since the number of argument of new 363 | ;; must be known at compile time and, thus, is not applyable. 364 | (def ~(r-help/add-meta (r-help/add-constructor-doc constructor constructor-args type field-tuples) meta-data) 365 | (fn [~@constructor-args] 366 | (new ~type 367 | ~@(map (fn [[?field _]] 368 | (if (contains? constructor-args-set ?field) 369 | `~?field 370 | `nil)) 371 | field-tuples)))) 372 | ;; Accessors 373 | ~@(map (make-get-accessor-from-field-tuple-fn type 374 | ?docref constructor field-tuples meta-data) 375 | field-tuples) 376 | 377 | ;; Specs 378 | ~(when-let [spec-name (:spec options)] 379 | (r-help/add-spec-code spec-name predicate field-tuples constructor-args constructor)) 380 | 381 | ;; When `map-protocol?` is `false`, we have to provide a print-method implementation 382 | ~(when (= false (:map-protocol? options)) 383 | (let [w (vary-meta `w# assoc :tag 'java.io.Writer) 384 | v `w#] 385 | `(defmethod print-method ~type [~v ~w] 386 | (.write ~w (str ~(str "#" *ns* "." type) 387 | (into {} ~(mapv (fn [[?field ?accessor _]] 388 | `(vector ~(keyword ?field) (~?accessor ~v))) 389 | field-tuples))))))) 390 | 391 | ;; Projection lens 392 | ~(when-let [projection-lens (r-help/options-projection-lens-constructor options)] 393 | `(def ~(vary-meta (symbol projection-lens) (fn [m] (merge meta-data m))) 394 | (r-help/into-record-projection-lens ~constructor ~@(mapv second field-tuples))))))) 395 | --------------------------------------------------------------------------------