diff --git a/.github/workflows/native-image-test.yml b/.github/workflows/native-image-test.yml index 3a2c5d0e..3783e04c 100644 --- a/.github/workflows/native-image-test.yml +++ b/.github/workflows/native-image-test.yml @@ -24,6 +24,13 @@ jobs: name: ${{ matrix.os }},jdk${{ matrix.java-version }},${{ matrix.test }},clj${{ matrix.clojure-version }} steps: + # + # Tell git not to convert newlines on checkout for Windows + # + - name: Prepare git (Windows) + run: git config --global core.autocrlf false + if: matrix.os == 'windows' + - name: Checkout uses: actions/checkout@v4 diff --git a/test-resources/code-samples/clojurescript/fa4b8d853be08120cb864782e4ea48826b9d757e/src/main/cljs/cljs/core.cljs b/test-resources/code-samples/clojurescript/fa4b8d853be08120cb864782e4ea48826b9d757e/src/main/cljs/cljs/core.cljs new file mode 100644 index 00000000..f11b3022 --- /dev/null +++ b/test-resources/code-samples/clojurescript/fa4b8d853be08120cb864782e4ea48826b9d757e/src/main/cljs/cljs/core.cljs @@ -0,0 +1,11876 @@ +; Copyright (c) Rich Hickey. All rights reserved. +; The use and distribution terms for this software are covered by the +; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +; which can be found in the file epl-v10.html at the root of this distribution. +; By using this software in any fashion, you are agreeing to be bound by +; the terms of this license. +; You must not remove this notice, or any other, from this software. + +(ns cljs.core + (:require goog.math.Long + goog.math.Integer + [goog.string :as gstring] + [goog.object :as gobject] + [goog.array :as garray] + [goog.Uri]) + (:import [goog.string StringBuffer])) + +;; next line is auto-generated by the build-script - Do not edit! +(def *clojurescript-version*) + +;; Setting of these Vars is in ClojureScript code is associated with intrinsics +;; that affect compilation state, but otherwise turn into no-ops in the emitted +;; JavaScript. + +;; The scope of *unchecked-if* is controlled by balanced pairs of set! calls. +(def *unchecked-if* false) +;; The scope of *unchecked-arrays* is file-scope: In JVM ClojureScript its side- +;; effect is to set same-named analyzer dynamic Var, which is unset via binding +;; scopes. In self-hosted it is cleared via cljs.js/post-file-side-effects. +(def *unchecked-arrays* false) +;; The scope of *warn-on-infer* is file-scope: Its side effect is to set the +;; cljs.analyzer/*cljs-warnings* dynamic Var, which is unset via binding scopes. +(def *warn-on-infer* false) + +(set! *unchecked-arrays* true) + +(defonce PROTOCOL_SENTINEL #js {}) + +(def MODULE_URIS nil) ;; set by compiler +(def MODULE_INFOS nil) ;; set by compiler + +(goog-define + ^{:dynamic true + :doc "Var bound to the name value of the compiler build :target option. + For example, if the compiler build :target is :nodejs, *target* will be bound + to \"nodejs\". *target* is a Google Closure define and can be set by compiler + :closure-defines option."} + *target* "default") + +(goog-define + ^{:dynamic true + :doc "Manually set the JavaScript global context. Only \"window\", \"self\" + , and \"global\" supported. "} + *global* "default") + +(def + ^{:dynamic true + :doc "Var bound to the current namespace. Only used for bootstrapping." + :jsdoc ["@type {*}"]} + *ns* nil) + +(def + ^{:dynamic true + :jsdoc ["@type {*}"]} + *out* nil) + +(def + ^{:dynamic true} + *assert* true) + +(defonce + ^{:doc "Each runtime environment provides a different way to print output. + Whatever function *print-fn* is bound to will be passed any + Strings which should be printed." :dynamic true} + *print-fn* nil) + +(declare boolean) + +(defn ^{:doc "Arranges to have tap functions executed via the supplied f, a + function of no arguments. Returns true if successful, false otherwise." :dynamic true} + *exec-tap-fn* + [f] + (and + (exists? js/setTimeout) + ;; See CLJS-3274 - workaround for recent WebKit releases + (boolean (js/setTimeout f 0)))) + +(defonce + ^{:doc "Each runtime environment provides a different way to print error output. + Whatever function *print-err-fn* is bound to will be passed any + Strings which should be printed." :dynamic true} + *print-err-fn* nil) + +(defn set-print-fn! + "Set *print-fn* to f." + [f] (set! *print-fn* f)) + +(defn set-print-err-fn! + "Set *print-err-fn* to f." + [f] (set! *print-err-fn* f)) + +(def + ^{:dynamic true + :doc "When set to true, output will be flushed whenever a newline is printed. + + Defaults to true."} + *flush-on-newline* true) + +(def + ^{:dynamic true + :doc "When set to logical false will drop newlines from printing calls. + This is to work around the implicit newlines emitted by standard JavaScript + console objects."} + *print-newline* true) + +(def + ^{:dynamic true + :doc "When set to logical false, strings and characters will be printed with + non-alphanumeric characters converted to the appropriate escape sequences. + + Defaults to true"} + *print-readably* true) + +(def + ^{:dynamic true + :doc "If set to logical true, when printing an object, its metadata will also + be printed in a form that can be read back by the reader. + + Defaults to false."} + *print-meta* false) + +(def + ^{:dynamic true + :doc "When set to logical true, objects will be printed in a way that preserves + their type when read in later. + + Defaults to false."} + *print-dup* false) + +(def + ^{:dynamic true + :doc "*print-namespace-maps* controls whether the printer will print + namespace map literal syntax. + + Defaults to false, but the REPL binds it to true."} + *print-namespace-maps* false) + +(def + ^{:dynamic true + :doc "*print-length* controls how many items of each collection the + printer will print. If it is bound to logical false, there is no + limit. Otherwise, it must be bound to an integer indicating the maximum + number of items of each collection to print. If a collection contains + more items, the printer will print items up to the limit followed by + '...' to represent the remaining items. The root binding is nil + indicating no limit." + :jsdoc ["@type {null|number}"]} + *print-length* nil) + +(def + ^{:dynamic true + :doc "*print-level* controls how many levels deep the printer will + print nested objects. If it is bound to logical false, there is no + limit. Otherwise, it must be bound to an integer indicating the maximum + level to print. Each argument to print is at level 0; if an argument is a + collection, its items are at level 1; and so on. If an object is a + collection and is at a level greater than or equal to the value bound to + *print-level*, the printer prints '#' to represent it. The root binding + is nil indicating no limit." + :jsdoc ["@type {null|number}"]} + *print-level* nil) + +(def + ^{:dynamic true + :doc "*print-fns-bodies* controls whether functions print their source or + only their names."} + *print-fn-bodies* false) + +(defonce + ^{:dynamic true + :jsdoc ["@type {*}"]} + *loaded-libs* nil) + +(defn- pr-opts [] + {:flush-on-newline *flush-on-newline* + :readably *print-readably* + :meta *print-meta* + :dup *print-dup* + :print-length *print-length*}) + +(declare into-array) + +(defn enable-console-print! + "Set *print-fn* to console.log" + [] + (set! *print-newline* false) + (set-print-fn! + (fn [] + (let [xs (js-arguments)] + (.apply (.-log js/console) js/console (garray/clone xs))))) + (set-print-err-fn! + (fn [] + (let [xs (js-arguments)] + (.apply (.-error js/console) js/console (garray/clone xs))))) + nil) + +(def + ^{:doc "bound in a repl thread to the most recent value printed"} + *1) + +(def + ^{:doc "bound in a repl thread to the second most recent value printed"} + *2) + +(def + ^{:doc "bound in a repl thread to the third most recent value printed"} + *3) + +(def + ^{:doc "bound in a repl thread to the most recent exception caught by the repl"} + *e) + +(defn truth_ + "Internal - do not use!" + [x] + (cljs.core/truth_ x)) + +(def not-native nil) + +(declare instance? Keyword) + +(defn ^boolean identical? + "Tests if 2 arguments are the same object" + [x y] + (cljs.core/identical? x y)) + +(defn ^boolean nil? + "Returns true if x is nil, false otherwise." + [x] + (coercive-= x nil)) + +(defn ^boolean array? + "Returns true if x is a JavaScript array." + [x] + (if (identical? *target* "nodejs") + (.isArray js/Array x) + (instance? js/Array x))) + +(defn ^boolean number? + "Returns true if x is a JavaScript number." + [x] + (cljs.core/number? x)) + +(defn not + "Returns true if x is logical false, false otherwise." + [x] + (cond + (nil? x) true + (false? x) true + :else false)) + +(defn ^boolean some? + "Returns true if x is not nil, false otherwise." + [x] (not (nil? x))) + +(defn object? + "Returns true if x's constructor is Object" + [x] + (if-not (nil? x) + (identical? (.-constructor x) js/Object) + false)) + +(defn ^boolean string? + "Returns true if x is a JavaScript string." + [x] + (goog/isString x)) + +(defn char? + "Returns true if x is a JavaScript string of length one." + [x] + (and (string? x) (== 1 (.-length x)))) + +(defn any? + "Returns true if given any argument." + [x] true) + +(set! *unchecked-if* true) +(defn native-satisfies? + "Internal - do not use!" + [p x] + (let [x (if (nil? x) nil x)] + (cond + (unchecked-get p (goog/typeOf x)) true + (unchecked-get p "_") true + :else false))) +(set! *unchecked-if* false) + +(defn is_proto_ + [x] + (identical? (.-prototype (.-constructor x)) x)) + +(def + ^{:doc "When compiled for a command-line target, whatever function + *main-cli-fn* is set to will be called with the command-line + argv as arguments"} + *main-cli-fn* nil) + +(def + ^{:doc "A sequence of the supplied command line arguments, or nil if + none were supplied"} + *command-line-args* nil) + +(defn type + "Return x's constructor." + [x] + (when-not (nil? x) + (.-constructor x))) + +(defn missing-protocol [proto obj] + (let [ty (type obj) + ty (if (and ty (.-cljs$lang$type ty)) + (.-cljs$lang$ctorStr ty) + (goog/typeOf obj))] + (js/Error. + (.join (array "No protocol method " proto + " defined for type " ty ": " obj) "")))) + +(defn type->str [ty] + (if-let [s (.-cljs$lang$ctorStr ty)] + s + (str ty))) + +;; INTERNAL - do not use, only for Node.js +(defn load-file [file] + (when-not js/COMPILED + (cljs.core/load-file* file))) + +(if (and (exists? js/Symbol) + (identical? (goog/typeOf js/Symbol) "function")) + (def ITER_SYMBOL (.-iterator js/Symbol)) + (def ITER_SYMBOL "@@iterator")) + +(def ^{:jsdoc ["@enum {string}"]} + CHAR_MAP + #js {"-" "_" + ":" "_COLON_" + "+" "_PLUS_" + ">" "_GT_" + "<" "_LT_" + "=" "_EQ_" + "~" "_TILDE_" + "!" "_BANG_" + "@" "_CIRCA_" + "#" "_SHARP_" + "'" "_SINGLEQUOTE_" + "\\\"" "_DOUBLEQUOTE_" + "%" "_PERCENT_" + "^" "_CARET_" + "&" "_AMPERSAND_" + "*" "_STAR_" + "|" "_BAR_" + "{" "_LBRACE_" + "}" "_RBRACE_" + "[" "_LBRACK_" + "]" "_RBRACK_" + "/" "_SLASH_" + "\\\\" "_BSLASH_" + "?" "_QMARK_"}) + +(def ^{:jsdoc ["@enum {string}"]} + DEMUNGE_MAP + #js {"_" "-" + "_COLON_" ":" + "_PLUS_" "+" + "_GT_" ">" + "_LT_" "<" + "_EQ_" "=" + "_TILDE_" "~" + "_BANG_" "!" + "_CIRCA_" "@" + "_SHARP_" "#" + "_SINGLEQUOTE_" "'" + "_DOUBLEQUOTE_" "\\\"" + "_PERCENT_" "%" + "_CARET_" "^" + "_AMPERSAND_" "&" + "_STAR_" "*" + "_BAR_" "|" + "_LBRACE_" "{" + "_RBRACE_" "}" + "_LBRACK_" "[" + "_RBRACK_" "]" + "_SLASH_" "/" + "_BSLASH_" "\\\\" + "_QMARK_" "?"}) + +(def DEMUNGE_PATTERN nil) + +(defn system-time + "Returns highest resolution time offered by host in milliseconds." + [] + (cond + (and (exists? js/performance) + (not (nil? (. js/performance -now)))) + (.now js/performance) + + (and (exists? js/process) + (not (nil? (. js/process -hrtime)))) + (let [t (.hrtime js/process)] + (/ (+ (* (aget t 0) 1e9) (aget t 1)) 1e6)) + + :else (.getTime (js/Date.)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; arrays ;;;;;;;;;;;;;;;; + +(declare apply) + +(defn ^array make-array + "Construct a JavaScript array of the specified dimensions. Accepts ignored + type argument for compatibility with Clojure. Note that there is no efficient + way to allocate multi-dimensional arrays in JavaScript; as such, this function + will run in polynomial time when called with 3 or more arguments." + ([size] + (js/Array. size)) + ([type size] + (make-array size)) + ([type size & more-sizes] + (let [dims more-sizes + dimarray (make-array size)] + (dotimes [i (alength dimarray)] + (aset dimarray i (apply make-array nil dims))) + dimarray))) + +(defn aclone + "Returns a javascript array, cloned from the passed in array" + [arr] + (let [len (alength arr) + new-arr (make-array len)] + (dotimes [i len] + (aset new-arr i (aget arr i))) + new-arr)) + +(defn ^array array + "Creates a new javascript array. +@param {...*} var_args" ;;array is a special case, don't emulate this doc string + [var-args] ;; [& items] + (let [a (js/Array. (alength (cljs.core/js-arguments)))] + (loop [i 0] + (if (< i (alength a)) + (do + (aset a i (aget (cljs.core/js-arguments) i)) + (recur (inc i))) + a)))) + +(defn- maybe-warn + [e] + (when *print-err-fn* + (*print-err-fn* e))) + +(defn- checked-aget + ([array idx] + (when-assert + (try + (assert (or (array? array) (goog/isArrayLike array))) + (assert (number? idx)) + (assert (not (neg? idx))) + (assert (< idx (alength array))) + (catch :default e + (maybe-warn e)))) + (unchecked-get array idx)) + ([array idx & idxs] + (apply checked-aget (checked-aget array idx) idxs))) + +(defn- checked-aset + ([array idx val] + (when-assert + (try + (assert (or (array? array) (goog/isArrayLike array))) + (assert (number? idx)) + (assert (not (neg? idx))) + (assert (< idx (alength array))) + (catch :default e + (maybe-warn e)))) + (unchecked-set array idx val)) + ([array idx idx2 & idxv] + (apply checked-aset (checked-aget array idx) idx2 idxv))) + +(defn- checked-aget' + ([array idx] + {:pre [(or (array? array) (goog/isArrayLike array)) + (number? idx) (not (neg? idx)) (< idx (alength array))]} + (unchecked-get array idx)) + ([array idx & idxs] + (apply checked-aget' (checked-aget' array idx) idxs))) + +(defn- checked-aset' + ([array idx val] + {:pre [(or (array? array) (goog/isArrayLike array)) + (number? idx) (not (neg? idx)) (< idx (alength array))]} + (unchecked-set array idx val)) + ([array idx idx2 & idxv] + (apply checked-aset' (checked-aget' array idx) idx2 idxv))) + +(defn aget + "Returns the value at the index/indices. Works on JavaScript arrays." + ([array idx] + (cljs.core/aget array idx)) + ([array idx & idxs] + (apply aget (aget array idx) idxs))) + +(defn aset + "Sets the value at the index/indices. Works on JavaScript arrays. + Returns val." + ([array idx val] + (cljs.core/aset array idx val)) + ([array idx idx2 & idxv] + (apply aset (aget array idx) idx2 idxv))) + +(defn ^number alength + "Returns the length of the array. Works on arrays of all types." + [array] + (cljs.core/alength array)) + +(declare reduce) + +(defn ^array into-array + "Returns an array with components set to the values in aseq. Optional type + argument accepted for compatibility with Clojure." + ([aseq] + (into-array nil aseq)) + ([type aseq] + (reduce (fn [a x] (.push a x) a) (array) aseq))) + +(defn js-invoke + "Invoke JavaScript object method via string. Needed when the + string is not a valid unquoted property name." + [obj s & args] + (.apply (unchecked-get obj s) obj (into-array args))) + +(defn js-symbol? + "Returns true if x is an instance of Symbol" + [x] + (or (identical? (goog/typeOf x) "symbol") + (and (exists? js/Symbol) + (instance? js/Symbol x)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;; core protocols ;;;;;;;;;;;;; + +(defprotocol Fn + "Marker protocol") + +(defprotocol IFn + "Protocol for adding the ability to invoke an object as a function. + For example, a vector can also be used to look up a value: + ([1 2 3 4] 1) => 2" + (-invoke + [this] + [this a] + [this a b] + [this a b c] + [this a b c d] + [this a b c d e] + [this a b c d e f] + [this a b c d e f g] + [this a b c d e f g h] + [this a b c d e f g h i] + [this a b c d e f g h i j] + [this a b c d e f g h i j k] + [this a b c d e f g h i j k l] + [this a b c d e f g h i j k l m] + [this a b c d e f g h i j k l m n] + [this a b c d e f g h i j k l m n o] + [this a b c d e f g h i j k l m n o p] + [this a b c d e f g h i j k l m n o p q] + [this a b c d e f g h i j k l m n o p q r] + [this a b c d e f g h i j k l m n o p q r s] + [this a b c d e f g h i j k l m n o p q r s t] + [this a b c d e f g h i j k l m n o p q r s t rest])) + +(defprotocol ICloneable + "Protocol for cloning a value." + (^clj -clone [value] + "Creates a clone of value.")) + +(defprotocol ICounted + "Protocol for adding the ability to count a collection in constant time." + (^number -count [coll] + "Calculates the count of coll in constant time. Used by cljs.core/count.")) + +(defprotocol IEmptyableCollection + "Protocol for creating an empty collection." + (-empty [coll] + "Returns an empty collection of the same category as coll. Used + by cljs.core/empty.")) + +(defprotocol ICollection + "Protocol for adding to a collection." + (^clj -conj [coll o] + "Returns a new collection of coll with o added to it. The new item + should be added to the most efficient place, e.g. + (conj [1 2 3 4] 5) => [1 2 3 4 5] + (conj '(2 3 4 5) 1) => '(1 2 3 4 5)")) + +#_(defprotocol IOrdinal + (-index [coll])) + +(defprotocol IIndexed + "Protocol for collections to provide indexed-based access to their items." + (-nth [coll n] [coll n not-found] + "Returns the value at the index n in the collection coll. + Returns not-found if index n is out of bounds and not-found is supplied.")) + +(defprotocol ASeq + "Marker protocol indicating an array sequence.") + +(defprotocol ISeq + "Protocol for collections to provide access to their items as sequences." + (-first [coll] + "Returns the first item in the collection coll. Used by cljs.core/first.") + (^clj -rest [coll] + "Returns a new collection of coll without the first item. It should + always return a seq, e.g. + (rest []) => () + (rest nil) => ()")) + +(defprotocol INext + "Protocol for accessing the next items of a collection." + (^clj-or-nil -next [coll] + "Returns a new collection of coll without the first item. In contrast to + rest, it should return nil if there are no more items, e.g. + (next []) => nil + (next nil) => nil")) + +(defprotocol ILookup + "Protocol for looking up a value in a data structure." + (-lookup [o k] [o k not-found] + "Use k to look up a value in o. If not-found is supplied and k is not + a valid value that can be used for look up, not-found is returned.")) + +(defprotocol IAssociative + "Protocol for adding associativity to collections." + (^boolean -contains-key? [coll k] + "Returns true if k is a key in coll.") + #_(-entry-at [coll k]) + (^clj -assoc [coll k v] + "Returns a new collection of coll with a mapping from key k to + value v added to it.")) + +(defprotocol IFind + "Protocol for implementing entry finding in collections." + (-find [coll k] "Returns the map entry for key, or nil if key not present.")) + +(defprotocol IMap + "Protocol for adding mapping functionality to collections." + #_(-assoc-ex [coll k v]) + (^clj -dissoc [coll k] + "Returns a new collection of coll without the mapping for key k.")) + +(defprotocol IMapEntry + "Protocol for examining a map entry." + (-key [coll] + "Returns the key of the map entry.") + (-val [coll] + "Returns the value of the map entry.")) + +(defprotocol ISet + "Protocol for adding set functionality to a collection." + (^clj -disjoin [coll v] + "Returns a new collection of coll that does not contain v.")) + +(defprotocol IStack + "Protocol for collections to provide access to their items as stacks. The top + of the stack should be accessed in the most efficient way for the different + data structures." + (-peek [coll] + "Returns the item from the top of the stack. Is used by cljs.core/peek.") + (^clj -pop [coll] + "Returns a new stack without the item on top of the stack. Is used + by cljs.core/pop.")) + +(defprotocol IVector + "Protocol for adding vector functionality to collections." + (^clj -assoc-n [coll n val] + "Returns a new vector with value val added at position n.")) + +(defprotocol IDeref + "Protocol for adding dereference functionality to a reference." + (-deref [o] + "Returns the value of the reference o.")) + +(defprotocol IDerefWithTimeout + (-deref-with-timeout [o msec timeout-val])) + +(defprotocol IMeta + "Protocol for accessing the metadata of an object." + (^clj-or-nil -meta [o] + "Returns the metadata of object o.")) + +(defprotocol IWithMeta + "Protocol for adding metadata to an object." + (^clj -with-meta [o meta] + "Returns a new object with value of o and metadata meta added to it.")) + +(defprotocol IReduce + "Protocol for seq types that can reduce themselves. + Called by cljs.core/reduce." + (-reduce [coll f] [coll f start] + "f should be a function of 2 arguments. If start is not supplied, + returns the result of applying f to the first 2 items in coll, then + applying f to that result and the 3rd item, etc.")) + +(defprotocol IKVReduce + "Protocol for associative types that can reduce themselves + via a function of key and val. Called by cljs.core/reduce-kv." + (-kv-reduce [coll f init] + "Reduces an associative collection and returns the result. f should be + a function that takes three arguments.")) + +(defprotocol IEquiv + "Protocol for adding value comparison functionality to a type." + (^boolean -equiv [o other] + "Returns true if o and other are equal, false otherwise.")) + +(defprotocol IHash + "Protocol for adding hashing functionality to a type." + (-hash [o] + "Returns the hash code of o.")) + +(defprotocol ISeqable + "Protocol for adding the ability to a type to be transformed into a sequence." + (^clj-or-nil -seq [o] + "Returns a seq of o, or nil if o is empty.")) + +(defprotocol ISequential + "Marker interface indicating a persistent collection of sequential items") + +(defprotocol IList + "Marker interface indicating a persistent list") + +(defprotocol IRecord + "Marker interface indicating a record object") + +(defprotocol IReversible + "Protocol for reversing a seq." + (^clj -rseq [coll] + "Returns a seq of the items in coll in reversed order.")) + +(defprotocol ISorted + "Protocol for a collection which can represent their items + in a sorted manner. " + (^clj -sorted-seq [coll ascending?] + "Returns a sorted seq from coll in either ascending or descending order.") + (^clj -sorted-seq-from [coll k ascending?] + "Returns a sorted seq from coll in either ascending or descending order. + If ascending is true, the result should contain all items which are > or >= + than k. If ascending is false, the result should contain all items which + are < or <= than k, e.g. + (-sorted-seq-from (sorted-set 1 2 3 4 5) 3 true) => (3 4 5) + (-sorted-seq-from (sorted-set 1 2 3 4 5) 3 false) => (3 2 1)") + (-entry-key [coll entry] + "Returns the key for entry.") + (-comparator [coll] + "Returns the comparator for coll.")) + +(defprotocol IWriter + "Protocol for writing. Currently only implemented by StringBufferWriter." + (-write [writer s] + "Writes s with writer and returns the result.") + (-flush [writer] + "Flush writer.")) + +(defprotocol IPrintWithWriter + "The old IPrintable protocol's implementation consisted of building a giant + list of strings to concatenate. This involved lots of concat calls, + intermediate vectors, and lazy-seqs, and was very slow in some older JS + engines. IPrintWithWriter implements printing via the IWriter protocol, so it + be implemented efficiently in terms of e.g. a StringBuffer append." + (-pr-writer [o writer opts])) + +(defprotocol IPending + "Protocol for types which can have a deferred realization. Currently only + implemented by Delay and LazySeq." + (^boolean -realized? [x] + "Returns true if a value for x has been produced, false otherwise.")) + +(defprotocol IWatchable + "Protocol for types that can be watched. Currently only implemented by Atom." + (-notify-watches [this oldval newval] + "Calls all watchers with this, oldval and newval.") + (-add-watch [this key f] + "Adds a watcher function f to this. Keys must be unique per reference, + and can be used to remove the watch with -remove-watch.") + (-remove-watch [this key] + "Removes watcher that corresponds to key from this.")) + +(defprotocol IEditableCollection + "Protocol for collections which can transformed to transients." + (^clj -as-transient [coll] + "Returns a new, transient version of the collection, in constant time.")) + +(defprotocol ITransientCollection + "Protocol for adding basic functionality to transient collections." + (^clj -conj! [tcoll val] + "Adds value val to tcoll and returns tcoll.") + (^clj -persistent! [tcoll] + "Creates a persistent data structure from tcoll and returns it.")) + +(defprotocol ITransientAssociative + "Protocol for adding associativity to transient collections." + (^clj -assoc! [tcoll key val] + "Returns a new transient collection of tcoll with a mapping from key to + val added to it.")) + +(defprotocol ITransientMap + "Protocol for adding mapping functionality to transient collections." + (^clj -dissoc! [tcoll key] + "Returns a new transient collection of tcoll without the mapping for key.")) + +(defprotocol ITransientVector + "Protocol for adding vector functionality to transient collections." + (^clj -assoc-n! [tcoll n val] + "Returns tcoll with value val added at position n.") + (^clj -pop! [tcoll] + "Returns tcoll with the last item removed from it.")) + +(defprotocol ITransientSet + "Protocol for adding set functionality to a transient collection." + (^clj -disjoin! [tcoll v] + "Returns tcoll without v.")) + +(defprotocol IComparable + "Protocol for values that can be compared." + (^number -compare [x y] + "Returns a negative number, zero, or a positive number when x is logically + 'less than', 'equal to', or 'greater than' y.")) + +(defprotocol IChunk + "Protocol for accessing the items of a chunk." + (-drop-first [coll] + "Return a new chunk of coll with the first item removed.")) + +(defprotocol IChunkedSeq + "Protocol for accessing a collection as sequential chunks." + (-chunked-first [coll] + "Returns the first chunk in coll.") + (-chunked-rest [coll] + "Return a new collection of coll with the first chunk removed.")) + +(defprotocol IChunkedNext + "Protocol for accessing the chunks of a collection." + (-chunked-next [coll] + "Returns a new collection of coll without the first chunk.")) + +(defprotocol INamed + "Protocol for adding a name." + (^string -name [x] + "Returns the name String of x.") + ( ^{:tag #{string clj-nil}}-namespace [x] + "Returns the namespace String of x.")) + +(defprotocol IAtom + "Marker protocol indicating an atom.") + +(defprotocol IReset + "Protocol for adding resetting functionality." + (-reset! [o new-value] + "Sets the value of o to new-value.")) + +(defprotocol ISwap + "Protocol for adding swapping functionality." + (-swap! [o f] [o f a] [o f a b] [o f a b xs] + "Swaps the value of o to be (apply f current-value-of-atom args).")) + +(defprotocol IVolatile + "Protocol for adding volatile functionality." + (-vreset! [o new-value] + "Sets the value of volatile o to new-value without regard for the + current value. Returns new-value.")) + +(defprotocol IIterable + "Protocol for iterating over a collection." + (-iterator [coll] + "Returns an iterator for coll.")) + +;; Printing support + +(deftype StringBufferWriter [sb] + IWriter + (-write [_ s] (.append sb s)) + (-flush [_] nil)) + +(defn pr-str* + "Support so that collections can implement toString without + loading all the printing machinery." + [^not-native obj] + (let [sb (StringBuffer.) + writer (StringBufferWriter. sb)] + (-pr-writer obj writer (pr-opts)) + (-flush writer) + (str sb))) + +;;;;;;;;;;;;;;;;;;; Murmur3 ;;;;;;;;;;;;;;; + +;;http://hg.openjdk.java.net/jdk7u/jdk7u6/jdk/file/8c2c5d63a17e/src/share/classes/java/lang/Integer.java +(defn ^number int-rotate-left [x n] + (bit-or + (bit-shift-left x n) + (unsigned-bit-shift-right x (- n)))) + +;; http://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/imul +(if (and (exists? Math/imul) + (not (zero? (Math/imul 0xffffffff 5)))) + (defn ^number imul [a b] (Math/imul a b)) + (defn ^number imul [a b] + (let [ah (bit-and (unsigned-bit-shift-right a 16) 0xffff) + al (bit-and a 0xffff) + bh (bit-and (unsigned-bit-shift-right b 16) 0xffff) + bl (bit-and b 0xffff)] + (bit-or + (+ (* al bl) + (unsigned-bit-shift-right + (bit-shift-left (+ (* ah bl) (* al bh)) 16) 0)) 0)))) + +;; http://smhasher.googlecode.com/svn/trunk/MurmurHash3.cpp +(def m3-seed 0) +(def m3-C1 (int 0xcc9e2d51)) +(def m3-C2 (int 0x1b873593)) + +(defn ^number m3-mix-K1 [k1] + (-> (int k1) (imul m3-C1) (int-rotate-left 15) (imul m3-C2))) + +(defn ^number m3-mix-H1 [h1 k1] + (int (-> (int h1) (bit-xor (int k1)) (int-rotate-left 13) (imul 5) (+ (int 0xe6546b64))))) + +(defn ^number m3-fmix [h1 len] + (as-> (int h1) h1 + (bit-xor h1 len) + (bit-xor h1 (unsigned-bit-shift-right h1 16)) + (imul h1 (int 0x85ebca6b)) + (bit-xor h1 (unsigned-bit-shift-right h1 13)) + (imul h1 (int 0xc2b2ae35)) + (bit-xor h1 (unsigned-bit-shift-right h1 16)))) + +(defn ^number m3-hash-int [in] + (if (zero? in) + in + (let [k1 (m3-mix-K1 in) + h1 (m3-mix-H1 m3-seed k1)] + (m3-fmix h1 4)))) + +(defn ^number m3-hash-unencoded-chars [in] + (let [h1 (loop [i 1 h1 m3-seed] + (if (< i (.-length in)) + (recur (+ i 2) + (m3-mix-H1 h1 + (m3-mix-K1 + (bit-or (.charCodeAt in (dec i)) + (bit-shift-left (.charCodeAt in i) 16))))) + h1)) + h1 (if (== (bit-and (.-length in) 1) 1) + (bit-xor h1 (m3-mix-K1 (.charCodeAt in (dec (.-length in))))) + h1)] + (m3-fmix h1 (imul 2 (.-length in))))) + +;;;;;;;;;;;;;;;;;;; symbols ;;;;;;;;;;;;;;; + +(declare list Symbol = compare) + +;; Simple caching of string hashcode +(def string-hash-cache (js-obj)) +(def string-hash-cache-count 0) + +;;http://hg.openjdk.java.net/jdk7u/jdk7u6/jdk/file/8c2c5d63a17e/src/share/classes/java/lang/String.java +(defn hash-string* [s] + (if-not (nil? s) + (let [len (.-length s)] + (if (pos? len) + (loop [i 0 hash 0] + (if (< i len) + (recur (inc i) (+ (imul 31 hash) (.charCodeAt s i))) + hash)) + 0)) + 0)) + +(defn add-to-string-hash-cache [k] + (let [h (hash-string* k)] + (gobject/set string-hash-cache k h) + (set! string-hash-cache-count (inc string-hash-cache-count)) + h)) + +(defn hash-string [k] + (when (> string-hash-cache-count 255) + (set! string-hash-cache (js-obj)) + (set! string-hash-cache-count 0)) + (if (nil? k) + 0 + (let [h (unchecked-get string-hash-cache k)] + (if (number? h) + h + (add-to-string-hash-cache k))))) + +(defn hash + "Returns the hash code of its argument. Note this is the hash code + consistent with =." + [o] + (cond + (implements? IHash o) + (bit-xor (-hash o) 0) + + (number? o) + (if (js/isFinite o) + (js-mod (Math/floor o) 2147483647) + (case o + ##Inf + 2146435072 + ##-Inf + -1048576 + 2146959360)) + + ;; note: mirrors Clojure's behavior on the JVM, where the hashCode is + ;; 1231 for true and 1237 for false + ;; http://docs.oracle.com/javase/7/docs/api/java/lang/Boolean.html#hashCode%28%29 + (true? o) 1231 + + (false? o) 1237 + + (string? o) + (m3-hash-int (hash-string o)) + + (instance? js/Date o) + (bit-xor (.valueOf o) 0) + + (nil? o) 0 + + :else + (bit-xor (-hash o) 0))) + +(defn hash-combine [seed hash] + ; a la boost + (bit-xor seed + (+ hash 0x9e3779b9 + (bit-shift-left seed 6) + (bit-shift-right seed 2)))) + +(defn ^boolean instance? + "Evaluates x and tests if it is an instance of the type + c. Returns true or false" + [c x] + (cljs.core/instance? c x)) + +(defn ^boolean symbol? + "Return true if x is a Symbol" + [x] + (instance? Symbol x)) + +(defn- hash-symbol [sym] + (hash-combine + (m3-hash-unencoded-chars (.-name sym)) + (hash-string (.-ns sym)))) + +(defn- compare-symbols [a b] + (cond + (identical? (.-str a) (.-str b)) 0 + (and (not (.-ns a)) (.-ns b)) -1 + (.-ns a) (if-not (.-ns b) + 1 + (let [nsc (garray/defaultCompare (.-ns a) (.-ns b))] + (if (== 0 nsc) + (garray/defaultCompare (.-name a) (.-name b)) + nsc))) + :default (garray/defaultCompare (.-name a) (.-name b)))) + +(declare get) + +(deftype Symbol [ns name str ^:mutable _hash _meta] + Object + (toString [_] str) + (equiv [this other] (-equiv this other)) + + IEquiv + (-equiv [_ other] + (if (instance? Symbol other) + (identical? str (.-str other)) + false)) + + IFn + (-invoke [sym coll] + (get coll sym)) + (-invoke [sym coll not-found] + (get coll sym not-found)) + + IMeta + (-meta [_] _meta) + + IWithMeta + (-with-meta [_ new-meta] (Symbol. ns name str _hash new-meta)) + + IHash + (-hash [sym] + (caching-hash sym hash-symbol _hash)) + + INamed + (-name [_] name) + (-namespace [_] ns) + + IPrintWithWriter + (-pr-writer [o writer _] (-write writer str))) + +(defn var? + "Returns true if v is of type cljs.core.Var" + [v] + (instance? cljs.core.Var v)) + +(defn symbol + "Returns a Symbol with the given namespace and name. Arity-1 works + on strings, keywords, and vars." + ([name] + (cond (symbol? name) name + (string? name) (let [idx (.indexOf name "/")] + (if (< idx 1) + (symbol nil name) + (symbol (.substring name 0 idx) + (.substring name (inc idx) (. name -length))))) + (var? name) (.-sym name) + (keyword? name) (recur (.-fqn name)) + :else (throw (new js/Error "no conversion to symbol")))) + ([ns name] + (let [sym-str (if-not (nil? ns) + (str ns "/" name) + name)] + (Symbol. ns name sym-str nil nil)))) + +(deftype Var [val sym _meta] + Object + (isMacro [_] + (. (val) -cljs$lang$macro)) + (toString [_] + (str "#'" sym)) + IDeref + (-deref [_] (val)) + IMeta + (-meta [_] _meta) + IWithMeta + (-with-meta [_ new-meta] + (Var. val sym new-meta)) + IEquiv + (-equiv [this other] + (if (instance? Var other) + (= (.-sym this) (.-sym other)) + false)) + IHash + (-hash [_] + (hash-symbol sym)) + Fn + IFn + (-invoke [_] + ((val))) + (-invoke [_ a] + ((val) a)) + (-invoke [_ a b] + ((val) a b)) + (-invoke [_ a b c] + ((val) a b c)) + (-invoke [_ a b c d] + ((val) a b c d)) + (-invoke [_ a b c d e] + ((val) a b c d e)) + (-invoke [_ a b c d e f] + ((val) a b c d e f)) + (-invoke [_ a b c d e f g] + ((val) a b c d e f g)) + (-invoke [_ a b c d e f g h] + ((val) a b c d e f g h)) + (-invoke [_ a b c d e f g h i] + ((val) a b c d e f g h i)) + (-invoke [_ a b c d e f g h i j] + ((val) a b c d e f g h i j)) + (-invoke [_ a b c d e f g h i j k] + ((val) a b c d e f g h i j k)) + (-invoke [_ a b c d e f g h i j k l] + ((val) a b c d e f g h i j k l)) + (-invoke [_ a b c d e f g h i j k l m] + ((val) a b c d e f g h i j k l m)) + (-invoke [_ a b c d e f g h i j k l m n] + ((val) a b c d e f g h i j k l m n)) + (-invoke [_ a b c d e f g h i j k l m n o] + ((val) a b c d e f g h i j k l m n o)) + (-invoke [_ a b c d e f g h i j k l m n o p] + ((val) a b c d e f g h i j k l m n o p)) + (-invoke [_ a b c d e f g h i j k l m n o p q] + ((val) a b c d e f g h i j k l m n o p q)) + (-invoke [_ a b c d e f g h i j k l m n o p q r] + ((val) a b c d e f g h i j k l m n o p q r)) + (-invoke [_ a b c d e f g h i j k l m n o p q r s] + ((val) a b c d e f g h i j k l m n o p q r s)) + (-invoke [_ a b c d e f g h i j k l m n o p q r s t] + ((val) a b c d e f g h i j k l m n o p q r s t)) + (-invoke [_ a b c d e f g h i j k l m n o p q r s t rest] + (apply (val) a b c d e f g h i j k l m n o p q r s t rest))) + +;;;;;;;;;;;;;;;;;;; fundamentals ;;;;;;;;;;;;;;; + +(declare array-seq prim-seq IndexedSeq) + +(defn iterable? + "Return true if x implements IIterable protocol." + [x] + (satisfies? IIterable x)) + +(defn js-iterable? + "Return true if x has a JavaScript iterator property" + [x] + (and (not (nil? x)) + (not (nil? (js* "~{}[~{}]" x ITER_SYMBOL))))) + +(defn clone + "Clone the supplied value which must implement ICloneable." + [value] + (-clone value)) + +(defn cloneable? + "Return true if x implements ICloneable protocol." + [value] + (satisfies? ICloneable value)) + +(declare es6-iterator-seq) + +(defn ^seq seq + "Returns a seq on the collection. If the collection is + empty, returns nil. (seq nil) returns nil. seq also works on + Strings." + [coll] + (when-not (nil? coll) + (cond + (implements? ISeqable coll) + (-seq coll) + + (array? coll) + (when-not (zero? (alength coll)) + (IndexedSeq. coll 0 nil)) + + (string? coll) + (when-not (zero? (.-length coll)) + (IndexedSeq. coll 0 nil)) + + (js-iterable? coll) + (es6-iterator-seq + (.call (gobject/get coll ITER_SYMBOL) coll)) + + (native-satisfies? ISeqable coll) + (-seq coll) + + :else (throw (js/Error. (str coll " is not ISeqable")))))) + +(defn first + "Returns the first item in the collection. Calls seq on its + argument. If coll is nil, returns nil." + [coll] + (when-not (nil? coll) + (if (implements? ISeq coll) + (-first coll) + (let [s (seq coll)] + (when-not (nil? s) + (-first s)))))) + +(defn ^seq rest + "Returns a possibly empty seq of the items after the first. Calls seq on its + argument." + [coll] + (if-not (nil? coll) + (if (implements? ISeq coll) + (-rest coll) + (let [s (seq coll)] + (if s + (-rest ^not-native s) + ()))) + ())) + +(defn ^seq next + "Returns a seq of the items after the first. Calls seq on its + argument. If there are no more items, returns nil" + [coll] + (when-not (nil? coll) + (if (implements? INext coll) + (-next coll) + (seq (rest coll))))) + +(defn ^boolean = + "Equality. Returns true if x equals y, false if not. Compares + numbers and collections in a type-independent manner. Clojure's immutable data + structures define -equiv (and thus =) as a value, not an identity, + comparison." + ([x] true) + ([x y] + (if (nil? x) + (nil? y) + (or (identical? x y) + ^boolean (-equiv x y)))) + ([x y & more] + (if (= x y) + (if (next more) + (recur y (first more) (next more)) + (= y (first more))) + false))) + +;; EXPERIMENTAL: subject to change +(deftype ES6Iterator [^:mutable s] + Object + (next [_] + (if-not (nil? s) + (let [x (first s)] + (set! s (next s)) + #js {:value x :done false}) + #js {:value nil :done true}))) + +(defn es6-iterator + "EXPERIMENTAL: Return a ES2015 compatible iterator for coll." + [coll] + (ES6Iterator. (seq coll))) + +(deftype ES6IteratorSeq [value iter ^:mutable _rest] + ISeqable + (-seq [this] this) + ISeq + (-first [_] value) + (-rest [_] + (when (nil? _rest) + (set! _rest (es6-iterator-seq iter))) + _rest)) + +(defn es6-iterator-seq + "EXPERIMENTAL: Given an ES2015 compatible iterator return a seq." + [iter] + (let [v (.next iter)] + (if (.-done v) + nil + (ES6IteratorSeq. (.-value v) iter nil)))) + +;;;;;;;;;;;;;;;;;;; Murmur3 Helpers ;;;;;;;;;;;;;;;; + +(defn ^number mix-collection-hash + "Mix final collection hash for ordered or unordered collections. + hash-basis is the combined collection hash, count is the number + of elements included in the basis. Note this is the hash code + consistent with =, different from .hashCode. + See http://clojure.org/data_structures#hash for full algorithms." + [hash-basis count] + (let [h1 m3-seed + k1 (m3-mix-K1 hash-basis) + h1 (m3-mix-H1 h1 k1)] + (m3-fmix h1 count))) + +(defn ^number hash-ordered-coll + "Returns the hash code, consistent with =, for an external ordered + collection implementing Iterable. + See http://clojure.org/data_structures#hash for full algorithms." + [coll] + (loop [n 0 hash-code 1 coll (seq coll)] + (if-not (nil? coll) + (recur (inc n) (bit-or (+ (imul 31 hash-code) (hash (first coll))) 0) + (next coll)) + (mix-collection-hash hash-code n)))) + +(def ^:private empty-ordered-hash + (mix-collection-hash 1 0)) + +(defn ^number hash-unordered-coll + "Returns the hash code, consistent with =, for an external unordered + collection implementing Iterable. For maps, the iterator should + return map entries whose hash is computed as + (hash-ordered-coll [k v]). + See http://clojure.org/data_structures#hash for full algorithms." + [coll] + (loop [n 0 hash-code 0 coll (seq coll)] + (if-not (nil? coll) + (recur (inc n) (bit-or (+ hash-code (hash (first coll))) 0) (next coll)) + (mix-collection-hash hash-code n)))) + +(def ^:private empty-unordered-hash + (mix-collection-hash 0 0)) + +;;;;;;;;;;;;;;;;;;; protocols on primitives ;;;;;;;; +(declare hash-map list equiv-sequential) + +(extend-type nil + ICounted + (-count [_] 0)) + +;; TODO: we should remove this and handle date equality checking +;; by some other means, probably by adding a new primitive type +;; case to the hash table lookup - David + +(extend-type js/Date + IEquiv + (-equiv [o other] + (and (instance? js/Date other) + (== (.valueOf o) (.valueOf other)))) + + IComparable + (-compare [this other] + (if (instance? js/Date other) + (garray/defaultCompare (.valueOf this) (.valueOf other)) + (throw (js/Error. (str "Cannot compare " this " to " other)))))) + +(defprotocol Inst + (inst-ms* [inst])) + +(extend-protocol Inst + js/Date + (inst-ms* [inst] (.getTime inst))) + +(defn inst-ms + "Return the number of milliseconds since January 1, 1970, 00:00:00 GMT" + [inst] + (inst-ms* inst)) + +(defn inst? + "Return true if x satisfies Inst" + [x] + (satisfies? Inst x)) + +(extend-type number + IEquiv + (-equiv [x o] (identical? x o))) + +(declare with-meta) + +(extend-type function + Fn + IMeta + (-meta [_] nil)) + +(extend-type default + IHash + (-hash [o] + (goog/getUid o))) + +;;this is primitive because & emits call to array-seq +(defn inc + "Returns a number one greater than num." + [x] (cljs.core/+ x 1)) + +(declare deref) + +(deftype Reduced [val] + IDeref + (-deref [o] val)) + +(defn reduced + "Wraps x in a way such that a reduce will terminate with the value x" + [x] + (Reduced. x)) + +(defn reduced? + "Returns true if x is the result of a call to reduced" + [r] + (instance? Reduced r)) + +(defn ensure-reduced + "If x is already reduced?, returns it, else returns (reduced x)" + [x] + (if (reduced? x) x (reduced x))) + +(defn unreduced + "If x is reduced?, returns (deref x), else returns x" + [x] + (if (reduced? x) (deref x) x)) + +;; generic to all refs +;; (but currently hard-coded to atom!) +(defn deref + "Also reader macro: @var/@atom/@delay. Returns the + most-recently-committed value of ref. When applied to a var + or atom, returns its current state. When applied to a delay, forces + it if not already forced. See also - realized?." + [o] + (-deref o)) + +(defn- ci-reduce + "Accepts any collection which satisfies the ICount and IIndexed protocols and +reduces them without incurring seq initialization" + ([^not-native cicoll f] + (let [cnt (-count cicoll)] + (if (zero? cnt) + (f) + (loop [val (-nth cicoll 0), n 1] + (if (< n cnt) + (let [nval (f val (-nth cicoll n))] + (if (reduced? nval) + @nval + (recur nval (inc n)))) + val))))) + ([^not-native cicoll f val] + (let [cnt (-count cicoll)] + (loop [val val, n 0] + (if (< n cnt) + (let [nval (f val (-nth cicoll n))] + (if (reduced? nval) + @nval + (recur nval (inc n)))) + val))))) + +(defn- array-reduce + ([arr f] + (let [cnt (alength arr)] + (if (zero? (alength arr)) + (f) + (loop [val (aget arr 0), n 1] + (if (< n cnt) + (let [nval (f val (aget arr n))] + (if (reduced? nval) + @nval + (recur nval (inc n)))) + val))))) + ([arr f val] + (let [cnt (alength arr)] + (loop [val val, n 0] + (if (< n cnt) + (let [nval (f val (aget arr n))] + (if (reduced? nval) + @nval + (recur nval (inc n)))) + val)))) + ([arr f val idx] + (let [cnt (alength arr)] + (loop [val val, n idx] + (if (< n cnt) + (let [nval (f val (aget arr n))] + (if (reduced? nval) + @nval + (recur nval (inc n)))) + val))))) + +(declare hash-coll cons drop count nth RSeq List) + +(defn counted? + "Returns true if coll implements count in constant time" + [x] (satisfies? ICounted x)) + +(defn indexed? + "Returns true if coll implements nth in constant time" + [x] (satisfies? IIndexed x)) + +(defn- -indexOf + ([coll x] + (-indexOf coll x 0)) + ([coll x start] + (let [len (count coll)] + (if (>= start len) + -1 + (loop [idx (cond + (pos? start) start + (neg? start) (max 0 (+ start len)) + :else start)] + (if (< idx len) + (if (= (nth coll idx) x) + idx + (recur (inc idx))) + -1)))))) + +(defn- -lastIndexOf + ([coll x] + (-lastIndexOf coll x (count coll))) + ([coll x start] + (let [len (count coll)] + (if (zero? len) + -1 + (loop [idx (cond + (pos? start) (min (dec len) start) + (neg? start) (+ len start) + :else start)] + (if (>= idx 0) + (if (= (nth coll idx) x) + idx + (recur (dec idx))) + -1)))))) + +(deftype IndexedSeqIterator [arr ^:mutable i] + Object + (hasNext [_] + (< i (alength arr))) + (next [_] + (let [ret (aget arr i)] + (set! i (inc i)) + ret))) + +(deftype IndexedSeq [arr i meta] + Object + (toString [coll] + (pr-str* coll)) + (equiv [this other] + (-equiv this other)) + (indexOf [coll x] + (-indexOf coll x 0)) + (indexOf [coll x start] + (-indexOf coll x start)) + (lastIndexOf [coll x] + (-lastIndexOf coll x (count coll))) + (lastIndexOf [coll x start] + (-lastIndexOf coll x start)) + + ICloneable + (-clone [_] (IndexedSeq. arr i meta)) + + ISeqable + (-seq [this] + (when (< i (alength arr)) + this)) + + IMeta + (-meta [coll] meta) + IWithMeta + (-with-meta [coll new-meta] + (if (identical? new-meta meta) + coll + (IndexedSeq. arr i new-meta))) + + ASeq + ISeq + (-first [_] (aget arr i)) + (-rest [_] (if (< (inc i) (alength arr)) + (IndexedSeq. arr (inc i) nil) + (list))) + + INext + (-next [_] (if (< (inc i) (alength arr)) + (IndexedSeq. arr (inc i) nil) + nil)) + + ICounted + (-count [_] + (max 0 (- (alength arr) i))) + + IIndexed + (-nth [coll n] + (let [i (+ n i)] + (if (and (<= 0 i) (< i (alength arr))) + (aget arr i) + (throw (js/Error. "Index out of bounds"))))) + (-nth [coll n not-found] + (let [i (+ n i)] + (if (and (<= 0 i) (< i (alength arr))) + (aget arr i) + not-found))) + + ISequential + IEquiv + (-equiv [coll other] (equiv-sequential coll other)) + + IIterable + (-iterator [coll] + (IndexedSeqIterator. arr i)) + + ICollection + (-conj [coll o] (cons o coll)) + + IEmptyableCollection + (-empty [coll] (.-EMPTY List)) + + IReduce + (-reduce [coll f] + (array-reduce arr f (aget arr i) (inc i))) + (-reduce [coll f start] + (array-reduce arr f start i)) + + IHash + (-hash [coll] (hash-ordered-coll coll)) + + IReversible + (-rseq [coll] + (let [c (-count coll)] + (if (pos? c) + (RSeq. coll (dec c) nil))))) + +(es6-iterable IndexedSeq) + +(defn prim-seq + "Create seq from a primitive JavaScript Array-like." + ([prim] + (prim-seq prim 0)) + ([prim i] + (when (< i (alength prim)) + (IndexedSeq. prim i nil)))) + +(defn array-seq + "Create a seq from a JavaScript array." + ([array] + (prim-seq array 0)) + ([array i] + (prim-seq array i))) + +(declare with-meta seq-reduce) + +(deftype RSeq [ci i meta] + Object + (toString [coll] + (pr-str* coll)) + (equiv [this other] + (-equiv this other)) + (indexOf [coll x] + (-indexOf coll x 0)) + (indexOf [coll x start] + (-indexOf coll x start)) + (lastIndexOf [coll x] + (-lastIndexOf coll x (count coll))) + (lastIndexOf [coll x start] + (-lastIndexOf coll x start)) + + ICloneable + (-clone [_] (RSeq. ci i meta)) + + IMeta + (-meta [coll] meta) + IWithMeta + (-with-meta [coll new-meta] + (if (identical? new-meta meta) + coll + (RSeq. ci i new-meta))) + + ISeqable + (-seq [coll] coll) + + ISequential + IEquiv + (-equiv [coll other] (equiv-sequential coll other)) + + ISeq + (-first [coll] + (-nth ci i)) + (-rest [coll] + (if (pos? i) + (RSeq. ci (dec i) nil) + ())) + + INext + (-next [coll] + (when (pos? i) + (RSeq. ci (dec i) nil))) + + ICounted + (-count [coll] (inc i)) + + ICollection + (-conj [coll o] + (cons o coll)) + + IEmptyableCollection + (-empty [coll] (.-EMPTY List)) + + IHash + (-hash [coll] (hash-ordered-coll coll)) + + IReduce + (-reduce [col f] (seq-reduce f col)) + (-reduce [col f start] (seq-reduce f start col))) + +(es6-iterable RSeq) + +(defn second + "Same as (first (next x))" + [coll] + (first (next coll))) + +(defn ffirst + "Same as (first (first x))" + [coll] + (first (first coll))) + +(defn nfirst + "Same as (next (first x))" + [coll] + (next (first coll))) + +(defn fnext + "Same as (first (next x))" + [coll] + (first (next coll))) + +(defn nnext + "Same as (next (next x))" + [coll] + (next (next coll))) + +(defn last + "Return the last item in coll, in linear time" + [s] + (let [sn (next s)] + (if-not (nil? sn) + (recur sn) + (first s)))) + +(extend-type default + IEquiv + (-equiv [x o] (identical? x o))) + +(defn conj + "conj[oin]. Returns a new collection with the xs + 'added'. (conj nil item) returns (item). The 'addition' may + happen at different 'places' depending on the concrete type." + ([] []) + ([coll] coll) + ([coll x] + (if-not (nil? coll) + (-conj coll x) + (list x))) + ([coll x & xs] + (if xs + (recur (conj coll x) (first xs) (next xs)) + (conj coll x)))) + +(defn empty + "Returns an empty collection of the same category as coll, or nil" + [coll] + (when-not (nil? coll) + (cond + (implements? IEmptyableCollection coll) + (-empty coll) + + (satisfies? IEmptyableCollection coll) + (-empty coll) + + :else nil))) + +(defn- accumulating-seq-count [coll] + (loop [s (seq coll) acc 0] + (if (counted? s) ; assumes nil is counted, which it currently is + (+ acc (-count s)) + (recur (next s) (inc acc))))) + +(defn count + "Returns the number of items in the collection. (count nil) returns + 0. Also works on strings, arrays, and Maps" + [coll] + (if-not (nil? coll) + (cond + (implements? ICounted coll) + (-count coll) + + (array? coll) + (alength coll) + + (string? coll) + ^number (.-length coll) + + (implements? ISeqable coll) + (accumulating-seq-count coll) + + :else (-count coll)) + 0)) + +(defn- linear-traversal-nth + ([coll n] + (cond + (nil? coll) (throw (js/Error. "Index out of bounds")) + (zero? n) (if (seq coll) + (first coll) + (throw (js/Error. "Index out of bounds"))) + (indexed? coll) (-nth coll n) + (seq coll) (recur (next coll) (dec n)) + :else (throw (js/Error. "Index out of bounds")))) + ([coll n not-found] + (cond + (nil? coll) not-found + (zero? n) (if (seq coll) + (first coll) + not-found) + (indexed? coll) (-nth coll n not-found) + (seq coll) (recur (next coll) (dec n) not-found) + :else not-found))) + +(defn nth + "Returns the value at the index. get returns nil if index out of + bounds, nth throws an exception unless not-found is supplied. nth + also works for strings, arrays, regex Matchers and Lists, and, + in O(n) time, for sequences." + ([coll n] + (cond + (not (number? n)) + (throw (js/Error. "Index argument to nth must be a number")) + + (nil? coll) + coll + + (implements? IIndexed coll) + (-nth coll n) + + (array? coll) + (if (and (< -1 n (.-length coll))) + (aget coll (int n)) + (throw (js/Error. "Index out of bounds"))) + + (string? coll) + (if (and (< -1 n (.-length coll))) + (.charAt coll (int n)) + (throw (js/Error. "Index out of bounds"))) + + (or (implements? ISeq coll) + (implements? ISequential coll)) + (if (neg? n) + (throw (js/Error. "Index out of bounds")) + (linear-traversal-nth coll n)) + + (native-satisfies? IIndexed coll) + (-nth coll n) + + :else + (throw (js/Error. (str "nth not supported on this type " + (type->str (type coll))))))) + ([coll n not-found] + (cond + (not (number? n)) + (throw (js/Error. "Index argument to nth must be a number.")) + + (nil? coll) + not-found + + (implements? IIndexed coll) + (-nth coll n not-found) + + (array? coll) + (if (and (< -1 n (.-length coll))) + (aget coll (int n)) + not-found) + + (string? coll) + (if (and (< -1 n (.-length coll))) + (.charAt coll (int n)) + not-found) + + (or (implements? ISeq coll) + (implements? ISequential coll)) + (if (neg? n) + not-found + (linear-traversal-nth coll n not-found)) + + (native-satisfies? IIndexed coll) + (-nth coll n not-found) + + :else + (throw (js/Error. (str "nth not supported on this type " + (type->str (type coll)))))))) + +(defn nthrest + "Returns the nth rest of coll, coll when n is 0." + [coll n] + (loop [n n xs coll] + (if-let [xs (and (pos? n) (seq xs))] + (recur (dec n) (rest xs)) + xs))) + +(defn get + "Returns the value mapped to key, not-found or nil if key not present." + ([o k] + (when-not (nil? o) + (cond + (implements? ILookup o) + (-lookup o k) + + (array? o) + (when (and (some? k) (< k (.-length o))) + (aget o (int k))) + + (string? o) + (when (and (some? k) (< -1 k (.-length o))) + (.charAt o (int k))) + + (native-satisfies? ILookup o) + (-lookup o k) + + :else nil))) + ([o k not-found] + (if-not (nil? o) + (cond + (implements? ILookup o) + (-lookup o k not-found) + + (array? o) + (if (and (some? k) (< -1 k (.-length o))) + (aget o (int k)) + not-found) + + (string? o) + (if (and (some? k) (< -1 k (.-length o))) + (.charAt o (int k)) + not-found) + + (native-satisfies? ILookup o) + (-lookup o k not-found) + + :else not-found) + not-found))) + +(declare PersistentHashMap PersistentArrayMap MapEntry) + +(defn assoc + "assoc[iate]. When applied to a map, returns a new map of the + same (hashed/sorted) type, that contains the mapping of key(s) to + val(s). When applied to a vector, returns a new vector that + contains val at index. Note - index must be <= (count vector)." + ([coll k v] + (if (implements? IAssociative coll) + (-assoc coll k v) + (if-not (nil? coll) + (-assoc coll k v) + (array-map k v)))) + ([coll k v & kvs] + (let [ret (assoc coll k v)] + (if kvs + (recur ret (first kvs) (second kvs) (nnext kvs)) + ret)))) + +(defn dissoc + "dissoc[iate]. Returns a new map of the same (hashed/sorted) type, + that does not contain a mapping for key(s)." + ([coll] coll) + ([coll k] + (when-not (nil? coll) + (-dissoc coll k))) + ([coll k & ks] + (when-not (nil? coll) + (let [ret (dissoc coll k)] + (if ks + (recur ret (first ks) (next ks)) + ret))))) + +(defn fn? + "Return true if f is a JavaScript function or satisfies the Fn protocol." + [f] + (or ^boolean (goog/isFunction f) (satisfies? Fn f))) + +(deftype MetaFn [afn meta] + IMeta + (-meta [_] meta) + IWithMeta + (-with-meta [_ new-meta] + (MetaFn. afn new-meta)) + Fn + IFn + (-invoke [_] + (afn)) + (-invoke [_ a] + (afn a)) + (-invoke [_ a b] + (afn a b)) + (-invoke [_ a b c] + (afn a b c)) + (-invoke [_ a b c d] + (afn a b c d)) + (-invoke [_ a b c d e] + (afn a b c d e)) + (-invoke [_ a b c d e f] + (afn a b c d e f)) + (-invoke [_ a b c d e f g] + (afn a b c d e f g)) + (-invoke [_ a b c d e f g h] + (afn a b c d e f g h)) + (-invoke [_ a b c d e f g h i] + (afn a b c d e f g h i)) + (-invoke [_ a b c d e f g h i j] + (afn a b c d e f g h i j)) + (-invoke [_ a b c d e f g h i j k] + (afn a b c d e f g h i j k)) + (-invoke [_ a b c d e f g h i j k l] + (afn a b c d e f g h i j k l)) + (-invoke [_ a b c d e f g h i j k l m] + (afn a b c d e f g h i j k l m)) + (-invoke [_ a b c d e f g h i j k l m n] + (afn a b c d e f g h i j k l m n)) + (-invoke [_ a b c d e f g h i j k l m n o] + (afn a b c d e f g h i j k l m n o)) + (-invoke [_ a b c d e f g h i j k l m n o p] + (afn a b c d e f g h i j k l m n o p)) + (-invoke [_ a b c d e f g h i j k l m n o p q] + (afn a b c d e f g h i j k l m n o p q)) + (-invoke [_ a b c d e f g h i j k l m n o p q r] + (afn a b c d e f g h i j k l m n o p q r)) + (-invoke [_ a b c d e f g h i j k l m n o p q r s] + (afn a b c d e f g h i j k l m n o p q r s)) + (-invoke [_ a b c d e f g h i j k l m n o p q r s t] + (afn a b c d e f g h i j k l m n o p q r s t)) + (-invoke [_ a b c d e f g h i j k l m n o p q r s t rest] + (apply afn a b c d e f g h i j k l m n o p q r s t rest))) + +(defn with-meta + "Returns an object of the same type and value as obj, with + map m as its metadata." + [o meta] + (if ^boolean (goog/isFunction o) + (MetaFn. o meta) + (when-not (nil? o) + (-with-meta o meta)))) + +(defn meta + "Returns the metadata of obj, returns nil if there is no metadata." + [o] + (when (and (not (nil? o)) + (satisfies? IMeta o)) + (-meta o))) + +(defn peek + "For a list or queue, same as first, for a vector, same as, but much + more efficient than, last. If the collection is empty, returns nil." + [coll] + (when-not (nil? coll) + (-peek coll))) + +(defn pop + "For a list or queue, returns a new list/queue without the first + item, for a vector, returns a new vector without the last item. + Note - not the same as next/butlast." + [coll] + (when-not (nil? coll) + (-pop coll))) + +(defn disj + "disj[oin]. Returns a new set of the same (hashed/sorted) type, that + does not contain key(s)." + ([coll] coll) + ([coll k] + (when-not (nil? coll) + (-disjoin coll k))) + ([coll k & ks] + (when-not (nil? coll) + (let [ret (disj coll k)] + (if ks + (recur ret (first ks) (next ks)) + ret))))) + +(defn empty? + "Returns true if coll has no items - same as (not (seq coll)). + Please use the idiom (seq x) rather than (not (empty? x))" + [coll] (or (nil? coll) + (not (seq coll)))) + +(defn coll? + "Returns true if x satisfies ICollection" + [x] + (if (nil? x) + false + (satisfies? ICollection x))) + +(defn set? + "Returns true if x satisfies ISet" + [x] + (if (nil? x) + false + (satisfies? ISet x))) + +(defn associative? + "Returns true if coll implements IAssociative" + [x] (satisfies? IAssociative x)) + +(defn ifind? + "Returns true if coll implements IFind" + [x] (satisfies? IFind x)) + +(defn sequential? + "Returns true if coll satisfies ISequential" + [x] (satisfies? ISequential x)) + +(defn sorted? + "Returns true if coll satisfies ISorted" + [x] (satisfies? ISorted x)) + +(defn reduceable? + "Returns true if coll satisfies IReduce" + [x] (satisfies? IReduce x)) + +(defn map? + "Return true if x satisfies IMap" + [x] + (if (nil? x) + false + (satisfies? IMap x))) + +(defn record? + "Return true if x satisfies IRecord" + [x] + (satisfies? IRecord x)) + +(defn vector? + "Return true if x satisfies IVector" + [x] (satisfies? IVector x)) + +(declare ChunkedCons ChunkedSeq) + +(defn chunked-seq? + "Return true if x satisfies IChunkedSeq." + [x] (implements? IChunkedSeq x)) + +;;;;;;;;;;;;;;;;;;;; js primitives ;;;;;;;;;;;; +(defn js-obj + "Create JavaSript object from an even number arguments representing + interleaved keys and values." + ([] + (cljs.core/js-obj)) + ([& keyvals] + (apply gobject/create keyvals))) + +(defn js-keys + "Return the JavaScript keys for an object." + [obj] + (gobject/getKeys obj)) + +(defn js-delete + "Delete a property from a JavaScript object. + Returns true upon success, false otherwise." + [obj key] + (cljs.core/js-delete obj key)) + +(defn- array-copy + ([from i to j len] + (loop [i i j j len len] + (if (zero? len) + to + (do (aset to j (aget from i)) + (recur (inc i) (inc j) (dec len))))))) + +(defn- array-copy-downward + ([from i to j len] + (loop [i (+ i (dec len)) j (+ j (dec len)) len len] + (if (zero? len) + to + (do (aset to j (aget from i)) + (recur (dec i) (dec j) (dec len))))))) + +;;;;;;;;;;;;;;;; preds ;;;;;;;;;;;;;;;;;; + +(def ^:private lookup-sentinel (js-obj)) + +(defn ^boolean false? + "Returns true if x is the value false, false otherwise." + [x] (cljs.core/false? x)) + +(defn ^boolean true? + "Returns true if x is the value true, false otherwise." + [x] (cljs.core/true? x)) + +(defn boolean? + "Return true if x is a Boolean" + [x] (or (cljs.core/true? x) (cljs.core/false? x))) + +(defn ^boolean undefined? + "Returns true if x identical to the JavaScript undefined value." + [x] + (cljs.core/undefined? x)) + +(defn seq? + "Return true if s satisfies ISeq" + [s] + (if (nil? s) + false + (satisfies? ISeq s))) + +(defn seqable? + "Return true if the seq function is supported for s" + [s] + (or + (nil? s) + (satisfies? ISeqable s) + (array? s) + (string? s))) + +(defn boolean + "Coerce to boolean" + [x] + (cond + (nil? x) false + (false? x) false + :else true)) + +(defn ifn? + "Returns true if f returns true for fn? or satisfies IFn." + [f] + (or (fn? f) (satisfies? IFn f))) + +(defn integer? + "Returns true if n is a JavaScript number with no decimal part." + [n] + (and (number? n) + (not ^boolean (js/isNaN n)) + (not (identical? n js/Infinity)) + (== (js/parseFloat n) (js/parseInt n 10)))) + +(defn int? + "Return true if x satisfies integer? or is an instance of goog.math.Integer + or goog.math.Long." + [x] + (or (integer? x) + (instance? goog.math.Integer x) + (instance? goog.math.Long x))) + +(defn pos-int? + "Return true if x satisfies int? and is positive." + [x] + (cond + (integer? x) (pos? x) + + (instance? goog.math.Integer x) + (and (not (.isNegative x)) + (not (.isZero x))) + + (instance? goog.math.Long x) + (and (not (.isNegative x)) + (not (.isZero x))) + + :else false)) + +(defn ^boolean neg-int? + "Return true if x satisfies int? and is negative." + [x] + (cond + (integer? x) (neg? x) + + (instance? goog.math.Integer x) + (.isNegative x) + + (instance? goog.math.Long x) + (.isNegative x) + + :else false)) + +(defn nat-int? + "Return true if x satisfies int? and is a natural integer value." + [x] + (cond + (integer? x) + (not (neg? x)) + + (instance? goog.math.Integer x) + (not (.isNegative x)) + + (instance? goog.math.Long x) + (not (.isNegative x)) + + :else false)) + +(defn float? + "Returns true for JavaScript numbers, false otherwise." + [x] + (number? x)) + +(defn double? + "Returns true for JavaScript numbers, false otherwise." + [x] + (number? x)) + +(defn infinite? + "Returns true for Infinity and -Infinity values." + [x] + (or (identical? x js/Number.POSITIVE_INFINITY) + (identical? x js/Number.NEGATIVE_INFINITY))) + +(defn contains? + "Returns true if key is present in the given collection, otherwise + returns false. Note that for numerically indexed collections like + vectors and arrays, this tests if the numeric key is within the + range of indexes. 'contains?' operates constant or logarithmic time; + it will not perform a linear search for a value. See also 'some'." + [coll v] + (if (identical? (get coll v lookup-sentinel) lookup-sentinel) + false + true)) + +(defn find + "Returns the map entry for key, or nil if key not present." + [coll k] + (if (ifind? coll) + (-find coll k) + (when (and (not (nil? coll)) + (associative? coll) + (contains? coll k)) + (MapEntry. k (get coll k) nil)))) + +(defn ^boolean distinct? + "Returns true if no two of the arguments are =" + ([x] true) + ([x y] (not (= x y))) + ([x y & more] + (if (not (= x y)) + (loop [s #{x y} xs more] + (let [x (first xs) + etc (next xs)] + (if xs + (if (contains? s x) + false + (recur (conj s x) etc)) + true))) + false))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Seq fns ;;;;;;;;;;;;;;;; + +(defn ^number compare + "Comparator. Returns a negative number, zero, or a positive number + when x is logically 'less than', 'equal to', or 'greater than' + y. Uses IComparable if available and google.array.defaultCompare for objects + of the same type and special-cases nil to be less than any other object." + [x y] + (cond + (identical? x y) 0 + + (nil? x) -1 + + (nil? y) 1 + + (number? x) (if (number? y) + (garray/defaultCompare x y) + (throw (js/Error. (str "Cannot compare " x " to " y)))) + + (satisfies? IComparable x) + (-compare x y) + + :else + (if (and (or (string? x) (array? x) (true? x) (false? x)) + (identical? (type x) (type y))) + (garray/defaultCompare x y) + (throw (js/Error. (str "Cannot compare " x " to " y)))))) + +(defn ^:private compare-indexed + "Compare indexed collection." + ([xs ys] + (let [xl (count xs) + yl (count ys)] + (cond + (< xl yl) -1 + (> xl yl) 1 + (== xl 0) 0 + :else (compare-indexed xs ys xl 0)))) + ([xs ys len n] + (let [d (compare (nth xs n) (nth ys n))] + (if (and (zero? d) (< (+ n 1) len)) + (recur xs ys len (inc n)) + d)))) + +(defn ^:private fn->comparator + "Given a fn that might be boolean valued or a comparator, + return a fn that is a comparator." + [f] + (if (= f compare) + compare + (fn [x y] + (let [r (f x y)] + (if (number? r) + r + (if r + -1 + (if (f y x) 1 0))))))) + +(declare to-array) + +(defn sort + "Returns a sorted sequence of the items in coll. Comp can be + boolean-valued comparison function, or a -/0/+ valued comparator. + Comp defaults to compare." + ([coll] + (sort compare coll)) + ([comp coll] + (if (seq coll) + (let [a (to-array coll)] + ;; matching Clojure's stable sort, though docs don't promise it + (garray/stableSort a (fn->comparator comp)) + (with-meta (seq a) (meta coll))) + ()))) + +(defn sort-by + "Returns a sorted sequence of the items in coll, where the sort + order is determined by comparing (keyfn item). Comp can be + boolean-valued comparison function, or a -/0/+ valued comparator. + Comp defaults to compare." + ([keyfn coll] + (sort-by keyfn compare coll)) + ([keyfn comp coll] + (sort (fn [x y] ((fn->comparator comp) (keyfn x) (keyfn y))) coll))) + +; simple reduce based on seqs, used as default +(defn- seq-reduce + ([f coll] + (if-let [s (seq coll)] + (reduce f (first s) (next s)) + (f))) + ([f val coll] + (loop [val val, coll (seq coll)] + (if coll + (let [nval (f val (first coll))] + (if (reduced? nval) + @nval + (recur nval (next coll)))) + val)))) + +(declare vec) + +(defn shuffle + "Return a random permutation of coll" + [coll] + (let [a (to-array coll)] + (garray/shuffle a) + (vec a))) + +(defn- iter-reduce + ([coll f] + (let [iter (-iterator coll)] + (if (.hasNext iter) + (let [init (.next iter)] + (loop [acc init] + (if ^boolean (.hasNext iter) + (let [nacc (f acc (.next iter))] + (if (reduced? nacc) + @nacc + (recur nacc))) + acc))) + (f)))) + ([coll f init] + (let [iter (-iterator coll)] + (loop [acc init] + (if ^boolean (.hasNext iter) + (let [nacc (f acc (.next iter))] + (if (reduced? nacc) + @nacc + (recur nacc))) + acc))))) + +(defn reduce + "f should be a function of 2 arguments. If val is not supplied, + returns the result of applying f to the first 2 items in coll, then + applying f to that result and the 3rd item, etc. If coll contains no + items, f must accept no arguments as well, and reduce returns the + result of calling f with no arguments. If coll has only 1 item, it + is returned and f is not called. If val is supplied, returns the + result of applying f to val and the first item in coll, then + applying f to that result and the 2nd item, etc. If coll contains no + items, returns val and f is not called." + ([f coll] + (cond + (implements? IReduce coll) + (-reduce coll f) + + (array? coll) + (array-reduce coll f) + + (string? coll) + (array-reduce coll f) + + (native-satisfies? IReduce coll) + (-reduce coll f) + + (iterable? coll) + (iter-reduce coll f) + + :else + (seq-reduce f coll))) + ([f val coll] + (cond + (implements? IReduce coll) + (-reduce coll f val) + + (array? coll) + (array-reduce coll f val) + + (string? coll) + (array-reduce coll f val) + + (native-satisfies? IReduce coll) + (-reduce coll f val) + + (iterable? coll) + (iter-reduce coll f val) + + :else + (seq-reduce f val coll)))) + +(defn reduce-kv + "Reduces an associative collection. f should be a function of 3 + arguments. Returns the result of applying f to init, the first key + and the first value in coll, then applying f to that result and the + 2nd key and value, etc. If coll contains no entries, returns init + and f is not called. Note that reduce-kv is supported on vectors, + where the keys will be the ordinals." + ([f init coll] + (if-not (nil? coll) + (-kv-reduce coll f init) + init))) + +(defn identity + "Returns its argument." + [x] x) + +(defn completing + "Takes a reducing function f of 2 args and returns a fn suitable for + transduce by adding an arity-1 signature that calls cf (default - + identity) on the result argument." + ([f] (completing f identity)) + ([f cf] + (fn + ([] (f)) + ([x] (cf x)) + ([x y] (f x y))))) + +(defn transduce + "reduce with a transformation of f (xf). If init is not + supplied, (f) will be called to produce it. f should be a reducing + step function that accepts both 1 and 2 arguments, if it accepts + only 2 you can add the arity-1 with 'completing'. Returns the result + of applying (the transformed) xf to init and the first item in coll, + then applying xf to that result and the 2nd item, etc. If coll + contains no items, returns init and f is not called. Note that + certain transforms may inject or skip items." + ([xform f coll] (transduce xform f (f) coll)) + ([xform f init coll] + (let [f (xform f) + ret (reduce f init coll)] + (f ret)))) + +;;; Math - variadic forms will not work until the following implemented: +;;; first, next, reduce + +(defn ^number + + "Returns the sum of nums. (+) returns 0." + ([] 0) + ([x] x) + ([x y] (cljs.core/+ x y)) + ([x y & more] + (reduce + (cljs.core/+ x y) more))) + +(defn ^number - + "If no ys are supplied, returns the negation of x, else subtracts + the ys from x and returns the result." + ([x] (cljs.core/- x)) + ([x y] (cljs.core/- x y)) + ([x y & more] (reduce - (cljs.core/- x y) more))) + +(defn ^number * + "Returns the product of nums. (*) returns 1." + ([] 1) + ([x] x) + ([x y] (cljs.core/* x y)) + ([x y & more] (reduce * (cljs.core/* x y) more))) + +(declare divide) + +(defn ^number / + "If no denominators are supplied, returns 1/numerator, + else returns numerator divided by all of the denominators." + ([x] (/ 1 x)) + ([x y] (cljs.core/divide x y)) ;; FIXME: waiting on cljs.core// + ([x y & more] (reduce / (/ x y) more))) + +(defn ^boolean < + "Returns non-nil if nums are in monotonically increasing order, + otherwise false." + ([x] true) + ([x y] (cljs.core/< x y)) + ([x y & more] + (if (cljs.core/< x y) + (if (next more) + (recur y (first more) (next more)) + (cljs.core/< y (first more))) + false))) + +(defn ^boolean <= + "Returns non-nil if nums are in monotonically non-decreasing order, + otherwise false." + ([x] true) + ([x y] (cljs.core/<= x y)) + ([x y & more] + (if (cljs.core/<= x y) + (if (next more) + (recur y (first more) (next more)) + (cljs.core/<= y (first more))) + false))) + +(defn ^boolean > + "Returns non-nil if nums are in monotonically decreasing order, + otherwise false." + ([x] true) + ([x y] (cljs.core/> x y)) + ([x y & more] + (if (cljs.core/> x y) + (if (next more) + (recur y (first more) (next more)) + (cljs.core/> y (first more))) + false))) + +(defn ^boolean >= + "Returns non-nil if nums are in monotonically non-increasing order, + otherwise false." + ([x] true) + ([x y] (cljs.core/>= x y)) + ([x y & more] + (if (cljs.core/>= x y) + (if (next more) + (recur y (first more) (next more)) + (cljs.core/>= y (first more))) + false))) + +(defn dec + "Returns a number one less than num." + [x] (- x 1)) + +(defn ^number max + "Returns the greatest of the nums." + ([x] x) + ([x y] (cljs.core/max x y)) + ([x y & more] + (reduce max (cljs.core/max x y) more))) + +(defn ^number min + "Returns the least of the nums." + ([x] x) + ([x y] (cljs.core/min x y)) + ([x y & more] + (reduce min (cljs.core/min x y) more))) + +(defn ^number byte [x] x) + +(defn char + "Coerce to char" + [x] + (cond + (number? x) (.fromCharCode js/String x) + (and (string? x) (== (.-length x) 1)) x + :else (throw (js/Error. "Argument to char must be a character or number")))) + +(defn ^number short [x] x) +(defn ^number float [x] x) +(defn ^number double [x] x) + +(defn ^number unchecked-byte [x] x) +(defn ^number unchecked-char [x] x) +(defn ^number unchecked-short [x] x) +(defn ^number unchecked-float [x] x) +(defn ^number unchecked-double [x] x) + +(defn ^number unchecked-add + "Returns the sum of nums. (+) returns 0." + ([] 0) + ([x] x) + ([x y] (cljs.core/unchecked-add x y)) + ([x y & more] (reduce unchecked-add (cljs.core/unchecked-add x y) more))) + +(defn ^number unchecked-add-int + "Returns the sum of nums. (+) returns 0." + ([] 0) + ([x] x) + ([x y] (cljs.core/unchecked-add-int x y)) + ([x y & more] (reduce unchecked-add-int (cljs.core/unchecked-add-int x y) more))) + +(defn unchecked-dec + "Returns a number one less than x, an int." + [x] + (cljs.core/unchecked-dec x)) + +(defn unchecked-dec-int + "Returns a number one less than x, an int." + [x] + (cljs.core/unchecked-dec-int x)) + +(defn ^number unchecked-divide-int + "If no denominators are supplied, returns 1/numerator, + else returns numerator divided by all of the denominators." + ([x] (unchecked-divide-int 1 x)) + ([x y] (cljs.core/divide x y)) ;; FIXME: waiting on cljs.core// + ([x y & more] (reduce unchecked-divide-int (unchecked-divide-int x y) more))) + +(defn unchecked-inc [x] + (cljs.core/unchecked-inc x)) + +(defn unchecked-inc-int [x] + (cljs.core/unchecked-inc-int x)) + +(defn ^number unchecked-multiply + "Returns the product of nums. (*) returns 1." + ([] 1) + ([x] x) + ([x y] (cljs.core/unchecked-multiply x y)) + ([x y & more] (reduce unchecked-multiply (cljs.core/unchecked-multiply x y) more))) + +(defn ^number unchecked-multiply-int + "Returns the product of nums. (*) returns 1." + ([] 1) + ([x] x) + ([x y] (cljs.core/unchecked-multiply-int x y)) + ([x y & more] (reduce unchecked-multiply-int (cljs.core/unchecked-multiply-int x y) more))) + +(defn unchecked-negate [x] + (cljs.core/unchecked-negate x)) + +(defn unchecked-negate-int [x] + (cljs.core/unchecked-negate-int x)) + +(declare mod) + +(defn unchecked-remainder-int [x n] + (cljs.core/unchecked-remainder-int x n)) + +(defn ^number unchecked-subtract + "If no ys are supplied, returns the negation of x, else subtracts + the ys from x and returns the result." + ([x] (cljs.core/unchecked-subtract x)) + ([x y] (cljs.core/unchecked-subtract x y)) + ([x y & more] (reduce unchecked-subtract (cljs.core/unchecked-subtract x y) more))) + +(defn ^number unchecked-subtract-int + "If no ys are supplied, returns the negation of x, else subtracts + the ys from x and returns the result." + ([x] (cljs.core/unchecked-subtract-int x)) + ([x y] (cljs.core/unchecked-subtract-int x y)) + ([x y & more] (reduce unchecked-subtract-int (cljs.core/unchecked-subtract-int x y) more))) + +(defn- ^number fix [q] + (if (>= q 0) + (Math/floor q) + (Math/ceil q))) + +(defn int + "Coerce to int by stripping decimal places." + [x] + (bit-or x 0)) + +(defn unchecked-int + "Coerce to int by stripping decimal places." + [x] + (fix x)) + +(defn long + "Coerce to long by stripping decimal places. Identical to `int'." + [x] + (fix x)) + +(defn unchecked-long + "Coerce to long by stripping decimal places. Identical to `int'." + [x] + (fix x)) + +(defn booleans [x] x) +(defn bytes [x] x) +(defn chars [x] x) +(defn shorts [x] x) +(defn ints [x] x) +(defn floats [x] x) +(defn doubles [x] x) +(defn longs [x] x) + +(defn js-mod + "Modulus of num and div with original javascript behavior. i.e. bug for negative numbers" + [n d] + (cljs.core/js-mod n d)) + +(defn mod + "Modulus of num and div. Truncates toward negative infinity." + [n d] + (js-mod (+ (js-mod n d) d) d)) + +(defn quot + "quot[ient] of dividing numerator by denominator." + [n d] + (let [rem (js-mod n d)] + (fix (/ (- n rem) d)))) + +(defn rem + "remainder of dividing numerator by denominator." + [n d] + (let [q (quot n d)] + (- n (* d q)))) + +(defn bit-xor + "Bitwise exclusive or" + ([x y] (cljs.core/bit-xor x y)) + ([x y & more] + (reduce bit-xor (cljs.core/bit-xor x y) more))) + +(defn bit-and + "Bitwise and" + ([x y] (cljs.core/bit-and x y)) + ([x y & more] + (reduce bit-and (cljs.core/bit-and x y) more))) + +(defn bit-or + "Bitwise or" + ([x y] (cljs.core/bit-or x y)) + ([x y & more] + (reduce bit-or (cljs.core/bit-or x y) more))) + +(defn bit-and-not + "Bitwise and with complement" + ([x y] (cljs.core/bit-and-not x y)) + ([x y & more] + (reduce bit-and-not (cljs.core/bit-and-not x y) more))) + +(defn bit-clear + "Clear bit at index n" + [x n] + (cljs.core/bit-clear x n)) + +(defn bit-flip + "Flip bit at index n" + [x n] + (cljs.core/bit-flip x n)) + +(defn bit-not + "Bitwise complement" + [x] (cljs.core/bit-not x)) + +(defn bit-set + "Set bit at index n" + [x n] + (cljs.core/bit-set x n)) + +(defn ^boolean bit-test + "Test bit at index n" + [x n] + (cljs.core/bit-test x n)) + +(defn bit-shift-left + "Bitwise shift left" + [x n] (cljs.core/bit-shift-left x n)) + +(defn bit-shift-right + "Bitwise shift right" + [x n] (cljs.core/bit-shift-right x n)) + +(defn bit-shift-right-zero-fill + "DEPRECATED: Bitwise shift right with zero fill" + [x n] (cljs.core/bit-shift-right-zero-fill x n)) + +(defn unsigned-bit-shift-right + "Bitwise shift right with zero fill" + [x n] (cljs.core/unsigned-bit-shift-right x n)) + +(defn bit-count + "Counts the number of bits set in n" + [v] + (let [v (- v (bit-and (bit-shift-right v 1) 0x55555555)) + v (+ (bit-and v 0x33333333) (bit-and (bit-shift-right v 2) 0x33333333))] + (bit-shift-right (* (bit-and (+ v (bit-shift-right v 4)) 0xF0F0F0F) 0x1010101) 24))) + +(defn ^boolean == + "Returns non-nil if nums all have the equivalent + value, otherwise false. Behavior on non nums is + undefined." + ([x] true) + ([x y] (-equiv x y)) + ([x y & more] + (if (== x y) + (if (next more) + (recur y (first more) (next more)) + (== y (first more))) + false))) + +(defn ^boolean pos? + "Returns true if num is greater than zero, else false" + [x] (cljs.core/pos? x)) + +(defn ^boolean zero? + "Returns true if num is zero, else false" + [x] + (cljs.core/zero? x)) + +(defn ^boolean neg? + "Returns true if num is less than zero, else false" + [x] (cljs.core/neg? x)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; protocols for host types ;;;;;; + +(defn nthnext + "Returns the nth next of coll, (seq coll) when n is 0." + [coll n] + (loop [n n xs (seq coll)] + (if (and xs (pos? n)) + (recur (dec n) (next xs)) + xs))) + +;;;;;;;;;;;;;;;;;;;;;;;;;; basics ;;;;;;;;;;;;;;;;;; + +(defn str + "With no args, returns the empty string. With one arg x, returns + x.toString(). (str nil) returns the empty string. With more than + one arg, returns the concatenation of the str values of the args." + ([] "") + ([x] (if (nil? x) + "" + (.join #js [x] ""))) + ([x & ys] + (loop [sb (StringBuffer. (str x)) more ys] + (if more + (recur (. sb (append (str (first more)))) (next more)) + (.toString sb))))) + +(defn subs + "Returns the substring of s beginning at start inclusive, and ending + at end (defaults to length of string), exclusive." + ([s start] ^string (.substring s start)) + ([s start end] ^string (.substring s start end))) + +(declare map name) + +(defn- equiv-sequential + "Assumes x is sequential. Returns true if x equals y, otherwise + returns false." + [x y] + (boolean + (when (sequential? y) + (if (and (counted? x) (counted? y) + (not (== (count x) (count y)))) + false + (loop [xs (seq x) ys (seq y)] + (cond (nil? xs) (nil? ys) + (nil? ys) false + (= (first xs) (first ys)) (recur (next xs) (next ys)) + :else false)))))) + +(defn- hash-coll [coll] + (if (seq coll) + (loop [res (hash (first coll)) s (next coll)] + (if (nil? s) + res + (recur (hash-combine res (hash (first s))) (next s)))) + 0)) + +(declare key val) + +(defn- hash-imap [m] + ;; a la clojure.lang.APersistentMap + (loop [h 0 s (seq m)] + (if s + (let [e (first s)] + (recur (js-mod (+ h (bit-xor (hash (key e)) (hash (val e)))) + 4503599627370496) + (next s))) + h))) + +(defn- hash-iset [s] + ;; a la clojure.lang.APersistentSet + (loop [h 0 s (seq s)] + (if s + (let [e (first s)] + (recur (js-mod (+ h (hash e)) 4503599627370496) + (next s))) + h))) + +(declare name chunk-first chunk-rest) + +(defn- extend-object! + "Takes a JavaScript object and a map of names to functions and + attaches said functions as methods on the object. Any references to + JavaScript's implicit this (via the this-as macro) will resolve to the + object that the function is attached." + [obj fn-map] + (doseq [[key-name f] fn-map] + (let [str-name (name key-name)] + (gobject/set obj str-name f))) + obj) + +;;;;;;;;;;;;;;;; cons ;;;;;;;;;;;;;;;; +(deftype List [meta first rest count ^:mutable __hash] + Object + (toString [coll] + (pr-str* coll)) + (equiv [this other] + (-equiv this other)) + (indexOf [coll x] + (-indexOf coll x 0)) + (indexOf [coll x start] + (-indexOf coll x start)) + (lastIndexOf [coll x] + (-lastIndexOf coll x count)) + (lastIndexOf [coll x start] + (-lastIndexOf coll x start)) + + IList + + ICloneable + (-clone [_] (List. meta first rest count __hash)) + + IWithMeta + (-with-meta [coll new-meta] + (if (identical? new-meta meta) + coll + (List. new-meta first rest count __hash))) + + IMeta + (-meta [coll] meta) + + ASeq + ISeq + (-first [coll] first) + (-rest [coll] + (if (== count 1) + () + rest)) + + INext + (-next [coll] + (if (== count 1) + nil + rest)) + + IStack + (-peek [coll] first) + (-pop [coll] (-rest coll)) + + ICollection + (-conj [coll o] (List. meta o coll (inc count) nil)) + + IEmptyableCollection + (-empty [coll] (-with-meta (.-EMPTY List) meta)) + + ISequential + IEquiv + (-equiv [coll other] (equiv-sequential coll other)) + + IHash + (-hash [coll] (caching-hash coll hash-ordered-coll __hash)) + + ISeqable + (-seq [coll] coll) + + ICounted + (-count [coll] count) + + IReduce + (-reduce [coll f] (seq-reduce f coll)) + (-reduce [coll f start] (seq-reduce f start coll))) + +(defn list? + "Returns true if x implements IList" + [x] + (satisfies? IList x)) + +(es6-iterable List) + +(deftype EmptyList [meta] + Object + (toString [coll] + (pr-str* coll)) + (equiv [this other] + (-equiv this other)) + (indexOf [coll x] + (-indexOf coll x 0)) + (indexOf [coll x start] + (-indexOf coll x start)) + (lastIndexOf [coll x] + (-lastIndexOf coll x (count coll))) + (lastIndexOf [coll x start] + (-lastIndexOf coll x start)) + + IList + + ICloneable + (-clone [_] (EmptyList. meta)) + + IWithMeta + (-with-meta [coll new-meta] + (if (identical? new-meta meta) + coll + (EmptyList. new-meta))) + + IMeta + (-meta [coll] meta) + + ISeq + (-first [coll] nil) + (-rest [coll] ()) + + INext + (-next [coll] nil) + + IStack + (-peek [coll] nil) + (-pop [coll] (throw (js/Error. "Can't pop empty list"))) + + ICollection + (-conj [coll o] (List. meta o nil 1 nil)) + + IEmptyableCollection + (-empty [coll] coll) + + ISequential + IEquiv + (-equiv [coll other] + (if (or (list? other) + (sequential? other)) + (nil? (seq other)) + false)) + + IHash + (-hash [coll] empty-ordered-hash) + + ISeqable + (-seq [coll] nil) + + ICounted + (-count [coll] 0) + + IReduce + (-reduce [coll f] (seq-reduce f coll)) + (-reduce [coll f start] (seq-reduce f start coll))) + +(set! (.-EMPTY List) (EmptyList. nil)) + +(es6-iterable EmptyList) + +(defn reversible? + "Returns true if coll satisfies? IReversible." + [coll] + (satisfies? IReversible coll)) + +(defn ^seq rseq + "Returns, in constant time, a seq of the items in rev (which + can be a vector or sorted-map), in reverse order. If rev is empty returns nil" + [rev] + (-rseq rev)) + +(defn reverse + "Returns a seq of the items in coll in reverse order. Not lazy." + [coll] + (if (reversible? coll) + (or (rseq coll) ()) + (reduce conj () coll))) + +(defn list + "Creates a new list containing the items." + [& xs] + (let [arr (if (and (instance? IndexedSeq xs) (zero? (.-i xs))) + (.-arr xs) + (let [arr (array)] + (loop [^not-native xs xs] + (if-not (nil? xs) + (do + (.push arr (-first xs)) + (recur (-next xs))) + arr))))] + (loop [i (alength arr) r ()] + (if (> i 0) + (recur (dec i) (-conj r (aget arr (dec i)))) + r)))) + +(deftype Cons [meta first rest ^:mutable __hash] + Object + (toString [coll] + (pr-str* coll)) + (equiv [this other] + (-equiv this other)) + (indexOf [coll x] + (-indexOf coll x 0)) + (indexOf [coll x start] + (-indexOf coll x start)) + (lastIndexOf [coll x] + (-lastIndexOf coll x (count coll))) + (lastIndexOf [coll x start] + (-lastIndexOf coll x start)) + + IList + + ICloneable + (-clone [_] (Cons. meta first rest __hash)) + + IWithMeta + (-with-meta [coll new-meta] + (if (identical? new-meta meta) + coll + (Cons. new-meta first rest __hash))) + + IMeta + (-meta [coll] meta) + + ASeq + ISeq + (-first [coll] first) + (-rest [coll] (if (nil? rest) () rest)) + + INext + (-next [coll] + (if (nil? rest) nil (seq rest))) + + ICollection + (-conj [coll o] (Cons. nil o coll nil)) + + IEmptyableCollection + (-empty [coll] (.-EMPTY List)) + + ISequential + IEquiv + (-equiv [coll other] (equiv-sequential coll other)) + + IHash + (-hash [coll] (caching-hash coll hash-ordered-coll __hash)) + + ISeqable + (-seq [coll] coll) + + IReduce + (-reduce [coll f] (seq-reduce f coll)) + (-reduce [coll f start] (seq-reduce f start coll))) + +(es6-iterable Cons) + +(defn cons + "Returns a new seq where x is the first element and coll is the rest." + [x coll] + (cond + (nil? coll) (List. nil x nil 1 nil) + (implements? ISeq coll) (Cons. nil x coll nil) + :default (Cons. nil x (seq coll) nil))) + +(defn hash-keyword [k] + (int (+ (hash-symbol k) 0x9e3779b9))) + +(defn- compare-keywords [a b] + (cond + (identical? (.-fqn a) (.-fqn b)) 0 + (and (not (.-ns a)) (.-ns b)) -1 + (.-ns a) (if-not (.-ns b) + 1 + (let [nsc (garray/defaultCompare (.-ns a) (.-ns b))] + (if (== 0 nsc) + (garray/defaultCompare (.-name a) (.-name b)) + nsc))) + :default (garray/defaultCompare (.-name a) (.-name b)))) + +(deftype Keyword [ns name fqn ^:mutable _hash] + Object + (toString [_] (str ":" fqn)) + (equiv [this other] + (-equiv this other)) + + IEquiv + (-equiv [_ other] + (if (instance? Keyword other) + (identical? fqn (.-fqn other)) + false)) + IFn + (-invoke [kw coll] + (get coll kw)) + (-invoke [kw coll not-found] + (get coll kw not-found)) + + IHash + (-hash [this] + (caching-hash this hash-keyword _hash)) + + INamed + (-name [_] name) + (-namespace [_] ns) + + IPrintWithWriter + (-pr-writer [o writer _] (-write writer (str ":" fqn)))) + +(defn keyword? + "Return true if x is a Keyword" + [x] + (instance? Keyword x)) + +(defn keyword-identical? + "Efficient test to determine that two keywords are identical." + [x y] + (if (identical? x y) + true + (if (and (keyword? x) (keyword? y)) + (identical? (.-fqn x) (.-fqn y)) + false))) + +(defn symbol-identical? + "Efficient test to determine that two symbols are identical." + [x y] + (if (identical? x y) + true + (if (and (symbol? x) (symbol? y)) + (identical? (.-str x) (.-str y)) + false))) + +(defn namespace + "Returns the namespace String of a symbol or keyword, or nil if not present." + [x] + (if (implements? INamed x) + (-namespace x) + (throw (js/Error. (str "Doesn't support namespace: " x))))) + +(defn ident? + "Return true if x is a symbol or keyword" + [x] (or (keyword? x) (symbol? x))) + +(defn simple-ident? + "Return true if x is a symbol or keyword without a namespace" + [x] (and (ident? x) (nil? (namespace x)))) + +(defn qualified-ident? + "Return true if x is a symbol or keyword with a namespace" + [x] (boolean (and (ident? x) (namespace x) true))) + +(defn simple-symbol? + "Return true if x is a symbol without a namespace" + [x] (and (symbol? x) (nil? (namespace x)))) + +(defn qualified-symbol? + "Return true if x is a symbol with a namespace" + [x] (boolean (and (symbol? x) (namespace x) true))) + +(defn simple-keyword? + "Return true if x is a keyword without a namespace" + [x] (and (keyword? x) (nil? (namespace x)))) + +(defn qualified-keyword? + "Return true if x is a keyword with a namespace" + [x] (boolean (and (keyword? x) (namespace x) true))) + +(defn keyword + "Returns a Keyword with the given namespace and name. Do not use : + in the keyword strings, it will be added automatically." + ([name] (cond + (keyword? name) name + (symbol? name) (Keyword. + (cljs.core/namespace name) + (cljs.core/name name) (.-str name) nil) + (= "/" name) (Keyword. nil name name nil) + (string? name) (let [parts (.split name "/")] + (if (== (alength parts) 2) + (Keyword. (aget parts 0) (aget parts 1) name nil) + (Keyword. nil (aget parts 0) name nil))))) + ([ns name] + (let [ns (cond + (keyword? ns) (cljs.core/name ns) + (symbol? ns) (cljs.core/name ns) + :else ns) + name (cond + (keyword? name) (cljs.core/name name) + (symbol? name) (cljs.core/name name) + :else name)] + (Keyword. ns name (str (when ns (str ns "/")) name) nil)))) + + +(deftype LazySeq [meta ^:mutable fn ^:mutable s ^:mutable __hash] + Object + (toString [coll] + (pr-str* coll)) + (equiv [this other] + (-equiv this other)) + (sval [coll] + (if (nil? fn) + s + (do + (set! s (fn)) + (set! fn nil) + s))) + (indexOf [coll x] + (-indexOf coll x 0)) + (indexOf [coll x start] + (-indexOf coll x start)) + (lastIndexOf [coll x] + (-lastIndexOf coll x (count coll))) + (lastIndexOf [coll x start] + (-lastIndexOf coll x start)) + + IPending + (-realized? [coll] + (not fn)) + + IWithMeta + (-with-meta [coll new-meta] + (if (identical? new-meta meta) + coll + (LazySeq. new-meta #(-seq coll) nil __hash))) + + IMeta + (-meta [coll] meta) + + ISeq + (-first [coll] + (-seq coll) + (when-not (nil? s) + (first s))) + (-rest [coll] + (-seq coll) + (if-not (nil? s) + (rest s) + ())) + + INext + (-next [coll] + (-seq coll) + (when-not (nil? s) + (next s))) + + ICollection + (-conj [coll o] (cons o coll)) + + IEmptyableCollection + (-empty [coll] (-with-meta (.-EMPTY List) meta)) + + ISequential + IEquiv + (-equiv [coll other] (equiv-sequential coll other)) + + IHash + (-hash [coll] (caching-hash coll hash-ordered-coll __hash)) + + ISeqable + (-seq [coll] + (.sval coll) + (when-not (nil? s) + (loop [ls s] + (if (instance? LazySeq ls) + (recur (.sval ls)) + (do (set! s ls) + (seq s)))))) + + IReduce + (-reduce [coll f] (seq-reduce f coll)) + (-reduce [coll f start] (seq-reduce f start coll))) + +(es6-iterable LazySeq) + +(declare ArrayChunk) + +(deftype ChunkBuffer [^:mutable buf ^:mutable end] + Object + (add [_ o] + (aset buf end o) + (set! end (inc end))) + + (chunk [_] + (let [ret (ArrayChunk. buf 0 end)] + (set! buf nil) + ret)) + + ICounted + (-count [_] end)) + +(defn chunk-buffer [capacity] + (ChunkBuffer. (make-array capacity) 0)) + +(deftype ArrayChunk [arr off end] + ICounted + (-count [_] (- end off)) + + IIndexed + (-nth [coll i] + (aget arr (+ off i))) + (-nth [coll i not-found] + (if (and (>= i 0) (< i (- end off))) + (aget arr (+ off i)) + not-found)) + + IChunk + (-drop-first [coll] + (if (== off end) + (throw (js/Error. "-drop-first of empty chunk")) + (ArrayChunk. arr (inc off) end))) + + IReduce + (-reduce [coll f] + (array-reduce arr f (aget arr off) (inc off))) + (-reduce [coll f start] + (array-reduce arr f start off))) + +(defn array-chunk + ([arr] + (ArrayChunk. arr 0 (alength arr))) + ([arr off] + (ArrayChunk. arr off (alength arr))) + ([arr off end] + (ArrayChunk. arr off end))) + +(deftype ChunkedCons [chunk more meta ^:mutable __hash] + Object + (toString [coll] + (pr-str* coll)) + (equiv [this other] + (-equiv this other)) + (indexOf [coll x] + (-indexOf coll x 0)) + (indexOf [coll x start] + (-indexOf coll x start)) + (lastIndexOf [coll x] + (-lastIndexOf coll x (count coll))) + (lastIndexOf [coll x start] + (-lastIndexOf coll x start)) + + IWithMeta + (-with-meta [coll new-meta] + (if (identical? new-meta meta) + coll + (ChunkedCons. chunk more new-meta __hash))) + + IMeta + (-meta [coll] meta) + + ISequential + IEquiv + (-equiv [coll other] (equiv-sequential coll other)) + + ISeqable + (-seq [coll] coll) + + ASeq + ISeq + (-first [coll] (-nth chunk 0)) + (-rest [coll] + (if (> (-count chunk) 1) + (ChunkedCons. (-drop-first chunk) more nil nil) + (if (nil? more) + () + more))) + + INext + (-next [coll] + (if (> (-count chunk) 1) + (ChunkedCons. (-drop-first chunk) more nil nil) + (when-not (nil? more) + (-seq more)))) + + IChunkedSeq + (-chunked-first [coll] chunk) + (-chunked-rest [coll] + (if (nil? more) + () + more)) + + IChunkedNext + (-chunked-next [coll] + (if (nil? more) + nil + more)) + + ICollection + (-conj [this o] + (cons o this)) + + IEmptyableCollection + (-empty [coll] (.-EMPTY List)) + + IHash + (-hash [coll] (caching-hash coll hash-ordered-coll __hash))) + +(es6-iterable ChunkedCons) + +(defn chunk-cons [chunk rest] + (if (zero? (-count chunk)) + rest + (ChunkedCons. chunk rest nil nil))) + +(defn chunk-append [b x] + (.add b x)) + +(defn chunk [b] + (.chunk b)) + +(defn chunk-first [s] + (-chunked-first s)) + +(defn chunk-rest [s] + (-chunked-rest s)) + +(defn chunk-next [s] + (if (implements? IChunkedNext s) + (-chunked-next s) + (seq (-chunked-rest s)))) + +;;;;;;;;;;;;;;;; + +(defn to-array + "Returns an array containing the contents of coll." + [coll] + (let [ary (array)] + (loop [s (seq coll)] + (if-not (nil? s) + (do (. ary push (first s)) + (recur (next s))) + ary)))) + +(defn to-array-2d + "Returns a (potentially-ragged) 2-dimensional array + containing the contents of coll." + [coll] + (let [ret (make-array (count coll))] + (loop [i 0 xs (seq coll)] + (when-not (nil? xs) + (aset ret i (to-array (first xs))) + (recur (inc i) (next xs)))) + ret)) + +(defn int-array + "Creates an array of ints. Does not coerce array, provided for compatibility + with Clojure." + ([size-or-seq] + (if (number? size-or-seq) + (int-array size-or-seq nil) + (into-array size-or-seq))) + ([size init-val-or-seq] + (let [a (make-array size)] + (if (seq? init-val-or-seq) + (let [s (seq init-val-or-seq)] + (loop [i 0 s s] + (if (and s (< i size)) + (do + (aset a i (first s)) + (recur (inc i) (next s))) + a))) + (do + (dotimes [i size] + (aset a i init-val-or-seq)) + a))))) + +(defn long-array + "Creates an array of longs. Does not coerce array, provided for compatibility + with Clojure." + ([size-or-seq] + (if (number? size-or-seq) + (long-array size-or-seq nil) + (into-array size-or-seq))) + ([size init-val-or-seq] + (let [a (make-array size)] + (if (seq? init-val-or-seq) + (let [s (seq init-val-or-seq)] + (loop [i 0 s s] + (if (and s (< i size)) + (do + (aset a i (first s)) + (recur (inc i) (next s))) + a))) + (do + (dotimes [i size] + (aset a i init-val-or-seq)) + a))))) + +(defn double-array + "Creates an array of doubles. Does not coerce array, provided for compatibility + with Clojure." + ([size-or-seq] + (if (number? size-or-seq) + (double-array size-or-seq nil) + (into-array size-or-seq))) + ([size init-val-or-seq] + (let [a (make-array size)] + (if (seq? init-val-or-seq) + (let [s (seq init-val-or-seq)] + (loop [i 0 s s] + (if (and s (< i size)) + (do + (aset a i (first s)) + (recur (inc i) (next s))) + a))) + (do + (dotimes [i size] + (aset a i init-val-or-seq)) + a))))) + +(defn object-array + "Creates an array of objects. Does not coerce array, provided for compatibility + with Clojure." + ([size-or-seq] + (if (number? size-or-seq) + (object-array size-or-seq nil) + (into-array size-or-seq))) + ([size init-val-or-seq] + (let [a (make-array size)] + (if (seq? init-val-or-seq) + (let [s (seq init-val-or-seq)] + (loop [i 0 s s] + (if (and s (< i size)) + (do + (aset a i (first s)) + (recur (inc i) (next s))) + a))) + (do + (dotimes [i size] + (aset a i init-val-or-seq)) + a))))) + +(defn bounded-count + "If coll is counted? returns its count, else will count at most the first n + elements of coll using its seq" + {:added "1.9"} + [n coll] + (if (counted? coll) + (count coll) + (loop [i 0 s (seq coll)] + (if (and (not (nil? s)) (< i n)) + (recur (inc i) (next s)) + i)))) + +(defn spread + [arglist] + (when-not (nil? arglist) + (let [n (next arglist)] + (if (nil? n) + (seq (first arglist)) + (cons (first arglist) + (spread n)))))) + +(defn concat + "Returns a lazy seq representing the concatenation of the elements in the supplied colls." + ([] (lazy-seq nil)) + ([x] (lazy-seq x)) + ([x y] + (lazy-seq + (let [s (seq x)] + (if s + (if (chunked-seq? s) + (chunk-cons (chunk-first s) (concat (chunk-rest s) y)) + (cons (first s) (concat (rest s) y))) + y)))) + ([x y & zs] + (let [cat (fn cat [xys zs] + (lazy-seq + (let [xys (seq xys)] + (if xys + (if (chunked-seq? xys) + (chunk-cons (chunk-first xys) + (cat (chunk-rest xys) zs)) + (cons (first xys) (cat (rest xys) zs))) + (when zs + (cat (first zs) (next zs)))))))] + (cat (concat x y) zs)))) + +(defn list* + "Creates a new list containing the items prepended to the rest, the + last of which will be treated as a sequence." + ([args] (seq args)) + ([a args] (cons a args)) + ([a b args] (cons a (cons b args))) + ([a b c args] (cons a (cons b (cons c args)))) + ([a b c d & more] + (cons a (cons b (cons c (cons d (spread more))))))) + + +;;; Transients + +(defn transient + "Returns a new, transient version of the collection, in constant time." + [coll] + (-as-transient coll)) + +(defn persistent! + "Returns a new, persistent version of the transient collection, in + constant time. The transient collection cannot be used after this + call, any such use will throw an exception." + [tcoll] + (-persistent! tcoll)) + +(defn conj! + "Adds val to the transient collection, and return tcoll. The 'addition' + may happen at different 'places' depending on the concrete type." + ([] (transient [])) + ([tcoll] tcoll) + ([tcoll val] + (-conj! tcoll val)) + ([tcoll val & vals] + (let [ntcoll (-conj! tcoll val)] + (if vals + (recur ntcoll (first vals) (next vals)) + ntcoll)))) + +(defn assoc! + "When applied to a transient map, adds mapping of key(s) to + val(s). When applied to a transient vector, sets the val at index. + Note - index must be <= (count vector). Returns coll." + ([tcoll key val] + (-assoc! tcoll key val)) + ([tcoll key val & kvs] + (let [ntcoll (-assoc! tcoll key val)] + (if kvs + (recur ntcoll (first kvs) (second kvs) (nnext kvs)) + ntcoll)))) + +(defn dissoc! + "Returns a transient map that doesn't contain a mapping for key(s)." + ([tcoll key] + (-dissoc! tcoll key)) + ([tcoll key & ks] + (let [ntcoll (-dissoc! tcoll key)] + (if ks + (recur ntcoll (first ks) (next ks)) + ntcoll)))) + +(defn pop! + "Removes the last item from a transient vector. If + the collection is empty, throws an exception. Returns tcoll" + [tcoll] + (-pop! tcoll)) + +(defn disj! + "disj[oin]. Returns a transient set of the same (hashed/sorted) type, that + does not contain key(s)." + ([tcoll val] + (-disjoin! tcoll val)) + ([tcoll val & vals] + (let [ntcoll (-disjoin! tcoll val)] + (if vals + (recur ntcoll (first vals) (next vals)) + ntcoll)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; apply ;;;;;;;;;;;;;;;; + +;; see core.clj +(gen-apply-to) + +(set! *unchecked-if* true) + +(defn- ^seq next* + "Internal. DO NOT USE! Next without the nil? check." + [coll] + (if (implements? INext coll) + (-next ^not-native coll) + (seq (rest coll)))) + +(defn- apply-to-simple + "Internal. DO NOT USE! + Assumes args was already called with seq beforehand!" + ([f ^seq args] + (if (nil? args) + (if (.-cljs$core$IFn$_invoke$arity$0 f) + (.cljs$core$IFn$_invoke$arity$0 f) + (.call f f)) + (apply-to-simple f (-first args) (next* args)))) + ([f a0 ^seq args] + (if (nil? args) + (if (.-cljs$core$IFn$_invoke$arity$1 f) + (.cljs$core$IFn$_invoke$arity$1 f a0) + (.call f f a0)) + (apply-to-simple f a0 (-first args) (next* args)))) + ([f a0 a1 ^seq args] + (if (nil? args) + (if (.-cljs$core$IFn$_invoke$arity$2 f) + (.cljs$core$IFn$_invoke$arity$2 f a0 a1) + (.call f f a0 a1)) + (apply-to-simple f a0 a1 (-first args) (next* args)))) + ([f a0 a1 a2 ^seq args] + (if (nil? args) + (if (.-cljs$core$IFn$_invoke$arity$3 f) + (.cljs$core$IFn$_invoke$arity$3 f a0 a1 a2) + (.call f f a0 a1 a2)) + (apply-to-simple f a0 a1 a2 (-first args) (next* args)))) + ([f a0 a1 a2 a3 ^seq args] + (if (nil? args) + (if (.-cljs$core$IFn$_invoke$arity$4 f) + (.cljs$core$IFn$_invoke$arity$4 f a0 a1 a2 a3) + (.call f f a0 a1 a2 a3)) + (gen-apply-to-simple f 4 args)))) + +(defn apply + "Applies fn f to the argument list formed by prepending intervening arguments to args." + ([f args] + (if (.-cljs$lang$applyTo f) + (let [fixed-arity (.-cljs$lang$maxFixedArity f) + bc (bounded-count (inc fixed-arity) args)] + (if (<= bc fixed-arity) + (apply-to f bc args) + (.cljs$lang$applyTo f args))) + (apply-to-simple f (seq args)))) + ([f x args] + (if (.-cljs$lang$applyTo f) + (let [arglist (list* x args) + fixed-arity (.-cljs$lang$maxFixedArity f) + bc (inc (bounded-count fixed-arity args))] + (if (<= bc fixed-arity) + (apply-to f bc arglist) + (.cljs$lang$applyTo f arglist))) + (apply-to-simple f x (seq args)))) + ([f x y args] + (if (.-cljs$lang$applyTo f) + (let [arglist (list* x y args) + fixed-arity (.-cljs$lang$maxFixedArity f) + bc (+ 2 (bounded-count (dec fixed-arity) args))] + (if (<= bc fixed-arity) + (apply-to f bc arglist) + (.cljs$lang$applyTo f arglist))) + (apply-to-simple f x y (seq args)))) + ([f x y z args] + (if (.-cljs$lang$applyTo f) + (let [arglist (list* x y z args) + fixed-arity (.-cljs$lang$maxFixedArity f) + bc (+ 3 (bounded-count (- fixed-arity 2) args))] + (if (<= bc fixed-arity) + (apply-to f bc arglist) + (.cljs$lang$applyTo f arglist))) + (apply-to-simple f x y z (seq args)))) + ([f a b c d & args] + (if (.-cljs$lang$applyTo f) + (let [spread-args (spread args) + arglist (cons a (cons b (cons c (cons d spread-args)))) + fixed-arity (.-cljs$lang$maxFixedArity f) + bc (+ 4 (bounded-count (- fixed-arity 3) spread-args))] + (if (<= bc fixed-arity) + (apply-to f bc arglist) + (.cljs$lang$applyTo f arglist))) + (apply-to-simple f a b c d (spread args))))) + +(set! *unchecked-if* false) + +;; CLJS-3200: used by destructure macro for maps to reduce amount of repeated code +;; placed here because it needs apply and hash-map (only declared at this point) +(defn --destructure-map [x] + (if (implements? ISeq x) (apply cljs.core/hash-map x) x)) + +(defn vary-meta + "Returns an object of the same type and value as obj, with + (apply f (meta obj) args) as its metadata." + ([obj f] + (with-meta obj (f (meta obj)))) + ([obj f a] + (with-meta obj (f (meta obj) a))) + ([obj f a b] + (with-meta obj (f (meta obj) a b))) + ([obj f a b c] + (with-meta obj (f (meta obj) a b c))) + ([obj f a b c d] + (with-meta obj (f (meta obj) a b c d))) + ([obj f a b c d & args] + (with-meta obj (apply f (meta obj) a b c d args)))) + +(defn ^boolean not= + "Same as (not (= obj1 obj2))" + ([x] false) + ([x y] (not (= x y))) + ([x y & more] + (not (apply = x y more)))) + +(defn not-empty + "If coll is empty, returns nil, else coll" + [coll] (when (seq coll) coll)) + +(defn nil-iter [] + (reify + Object + (hasNext [_] false) + (next [_] (js/Error. "No such element")) + (remove [_] (js/Error. "Unsupported operation")))) + +(deftype StringIter [s ^:mutable i] + Object + (hasNext [_] (< i (.-length s))) + (next [_] + (let [ret (.charAt s i)] + (set! i (inc i)) + ret)) + (remove [_] (js/Error. "Unsupported operation"))) + +(defn string-iter [x] + (StringIter. x 0)) + +(deftype ArrayIter [arr ^:mutable i] + Object + (hasNext [_] (< i (alength arr))) + (next [_] + (let [ret (aget arr i)] + (set! i (inc i)) + ret)) + (remove [_] (js/Error. "Unsupported operation"))) + +(defn array-iter [x] + (ArrayIter. x 0)) + +(def INIT #js {}) +(def START #js {}) + +(deftype SeqIter [^:mutable _seq ^:mutable _next] + Object + (hasNext [_] + (if (identical? _seq INIT) + (do + (set! _seq START) + (set! _next (seq _next))) + (if (identical? _seq _next) + (set! _next (next _seq)))) + (not (nil? _next))) + (next [this] + (if-not ^boolean (.hasNext this) + (throw (js/Error. "No such element")) + (do + (set! _seq _next) + (first _next)))) + (remove [_] (js/Error. "Unsupported operation"))) + +(defn seq-iter [coll] + (SeqIter. INIT coll)) + +(defn iter [coll] + (cond + (iterable? coll) (-iterator coll) + (nil? coll) (nil-iter) + (string? coll) (string-iter coll) + (array? coll) (array-iter coll) + (seqable? coll) (seq-iter coll) + :else (throw (js/Error. (str "Cannot create iterator from " coll))))) + +(deftype Many [vals] + Object + (add [this o] + (.push vals o) + this) + (remove [this] + (.shift vals)) + (isEmpty [this] + (zero? (.-length vals))) + (toString [this] + (str "Many: " vals))) + +(def ^:private NONE #js {}) + +(deftype Single [^:mutable val] + Object + (add [this o] + (if (identical? val NONE) + (do + (set! val o) + this) + (Many. #js [val o]))) + (remove [this] + (if (identical? val NONE) + (throw (js/Error. (str "Removing object from empty buffer"))) + (let [ret val] + (set! val NONE) + ret))) + (isEmpty [this] + (identical? val NONE)) + (toString [this] + (str "Single: " val))) + +(deftype Empty [] + Object + (add [this o] + (Single. o)) + (remove [this] + (throw (js/Error. (str "Removing object from empty buffer")))) + (isEmpty [this] + true) + (toString [this] + "Empty")) + +(def ^:private EMPTY (Empty.)) + +(deftype MultiIterator [iters] + Object + (hasNext [_] + (loop [iters (seq iters)] + (if-not (nil? iters) + (let [iter (first iters)] + (if-not ^boolean (.hasNext iter) + false + (recur (next iters)))) + true))) + (next [_] + (let [nexts (array)] + (dotimes [i (alength iters)] + (aset nexts i (.next (aget iters i)))) + (prim-seq nexts 0)))) + +(defn- chunkIteratorSeq [iter] + (lazy-seq + (when ^boolean (.hasNext iter) + (let [arr (array)] + (loop [n 0] + (if (and (.hasNext iter) (< n 32)) + (do + (aset arr n (.next iter)) + (recur (inc n))) + (chunk-cons (array-chunk arr 0 n) (chunkIteratorSeq iter)))))))) + +(deftype TransformerIterator [^:mutable buffer ^:mutable _next ^:mutable completed ^:mutable xf sourceIter multi] + Object + (step [this] + (if-not (identical? _next NONE) + true + (loop [] + (if (identical? _next NONE) + (if ^boolean (.isEmpty buffer) + (if ^boolean completed + false + (if ^boolean (.hasNext sourceIter) + (let [iter (if ^boolean multi + (apply xf (cons nil (.next sourceIter))) + (xf nil (.next sourceIter)))] + (when (reduced? iter) + (xf nil) + (set! completed true)) + (recur)) + (do + (xf nil) + (set! completed true) + (recur)))) + (do + (set! _next (.remove buffer)) + (recur))) + true)))) + (hasNext [this] + (.step this)) + (next [this] + (if ^boolean (.hasNext this) + (let [ret _next] + (set! _next NONE) + ret) + (throw (js/Error. "No such element")))) + (remove [_] + (js/Error. "Unsupported operation"))) + +(es6-iterable TransformerIterator) + +(defn transformer-iterator + [xform sourceIter multi] + (let [iterator (TransformerIterator. EMPTY NONE false nil sourceIter multi)] + (set! (.-xf iterator) + (xform (fn + ([] nil) + ([acc] acc) + ([acc o] + (set! (.-buffer iterator) (.add (.-buffer iterator) o)) + acc)))) + iterator)) + +(set! (.-create TransformerIterator) + (fn [xform source] + (transformer-iterator xform source false))) + +(set! (.-createMulti TransformerIterator) + (fn [xform sources] + (transformer-iterator xform (MultiIterator. (to-array sources)) true))) + +(defn sequence + "Coerces coll to a (possibly empty) sequence, if it is not already + one. Will not force a lazy seq. (sequence nil) yields (), When a + transducer is supplied, returns a lazy sequence of applications of + the transform to the items in coll(s), i.e. to the set of first + items of each coll, followed by the set of second + items in each coll, until any one of the colls is exhausted. Any + remaining items in other colls are ignored. The transform should accept + number-of-colls arguments" + ([coll] + (if (seq? coll) + coll + (or (seq coll) ()))) + ([xform coll] + (or (chunkIteratorSeq + (.create TransformerIterator xform (iter coll))) + ())) + ([xform coll & colls] + (or (chunkIteratorSeq + (.createMulti TransformerIterator xform (map iter (cons coll colls)))) + ()))) + +(defn every? + "Returns true if (pred x) is logical true for every x in coll, else + false." + [pred coll] + (cond + (nil? (seq coll)) true + (pred (first coll)) (recur pred (next coll)) + :else false)) + +(defn not-every? + "Returns false if (pred x) is logical true for every x in + coll, else true." + [pred coll] (not (every? pred coll))) + +(defn some + "Returns the first logical true value of (pred x) for any x in coll, + else nil. One common idiom is to use a set as pred, for example + this will return :fred if :fred is in the sequence, otherwise nil: + (some #{:fred} coll)" + [pred coll] + (when-let [s (seq coll)] + (or (pred (first s)) (recur pred (next s))))) + +(defn not-any? + "Returns false if (pred x) is logical true for any x in coll, + else true." + [pred coll] (not (some pred coll))) + +(defn even? + "Returns true if n is even, throws an exception if n is not an integer" + [n] (if (integer? n) + (zero? (bit-and n 1)) + (throw (js/Error. (str "Argument must be an integer: " n))))) + +(defn odd? + "Returns true if n is odd, throws an exception if n is not an integer" + [n] (not (even? n))) + +(defn complement + "Takes a fn f and returns a fn that takes the same arguments as f, + has the same effects, if any, and returns the opposite truth value." + [f] + (fn + ([] (not (f))) + ([x] (not (f x))) + ([x y] (not (f x y))) + ([x y & zs] (not (apply f x y zs))))) + +(defn constantly + "Returns a function that takes any number of arguments and returns x." + [x] (fn [& args] x)) + +(defn comp + "Takes a set of functions and returns a fn that is the composition + of those fns. The returned fn takes a variable number of args, + applies the rightmost of fns to the args, the next + fn (right-to-left) to the result, etc." + ([] identity) + ([f] f) + ([f g] + (fn + ([] (f (g))) + ([x] (f (g x))) + ([x y] (f (g x y))) + ([x y z] (f (g x y z))) + ([x y z & args] (f (apply g x y z args))))) + ([f g h] + (fn + ([] (f (g (h)))) + ([x] (f (g (h x)))) + ([x y] (f (g (h x y)))) + ([x y z] (f (g (h x y z)))) + ([x y z & args] (f (g (apply h x y z args)))))) + ([f1 f2 f3 & fs] + (let [fs (reverse (list* f1 f2 f3 fs))] + (fn [& args] + (loop [ret (apply (first fs) args) fs (next fs)] + (if fs + (recur ((first fs) ret) (next fs)) + ret)))))) + +(defn partial + "Takes a function f and fewer than the normal arguments to f, and + returns a fn that takes a variable number of additional args. When + called, the returned function calls f with args + additional args." + ([f] f) + ([f arg1] + (fn + ([] (f arg1)) + ([x] (f arg1 x)) + ([x y] (f arg1 x y)) + ([x y z] (f arg1 x y z)) + ([x y z & args] (apply f arg1 x y z args)))) + ([f arg1 arg2] + (fn + ([] (f arg1 arg2)) + ([x] (f arg1 arg2 x)) + ([x y] (f arg1 arg2 x y)) + ([x y z] (f arg1 arg2 x y z)) + ([x y z & args] (apply f arg1 arg2 x y z args)))) + ([f arg1 arg2 arg3] + (fn + ([] (f arg1 arg2 arg3)) + ([x] (f arg1 arg2 arg3 x)) + ([x y] (f arg1 arg2 arg3 x y)) + ([x y z] (f arg1 arg2 arg3 x y z)) + ([x y z & args] (apply f arg1 arg2 arg3 x y z args)))) + ([f arg1 arg2 arg3 & more] + (fn [& args] (apply f arg1 arg2 arg3 (concat more args))))) + +(defn fnil + "Takes a function f, and returns a function that calls f, replacing + a nil first argument to f with the supplied value x. Higher arity + versions can replace arguments in the second and third + positions (y, z). Note that the function f can take any number of + arguments, not just the one(s) being nil-patched." + ([f x] + (fn + ([a] (f (if (nil? a) x a))) + ([a b] (f (if (nil? a) x a) b)) + ([a b c] (f (if (nil? a) x a) b c)) + ([a b c & ds] (apply f (if (nil? a) x a) b c ds)))) + ([f x y] + (fn + ([a b] (f (if (nil? a) x a) (if (nil? b) y b))) + ([a b c] (f (if (nil? a) x a) (if (nil? b) y b) c)) + ([a b c & ds] (apply f (if (nil? a) x a) (if (nil? b) y b) c ds)))) + ([f x y z] + (fn + ([a b] (f (if (nil? a) x a) (if (nil? b) y b))) + ([a b c] (f (if (nil? a) x a) (if (nil? b) y b) (if (nil? c) z c))) + ([a b c & ds] (apply f (if (nil? a) x a) (if (nil? b) y b) (if (nil? c) z c) ds))))) + +(declare volatile!) + +(defn map-indexed + "Returns a lazy sequence consisting of the result of applying f to 0 + and the first item of coll, followed by applying f to 1 and the second + item in coll, etc, until coll is exhausted. Thus function f should + accept 2 arguments, index and item. Returns a stateful transducer when + no collection is provided." + ([f] + (fn [rf] + (let [i (volatile! -1)] + (fn + ([] (rf)) + ([result] (rf result)) + ([result input] + (rf result (f (vswap! i inc) input))))))) + ([f coll] + (letfn [(mapi [idx coll] + (lazy-seq + (when-let [s (seq coll)] + (if (chunked-seq? s) + (let [c (chunk-first s) + size (count c) + b (chunk-buffer size)] + (dotimes [i size] + (chunk-append b (f (+ idx i) (-nth c i)))) + (chunk-cons (chunk b) (mapi (+ idx size) (chunk-rest s)))) + (cons (f idx (first s)) (mapi (inc idx) (rest s)))))))] + (mapi 0 coll)))) + +(defn keep + "Returns a lazy sequence of the non-nil results of (f item). Note, + this means false return values will be included. f must be free of + side-effects. Returns a transducer when no collection is provided." + ([f] + (fn [rf] + (fn + ([] (rf)) + ([result] (rf result)) + ([result input] + (let [v (f input)] + (if (nil? v) + result + (rf result v))))))) + ([f coll] + (lazy-seq + (when-let [s (seq coll)] + (if (chunked-seq? s) + (let [c (chunk-first s) + size (count c) + b (chunk-buffer size)] + (dotimes [i size] + (let [x (f (-nth c i))] + (when-not (nil? x) + (chunk-append b x)))) + (chunk-cons (chunk b) (keep f (chunk-rest s)))) + (let [x (f (first s))] + (if (nil? x) + (keep f (rest s)) + (cons x (keep f (rest s)))))))))) + +;; ============================================================================= +;; Atom + +(deftype Atom [state meta validator watches] + Object + (equiv [this other] + (-equiv this other)) + + IAtom + + IEquiv + (-equiv [o other] (identical? o other)) + + IDeref + (-deref [_] state) + + IMeta + (-meta [_] meta) + + IWatchable + (-notify-watches [this oldval newval] + (doseq [[key f] watches] + (f key this oldval newval))) + (-add-watch [this key f] + (set! (.-watches this) (assoc watches key f)) + this) + (-remove-watch [this key] + (set! (.-watches this) (dissoc watches key))) + + IHash + (-hash [this] (goog/getUid this))) + +(defn atom + "Creates and returns an Atom with an initial value of x and zero or + more options (in any order): + + :meta metadata-map + + :validator validate-fn + + If metadata-map is supplied, it will become the metadata on the + atom. validate-fn must be nil or a side-effect-free fn of one + argument, which will be passed the intended new state on any state + change. If the new state is unacceptable, the validate-fn should + return false or throw an Error. If either of these error conditions + occur, then the value of the atom will not change." + ([x] (Atom. x nil nil nil)) + ([x & {:keys [meta validator]}] (Atom. x meta validator nil))) + +(declare pr-str) + +(defn reset! + "Sets the value of atom to newval without regard for the + current value. Returns new-value." + [a new-value] + (if (instance? Atom a) + (let [validate (.-validator a)] + (when-not (nil? validate) + (when-not (validate new-value) + (throw (js/Error. "Validator rejected reference state")))) + (let [old-value (.-state a)] + (set! (.-state a) new-value) + (when-not (nil? (.-watches a)) + (-notify-watches a old-value new-value)) + new-value)) + (-reset! a new-value))) + +(defn reset-vals! + "Sets the value of atom to newval. Returns [old new], the value of the + atom before and after the reset." + {:added "1.9"} + [a new-value] + (let [validate (.-validator a)] + (when-not (nil? validate) + (when-not (validate new-value) + (throw (js/Error. "Validator rejected reference state")))) + (let [old-value (.-state a)] + (set! (.-state a) new-value) + (when-not (nil? (.-watches a)) + (-notify-watches a old-value new-value)) + [old-value new-value]))) + +(defn swap! + "Atomically swaps the value of atom to be: + (apply f current-value-of-atom args). Note that f may be called + multiple times, and thus should be free of side effects. Returns + the value that was swapped in." + ([a f] + (if (instance? Atom a) + (reset! a (f (.-state a))) + (-swap! a f))) + ([a f x] + (if (instance? Atom a) + (reset! a (f (.-state a) x)) + (-swap! a f x))) + ([a f x y] + (if (instance? Atom a) + (reset! a (f (.-state a) x y)) + (-swap! a f x y))) + ([a f x y & more] + (if (instance? Atom a) + (reset! a (apply f (.-state a) x y more)) + (-swap! a f x y more)))) + +(defn swap-vals! + "Atomically swaps the value of atom to be: + (apply f current-value-of-atom args). Note that f may be called + multiple times, and thus should be free of side effects. + Returns [old new], the value of the atom before and after the swap." + {:added "1.9"} + ([a f] + (reset-vals! a (f (.-state a)))) + ([a f x] + (reset-vals! a (f (.-state a) x))) + ([a f x y] + (reset-vals! a (f (.-state a) x y))) + ([a f x y & more] + (reset-vals! a (apply f (.-state a) x y more)))) + +(defn compare-and-set! + "Atomically sets the value of atom to newval if and only if the + current value of the atom is equal to oldval. Returns true if + set happened, else false." + [^not-native a oldval newval] + (if (= (-deref a) oldval) + (do (reset! a newval) true) + false)) + +(defn set-validator! + "Sets the validator-fn for an atom. validator-fn must be nil or a + side-effect-free fn of one argument, which will be passed the intended + new state on any state change. If the new state is unacceptable, the + validator-fn should return false or throw an Error. If the current state + is not acceptable to the new validator, an Error will be thrown and the + validator will not be changed." + [iref val] + (when (and (some? val) + (not (val (-deref iref)))) + (throw (js/Error. "Validator rejected reference state"))) + (set! (.-validator iref) val)) + +(defn get-validator + "Gets the validator-fn for a var/ref/agent/atom." + [iref] + (.-validator iref)) + +(deftype Volatile [^:mutable state] + IVolatile + (-vreset! [_ new-state] + (set! state new-state)) + + IDeref + (-deref [_] state)) + +(defn volatile! + "Creates and returns a Volatile with an initial value of val." + [val] + (Volatile. val)) + +(defn volatile? + "Returns true if x is a volatile." + [x] (instance? Volatile x)) + +(defn vreset! + "Sets the value of volatile to newval without regard for the + current value. Returns newval." + [vol newval] (-vreset! vol newval)) + +(defn keep-indexed + "Returns a lazy sequence of the non-nil results of (f index item). Note, + this means false return values will be included. f must be free of + side-effects. Returns a stateful transducer when no collection is + provided." + ([f] + (fn [rf] + (let [ia (volatile! -1)] + (fn + ([] (rf)) + ([result] (rf result)) + ([result input] + (let [i (vswap! ia inc) + v (f i input)] + (if (nil? v) + result + (rf result v)))))))) + ([f coll] + (letfn [(keepi [idx coll] + (lazy-seq + (when-let [s (seq coll)] + (if (chunked-seq? s) + (let [c (chunk-first s) + size (count c) + b (chunk-buffer size)] + (dotimes [i size] + (let [x (f (+ idx i) (-nth c i))] + (when-not (nil? x) + (chunk-append b x)))) + (chunk-cons (chunk b) (keepi (+ idx size) (chunk-rest s)))) + (let [x (f idx (first s))] + (if (nil? x) + (keepi (inc idx) (rest s)) + (cons x (keepi (inc idx) (rest s)))))))))] + (keepi 0 coll)))) + +(defn every-pred + "Takes a set of predicates and returns a function f that returns true if all of its + composing predicates return a logical true value against all of its arguments, else it returns + false. Note that f is short-circuiting in that it will stop execution on the first + argument that triggers a logical false result against the original predicates." + ([p] + (fn ep1 + ([] true) + ([x] (boolean (p x))) + ([x y] (boolean (and (p x) (p y)))) + ([x y z] (boolean (and (p x) (p y) (p z)))) + ([x y z & args] (boolean (and (ep1 x y z) + (every? p args)))))) + ([p1 p2] + (fn ep2 + ([] true) + ([x] (boolean (and (p1 x) (p2 x)))) + ([x y] (boolean (and (p1 x) (p1 y) (p2 x) (p2 y)))) + ([x y z] (boolean (and (p1 x) (p1 y) (p1 z) (p2 x) (p2 y) (p2 z)))) + ([x y z & args] (boolean (and (ep2 x y z) + (every? #(and (p1 %) (p2 %)) args)))))) + ([p1 p2 p3] + (fn ep3 + ([] true) + ([x] (boolean (and (p1 x) (p2 x) (p3 x)))) + ([x y] (boolean (and (p1 x) (p2 x) (p3 x) (p1 y) (p2 y) (p3 y)))) + ([x y z] (boolean (and (p1 x) (p2 x) (p3 x) (p1 y) (p2 y) (p3 y) (p1 z) (p2 z) (p3 z)))) + ([x y z & args] (boolean (and (ep3 x y z) + (every? #(and (p1 %) (p2 %) (p3 %)) args)))))) + ([p1 p2 p3 & ps] + (let [ps (list* p1 p2 p3 ps)] + (fn epn + ([] true) + ([x] (every? #(% x) ps)) + ([x y] (every? #(and (% x) (% y)) ps)) + ([x y z] (every? #(and (% x) (% y) (% z)) ps)) + ([x y z & args] (boolean (and (epn x y z) + (every? #(every? % args) ps)))))))) + +(defn some-fn + "Takes a set of predicates and returns a function f that returns the first logical true value + returned by one of its composing predicates against any of its arguments, else it returns + logical false. Note that f is short-circuiting in that it will stop execution on the first + argument that triggers a logical true result against the original predicates." + ([p] + (fn sp1 + ([] nil) + ([x] (p x)) + ([x y] (or (p x) (p y))) + ([x y z] (or (p x) (p y) (p z))) + ([x y z & args] (or (sp1 x y z) + (some p args))))) + ([p1 p2] + (fn sp2 + ([] nil) + ([x] (or (p1 x) (p2 x))) + ([x y] (or (p1 x) (p1 y) (p2 x) (p2 y))) + ([x y z] (or (p1 x) (p1 y) (p1 z) (p2 x) (p2 y) (p2 z))) + ([x y z & args] (or (sp2 x y z) + (some #(or (p1 %) (p2 %)) args))))) + ([p1 p2 p3] + (fn sp3 + ([] nil) + ([x] (or (p1 x) (p2 x) (p3 x))) + ([x y] (or (p1 x) (p2 x) (p3 x) (p1 y) (p2 y) (p3 y))) + ([x y z] (or (p1 x) (p2 x) (p3 x) (p1 y) (p2 y) (p3 y) (p1 z) (p2 z) (p3 z))) + ([x y z & args] (or (sp3 x y z) + (some #(or (p1 %) (p2 %) (p3 %)) args))))) + ([p1 p2 p3 & ps] + (let [ps (list* p1 p2 p3 ps)] + (fn spn + ([] nil) + ([x] (some #(% x) ps)) + ([x y] (some #(or (% x) (% y)) ps)) + ([x y z] (some #(or (% x) (% y) (% z)) ps)) + ([x y z & args] (or (spn x y z) + (some #(some % args) ps))))))) + +(defn map + "Returns a lazy sequence consisting of the result of applying f to + the set of first items of each coll, followed by applying f to the + set of second items in each coll, until any one of the colls is + exhausted. Any remaining items in other colls are ignored. Function + f should accept number-of-colls arguments. Returns a transducer when + no collection is provided." + ([f] + (fn [rf] + (fn + ([] (rf)) + ([result] (rf result)) + ([result input] + (rf result (f input))) + ([result input & inputs] + (rf result (apply f input inputs)))))) + ([f coll] + (lazy-seq + (when-let [s (seq coll)] + (if (chunked-seq? s) + (let [c (chunk-first s) + size (count c) + b (chunk-buffer size)] + (dotimes [i size] + (chunk-append b (f (-nth c i)))) + (chunk-cons (chunk b) (map f (chunk-rest s)))) + (cons (f (first s)) (map f (rest s))))))) + ([f c1 c2] + (lazy-seq + (let [s1 (seq c1) s2 (seq c2)] + (when (and s1 s2) + (cons (f (first s1) (first s2)) + (map f (rest s1) (rest s2))))))) + ([f c1 c2 c3] + (lazy-seq + (let [s1 (seq c1) s2 (seq c2) s3 (seq c3)] + (when (and s1 s2 s3) + (cons (f (first s1) (first s2) (first s3)) + (map f (rest s1) (rest s2) (rest s3))))))) + ([f c1 c2 c3 & colls] + (let [step (fn step [cs] + (lazy-seq + (let [ss (map seq cs)] + (when (every? identity ss) + (cons (map first ss) (step (map rest ss)))))))] + (map #(apply f %) (step (conj colls c3 c2 c1)))))) + +(defn take + "Returns a lazy sequence of the first n items in coll, or all items if + there are fewer than n. Returns a stateful transducer when + no collection is provided." + ([n] + {:pre [(number? n)]} + (fn [rf] + (let [na (volatile! n)] + (fn + ([] (rf)) + ([result] (rf result)) + ([result input] + (let [n @na + nn (vswap! na dec) + result (if (pos? n) + (rf result input) + result)] + (if (not (pos? nn)) + (ensure-reduced result) + result))))))) + ([n coll] + {:pre [(number? n)]} + (lazy-seq + (when (pos? n) + (when-let [s (seq coll)] + (cons (first s) (take (dec n) (rest s)))))))) + +(defn drop + "Returns a lazy sequence of all but the first n items in coll. + Returns a stateful transducer when no collection is provided." + ([n] + {:pre [(number? n)]} + (fn [rf] + (let [na (volatile! n)] + (fn + ([] (rf)) + ([result] (rf result)) + ([result input] + (let [n @na] + (vswap! na dec) + (if (pos? n) + result + (rf result input)))))))) + ([n coll] + {:pre [(number? n)]} + (let [step (fn [n coll] + (let [s (seq coll)] + (if (and (pos? n) s) + (recur (dec n) (rest s)) + s)))] + (lazy-seq (step n coll))))) + +(defn drop-last + "Return a lazy sequence of all but the last n (default 1) items in coll" + ([s] (drop-last 1 s)) + ([n s] (map (fn [x _] x) s (drop n s)))) + +(defn take-last + "Returns a seq of the last n items in coll. Depending on the type + of coll may be no better than linear time. For vectors, see also subvec." + [n coll] + (loop [s (seq coll), lead (seq (drop n coll))] + (if lead + (recur (next s) (next lead)) + s))) + +(defn drop-while + "Returns a lazy sequence of the items in coll starting from the + first item for which (pred item) returns logical false. Returns a + stateful transducer when no collection is provided." + ([pred] + (fn [rf] + (let [da (volatile! true)] + (fn + ([] (rf)) + ([result] (rf result)) + ([result input] + (let [drop? @da] + (if (and drop? (pred input)) + result + (do + (vreset! da nil) + (rf result input))))))))) + ([pred coll] + (let [step (fn [pred coll] + (let [s (seq coll)] + (if (and s (pred (first s))) + (recur pred (rest s)) + s)))] + (lazy-seq (step pred coll))))) + +(deftype Cycle [meta all prev ^:mutable current ^:mutable _next] + Object + (toString [coll] + (pr-str* coll)) + (currentval [coll] + (when-not ^seq current + (if-let [c (next prev)] + (set! current c) + (set! current all))) + current) + + IPending + (-realized? [coll] + (some? current)) + + IWithMeta + (-with-meta [coll new-meta] + (if (identical? new-meta meta) + coll + (Cycle. new-meta all prev current _next))) + + IMeta + (-meta [coll] meta) + + ISeq + (-first [coll] + (first (.currentval coll))) + (-rest [coll] + (when (nil? _next) + (set! _next (Cycle. nil all (.currentval coll) nil nil))) + _next) + + INext + (-next [coll] + (-rest coll)) + + ICollection + (-conj [coll o] (cons o coll)) + + IEmptyableCollection + (-empty [coll] (.-EMPTY List)) + + ISequential + ISeqable + (-seq [coll] coll) + + IReduce + (-reduce [coll f] + (loop [s (.currentval coll) ret (first s)] + (let [s (or (next s) all) + ret (f ret (first s))] + (if (reduced? ret) + @ret + (recur s ret))))) + (-reduce [coll f start] + (loop [s (.currentval coll) ret start] + (let [ret (f ret (first s))] + (if (reduced? ret) + @ret + (recur (or (next s) all) ret)))))) + +(defn cycle + "Returns a lazy (infinite!) sequence of repetitions of the items in coll." + [coll] (if-let [vals (seq coll)] + (Cycle. nil vals nil vals nil) + (.-EMPTY List))) + +(defn split-at + "Returns a vector of [(take n coll) (drop n coll)]" + [n coll] + [(take n coll) (drop n coll)]) + +(deftype Repeat [meta count val ^:mutable next ^:mutable __hash] + Object + (toString [coll] + (pr-str* coll)) + (equiv [this other] + (-equiv this other)) + (indexOf [coll x] + (-indexOf coll x 0)) + (indexOf [coll x start] + (-indexOf coll x start)) + (lastIndexOf [coll x] + (-lastIndexOf coll x count)) + (lastIndexOf [coll x start] + (-lastIndexOf coll x start)) + + IPending + (-realized? [coll] false) + + IWithMeta + (-with-meta [coll new-meta] + (if (identical? new-meta meta) + coll + (Repeat. new-meta count val next nil))) + + IMeta + (-meta [coll] meta) + + ISeq + (-first [coll] + val) + (-rest [coll] + (if (nil? next) + (if (> count 1) + (do + (set! next (Repeat. nil (dec count) val nil nil)) + next) + (if (== -1 count) + coll + ())) + next)) + + INext + (-next [coll] + (if (nil? next) + (if (> count 1) + (do + (set! next (Repeat. nil (dec count) val nil nil)) + next) + (if (== -1 count) + coll + nil)) + next)) + + ICollection + (-conj [coll o] (cons o coll)) + + IEmptyableCollection + (-empty [coll] (.-EMPTY List)) + + IHash + (-hash [coll] (caching-hash coll hash-ordered-coll __hash)) + + ISequential + ISeqable + (-seq [coll] coll) + + IEquiv + (-equiv [coll other] (equiv-sequential coll other)) + + IReduce + (-reduce [coll f] + (if (== count -1) + (loop [ret (f val val)] + (if (reduced? ret) + @ret + (recur (f ret val)))) + (loop [i 1 ret val] + (if (< i count) + (let [ret (f ret val)] + (if (reduced? ret) + @ret + (recur (inc i) ret))) + ret)))) + (-reduce [coll f start] + (if (== count -1) + (loop [ret (f start val)] + (if (reduced? ret) + @ret + (recur (f ret val)))) + (loop [i 0 ret start] + (if (< i count) + (let [ret (f ret val)] + (if (reduced? ret) + @ret + (recur (inc i) ret))) + ret))))) + +(defn repeat + "Returns a lazy (infinite!, or length n if supplied) sequence of xs." + ([x] (Repeat. nil -1 x nil nil)) + ([n x] (if (pos? n) + (Repeat. nil n x nil nil) + (.-EMPTY List)))) + +(defn replicate + "DEPRECATED: Use 'repeat' instead. + Returns a lazy seq of n xs." + [n x] (take n (repeat x))) + +(defn repeatedly + "Takes a function of no args, presumably with side effects, and + returns an infinite (or length n if supplied) lazy sequence of calls + to it" + ([f] (lazy-seq (cons (f) (repeatedly f)))) + ([n f] (take n (repeatedly f)))) + +(def ^:private UNREALIZED-SEED #js {}) + +(deftype Iterate [meta f prev-seed ^:mutable seed ^:mutable next] + Object + (toString [coll] + (pr-str* coll)) + + IPending + (-realized? [coll] + (not (identical? seed UNREALIZED-SEED))) + + IWithMeta + (-with-meta [coll new-meta] + (if (identical? new-meta meta) + coll + (Iterate. new-meta f prev-seed seed next))) + + IMeta + (-meta [coll] meta) + + ISeq + (-first [coll] + (when (identical? UNREALIZED-SEED seed) + (set! seed (f prev-seed))) + seed) + (-rest [coll] + (when (nil? next) + (set! next (Iterate. nil f (-first coll) UNREALIZED-SEED nil))) + next) + + INext + (-next [coll] + (-rest coll)) + + ICollection + (-conj [coll o] (cons o coll)) + + IEmptyableCollection + (-empty [coll] (.-EMPTY List)) + + ISequential + ISeqable + (-seq [coll] coll) + + IReduce + (-reduce [coll rf] + (let [first (-first coll) + v (f first)] + (loop [ret (rf first v) v v] + (if (reduced? ret) + @ret + (let [v (f v)] + (recur (rf ret v) v)))))) + (-reduce [coll rf start] + (let [v (-first coll)] + (loop [ret (rf start v) v v] + (if (reduced? ret) + @ret + (let [v (f v)] + (recur (rf ret v) v))))))) + +(defn iterate + "Returns a lazy sequence of x, (f x), (f (f x)) etc. f must be free of side-effects" + {:added "1.0"} + [f x] (Iterate. nil f nil x nil)) + +(defn interleave + "Returns a lazy seq of the first item in each coll, then the second etc." + ([] ()) + ([c1] (lazy-seq c1)) + ([c1 c2] + (lazy-seq + (let [s1 (seq c1) s2 (seq c2)] + (when (and s1 s2) + (cons (first s1) (cons (first s2) + (interleave (rest s1) (rest s2)))))))) + ([c1 c2 & colls] + (lazy-seq + (let [ss (map seq (conj colls c2 c1))] + (when (every? identity ss) + (concat (map first ss) (apply interleave (map rest ss)))))))) + +(defn interpose + "Returns a lazy seq of the elements of coll separated by sep. + Returns a stateful transducer when no collection is provided." + ([sep] + (fn [rf] + (let [started (volatile! false)] + (fn + ([] (rf)) + ([result] (rf result)) + ([result input] + (if @started + (let [sepr (rf result sep)] + (if (reduced? sepr) + sepr + (rf sepr input))) + (do + (vreset! started true) + (rf result input)))))))) + ([sep coll] (drop 1 (interleave (repeat sep) coll)))) + + + +(defn- flatten1 + "Take a collection of collections, and return a lazy seq + of items from the inner collection" + [colls] + (let [cat (fn cat [coll colls] + (lazy-seq + (if-let [coll (seq coll)] + (cons (first coll) (cat (rest coll) colls)) + (when (seq colls) + (cat (first colls) (rest colls))))))] + (cat nil colls))) + +(declare cat) + +(defn mapcat + "Returns the result of applying concat to the result of applying map + to f and colls. Thus function f should return a collection. Returns + a transducer when no collections are provided" + {:added "1.0" + :static true} + ([f] (comp (map f) cat)) + ([f & colls] + (apply concat (apply map f colls)))) + +(defn filter + "Returns a lazy sequence of the items in coll for which + (pred item) returns logical true. pred must be free of side-effects. + Returns a transducer when no collection is provided." + ([pred] + (fn [rf] + (fn + ([] (rf)) + ([result] (rf result)) + ([result input] + (if (pred input) + (rf result input) + result))))) + ([pred coll] + (lazy-seq + (when-let [s (seq coll)] + (if (chunked-seq? s) + (let [c (chunk-first s) + size (count c) + b (chunk-buffer size)] + (dotimes [i size] + (when (pred (-nth c i)) + (chunk-append b (-nth c i)))) + (chunk-cons (chunk b) (filter pred (chunk-rest s)))) + (let [f (first s) r (rest s)] + (if (pred f) + (cons f (filter pred r)) + (filter pred r)))))))) + +(defn remove + "Returns a lazy sequence of the items in coll for which + (pred item) returns logical false. pred must be free of side-effects. + Returns a transducer when no collection is provided." + ([pred] (filter (complement pred))) + ([pred coll] + (filter (complement pred) coll))) + +(defn tree-seq + "Returns a lazy sequence of the nodes in a tree, via a depth-first walk. + branch? must be a fn of one arg that returns true if passed a node + that can have children (but may not). children must be a fn of one + arg that returns a sequence of the children. Will only be called on + nodes for which branch? returns true. Root is the root node of the + tree." + [branch? children root] + (let [walk (fn walk [node] + (lazy-seq + (cons node + (when (branch? node) + (mapcat walk (children node))))))] + (walk root))) + +(defn flatten + "Takes any nested combination of sequential things (lists, vectors, + etc.) and returns their contents as a single, flat sequence. + (flatten nil) returns nil." + [x] + (filter #(not (sequential? %)) + (rest (tree-seq sequential? seq x)))) + +(defn into + "Returns a new coll consisting of to-coll with all of the items of + from-coll conjoined. A transducer may be supplied." + ([] []) + ([to] to) + ([to from] + (if-not (nil? to) + (if (implements? IEditableCollection to) + (-with-meta (persistent! (reduce -conj! (transient to) from)) (meta to)) + (reduce -conj to from)) + (reduce conj to from))) + ([to xform from] + (if (implements? IEditableCollection to) + (-with-meta (persistent! (transduce xform conj! (transient to) from)) (meta to)) + (transduce xform conj to from)))) + +(defn mapv + "Returns a vector consisting of the result of applying f to the + set of first items of each coll, followed by applying f to the set + of second items in each coll, until any one of the colls is + exhausted. Any remaining items in other colls are ignored. Function + f should accept number-of-colls arguments." + ([f coll] + (-> (reduce (fn [v o] (conj! v (f o))) (transient []) coll) + persistent!)) + ([f c1 c2] + (into [] (map f c1 c2))) + ([f c1 c2 c3] + (into [] (map f c1 c2 c3))) + ([f c1 c2 c3 & colls] + (into [] (apply map f c1 c2 c3 colls)))) + +(defn filterv + "Returns a vector of the items in coll for which + (pred item) returns logical true. pred must be free of side-effects." + [pred coll] + (-> (reduce (fn [v o] (if (pred o) (conj! v o) v)) + (transient []) + coll) + persistent!)) + +(defn partition + "Returns a lazy sequence of lists of n items each, at offsets step + apart. If step is not supplied, defaults to n, i.e. the partitions + do not overlap. If a pad collection is supplied, use its elements as + necessary to complete last partition up to n items. In case there are + not enough padding elements, return a partition with less than n items." + ([n coll] + (partition n n coll)) + ([n step coll] + (lazy-seq + (when-let [s (seq coll)] + (let [p (take n s)] + (when (== n (count p)) + (cons p (partition n step (drop step s)))))))) + ([n step pad coll] + (lazy-seq + (when-let [s (seq coll)] + (let [p (take n s)] + (if (== n (count p)) + (cons p (partition n step pad (drop step s))) + (list (take n (concat p pad))))))))) + +(defn get-in + "Returns the value in a nested associative structure, + where ks is a sequence of keys. Returns nil if the key is not present, + or the not-found value if supplied." + {:added "1.2" + :static true} + ([m ks] + (reduce get m ks)) + ([m ks not-found] + (loop [sentinel lookup-sentinel + m m + ks (seq ks)] + (if-not (nil? ks) + (let [m (get m (first ks) sentinel)] + (if (identical? sentinel m) + not-found + (recur sentinel m (next ks)))) + m)))) + +(defn assoc-in + "Associates a value in a nested associative structure, where ks is a + sequence of keys and v is the new value and returns a new nested structure. + If any levels do not exist, hash-maps will be created." + [m [k & ks] v] + (if ks + (assoc m k (assoc-in (get m k) ks v)) + (assoc m k v))) + +(defn update-in + "'Updates' a value in a nested associative structure, where ks is a + sequence of keys and f is a function that will take the old value + and any supplied args and return the new value, and returns a new + nested structure. If any levels do not exist, hash-maps will be + created." + ([m [k & ks] f] + (if ks + (assoc m k (update-in (get m k) ks f)) + (assoc m k (f (get m k))))) + ([m [k & ks] f a] + (if ks + (assoc m k (update-in (get m k) ks f a)) + (assoc m k (f (get m k) a)))) + ([m [k & ks] f a b] + (if ks + (assoc m k (update-in (get m k) ks f a b)) + (assoc m k (f (get m k) a b)))) + ([m [k & ks] f a b c] + (if ks + (assoc m k (update-in (get m k) ks f a b c)) + (assoc m k (f (get m k) a b c)))) + ([m [k & ks] f a b c & args] + (if ks + (assoc m k (apply update-in (get m k) ks f a b c args)) + (assoc m k (apply f (get m k) a b c args))))) + +(defn update + "'Updates' a value in an associative structure, where k is a + key and f is a function that will take the old value + and any supplied args and return the new value, and returns a new + structure. If the key does not exist, nil is passed as the old value." + ([m k f] + (assoc m k (f (get m k)))) + ([m k f x] + (assoc m k (f (get m k) x))) + ([m k f x y] + (assoc m k (f (get m k) x y))) + ([m k f x y z] + (assoc m k (f (get m k) x y z))) + ([m k f x y z & more] + (assoc m k (apply f (get m k) x y z more)))) + +;;; PersistentVector + +(deftype VectorNode [edit arr]) + +(defn- pv-fresh-node [edit] + (VectorNode. edit (make-array 32))) + +(defn- pv-aget [node idx] + (aget (.-arr node) idx)) + +(defn- pv-aset [node idx val] + (aset (.-arr node) idx val)) + +(defn- pv-clone-node [node] + (VectorNode. (.-edit node) (aclone (.-arr node)))) + +(defn- tail-off [pv] + (let [cnt (.-cnt pv)] + (if (< cnt 32) + 0 + (bit-shift-left (bit-shift-right-zero-fill (dec cnt) 5) 5)))) + +(defn- new-path [edit level node] + (loop [ll level + ret node] + (if (zero? ll) + ret + (let [embed ret + r (pv-fresh-node edit) + _ (pv-aset r 0 embed)] + (recur (- ll 5) r))))) + +(defn- push-tail [pv level parent tailnode] + (let [ret (pv-clone-node parent) + subidx (bit-and (bit-shift-right-zero-fill (dec (.-cnt pv)) level) 0x01f)] + (if (== 5 level) + (do + (pv-aset ret subidx tailnode) + ret) + (let [child (pv-aget parent subidx)] + (if-not (nil? child) + (let [node-to-insert (push-tail pv (- level 5) child tailnode)] + (pv-aset ret subidx node-to-insert) + ret) + (let [node-to-insert (new-path nil (- level 5) tailnode)] + (pv-aset ret subidx node-to-insert) + ret)))))) + +(defn- vector-index-out-of-bounds [i cnt] + (throw (js/Error. (str "No item " i " in vector of length " cnt)))) + +(defn- first-array-for-longvec [pv] + ;; invariants: (count pv) > 32. + (loop [node (.-root pv) + level (.-shift pv)] + (if (pos? level) + (recur (pv-aget node 0) (- level 5)) + (.-arr node)))) + +(defn- unchecked-array-for [pv i] + ;; invariant: i is a valid index of pv (use array-for if unknown). + (if (>= i (tail-off pv)) + (.-tail pv) + (loop [node (.-root pv) + level (.-shift pv)] + (if (pos? level) + (recur (pv-aget node (bit-and (bit-shift-right-zero-fill i level) 0x01f)) + (- level 5)) + (.-arr node))))) + +(defn- array-for [pv i] + (if (and (<= 0 i) (< i (.-cnt pv))) + (unchecked-array-for pv i) + (vector-index-out-of-bounds i (.-cnt pv)))) + +(defn- do-assoc [pv level node i val] + (let [ret (pv-clone-node node)] + (if (zero? level) + (do + (pv-aset ret (bit-and i 0x01f) val) + ret) + (let [subidx (bit-and (bit-shift-right-zero-fill i level) 0x01f)] + (pv-aset ret subidx (do-assoc pv (- level 5) (pv-aget node subidx) i val)) + ret)))) + +(defn- pop-tail [pv level node] + (let [subidx (bit-and (bit-shift-right-zero-fill (- (.-cnt pv) 2) level) 0x01f)] + (cond + (> level 5) (let [new-child (pop-tail pv (- level 5) (pv-aget node subidx))] + (if (and (nil? new-child) (zero? subidx)) + nil + (let [ret (pv-clone-node node)] + (pv-aset ret subidx new-child) + ret))) + (zero? subidx) nil + :else (let [ret (pv-clone-node node)] + (pv-aset ret subidx nil) + ret)))) + +(deftype RangedIterator [^:mutable i ^:mutable base ^:mutable arr v start end] + Object + (hasNext [this] + (< i end)) + (next [this] + (when (== (- i base) 32) + (set! arr (unchecked-array-for v i)) + (set! base (+ base 32))) + (let [ret (aget arr (bit-and i 0x01f))] + (set! i (inc i)) + ret))) + +(defn ranged-iterator [v start end] + (let [i start] + (RangedIterator. i (- i (js-mod i 32)) + (when (< start (count v)) + (unchecked-array-for v i)) + v start end))) + +(defn- pv-reduce + ([pv f start end] + (if (< start end) + (pv-reduce pv f (nth pv start) (inc start) end) + (f))) + ([pv f init start end] + (loop [acc init i start arr (unchecked-array-for pv start)] + (if (< i end) + (let [j (bit-and i 0x01f) + arr (if (zero? j) (unchecked-array-for pv i) arr) + nacc (f acc (aget arr j))] + (if (reduced? nacc) + @nacc + (recur nacc (inc i) arr))) + acc)))) + +(declare tv-editable-root tv-editable-tail TransientVector deref + pr-sequential-writer pr-writer chunked-seq) + +(defprotocol APersistentVector + "Marker protocol") + +(deftype PersistentVector [meta cnt shift root tail ^:mutable __hash] + Object + (toString [coll] + (pr-str* coll)) + (equiv [this other] + (-equiv this other)) + (indexOf [coll x] + (-indexOf coll x 0)) + (indexOf [coll x start] + (-indexOf coll x start)) + (lastIndexOf [coll x] + (-lastIndexOf coll x (count coll))) + (lastIndexOf [coll x start] + (-lastIndexOf coll x start)) + + ICloneable + (-clone [_] (PersistentVector. meta cnt shift root tail __hash)) + + IWithMeta + (-with-meta [coll new-meta] + (if (identical? new-meta meta) + coll + (PersistentVector. new-meta cnt shift root tail __hash))) + + IMeta + (-meta [coll] meta) + + IStack + (-peek [coll] + (when (> cnt 0) + (-nth coll (dec cnt)))) + (-pop [coll] + (cond + (zero? cnt) (throw (js/Error. "Can't pop empty vector")) + (== 1 cnt) (-with-meta (.-EMPTY PersistentVector) meta) + (< 1 (- cnt (tail-off coll))) + (PersistentVector. meta (dec cnt) shift root (.slice tail 0 -1) nil) + :else (let [new-tail (unchecked-array-for coll (- cnt 2)) + nr (pop-tail coll shift root) + new-root (if (nil? nr) (.-EMPTY-NODE PersistentVector) nr) + cnt-1 (dec cnt)] + (if (and (< 5 shift) (nil? (pv-aget new-root 1))) + (PersistentVector. meta cnt-1 (- shift 5) (pv-aget new-root 0) new-tail nil) + (PersistentVector. meta cnt-1 shift new-root new-tail nil))))) + + ICollection + (-conj [coll o] + (if (< (- cnt (tail-off coll)) 32) + (let [len (alength tail) + new-tail (make-array (inc len))] + (dotimes [i len] + (aset new-tail i (aget tail i))) + (aset new-tail len o) + (PersistentVector. meta (inc cnt) shift root new-tail nil)) + (let [root-overflow? (> (bit-shift-right-zero-fill cnt 5) (bit-shift-left 1 shift)) + new-shift (if root-overflow? (+ shift 5) shift) + new-root (if root-overflow? + (let [n-r (pv-fresh-node nil)] + (pv-aset n-r 0 root) + (pv-aset n-r 1 (new-path nil shift (VectorNode. nil tail))) + n-r) + (push-tail coll shift root (VectorNode. nil tail)))] + (PersistentVector. meta (inc cnt) new-shift new-root (array o) nil)))) + + IEmptyableCollection + (-empty [coll] (-with-meta (.-EMPTY PersistentVector) meta)) + + ISequential + IEquiv + (-equiv [coll other] + (if (instance? PersistentVector other) + (if (== cnt (count other)) + (let [me-iter (-iterator coll) + you-iter (-iterator other)] + (loop [] + (if ^boolean (.hasNext me-iter) + (let [x (.next me-iter) + y (.next you-iter)] + (if (= x y) + (recur) + false)) + true))) + false) + (equiv-sequential coll other))) + + IHash + (-hash [coll] (caching-hash coll hash-ordered-coll __hash)) + + ISeqable + (-seq [coll] + (cond + (zero? cnt) nil + (<= cnt 32) (IndexedSeq. tail 0 nil) + :else (chunked-seq coll (first-array-for-longvec coll) 0 0))) + + ICounted + (-count [coll] cnt) + + IIndexed + (-nth [coll n] + (aget (array-for coll n) (bit-and n 0x01f))) + (-nth [coll n not-found] + (if (and (<= 0 n) (< n cnt)) + (aget (unchecked-array-for coll n) (bit-and n 0x01f)) + not-found)) + + ILookup + (-lookup [coll k] (-lookup coll k nil)) + (-lookup [coll k not-found] (if (number? k) + (-nth coll k not-found) + not-found)) + + IAssociative + (-assoc [coll k v] + (if (number? k) + (-assoc-n coll k v) + (throw (js/Error. "Vector's key for assoc must be a number.")))) + (-contains-key? [coll k] + (if (integer? k) + (and (<= 0 k) (< k cnt)) + false)) + + IFind + (-find [coll n] + (when (and (<= 0 n) (< n cnt)) + (MapEntry. n (aget (unchecked-array-for coll n) (bit-and n 0x01f)) nil))) + + APersistentVector + IVector + (-assoc-n [coll n val] + (cond + (and (<= 0 n) (< n cnt)) + (if (<= (tail-off coll) n) + (let [new-tail (aclone tail)] + (aset new-tail (bit-and n 0x01f) val) + (PersistentVector. meta cnt shift root new-tail nil)) + (PersistentVector. meta cnt shift (do-assoc coll shift root n val) tail nil)) + (== n cnt) (-conj coll val) + :else (throw (js/Error. (str "Index " n " out of bounds [0," cnt "]"))))) + + IReduce + (-reduce [v f] + (pv-reduce v f 0 cnt)) + (-reduce [v f init] + (loop [i 0 init init] + (if (< i cnt) + (let [arr (unchecked-array-for v i) + len (alength arr) + init (loop [j 0 init init] + (if (< j len) + (let [init (f init (aget arr j))] + (if (reduced? init) + init + (recur (inc j) init))) + init))] + (if (reduced? init) + @init + (recur (+ i len) init))) + init))) + + IKVReduce + (-kv-reduce [v f init] + (loop [i 0 init init] + (if (< i cnt) + (let [arr (unchecked-array-for v i) + len (alength arr) + init (loop [j 0 init init] + (if (< j len) + (let [init (f init (+ j i) (aget arr j))] + (if (reduced? init) + init + (recur (inc j) init))) + init))] + (if (reduced? init) + @init + (recur (+ i len) init))) + init))) + + IFn + (-invoke [coll k] + (-nth coll k)) + (-invoke [coll k not-found] + (-nth coll k not-found)) + + IEditableCollection + (-as-transient [coll] + (TransientVector. cnt shift (tv-editable-root root) (tv-editable-tail tail))) + + IReversible + (-rseq [coll] + (when (pos? cnt) + (RSeq. coll (dec cnt) nil))) + + IIterable + (-iterator [this] + (ranged-iterator this 0 cnt))) + +(set! (.-EMPTY-NODE PersistentVector) (VectorNode. nil (make-array 32))) + +(set! (.-EMPTY PersistentVector) + (PersistentVector. nil 0 5 (.-EMPTY-NODE PersistentVector) (array) empty-ordered-hash)) + +(set! (.-fromArray PersistentVector) + (fn [xs ^boolean no-clone] + (let [l (alength xs) + xs (if no-clone xs (aclone xs))] + (if (< l 32) + (PersistentVector. nil l 5 (.-EMPTY-NODE PersistentVector) xs nil) + (let [node (.slice xs 0 32) + v (PersistentVector. nil 32 5 (.-EMPTY-NODE PersistentVector) node nil)] + (loop [i 32 out (-as-transient v)] + (if (< i l) + (recur (inc i) (conj! out (aget xs i))) + (persistent! out)))))))) + +(es6-iterable PersistentVector) + +(declare map-entry?) + +(defn vec + "Creates a new vector containing the contents of coll. JavaScript arrays + will be aliased and should not be modified." + [coll] + (cond + (map-entry? coll) + [(key coll) (val coll)] + + (vector? coll) + (with-meta coll nil) + + (array? coll) + (.fromArray PersistentVector coll true) + + :else + (-persistent! + (reduce -conj! + (-as-transient (.-EMPTY PersistentVector)) + coll)))) + +(defn vector + "Creates a new vector containing the args." + [& args] + (if (and (instance? IndexedSeq args) (zero? (.-i args))) + (.fromArray PersistentVector (.-arr args) (not (array? (.-arr args)))) + (vec args))) + +(declare subvec) + +(deftype ChunkedSeq [vec node i off meta ^:mutable __hash] + Object + (toString [coll] + (pr-str* coll)) + (equiv [this other] + (-equiv this other)) + (indexOf [coll x] + (-indexOf coll x 0)) + (indexOf [coll x start] + (-indexOf coll x start)) + (lastIndexOf [coll x] + (-lastIndexOf coll x (count coll))) + (lastIndexOf [coll x start] + (-lastIndexOf coll x start)) + + IWithMeta + (-with-meta [coll new-meta] + (if (identical? new-meta meta) + coll + (chunked-seq vec node i off new-meta))) + IMeta + (-meta [coll] meta) + + ISeqable + (-seq [coll] coll) + + ISequential + IEquiv + (-equiv [coll other] (equiv-sequential coll other)) + + ASeq + ISeq + (-first [coll] + (aget node off)) + (-rest [coll] + (if (< (inc off) (alength node)) + (let [s (chunked-seq vec node i (inc off))] + (if (nil? s) + () + s)) + (-chunked-rest coll))) + + INext + (-next [coll] + (if (< (inc off) (alength node)) + (let [s (chunked-seq vec node i (inc off))] + (if (nil? s) + nil + s)) + (-chunked-next coll))) + + ICollection + (-conj [coll o] + (cons o coll)) + + IEmptyableCollection + (-empty [coll] + ()) + + IChunkedSeq + (-chunked-first [coll] + (array-chunk node off)) + (-chunked-rest [coll] + (let [end (+ i (alength node))] + (if (< end (-count vec)) + (chunked-seq vec (unchecked-array-for vec end) end 0) + ()))) + + IChunkedNext + (-chunked-next [coll] + (let [end (+ i (alength node))] + (when (< end (-count vec)) + (chunked-seq vec (unchecked-array-for vec end) end 0)))) + + IHash + (-hash [coll] (caching-hash coll hash-ordered-coll __hash)) + + IReduce + (-reduce [coll f] + (pv-reduce vec f (+ i off) (count vec))) + + (-reduce [coll f start] + (pv-reduce vec f start (+ i off) (count vec)))) + +(es6-iterable ChunkedSeq) + +(defn chunked-seq + ([vec i off] (ChunkedSeq. vec (array-for vec i) i off nil nil)) + ([vec node i off] (ChunkedSeq. vec node i off nil nil)) + ([vec node i off meta] + (ChunkedSeq. vec node i off meta nil))) + +(declare build-subvec) + +(deftype Subvec [meta v start end ^:mutable __hash] + Object + (toString [coll] + (pr-str* coll)) + (equiv [this other] + (-equiv this other)) + (indexOf [coll x] + (-indexOf coll x 0)) + (indexOf [coll x start] + (-indexOf coll x start)) + (lastIndexOf [coll x] + (-lastIndexOf coll x (count coll))) + (lastIndexOf [coll x start] + (-lastIndexOf coll x start)) + + ICloneable + (-clone [_] (Subvec. meta v start end __hash)) + + IWithMeta + (-with-meta [coll new-meta] + (if (identical? new-meta meta) + coll + (build-subvec new-meta v start end __hash))) + + IMeta + (-meta [coll] meta) + + IStack + (-peek [coll] + (when-not (== start end) + (-nth v (dec end)))) + (-pop [coll] + (if (== start end) + (throw (js/Error. "Can't pop empty vector")) + (build-subvec meta v start (dec end) nil))) + + ICollection + (-conj [coll o] + (build-subvec meta (-assoc-n v end o) start (inc end) nil)) + + IEmptyableCollection + (-empty [coll] (-with-meta (.-EMPTY PersistentVector) meta)) + + ISequential + IEquiv + (-equiv [coll other] (equiv-sequential coll other)) + + IHash + (-hash [coll] (caching-hash coll hash-ordered-coll __hash)) + + ISeqable + (-seq [coll] + (let [subvec-seq (fn subvec-seq [i] + (when-not (== i end) + (cons (-nth v i) + (lazy-seq + (subvec-seq (inc i))))))] + (subvec-seq start))) + + IReversible + (-rseq [coll] + (if-not (== start end) + (RSeq. coll (dec (- end start)) nil))) + + ICounted + (-count [coll] (- end start)) + + IIndexed + (-nth [coll n] + (if (or (neg? n) (<= end (+ start n))) + (vector-index-out-of-bounds n (- end start)) + (-nth v (+ start n)))) + (-nth [coll n not-found] + (if (or (neg? n) (<= end (+ start n))) + not-found + (-nth v (+ start n) not-found))) + + ILookup + (-lookup [coll k] (-lookup coll k nil)) + (-lookup [coll k not-found] (if (number? k) + (-nth coll k not-found) + not-found)) + + IAssociative + (-assoc [coll key val] + (if (number? key) + (-assoc-n coll key val) + (throw (js/Error. "Subvec's key for assoc must be a number.")))) + + IFind + (-find [coll n] + (when-not (neg? n) + (let [idx (+ start n)] + (when (< idx end) + (MapEntry. n (-lookup v idx) nil))))) + + IVector + (-assoc-n [coll n val] + (let [v-pos (+ start n)] + (if (or (neg? n) (<= (inc end) v-pos)) + (throw (js/Error. (str "Index " n " out of bounds [0," (-count coll) "]"))) + (build-subvec meta (assoc v v-pos val) start (max end (inc v-pos)) nil)))) + + IReduce + (-reduce [coll f] + (if (implements? APersistentVector v) + (pv-reduce v f start end) + (ci-reduce coll f))) + (-reduce [coll f init] + (if (implements? APersistentVector v) + (pv-reduce v f init start end) + (ci-reduce coll f init))) + + IKVReduce + (-kv-reduce [coll f init] + (loop [i start j 0 init init] + (if (< i end) + (let [init (f init j (-nth v i))] + (if (reduced? init) + @init + (recur (inc i) (inc j) init))) + init))) + + IFn + (-invoke [coll k] + (-nth coll k)) + (-invoke [coll k not-found] + (-nth coll k not-found)) + + IIterable + (-iterator [coll] + (if (implements? APersistentVector v) + (ranged-iterator v start end) + (seq-iter coll)))) + +(es6-iterable Subvec) + +(defn- build-subvec [meta v start end __hash] + (if (instance? Subvec v) + (recur meta (.-v v) (+ (.-start v) start) (+ (.-start v) end) __hash) + (do + (when-not (vector? v) + (throw (js/Error. "v must satisfy IVector"))) + (when (or (neg? start) + (< end start) + (> end (count v))) + (throw (js/Error. "Index out of bounds"))) + (Subvec. meta v start end __hash)))) + +(defn subvec + "Returns a persistent vector of the items in vector from + start (inclusive) to end (exclusive). If end is not supplied, + defaults to (count vector). This operation is O(1) and very fast, as + the resulting vector shares structure with the original and no + trimming is done." + ([v start] + (subvec v start (count v))) + ([v start end] + (assert (and (not (nil? start)) (not (nil? end)))) + (build-subvec nil v (int start) (int end) nil))) + +(defn- tv-ensure-editable [edit node] + (if (identical? edit (.-edit node)) + node + (VectorNode. edit (aclone (.-arr node))))) + +(defn- tv-editable-root [node] + (VectorNode. (js-obj) (aclone (.-arr node)))) + +(defn- tv-editable-tail [tl] + (let [ret (make-array 32)] + (array-copy tl 0 ret 0 (alength tl)) + ret)) + +(defn- tv-push-tail [tv level parent tail-node] + (let [ret (tv-ensure-editable (.. tv -root -edit) parent) + subidx (bit-and (bit-shift-right-zero-fill (dec (.-cnt tv)) level) 0x01f)] + (pv-aset ret subidx + (if (== level 5) + tail-node + (let [child (pv-aget ret subidx)] + (if-not (nil? child) + (tv-push-tail tv (- level 5) child tail-node) + (new-path (.. tv -root -edit) (- level 5) tail-node))))) + ret)) + +(defn- tv-pop-tail [tv level node] + (let [node (tv-ensure-editable (.. tv -root -edit) node) + subidx (bit-and (bit-shift-right-zero-fill (- (.-cnt tv) 2) level) 0x01f)] + (cond + (> level 5) (let [new-child (tv-pop-tail + tv (- level 5) (pv-aget node subidx))] + (if (and (nil? new-child) (zero? subidx)) + nil + (do (pv-aset node subidx new-child) + node))) + (zero? subidx) nil + :else (do (pv-aset node subidx nil) + node)))) + +(defn- unchecked-editable-array-for [tv i] + ;; invariant: i is a valid index of tv. + (if (>= i (tail-off tv)) + (.-tail tv) + (let [root (.-root tv)] + (loop [node root + level (.-shift tv)] + (if (pos? level) + (recur (tv-ensure-editable + (.-edit root) + (pv-aget node + (bit-and (bit-shift-right-zero-fill i level) + 0x01f))) + (- level 5)) + (.-arr node)))))) + +(deftype TransientVector [^:mutable cnt + ^:mutable shift + ^:mutable root + ^:mutable tail] + ITransientCollection + (-conj! [tcoll o] + (if ^boolean (.-edit root) + (if (< (- cnt (tail-off tcoll)) 32) + (do (aset tail (bit-and cnt 0x01f) o) + (set! cnt (inc cnt)) + tcoll) + (let [tail-node (VectorNode. (.-edit root) tail) + new-tail (make-array 32)] + (aset new-tail 0 o) + (set! tail new-tail) + (if (> (bit-shift-right-zero-fill cnt 5) + (bit-shift-left 1 shift)) + (let [new-root-array (make-array 32) + new-shift (+ shift 5)] + (aset new-root-array 0 root) + (aset new-root-array 1 (new-path (.-edit root) shift tail-node)) + (set! root (VectorNode. (.-edit root) new-root-array)) + (set! shift new-shift) + (set! cnt (inc cnt)) + tcoll) + (let [new-root (tv-push-tail tcoll shift root tail-node)] + (set! root new-root) + (set! cnt (inc cnt)) + tcoll)))) + (throw (js/Error. "conj! after persistent!")))) + + (-persistent! [tcoll] + (if ^boolean (.-edit root) + (do (set! (.-edit root) nil) + (let [len (- cnt (tail-off tcoll)) + trimmed-tail (make-array len)] + (array-copy tail 0 trimmed-tail 0 len) + (PersistentVector. nil cnt shift root trimmed-tail nil))) + (throw (js/Error. "persistent! called twice")))) + + ITransientAssociative + (-assoc! [tcoll key val] + (if (number? key) + (-assoc-n! tcoll key val) + (throw (js/Error. "TransientVector's key for assoc! must be a number.")))) + + ITransientVector + (-assoc-n! [tcoll n val] + (if ^boolean (.-edit root) + (cond + (and (<= 0 n) (< n cnt)) + (if (<= (tail-off tcoll) n) + (do (aset tail (bit-and n 0x01f) val) + tcoll) + (let [new-root + ((fn go [level node] + (let [node (tv-ensure-editable (.-edit root) node)] + (if (zero? level) + (do (pv-aset node (bit-and n 0x01f) val) + node) + (let [subidx (bit-and (bit-shift-right-zero-fill n level) + 0x01f)] + (pv-aset node subidx + (go (- level 5) (pv-aget node subidx))) + node)))) + shift root)] + (set! root new-root) + tcoll)) + (== n cnt) (-conj! tcoll val) + :else + (throw + (js/Error. + (str "Index " n " out of bounds for TransientVector of length" cnt)))) + (throw (js/Error. "assoc! after persistent!")))) + + (-pop! [tcoll] + (if ^boolean (.-edit root) + (cond + (zero? cnt) (throw (js/Error. "Can't pop empty vector")) + (== 1 cnt) (do (set! cnt 0) tcoll) + (pos? (bit-and (dec cnt) 0x01f)) (do (set! cnt (dec cnt)) tcoll) + :else + (let [new-tail (unchecked-editable-array-for tcoll (- cnt 2)) + new-root (let [nr (tv-pop-tail tcoll shift root)] + (if-not (nil? nr) + nr + (VectorNode. (.-edit root) (make-array 32))))] + (if (and (< 5 shift) (nil? (pv-aget new-root 1))) + (let [new-root (tv-ensure-editable (.-edit root) (pv-aget new-root 0))] + (set! root new-root) + (set! shift (- shift 5)) + (set! cnt (dec cnt)) + (set! tail new-tail) + tcoll) + (do (set! root new-root) + (set! cnt (dec cnt)) + (set! tail new-tail) + tcoll)))) + (throw (js/Error. "pop! after persistent!")))) + + ICounted + (-count [coll] + (if ^boolean (.-edit root) + cnt + (throw (js/Error. "count after persistent!")))) + + IIndexed + (-nth [coll n] + (if ^boolean (.-edit root) + (aget (array-for coll n) (bit-and n 0x01f)) + (throw (js/Error. "nth after persistent!")))) + + (-nth [coll n not-found] + (if (and (<= 0 n) (< n cnt)) + (-nth coll n) + not-found)) + + ILookup + (-lookup [coll k] (-lookup coll k nil)) + + (-lookup [coll k not-found] + (cond + (not ^boolean (.-edit root)) (throw (js/Error. "lookup after persistent!")) + (number? k) (-nth coll k not-found) + :else not-found)) + + IFn + (-invoke [coll k] + (-lookup coll k)) + + (-invoke [coll k not-found] + (-lookup coll k not-found))) + +;;; PersistentQueue ;;; + +(deftype PersistentQueueIter [^:mutable fseq riter] + Object + (hasNext [_] + (or (and (some? fseq) (seq fseq)) (and (some? riter) (.hasNext riter)))) + (next [_] + (cond + (some? fseq) + (let [ret (first fseq)] + (set! fseq (next fseq)) + ret) + (and (some? riter) ^boolean (.hasNext riter)) + (.next riter) + :else (throw (js/Error. "No such element")))) + (remove [_] (js/Error. "Unsupported operation"))) + +(deftype PersistentQueueSeq [meta front rear ^:mutable __hash] + Object + (toString [coll] + (pr-str* coll)) + (equiv [this other] + (-equiv this other)) + (indexOf [coll x] + (-indexOf coll x 0)) + (indexOf [coll x start] + (-indexOf coll x start)) + (lastIndexOf [coll x] + (-lastIndexOf coll x (count coll))) + (lastIndexOf [coll x start] + (-lastIndexOf coll x start)) + + IWithMeta + (-with-meta [coll new-meta] + (if (identical? new-meta meta) + coll + (PersistentQueueSeq. new-meta front rear __hash))) + + IMeta + (-meta [coll] meta) + + ISeq + (-first [coll] (first front)) + (-rest [coll] + (if-let [f1 (next front)] + (PersistentQueueSeq. meta f1 rear nil) + (if (nil? rear) + (-empty coll) + (PersistentQueueSeq. meta rear nil nil)))) + + INext + (-next [coll] + (if-let [f1 (next front)] + (PersistentQueueSeq. meta f1 rear nil) + (when (some? rear) + (PersistentQueueSeq. meta rear nil nil)))) + + ICollection + (-conj [coll o] (cons o coll)) + + IEmptyableCollection + (-empty [coll] (-with-meta (.-EMPTY List) meta)) + + ISequential + IEquiv + (-equiv [coll other] (equiv-sequential coll other)) + + IHash + (-hash [coll] (caching-hash coll hash-ordered-coll __hash)) + + ISeqable + (-seq [coll] coll)) + +(es6-iterable PersistentQueueSeq) + +(deftype PersistentQueue [meta count front rear ^:mutable __hash] + Object + (toString [coll] + (pr-str* coll)) + (equiv [this other] + (-equiv this other)) + (indexOf [coll x] + (-indexOf coll x 0)) + (indexOf [coll x start] + (-indexOf coll x start)) + (lastIndexOf [coll x] + (-lastIndexOf coll x (count coll))) + (lastIndexOf [coll x start] + (-lastIndexOf coll x start)) + + ICloneable + (-clone [coll] (PersistentQueue. meta count front rear __hash)) + + IIterable + (-iterator [coll] + (PersistentQueueIter. front (-iterator rear))) + + IWithMeta + (-with-meta [coll new-meta] + (if (identical? new-meta meta) + coll + (PersistentQueue. new-meta count front rear __hash))) + + IMeta + (-meta [coll] meta) + + ISeq + (-first [coll] (first front)) + (-rest [coll] (rest (seq coll))) + + IStack + (-peek [coll] (first front)) + (-pop [coll] + (if front + (if-let [f1 (next front)] + (PersistentQueue. meta (dec count) f1 rear nil) + (PersistentQueue. meta (dec count) (seq rear) [] nil)) + coll)) + + ICollection + (-conj [coll o] + (if front + (PersistentQueue. meta (inc count) front (conj (or rear []) o) nil) + (PersistentQueue. meta (inc count) (conj front o) [] nil))) + + IEmptyableCollection + (-empty [coll] (-with-meta (.-EMPTY PersistentQueue) meta)) + + ISequential + IEquiv + (-equiv [coll other] (equiv-sequential coll other)) + + IHash + (-hash [coll] (caching-hash coll hash-ordered-coll __hash)) + + ISeqable + (-seq [coll] + (let [rear (seq rear)] + (if (or front rear) + (PersistentQueueSeq. nil front (seq rear) nil)))) + + ICounted + (-count [coll] count)) + +(set! (.-EMPTY PersistentQueue) (PersistentQueue. nil 0 nil [] empty-ordered-hash)) + +(es6-iterable PersistentQueue) + +(deftype NeverEquiv [] + Object + (equiv [this other] + (-equiv this other)) + IEquiv + (-equiv [o other] false)) + +(def ^:private never-equiv (NeverEquiv.)) + +(defn equiv-map + "Test map equivalence. Returns true if x equals y, otherwise returns false." + [x y] + (boolean + (when (and (map? y) (not (record? y))) + ; assume all maps are counted + (when (== (count x) (count y)) + (if (satisfies? IKVReduce x) + (reduce-kv + (fn [_ k v] + (if (= (get y k never-equiv) v) + true + (reduced false))) + true x) + (every? + (fn [xkv] + (= (get y (first xkv) never-equiv) (second xkv))) + x)))))) + + +(defn- scan-array [incr k array] + (let [len (alength array)] + (loop [i 0] + (when (< i len) + (if (identical? k (aget array i)) + i + (recur (+ i incr))))))) + +; The keys field is an array of all keys of this map, in no particular +; order. Any string, keyword, or symbol key is used as a property name +; to store the value in strobj. If a key is assoc'ed when that same +; key already exists in strobj, the old value is overwritten. If a +; non-string key is assoc'ed, return a HashMap object instead. + +(defn- obj-map-compare-keys [a b] + (let [a (hash a) + b (hash b)] + (cond + (< a b) -1 + (> a b) 1 + :else 0))) + +(defn- obj-map->hash-map [m k v] + (let [ks (.-keys m) + len (alength ks) + so (.-strobj m) + mm (meta m)] + (loop [i 0 + out (transient (.-EMPTY PersistentHashMap))] + (if (< i len) + (let [k (aget ks i)] + (recur (inc i) (assoc! out k (gobject/get so k)))) + (-with-meta (persistent! (assoc! out k v)) mm))))) + +;;; ObjMap - DEPRECATED + +(defn- obj-clone [obj ks] + (let [new-obj (js-obj) + l (alength ks)] + (loop [i 0] + (when (< i l) + (let [k (aget ks i)] + (gobject/set new-obj k (gobject/get obj k)) + (recur (inc i))))) + new-obj)) + +(deftype ObjMap [meta keys strobj update-count ^:mutable __hash] + Object + (toString [coll] + (pr-str* coll)) + (equiv [this other] + (-equiv this other)) + + IWithMeta + (-with-meta [coll new-meta] + (if (identical? new-meta meta) + coll + (ObjMap. new-meta keys strobj update-count __hash))) + + IMeta + (-meta [coll] meta) + + ICollection + (-conj [coll entry] + (if (vector? entry) + (-assoc coll (-nth entry 0) (-nth entry 1)) + (reduce -conj + coll + entry))) + + IEmptyableCollection + (-empty [coll] (-with-meta (.-EMPTY ObjMap) meta)) + + IEquiv + (-equiv [coll other] (equiv-map coll other)) + + IHash + (-hash [coll] (caching-hash coll hash-unordered-coll __hash)) + + ISeqable + (-seq [coll] + (when (pos? (alength keys)) + (map #(vector % (unchecked-get strobj %)) + (.sort keys obj-map-compare-keys)))) + + ICounted + (-count [coll] (alength keys)) + + ILookup + (-lookup [coll k] (-lookup coll k nil)) + (-lookup [coll k not-found] + (if (and ^boolean (goog/isString k) + (not (nil? (scan-array 1 k keys)))) + (unchecked-get strobj k) + not-found)) + + IAssociative + (-assoc [coll k v] + (if ^boolean (goog/isString k) + (if (or (> update-count (.-HASHMAP_THRESHOLD ObjMap)) + (>= (alength keys) (.-HASHMAP_THRESHOLD ObjMap))) + (obj-map->hash-map coll k v) + (if-not (nil? (scan-array 1 k keys)) + (let [new-strobj (obj-clone strobj keys)] + (gobject/set new-strobj k v) + (ObjMap. meta keys new-strobj (inc update-count) nil)) ; overwrite + (let [new-strobj (obj-clone strobj keys) ; append + new-keys (aclone keys)] + (gobject/set new-strobj k v) + (.push new-keys k) + (ObjMap. meta new-keys new-strobj (inc update-count) nil)))) + ;; non-string key. game over. + (obj-map->hash-map coll k v))) + (-contains-key? [coll k] + (if (and ^boolean (goog/isString k) + (not (nil? (scan-array 1 k keys)))) + true + false)) + + IFind + (-find [coll k] + (when (and ^boolean (goog/isString k) + (not (nil? (scan-array 1 k keys)))) + (MapEntry. k (unchecked-get strobj k) nil))) + + IKVReduce + (-kv-reduce [coll f init] + (let [len (alength keys)] + (loop [keys (.sort keys obj-map-compare-keys) + init init] + (if (seq keys) + (let [k (first keys) + init (f init k (unchecked-get strobj k))] + (if (reduced? init) + @init + (recur (rest keys) init))) + init)))) + + IMap + (-dissoc [coll k] + (if (and ^boolean (goog/isString k) + (not (nil? (scan-array 1 k keys)))) + (let [new-keys (aclone keys) + new-strobj (obj-clone strobj keys)] + (.splice new-keys (scan-array 1 k new-keys) 1) + (js-delete new-strobj k) + (ObjMap. meta new-keys new-strobj (inc update-count) nil)) + coll)) ; key not found, return coll unchanged + + IFn + (-invoke [coll k] + (-lookup coll k)) + (-invoke [coll k not-found] + (-lookup coll k not-found)) + + IEditableCollection + (-as-transient [coll] + (transient (into (hash-map) coll)))) + +(set! (.-EMPTY ObjMap) (ObjMap. nil (array) (js-obj) 0 empty-unordered-hash)) + +(set! (.-HASHMAP_THRESHOLD ObjMap) 8) + +(set! (.-fromObject ObjMap) (fn [ks obj] (ObjMap. nil ks obj 0 nil))) + +;; Record Iterator +(deftype RecordIter [^:mutable i record base-count fields ext-map-iter] + Object + (hasNext [_] + (or (< i base-count) (.hasNext ext-map-iter))) + (next [_] + (if (< i base-count) + (let [k (nth fields i)] + (set! i (inc i)) + (MapEntry. k (-lookup record k) nil)) + (.next ext-map-iter))) + (remove [_] (js/Error. "Unsupported operation"))) + +;; EXPERIMENTAL: subject to change +(deftype ES6EntriesIterator [^:mutable s] + Object + (next [_] + (if-not (nil? s) + (let [[k v] (first s)] + (set! s (next s)) + #js {:value #js [k v] :done false}) + #js {:value nil :done true}))) + +(defn es6-entries-iterator [coll] + (ES6EntriesIterator. (seq coll))) + +;; EXPERIMENTAL: subject to change +(deftype ES6SetEntriesIterator [^:mutable s] + Object + (next [_] + (if-not (nil? s) + (let [x (first s)] + (set! s (next s)) + #js {:value #js [x x] :done false}) + #js {:value nil :done true}))) + +(defn es6-set-entries-iterator [coll] + (ES6SetEntriesIterator. (seq coll))) + +;;; PersistentArrayMap + +(defn- array-index-of-nil? [arr] + (let [len (alength arr)] + (loop [i 0] + (cond + (<= len i) -1 + (nil? (aget arr i)) i + :else (recur (+ i 2)))))) + +(defn- array-index-of-keyword? [arr k] + (let [len (alength arr) + kstr (.-fqn k)] + (loop [i 0] + (cond + (<= len i) -1 + (and (keyword? (aget arr i)) + (identical? kstr (.-fqn (aget arr i)))) i + :else (recur (+ i 2)))))) + +(defn- array-index-of-symbol? [arr k] + (let [len (alength arr) + kstr (.-str k)] + (loop [i 0] + (cond + (<= len i) -1 + (and (symbol? (aget arr i)) + (identical? kstr (.-str (aget arr i)))) i + :else (recur (+ i 2)))))) + +(defn- array-index-of-identical? [arr k] + (let [len (alength arr)] + (loop [i 0] + (cond + (<= len i) -1 + (identical? k (aget arr i)) i + :else (recur (+ i 2)))))) + +(defn- array-index-of-equiv? [arr k] + (let [len (alength arr)] + (loop [i 0] + (cond + (<= len i) -1 + (= k (aget arr i)) i + :else (recur (+ i 2)))))) + +(defn array-index-of [arr k] + (cond + (keyword? k) (array-index-of-keyword? arr k) + + (or ^boolean (goog/isString k) (number? k)) + (array-index-of-identical? arr k) + + (symbol? k) (array-index-of-symbol? arr k) + + (nil? k) + (array-index-of-nil? arr) + + :else (array-index-of-equiv? arr k))) + +(defn- array-map-index-of [m k] + (array-index-of (.-arr m) k)) + +(defn- array-extend-kv [arr k v] + (let [l (alength arr) + narr (make-array (+ l 2))] + (loop [i 0] + (when (< i l) + (aset narr i (aget arr i)) + (recur (inc i)))) + (aset narr l k) + (aset narr (inc l) v) + narr)) + +(defn- array-map-extend-kv [m k v] + (array-extend-kv (.-arr m) k v)) + +(declare TransientArrayMap) + +(deftype MapEntry [key val ^:mutable __hash] + Object + (indexOf [coll x] + (-indexOf coll x 0)) + (indexOf [coll x start] + (-indexOf coll x start)) + (lastIndexOf [coll x] + (-lastIndexOf coll x (count coll))) + (lastIndexOf [coll x start] + (-lastIndexOf coll x start)) + + IMapEntry + (-key [node] key) + (-val [node] val) + + IHash + (-hash [coll] (caching-hash coll hash-ordered-coll __hash)) + + IEquiv + (-equiv [coll other] (equiv-sequential coll other)) + + IMeta + (-meta [node] nil) + + IWithMeta + (-with-meta [node meta] + (with-meta [key val] meta)) + + IStack + (-peek [node] val) + + (-pop [node] [key]) + + ICollection + (-conj [node o] [key val o]) + + IEmptyableCollection + (-empty [node] nil) + + ISequential + ISeqable + (-seq [node] (IndexedSeq. #js [key val] 0 nil)) + + IReversible + (-rseq [node] (IndexedSeq. #js [val key] 0 nil)) + + ICounted + (-count [node] 2) + + IIndexed + (-nth [node n] + (cond (== n 0) key + (== n 1) val + :else (throw (js/Error. "Index out of bounds")))) + + (-nth [node n not-found] + (cond (== n 0) key + (== n 1) val + :else not-found)) + + ILookup + (-lookup [node k] (-nth node k nil)) + (-lookup [node k not-found] (-nth node k not-found)) + + IAssociative + (-assoc [node k v] + (assoc [key val] k v)) + (-contains-key? [node k] + (or (== k 0) (== k 1))) + + IFind + (-find [node k] + (case k + 0 (MapEntry. 0 key nil) + 1 (MapEntry. 1 val nil) + nil)) + + IVector + (-assoc-n [node n v] + (-assoc-n [key val] n v)) + + IReduce + (-reduce [node f] + (ci-reduce node f)) + + (-reduce [node f start] + (ci-reduce node f start)) + + IFn + (-invoke [node k] + (-nth node k)) + + (-invoke [node k not-found] + (-nth node k not-found))) + +(defn map-entry? + "Returns true if x satisfies IMapEntry" + [x] + (implements? IMapEntry x)) + +(deftype PersistentArrayMapSeq [arr i _meta] + Object + (toString [coll] + (pr-str* coll)) + (equiv [this other] + (-equiv this other)) + (indexOf [coll x] + (-indexOf coll x 0)) + (indexOf [coll x start] + (-indexOf coll x start)) + (lastIndexOf [coll x] + (-lastIndexOf coll x (count coll))) + (lastIndexOf [coll x start] + (-lastIndexOf coll x start)) + + IMeta + (-meta [coll] _meta) + + IWithMeta + (-with-meta [coll new-meta] + (if (identical? new-meta _meta) + coll + (PersistentArrayMapSeq. arr i new-meta))) + + ICounted + (-count [coll] + (/ (- (alength arr) i) 2)) + + ISeqable + (-seq [coll] coll) + + ISequential + IEquiv + (-equiv [coll other] (equiv-sequential coll other)) + + ICollection + (-conj [coll o] + (cons o coll)) + + IEmptyableCollection + (-empty [coll] (.-EMPTY List)) + + IHash + (-hash [coll] (hash-ordered-coll coll)) + + ISeq + (-first [coll] + (MapEntry. (aget arr i) (aget arr (inc i)) nil)) + + (-rest [coll] + (if (< i (- (alength arr) 2)) + (PersistentArrayMapSeq. arr (+ i 2) nil) + ())) + + INext + (-next [coll] + (when (< i (- (alength arr) 2)) + (PersistentArrayMapSeq. arr (+ i 2) nil))) + + IReduce + (-reduce [coll f] (seq-reduce f coll)) + (-reduce [coll f start] (seq-reduce f start coll))) + +(es6-iterable PersistentArrayMapSeq) + +(defn persistent-array-map-seq [arr i _meta] + (when (<= i (- (alength arr) 2)) + (PersistentArrayMapSeq. arr i _meta))) + +(declare keys vals) + +(deftype PersistentArrayMapIterator [arr ^:mutable i cnt] + Object + (hasNext [_] + (< i cnt)) + (next [_] + (let [ret (MapEntry. (aget arr i) (aget arr (inc i)) nil)] + (set! i (+ i 2)) + ret))) + +(deftype PersistentArrayMap [meta cnt arr ^:mutable __hash] + Object + (toString [coll] + (pr-str* coll)) + (equiv [this other] + (-equiv this other)) + + ;; EXPERIMENTAL: subject to change + (keys [coll] + (es6-iterator (keys coll))) + (entries [coll] + (es6-entries-iterator (seq coll))) + (values [coll] + (es6-iterator (vals coll))) + (has [coll k] + (contains? coll k)) + (get [coll k not-found] + (-lookup coll k not-found)) + (forEach [coll f] + (doseq [[k v] coll] + (f v k))) + + ICloneable + (-clone [_] (PersistentArrayMap. meta cnt arr __hash)) + + IWithMeta + (-with-meta [coll new-meta] + (if (identical? new-meta meta) + coll + (PersistentArrayMap. new-meta cnt arr __hash))) + + IMeta + (-meta [coll] meta) + + ICollection + (-conj [coll entry] + (if (vector? entry) + (-assoc coll (-nth entry 0) (-nth entry 1)) + (loop [ret coll es (seq entry)] + (if (nil? es) + ret + (let [e (first es)] + (if (vector? e) + (recur (-assoc ret (-nth e 0) (-nth e 1)) + (next es)) + (throw (js/Error. "conj on a map takes map entries or seqables of map entries")))))))) + + IEmptyableCollection + (-empty [coll] (-with-meta (.-EMPTY PersistentArrayMap) meta)) + + IEquiv + (-equiv [coll other] + (if (and (map? other) (not (record? other))) + (let [alen (alength arr) + ^not-native other other] + (if (== cnt (-count other)) + (loop [i 0] + (if (< i alen) + (let [v (-lookup other (aget arr i) lookup-sentinel)] + (if-not (identical? v lookup-sentinel) + (if (= (aget arr (inc i)) v) + (recur (+ i 2)) + false) + false)) + true)) + false)) + false)) + + IHash + (-hash [coll] (caching-hash coll hash-unordered-coll __hash)) + + IIterable + (-iterator [this] + (PersistentArrayMapIterator. arr 0 (* cnt 2))) + + ISeqable + (-seq [coll] + (persistent-array-map-seq arr 0 nil)) + + ICounted + (-count [coll] cnt) + + ILookup + (-lookup [coll k] + (-lookup coll k nil)) + + (-lookup [coll k not-found] + (let [idx (array-map-index-of coll k)] + (if (== idx -1) + not-found + (aget arr (inc idx))))) + + IAssociative + (-assoc [coll k v] + (let [idx (array-map-index-of coll k)] + (cond + (== idx -1) + (if (< cnt (.-HASHMAP-THRESHOLD PersistentArrayMap)) + (let [arr (array-map-extend-kv coll k v)] + (PersistentArrayMap. meta (inc cnt) arr nil)) + (-> (into (.-EMPTY PersistentHashMap) coll) + (-assoc k v) + (-with-meta meta))) + + (identical? v (aget arr (inc idx))) + coll + + :else + (let [arr (doto (aclone arr) + (aset (inc idx) v))] + (PersistentArrayMap. meta cnt arr nil))))) + + (-contains-key? [coll k] + (not (== (array-map-index-of coll k) -1))) + + IFind + (-find [coll k] + (let [idx (array-map-index-of coll k)] + (when-not (== idx -1) + (MapEntry. (aget arr idx) (aget arr (inc idx)) nil)))) + + IMap + (-dissoc [coll k] + (let [idx (array-map-index-of coll k)] + (if (>= idx 0) + (let [len (alength arr) + new-len (- len 2)] + (if (zero? new-len) + (-empty coll) + (let [new-arr (make-array new-len)] + (loop [s 0 d 0] + (cond + (>= s len) (PersistentArrayMap. meta (dec cnt) new-arr nil) + (= k (aget arr s)) (recur (+ s 2) d) + :else (do (aset new-arr d (aget arr s)) + (aset new-arr (inc d) (aget arr (inc s))) + (recur (+ s 2) (+ d 2)))))))) + coll))) + + IKVReduce + (-kv-reduce [coll f init] + (let [len (alength arr)] + (loop [i 0 init init] + (if (< i len) + (let [init (f init (aget arr i) (aget arr (inc i)))] + (if (reduced? init) + @init + (recur (+ i 2) init))) + init)))) + + IReduce + (-reduce [coll f] + (iter-reduce coll f)) + (-reduce [coll f start] + (iter-reduce coll f start)) + + IFn + (-invoke [coll k] + (-lookup coll k)) + + (-invoke [coll k not-found] + (-lookup coll k not-found)) + + IEditableCollection + (-as-transient [coll] + (TransientArrayMap. (js-obj) (alength arr) (aclone arr)))) + +(set! (.-EMPTY PersistentArrayMap) (PersistentArrayMap. nil 0 (array) empty-unordered-hash)) + +(set! (.-HASHMAP-THRESHOLD PersistentArrayMap) 8) + +(set! (.-fromArray PersistentArrayMap) + (fn [arr ^boolean no-clone ^boolean no-check] + (as-> (if no-clone arr (aclone arr)) arr + (if no-check + arr + (let [ret (array)] + (loop [i 0] + (when (< i (alength arr)) + (let [k (aget arr i) + v (aget arr (inc i)) + idx (array-index-of ret k)] + (when (== idx -1) + (.push ret k) + (.push ret v))) + (recur (+ i 2)))) + ret)) + (let [cnt (/ (alength arr) 2)] + (PersistentArrayMap. nil cnt arr nil))))) + +(set! (.-createWithCheck PersistentArrayMap) + (fn [arr] + (let [ret (array)] + (loop [i 0] + (when (< i (alength arr)) + (let [k (aget arr i) + v (aget arr (inc i)) + idx (array-index-of ret k)] + (if (== idx -1) + (doto ret (.push k) (.push v)) + (throw (js/Error. (str "Duplicate key: " k))))) + (recur (+ i 2)))) + (let [cnt (/ (alength arr) 2)] + (PersistentArrayMap. nil cnt arr nil))))) + +(set! (.-createAsIfByAssoc PersistentArrayMap) + (fn [arr] + (let [ret (array)] + (loop [i 0] + (when (< i (alength arr)) + (let [k (aget arr i) + v (aget arr (inc i)) + idx (array-index-of ret k)] + (if (== idx -1) + (doto ret (.push k) (.push v)) + (aset ret (inc idx) v))) + (recur (+ i 2)))) + (PersistentArrayMap. nil (/ (alength ret) 2) ret nil)))) + +(es6-iterable PersistentArrayMap) + +(declare array->transient-hash-map) + +(deftype TransientArrayMap [^:mutable ^boolean editable? + ^:mutable len + arr] + ICounted + (-count [tcoll] + (if editable? + (quot len 2) + (throw (js/Error. "count after persistent!")))) + + ILookup + (-lookup [tcoll k] + (-lookup tcoll k nil)) + + (-lookup [tcoll k not-found] + (if editable? + (let [idx (array-map-index-of tcoll k)] + (if (== idx -1) + not-found + (aget arr (inc idx)))) + (throw (js/Error. "lookup after persistent!")))) + + ITransientCollection + (-conj! [tcoll o] + (if editable? + (cond + (map-entry? o) + (-assoc! tcoll (key o) (val o)) + + (vector? o) + (-assoc! tcoll (o 0) (o 1)) + + :else + (loop [es (seq o) tcoll tcoll] + (if-let [e (first es)] + (recur (next es) + (-assoc! tcoll (key e) (val e))) + tcoll))) + (throw (js/Error. "conj! after persistent!")))) + + (-persistent! [tcoll] + (if editable? + (do (set! editable? false) + (PersistentArrayMap. nil (quot len 2) arr nil)) + (throw (js/Error. "persistent! called twice")))) + + ITransientAssociative + (-assoc! [tcoll key val] + (if editable? + (let [idx (array-map-index-of tcoll key)] + (if (== idx -1) + (if (<= (+ len 2) (* 2 (.-HASHMAP-THRESHOLD PersistentArrayMap))) + (do (set! len (+ len 2)) + (.push arr key) + (.push arr val) + tcoll) + (assoc! (array->transient-hash-map len arr) key val)) + (if (identical? val (aget arr (inc idx))) + tcoll + (do (aset arr (inc idx) val) + tcoll)))) + (throw (js/Error. "assoc! after persistent!")))) + + ITransientMap + (-dissoc! [tcoll key] + (if editable? + (let [idx (array-map-index-of tcoll key)] + (when (>= idx 0) + (aset arr idx (aget arr (- len 2))) + (aset arr (inc idx) (aget arr (dec len))) + (doto arr .pop .pop) + (set! len (- len 2))) + tcoll) + (throw (js/Error. "dissoc! after persistent!")))) + + IFn + (-invoke [tcoll key] + (-lookup tcoll key nil)) + (-invoke [tcoll key not-found] + (-lookup tcoll key not-found))) + +(declare TransientHashMap) + +(defn- array->transient-hash-map [len arr] + (loop [out (transient (.-EMPTY PersistentHashMap)) + i 0] + (if (< i len) + (recur (assoc! out (aget arr i) (aget arr (inc i))) (+ i 2)) + out))) + +;;; PersistentHashMap + +(deftype Box [^:mutable val]) + +(declare create-inode-seq create-array-node-seq reset! create-node atom deref) + +(defn key-test [key other] + (cond + (identical? key other) true + (keyword-identical? key other) true + :else (= key other))) + +(defn- mask [hash shift] + (bit-and (bit-shift-right-zero-fill hash shift) 0x01f)) + +(defn- clone-and-set + ([arr i a] + (doto (aclone arr) + (aset i a))) + ([arr i a j b] + (doto (aclone arr) + (aset i a) + (aset j b)))) + +(defn- remove-pair [arr i] + (let [new-arr (make-array (- (alength arr) 2))] + (array-copy arr 0 new-arr 0 (* 2 i)) + (array-copy arr (* 2 (inc i)) new-arr (* 2 i) (- (alength new-arr) (* 2 i))) + new-arr)) + +(defn- bitmap-indexed-node-index [bitmap bit] + (bit-count (bit-and bitmap (dec bit)))) + +(defn- bitpos [hash shift] + (bit-shift-left 1 (mask hash shift))) + +(defn- edit-and-set + ([inode edit i a] + (let [editable (.ensure-editable inode edit)] + (aset (.-arr editable) i a) + editable)) + ([inode edit i a j b] + (let [editable (.ensure-editable inode edit)] + (aset (.-arr editable) i a) + (aset (.-arr editable) j b) + editable))) + +(defn- inode-kv-reduce [arr f init] + (let [len (alength arr)] + (loop [i 0 init init] + (if (< i len) + (let [init (let [k (aget arr i)] + (if-not (nil? k) + (f init k (aget arr (inc i))) + (let [node (aget arr (inc i))] + (if-not (nil? node) + (.kv-reduce node f init) + init))))] + (if (reduced? init) + init + (recur (+ i 2) init))) + init)))) + +(declare ArrayNode) + + (deftype NodeIterator [arr ^:mutable i ^:mutable next-entry ^:mutable next-iter] + Object + (advance [this] + (let [len (alength arr)] + (loop [] + (if (< i len) + (let [key (aget arr i) + node-or-val (aget arr (inc i)) + ^boolean found + (cond (some? key) + (set! next-entry (MapEntry. key node-or-val nil)) + (some? node-or-val) + (let [new-iter (-iterator node-or-val)] + (if ^boolean (.hasNext new-iter) + (set! next-iter new-iter) + false)) + :else false)] + (set! i (+ i 2)) + (if found true (recur))) + false)))) + (hasNext [this] + (or (some? next-entry) (some? next-iter) (.advance this))) + (next [this] + (cond + (some? next-entry) + (let [ret next-entry] + (set! next-entry nil) + ret) + (some? next-iter) + (let [ret (.next next-iter)] + (when-not ^boolean (.hasNext next-iter) + (set! next-iter nil)) + ret) + ^boolean (.advance this) + (.next this) + :else (throw (js/Error. "No such element")))) + (remove [_] (js/Error. "Unsupported operation"))) + +(deftype BitmapIndexedNode [edit ^:mutable bitmap ^:mutable arr] + Object + (inode-assoc [inode shift hash key val added-leaf?] + (let [bit (bitpos hash shift) + idx (bitmap-indexed-node-index bitmap bit)] + (if (zero? (bit-and bitmap bit)) + (let [n (bit-count bitmap)] + (if (>= n 16) + (let [nodes (make-array 32) + jdx (mask hash shift)] + (aset nodes jdx (.inode-assoc (.-EMPTY BitmapIndexedNode) (+ shift 5) hash key val added-leaf?)) + (loop [i 0 j 0] + (if (< i 32) + (if (zero? (bit-and (bit-shift-right-zero-fill bitmap i) 1)) + (recur (inc i) j) + (do (aset nodes i + (if-not (nil? (aget arr j)) + (.inode-assoc (.-EMPTY BitmapIndexedNode) + (+ shift 5) (cljs.core/hash (aget arr j)) (aget arr j) (aget arr (inc j)) added-leaf?) + (aget arr (inc j)))) + (recur (inc i) (+ j 2)))))) + (ArrayNode. nil (inc n) nodes)) + (let [new-arr (make-array (* 2 (inc n)))] + (array-copy arr 0 new-arr 0 (* 2 idx)) + (aset new-arr (* 2 idx) key) + (aset new-arr (inc (* 2 idx)) val) + (array-copy arr (* 2 idx) new-arr (* 2 (inc idx)) (* 2 (- n idx))) + (set! (.-val added-leaf?) true) + (BitmapIndexedNode. nil (bit-or bitmap bit) new-arr)))) + (let [key-or-nil (aget arr (* 2 idx)) + val-or-node (aget arr (inc (* 2 idx)))] + (cond (nil? key-or-nil) + (let [n (.inode-assoc val-or-node (+ shift 5) hash key val added-leaf?)] + (if (identical? n val-or-node) + inode + (BitmapIndexedNode. nil bitmap (clone-and-set arr (inc (* 2 idx)) n)))) + + (key-test key key-or-nil) + (if (identical? val val-or-node) + inode + (BitmapIndexedNode. nil bitmap (clone-and-set arr (inc (* 2 idx)) val))) + + :else + (do (set! (.-val added-leaf?) true) + (BitmapIndexedNode. nil bitmap + (clone-and-set arr (* 2 idx) nil (inc (* 2 idx)) + (create-node (+ shift 5) key-or-nil val-or-node hash key val))))))))) + + (inode-without [inode shift hash key] + (let [bit (bitpos hash shift)] + (if (zero? (bit-and bitmap bit)) + inode + (let [idx (bitmap-indexed-node-index bitmap bit) + key-or-nil (aget arr (* 2 idx)) + val-or-node (aget arr (inc (* 2 idx)))] + (cond (nil? key-or-nil) + (let [n (.inode-without val-or-node (+ shift 5) hash key)] + (cond (identical? n val-or-node) inode + (not (nil? n)) (BitmapIndexedNode. nil bitmap (clone-and-set arr (inc (* 2 idx)) n)) + (== bitmap bit) nil + :else (BitmapIndexedNode. nil (bit-xor bitmap bit) (remove-pair arr idx)))) + (key-test key key-or-nil) + (BitmapIndexedNode. nil (bit-xor bitmap bit) (remove-pair arr idx)) + :else inode))))) + + (inode-lookup [inode shift hash key not-found] + (let [bit (bitpos hash shift)] + (if (zero? (bit-and bitmap bit)) + not-found + (let [idx (bitmap-indexed-node-index bitmap bit) + key-or-nil (aget arr (* 2 idx)) + val-or-node (aget arr (inc (* 2 idx)))] + (cond (nil? key-or-nil) (.inode-lookup val-or-node (+ shift 5) hash key not-found) + (key-test key key-or-nil) val-or-node + :else not-found))))) + + (inode-find [inode shift hash key not-found] + (let [bit (bitpos hash shift)] + (if (zero? (bit-and bitmap bit)) + not-found + (let [idx (bitmap-indexed-node-index bitmap bit) + key-or-nil (aget arr (* 2 idx)) + val-or-node (aget arr (inc (* 2 idx)))] + (cond (nil? key-or-nil) (.inode-find val-or-node (+ shift 5) hash key not-found) + (key-test key key-or-nil) (MapEntry. key-or-nil val-or-node nil) + :else not-found))))) + + (inode-seq [inode] + (create-inode-seq arr)) + + (ensure-editable [inode e] + (if (identical? e edit) + inode + (let [n (bit-count bitmap) + new-arr (make-array (if (neg? n) 4 (* 2 (inc n))))] + (array-copy arr 0 new-arr 0 (* 2 n)) + (BitmapIndexedNode. e bitmap new-arr)))) + + (edit-and-remove-pair [inode e bit i] + (if (== bitmap bit) + nil + (let [editable (.ensure-editable inode e) + earr (.-arr editable) + len (alength earr)] + (set! (.-bitmap editable) (bit-xor bit (.-bitmap editable))) + (array-copy earr (* 2 (inc i)) + earr (* 2 i) + (- len (* 2 (inc i)))) + (aset earr (- len 2) nil) + (aset earr (dec len) nil) + editable))) + + (inode-assoc! [inode edit shift hash key val added-leaf?] + (let [bit (bitpos hash shift) + idx (bitmap-indexed-node-index bitmap bit)] + (if (zero? (bit-and bitmap bit)) + (let [n (bit-count bitmap)] + (cond + (< (* 2 n) (alength arr)) + (let [editable (.ensure-editable inode edit) + earr (.-arr editable)] + (set! (.-val added-leaf?) true) + (array-copy-downward earr (* 2 idx) + earr (* 2 (inc idx)) + (* 2 (- n idx))) + (aset earr (* 2 idx) key) + (aset earr (inc (* 2 idx)) val) + (set! (.-bitmap editable) (bit-or (.-bitmap editable) bit)) + editable) + + (>= n 16) + (let [nodes (make-array 32) + jdx (mask hash shift)] + (aset nodes jdx (.inode-assoc! (.-EMPTY BitmapIndexedNode) edit (+ shift 5) hash key val added-leaf?)) + (loop [i 0 j 0] + (if (< i 32) + (if (zero? (bit-and (bit-shift-right-zero-fill bitmap i) 1)) + (recur (inc i) j) + (do (aset nodes i + (if-not (nil? (aget arr j)) + (.inode-assoc! (.-EMPTY BitmapIndexedNode) + edit (+ shift 5) (cljs.core/hash (aget arr j)) (aget arr j) (aget arr (inc j)) added-leaf?) + (aget arr (inc j)))) + (recur (inc i) (+ j 2)))))) + (ArrayNode. edit (inc n) nodes)) + + :else + (let [new-arr (make-array (* 2 (+ n 4)))] + (array-copy arr 0 new-arr 0 (* 2 idx)) + (aset new-arr (* 2 idx) key) + (aset new-arr (inc (* 2 idx)) val) + (array-copy arr (* 2 idx) new-arr (* 2 (inc idx)) (* 2 (- n idx))) + (set! (.-val added-leaf?) true) + (let [editable (.ensure-editable inode edit)] + (set! (.-arr editable) new-arr) + (set! (.-bitmap editable) (bit-or (.-bitmap editable) bit)) + editable)))) + (let [key-or-nil (aget arr (* 2 idx)) + val-or-node (aget arr (inc (* 2 idx)))] + (cond (nil? key-or-nil) + (let [n (.inode-assoc! val-or-node edit (+ shift 5) hash key val added-leaf?)] + (if (identical? n val-or-node) + inode + (edit-and-set inode edit (inc (* 2 idx)) n))) + + (key-test key key-or-nil) + (if (identical? val val-or-node) + inode + (edit-and-set inode edit (inc (* 2 idx)) val)) + + :else + (do (set! (.-val added-leaf?) true) + (edit-and-set inode edit (* 2 idx) nil (inc (* 2 idx)) + (create-node edit (+ shift 5) key-or-nil val-or-node hash key val)))))))) + + (inode-without! [inode edit shift hash key removed-leaf?] + (let [bit (bitpos hash shift)] + (if (zero? (bit-and bitmap bit)) + inode + (let [idx (bitmap-indexed-node-index bitmap bit) + key-or-nil (aget arr (* 2 idx)) + val-or-node (aget arr (inc (* 2 idx)))] + (cond (nil? key-or-nil) + (let [n (.inode-without! val-or-node edit (+ shift 5) hash key removed-leaf?)] + (cond (identical? n val-or-node) inode + (not (nil? n)) (edit-and-set inode edit (inc (* 2 idx)) n) + (== bitmap bit) nil + :else (.edit-and-remove-pair inode edit bit idx))) + (key-test key key-or-nil) + (do (set! (.-val removed-leaf?) true) + (.edit-and-remove-pair inode edit bit idx)) + :else inode))))) + + (kv-reduce [inode f init] + (inode-kv-reduce arr f init)) + + IIterable + (-iterator [coll] + (NodeIterator. arr 0 nil nil))) + +(set! (.-EMPTY BitmapIndexedNode) (BitmapIndexedNode. nil 0 (make-array 0))) + +(defn- pack-array-node [array-node edit idx] + (let [arr (.-arr array-node) + len (alength arr) + new-arr (make-array (* 2 (dec (.-cnt array-node))))] + (loop [i 0 j 1 bitmap 0] + (if (< i len) + (if (and (not (== i idx)) + (not (nil? (aget arr i)))) + (do (aset new-arr j (aget arr i)) + (recur (inc i) (+ j 2) (bit-or bitmap (bit-shift-left 1 i)))) + (recur (inc i) j bitmap)) + (BitmapIndexedNode. edit bitmap new-arr))))) + +(deftype ArrayNodeIterator [arr ^:mutable i ^:mutable next-iter] + Object + (hasNext [this] + (let [len (alength arr)] + (loop [] + (if-not (and (some? next-iter) ^boolean (.hasNext next-iter)) + (if (< i len) + (let [node (aget arr i)] + (set! i (inc i)) + (when (some? node) + (set! next-iter (-iterator node))) + (recur)) + false) + true)))) + (next [this] + (if ^boolean (.hasNext this) + (.next next-iter) + (throw (js/Error. "No such element")))) + (remove [_] (js/Error. "Unsupported operation"))) + +(deftype ArrayNode [edit ^:mutable cnt ^:mutable arr] + Object + (inode-assoc [inode shift hash key val added-leaf?] + (let [idx (mask hash shift) + node (aget arr idx)] + (if (nil? node) + (ArrayNode. nil (inc cnt) (clone-and-set arr idx (.inode-assoc (.-EMPTY BitmapIndexedNode) (+ shift 5) hash key val added-leaf?))) + (let [n (.inode-assoc node (+ shift 5) hash key val added-leaf?)] + (if (identical? n node) + inode + (ArrayNode. nil cnt (clone-and-set arr idx n))))))) + + (inode-without [inode shift hash key] + (let [idx (mask hash shift) + node (aget arr idx)] + (if-not (nil? node) + (let [n (.inode-without node (+ shift 5) hash key)] + (cond + (identical? n node) + inode + + (nil? n) + (if (<= cnt 8) + (pack-array-node inode nil idx) + (ArrayNode. nil (dec cnt) (clone-and-set arr idx n))) + + :else + (ArrayNode. nil cnt (clone-and-set arr idx n)))) + inode))) + + (inode-lookup [inode shift hash key not-found] + (let [idx (mask hash shift) + node (aget arr idx)] + (if-not (nil? node) + (.inode-lookup node (+ shift 5) hash key not-found) + not-found))) + + (inode-find [inode shift hash key not-found] + (let [idx (mask hash shift) + node (aget arr idx)] + (if-not (nil? node) + (.inode-find node (+ shift 5) hash key not-found) + not-found))) + + (inode-seq [inode] + (create-array-node-seq arr)) + + (ensure-editable [inode e] + (if (identical? e edit) + inode + (ArrayNode. e cnt (aclone arr)))) + + (inode-assoc! [inode edit shift hash key val added-leaf?] + (let [idx (mask hash shift) + node (aget arr idx)] + (if (nil? node) + (let [editable (edit-and-set inode edit idx (.inode-assoc! (.-EMPTY BitmapIndexedNode) edit (+ shift 5) hash key val added-leaf?))] + (set! (.-cnt editable) (inc (.-cnt editable))) + editable) + (let [n (.inode-assoc! node edit (+ shift 5) hash key val added-leaf?)] + (if (identical? n node) + inode + (edit-and-set inode edit idx n)))))) + + (inode-without! [inode edit shift hash key removed-leaf?] + (let [idx (mask hash shift) + node (aget arr idx)] + (if (nil? node) + inode + (let [n (.inode-without! node edit (+ shift 5) hash key removed-leaf?)] + (cond + (identical? n node) + inode + + (nil? n) + (if (<= cnt 8) + (pack-array-node inode edit idx) + (let [editable (edit-and-set inode edit idx n)] + (set! (.-cnt editable) (dec (.-cnt editable))) + editable)) + + :else + (edit-and-set inode edit idx n)))))) + + (kv-reduce [inode f init] + (let [len (alength arr)] ; actually 32 + (loop [i 0 init init] + (if (< i len) + (let [node (aget arr i)] + (if-not (nil? node) + (let [init (.kv-reduce node f init)] + (if (reduced? init) + init + (recur (inc i) init))) + (recur (inc i) init))) + init)))) + + IIterable + (-iterator [coll] + (ArrayNodeIterator. arr 0 nil))) + +(defn- hash-collision-node-find-index [arr cnt key] + (let [lim (* 2 cnt)] + (loop [i 0] + (if (< i lim) + (if (key-test key (aget arr i)) + i + (recur (+ i 2))) + -1)))) + +(deftype HashCollisionNode [edit + ^:mutable collision-hash + ^:mutable cnt + ^:mutable arr] + Object + (inode-assoc [inode shift hash key val added-leaf?] + (if (== hash collision-hash) + (let [idx (hash-collision-node-find-index arr cnt key)] + (if (== idx -1) + (let [len (* 2 cnt) + new-arr (make-array (+ len 2))] + (array-copy arr 0 new-arr 0 len) + (aset new-arr len key) + (aset new-arr (inc len) val) + (set! (.-val added-leaf?) true) + (HashCollisionNode. nil collision-hash (inc cnt) new-arr)) + (if (= (aget arr (inc idx)) val) + inode + (HashCollisionNode. nil collision-hash cnt (clone-and-set arr (inc idx) val))))) + (.inode-assoc (BitmapIndexedNode. nil (bitpos collision-hash shift) (array nil inode)) + shift hash key val added-leaf?))) + + (inode-without [inode shift hash key] + (let [idx (hash-collision-node-find-index arr cnt key)] + (cond (== idx -1) inode + (== cnt 1) nil + :else (HashCollisionNode. nil collision-hash (dec cnt) (remove-pair arr (quot idx 2)))))) + + (inode-lookup [inode shift hash key not-found] + (let [idx (hash-collision-node-find-index arr cnt key)] + (cond (< idx 0) not-found + (key-test key (aget arr idx)) (aget arr (inc idx)) + :else not-found))) + + (inode-find [inode shift hash key not-found] + (let [idx (hash-collision-node-find-index arr cnt key)] + (cond (< idx 0) not-found + (key-test key (aget arr idx)) (MapEntry. (aget arr idx) (aget arr (inc idx)) nil) + :else not-found))) + + (inode-seq [inode] + (create-inode-seq arr)) + + (ensure-editable [inode e] + (if (identical? e edit) + inode + (let [new-arr (make-array (* 2 (inc cnt)))] + (array-copy arr 0 new-arr 0 (* 2 cnt)) + (HashCollisionNode. e collision-hash cnt new-arr)))) + + (ensure-editable-array [inode e count array] + (if (identical? e edit) + (do (set! arr array) + (set! cnt count) + inode) + (HashCollisionNode. edit collision-hash count array))) + + (inode-assoc! [inode edit shift hash key val added-leaf?] + (if (== hash collision-hash) + (let [idx (hash-collision-node-find-index arr cnt key)] + (if (== idx -1) + (if (> (alength arr) (* 2 cnt)) + (let [editable (edit-and-set inode edit (* 2 cnt) key (inc (* 2 cnt)) val)] + (set! (.-val added-leaf?) true) + (set! (.-cnt editable) (inc (.-cnt editable))) + editable) + (let [len (alength arr) + new-arr (make-array (+ len 2))] + (array-copy arr 0 new-arr 0 len) + (aset new-arr len key) + (aset new-arr (inc len) val) + (set! (.-val added-leaf?) true) + (.ensure-editable-array inode edit (inc cnt) new-arr))) + (if (identical? (aget arr (inc idx)) val) + inode + (edit-and-set inode edit (inc idx) val)))) + (.inode-assoc! (BitmapIndexedNode. edit (bitpos collision-hash shift) (array nil inode nil nil)) + edit shift hash key val added-leaf?))) + + (inode-without! [inode edit shift hash key removed-leaf?] + (let [idx (hash-collision-node-find-index arr cnt key)] + (if (== idx -1) + inode + (do (set! (.-val removed-leaf?) true) + (if (== cnt 1) + nil + (let [editable (.ensure-editable inode edit) + earr (.-arr editable)] + (aset earr idx (aget earr (- (* 2 cnt) 2))) + (aset earr (inc idx) (aget earr (dec (* 2 cnt)))) + (aset earr (dec (* 2 cnt)) nil) + (aset earr (- (* 2 cnt) 2) nil) + (set! (.-cnt editable) (dec (.-cnt editable))) + editable)))))) + + (kv-reduce [inode f init] + (inode-kv-reduce arr f init)) + + IIterable + (-iterator [coll] + (NodeIterator. arr 0 nil nil))) + +(defn- create-node + ([shift key1 val1 key2hash key2 val2] + (let [key1hash (hash key1)] + (if (== key1hash key2hash) + (HashCollisionNode. nil key1hash 2 (array key1 val1 key2 val2)) + (let [added-leaf? (Box. false)] + (-> (.-EMPTY BitmapIndexedNode) + (.inode-assoc shift key1hash key1 val1 added-leaf?) + (.inode-assoc shift key2hash key2 val2 added-leaf?)))))) + ([edit shift key1 val1 key2hash key2 val2] + (let [key1hash (hash key1)] + (if (== key1hash key2hash) + (HashCollisionNode. nil key1hash 2 (array key1 val1 key2 val2)) + (let [added-leaf? (Box. false)] + (-> (.-EMPTY BitmapIndexedNode) + (.inode-assoc! edit shift key1hash key1 val1 added-leaf?) + (.inode-assoc! edit shift key2hash key2 val2 added-leaf?))))))) + +(deftype NodeSeq [meta nodes i s ^:mutable __hash] + Object + (toString [coll] + (pr-str* coll)) + (equiv [this other] + (-equiv this other)) + (indexOf [coll x] + (-indexOf coll x 0)) + (indexOf [coll x start] + (-indexOf coll x start)) + (lastIndexOf [coll x] + (-lastIndexOf coll x (count coll))) + (lastIndexOf [coll x start] + (-lastIndexOf coll x start)) + + IMeta + (-meta [coll] meta) + + IWithMeta + (-with-meta [coll new-meta] + (if (identical? new-meta meta) + coll + (NodeSeq. new-meta nodes i s __hash))) + + ICollection + (-conj [coll o] (cons o coll)) + + IEmptyableCollection + (-empty [coll] (.-EMPTY List)) + + ISequential + ISeq + (-first [coll] + (if (nil? s) + (MapEntry. (aget nodes i) (aget nodes (inc i)) nil) + (first s))) + + (-rest [coll] + (let [ret (if (nil? s) + (create-inode-seq nodes (+ i 2) nil) + (create-inode-seq nodes i (next s)))] + (if-not (nil? ret) ret ()))) + + INext + (-next [coll] + (if (nil? s) + (create-inode-seq nodes (+ i 2) nil) + (create-inode-seq nodes i (next s)))) + + ISeqable + (-seq [this] this) + + IEquiv + (-equiv [coll other] (equiv-sequential coll other)) + + IHash + (-hash [coll] (caching-hash coll hash-ordered-coll __hash)) + + IReduce + (-reduce [coll f] (seq-reduce f coll)) + (-reduce [coll f start] (seq-reduce f start coll))) + +(es6-iterable NodeSeq) + +(defn- create-inode-seq + ([nodes] + (create-inode-seq nodes 0 nil)) + ([nodes i s] + (if (nil? s) + (let [len (alength nodes)] + (loop [j i] + (if (< j len) + (if-not (nil? (aget nodes j)) + (NodeSeq. nil nodes j nil nil) + (if-let [node (aget nodes (inc j))] + (if-let [node-seq (.inode-seq node)] + (NodeSeq. nil nodes (+ j 2) node-seq nil) + (recur (+ j 2))) + (recur (+ j 2))))))) + (NodeSeq. nil nodes i s nil)))) + +(deftype ArrayNodeSeq [meta nodes i s ^:mutable __hash] + Object + (toString [coll] + (pr-str* coll)) + (equiv [this other] + (-equiv this other)) + (indexOf [coll x] + (-indexOf coll x 0)) + (indexOf [coll x start] + (-indexOf coll x start)) + (lastIndexOf [coll x] + (-lastIndexOf coll x (count coll))) + (lastIndexOf [coll x start] + (-lastIndexOf coll x start)) + + IMeta + (-meta [coll] meta) + + IWithMeta + (-with-meta [coll new-meta] + (if (identical? new-meta meta) + coll + (ArrayNodeSeq. new-meta nodes i s __hash))) + + ICollection + (-conj [coll o] (cons o coll)) + + IEmptyableCollection + (-empty [coll] (.-EMPTY List)) + + ISequential + ISeq + (-first [coll] (first s)) + (-rest [coll] + (let [ret (create-array-node-seq nodes i (next s))] + (if-not (nil? ret) ret ()))) + + INext + (-next [coll] + (create-array-node-seq nodes i (next s))) + + ISeqable + (-seq [this] this) + + IEquiv + (-equiv [coll other] (equiv-sequential coll other)) + + IHash + (-hash [coll] (caching-hash coll hash-ordered-coll __hash)) + + IReduce + (-reduce [coll f] (seq-reduce f coll)) + (-reduce [coll f start] (seq-reduce f start coll))) + +(es6-iterable ArrayNodeSeq) + +(defn- create-array-node-seq + ([nodes] (create-array-node-seq nodes 0 nil)) + ([nodes i s] + (if (nil? s) + (let [len (alength nodes)] + (loop [j i] + (if (< j len) + (if-let [nj (aget nodes j)] + (if-let [ns (.inode-seq nj)] + (ArrayNodeSeq. nil nodes (inc j) ns nil) + (recur (inc j))) + (recur (inc j)))))) + (ArrayNodeSeq. nil nodes i s nil)))) + +(deftype HashMapIter [nil-val root-iter ^:mutable seen] + Object + (hasNext [_] + (or (not ^boolean seen) ^boolean (.hasNext root-iter))) + (next [_] + (if-not ^boolean seen + (do + (set! seen true) + (MapEntry. nil nil-val nil)) + (.next root-iter))) + (remove [_] (js/Error. "Unsupported operation"))) + +(deftype PersistentHashMap [meta cnt root ^boolean has-nil? nil-val ^:mutable __hash] + Object + (toString [coll] + (pr-str* coll)) + (equiv [this other] + (-equiv this other)) + + ;; EXPERIMENTAL: subject to change + (keys [coll] + (es6-iterator (keys coll))) + (entries [coll] + (es6-entries-iterator (seq coll))) + (values [coll] + (es6-iterator (vals coll))) + (has [coll k] + (contains? coll k)) + (get [coll k not-found] + (-lookup coll k not-found)) + (forEach [coll f] + (doseq [[k v] coll] + (f v k))) + + ICloneable + (-clone [_] (PersistentHashMap. meta cnt root has-nil? nil-val __hash)) + + IIterable + (-iterator [coll] + (let [root-iter (if ^boolean root (-iterator root) (nil-iter))] + (if has-nil? + (HashMapIter. nil-val root-iter false) + root-iter))) + + IWithMeta + (-with-meta [coll new-meta] + (if (identical? new-meta meta) + coll + (PersistentHashMap. new-meta cnt root has-nil? nil-val __hash))) + + IMeta + (-meta [coll] meta) + + ICollection + (-conj [coll entry] + (if (vector? entry) + (-assoc coll (-nth entry 0) (-nth entry 1)) + (loop [ret coll es (seq entry)] + (if (nil? es) + ret + (let [e (first es)] + (if (vector? e) + (recur (-assoc ret (-nth e 0) (-nth e 1)) + (next es)) + (throw (js/Error. "conj on a map takes map entries or seqables of map entries")))))))) + + IEmptyableCollection + (-empty [coll] (-with-meta (.-EMPTY PersistentHashMap) meta)) + + IEquiv + (-equiv [coll other] (equiv-map coll other)) + + IHash + (-hash [coll] (caching-hash coll hash-unordered-coll __hash)) + + ISeqable + (-seq [coll] + (when (pos? cnt) + (let [s (if-not (nil? root) (.inode-seq root))] + (if has-nil? + (cons (MapEntry. nil nil-val nil) s) + s)))) + + ICounted + (-count [coll] cnt) + + ILookup + (-lookup [coll k] + (-lookup coll k nil)) + + (-lookup [coll k not-found] + (cond (nil? k) (if has-nil? + nil-val + not-found) + (nil? root) not-found + :else (.inode-lookup root 0 (hash k) k not-found))) + + IAssociative + (-assoc [coll k v] + (if (nil? k) + (if (and has-nil? (identical? v nil-val)) + coll + (PersistentHashMap. meta (if has-nil? cnt (inc cnt)) root true v nil)) + (let [added-leaf? (Box. false) + new-root (-> (if (nil? root) + (.-EMPTY BitmapIndexedNode) + root) + (.inode-assoc 0 (hash k) k v added-leaf?))] + (if (identical? new-root root) + coll + (PersistentHashMap. meta (if ^boolean (.-val added-leaf?) (inc cnt) cnt) new-root has-nil? nil-val nil))))) + + (-contains-key? [coll k] + (cond (nil? k) has-nil? + (nil? root) false + :else (not (identical? (.inode-lookup root 0 (hash k) k lookup-sentinel) + lookup-sentinel)))) + + IFind + (-find [coll k] + (cond + (nil? k) (when has-nil? (MapEntry. nil nil-val nil)) + (nil? root) nil + :else (.inode-find root 0 (hash k) k nil))) + + IMap + (-dissoc [coll k] + (cond (nil? k) (if has-nil? + (PersistentHashMap. meta (dec cnt) root false nil nil) + coll) + (nil? root) coll + :else + (let [new-root (.inode-without root 0 (hash k) k)] + (if (identical? new-root root) + coll + (PersistentHashMap. meta (dec cnt) new-root has-nil? nil-val nil))))) + + IKVReduce + (-kv-reduce [coll f init] + (let [init (if has-nil? (f init nil nil-val) init)] + (cond + (reduced? init) @init + (not (nil? root)) (unreduced (.kv-reduce root f init)) + :else init))) + + IFn + (-invoke [coll k] + (-lookup coll k)) + + (-invoke [coll k not-found] + (-lookup coll k not-found)) + + IEditableCollection + (-as-transient [coll] + (TransientHashMap. (js-obj) root cnt has-nil? nil-val))) + +(set! (.-EMPTY PersistentHashMap) (PersistentHashMap. nil 0 nil false nil empty-unordered-hash)) + +(set! (.-fromArray PersistentHashMap) + (fn [arr ^boolean no-clone] + (let [arr (if no-clone arr (aclone arr)) + len (alength arr)] + (loop [i 0 ret (transient (.-EMPTY PersistentHashMap))] + (if (< i len) + (recur (+ i 2) + (-assoc! ret (aget arr i) (aget arr (inc i)))) + (-persistent! ret)))))) + +(set! (.-fromArrays PersistentHashMap) + (fn [ks vs] + (let [len (alength ks)] + (loop [i 0 ^not-native out (transient (.-EMPTY PersistentHashMap))] + (if (< i len) + (recur (inc i) (-assoc! out (aget ks i) (aget vs i))) + (persistent! out)))))) + +(set! (.-createWithCheck PersistentHashMap) + (fn [arr] + (let [len (alength arr) + ret (transient (.-EMPTY PersistentHashMap))] + (loop [i 0] + (when (< i len) + (-assoc! ret (aget arr i) (aget arr (inc i))) + (if (not= (-count ret) (inc (/ i 2))) + (throw (js/Error. (str "Duplicate key: " (aget arr i)))) + (recur (+ i 2))))) + (-persistent! ret)))) + +(es6-iterable PersistentHashMap) + +(deftype TransientHashMap [^:mutable ^boolean edit + ^:mutable root + ^:mutable count + ^:mutable ^boolean has-nil? + ^:mutable nil-val] + Object + (conj! [tcoll o] + (if edit + (cond + (map-entry? o) + (.assoc! tcoll (key o) (val o)) + + (vector? o) + (.assoc! tcoll (o 0) (o 1)) + + :else + (loop [es (seq o) tcoll tcoll] + (if-let [e (first es)] + (recur (next es) + (.assoc! tcoll (key e) (val e))) + tcoll))) + (throw (js/Error. "conj! after persistent")))) + + (assoc! [tcoll k v] + (if edit + (if (nil? k) + (do (if (identical? nil-val v) + nil + (set! nil-val v)) + (if has-nil? + nil + (do (set! count (inc count)) + (set! has-nil? true))) + tcoll) + (let [added-leaf? (Box. false) + node (-> (if (nil? root) + (.-EMPTY BitmapIndexedNode) + root) + (.inode-assoc! edit 0 (hash k) k v added-leaf?))] + (if (identical? node root) + nil + (set! root node)) + (if ^boolean (.-val added-leaf?) + (set! count (inc count))) + tcoll)) + (throw (js/Error. "assoc! after persistent!")))) + + (without! [tcoll k] + (if edit + (if (nil? k) + (if has-nil? + (do (set! has-nil? false) + (set! nil-val nil) + (set! count (dec count)) + tcoll) + tcoll) + (if (nil? root) + tcoll + (let [removed-leaf? (Box. false) + node (.inode-without! root edit 0 (hash k) k removed-leaf?)] + (if (identical? node root) + nil + (set! root node)) + (if ^boolean (.-val removed-leaf?) + (set! count (dec count))) + tcoll))) + (throw (js/Error. "dissoc! after persistent!")))) + + (persistent! [tcoll] + (if edit + (do (set! edit nil) + (PersistentHashMap. nil count root has-nil? nil-val nil)) + (throw (js/Error. "persistent! called twice")))) + + ICounted + (-count [coll] + (if edit + count + (throw (js/Error. "count after persistent!")))) + + ILookup + (-lookup [tcoll k] + (if (nil? k) + (if has-nil? + nil-val) + (if (nil? root) + nil + (.inode-lookup root 0 (hash k) k)))) + + (-lookup [tcoll k not-found] + (if (nil? k) + (if has-nil? + nil-val + not-found) + (if (nil? root) + not-found + (.inode-lookup root 0 (hash k) k not-found)))) + + ITransientCollection + (-conj! [tcoll val] (.conj! tcoll val)) + + (-persistent! [tcoll] (.persistent! tcoll)) + + ITransientAssociative + (-assoc! [tcoll key val] (.assoc! tcoll key val)) + + ITransientMap + (-dissoc! [tcoll key] (.without! tcoll key)) + + IFn + (-invoke [tcoll key] + (-lookup tcoll key)) + (-invoke [tcoll key not-found] + (-lookup tcoll key not-found))) + +;;; PersistentTreeMap + +(defn- tree-map-seq-push [node stack ^boolean ascending?] + (loop [t node stack stack] + (if-not (nil? t) + (recur (if ascending? (.-left t) (.-right t)) + (conj stack t)) + stack))) + +(deftype PersistentTreeMapSeq [meta stack ^boolean ascending? cnt ^:mutable __hash] + Object + (toString [coll] + (pr-str* coll)) + (equiv [this other] + (-equiv this other)) + (indexOf [coll x] + (-indexOf coll x 0)) + (indexOf [coll x start] + (-indexOf coll x start)) + (lastIndexOf [coll x] + (-lastIndexOf coll x (count coll))) + (lastIndexOf [coll x start] + (-lastIndexOf coll x start)) + + ISeqable + (-seq [this] this) + + ISequential + ISeq + (-first [this] (peek stack)) + (-rest [this] + (let [t (first stack) + next-stack (tree-map-seq-push (if ascending? (.-right t) (.-left t)) + (next stack) + ascending?)] + (if-not (nil? next-stack) + (PersistentTreeMapSeq. nil next-stack ascending? (dec cnt) nil) + ()))) + INext + (-next [this] + (let [t (first stack) + next-stack (tree-map-seq-push (if ascending? (.-right t) (.-left t)) + (next stack) + ascending?)] + (when-not (nil? next-stack) + (PersistentTreeMapSeq. nil next-stack ascending? (dec cnt) nil)))) + + ICounted + (-count [coll] + (if (neg? cnt) + (inc (count (next coll))) + cnt)) + + IEquiv + (-equiv [coll other] (equiv-sequential coll other)) + + ICollection + (-conj [coll o] (cons o coll)) + + IEmptyableCollection + (-empty [coll] (.-EMPTY List)) + + IHash + (-hash [coll] (caching-hash coll hash-ordered-coll __hash)) + + IMeta + (-meta [coll] meta) + + IWithMeta + (-with-meta [coll new-meta] + (if (identical? new-meta meta) + coll + (PersistentTreeMapSeq. new-meta stack ascending? cnt __hash))) + + IReduce + (-reduce [coll f] (seq-reduce f coll)) + (-reduce [coll f start] (seq-reduce f start coll))) + +(es6-iterable PersistentTreeMapSeq) + +(defn- create-tree-map-seq [tree ascending? cnt] + (PersistentTreeMapSeq. nil (tree-map-seq-push tree nil ascending?) ascending? cnt nil)) + +(declare RedNode BlackNode) + +(defn- balance-left [key val ins right] + (if (instance? RedNode ins) + (cond + (instance? RedNode (.-left ins)) + (RedNode. (.-key ins) (.-val ins) + (.blacken (.-left ins)) + (BlackNode. key val (.-right ins) right nil) + nil) + + (instance? RedNode (.-right ins)) + (RedNode. (.. ins -right -key) (.. ins -right -val) + (BlackNode. (.-key ins) (.-val ins) + (.-left ins) + (.. ins -right -left) + nil) + (BlackNode. key val + (.. ins -right -right) + right + nil) + nil) + + :else + (BlackNode. key val ins right nil)) + (BlackNode. key val ins right nil))) + +(defn- balance-right [key val left ins] + (if (instance? RedNode ins) + (cond + (instance? RedNode (.-right ins)) + (RedNode. (.-key ins) (.-val ins) + (BlackNode. key val left (.-left ins) nil) + (.blacken (.-right ins)) + nil) + + (instance? RedNode (.-left ins)) + (RedNode. (.. ins -left -key) (.. ins -left -val) + (BlackNode. key val left (.. ins -left -left) nil) + (BlackNode. (.-key ins) (.-val ins) + (.. ins -left -right) + (.-right ins) + nil) + nil) + + :else + (BlackNode. key val left ins nil)) + (BlackNode. key val left ins nil))) + +(defn- balance-left-del [key val del right] + (cond + (instance? RedNode del) + (RedNode. key val (.blacken del) right nil) + + (instance? BlackNode right) + (balance-right key val del (.redden right)) + + (and (instance? RedNode right) (instance? BlackNode (.-left right))) + (RedNode. (.. right -left -key) (.. right -left -val) + (BlackNode. key val del (.. right -left -left) nil) + (balance-right (.-key right) (.-val right) + (.. right -left -right) + (.redden (.-right right))) + nil) + + :else + (throw (js/Error. "red-black tree invariant violation")))) + +(defn- balance-right-del [key val left del] + (cond + (instance? RedNode del) + (RedNode. key val left (.blacken del) nil) + + (instance? BlackNode left) + (balance-left key val (.redden left) del) + + (and (instance? RedNode left) (instance? BlackNode (.-right left))) + (RedNode. (.. left -right -key) (.. left -right -val) + (balance-left (.-key left) (.-val left) + (.redden (.-left left)) + (.. left -right -left)) + (BlackNode. key val (.. left -right -right) del nil) + nil) + + :else + (throw (js/Error. "red-black tree invariant violation")))) + +(defn- tree-map-kv-reduce [node f init] + (let [init (if-not (nil? (.-left node)) + (tree-map-kv-reduce (.-left node) f init) + init)] + (if (reduced? init) + init + (let [init (f init (.-key node) (.-val node))] + (if (reduced? init) + init + (if-not (nil? (.-right node)) + (tree-map-kv-reduce (.-right node) f init) + init)))))) + +(deftype BlackNode [key val left right ^:mutable __hash] + Object + (add-left [node ins] + (.balance-left ins node)) + + (add-right [node ins] + (.balance-right ins node)) + + (remove-left [node del] + (balance-left-del key val del right)) + + (remove-right [node del] + (balance-right-del key val left del)) + + (blacken [node] node) + + (redden [node] (RedNode. key val left right nil)) + + (balance-left [node parent] + (BlackNode. (.-key parent) (.-val parent) node (.-right parent) nil)) + + (balance-right [node parent] + (BlackNode. (.-key parent) (.-val parent) (.-left parent) node nil)) + + (replace [node key val left right] + (BlackNode. key val left right nil)) + + (kv-reduce [node f init] + (tree-map-kv-reduce node f init)) + + (indexOf [coll x] + (-indexOf coll x 0)) + (indexOf [coll x start] + (-indexOf coll x start)) + (lastIndexOf [coll x] + (-lastIndexOf coll x (count coll))) + (lastIndexOf [coll x start] + (-lastIndexOf coll x start)) + + IMapEntry + (-key [node] key) + (-val [node] val) + + IHash + (-hash [coll] (caching-hash coll hash-ordered-coll __hash)) + + IEquiv + (-equiv [coll other] (equiv-sequential coll other)) + + IMeta + (-meta [node] nil) + + IWithMeta + (-with-meta [node meta] + (-with-meta [key val] meta)) + + IStack + (-peek [node] val) + + (-pop [node] [key]) + + ICollection + (-conj [node o] [key val o]) + + IEmptyableCollection + (-empty [node] nil) + + ISequential + ISeqable + (-seq [node] (IndexedSeq. #js [key val] 0 nil)) + + IReversible + (-rseq [node] (IndexedSeq. #js [val key] 0 nil)) + + ICounted + (-count [node] 2) + + IIndexed + (-nth [node n] + (cond (== n 0) key + (== n 1) val + :else (throw (js/Error. "Index out of bounds")))) + + (-nth [node n not-found] + (cond (== n 0) key + (== n 1) val + :else not-found)) + + ILookup + (-lookup [node k] (-nth node k nil)) + (-lookup [node k not-found] (-nth node k not-found)) + + IAssociative + (-assoc [node k v] + (assoc [key val] k v)) + (-contains-key? [node k] + (or (== k 0) (== k 1))) + + IFind + (-find [node k] + (case k + 0 (MapEntry. 0 key nil) + 1 (MapEntry. 1 val nil) + nil)) + + IVector + (-assoc-n [node n v] + (-assoc-n [key val] n v)) + + IReduce + (-reduce [node f] + (ci-reduce node f)) + + (-reduce [node f start] + (ci-reduce node f start)) + + IFn + (-invoke [node k] + (-nth node k)) + + (-invoke [node k not-found] + (-nth node k not-found))) + +(es6-iterable BlackNode) + +(deftype RedNode [key val left right ^:mutable __hash] + Object + (add-left [node ins] + (RedNode. key val ins right nil)) + + (add-right [node ins] + (RedNode. key val left ins nil)) + + (remove-left [node del] + (RedNode. key val del right nil)) + + (remove-right [node del] + (RedNode. key val left del nil)) + + (blacken [node] + (BlackNode. key val left right nil)) + + (redden [node] + (throw (js/Error. "red-black tree invariant violation"))) + + (balance-left [node parent] + (cond + (instance? RedNode left) + (RedNode. key val + (.blacken left) + (BlackNode. (.-key parent) (.-val parent) right (.-right parent) nil) + nil) + + (instance? RedNode right) + (RedNode. (.-key right) (.-val right) + (BlackNode. key val left (.-left right) nil) + (BlackNode. (.-key parent) (.-val parent) + (.-right right) + (.-right parent) + nil) + nil) + + :else + (BlackNode. (.-key parent) (.-val parent) node (.-right parent) nil))) + + (balance-right [node parent] + (cond + (instance? RedNode right) + (RedNode. key val + (BlackNode. (.-key parent) (.-val parent) + (.-left parent) + left + nil) + (.blacken right) + nil) + + (instance? RedNode left) + (RedNode. (.-key left) (.-val left) + (BlackNode. (.-key parent) (.-val parent) + (.-left parent) + (.-left left) + nil) + (BlackNode. key val (.-right left) right nil) + nil) + + :else + (BlackNode. (.-key parent) (.-val parent) (.-left parent) node nil))) + + (replace [node key val left right] + (RedNode. key val left right nil)) + + (kv-reduce [node f init] + (tree-map-kv-reduce node f init)) + + (indexOf [coll x] + (-indexOf coll x 0)) + (indexOf [coll x start] + (-indexOf coll x start)) + (lastIndexOf [coll x] + (-lastIndexOf coll x (count coll))) + (lastIndexOf [coll x start] + (-lastIndexOf coll x start)) + + IMapEntry + (-key [node] key) + (-val [node] val) + + IHash + (-hash [coll] (caching-hash coll hash-ordered-coll __hash)) + + IEquiv + (-equiv [coll other] (equiv-sequential coll other)) + + IMeta + (-meta [node] nil) + + IWithMeta + (-with-meta [node meta] + (-with-meta [key val] meta)) + + IStack + (-peek [node] val) + + (-pop [node] [key]) + + ICollection + (-conj [node o] [key val o]) + + IEmptyableCollection + (-empty [node] nil) + + ISequential + ISeqable + (-seq [node] (IndexedSeq. #js [key val] 0 nil)) + + IReversible + (-rseq [node] (IndexedSeq. #js [val key] 0 nil)) + + ICounted + (-count [node] 2) + + IIndexed + (-nth [node n] + (cond (== n 0) key + (== n 1) val + :else (throw (js/Error. "Index out of bounds")))) + + (-nth [node n not-found] + (cond (== n 0) key + (== n 1) val + :else not-found)) + + ILookup + (-lookup [node k] (-nth node k nil)) + (-lookup [node k not-found] (-nth node k not-found)) + + IAssociative + (-assoc [node k v] + (assoc [key val] k v)) + (-contains-key? [node k] + (or (== k 0) (== k 1))) + + IFind + (-find [node k] + (case k + 0 (MapEntry. 0 key nil) + 1 (MapEntry. 1 val nil) + nil)) + + IVector + (-assoc-n [node n v] + (-assoc-n [key val] n v)) + + IReduce + (-reduce [node f] + (ci-reduce node f)) + + (-reduce [node f start] + (ci-reduce node f start)) + + IFn + (-invoke [node k] + (-nth node k)) + + (-invoke [node k not-found] + (-nth node k not-found))) + +(es6-iterable RedNode) + +(defn- tree-map-add [comp tree k v found] + (if (nil? tree) + (RedNode. k v nil nil nil) + (let [c (comp k (.-key tree))] + (cond + (zero? c) + (do (aset found 0 tree) + nil) + + (neg? c) + (let [ins (tree-map-add comp (.-left tree) k v found)] + (if-not (nil? ins) + (.add-left tree ins))) + + :else + (let [ins (tree-map-add comp (.-right tree) k v found)] + (if-not (nil? ins) + (.add-right tree ins))))))) + +(defn- tree-map-append [left right] + (cond + (nil? left) + right + + (nil? right) + left + + (instance? RedNode left) + (if (instance? RedNode right) + (let [app (tree-map-append (.-right left) (.-left right))] + (if (instance? RedNode app) + (RedNode. (.-key app) (.-val app) + (RedNode. (.-key left) (.-val left) + (.-left left) + (.-left app) + nil) + (RedNode. (.-key right) (.-val right) + (.-right app) + (.-right right) + nil) + nil) + (RedNode. (.-key left) (.-val left) + (.-left left) + (RedNode. (.-key right) (.-val right) app (.-right right) nil) + nil))) + (RedNode. (.-key left) (.-val left) + (.-left left) + (tree-map-append (.-right left) right) + nil)) + + (instance? RedNode right) + (RedNode. (.-key right) (.-val right) + (tree-map-append left (.-left right)) + (.-right right) + nil) + + :else + (let [app (tree-map-append (.-right left) (.-left right))] + (if (instance? RedNode app) + (RedNode. (.-key app) (.-val app) + (BlackNode. (.-key left) (.-val left) + (.-left left) + (.-left app) + nil) + (BlackNode. (.-key right) (.-val right) + (.-right app) + (.-right right) + nil) + nil) + (balance-left-del (.-key left) (.-val left) + (.-left left) + (BlackNode. (.-key right) (.-val right) + app + (.-right right) + nil)))))) + +(defn- tree-map-remove [comp tree k found] + (if-not (nil? tree) + (let [c (comp k (.-key tree))] + (cond + (zero? c) + (do (aset found 0 tree) + (tree-map-append (.-left tree) (.-right tree))) + + (neg? c) + (let [del (tree-map-remove comp (.-left tree) k found)] + (if (or (not (nil? del)) (not (nil? (aget found 0)))) + (if (instance? BlackNode (.-left tree)) + (balance-left-del (.-key tree) (.-val tree) del (.-right tree)) + (RedNode. (.-key tree) (.-val tree) del (.-right tree) nil)))) + + :else + (let [del (tree-map-remove comp (.-right tree) k found)] + (if (or (not (nil? del)) (not (nil? (aget found 0)))) + (if (instance? BlackNode (.-right tree)) + (balance-right-del (.-key tree) (.-val tree) (.-left tree) del) + (RedNode. (.-key tree) (.-val tree) (.-left tree) del nil)))))))) + +(defn- tree-map-replace [comp tree k v] + (let [tk (.-key tree) + c (comp k tk)] + (cond (zero? c) (.replace tree tk v (.-left tree) (.-right tree)) + (neg? c) (.replace tree tk (.-val tree) (tree-map-replace comp (.-left tree) k v) (.-right tree)) + :else (.replace tree tk (.-val tree) (.-left tree) (tree-map-replace comp (.-right tree) k v))))) + +(declare key) + +(deftype PersistentTreeMap [comp tree cnt meta ^:mutable __hash] + Object + (toString [coll] + (pr-str* coll)) + (equiv [this other] + (-equiv this other)) + + ;; EXPERIMENTAL: subject to change + (keys [coll] + (es6-iterator (keys coll))) + (entries [coll] + (es6-entries-iterator (seq coll))) + (values [coll] + (es6-iterator (vals coll))) + (has [coll k] + (contains? coll k)) + (get [coll k not-found] + (-lookup coll k not-found)) + (forEach [coll f] + (doseq [[k v] coll] + (f v k))) + + (entry-at [coll k] + (loop [t tree] + (if-not (nil? t) + (let [c (comp k (.-key t))] + (cond (zero? c) t + (neg? c) (recur (.-left t)) + :else (recur (.-right t))))))) + + ICloneable + (-clone [_] (PersistentTreeMap. comp tree cnt meta __hash)) + + IWithMeta + (-with-meta [coll new-meta] + (if (identical? new-meta meta) + coll + (PersistentTreeMap. comp tree cnt new-meta __hash))) + + IMeta + (-meta [coll] meta) + + ICollection + (-conj [coll entry] + (if (vector? entry) + (-assoc coll (-nth entry 0) (-nth entry 1)) + (loop [ret coll es (seq entry)] + (if (nil? es) + ret + (let [e (first es)] + (if (vector? e) + (recur (-assoc ret (-nth e 0) (-nth e 1)) + (next es)) + (throw (js/Error. "conj on a map takes map entries or seqables of map entries")))))))) + + IEmptyableCollection + (-empty [coll] (PersistentTreeMap. comp nil 0 meta 0)) + + IEquiv + (-equiv [coll other] (equiv-map coll other)) + + IHash + (-hash [coll] (caching-hash coll hash-unordered-coll __hash)) + + ICounted + (-count [coll] cnt) + + IKVReduce + (-kv-reduce [coll f init] + (if-not (nil? tree) + (unreduced (tree-map-kv-reduce tree f init)) + init)) + + IFn + (-invoke [coll k] + (-lookup coll k)) + + (-invoke [coll k not-found] + (-lookup coll k not-found)) + + ISeqable + (-seq [coll] + (if (pos? cnt) + (create-tree-map-seq tree true cnt))) + + IReversible + (-rseq [coll] + (if (pos? cnt) + (create-tree-map-seq tree false cnt))) + + ILookup + (-lookup [coll k] + (-lookup coll k nil)) + + (-lookup [coll k not-found] + (let [n (.entry-at coll k)] + (if-not (nil? n) + (.-val n) + not-found))) + + IAssociative + (-assoc [coll k v] + (let [found (array nil) + t (tree-map-add comp tree k v found)] + (if (nil? t) + (let [found-node (nth found 0)] + (if (= v (.-val found-node)) + coll + (PersistentTreeMap. comp (tree-map-replace comp tree k v) cnt meta nil))) + (PersistentTreeMap. comp (.blacken t) (inc cnt) meta nil)))) + + (-contains-key? [coll k] + (not (nil? (.entry-at coll k)))) + + IFind + (-find [coll k] + (.entry-at coll k)) + + IMap + (-dissoc [coll k] + (let [found (array nil) + t (tree-map-remove comp tree k found)] + (if (nil? t) + (if (nil? (nth found 0)) + coll + (PersistentTreeMap. comp nil 0 meta nil)) + (PersistentTreeMap. comp (.blacken t) (dec cnt) meta nil)))) + + ISorted + (-sorted-seq [coll ascending?] + (if (pos? cnt) + (create-tree-map-seq tree ascending? cnt))) + + (-sorted-seq-from [coll k ascending?] + (if (pos? cnt) + (loop [stack nil t tree] + (if-not (nil? t) + (let [c (comp k (.-key t))] + (cond + (zero? c) (PersistentTreeMapSeq. nil (conj stack t) ascending? -1 nil) + ascending? (if (neg? c) + (recur (conj stack t) (.-left t)) + (recur stack (.-right t))) + :else (if (pos? c) + (recur (conj stack t) (.-right t)) + (recur stack (.-left t))))) + (when-not (nil? stack) + (PersistentTreeMapSeq. nil stack ascending? -1 nil)))))) + + (-entry-key [coll entry] (key entry)) + + (-comparator [coll] comp)) + +(set! (.-EMPTY PersistentTreeMap) (PersistentTreeMap. compare nil 0 nil empty-unordered-hash)) + +(es6-iterable PersistentTreeMap) + +(defn hash-map + "keyval => key val + Returns a new hash map with supplied mappings." + [& keyvals] + (loop [in (seq keyvals), out (transient (.-EMPTY PersistentHashMap))] + (if in + (recur (nnext in) (assoc! out (first in) (second in))) + (persistent! out)))) + +(defn array-map + "keyval => key val + Returns a new array map with supplied mappings." + [& keyvals] + (let [arr (if (and (instance? IndexedSeq keyvals) (zero? (.-i keyvals))) + (.-arr keyvals) + (into-array keyvals))] + (.createAsIfByAssoc PersistentArrayMap arr))) + +(defn obj-map + "keyval => key val + Returns a new object map with supplied mappings." + [& keyvals] + (let [ks (array) + obj (js-obj)] + (loop [kvs (seq keyvals)] + (if kvs + (do (.push ks (first kvs)) + (gobject/set obj (first kvs) (second kvs)) + (recur (nnext kvs))) + (.fromObject ObjMap ks obj))))) + +(defn sorted-map + "keyval => key val + Returns a new sorted map with supplied mappings." + ([& keyvals] + (loop [in (seq keyvals) out (.-EMPTY PersistentTreeMap)] + (if in + (recur (nnext in) (assoc out (first in) (second in))) + out)))) + +(defn sorted-map-by + "keyval => key val + Returns a new sorted map with supplied mappings, using the supplied comparator." + ([comparator & keyvals] + (loop [in (seq keyvals) + out (PersistentTreeMap. (fn->comparator comparator) nil 0 nil 0)] + (if in + (recur (nnext in) (assoc out (first in) (second in))) + out)))) + +(deftype KeySeq [^not-native mseq _meta] + Object + (toString [coll] + (pr-str* coll)) + (equiv [this other] + (-equiv this other)) + (indexOf [coll x] + (-indexOf coll x 0)) + (indexOf [coll x start] + (-indexOf coll x start)) + (lastIndexOf [coll x] + (-lastIndexOf coll x (count coll))) + (lastIndexOf [coll x start] + (-lastIndexOf coll x start)) + + IMeta + (-meta [coll] _meta) + + IWithMeta + (-with-meta [coll new-meta] + (if (identical? new-meta _meta) + coll + (KeySeq. mseq new-meta))) + + ISeqable + (-seq [coll] coll) + + ISequential + IEquiv + (-equiv [coll other] (equiv-sequential coll other)) + + ICollection + (-conj [coll o] + (cons o coll)) + + IEmptyableCollection + (-empty [coll] (.-EMPTY List)) + + IHash + (-hash [coll] (hash-ordered-coll coll)) + + ISeq + (-first [coll] + (let [^not-native me (-first mseq)] + (-key me))) + + (-rest [coll] + (let [nseq (if (satisfies? INext mseq) + (-next mseq) + (next mseq))] + (if-not (nil? nseq) + (KeySeq. nseq nil) + ()))) + + INext + (-next [coll] + (let [nseq (if (satisfies? INext mseq) + (-next mseq) + (next mseq))] + (when-not (nil? nseq) + (KeySeq. nseq nil)))) + + IReduce + (-reduce [coll f] (seq-reduce f coll)) + (-reduce [coll f start] (seq-reduce f start coll))) + +(es6-iterable KeySeq) + +(defn keys + "Returns a sequence of the map's keys, in the same order as (seq map)." + [map] + (when-let [mseq (seq map)] + (KeySeq. mseq nil))) + +(defn key + "Returns the key of the map entry." + [map-entry] + (-key map-entry)) + +(deftype ValSeq [^not-native mseq _meta] + Object + (toString [coll] + (pr-str* coll)) + (equiv [this other] + (-equiv this other)) + (indexOf [coll x] + (-indexOf coll x 0)) + (indexOf [coll x start] + (-indexOf coll x start)) + (lastIndexOf [coll x] + (-lastIndexOf coll x (count coll))) + (lastIndexOf [coll x start] + (-lastIndexOf coll x start)) + + IMeta + (-meta [coll] _meta) + + IWithMeta + (-with-meta [coll new-meta] + (if (identical? new-meta _meta) + coll + (ValSeq. mseq new-meta))) + + ISeqable + (-seq [coll] coll) + + ISequential + IEquiv + (-equiv [coll other] (equiv-sequential coll other)) + + ICollection + (-conj [coll o] + (cons o coll)) + + IEmptyableCollection + (-empty [coll] (.-EMPTY List)) + + IHash + (-hash [coll] (hash-ordered-coll coll)) + + ISeq + (-first [coll] + (let [^not-native me (-first mseq)] + (-val me))) + + (-rest [coll] + (let [nseq (if (satisfies? INext mseq) + (-next mseq) + (next mseq))] + (if-not (nil? nseq) + (ValSeq. nseq nil) + ()))) + + INext + (-next [coll] + (let [nseq (if (satisfies? INext mseq) + (-next mseq) + (next mseq))] + (when-not (nil? nseq) + (ValSeq. nseq nil)))) + + IReduce + (-reduce [coll f] (seq-reduce f coll)) + (-reduce [coll f start] (seq-reduce f start coll))) + +(es6-iterable ValSeq) + +(defn vals + "Returns a sequence of the map's values, in the same order as (seq map)." + [map] + (when-let [mseq (seq map)] + (ValSeq. mseq nil))) + +(defn val + "Returns the value in the map entry." + [map-entry] + (-val map-entry)) + +(defn merge + "Returns a map that consists of the rest of the maps conj-ed onto + the first. If a key occurs in more than one map, the mapping from + the latter (left-to-right) will be the mapping in the result." + [& maps] + (when (some identity maps) + (reduce #(conj (or %1 {}) %2) maps))) + +(defn merge-with + "Returns a map that consists of the rest of the maps conj-ed onto + the first. If a key occurs in more than one map, the mapping(s) + from the latter (left-to-right) will be combined with the mapping in + the result by calling (f val-in-result val-in-latter)." + [f & maps] + (when (some identity maps) + (let [merge-entry (fn [m e] + (let [k (key e) v (val e)] + (if (contains? m k) + (assoc m k (f (get m k) v)) + (assoc m k v)))) + merge2 (fn [m1 m2] + (reduce merge-entry (or m1 {}) (seq m2)))] + (reduce merge2 maps)))) + +(defn select-keys + "Returns a map containing only those entries in map whose key is in keys" + [map keyseq] + (loop [ret {} keys (seq keyseq)] + (if keys + (let [key (first keys) + entry (get map key ::not-found)] + (recur + (if (not= entry ::not-found) + (assoc ret key entry) + ret) + (next keys))) + (-with-meta ret (meta map))))) + +;;; PersistentHashSet + +(declare TransientHashSet) + +(deftype HashSetIter [iter] + Object + (hasNext [_] + (.hasNext iter)) + (next [_] + (if ^boolean (.hasNext iter) + (.-key (.next iter)) + (throw (js/Error. "No such element")))) + (remove [_] (js/Error. "Unsupported operation"))) + +(deftype PersistentHashSet [meta hash-map ^:mutable __hash] + Object + (toString [coll] + (pr-str* coll)) + (equiv [this other] + (-equiv this other)) + + ;; EXPERIMENTAL: subject to change + (keys [coll] + (es6-iterator (seq coll))) + (entries [coll] + (es6-set-entries-iterator (seq coll))) + (values [coll] + (es6-iterator (seq coll))) + (has [coll k] + (contains? coll k)) + (forEach [coll f] + (doseq [[k v] coll] + (f v k))) + + ICloneable + (-clone [_] (PersistentHashSet. meta hash-map __hash)) + + IIterable + (-iterator [coll] + (HashSetIter. (-iterator hash-map))) + + IWithMeta + (-with-meta [coll new-meta] + (if (identical? new-meta meta) + coll + (PersistentHashSet. new-meta hash-map __hash))) + + IMeta + (-meta [coll] meta) + + ICollection + (-conj [coll o] + (PersistentHashSet. meta (assoc hash-map o nil) nil)) + + IEmptyableCollection + (-empty [coll] (-with-meta (.-EMPTY PersistentHashSet) meta)) + + IEquiv + (-equiv [coll other] + (and + (set? other) + (== (count coll) (count other)) + ^boolean + (try + (reduce-kv + #(or (contains? other %2) (reduced false)) + true hash-map) + (catch js/Error ex + false)))) + + IHash + (-hash [coll] (caching-hash coll hash-unordered-coll __hash)) + + ISeqable + (-seq [coll] (keys hash-map)) + + ICounted + (-count [coll] (-count hash-map)) + + ILookup + (-lookup [coll v] + (-lookup coll v nil)) + (-lookup [coll v not-found] + (if-let [entry (-find hash-map v)] + (key entry) + not-found)) + + ISet + (-disjoin [coll v] + (PersistentHashSet. meta (-dissoc hash-map v) nil)) + + IFn + (-invoke [coll k] + (-lookup coll k)) + (-invoke [coll k not-found] + (-lookup coll k not-found)) + + IEditableCollection + (-as-transient [coll] (TransientHashSet. (-as-transient hash-map)))) + +(set! (.-EMPTY PersistentHashSet) + (PersistentHashSet. nil (.-EMPTY PersistentArrayMap) empty-unordered-hash)) + +(set! (.-fromArray PersistentHashSet) + (fn [items ^boolean no-clone] + (let [len (alength items)] + (if (<= len (.-HASHMAP-THRESHOLD PersistentArrayMap)) + (let [arr (if no-clone items (aclone items))] + (loop [i 0 + out (transient (.-EMPTY PersistentArrayMap))] + (if (< i len) + (recur (inc i) (-assoc! out (aget items i) nil)) + (PersistentHashSet. nil (-persistent! out) nil)))) + (loop [i 0 + out (transient (.-EMPTY PersistentHashSet))] + (if (< i len) + (recur (inc i) (-conj! out (aget items i))) + (-persistent! out))))))) + +(set! (.-createWithCheck PersistentHashSet) + (fn [items] + (let [len (alength items) + t (-as-transient (.-EMPTY PersistentHashSet))] + (dotimes [i len] + (-conj! t (aget items i)) + (when-not (= (count t) (inc i)) + (throw (js/Error. (str "Duplicate key: " (aget items i)))))) + (-persistent! t)))) + +(set! (.-createAsIfByAssoc PersistentHashSet) + (fn [items] + (let [len (alength items) + t (-as-transient (.-EMPTY PersistentHashSet))] + (dotimes [i len] (-conj! t (aget items i))) + (-persistent! t)))) + +(es6-iterable PersistentHashSet) + +(deftype TransientHashSet [^:mutable transient-map] + ITransientCollection + (-conj! [tcoll o] + (set! transient-map (assoc! transient-map o nil)) + tcoll) + + (-persistent! [tcoll] + (PersistentHashSet. nil (persistent! transient-map) nil)) + + ITransientSet + (-disjoin! [tcoll v] + (set! transient-map (dissoc! transient-map v)) + tcoll) + + ICounted + (-count [tcoll] (count transient-map)) + + ILookup + (-lookup [tcoll v] + (-lookup tcoll v nil)) + + (-lookup [tcoll v not-found] + (if (identical? (-lookup transient-map v lookup-sentinel) lookup-sentinel) + not-found + v)) + + IFn + (-invoke [tcoll k] + (if (identical? (-lookup transient-map k lookup-sentinel) lookup-sentinel) + nil + k)) + + (-invoke [tcoll k not-found] + (if (identical? (-lookup transient-map k lookup-sentinel) lookup-sentinel) + not-found + k))) + +(deftype PersistentTreeSet [meta tree-map ^:mutable __hash] + Object + (toString [coll] + (pr-str* coll)) + (equiv [this other] + (-equiv this other)) + + ;; EXPERIMENTAL: subject to change + (keys [coll] + (es6-iterator (seq coll))) + (entries [coll] + (es6-set-entries-iterator (seq coll))) + (values [coll] + (es6-iterator (seq coll))) + (has [coll k] + (contains? coll k)) + (forEach [coll f] + (doseq [[k v] coll] + (f v k))) + + ICloneable + (-clone [_] (PersistentTreeSet. meta tree-map __hash)) + + IWithMeta + (-with-meta [coll new-meta] + (if (identical? new-meta meta) + coll + (PersistentTreeSet. new-meta tree-map __hash))) + + IMeta + (-meta [coll] meta) + + ICollection + (-conj [coll o] + (PersistentTreeSet. meta (assoc tree-map o nil) nil)) + + IEmptyableCollection + (-empty [coll] (PersistentTreeSet. meta (-empty tree-map) 0)) + + IEquiv + (-equiv [coll other] + (and + (set? other) + (== (count coll) (count other)) + ^boolean + (try + (reduce-kv + #(or (contains? other %2) (reduced false)) + true tree-map) + (catch js/Error ex + false)))) + + IHash + (-hash [coll] (caching-hash coll hash-unordered-coll __hash)) + + ISeqable + (-seq [coll] (keys tree-map)) + + ISorted + (-sorted-seq [coll ascending?] + (map key (-sorted-seq tree-map ascending?))) + + (-sorted-seq-from [coll k ascending?] + (map key (-sorted-seq-from tree-map k ascending?))) + + (-entry-key [coll entry] entry) + + (-comparator [coll] (-comparator tree-map)) + + IReversible + (-rseq [coll] + (if (pos? (count tree-map)) + (map key (rseq tree-map)))) + + ICounted + (-count [coll] (count tree-map)) + + ILookup + (-lookup [coll v] + (-lookup coll v nil)) + (-lookup [coll v not-found] + (let [n (.entry-at tree-map v)] + (if-not (nil? n) + (.-key n) + not-found))) + + ISet + (-disjoin [coll v] + (PersistentTreeSet. meta (dissoc tree-map v) nil)) + + IFn + (-invoke [coll k] + (-lookup coll k)) + (-invoke [coll k not-found] + (-lookup coll k not-found))) + +(set! (.-EMPTY PersistentTreeSet) + (PersistentTreeSet. nil (.-EMPTY PersistentTreeMap) empty-unordered-hash)) + +(es6-iterable PersistentTreeSet) + +(defn set-from-indexed-seq [iseq] + (let [arr (.-arr iseq) + ret (areduce arr i ^not-native res (-as-transient #{}) + (-conj! res (aget arr i)))] + (-persistent! ^not-native ret))) + +(defn set + "Returns a set of the distinct elements of coll." + [coll] + (if (set? coll) + (with-meta coll nil) + (let [in (seq coll)] + (cond + (nil? in) #{} + + (and (instance? IndexedSeq in) (zero? (.-i in))) + (.createAsIfByAssoc PersistentHashSet (.-arr in)) + + :else + (loop [^not-native in in + ^not-native out (-as-transient #{})] + (if-not (nil? in) + (recur (next in) (-conj! out (-first in))) + (persistent! out))))))) + +(defn hash-set + "Returns a new hash set with supplied keys. Any equal keys are + handled as if by repeated uses of conj." + ([] #{}) + ([& keys] (set keys))) + +(defn sorted-set + "Returns a new sorted set with supplied keys." + ([& keys] + (reduce -conj (.-EMPTY PersistentTreeSet) keys))) + +(defn sorted-set-by + "Returns a new sorted set with supplied keys, using the supplied comparator." + ([comparator & keys] + (reduce -conj + (PersistentTreeSet. nil (sorted-map-by comparator) 0) + keys))) + +(defn replace + "Given a map of replacement pairs and a vector/collection, returns a + vector/seq with any elements = a key in smap replaced with the + corresponding val in smap. Returns a transducer when no collection + is provided." + ([smap] + (map #(if-let [e (find smap %)] (val e) %))) + ([smap coll] + (if (vector? coll) + (let [n (count coll)] + (reduce (fn [v i] + (if-let [e (find smap (nth v i))] + (assoc v i (second e)) + v)) + coll (take n (iterate inc 0)))) + (map #(if-let [e (find smap %)] (second e) %) coll)))) + +(defn distinct + "Returns a lazy sequence of the elements of coll with duplicates removed. + Returns a stateful transducer when no collection is provided." + ([] + (fn [rf] + (let [seen (volatile! #{})] + (fn + ([] (rf)) + ([result] (rf result)) + ([result input] + (if (contains? @seen input) + result + (do (vswap! seen conj input) + (rf result input)))))))) + ([coll] + (let [step (fn step [xs seen] + (lazy-seq + ((fn [[f :as xs] seen] + (when-let [s (seq xs)] + (if (contains? seen f) + (recur (rest s) seen) + (cons f (step (rest s) (conj seen f)))))) + xs seen)))] + (step coll #{})))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defn butlast + "Return a seq of all but the last item in coll, in linear time" + [s] + (loop [ret [] s s] + (if (next s) + (recur (conj ret (first s)) (next s)) + (seq ret)))) + +(defn name + "Returns the name String of a string, symbol or keyword." + [x] + (if (implements? INamed x) + (-name x) + (if (string? x) + x + (throw (js/Error. (str "Doesn't support name: " x)))))) + +(defn zipmap + "Returns a map with the keys mapped to the corresponding vals." + [keys vals] + (loop [map (transient {}) + ks (seq keys) + vs (seq vals)] + (if (and ks vs) + (recur (assoc! map (first ks) (first vs)) + (next ks) + (next vs)) + (persistent! map)))) + +(defn max-key + "Returns the x for which (k x), a number, is greatest. + + If there are multiple such xs, the last one is returned." + ([k x] x) + ([k x y] (if (> (k x) (k y)) x y)) + ([k x y & more] + (reduce #(max-key k %1 %2) (max-key k x y) more))) + +(defn min-key + "Returns the x for which (k x), a number, is least. + + If there are multiple such xs, the last one is returned." + ([k x] x) + ([k x y] (if (< (k x) (k y)) x y)) + ([k x y & more] + (reduce #(min-key k %1 %2) (min-key k x y) more))) + +(deftype ArrayList [^:mutable arr] + Object + (add [_ x] (.push arr x)) + (size [_] (alength arr)) + (clear [_] (set! arr (array))) + (isEmpty [_] (zero? (alength arr))) + (toArray [_] arr)) + +(defn array-list [] + (ArrayList. (array))) + +(defn partition-all + "Returns a lazy sequence of lists like partition, but may include + partitions with fewer than n items at the end. Returns a stateful + transducer when no collection is provided." + ([n] + (fn [rf] + (let [a (array-list)] + (fn + ([] (rf)) + ([result] + (let [result (if (.isEmpty a) + result + (let [v (vec (.toArray a))] + ;;clear first! + (.clear a) + (unreduced (rf result v))))] + (rf result))) + ([result input] + (.add a input) + (if (== n (.size a)) + (let [v (vec (.toArray a))] + (.clear a) + (rf result v)) + result)))))) + ([n coll] + (partition-all n n coll)) + ([n step coll] + (lazy-seq + (when-let [s (seq coll)] + (cons (take n s) (partition-all n step (drop step s))))))) + +(defn take-while + "Returns a lazy sequence of successive items from coll while + (pred item) returns logical true. pred must be free of side-effects. + Returns a transducer when no collection is provided." + ([pred] + (fn [rf] + (fn + ([] (rf)) + ([result] (rf result)) + ([result input] + (if (pred input) + (rf result input) + (reduced result)))))) + ([pred coll] + (lazy-seq + (when-let [s (seq coll)] + (when (pred (first s)) + (cons (first s) (take-while pred (rest s)))))))) + +(defn mk-bound-fn + [sc test key] + (fn [e] + (let [comp (-comparator sc)] + (test (comp (-entry-key sc e) key) 0)))) + +(defn subseq + "sc must be a sorted collection, test(s) one of <, <=, > or + >=. Returns a seq of those entries with keys ek for + which (test (.. sc comparator (compare ek key)) 0) is true" + ([sc test key] + (let [include (mk-bound-fn sc test key)] + (if (#{> >=} test) + (when-let [[e :as s] (-sorted-seq-from sc key true)] + (if (include e) s (next s))) + (take-while include (-sorted-seq sc true))))) + ([sc start-test start-key end-test end-key] + (when-let [[e :as s] (-sorted-seq-from sc start-key true)] + (take-while (mk-bound-fn sc end-test end-key) + (if ((mk-bound-fn sc start-test start-key) e) s (next s)))))) + +(defn rsubseq + "sc must be a sorted collection, test(s) one of <, <=, > or + >=. Returns a reverse seq of those entries with keys ek for + which (test (.. sc comparator (compare ek key)) 0) is true" + ([sc test key] + (let [include (mk-bound-fn sc test key)] + (if (#{< <=} test) + (when-let [[e :as s] (-sorted-seq-from sc key false)] + (if (include e) s (next s))) + (take-while include (-sorted-seq sc false))))) + ([sc start-test start-key end-test end-key] + (when-let [[e :as s] (-sorted-seq-from sc end-key false)] + (take-while (mk-bound-fn sc start-test start-key) + (if ((mk-bound-fn sc end-test end-key) e) s (next s)))))) + +(deftype IntegerRangeChunk [start step count] + ICounted + (-count [coll] count) + + ISeq + (-first [coll] start) + + IIndexed + (-nth [coll i] + (+ start (* i step))) + (-nth [coll i not-found] + (if (and (>= i 0) (< i count)) + (+ start (* i step)) + not-found)) + + IChunk + (-drop-first [coll] + (if (<= count 1) + (throw (js/Error. "-drop-first of empty chunk")) + (IntegerRangeChunk. (+ start step) step (dec count))))) + +(deftype RangeIterator [^:mutable i end step] + Object + (hasNext [_] + (if (pos? step) + (< i end) + (> i end))) + (next [_] + (let [ret i] + (set! i (+ i step)) + ret))) + +(deftype IntegerRange [meta start end step ^:mutable chunk ^:mutable chunk-next ^:mutable __hash] + Object + (toString [coll] + (pr-str* coll)) + (equiv [this other] + (-equiv this other)) + (indexOf [coll x] + (-indexOf coll x 0)) + (indexOf [coll x start] + (-indexOf coll x start)) + (lastIndexOf [coll x] + (-lastIndexOf coll x (count coll))) + (lastIndexOf [coll x start] + (-lastIndexOf coll x start)) + (forceChunk [coll] + (when (nil? chunk) + (let [count (-count coll)] + (if (> count 32) + (do + (set! chunk-next (IntegerRange. nil (+ start (* step 32)) end step nil nil nil)) + (set! chunk (IntegerRangeChunk. start step 32))) + (set! chunk (IntegerRangeChunk. start step count)))))) + + ICloneable + (-clone [_] (IntegerRange. meta start end step chunk chunk-next __hash)) + + IWithMeta + (-with-meta [rng new-meta] + (if (identical? new-meta meta) + rng + (IntegerRange. new-meta start end step chunk chunk-next __hash))) + + IMeta + (-meta [rng] meta) + + ISeqable + (-seq [rng] rng) + + ISeq + (-first [rng] start) + (-rest [rng] + (let [s (-next rng)] + (if (nil? s) + () + s))) + + IIterable + (-iterator [_] + (RangeIterator. start end step)) + + INext + (-next [rng] + (if (pos? step) + (when (< (+ start step) end) + (IntegerRange. nil (+ start step) end step nil nil nil)) + (when (> (+ start step) end) + (IntegerRange. nil (+ start step) end step nil nil nil)))) + + IChunkedSeq + (-chunked-first [rng] + (.forceChunk rng) + chunk) + (-chunked-rest [rng] + (.forceChunk rng) + (if (nil? chunk-next) + () + chunk-next)) + + IChunkedNext + (-chunked-next [rng] + (seq (-chunked-rest rng))) + + ICollection + (-conj [rng o] (cons o rng)) + + IEmptyableCollection + (-empty [rng] (.-EMPTY List)) + + ISequential + IEquiv + (-equiv [rng other] (equiv-sequential rng other)) + + IHash + (-hash [rng] (caching-hash rng hash-ordered-coll __hash)) + + ICounted + (-count [rng] + (Math/ceil (/ (- end start) step))) + + IIndexed + (-nth [rng n] + (if (and (<= 0 n) (< n (-count rng))) + (+ start (* n step)) + (if (and (<= 0 n) (> start end) (zero? step)) + start + (throw (js/Error. "Index out of bounds"))))) + (-nth [rng n not-found] + (if (and (<= 0 n) (< n (-count rng))) + (+ start (* n step)) + (if (and (<= 0 n) (> start end) (zero? step)) + start + not-found))) + + IReduce + (-reduce [rng f] (ci-reduce rng f)) + (-reduce [rng f init] + (loop [i start ret init] + (if (if (pos? step) (< i end) (> i end)) + (let [ret (f ret i)] + (if (reduced? ret) + @ret + (recur (+ i step) ret))) + ret)))) + +(es6-iterable IntegerRange) + +(deftype Range [meta start end step ^:mutable chunk ^:mutable chunk-next ^:mutable __hash] + Object + (toString [coll] + (pr-str* coll)) + (equiv [this other] + (-equiv this other)) + (indexOf [coll x] + (-indexOf coll x 0)) + (indexOf [coll x start] + (-indexOf coll x start)) + (lastIndexOf [coll x] + (-lastIndexOf coll x (count coll))) + (lastIndexOf [coll x start] + (-lastIndexOf coll x start)) + (forceChunk [coll] + (when (nil? chunk) + (let [arr (make-array 32) + val (loop [n 0 val start] + (if (< n 32) + (do + (aset arr n val) + (let [n (inc n) + val (+ val step)] + (if (if (pos? step) (< val end) (> val end)) + (recur n val) + (set! chunk (array-chunk arr 0 n))))) + val))] + (when (nil? chunk) + (set! chunk (array-chunk arr 0 32)) + (when (if (pos? step) (< val end) (> val end)) + (set! chunk-next (Range. nil val end step nil nil nil))))))) + + ICloneable + (-clone [_] (Range. meta start end step chunk chunk-next __hash)) + + IWithMeta + (-with-meta [rng new-meta] + (if (identical? new-meta meta) + rng + (Range. new-meta start end step chunk chunk-next __hash))) + + IMeta + (-meta [rng] meta) + + ISeqable + (-seq [rng] rng) + + ISeq + (-first [rng] start) + (-rest [rng] + (let [s (-next rng)] + (if (nil? s) + () + s))) + + IIterable + (-iterator [_] + (RangeIterator. start end step)) + + INext + (-next [rng] + (if (pos? step) + (when (< (+ start step) end) + (Range. nil (+ start step) end step nil nil nil)) + (when (> (+ start step) end) + (Range. nil (+ start step) end step nil nil nil)))) + + IChunkedSeq + (-chunked-first [rng] + (.forceChunk rng) + chunk) + (-chunked-rest [rng] + (.forceChunk rng) + (if (nil? chunk-next) + () + chunk-next)) + + IChunkedNext + (-chunked-next [rng] + (seq (-chunked-rest rng))) + + ICollection + (-conj [rng o] (cons o rng)) + + IEmptyableCollection + (-empty [rng] (.-EMPTY List)) + + ISequential + IEquiv + (-equiv [rng other] (equiv-sequential rng other)) + + IHash + (-hash [rng] (caching-hash rng hash-ordered-coll __hash)) + + IReduce + (-reduce [rng f] (seq-reduce f rng)) + (-reduce [rng f init] + (loop [i start ret init] + (if (if (pos? step) (< i end) (> i end)) + (let [ret (f ret i)] + (if (reduced? ret) + @ret + (recur (+ i step) ret))) + ret)))) + +(es6-iterable Range) + +(defn range + "Returns a lazy seq of nums from start (inclusive) to end + (exclusive), by step, where start defaults to 0, step to 1, + and end to infinity." + ([] (range 0 (.-MAX_VALUE js/Number) 1)) + ([end] (range 0 end 1)) + ([start end] (range start end 1)) + ([start end step] + (cond + (pos? step) + (if (<= end start) + () + (if (and (integer? start) (integer? end) (integer? step)) + (IntegerRange. nil start end step nil nil nil) + (Range. nil start end step nil nil nil))) + + (neg? step) + (if (>= end start) + () + (if (and (integer? start) (integer? end) (integer? step)) + (IntegerRange. nil start end step nil nil nil) + (Range. nil start end step nil nil nil))) + + :else + (if (== end start) + () + (repeat start))))) + +(defn take-nth + "Returns a lazy seq of every nth item in coll. Returns a stateful + transducer when no collection is provided." + ([n] + {:pre [(number? n)]} + (fn [rf] + (let [ia (volatile! -1)] + (fn + ([] (rf)) + ([result] (rf result)) + ([result input] + (let [i (vswap! ia inc)] + (if (zero? (rem i n)) + (rf result input) + result))))))) + ([n coll] + {:pre [(number? n)]} + (lazy-seq + (when-let [s (seq coll)] + (cons (first s) (take-nth n (drop n s))))))) + +(defn split-with + "Returns a vector of [(take-while pred coll) (drop-while pred coll)]" + [pred coll] + [(take-while pred coll) (drop-while pred coll)]) + +(defn partition-by + "Applies f to each value in coll, splitting it each time f returns a + new value. Returns a lazy seq of partitions. Returns a stateful + transducer when no collection is provided." + ([f] + (fn [rf] + (let [a (array-list) + pa (volatile! ::none)] + (fn + ([] (rf)) + ([result] + (let [result (if (.isEmpty a) + result + (let [v (vec (.toArray a))] + ;;clear first! + (.clear a) + (unreduced (rf result v))))] + (rf result))) + ([result input] + (let [pval @pa + val (f input)] + (vreset! pa val) + (if (or (keyword-identical? pval ::none) + (= val pval)) + (do + (.add a input) + result) + (let [v (vec (.toArray a))] + (.clear a) + (let [ret (rf result v)] + (when-not (reduced? ret) + (.add a input)) + ret))))))))) + ([f coll] + (lazy-seq + (when-let [s (seq coll)] + (let [fst (first s) + fv (f fst) + run (cons fst (take-while #(= fv (f %)) (next s)))] + (cons run (partition-by f (lazy-seq (drop (count run) s))))))))) + +(defn frequencies + "Returns a map from distinct items in coll to the number of times + they appear." + [coll] + (persistent! + (reduce (fn [counts x] + (assoc! counts x (inc (get counts x 0)))) + (transient {}) coll))) + +(defn reductions + "Returns a lazy seq of the intermediate values of the reduction (as + per reduce) of coll by f, starting with init." + ([f coll] + (lazy-seq + (if-let [s (seq coll)] + (reductions f (first s) (rest s)) + (list (f))))) + ([f init coll] + (if (reduced? init) + (list @init) + (cons init + (lazy-seq + (when-let [s (seq coll)] + (reductions f (f init (first s)) (rest s)))))))) + +(defn juxt + "Takes a set of functions and returns a fn that is the juxtaposition + of those fns. The returned fn takes a variable number of args, and + returns a vector containing the result of applying each fn to the + args (left-to-right). + ((juxt a b c) x) => [(a x) (b x) (c x)]" + ([f] + (fn + ([] (vector (f))) + ([x] (vector (f x))) + ([x y] (vector (f x y))) + ([x y z] (vector (f x y z))) + ([x y z & args] (vector (apply f x y z args))))) + ([f g] + (fn + ([] (vector (f) (g))) + ([x] (vector (f x) (g x))) + ([x y] (vector (f x y) (g x y))) + ([x y z] (vector (f x y z) (g x y z))) + ([x y z & args] (vector (apply f x y z args) (apply g x y z args))))) + ([f g h] + (fn + ([] (vector (f) (g) (h))) + ([x] (vector (f x) (g x) (h x))) + ([x y] (vector (f x y) (g x y) (h x y))) + ([x y z] (vector (f x y z) (g x y z) (h x y z))) + ([x y z & args] (vector (apply f x y z args) (apply g x y z args) (apply h x y z args))))) + ([f g h & fs] + (let [fs (list* f g h fs)] + (fn + ([] (reduce #(conj %1 (%2)) [] fs)) + ([x] (reduce #(conj %1 (%2 x)) [] fs)) + ([x y] (reduce #(conj %1 (%2 x y)) [] fs)) + ([x y z] (reduce #(conj %1 (%2 x y z)) [] fs)) + ([x y z & args] (reduce #(conj %1 (apply %2 x y z args)) [] fs)))))) + +(defn dorun + "When lazy sequences are produced via functions that have side + effects, any effects other than those needed to produce the first + element in the seq do not occur until the seq is consumed. dorun can + be used to force any effects. Walks through the successive nexts of + the seq, does not retain the head and returns nil." + ([coll] + (when-let [s (seq coll)] + (recur (next s)))) + ([n coll] + (when (and (seq coll) (pos? n)) + (recur (dec n) (next coll))))) + +(defn doall + "When lazy sequences are produced via functions that have side + effects, any effects other than those needed to produce the first + element in the seq do not occur until the seq is consumed. doall can + be used to force any effects. Walks through the successive nexts of + the seq, retains the head and returns it, thus causing the entire + seq to reside in memory at one time." + ([coll] + (dorun coll) + coll) + ([n coll] + (dorun n coll) + coll)) + +;;;;;;;;;;;;;;;;;;;;;;;;; Regular Expressions ;;;;;;;;;; + +(defn regexp? + "Returns true if x is a JavaScript RegExp instance." + [x] + (instance? js/RegExp x)) + +(defn re-matches + "Returns the result of (re-find re s) if re fully matches s." + [re s] + (if (string? s) + (let [matches (.exec re s)] + (when (and (not (nil? matches)) + (= (aget matches 0) s)) + (if (== (count ^array matches) 1) + (aget matches 0) + (vec matches)))) + (throw (js/TypeError. "re-matches must match against a string.")))) + + +(defn re-find + "Returns the first regex match, if any, of s to re, using + re.exec(s). Returns a vector, containing first the matching + substring, then any capturing groups if the regular expression contains + capturing groups." + [re s] + (if (string? s) + (let [matches (.exec re s)] + (when-not (nil? matches) + (if (== (count ^array matches) 1) + (aget matches 0) + (vec matches)))) + (throw (js/TypeError. "re-find must match against a string.")))) + +(defn- re-seq* [re s] + (when-some [matches (.exec re s)] + (let [match-str (aget matches 0) + match-vals (if (== (.-length matches) 1) + match-str + (vec matches))] + (cons match-vals + (lazy-seq + (let [post-idx (+ (.-index matches) + (max 1 (.-length match-str)))] + (when (<= post-idx (.-length s)) + (re-seq* re (subs s post-idx))))))))) + +(defn re-seq + "Returns a lazy sequence of successive matches of re in s." + [re s] + (if (string? s) + (re-seq* re s) + (throw (js/TypeError. "re-seq must match against a string.")))) + +(defn re-pattern + "Returns an instance of RegExp which has compiled the provided string." + [s] + (if (instance? js/RegExp s) + s + (let [[prefix flags] (re-find #"^\(\?([idmsux]*)\)" s) + pattern (subs s (if (nil? prefix) + 0 + (count ^string prefix)))] + (js/RegExp. pattern (or flags ""))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Printing ;;;;;;;;;;;;;;;; + +(defn pr-sequential-writer [writer print-one begin sep end opts coll] + (binding [*print-level* (when-not (nil? *print-level*) (dec *print-level*))] + (if (and (not (nil? *print-level*)) (neg? *print-level*)) + (-write writer "#") + (do + (-write writer begin) + (if (zero? (:print-length opts)) + (when (seq coll) + (-write writer (or (:more-marker opts) "..."))) + (do + (when (seq coll) + (print-one (first coll) writer opts)) + (loop [coll (next coll) n (dec (:print-length opts))] + (if (and coll (or (nil? n) (not (zero? n)))) + (do + (-write writer sep) + (print-one (first coll) writer opts) + (recur (next coll) (dec n))) + (when (and (seq coll) (zero? n)) + (-write writer sep) + (-write writer (or (:more-marker opts) "..."))))))) + (-write writer end))))) + +(defn write-all [writer & ss] + (doseq [s ss] + (-write writer s))) + +(defn string-print [x] + (when (nil? *print-fn*) + (throw (js/Error. "No *print-fn* fn set for evaluation environment"))) + (*print-fn* x) + nil) + +(defn flush [] ;stub + nil) + +(def ^:private char-escapes + (js-obj + "\"" "\\\"" + "\\" "\\\\" + "\b" "\\b" + "\f" "\\f" + "\n" "\\n" + "\r" "\\r" + "\t" "\\t")) + +(defn ^:private quote-string + [s] + (str \" + (.replace s (js/RegExp "[\\\\\"\b\f\n\r\t]" "g") + (fn [match] (unchecked-get char-escapes match))) + \")) + +(declare print-map) + +(defn print-meta? [opts obj] + (and (boolean (get opts :meta)) + (implements? IMeta obj) + (not (nil? (meta obj))))) + +(defn- pr-writer-impl + [obj writer opts] + (cond + (nil? obj) (-write writer "nil") + :else + (do + (when (print-meta? opts obj) + (-write writer "^") + (pr-writer (meta obj) writer opts) + (-write writer " ")) + (cond + ;; handle CLJS ctors + ^boolean (.-cljs$lang$type obj) + (.cljs$lang$ctorPrWriter obj obj writer opts) + + ; Use the new, more efficient, IPrintWithWriter interface when possible. + (satisfies? IPrintWithWriter obj) + (-pr-writer obj writer opts) + + (or (true? obj) (false? obj)) + (-write writer (str obj)) + + (number? obj) + (-write writer + (cond + ^boolean (js/isNaN obj) "##NaN" + (identical? obj js/Number.POSITIVE_INFINITY) "##Inf" + (identical? obj js/Number.NEGATIVE_INFINITY) "##-Inf" + :else (str obj))) + + (object? obj) + (do + (-write writer "#js ") + (print-map + (map (fn [k] + (MapEntry. (cond-> k (some? (re-matches #"[A-Za-z_\*\+\?!\-'][\w\*\+\?!\-']*" k)) keyword) (unchecked-get obj k) nil)) + (js-keys obj)) + pr-writer writer opts)) + + (array? obj) + (pr-sequential-writer writer pr-writer "#js [" " " "]" opts obj) + + ^boolean (goog/isString obj) + (if (:readably opts) + (-write writer (quote-string obj)) + (-write writer obj)) + + ^boolean (goog/isFunction obj) + (let [name (.-name obj) + name (if (or (nil? name) (gstring/isEmpty name)) + "Function" + name)] + (write-all writer "#object[" name + (if *print-fn-bodies* + (str " \"" (str obj) "\"") + "") + "]")) + + (instance? js/Date obj) + (let [normalize (fn [n len] + (loop [ns (str n)] + (if (< (count ns) len) + (recur (str "0" ns)) + ns)))] + (write-all writer + "#inst \"" + (normalize (.getUTCFullYear obj) 4) "-" + (normalize (inc (.getUTCMonth obj)) 2) "-" + (normalize (.getUTCDate obj) 2) "T" + (normalize (.getUTCHours obj) 2) ":" + (normalize (.getUTCMinutes obj) 2) ":" + (normalize (.getUTCSeconds obj) 2) "." + (normalize (.getUTCMilliseconds obj) 3) "-" + "00:00\"")) + + (regexp? obj) (write-all writer "#\"" (.-source obj) "\"") + + (js-symbol? obj) (write-all writer "#object[" (.toString obj) "]" ) + + :else + (if (some-> obj .-constructor .-cljs$lang$ctorStr) + (write-all writer + "#object[" (.replace (.. obj -constructor -cljs$lang$ctorStr) + (js/RegExp. "/" "g") ".") "]") + (let [name (some-> obj .-constructor .-name) + name (if (or (nil? name) (gstring/isEmpty name)) + "Object" + name)] + (if (nil? (. obj -constructor)) + (write-all writer "#object[" name "]") + (write-all writer "#object[" name " " (str obj) "]")))))))) + +(defn- pr-writer + "Prefer this to pr-seq, because it makes the printing function + configurable, allowing efficient implementations such as appending + to a StringBuffer." + [obj writer opts] + (if-let [alt-impl (:alt-impl opts)] + (alt-impl obj writer (assoc opts :fallback-impl pr-writer-impl)) + (pr-writer-impl obj writer opts))) + +(defn pr-seq-writer [objs writer opts] + (pr-writer (first objs) writer opts) + (doseq [obj (next objs)] + (-write writer " ") + (pr-writer obj writer opts))) + +(defn- pr-sb-with-opts [objs opts] + (let [sb (StringBuffer.) + writer (StringBufferWriter. sb)] + (pr-seq-writer objs writer opts) + (-flush writer) + sb)) + +(defn pr-str-with-opts + "Prints a sequence of objects to a string, observing all the + options given in opts" + [objs opts] + (if (empty? objs) + "" + (str (pr-sb-with-opts objs opts)))) + +(defn prn-str-with-opts + "Same as pr-str-with-opts followed by (newline)" + [objs opts] + (if (empty? objs) + "\n" + (let [sb (pr-sb-with-opts objs opts)] + (.append sb \newline) + (str sb)))) + +(defn- pr-with-opts + "Prints a sequence of objects using string-print, observing all + the options given in opts" + [objs opts] + (string-print (pr-str-with-opts objs opts))) + +(defn newline + "Prints a newline using *print-fn*" + ([] (newline nil)) + ([opts] + (string-print "\n") + (when (get opts :flush-on-newline) + (flush)))) + +(defn pr-str + "pr to a string, returning it. Fundamental entrypoint to IPrintWithWriter." + [& objs] + (pr-str-with-opts objs (pr-opts))) + +(defn prn-str + "Same as pr-str followed by (newline)" + [& objs] + (prn-str-with-opts objs (pr-opts))) + +(defn pr + "Prints the object(s) using string-print. Prints the + object(s), separated by spaces if there is more than one. + By default, pr and prn print in a way that objects can be + read by the reader" + [& objs] + (pr-with-opts objs (pr-opts))) + +(def ^{:doc + "Prints the object(s) using string-print. + print and println produce output for human consumption."} + print + (fn cljs-core-print [& objs] + (pr-with-opts objs (assoc (pr-opts) :readably false)))) + +(defn print-str + "print to a string, returning it" + [& objs] + (pr-str-with-opts objs (assoc (pr-opts) :readably false))) + +(defn println + "Same as print followed by (newline)" + [& objs] + (pr-with-opts objs (assoc (pr-opts) :readably false)) + (when *print-newline* + (newline (pr-opts)))) + +(defn println-str + "println to a string, returning it" + [& objs] + (prn-str-with-opts objs (assoc (pr-opts) :readably false))) + +(defn prn + "Same as pr followed by (newline)." + [& objs] + (pr-with-opts objs (pr-opts)) + (when *print-newline* + (newline (pr-opts)))) + +(defn- strip-ns + [named] + (if (symbol? named) + (symbol nil (name named)) + (keyword nil (name named)))) + +(defn- lift-ns + "Returns [lifted-ns lifted-map] or nil if m can't be lifted." + [m] + (when *print-namespace-maps* + (loop [ns nil + [[k v :as entry] & entries] (seq m) + lm (empty m)] + (if entry + (when (or (keyword? k) (symbol? k)) + (if ns + (when (= ns (namespace k)) + (recur ns entries (assoc lm (strip-ns k) v))) + (when-let [new-ns (namespace k)] + (recur new-ns entries (assoc lm (strip-ns k) v))))) + [ns lm])))) + +(defn print-prefix-map [prefix m print-one writer opts] + (pr-sequential-writer + writer + (fn [e w opts] + (do (print-one (key e) w opts) + (-write w \space) + (print-one (val e) w opts))) + (str prefix "{") ", " "}" + opts (seq m))) + +(defn print-map [m print-one writer opts] + (let [[ns lift-map] (when (map? m) + (lift-ns m))] + (if ns + (print-prefix-map (str "#:" ns) lift-map print-one writer opts) + (print-prefix-map nil m print-one writer opts)))) + +(extend-protocol IPrintWithWriter + LazySeq + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) + + TransformerIterator + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) + + IndexedSeq + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) + + RSeq + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) + + PersistentQueue + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "#queue [" " " "]" opts (seq coll))) + + PersistentQueueSeq + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) + + PersistentTreeMapSeq + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) + + NodeSeq + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) + + ArrayNodeSeq + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) + + List + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) + + Cons + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) + + EmptyList + (-pr-writer [coll writer opts] (-write writer "()")) + + PersistentVector + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "[" " " "]" opts coll)) + + ChunkedCons + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) + + ChunkedSeq + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) + + Subvec + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "[" " " "]" opts coll)) + + BlackNode + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "[" " " "]" opts coll)) + + RedNode + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "[" " " "]" opts coll)) + + MapEntry + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "[" " " "]" opts coll)) + + ObjMap + (-pr-writer [coll writer opts] + (print-map coll pr-writer writer opts)) + + KeySeq + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) + + ValSeq + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) + + PersistentArrayMapSeq + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) + + PersistentArrayMap + (-pr-writer [coll writer opts] + (print-map coll pr-writer writer opts)) + + PersistentHashMap + (-pr-writer [coll writer opts] + (print-map coll pr-writer writer opts)) + + PersistentTreeMap + (-pr-writer [coll writer opts] + (print-map coll pr-writer writer opts)) + + PersistentHashSet + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "#{" " " "}" opts coll)) + + PersistentTreeSet + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "#{" " " "}" opts coll)) + + Range + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) + + IntegerRange + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) + + Cycle + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) + + Repeat + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) + + Iterate + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) + + ES6IteratorSeq + (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "(" " " ")" opts coll)) + + Atom + (-pr-writer [a writer opts] + (-write writer "#object[cljs.core.Atom ") + (pr-writer {:val (.-state a)} writer opts) + (-write writer "]")) + + Volatile + (-pr-writer [a writer opts] + (-write writer "#object[cljs.core.Volatile ") + (pr-writer {:val (.-state a)} writer opts) + (-write writer "]")) + + Var + (-pr-writer [a writer opts] + (-write writer "#'") + (pr-writer (.-sym a) writer opts))) + +;; IComparable +(extend-protocol IComparable + Symbol + (-compare [x y] + (if (symbol? y) + (compare-symbols x y) + (throw (js/Error. (str "Cannot compare " x " to " y))))) + + Keyword + (-compare [x y] + (if (keyword? y) + (compare-keywords x y) + (throw (js/Error. (str "Cannot compare " x " to " y))))) + + Subvec + (-compare [x y] + (if (vector? y) + (compare-indexed x y) + (throw (js/Error. (str "Cannot compare " x " to " y))))) + + PersistentVector + (-compare [x y] + (if (vector? y) + (compare-indexed x y) + (throw (js/Error. (str "Cannot compare " x " to " y))))) + + MapEntry + (-compare [x y] + (if (vector? y) + (compare-indexed x y) + (throw (js/Error. (str "Cannot compare " x " to " y))))) + + BlackNode + (-compare [x y] + (if (vector? y) + (compare-indexed x y) + (throw (js/Error. (str "Cannot compare " x " to " y))))) + + RedNode + (-compare [x y] + (if (vector? y) + (compare-indexed x y) + (throw (js/Error. (str "Cannot compare " x " to " y)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Reference Types ;;;;;;;;;;;;;;;; + +(defn alter-meta! + "Atomically sets the metadata for a namespace/var/ref/agent/atom to be: + + (apply f its-current-meta args) + + f must be free of side-effects" + [iref f & args] + (set! (.-meta iref) (apply f (.-meta iref) args))) + +(defn reset-meta! + "Atomically resets the metadata for an atom" + [iref m] + (set! (.-meta iref) m)) + +(defn add-watch + "Adds a watch function to an atom reference. The watch fn must be a + fn of 4 args: a key, the reference, its old-state, its + new-state. Whenever the reference's state might have been changed, + any registered watches will have their functions called. The watch + fn will be called synchronously. Note that an atom's state + may have changed again prior to the fn call, so use old/new-state + rather than derefing the reference. Keys must be unique per + reference, and can be used to remove the watch with remove-watch, + but are otherwise considered opaque by the watch mechanism. Bear in + mind that regardless of the result or action of the watch fns the + atom's value will change. Example: + + (def a (atom 0)) + (add-watch a :inc (fn [k r o n] (assert (== 0 n)))) + (swap! a inc) + ;; Assertion Error + (deref a) + ;=> 1" + [iref key f] + (-add-watch iref key f) + iref) + +(defn remove-watch + "Removes a watch (set by add-watch) from a reference" + [iref key] + (-remove-watch iref key) + iref) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; gensym ;;;;;;;;;;;;;;;; +;; Internal - do not use! +(def + ^{:jsdoc ["@type {*}"]} + gensym_counter nil) + +(defn gensym + "Returns a new symbol with a unique name. If a prefix string is + supplied, the name is prefix# where # is some unique number. If + prefix is not supplied, the prefix is 'G__'." + ([] (gensym "G__")) + ([prefix-string] + (when (nil? gensym_counter) + (set! gensym_counter (atom 0))) + (symbol (str prefix-string (swap! gensym_counter inc))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Delay ;;;;;;;;;;;;;;;;;;;; + +(deftype Delay [^:mutable f ^:mutable value] + IDeref + (-deref [_] + (when f + (set! value (f)) + (set! f nil)) + value) + + IPending + (-realized? [x] + (not f)) + + IPrintWithWriter + (-pr-writer [x writer opts] + (-write writer "#object[cljs.core.Delay ") + (pr-writer {:status (if (nil? f) :ready :pending), :val value} writer opts) + (-write writer "]"))) + +(defn delay? + "returns true if x is a Delay created with delay" + [x] (instance? Delay x)) + +(defn force + "If x is a Delay, returns the (possibly cached) value of its expression, else returns x" + [x] + (if (delay? x) + (deref x) + x)) + +(defn ^boolean realized? + "Returns true if a value has been produced for a delay or lazy sequence." + [x] + (-realized? x)) + +(defn- preserving-reduced + [rf] + #(let [ret (rf %1 %2)] + (if (reduced? ret) + (reduced ret) + ret))) + +(defn cat + "A transducer which concatenates the contents of each input, which must be a + collection, into the reduction." + {:added "1.7"} + [rf] + (let [rf1 (preserving-reduced rf)] + (fn + ([] (rf)) + ([result] (rf result)) + ([result input] + (reduce rf1 result input))))) + +(defn halt-when + "Returns a transducer that ends transduction when pred returns true + for an input. When retf is supplied it must be a fn of 2 arguments - + it will be passed the (completed) result so far and the input that + triggered the predicate, and its return value (if it does not throw + an exception) will be the return value of the transducer. If retf + is not supplied, the input that triggered the predicate will be + returned. If the predicate never returns true the transduction is + unaffected." + {:added "1.9"} + ([pred] (halt-when pred nil)) + ([pred retf] + (fn [rf] + (fn + ([] (rf)) + ([result] + (if (and (map? result) (contains? result ::halt)) + (::halt result) + (rf result))) + ([result input] + (if (pred input) + (reduced {::halt (if retf (retf (rf result) input) input)}) + (rf result input))))))) + +(defn dedupe + "Returns a lazy sequence removing consecutive duplicates in coll. + Returns a transducer when no collection is provided." + ([] + (fn [rf] + (let [pa (volatile! ::none)] + (fn + ([] (rf)) + ([result] (rf result)) + ([result input] + (let [prior @pa] + (vreset! pa input) + (if (= prior input) + result + (rf result input)))))))) + ([coll] (sequence (dedupe) coll))) + +(declare rand) + +(defn random-sample + "Returns items from coll with random probability of prob (0.0 - + 1.0). Returns a transducer when no collection is provided." + ([prob] + (filter (fn [_] (< (rand) prob)))) + ([prob coll] + (filter (fn [_] (< (rand) prob)) coll))) + +(deftype Eduction [xform coll] + Object + (indexOf [coll x] + (-indexOf coll x 0)) + (indexOf [coll x start] + (-indexOf coll x start)) + (lastIndexOf [coll x] + (-lastIndexOf coll x (count coll))) + (lastIndexOf [coll x start] + (-lastIndexOf coll x start)) + + ISequential + + IIterable + (-iterator [_] + (.create TransformerIterator xform (iter coll))) + + ISeqable + (-seq [_] (seq (sequence xform coll))) + + IReduce + (-reduce [_ f] (transduce xform (completing f) coll)) + (-reduce [_ f init] (transduce xform (completing f) init coll)) + + IPrintWithWriter + (-pr-writer [coll writer opts] + (pr-sequential-writer writer pr-writer "(" " " ")" opts coll))) + +(es6-iterable Eduction) + +(defn eduction + "Returns a reducible/iterable application of the transducers + to the items in coll. Transducers are applied in order as if + combined with comp. Note that these applications will be + performed every time reduce/iterator is called." + {:arglists '([xform* coll])} + [& xforms] + (Eduction. (apply comp (butlast xforms)) (last xforms))) + +(defn run! + "Runs the supplied procedure (via reduce), for purposes of side + effects, on successive items in the collection. Returns nil" + [proc coll] + (reduce #(proc %2) nil coll) + nil) + +(defprotocol IEncodeJS + (-clj->js [x] "Recursively transforms clj values to JavaScript") + (-key->js [x] "Transforms map keys to valid JavaScript keys. Arbitrary keys are + encoded to their string representation via (pr-str x)")) + +(declare clj->js) + +(defn key->js + ([k] (key->js k clj->js)) + ([k primitive-fn] + (cond + (satisfies? IEncodeJS k) (-clj->js k) + (or (string? k) + (number? k) + (keyword? k) + (symbol? k)) (primitive-fn k) + :default (pr-str k)))) + +(defn clj->js + "Recursively transforms ClojureScript values to JavaScript. + sets/vectors/lists become Arrays, Keywords and Symbol become Strings, + Maps become Objects. Arbitrary keys are encoded to by `key->js`. + Options is a key-value pair, where the only valid key is + :keyword-fn, which should point to a single-argument function to be + called on keyword keys. Default to `name`." + [x & {:keys [keyword-fn] + :or {keyword-fn name} + :as options}] + (letfn [(keyfn [k] (key->js k thisfn)) + (thisfn [x] (cond + (nil? x) nil + (satisfies? IEncodeJS x) (-clj->js x) + (keyword? x) (keyword-fn x) + (symbol? x) (str x) + (map? x) (let [m (js-obj)] + (doseq [[k v] x] + (gobject/set m (keyfn k) (thisfn v))) + m) + (coll? x) (let [arr (array)] + (doseq [x (map thisfn x)] + (.push arr x)) + arr) + :else x))] + (thisfn x))) + + +(defprotocol IEncodeClojure + (-js->clj [x options] "Transforms JavaScript values to Clojure")) + +(defn js->clj + "Recursively transforms JavaScript arrays into ClojureScript + vectors, and JavaScript objects into ClojureScript maps. With + option ':keywordize-keys true' will convert object fields from + strings to keywords." + ([x] (js->clj x :keywordize-keys false)) + ([x & opts] + (let [{:keys [keywordize-keys]} opts + keyfn (if keywordize-keys keyword str) + f (fn thisfn [x] + (cond + (satisfies? IEncodeClojure x) + (-js->clj x (apply array-map opts)) + + (seq? x) + (doall (map thisfn x)) + + (map-entry? x) + (MapEntry. (thisfn (key x)) (thisfn (val x)) nil) + + (coll? x) + (into (empty x) (map thisfn) x) + + (array? x) + (persistent! + (reduce #(conj! %1 (thisfn %2)) + (transient []) x)) + + (identical? (type x) js/Object) + (persistent! + (reduce (fn [r k] (assoc! r (keyfn k) (thisfn (gobject/get x k)))) + (transient {}) (js-keys x))) + :else x))] + (f x)))) + +(defn memoize + "Returns a memoized version of a referentially transparent function. The + memoized version of the function keeps a cache of the mapping from arguments + to results and, when calls with the same arguments are repeated often, has + higher performance at the expense of higher memory use." + [f] + (let [mem (atom {})] + (fn [& args] + (let [v (get @mem args lookup-sentinel)] + (if (identical? v lookup-sentinel) + (let [ret (apply f args)] + (swap! mem assoc args ret) + ret) + v))))) + +(defn trampoline + "trampoline can be used to convert algorithms requiring mutual + recursion without stack consumption. Calls f with supplied args, if + any. If f returns a fn, calls that fn with no arguments, and + continues to repeat, until the return value is not a fn, then + returns that non-fn value. Note that if you want to return a fn as a + final value, you must wrap it in some data structure and unpack it + after trampoline returns." + ([f] + (let [ret (f)] + (if (fn? ret) + (recur ret) + ret))) + ([f & args] + (trampoline #(apply f args)))) + +(defn rand + "Returns a random floating point number between 0 (inclusive) and + n (default 1) (exclusive)." + ([] (rand 1)) + ([n] (* (Math/random) n))) + +(defn rand-int + "Returns a random integer between 0 (inclusive) and n (exclusive)." + [n] (Math/floor (* (Math/random) n))) + +(defn rand-nth + "Return a random element of the (sequential) collection. Will have + the same performance characteristics as nth for the given + collection." + [coll] + (nth coll (rand-int (count coll)))) + +(defn group-by + "Returns a map of the elements of coll keyed by the result of + f on each element. The value at each key will be a vector of the + corresponding elements, in the order they appeared in coll." + [f coll] + (persistent! + (reduce + (fn [ret x] + (let [k (f x)] + (assoc! ret k (conj (get ret k []) x)))) + (transient {}) coll))) + +(defn make-hierarchy + "Creates a hierarchy object for use with derive, isa? etc." + [] {:parents {} :descendants {} :ancestors {}}) + +(def + ^{:private true + :jsdoc ["@type {*}"]} + -global-hierarchy nil) + +(defn- get-global-hierarchy [] + (when (nil? -global-hierarchy) + (set! -global-hierarchy (atom (make-hierarchy)))) + -global-hierarchy) + +(defn- swap-global-hierarchy! [f & args] + (apply swap! (get-global-hierarchy) f args)) + +(defn ^boolean isa? + "Returns true if (= child parent), or child is directly or indirectly derived from + parent, either via a JavaScript type inheritance relationship or a + relationship established via derive. h must be a hierarchy obtained + from make-hierarchy, if not supplied defaults to the global + hierarchy" + ([child parent] (isa? @(get-global-hierarchy) child parent)) + ([h child parent] + (or (= child parent) + ;; (and (class? parent) (class? child) + ;; (. ^Class parent isAssignableFrom child)) + (contains? ((:ancestors h) child) parent) + ;;(and (class? child) (some #(contains? ((:ancestors h) %) parent) (supers child))) + (and (vector? parent) (vector? child) + (== (count parent) (count child)) + (loop [ret true i 0] + (if (or (not ret) (== i (count parent))) + ret + (recur (isa? h (child i) (parent i)) (inc i)))))))) + +(defn parents + "Returns the immediate parents of tag, either via a JavaScript type + inheritance relationship or a relationship established via derive. h + must be a hierarchy obtained from make-hierarchy, if not supplied + defaults to the global hierarchy" + ([tag] (parents @(get-global-hierarchy) tag)) + ([h tag] (not-empty (get (:parents h) tag)))) + +(defn ancestors + "Returns the immediate and indirect parents of tag, either via a JavaScript type + inheritance relationship or a relationship established via derive. h + must be a hierarchy obtained from make-hierarchy, if not supplied + defaults to the global hierarchy" + ([tag] (ancestors @(get-global-hierarchy) tag)) + ([h tag] (not-empty (get (:ancestors h) tag)))) + +(defn descendants + "Returns the immediate and indirect children of tag, through a + relationship established via derive. h must be a hierarchy obtained + from make-hierarchy, if not supplied defaults to the global + hierarchy. Note: does not work on JavaScript type inheritance + relationships." + ([tag] (descendants @(get-global-hierarchy) tag)) + ([h tag] (not-empty (get (:descendants h) tag)))) + +(defn derive + "Establishes a parent/child relationship between parent and + tag. Parent must be a namespace-qualified symbol or keyword and + child can be either a namespace-qualified symbol or keyword or a + class. h must be a hierarchy obtained from make-hierarchy, if not + supplied defaults to, and modifies, the global hierarchy." + ([tag parent] + (assert (namespace parent)) + ;; (assert (or (class? tag) (and (instance? cljs.core.Named tag) (namespace tag)))) + (swap-global-hierarchy! derive tag parent) nil) + ([h tag parent] + (assert (not= tag parent)) + ;; (assert (or (class? tag) (instance? clojure.lang.Named tag))) + ;; (assert (instance? clojure.lang.INamed tag)) + ;; (assert (instance? clojure.lang.INamed parent)) + (let [tp (:parents h) + td (:descendants h) + ta (:ancestors h) + tf (fn [m source sources target targets] + (reduce (fn [ret k] + (assoc ret k + (reduce conj (get targets k #{}) (cons target (targets target))))) + m (cons source (sources source))))] + (or + (when-not (contains? (tp tag) parent) + (when (contains? (ta tag) parent) + (throw (js/Error. (str tag "already has" parent "as ancestor")))) + (when (contains? (ta parent) tag) + (throw (js/Error. (str "Cyclic derivation:" parent "has" tag "as ancestor")))) + {:parents (assoc (:parents h) tag (conj (get tp tag #{}) parent)) + :ancestors (tf (:ancestors h) tag td parent ta) + :descendants (tf (:descendants h) parent ta tag td)}) + h)))) + +(defn underive + "Removes a parent/child relationship between parent and + tag. h must be a hierarchy obtained from make-hierarchy, if not + supplied defaults to, and modifies, the global hierarchy." + ([tag parent] + (swap-global-hierarchy! underive tag parent) + nil) + ([h tag parent] + (let [parentMap (:parents h) + childsParents (if (parentMap tag) + (disj (parentMap tag) parent) #{}) + newParents (if (not-empty childsParents) + (assoc parentMap tag childsParents) + (dissoc parentMap tag)) + deriv-seq (flatten (map #(cons (first %) (interpose (first %) (second %))) + (seq newParents)))] + (if (contains? (parentMap tag) parent) + (reduce #(apply derive %1 %2) (make-hierarchy) + (partition 2 deriv-seq)) + h)))) + +(defn- reset-cache + [method-cache method-table cached-hierarchy hierarchy] + (swap! method-cache (fn [_] (deref method-table))) + (swap! cached-hierarchy (fn [_] (deref hierarchy)))) + +(defn- prefers* + [x y prefer-table] + (let [xprefs (@prefer-table x)] + (or + (when (and xprefs (xprefs y)) + true) + (loop [ps (parents y)] + (when (pos? (count ps)) + (when (prefers* x (first ps) prefer-table) + true) + (recur (rest ps)))) + (loop [ps (parents x)] + (when (pos? (count ps)) + (when (prefers* (first ps) y prefer-table) + true) + (recur (rest ps)))) + false))) + +(defn- dominates + [x y prefer-table hierarchy] + (or (prefers* x y prefer-table) (isa? hierarchy x y))) + +(defn- find-and-cache-best-method + [name dispatch-val hierarchy method-table prefer-table method-cache cached-hierarchy default-dispatch-val] + (let [best-entry (reduce (fn [be [k _ :as e]] + (if (isa? @hierarchy dispatch-val k) + (let [be2 (if (or (nil? be) (dominates k (first be) prefer-table @hierarchy)) + e + be)] + (when-not (dominates (first be2) k prefer-table @hierarchy) + (throw (js/Error. + (str "Multiple methods in multimethod '" name + "' match dispatch value: " dispatch-val " -> " k + " and " (first be2) ", and neither is preferred")))) + be2) + be)) + nil @method-table) + best-entry (if-let [entry (and (nil? best-entry) (@method-table default-dispatch-val))] + [default-dispatch-val entry] + best-entry)] + (when best-entry + (if (= @cached-hierarchy @hierarchy) + (do + (swap! method-cache assoc dispatch-val (second best-entry)) + (second best-entry)) + (do + (reset-cache method-cache method-table cached-hierarchy hierarchy) + (find-and-cache-best-method name dispatch-val hierarchy method-table prefer-table + method-cache cached-hierarchy default-dispatch-val)))))) + +(defprotocol IMultiFn + (-reset [mf]) + (-add-method [mf dispatch-val method]) + (-remove-method [mf dispatch-val]) + (-prefer-method [mf dispatch-val dispatch-val-y]) + (-get-method [mf dispatch-val]) + (-methods [mf]) + (-prefers [mf]) + (-default-dispatch-val [mf]) + (-dispatch-fn [mf])) + +(defn- throw-no-method-error [name dispatch-val] + (throw (js/Error. (str "No method in multimethod '" name "' for dispatch value: " dispatch-val)))) + +(deftype MultiFn [name dispatch-fn default-dispatch-val hierarchy + method-table prefer-table method-cache cached-hierarchy] + IFn + (-invoke [mf] + (let [dispatch-val (dispatch-fn) + target-fn (-get-method mf dispatch-val)] + (when-not target-fn + (throw-no-method-error name dispatch-val)) + (target-fn))) + (-invoke [mf a] + (let [dispatch-val (dispatch-fn a) + target-fn (-get-method mf dispatch-val)] + (when-not target-fn + (throw-no-method-error name dispatch-val)) + (target-fn a))) + (-invoke [mf a b] + (let [dispatch-val (dispatch-fn a b) + target-fn (-get-method mf dispatch-val)] + (when-not target-fn + (throw-no-method-error name dispatch-val)) + (target-fn a b))) + (-invoke [mf a b c] + (let [dispatch-val (dispatch-fn a b c) + target-fn (-get-method mf dispatch-val)] + (when-not target-fn + (throw-no-method-error name dispatch-val)) + (target-fn a b c))) + (-invoke [mf a b c d] + (let [dispatch-val (dispatch-fn a b c d) + target-fn (-get-method mf dispatch-val)] + (when-not target-fn + (throw-no-method-error name dispatch-val)) + (target-fn a b c d))) + (-invoke [mf a b c d e] + (let [dispatch-val (dispatch-fn a b c d e) + target-fn (-get-method mf dispatch-val)] + (when-not target-fn + (throw-no-method-error name dispatch-val)) + (target-fn a b c d e))) + (-invoke [mf a b c d e f] + (let [dispatch-val (dispatch-fn a b c d e f) + target-fn (-get-method mf dispatch-val)] + (when-not target-fn + (throw-no-method-error name dispatch-val)) + (target-fn a b c d e f))) + (-invoke [mf a b c d e f g] + (let [dispatch-val (dispatch-fn a b c d e f g) + target-fn (-get-method mf dispatch-val)] + (when-not target-fn + (throw-no-method-error name dispatch-val)) + (target-fn a b c d e f g))) + (-invoke [mf a b c d e f g h] + (let [dispatch-val (dispatch-fn a b c d e f g h) + target-fn (-get-method mf dispatch-val)] + (when-not target-fn + (throw-no-method-error name dispatch-val)) + (target-fn a b c d e f g h))) + (-invoke [mf a b c d e f g h i] + (let [dispatch-val (dispatch-fn a b c d e f g h i) + target-fn (-get-method mf dispatch-val)] + (when-not target-fn + (throw-no-method-error name dispatch-val)) + (target-fn a b c d e f g h i))) + (-invoke [mf a b c d e f g h i j] + (let [dispatch-val (dispatch-fn a b c d e f g h i j) + target-fn (-get-method mf dispatch-val)] + (when-not target-fn + (throw-no-method-error name dispatch-val)) + (target-fn a b c d e f g h i j))) + (-invoke [mf a b c d e f g h i j k] + (let [dispatch-val (dispatch-fn a b c d e f g h i j k) + target-fn (-get-method mf dispatch-val)] + (when-not target-fn + (throw-no-method-error name dispatch-val)) + (target-fn a b c d e f g h i j k))) + (-invoke [mf a b c d e f g h i j k l] + (let [dispatch-val (dispatch-fn a b c d e f g h i j k l) + target-fn (-get-method mf dispatch-val)] + (when-not target-fn + (throw-no-method-error name dispatch-val)) + (target-fn a b c d e f g h i j k l))) + (-invoke [mf a b c d e f g h i j k l m] + (let [dispatch-val (dispatch-fn a b c d e f g h i j k l m) + target-fn (-get-method mf dispatch-val)] + (when-not target-fn + (throw-no-method-error name dispatch-val)) + (target-fn a b c d e f g h i j k l m))) + (-invoke [mf a b c d e f g h i j k l m n] + (let [dispatch-val (dispatch-fn a b c d e f g h i j k l m n) + target-fn (-get-method mf dispatch-val)] + (when-not target-fn + (throw-no-method-error name dispatch-val)) + (target-fn a b c d e f g h i j k l m n))) + (-invoke [mf a b c d e f g h i j k l m n o] + (let [dispatch-val (dispatch-fn a b c d e f g h i j k l m n o) + target-fn (-get-method mf dispatch-val)] + (when-not target-fn + (throw-no-method-error name dispatch-val)) + (target-fn a b c d e f g h i j k l m n o))) + (-invoke [mf a b c d e f g h i j k l m n o p] + (let [dispatch-val (dispatch-fn a b c d e f g h i j k l m n o p) + target-fn (-get-method mf dispatch-val)] + (when-not target-fn + (throw-no-method-error name dispatch-val)) + (target-fn a b c d e f g h i j k l m n o p))) + (-invoke [mf a b c d e f g h i j k l m n o p q] + (let [dispatch-val (dispatch-fn a b c d e f g h i j k l m n o p q) + target-fn (-get-method mf dispatch-val)] + (when-not target-fn + (throw-no-method-error name dispatch-val)) + (target-fn a b c d e f g h i j k l m n o p q))) + (-invoke [mf a b c d e f g h i j k l m n o p q r] + (let [dispatch-val (dispatch-fn a b c d e f g h i j k l m n o p q r) + target-fn (-get-method mf dispatch-val)] + (when-not target-fn + (throw-no-method-error name dispatch-val)) + (target-fn a b c d e f g h i j k l m n o p q r))) + (-invoke [mf a b c d e f g h i j k l m n o p q r s] + (let [dispatch-val (dispatch-fn a b c d e f g h i j k l m n o p q r s) + target-fn (-get-method mf dispatch-val)] + (when-not target-fn + (throw-no-method-error name dispatch-val)) + (target-fn a b c d e f g h i j k l m n o p q r s))) + (-invoke [mf a b c d e f g h i j k l m n o p q r s t] + (let [dispatch-val (dispatch-fn a b c d e f g h i j k l m n o p q r s t) + target-fn (-get-method mf dispatch-val)] + (when-not target-fn + (throw-no-method-error name dispatch-val)) + (target-fn a b c d e f g h i j k l m n o p q r s t))) + (-invoke [mf a b c d e f g h i j k l m n o p q r s t rest] + (let [dispatch-val (apply dispatch-fn a b c d e f g h i j k l m n o p q r s t rest) + target-fn (-get-method mf dispatch-val)] + (when-not target-fn + (throw-no-method-error name dispatch-val)) + (apply target-fn a b c d e f g h i j k l m n o p q r s t rest))) + + IMultiFn + (-reset [mf] + (swap! method-table (fn [mf] {})) + (swap! method-cache (fn [mf] {})) + (swap! prefer-table (fn [mf] {})) + (swap! cached-hierarchy (fn [mf] nil)) + mf) + + (-add-method [mf dispatch-val method] + (swap! method-table assoc dispatch-val method) + (reset-cache method-cache method-table cached-hierarchy hierarchy) + mf) + + (-remove-method [mf dispatch-val] + (swap! method-table dissoc dispatch-val) + (reset-cache method-cache method-table cached-hierarchy hierarchy) + mf) + + (-get-method [mf dispatch-val] + (when-not (= @cached-hierarchy @hierarchy) + (reset-cache method-cache method-table cached-hierarchy hierarchy)) + (if-let [target-fn (@method-cache dispatch-val)] + target-fn + (find-and-cache-best-method name dispatch-val hierarchy method-table + prefer-table method-cache cached-hierarchy default-dispatch-val))) + + (-prefer-method [mf dispatch-val-x dispatch-val-y] + (when (prefers* dispatch-val-x dispatch-val-y prefer-table) + (throw (js/Error. (str "Preference conflict in multimethod '" name "': " dispatch-val-y + " is already preferred to " dispatch-val-x)))) + (swap! prefer-table + (fn [old] + (assoc old dispatch-val-x + (conj (get old dispatch-val-x #{}) + dispatch-val-y)))) + (reset-cache method-cache method-table cached-hierarchy hierarchy)) + + (-methods [mf] @method-table) + (-prefers [mf] @prefer-table) + (-default-dispatch-val [mf] default-dispatch-val) + (-dispatch-fn [mf] dispatch-fn) + + INamed + (-name [this] (-name name)) + (-namespace [this] (-namespace name)) + + IHash + (-hash [this] (goog/getUid this))) + +(defn remove-all-methods + "Removes all of the methods of multimethod." + [multifn] + (-reset multifn)) + +(defn remove-method + "Removes the method of multimethod associated with dispatch-value." + [multifn dispatch-val] + (-remove-method multifn dispatch-val)) + +(defn prefer-method + "Causes the multimethod to prefer matches of dispatch-val-x over dispatch-val-y + when there is a conflict" + [multifn dispatch-val-x dispatch-val-y] + (-prefer-method multifn dispatch-val-x dispatch-val-y)) + +(defn methods + "Given a multimethod, returns a map of dispatch values -> dispatch fns" + [multifn] (-methods multifn)) + +(defn get-method + "Given a multimethod and a dispatch value, returns the dispatch fn + that would apply to that value, or nil if none apply and no default" + [multifn dispatch-val] (-get-method multifn dispatch-val)) + +(defn prefers + "Given a multimethod, returns a map of preferred value -> set of other values" + [multifn] (-prefers multifn)) + +(defn default-dispatch-val + "Given a multimethod, return it's default-dispatch-val." + [multifn] (-default-dispatch-val multifn)) + +(defn dispatch-fn + "Given a multimethod, return it's dispatch-fn." + [multifn] (-dispatch-fn multifn)) + +;; UUID +(defprotocol IUUID "A marker protocol for UUIDs") + +(deftype UUID [uuid ^:mutable __hash] + IUUID + + Object + (toString [_] uuid) + (equiv [this other] + (-equiv this other)) + + IEquiv + (-equiv [_ other] + (and (instance? UUID other) (identical? uuid (.-uuid other)))) + + IPrintWithWriter + (-pr-writer [_ writer _] + (-write writer (str "#uuid \"" uuid "\""))) + + IHash + (-hash [this] + (when (nil? __hash) + (set! __hash (hash uuid))) + __hash) + + IComparable + (-compare [this other] + (if (instance? UUID other) + (garray/defaultCompare uuid (.-uuid other)) + (throw (js/Error. (str "Cannot compare " this " to " other)))))) + +(defn uuid [s] + (assert (string? s)) + (UUID. (.toLowerCase s) nil)) + +(defn random-uuid [] + (letfn [(hex [] (.toString (rand-int 16) 16))] + (let [rhex (.toString (bit-or 0x8 (bit-and 0x3 (rand-int 16))) 16)] + (uuid + (str (hex) (hex) (hex) (hex) + (hex) (hex) (hex) (hex) "-" + (hex) (hex) (hex) (hex) "-" + "4" (hex) (hex) (hex) "-" + rhex (hex) (hex) (hex) "-" + (hex) (hex) (hex) (hex) + (hex) (hex) (hex) (hex) + (hex) (hex) (hex) (hex)))))) + +(defn uuid? + [x] (implements? IUUID x)) + +;;; ExceptionInfo + +(defn- pr-writer-ex-info [obj writer opts] + (-write writer "#error {:message ") + (pr-writer (.-message obj) writer opts) + (when (.-data obj) + (-write writer ", :data ") + (pr-writer (.-data obj) writer opts)) + (when (.-cause obj) + (-write writer ", :cause ") + (pr-writer (.-cause obj) writer opts)) + (-write writer "}")) + +(defn ^{:jsdoc ["@constructor"]} + ExceptionInfo [message data cause] + (let [e (js/Error. message)] + (this-as this + (set! (.-message this) message) + (set! (.-data this) data) + (set! (.-cause this) cause) + (do + (set! (.-name this) (.-name e)) + ;; non-standard + (set! (.-description this) (.-description e)) + (set! (.-number this) (.-number e)) + (set! (.-fileName this) (.-fileName e)) + (set! (.-lineNumber this) (.-lineNumber e)) + (set! (.-columnNumber this) (.-columnNumber e)) + (set! (.-stack this) (.-stack e))) + this))) + +(set! (.. ExceptionInfo -prototype -__proto__) js/Error.prototype) + +(extend-type ExceptionInfo + IPrintWithWriter + (-pr-writer [obj writer opts] + (pr-writer-ex-info obj writer opts))) + +(set! (.. ExceptionInfo -prototype -toString) + (fn [] + (this-as this (pr-str* this)))) + +(defn ex-info + "Create an instance of ExceptionInfo, an Error type that carries a + map of additional data." + ([msg data] (ex-info msg data nil)) + ([msg data cause] + (ExceptionInfo. msg data cause))) + +(defn ex-data + "Returns exception data (a map) if ex is an ExceptionInfo. + Otherwise returns nil." + [ex] + (when (instance? ExceptionInfo ex) + (.-data ex))) + +(defn ex-message + "Returns the message attached to the given Error / ExceptionInfo object. + For non-Errors returns nil." + [ex] + (when (instance? js/Error ex) + (.-message ex))) + +(defn ex-cause + "Returns exception cause (an Error / ExceptionInfo) if ex is an + ExceptionInfo. + Otherwise returns nil." + [ex] + (when (instance? ExceptionInfo ex) + (.-cause ex))) + +(defn comparator + "Returns an JavaScript compatible comparator based upon pred." + [pred] + (fn [x y] + (cond (pred x y) -1 (pred y x) 1 :else 0))) + +(defn ^boolean special-symbol? + "Returns true if x names a special form" + [x] + (contains? + '#{if def fn* do let* loop* letfn* throw try catch finally + recur new set! ns deftype* defrecord* . js* & quote case* var ns*} + x)) + +(defn test + "test [v] finds fn at key :test in var metadata and calls it, + presuming failure will throw exception" + [v] + (let [f (.-cljs$lang$test v)] + (if f + (do (f) :ok) + :no-test))) + + +(deftype TaggedLiteral [tag form] + Object + (toString [coll] + (pr-str* coll)) + + IEquiv + (-equiv [this other] + (and (instance? TaggedLiteral other) + (= tag (.-tag other)) + (= form (.-form other)))) + + IHash + (-hash [this] + (+ (* 31 (hash tag)) + (hash form))) + + ILookup + (-lookup [this v] + (-lookup this v nil)) + (-lookup [this v not-found] + (case v + :tag tag + :form form + not-found)) + + IPrintWithWriter + (-pr-writer [o writer opts] + (-write writer (str "#" tag " ")) + (pr-writer form writer opts))) + +(defn tagged-literal? + "Return true if the value is the data representation of a tagged literal" + [value] + (instance? TaggedLiteral value)) + +(defn tagged-literal + "Construct a data representation of a tagged literal from a + tag symbol and a form." + [tag form] + {:pre [(symbol? tag)]} + (TaggedLiteral. tag form)) + +(def + ^{:private true + :jsdoc ["@type {*}"]} + js-reserved-arr + #js ["arguments" "abstract" "await" "boolean" "break" "byte" "case" + "catch" "char" "class" "const" "continue" + "debugger" "default" "delete" "do" "double" + "else" "enum" "export" "extends" "final" + "finally" "float" "for" "function" "goto" "if" + "implements" "import" "in" "instanceof" "int" + "interface" "let" "long" "native" "new" + "package" "private" "protected" "public" + "return" "short" "static" "super" "switch" + "synchronized" "this" "throw" "throws" + "transient" "try" "typeof" "var" "void" + "volatile" "while" "with" "yield" "methods" + "null" "constructor"]) + +(def + ^{:jsdoc ["@type {null|Object}"]} + js-reserved nil) + +(defn- js-reserved? [x] + (when (nil? js-reserved) + (set! js-reserved + (reduce #(do (gobject/set %1 %2 true) %1) + #js {} js-reserved-arr))) + (.hasOwnProperty js-reserved x)) + +(defn- demunge-pattern [] + (when-not DEMUNGE_PATTERN + (set! DEMUNGE_PATTERN + (let [ks (sort (fn [a b] (- (. b -length) (. a -length))) + (js-keys DEMUNGE_MAP))] + (loop [ks ks ret ""] + (if (seq ks) + (recur + (next ks) + (str + (cond-> ret + (not (identical? ret "")) (str "|")) + (first ks))) + (str ret "|\\$")))))) + DEMUNGE_PATTERN) + +(defn- ^string munge-str [name] + (let [sb (StringBuffer.)] + (loop [i 0] + (if (< i (. name -length)) + (let [c (.charAt name i) + sub (gobject/get CHAR_MAP c)] + (if-not (nil? sub) + (.append sb sub) + (.append sb c)) + (recur (inc i))))) + (.toString sb))) + +(defn munge [name] + (let [name' (munge-str (str name)) + name' (cond + (identical? name' "..") "_DOT__DOT_" + (js-reserved? name') (str name' "$") + :else name')] + (if (symbol? name) + (symbol name') + name'))) + +(defn- demunge-str [munged-name] + (let [r (js/RegExp. (demunge-pattern) "g") + munged-name (if (gstring/endsWith munged-name "$") + (.substring munged-name 0 (dec (. munged-name -length))) + munged-name)] + (loop [ret "" last-match-end 0] + (if-let [match (.exec r munged-name)] + (let [[x] match] + (recur + (str ret + (.substring munged-name last-match-end + (- (. r -lastIndex) (. x -length))) + (if (identical? x "$") "/" (gobject/get DEMUNGE_MAP x))) + (. r -lastIndex))) + (str ret + (.substring munged-name last-match-end (.-length munged-name))))))) + +(defn demunge [name] + ((if (symbol? name) symbol str) + (let [name' (str name)] + (if (identical? name' "_DOT__DOT_") + ".." + (demunge-str name'))))) + +(defonce ^{:jsdoc ["@type {*}"] :private true} + tapset nil) + +(defn- maybe-init-tapset [] + (when (nil? tapset) + (set! tapset (atom #{})))) + +(defn add-tap + "Adds f, a fn of one argument, to the tap set. This function will be called with + anything sent via tap>. Remember f in order to remove-tap" + [f] + (maybe-init-tapset) + (swap! tapset conj f) + nil) + +(defn remove-tap + "Remove f from the tap set." + [f] + (maybe-init-tapset) + (swap! tapset disj f) + nil) + +(defn ^boolean tap> + "Sends x to any taps. Returns the result of *exec-tap-fn*, a Boolean value." + [x] + (maybe-init-tapset) + (*exec-tap-fn* + (fn [] + (doseq [tap @tapset] + (try + (tap x) + (catch js/Error ex)))))) + +;; ----------------------------------------------------------------------------- +;; Bootstrap helpers - incompatible with advanced compilation + +(defn- ns-lookup + "Bootstrap only." + [ns-obj k] + (fn [] (gobject/get ns-obj k))) + +;; Bootstrap only +(deftype Namespace [obj name] + Object + (findInternedVar [this sym] + (let [k (munge (str sym))] + (when ^boolean (gobject/containsKey obj k) + (let [var-sym (symbol (str name) (str sym)) + var-meta {:ns this}] + (Var. (ns-lookup obj k) var-sym var-meta))))) + (getName [_] name) + (toString [_] + (str name)) + IEquiv + (-equiv [_ other] + (if (instance? Namespace other) + (= name (.-name other)) + false)) + IHash + (-hash [_] + (hash name))) + +(def + ^{:doc "Bootstrap only." :jsdoc ["@type {*}"]} + NS_CACHE nil) + +(defn- find-ns-obj* + "Bootstrap only." + [ctxt xs] + (cond + (nil? ctxt) nil + (nil? xs) ctxt + :else (recur (gobject/get ctxt (first xs)) (next xs)))) + +(defn find-ns-obj + "Bootstrap only." + [ns] + (let [munged-ns (munge (str ns)) + segs (.split munged-ns ".")] + (case *target* + "nodejs" (if ^boolean js/COMPILED + ; Under simple optimizations on nodejs, namespaces will be in module + ; rather than global scope and must be accessed by a direct call to eval. + ; The first segment may refer to an undefined variable, so its evaluation + ; may throw ReferenceError. + (find-ns-obj* + (try + (let [ctxt (js/eval (first segs))] + (when (and ctxt (object? ctxt)) + ctxt)) + (catch js/ReferenceError e + nil)) + (next segs)) + (find-ns-obj* goog/global segs)) + ("default" "webworker") (find-ns-obj* goog/global segs) + (throw (js/Error. (str "find-ns-obj not supported for target " *target*)))))) + +(defn ns-interns* + "Returns a map of the intern mappings for the namespace. + Bootstrap only." + [sym] + (let [ns-obj (find-ns-obj sym) + ns (Namespace. ns-obj sym)] + (letfn [(step [ret k] + (let [var-sym (symbol (demunge k))] + (assoc ret + var-sym (Var. #(gobject/get ns-obj k) + (symbol (str sym) (str var-sym)) {:ns ns}))))] + (reduce step {} (js-keys ns-obj))))) + +(defn create-ns + "Create a new namespace named by the symbol. Bootstrap only." + ([sym] + (create-ns sym (find-ns-obj sym))) + ([sym ns-obj] + (Namespace. ns-obj sym))) + +(defn find-ns + "Returns the namespace named by the symbol or nil if it doesn't exist. + Bootstrap only." + [ns] + (when (nil? NS_CACHE) + (set! NS_CACHE (atom {}))) + (let [the-ns (get @NS_CACHE ns)] + (if-not (nil? the-ns) + the-ns + (let [ns-obj (find-ns-obj ns)] + (when-not (nil? ns-obj) + (let [new-ns (create-ns ns ns-obj)] + (swap! NS_CACHE assoc ns new-ns) + new-ns)))))) + +(defn find-macros-ns + "Returns the macros namespace named by the symbol or nil if it doesn't exist. + Bootstrap only." + [ns] + (when (nil? NS_CACHE) + (set! NS_CACHE (atom {}))) + (let [ns-str (str ns) + ns (if (not ^boolean (gstring/contains ns-str "$macros")) + (symbol (str ns-str "$macros")) + ns) + the-ns (get @NS_CACHE ns)] + (if-not (nil? the-ns) + the-ns + (let [ns-obj (find-ns-obj ns)] + (when-not (nil? ns-obj) + (let [new-ns (create-ns ns ns-obj)] + (swap! NS_CACHE assoc ns new-ns) + new-ns)))))) + +(defn ns-name + "Returns the name of the namespace, a Namespace object. + Bootstrap only." + [ns-obj] + (.-name ns-obj)) + +(defn uri? + "Returns true x is a goog.Uri instance." + {:added "1.9"} + [x] + (instance? goog.Uri x)) + +(defn- maybe-enable-print! [] + (cond + (exists? js/console) + (enable-console-print!) + + (or (identical? *target* "nashorn") + (identical? *target* "graaljs")) + (let [system (.type js/Java "java.lang.System")] + (set! *print-newline* false) + (set-print-fn! + (fn [] + (let [xs (js-arguments) + s (.join (garray/clone xs) "")] + (.println (.-out system) s)))) + (set-print-err-fn! + (fn [] + (let [xs (js-arguments) + s (.join (garray/clone xs) "")] + (.println (.-error system) s))))))) + +(maybe-enable-print!) + +(defonce + ^{:doc "Runtime environments may provide a way to evaluate ClojureScript + forms. Whatever function *eval* is bound to will be passed any forms which + should be evaluated." :dynamic true} + *eval* + (fn [_] + (throw (js/Error. "cljs.core/*eval* not bound")))) + +(defn eval + "Evaluates the form data structure (not text!) and returns the result. + Delegates to cljs.core/*eval*. Intended for use in self-hosted ClojureScript, + which sets up an implementation of cljs.core/*eval* for that environment." + [form] + (*eval* form)) + +(when ^boolean js/COMPILED + (when (identical? "nodejs" *target*) + (set! goog/global js/global)) + (cond + (identical? "window" *global*) (set! goog/global js/window) + (identical? "self" *global*) (set! goog/global js/self) + (identical? "global" *global*) (set! goog/global js/global))) diff --git a/test-resources/code-samples/clojurescript/fa4b8d853be08120cb864782e4ea48826b9d757e/src/main/clojure/cljs/analyzer.cljc b/test-resources/code-samples/clojurescript/fa4b8d853be08120cb864782e4ea48826b9d757e/src/main/clojure/cljs/analyzer.cljc new file mode 100644 index 00000000..c9f7b7fb --- /dev/null +++ b/test-resources/code-samples/clojurescript/fa4b8d853be08120cb864782e4ea48826b9d757e/src/main/clojure/cljs/analyzer.cljc @@ -0,0 +1,4745 @@ +; Copyright (c) Rich Hickey. All rights reserved. +; The use and distribution terms for this software are covered by the +; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +; which can be found in the file epl-v10.html at the root of this distribution. +; By using this software in any fashion, you are agreeing to be bound by +; the terms of this license. +; You must not remove this notice, or any other, from this software. + +(ns cljs.analyzer + #?(:clj (:refer-clojure :exclude [ensure macroexpand-1]) + :cljs (:refer-clojure :exclude [ensure js-reserved macroexpand-1 ns-interns])) + #?(:cljs (:require-macros [cljs.analyzer.macros + :refer [allowing-redef disallowing-ns* disallowing-recur + no-warn with-warning-handlers wrapping-errors]] + [cljs.env.macros :refer [ensure]])) + #?(:clj (:require [cljs.analyzer.impl :as impl] + [cljs.env :as env :refer [ensure]] + [cljs.externs :as externs] + [cljs.js-deps :as deps] + [cljs.tagged-literals :as tags] + [cljs.util :as util :refer [ns->relpath topo-sort]] + [clojure.edn :as edn] + [clojure.java.io :as io] + [clojure.set :as set] + [clojure.string :as string] + [clojure.tools.reader :as reader] + [clojure.tools.reader.reader-types :as readers]) + :cljs (:require [cljs.analyzer.impl :as impl] + [cljs.env :as env] + [cljs.reader :as edn] + [cljs.tagged-literals :as tags] + [cljs.tools.reader :as reader] + [cljs.tools.reader.reader-types :as readers] + [clojure.set :as set] + [clojure.string :as string] + [goog.string :as gstring])) + #?(:clj (:import [cljs.tagged_literals JSValue] + [clojure.lang Namespace Var LazySeq ArityException] + [java.io File Reader PushbackReader] + [java.lang Throwable] + [java.net URL] + [java.util.regex Pattern]))) + +#?(:clj (set! *warn-on-reflection* true)) + +;; User file-local compiler flags +#?(:clj (def ^:dynamic *unchecked-if* false)) +#?(:clj (def ^:dynamic *unchecked-arrays* false)) + +;; Compiler dynamic vars +(def ^:dynamic *cljs-ns* 'cljs.user) +(def ^:dynamic *cljs-file* nil) +(def ^:dynamic *checked-arrays* false) +(def ^:dynamic *check-alias-dupes* true) +(def ^:dynamic *cljs-static-fns* false) +(def ^:dynamic *fn-invoke-direct* false) +(def ^:dynamic *cljs-macros-path* "/cljs/core") +(def ^:dynamic *cljs-macros-is-classpath* true) +(def ^:dynamic *cljs-dep-set* (with-meta #{} {:dep-path []})) +(def ^:dynamic *analyze-deps* true) +(def ^:dynamic *load-tests* true) +(def ^:dynamic *load-macros* true) +(def ^:dynamic *reload-macros* false) +(def ^:dynamic *macro-infer* true) +(def ^:dynamic *passes* nil) +(def ^:dynamic *file-defs* nil) +(def ^:dynamic *private-var-access-nowarn* false) + +(def constants-ns-sym + "The namespace of the constants table as a symbol." + 'cljs.core.constants) + +#?(:clj + (def transit-read-opts + (try + (require '[cognitect.transit]) + (when-some [ns (find-ns 'cognitect.transit)] + (let [read-handler @(ns-resolve ns 'read-handler) + read-handler-map @(ns-resolve ns 'read-handler-map)] + {:handlers + (read-handler-map + {"cljs/js" (read-handler (fn [v] (JSValue. v))) + "cljs/regex" (read-handler (fn [v] (Pattern/compile v)))})})) + (catch Throwable t + nil)))) + +#?(:clj + (def transit-write-opts + (try + (require '[cognitect.transit]) + (when-some [ns (find-ns 'cognitect.transit)] + (let [write-handler @(ns-resolve ns 'write-handler) + write-handler-map @(ns-resolve ns 'write-handler-map)] + {:handlers + (write-handler-map + {JSValue + (write-handler + (fn [_] "cljs/js") + (fn [js] (.val ^JSValue js))) + Pattern + (write-handler + (fn [_] "cljs/regex") + (fn [pat] (.pattern ^Pattern pat)))})})) + (catch Throwable t + nil)))) + +#?(:clj + (def transit + (delay + (try + (require '[cognitect.transit]) + (when-some [ns (find-ns 'cognitect.transit)] + {:writer @(ns-resolve ns 'writer) + :reader @(ns-resolve ns 'reader) + :write @(ns-resolve ns 'write) + :read @(ns-resolve ns 'read)}) + (catch Throwable t + nil))))) + +;; log compiler activities +(def ^:dynamic *verbose* false) + +(def -cljs-macros-loaded (atom false)) + +(def ^:dynamic *cljs-warnings* + {:preamble-missing true + :unprovided true + :undeclared-var true + :private-var-access true + :undeclared-ns true + :undeclared-ns-form true + :redef true + :redef-in-file true + :dynamic true + :fn-var true + :fn-arity true + :fn-deprecated true + :declared-arglists-mismatch true + :protocol-deprecated true + :undeclared-protocol-symbol true + :invalid-protocol-symbol true + :multiple-variadic-overloads true + :variadic-max-arity true + :overload-arity true + :extending-base-js-type true + :invoke-ctor true + :invalid-arithmetic true + :invalid-array-access true + :protocol-invalid-method true + :protocol-duped-method true + :protocol-multiple-impls true + :protocol-with-variadic-method true + :protocol-with-overwriting-method true + :protocol-impl-with-variadic-method true + :protocol-impl-recur-with-target true + :single-segment-namespace true + :munged-namespace true + :ns-var-clash true + :non-dynamic-earmuffed-var true + :extend-type-invalid-method-shape true + :unsupported-js-module-type true + :unsupported-preprocess-value true + :js-shadowed-by-local true + :infer-warning false}) + +(defn unchecked-arrays? [] + *unchecked-arrays*) + +(defn compiler-options [] + (get @env/*compiler* :options)) + +(defn get-externs [] + (::externs @env/*compiler*)) + +(defn checked-arrays + "Returns false-y, :warn, or :error based on configuration and the + current value of *unchecked-arrays*." + [] + (when (and (not (:advanced (compiler-options))) + (not *unchecked-arrays*)) + *checked-arrays*)) + +(def js-reserved + #{"arguments" "abstract" "await" "boolean" "break" "byte" "case" + "catch" "char" "class" "const" "continue" + "debugger" "default" "delete" "do" "double" + "else" "enum" "export" "extends" "final" + "finally" "float" "for" "function" "goto" "if" + "implements" "import" "in" "instanceof" "int" + "interface" "let" "long" "native" "new" + "package" "private" "protected" "public" + "return" "short" "static" "super" "switch" + "synchronized" "this" "throw" "throws" + "transient" "try" "typeof" "var" "void" + "volatile" "while" "with" "yield" "methods" + "null" "constructor"}) + +(def es5-allowed + #{"default"}) + +#?(:clj (def SENTINEL (Object.)) + :cljs (def SENTINEL (js-obj))) + +(defn gets + ([m k0 k1] + (let [m (get m k0 SENTINEL)] + (when-not (identical? m SENTINEL) + (get m k1)))) + ([m k0 k1 k2] + (let [m (get m k0 SENTINEL)] + (when-not (identical? m SENTINEL) + (let [m (get m k1 SENTINEL)] + (when-not (identical? m SENTINEL) + (get m k2)))))) + ([m k0 k1 k2 k3] + (let [m (get m k0 SENTINEL)] + (when-not (identical? m SENTINEL) + (let [m (get m k1 SENTINEL)] + (when-not (identical? m SENTINEL) + (let [m (get m k2 SENTINEL)] + (when-not (identical? m SENTINEL) + (get m k3))))))))) + +#?(:cljs + (defn munge-path [ss] + (munge (str ss)))) + +#?(:cljs + (defn ns->relpath + "Given a namespace as a symbol return the relative path. May optionally + provide the file extension, defaults to :cljs." + ([ns] (ns->relpath ns :cljs)) + ([ns ext] + (str (string/replace (munge-path ns) \. \/) "." (name ext))))) + +#?(:cljs + (defn topo-sort + ([x get-deps] + (topo-sort x 0 (atom (sorted-map)) (memoize get-deps))) + ([x depth state memo-get-deps] + (let [deps (memo-get-deps x)] + (swap! state update-in [depth] (fnil into #{}) deps) + (doseq [dep deps] + (topo-sort dep (inc depth) state memo-get-deps)) + (doseq [[relpath ns-sym :cljs) + ", " (ns->relpath ns-sym :cljc) + ", or JavaScript source providing \"" js-provide "\"" + (when (string/includes? (ns->relpath ns-sym) "_") + " (Please check that namespaces with dashes use underscores in the ClojureScript file name)"))) + +(defmethod error-message :undeclared-macros-ns + [warning-type {:keys [ns-sym js-provide] :as info}] + (str "No such macros namespace: " ns-sym + ", could not locate " (ns->relpath ns-sym :clj) + " or " (ns->relpath ns-sym :cljc))) + +(defmethod error-message :dynamic + [warning-type info] + (str (:name info) " not declared ^:dynamic")) + +(defmethod error-message :redef + [warning-type info] + (str (:sym info) " already refers to: " (symbol (str (:ns info)) (str (:sym info))) + " being replaced by: " (symbol (str (:ns-name info)) (str (:sym info))))) + +(defmethod error-message :redef-in-file + [warning-type info] + (str (:sym info) " at line " (:line info) " is being replaced")) + +(defmethod error-message :fn-var + [warning-type info] + (str (symbol (str (:ns-name info)) (str (:sym info))) + " no longer fn, references are stale")) + +(defmethod error-message :fn-arity + [warning-type info] + (str "Wrong number of args (" (:argc info) ") passed to " + (or (:ctor info) + (:name info)))) + +(defmethod error-message :fn-deprecated + [warning-type info] + (str (-> info :fexpr :info :name) " is deprecated")) + +(defmethod error-message :declared-arglists-mismatch + [warning-type info] + (str (symbol (str (:ns-name info)) (str (:sym info))) + " declared arglists " (:declared info) + " mismatch defined arglists " (:defined info))) + +(defmethod error-message :undeclared-ns-form + [warning-type info] + (str "Invalid :refer, " (:type info) " " (:lib info) "/" (:sym info) " does not exist")) + +(defmethod error-message :protocol-deprecated + [warning-type info] + (str "Protocol " (:protocol info) " is deprecated")) + +(defmethod error-message :undeclared-protocol-symbol + [warning-type info] + (str "Can't resolve protocol symbol " (:protocol info))) + +(defmethod error-message :invalid-protocol-symbol + [warning-type info] + (str "Symbol " (:protocol info) " is not a protocol")) + +(defmethod error-message :protocol-invalid-method + [warning-type info] + (if (:no-such-method info) + (str "Bad method signature in protocol implementation, " + (:protocol info) " does not declare method called " (:fname info)) + (str "Bad method signature in protocol implementation, " + (:protocol info) " " (:fname info) " does not declare arity " (:invalid-arity info)))) + +(defmethod error-message :protocol-duped-method + [warning-type info] + (str "Duplicated methods in protocol implementation " (:protocol info) " " (:fname info))) + +(defmethod error-message :protocol-multiple-impls + [warning-type info] + (str "Protocol " (:protocol info) " implemented multiple times")) + +(defmethod error-message :protocol-with-variadic-method + [warning-type info] + (str "Protocol " (:protocol info) " declares method " + (:name info) " with variadic signature (&)")) + +(defmethod error-message :protocol-with-overwriting-method + [warning-type info] + (let [overwritten-protocol (-> info :existing :protocol)] + (str "Protocol " (:protocol info) " is overwriting " + (if overwritten-protocol "method" "function") + " " (:name info) + (when overwritten-protocol (str " of protocol " (name overwritten-protocol)))))) + +(defmethod error-message :protocol-impl-with-variadic-method + [warning-type info] + (str "Protocol " (:protocol info) " implements method " + (:name info) " with variadic signature (&)")) + +(defmethod error-message :protocol-impl-recur-with-target + [warning-type info] + (str "Ignoring target object \"" (pr-str (:form info)) "\" passed in recur to protocol method head")) + +(defmethod error-message :multiple-variadic-overloads + [warning-type info] + (str (:name info) ": Can't have more than 1 variadic overload")) + +(defmethod error-message :variadic-max-arity + [warning-type info] + (str (:name info) ": Can't have fixed arity function with more params than variadic function")) + +(defmethod error-message :overload-arity + [warning-type info] + (str (:name info) ": Can't have 2 overloads with same arity")) + +(defmethod error-message :extending-base-js-type + [warning-type info] + (str "Extending an existing JavaScript type - use a different symbol name " + "instead of " (:current-symbol info) " e.g " (:suggested-symbol info))) + +(defmethod error-message :invalid-arithmetic + [warning-type info] + (str (:js-op info) ", all arguments must be numbers, got " (:types info) " instead")) + +(defmethod error-message :invalid-array-access + [warning-type {:keys [name types]}] + (case name + (cljs.core/checked-aget cljs.core/checked-aget') + (str "cljs.core/aget, arguments must be an array followed by numeric indices, got " types " instead" + (when (or (= 'object (first types)) + (every? #{'string} (rest types))) + (str " (consider " + (if (== 2 (count types)) + "goog.object/get" + "goog.object/getValueByKeys") + " for object access)"))) + + (cljs.core/checked-aset cljs.core/checked-aset') + (str "cljs.core/aset, arguments must be an array, followed by numeric indices, followed by a value, got " types " instead" + (when (or (= 'object (first types)) + (every? #{'string} (butlast (rest types)))) + " (consider goog.object/set for object access)")))) + +(defmethod error-message :invoke-ctor + [warning-type info] + (str "Cannot invoke type constructor " (-> info :fexpr :info :name) " as function ")) + +(defmethod error-message :single-segment-namespace + [warning-type info] + (str (:name info) " is a single segment namespace")) + +(defmethod error-message :munged-namespace + [warning-type {:keys [name] :as info}] + (let [munged (->> (string/split (clojure.core/name name) #"\.") + (map #(if (js-reserved %) (str % "$") %)) + (string/join ".") + (munge))] + (str "Namespace " name " contains a reserved JavaScript keyword," + " the corresponding Google Closure namespace will be munged to " munged))) + +(defmethod error-message :ns-var-clash + [warning-type {:keys [ns var] :as info}] + (str "Namespace " ns " clashes with var " var)) + +(defmethod error-message :non-dynamic-earmuffed-var + [warning-type {:keys [var] :as info}] + (str var " not declared dynamic and thus is not dynamically rebindable, but its name " + "suggests otherwise. Please either indicate ^:dynamic " var " or change the name")) + +(defmethod error-message :extend-type-invalid-method-shape + [warning-type {:keys [protocol method] :as info}] + (str "Bad extend-type method shape for protocol " protocol " method " method + ", method arities must be grouped together")) + +(defmethod error-message :unsupported-js-module-type + [warning-type {:keys [module-type file] :as info}] + (str "Unsupported JavaScript module type " module-type " for foreign library " + file ".")) + +(defmethod error-message :unsupported-preprocess-value + [warning-type {:keys [preprocess file]}] + (str "Unsupported preprocess value " preprocess " for foreign library " + file ".")) + +(defmethod error-message :js-shadowed-by-local + [warning-type {:keys [name]}] + (str name " is shadowed by a local")) + +(defmethod error-message :infer-warning + [warning-type {:keys [warn-type form type property]}] + (case warn-type + :target (str "Cannot infer target type in expression " form "") + :property (str "Cannot resolve property " property + " for inferred type " type " in expression " form) + :object (str "Adding extern to Object for property " property " due to " + "ambiguous expression " form))) + +(defn default-warning-handler [warning-type env extra] + (when (warning-type *cljs-warnings*) + (when-let [s (error-message warning-type extra)] + #?(:clj (binding [*out* *err*] + (println (message env (str "WARNING: " s)))) + :cljs (binding [*print-fn* *print-err-fn*] + (println (message env (str "WARNING: " s)))))))) + +(def ^:dynamic *cljs-warning-handlers* + [default-warning-handler]) + +#?(:clj + (defmacro with-warning-handlers [handlers & body] + `(binding [*cljs-warning-handlers* ~handlers] + ~@body))) + +(defn- repeat-char [c n] + (loop [ret c n n] + (if (pos? n) + (recur (str ret c) (dec n)) + ret))) + +(defn- hex-format [s pad] + #?(:clj (str "_u" (format (str "%0" pad "x") (int (first s))) "_") + :cljs (let [hex (.toString (.charCodeAt s 0) 16) + len (. hex -length) + hex (if (< len pad) + (str (repeat-char "0" (- pad len)) hex) + hex)] + (str "_u" hex "_")))) + +(defn gen-constant-id [value] + (let [prefix (cond + (keyword? value) "cst$kw$" + (symbol? value) "cst$sym$" + :else + (throw + #?(:clj (Exception. (str "constant type " (type value) " not supported")) + :cljs (js/Error. (str "constant type " (type value) " not supported"))))) + name (if (keyword? value) + (subs (str value) 1) + (str value)) + name (if (= "." name) + "_DOT_" + (-> name + (string/replace "-" "_DASH_") + (munge) + (string/replace "." "$") + (string/replace #"(?i)[^a-z0-9$_]" #(hex-format % 4))))] + (symbol (str prefix name)))) + +(defn- register-constant! + ([val] (register-constant! nil val)) + ([env val] + (swap! env/*compiler* + (fn [cenv] + (cond-> + (-> cenv + (update-in [::constant-table] + (fn [table] + (if (get table val) + table + (assoc table val (gen-constant-id val)))))) + env (update-in [::namespaces (-> env :ns :name) ::constants] + (fn [{:keys [seen order] :or {seen #{} order []} :as constants}] + (cond-> constants + (not (contains? seen val)) + (assoc + :seen (conj seen val) + :order (conj order val)))))))))) + +(def default-namespaces '{cljs.core {:name cljs.core} + cljs.user {:name cljs.user}}) + +;; this exists solely to support read-only namespace access from macros. +;; External tools should look at the authoritative ::namespaces slot in the +;; compiler-env atoms/maps they're using already; this value will yield only +;; `default-namespaces` when accessed outside the scope of a +;; compilation/analysis call +(def namespaces + #?(:clj + (reify clojure.lang.IDeref + (deref [_] + (if (some? env/*compiler*) + (::namespaces @env/*compiler*) + default-namespaces))) + :cljs + (reify IDeref + (-deref [_] + (if (some? env/*compiler*) + (::namespaces @env/*compiler*) + default-namespaces))))) + +(defn get-namespace + ([key] + (get-namespace env/*compiler* key)) + ([cenv key] + (if-some [ns (get-in @cenv [::namespaces key])] + ns + (when (= 'cljs.user key) + {:name 'cljs.user})))) + +#?(:clj + (defmacro no-warn [& body] + (let [no-warnings (zipmap (keys *cljs-warnings*) (repeat false))] + `(binding [*cljs-warnings* ~no-warnings] + ~@body)))) + +#?(:clj + (defmacro all-warn [& body] + (let [all-warnings (zipmap (keys *cljs-warnings*) (repeat true))] + `(binding [*cljs-warnings* ~all-warnings] + ~@body)))) + +(defn get-line [x env] + (or (-> x meta :line) (:line env))) + +(defn get-col [x env] + (or (-> x meta :column) (:column env))) + +(defn intern-macros + "Given a Clojure namespace intern all macros into the ambient ClojureScript + analysis environment." + ([ns] (intern-macros ns false)) + ([ns reload] + (when (or (nil? (gets @env/*compiler* ::namespaces ns :macros)) + reload) + (swap! env/*compiler* assoc-in [::namespaces ns :macros] + (->> #?(:clj (ns-interns ns) :cljs (ns-interns* ns)) + (filter (fn [[_ ^Var v]] (.isMacro v))) + (map (fn [[k v]] + [k (as-> (meta v) vm + (let [ns (.getName ^Namespace (:ns vm))] + (assoc vm + :ns ns + :name (symbol (str ns) (str k)) + :macro true)))])) + (into {})))))) + +#?(:clj + (def load-mutex (Object.))) + +#?(:clj + (defn load-core [] + (when (not @-cljs-macros-loaded) + (reset! -cljs-macros-loaded true) + (if *cljs-macros-is-classpath* + (locking load-mutex + (load *cljs-macros-path*)) + (locking load-mutex + (load-file *cljs-macros-path*)))) + (intern-macros 'cljs.core))) + +#?(:clj + (defmacro with-core-macros + [path & body] + `(do + (when (not= *cljs-macros-path* ~path) + (reset! -cljs-macros-loaded false)) + (binding [*cljs-macros-path* ~path] + ~@body)))) + +#?(:clj + (defmacro with-core-macros-file + [path & body] + `(do + (when (not= *cljs-macros-path* ~path) + (reset! -cljs-macros-loaded false)) + (binding [*cljs-macros-path* ~path + *cljs-macros-is-classpath* false] + ~@body)))) + +(defn empty-env + "Construct an empty analysis environment. Required to analyze forms." + [] + (ensure + {:ns (get-namespace *cljs-ns*) + :context :statement + :locals {} + :fn-scope [] + :js-globals (into {} + (map #(vector % {:op :js-var :name % :ns 'js}) + '(alert window document console escape unescape + screen location navigator history location + global process require module exports)))})) + +(defn- source-info->error-data + [{:keys [file line column]}] + {:clojure.error/source file + :clojure.error/line line + :clojure.error/column column}) + +(defn source-info + ([env] + (when (:line env) + (source-info nil env))) + ([name env] + (cond-> {:file (if (= (-> env :ns :name) 'cljs.core) + "cljs/core.cljs" + *cljs-file*) + :line (get-line name env) + :column (get-col name env)} + (:root-source-info env) + (merge (select-keys env [:root-source-info]))))) + +(defn message [env s] + (str s + (if (:line env) + (str " at line " (:line env) " " *cljs-file*) + (when *cljs-file* + (str " in file " *cljs-file*))))) + +(defn warning [warning-type env extra] + (doseq [handler *cljs-warning-handlers*] + (handler warning-type env extra))) + +(defn- accumulating-warning-handler [warn-acc] + (fn [warning-type env extra] + (when (warning-type *cljs-warnings*) + (swap! warn-acc conj [warning-type env extra])))) + +(defn- replay-accumulated-warnings [warn-acc] + (run! #(apply warning %) @warn-acc)) + +(defn- error-data + ([env phase] + (error-data env phase nil)) + ([env phase symbol] + (merge (-> (source-info env) source-info->error-data) + {:clojure.error/phase phase} + (when symbol + {:clojure.error/symbol symbol})))) + +(defn- compile-syntax-error + [env msg symbol] + (ex-info nil (error-data env :compile-syntax-check symbol) + #?(:clj (RuntimeException. ^String msg) :cljs (js/Error. msg)))) + +(defn error + ([env msg] + (error env msg nil)) + ([env msg cause] + (ex-info (message env msg) + (assoc (source-info env) :tag :cljs/analysis-error) + cause))) + +(defn analysis-error? + #?(:cljs {:tag boolean}) + [ex] + (= :cljs/analysis-error (:tag (ex-data ex)))) + +(defn has-error-data? + #?(:cljs {:tag boolean}) + [ex] + (contains? (ex-data ex) :clojure.error/phase)) + +#?(:clj + (defmacro wrapping-errors [env & body] + `(try + ~@body + (catch Throwable err# + (cond + (has-error-data? err#) (throw err#) + (analysis-error? err#) (throw (ex-info nil (error-data ~env :compilation) err#)) + :else (throw (ex-info nil (error-data ~env :compilation) (error ~env (.getMessage err#) err#)))))))) + +;; namespaces implicit to the inclusion of cljs.core +(def implicit-nses '#{goog goog.object goog.string goog.array Math String}) + +(defn implicit-import? + #?(:cljs {:tag boolean}) + [env prefix suffix] + (contains? implicit-nses prefix)) + +(declare get-expander) + +(defn confirm-var-exist-warning [env prefix suffix] + (fn [env prefix suffix] + (warning :undeclared-var env + {:prefix prefix + :suffix suffix + :macro-present? (not (nil? (get-expander (symbol (str prefix) (str suffix)) env)))}))) + +(defn lib&sublib + "If a library name has the form foo$bar, return a vector of the library and + the sublibrary property." + [lib] + (if-let [xs (re-matches #"(.*)\$(.*)" (str lib))] + (drop 1 xs) + [lib nil])) + +(defn loaded-js-ns? + "Check if a JavaScript namespace has been loaded. JavaScript vars are + not currently checked." + #?(:cljs {:tag boolean}) + [env prefix] + (when-not (gets @env/*compiler* ::namespaces prefix) + (let [ns (:ns env)] + (or (some? (get (:requires ns) prefix)) + (some? (get (:imports ns) prefix)))))) + +(defn- internal-js-module-exists? + [js-module-index module] + ;; we need to check both keys and values of the JS module index, because + ;; macroexpansion will be looking for the provided name - António Monteiro + (contains? + (into #{} + (mapcat (fn [[k v]] + [k (:name v)])) + js-module-index) + (str module))) + +(def js-module-exists?* (memoize internal-js-module-exists?)) + +(defn js-module-exists? + [module] + (js-module-exists?* (get-in @env/*compiler* [:js-module-index]) module)) + +(defn node-module-dep? + #?(:cljs {:tag boolean}) + [module] + #?(:clj (let [idx (get @env/*compiler* :node-module-index)] + (contains? idx (str (-> module lib&sublib first)))) + :cljs (try + (and (= *target* "nodejs") + (boolean + (or (js/require.resolve (str module)) + (js/require.resolve (-> module lib&sublib first))))) + (catch :default _ + false)))) + +(defn dep-has-global-exports? + [module] + (let [[module _] (lib&sublib module) + global-exports (get-in @env/*compiler* [:js-dependency-index (str module) :global-exports])] + (or (contains? global-exports (symbol module)) + (contains? global-exports (name module))))) + +(defn confirm-var-exists + ([env prefix suffix] + (let [warn (confirm-var-exist-warning env prefix suffix)] + (confirm-var-exists env prefix suffix warn))) + ([env prefix suffix missing-fn] + (let [sufstr (str suffix) + suffix-str (if (and #?(:clj (not= ".." sufstr) + :cljs (not (identical? ".." sufstr))) ;; leave cljs.core$macros/.. alone + #?(:clj (re-find #"\." sufstr) + :cljs ^boolean (.test #"\." sufstr))) + (first (string/split sufstr #"\.")) + suffix) + suffix (symbol suffix-str)] + (when (and (not (implicit-import? env prefix suffix)) + (not (loaded-js-ns? env prefix)) + (not (and (= 'cljs.core prefix) (= 'unquote suffix))) + (nil? (gets @env/*compiler* ::namespaces prefix :defs suffix)) + (not (js-module-exists? prefix))) + (missing-fn env prefix suffix))))) + +(defn confirm-var-exists-throw [] + (fn [env prefix suffix] + (confirm-var-exists env prefix suffix + (fn [env prefix suffix] + (throw (error env (str "Unable to resolve var: " suffix " in this context"))))))) + +(defn resolve-ns-alias + ([env name] + (resolve-ns-alias env name (symbol name))) + ([env name not-found] + (let [sym (symbol name)] + (get (:requires (:ns env)) sym not-found)))) + +(defn resolve-macro-ns-alias + ([env name] + (resolve-macro-ns-alias env name (symbol name))) + ([env name not-found] + (let [sym (symbol name)] + (get (:require-macros (:ns env)) sym not-found)))) + +(defn confirm-ns + "Given env, an analysis environment, and ns-sym, a symbol identifying a + namespace, confirm that the namespace exists. Warn if not found." + [env ns-sym] + (when (and (not= 'cljs.core ns-sym) + (nil? (get implicit-nses ns-sym)) + (nil? (get (-> env :ns :requires) ns-sym)) + ;; something else may have loaded the namespace, i.e. load-file + (nil? (gets @env/*compiler* ::namespaces ns-sym)) + ;; macros may refer to namespaces never explicitly required + ;; confirm that the library at least exists + #?(:clj (nil? (util/ns->source ns-sym))) + (not (js-module-exists? ns-sym))) + (warning :undeclared-ns env {:ns-sym ns-sym :js-provide ns-sym}))) + +(defn core-name? + "Is sym visible from core in the current compilation namespace?" + #?(:cljs {:tag boolean}) + [env sym] + (and (or (some? (gets @env/*compiler* ::namespaces 'cljs.core :defs sym)) + (if-some [mac (get-expander sym env)] + (let [^Namespace ns (-> mac meta :ns)] + (= (.getName ns) #?(:clj 'cljs.core :cljs 'cljs.core$macros))) + false)) + (not (contains? (-> env :ns :excludes) sym)))) + +(defn public-name? + "Is sym public?" + #?(:cljs {:tag boolean}) + [ns sym] + (let [var-ast (or (gets @env/*compiler* ::namespaces ns :defs sym) + #?(:clj (gets @env/*compiler* ::namespaces ns :macros sym) + :cljs (gets @env/*compiler* ::namespaces (symbol (str (name ns) "$macros")) :defs sym)))] + (and (some? var-ast) + (not (or (:private var-ast) + (:anonymous var-ast)))))) + +(defn js-tag? [x] + (and (symbol? x) + (or (= 'js x) + (= "js" (namespace x))))) + +(defn normalize-js-tag [x] + ;; if not 'js, assume constructor + (if-not (= 'js x) + (with-meta 'js + {:prefix (conj (->> (string/split (name x) #"\.") + (map symbol) vec) + 'prototype)}) + x)) + +(defn ->type-set + "Ensures that a type tag is a set." + [t] + (if #?(:clj (set? t) + :cljs (impl/cljs-set? t)) + t + #{t})) + +(defn canonicalize-type [t] + "Ensures that a type tag is either nil, a type symbol, or a non-singleton + set of type symbols, absorbing clj-nil into seq and all types into any." + (cond + (symbol? t) t + (empty? t) nil + (== 1 (count t)) (first t) + (contains? t 'any) 'any + (contains? t 'seq) (let [res (disj t 'clj-nil)] + (if (== 1 (count res)) + 'seq + res)) + :else t)) + +(defn add-types + "Produces a union of types." + ([] 'any) + ([t1] t1) + ([t1 t2] + (if (or (nil? t1) + (nil? t2)) + 'any + (-> (set/union (->type-set t1) (->type-set t2)) + canonicalize-type))) + ([t1 t2 & ts] + (apply add-types (add-types t1 t2) ts))) + +(def alias->type + '{object Object + string String + number Number + array Array + function Function + boolean Boolean + symbol Symbol}) + +(defn has-extern?* + ([pre externs] + (let [pre (if-some [me (find + (get-in externs '[Window prototype]) + (first pre))] + (if-some [tag (-> me first meta :tag)] + (into [tag 'prototype] (next pre)) + pre) + pre)] + (has-extern?* pre externs externs))) + ([pre externs top] + (cond + (empty? pre) true + :else + (let [x (first pre) + me (find externs x)] + (cond + (not me) false + :else + (let [[x' externs'] me + xmeta (meta x')] + (if (and (= 'Function (:tag xmeta)) (:ctor xmeta)) + (or (has-extern?* (into '[prototype] (next pre)) externs' top) + (has-extern?* (next pre) externs' top)) + (recur (next pre) externs' top)))))))) + +(defn has-extern? + ([pre] + (has-extern? pre (get-externs))) + ([pre externs] + (or (has-extern?* pre externs) + (when (= 1 (count pre)) + (let [x (first pre)] + (or (get-in externs (conj '[Window prototype] x)) + (get-in externs (conj '[Number] x))))) + (-> (last pre) str (string/starts-with? "cljs$"))))) + +(defn js-tag + ([pre] + (js-tag pre :tag)) + ([pre tag-type] + (js-tag pre tag-type (get-externs))) + ([pre tag-type externs] + (js-tag pre tag-type externs externs)) + ([pre tag-type externs top] + (when-let [[p externs' :as me] (find externs (first pre))] + (let [tag (-> p meta tag-type)] + (if (= (count pre) 1) + (when tag (symbol "js" (str (alias->type tag tag)))) + (or (js-tag (next pre) tag-type externs' top) + (js-tag (into '[prototype] (next pre)) tag-type (get top tag) top))))))) + +(defn dotted-symbol? [sym] + (let [s (str sym)] + #?(:clj (and (.contains s ".") + (not (.contains s ".."))) + :cljs (and ^boolean (goog.string/contains s ".") + (not ^boolean (goog.string/contains s "..")))))) + +(defn munge-node-lib [name] + (str "node$module$" (munge (string/replace (str name) #"[.\/]" #?(:clj "\\$" + :cljs "$$"))))) + +(defn munge-global-export [name] + (str "global$module$" (munge (string/replace (str name) #"[.\/]" #?(:clj "\\$" + :cljs "$$"))))) + +(defn resolve-alias + "Takes a namespace and an unqualified symbol and potentially returns a new + symbol to be used in lieu of the original." + [ns sym] + ;; Conditionally alias aget/aset fns to checked variants + (if (and (= 'cljs.core ns) + ('#{aget aset} sym) + (checked-arrays)) + (get-in '{:warn {aget checked-aget + aset checked-aset} + :error {aget checked-aget' + aset checked-aset'}} + [(checked-arrays) sym]) + sym)) + +(defn ns->module-type [ns] + (cond + (js-module-exists? ns) :js + (node-module-dep? ns) :node + (dep-has-global-exports? ns) :global)) + +(defmulti resolve* (fn [env sym full-ns current-ns] (ns->module-type full-ns))) + +(defmethod resolve* :js + [env sym full-ns current-ns] + {:name (symbol (str full-ns) (str (name sym))) + :op :js-var + :ns full-ns}) + +(defn extern-pre [sym current-ns] + (let [pre (into '[Object] (->> (string/split (name sym) #"\.") (map symbol) vec))] + (when-not (has-extern? pre) + (swap! env/*compiler* update-in + (into [::namespaces current-ns :externs] pre) merge {})) + pre)) + +(defn node-like? + ([] + (node-like? (compiler-options))) + ([opts] + (and (= :nodejs (:target opts)) + (false? (:nodejs-rt opts))))) + +(defmethod resolve* :node + [env sym full-ns current-ns] + ;; not actually targeting Node.js, we need to generate externs + (if (node-like?) + (let [pre (extern-pre sym current-ns)] + {:ns current-ns + :name (symbol (str current-ns) (str (munge-node-lib full-ns) "." (name sym))) + :op :js-var + :tag (with-meta 'js {:prefix pre}) + :foreign true}) + {:ns current-ns + :name (symbol (str current-ns) (str (munge-node-lib full-ns) "." (name sym))) + :op :js-var + :foreign true})) + +(defmethod resolve* :global + [env sym full-ns current-ns] + (let [pre (extern-pre sym current-ns)] + {:ns current-ns + :name (symbol (str current-ns) (str (munge-global-export full-ns) "." (name sym))) + :op :js-var + :tag (with-meta 'js {:prefix pre}) + :foreign true})) + +(def ^:private private-var-access-exceptions + "Specially-treated symbols for which we don't trigger :private-var-access warnings." + '#{cljs.core/checked-aget + cljs.core/checked-aset + cljs.core/checked-aget' + cljs.core/checked-aset'}) + +(defmethod resolve* :default + [env sym full-ns current-ns] + (let [sym-ast (gets @env/*compiler* ::namespaces full-ns :defs (symbol (name sym))) + sym-name (symbol (str full-ns) (str (name sym)))] + (when (and (not= current-ns full-ns) + (:private sym-ast) + (not *private-var-access-nowarn*) + (not (contains? private-var-access-exceptions sym-name))) + (warning :private-var-access env + {:sym sym-name})) + (merge sym-ast + {:name sym-name + :op :var + :ns full-ns}))) + +(defn required? [ns env] + (or (contains? (set (vals (gets env :ns :requires))) ns) + (contains? (set (vals (gets env :ns :uses))) ns))) + +(defn invokeable-ns? + "Returns true if ns is a required namespace and a JavaScript module that + might be invokeable as a function." + [ns env] + (let [ns (resolve-ns-alias env ns)] + (and (required? ns env) + (or (js-module-exists? ns) + (node-module-dep? ns) + (dep-has-global-exports? ns))))) + +(defn resolve-invokeable-ns [ns current-ns env] + (let [ns (resolve-ns-alias env ns) + module-type (ns->module-type ns)] + (case module-type + :js {:name (symbol + (or (gets @env/*compiler* :js-module-index ns :name) + (resolve-ns-alias env ns))) + :op :js-var + :ns 'js} + :node {:name (symbol (str current-ns) + (munge-node-lib (resolve-ns-alias env ns))) + :op :js-var + :ns current-ns} + :global {:name (symbol (str current-ns) + (munge-global-export (resolve-ns-alias env ns))) + :op :js-var + :ns current-ns}))) + +;; core.async calls `macroexpand-1` manually with an ill-formed +;; :locals map. Normally :locals maps symbols maps, but +;; core.async adds entries mapping symbols to symbols. We work +;; around that specific case here. This is called defensively +;; every time we lookup the :locals map. +(defn handle-symbol-local [sym lb] + (if (symbol? lb) + {:name sym} + lb)) + +(defn resolve-var + "Resolve a var. Accepts a side-effecting confirm fn for producing + warnings about unresolved vars." + ([env sym] + (resolve-var env sym nil)) + ([env sym confirm] + (resolve-var env sym confirm true)) + ([env sym confirm default?] + (let [locals (:locals env)] + (if #?(:clj (= "js" (namespace sym)) + :cljs (identical? "js" (namespace sym))) + (let [symn (-> sym name symbol) + shadowed-by-local (handle-symbol-local symn (get locals symn))] + (cond + (some? shadowed-by-local) + (do (warning :js-shadowed-by-local env {:name sym}) + (assoc shadowed-by-local :op :local)) + + :else + (let [pre (->> (string/split (name sym) #"\.") (map symbol) vec)] + (when (and (not (has-extern? pre)) + ;; ignore exists? usage + (not (-> sym meta ::no-resolve))) + (swap! env/*compiler* update-in + (into [::namespaces (-> env :ns :name) :externs] pre) merge {})) + (merge + {:name sym + :op :js-var + :ns 'js + :tag (with-meta (or (js-tag pre) (:tag (meta sym)) 'js) {:prefix pre})} + (when-let [ret-tag (js-tag pre :ret-tag)] + {:js-fn-var true + :ret-tag ret-tag}))))) + (let [s (str sym) + lb (handle-symbol-local sym (get locals sym)) + current-ns (-> env :ns :name)] + (cond + (some? lb) (assoc lb :op :local) + + (some? (namespace sym)) + (let [ns (namespace sym) + ns (if #?(:clj (= "clojure.core" ns) + :cljs (identical? "clojure.core" ns)) + "cljs.core" + ns) + full-ns (resolve-ns-alias env ns + (or (and (js-module-exists? ns) + (gets @env/*compiler* :js-module-index ns :name)) + (symbol ns)))] + (when (some? confirm) + (when (not= current-ns full-ns) + (confirm-ns env full-ns)) + (confirm env full-ns (symbol (name sym)))) + (resolve* env sym full-ns current-ns)) + + (dotted-symbol? sym) + (let [idx (.indexOf s ".") + prefix (symbol (subs s 0 idx)) + suffix (subs s (inc idx))] + ;; check if prefix is some existing def + (if-let [resolved (resolve-var env prefix nil false)] + (update resolved :name #(symbol (str % "." suffix))) + (let [idx (.lastIndexOf s ".") + pre (subs s 0 idx) + suf (subs s (inc idx))] + {:op :var + :name (symbol pre suf) + :ns (symbol pre)}))) + + (some? (gets @env/*compiler* ::namespaces current-ns :uses sym)) + (let [full-ns (gets @env/*compiler* ::namespaces current-ns :uses sym)] + (resolve* env sym full-ns current-ns)) + + (some? (gets @env/*compiler* ::namespaces current-ns :renames sym)) + (let [qualified-symbol (gets @env/*compiler* ::namespaces current-ns :renames sym) + full-ns (symbol (namespace qualified-symbol)) + sym (symbol (name qualified-symbol))] + (resolve* env sym full-ns current-ns)) + + (some? (gets @env/*compiler* ::namespaces current-ns :imports sym)) + (recur env (gets @env/*compiler* ::namespaces current-ns :imports sym) confirm default?) + + (some? (gets @env/*compiler* ::namespaces current-ns :defs sym)) + (do + (when (some? confirm) + (confirm env current-ns sym)) + (merge (gets @env/*compiler* ::namespaces current-ns :defs sym) + {:name (symbol (str current-ns) (str sym)) + :op :var + :ns current-ns})) + + (core-name? env sym) + (do + (when (some? confirm) + (confirm env 'cljs.core sym)) + (merge (gets @env/*compiler* ::namespaces 'cljs.core :defs sym) + {:name (symbol "cljs.core" (str sym)) + :op :var + :ns 'cljs.core})) + + (invokeable-ns? s env) + (resolve-invokeable-ns s current-ns env) + + :else + (when default? + (when (some? confirm) + (confirm env current-ns sym)) + (merge (gets @env/*compiler* ::namespaces current-ns :defs sym) + {:name (symbol (str current-ns) (str sym)) + :op :var + :ns current-ns})))))))) + +(defn resolve-existing-var + "Given env, an analysis environment, and sym, a symbol, resolve an existing var. + Emits a warning if no such var exists." + [env sym] + (if-not (-> sym meta ::no-resolve) + (resolve-var env sym confirm-var-exists) + (resolve-var env sym))) + +(defn confirm-bindings + "Given env, an analysis environment env, and names, a list of symbols, confirm + that all correspond to declared dynamic vars." + [env names] + (doseq [name names] + (let [env (assoc env :ns (get-namespace *cljs-ns*)) + ev (resolve-existing-var env name)] + (when (and ev (not (-> ev :dynamic))) + (warning :dynamic env {:ev ev :name (:name ev)}))))) + +(defn resolve-macro-var + "Given env, an analysis environment, and sym, a symbol, resolve a macro." + [env sym] + (let [ns (-> env :ns :name) + namespaces (get @env/*compiler* ::namespaces)] + (cond + (some? (namespace sym)) + (let [ns (namespace sym) + ns (if (= "clojure.core" ns) "cljs.core" ns) + full-ns (resolve-macro-ns-alias env ns) + #?@(:cljs [full-ns (if-not (string/ends-with? (str full-ns) "$macros") + (symbol (str full-ns "$macros")) + full-ns)])] + #?(:clj (get-in namespaces [full-ns :macros (symbol (name sym))]) + :cljs (get-in namespaces [full-ns :defs (symbol (name sym))]))) + + (some? (get-in namespaces [ns :use-macros sym])) + (let [full-ns (get-in namespaces [ns :use-macros sym])] + (get-in namespaces [full-ns :macros sym])) + + (some? (get-in namespaces [ns :rename-macros sym])) + (let [qualified-symbol (get-in namespaces [ns :rename-macros sym]) + full-ns (symbol (namespace qualified-symbol)) + sym (symbol (name qualified-symbol))] + (get-in namespaces [full-ns :macros sym])) + + :else + (let [ns (cond + (some? (get-in namespaces [ns :macros sym])) ns + (core-name? env sym) #?(:clj 'cljs.core + :cljs impl/CLJS_CORE_MACROS_SYM))] + (when (some? ns) + #?(:clj (get-in namespaces [ns :macros sym]) + :cljs (get-in namespaces [ns :defs sym]))))))) + +(declare analyze analyze-symbol analyze-seq) + +;; Note: This is the set of parse multimethod dispatch values, +;; along with '&, and differs from cljs.core/special-symbol? +(def specials '#{if def fn* do let* loop* letfn* throw try recur new set! + ns deftype* defrecord* . js* & quote case* var ns*}) + +(def ^:dynamic *recur-frames* nil) +(def ^:dynamic *loop-lets* ()) +(def ^:dynamic *allow-redef* false) +(def ^:dynamic *allow-ns* true) + +#?(:clj + (defmacro disallowing-recur [& body] + `(binding [*recur-frames* (cons nil *recur-frames*)] ~@body))) + +#?(:clj + (defmacro allowing-redef [& body] + `(binding [*allow-redef* true] ~@body))) + +#?(:clj + (defmacro disallowing-ns* [& body] + `(binding [*allow-ns* false] ~@body))) + +;; TODO: move this logic out - David +(defn analyze-keyword + [env sym] + (register-constant! env sym) + {:op :const :val sym :env env :form sym :tag 'cljs.core/Keyword}) + +(defn get-tag [e] + (if-some [tag (-> e :form meta :tag)] + tag + (if-some [tag (-> e :tag)] + tag + (-> e :info :tag)))) + +(defn find-matching-method [f params] + ;; if local fn, need to look in :info + (let [methods (or (:methods f) (-> f :info :methods)) + c (count params)] + (some + (fn [m] + (and (or (== (:fixed-arity m) c) + (:variadic? m)) + m)) + methods))) + +(defn type? + #?(:cljs {:tag boolean}) + [env t] + ;; don't use resolve-existing-var to avoid warnings + (when (and (some? t) (symbol? t)) + (let [var (resolve-var env t)] + (if-some [type (:type var)] + type + (if-some [type (-> var :info :type)] + type + (if-some [proto (:protocol-symbol var)] + proto + (get '#{cljs.core/PersistentHashMap cljs.core/List} t))))))) + +(declare infer-tag) + +(defn unwrap-quote [{:keys [op] :as expr}] + (if #?(:clj (= op :quote) + :cljs (keyword-identical? op :quote)) + (:expr expr) + expr)) + +(defn infer-if [env e] + (let [{:keys [op form]} (unwrap-quote (:test e)) + then-tag (infer-tag env (:then e))] + (if (and #?(:clj (= op :const) + :cljs (keyword-identical? op :const)) + (not (nil? form)) + (not (false? form))) + then-tag + (let [else-tag (infer-tag env (:else e))] + (cond + (or #?(:clj (= then-tag else-tag) + :cljs (symbol-identical? then-tag else-tag)) + #?(:clj (= else-tag impl/IGNORE_SYM) + :cljs (symbol-identical? else-tag impl/IGNORE_SYM))) then-tag + #?(:clj (= then-tag impl/IGNORE_SYM) + :cljs (symbol-identical? then-tag impl/IGNORE_SYM)) else-tag + ;; TODO: temporary until we move not-native -> clj - David + (and (or (some? (get impl/NOT_NATIVE then-tag)) (type? env then-tag)) + (or (some? (get impl/NOT_NATIVE else-tag)) (type? env else-tag))) + 'clj + :else + (if (and (some? (get impl/BOOLEAN_OR_SEQ then-tag)) + (some? (get impl/BOOLEAN_OR_SEQ else-tag))) + 'seq + (let [then-tag (if #?(:clj (set? then-tag) + :cljs (impl/cljs-set? then-tag)) + then-tag #{then-tag}) + else-tag (if #?(:clj (set? else-tag) + :cljs (impl/cljs-set? else-tag)) + else-tag #{else-tag})] + (into then-tag else-tag)))))))) + +(defn infer-invoke [env {f :fn :keys [args] :as e}] + (let [me (assoc (find-matching-method f args) :op :fn-method)] + (if-some [ret-tag (infer-tag env me)] + ret-tag + (let [{:keys [info]} f] + (if-some [ret-tag (if (or (true? (:fn-var info)) + (true? (:js-fn-var info))) + (:ret-tag info) + (when (= 'js (:ns info)) 'js))] + ret-tag + impl/ANY_SYM))))) + +(defn infer-tag + "Given env, an analysis environment, and e, an AST node, return the inferred + type of the node" + [env e] + (if-some [tag (get-tag e)] + tag + (case (:op e) + :recur impl/IGNORE_SYM + :throw impl/IGNORE_SYM + :let (infer-tag env (:body e)) + :loop (infer-tag env (:body e)) + :do (infer-tag env (:ret e)) + :fn-method (infer-tag env (:body e)) + :def (infer-tag env (:init e)) + :invoke (infer-invoke env e) + :if (infer-if env e) + :const (case (:form e) + true impl/BOOLEAN_SYM + false impl/BOOLEAN_SYM + impl/ANY_SYM) + :quote (infer-tag env (:expr e)) + (:var :local :js-var :binding) + (if-some [init (:init e)] + (infer-tag env init) + (infer-tag env (:info e))) + (:host-field :host-call) + impl/ANY_SYM + :js impl/ANY_SYM + nil))) + +(defmulti parse (fn [op & rest] op)) + +(defn var-meta + ([var] + (var-meta var nil)) + ([var expr-env] + (let [sym (:name var) + ks [:ns :doc :file :line :column] + m (merge + (let [user-meta (:meta var) + uks (keys user-meta)] + (zipmap uks + (map #(list 'quote (get user-meta %)) uks))) + (assoc (zipmap ks (map #(list 'quote (get var %)) ks)) + :name `(quote ~(symbol (name (:name var)))) + :test `(when ~sym (.-cljs$lang$test ~sym)) + :arglists (let [arglists (:arglists var) + arglists' (if (= 'quote (first arglists)) + (second arglists) + arglists)] + (list 'quote + (doall (map with-meta arglists' + (:arglists-meta var)))))))] + (if expr-env + (analyze expr-env m) + m)))) + +(defn var-ast + [env sym] + ;; we need to dissoc locals for the `(let [x 1] (def x x))` case, because we + ;; want the var's AST and `resolve-var` will check locals first. - António Monteiro + (binding [*private-var-access-nowarn* true] + (let [env (dissoc env :locals) + var (resolve-var env sym (confirm-var-exists-throw)) + expr-env (assoc env :context :expr)] + (when-some [var-ns (:ns var)] + {:var (analyze expr-env sym) + :sym (analyze expr-env `(quote ~(symbol (name var-ns) (name (:name var))))) + :meta (var-meta var expr-env)})))) + +(defmethod parse 'var + [op env [_ sym :as form] _ _] + (when (not= 2 (count form)) + (throw (error env "Wrong number of args to var"))) + (when-not (symbol? sym) + (throw (error env "Argument to var must be symbol"))) + (merge + {:env env + :op :the-var + :children [:var :sym :meta] + :form form} + (var-ast env sym))) + +(def ^:private predicate->tag + '{ + ;; Base values + cljs.core/nil? clj-nil + cljs.core/undefined? clj-nil + cljs.core/false? boolean + cljs.core/true? boolean + cljs.core/zero? number + cljs.core/infinite? number + + ;; Base types + cljs.core/boolean? boolean + cljs.core/string? string + cljs.core/char? string + cljs.core/number? number + cljs.core/integer? number + cljs.core/float? number + cljs.core/double? number + cljs.core/array? array + cljs.core/seq? seq + + ;; JavaScript types + cljs.core/regexp? js/RegExp + + ;; Types + cljs.core/keyword? cljs.core/Keyword + cljs.core/var? cljs.core/Var + cljs.core/symbol? cljs.core/Symbol + cljs.core/volatile? cljs.core/Volatile + cljs.core/delay? cljs.core/Delay + cljs.core/reduced? cljs.core/Reduced + + ;; Subtypes + cljs.core/simple-keyword? cljs.core/Keyword + cljs.core/qualified-keyword? cljs.core/Keyword + cljs.core/simple-symbol? cljs.core/Symbol + cljs.core/qualified-symbol? cljs.core/Symbol + + ;;; Note: For non-marker protocol entries below, we + ;;; omit predicates that are based on satisfies? because + ;;; we cannot safely apply the fast-path optimization + ;;; which is enabled when the protocol type is inferred. + ;;; If adding a non-marker entry here, also add a test to + ;;; cljs.extend-to-native-test/test-extend-to-protocols. + + ;; Protocols + cljs.core/map-entry? cljs.core/IMapEntry + cljs.core/uuid? cljs.core/IUUID + cljs.core/tagged-literal? cljs.core/ITaggedLiteral + cljs.core/inst? cljs.core/Inst + cljs.core/sequential? cljs.core/ISequential + cljs.core/list? cljs.core/IList + cljs.core/record? cljs.core/IRecord + cljs.core/chunked-seq? cljs.core/IChunkedSeq + + ;; Composites + cljs.core/seqable? #{cljs.core/ISeqable array string} + cljs.core/ident? #{cljs.core/Keyword cljs.core/Symbol} + + ;; Composite subtypes + cljs.core/simple-ident? #{cljs.core/Keyword cljs.core/Symbol} + cljs.core/qualified-ident? #{cljs.core/Keyword cljs.core/Symbol} + }) + +(defn- simple-predicate-induced-tag + "Look for a predicate-induced tag when the test expression is a simple + application of a predicate to a local, as in (string? x)." + [env test] + (when (and (list? test) + (== 2 (count test)) + (every? symbol? test)) + (let [analyzed-fn (no-warn (analyze (assoc env :context :expr) (first test)))] + (when (= :var (:op analyzed-fn)) + (when-let [tag (predicate->tag (:name analyzed-fn))] + (let [sym (last test)] + (when (and (nil? (namespace sym)) + (get-in env [:locals sym])) + [sym tag]))))))) + +(declare specials) + +(defn- type-check-induced-tag + "Look for a type-check-induced tag when the test expression is the use of + instance? on a local, as in (instance? UUID x) or implements? on a local, as + in (implements? ICounted x)." + [env test] + (when (and (list? test) + (== 3 (count test)) + (every? symbol? test) + (not (contains? specials (first test)))) + (let [analyzed-fn (no-warn (analyze (assoc env :context :expr) (first test)))] + (when (= :var (:op analyzed-fn)) + (when ('#{cljs.core/instance? cljs.core/implements?} (:name analyzed-fn)) + (let [analyzed-type (no-warn (analyze (assoc env :context :expr) (second test))) + tag (:name analyzed-type) + sym (last test)] + (when (and (= :var (:op analyzed-type)) + (nil? (namespace sym)) + (get-in env [:locals sym])) + [sym tag]))))))) + +(defn- truth-induced-tag + "Refine a tag to exclude clj-nil if the test is a local." + [env test] + (when (and (symbol? test) + (nil? (namespace test)) + (get-in env [:locals test])) + (let [analyzed-symbol (no-warn (analyze (assoc env :context :expr) test))] + (when-let [tag (:tag analyzed-symbol)] + (when (and (set? tag) + (contains? tag 'clj-nil)) + [test (canonicalize-type (disj tag 'clj-nil))]))))) + +(defn- set-test-induced-tags + "Looks at the test and sets any tags which are induced by virtue + of the test being truthy. For example in (if (string? x) x :bar) + the local x in the then branch must be of string type." + [env test] + (let [[local tag] (or (simple-predicate-induced-tag env test) + (type-check-induced-tag env test) + (truth-induced-tag env test))] + (cond-> env + local (assoc-in [:locals local :tag] tag)))) + +(defmethod parse 'if + [op env [_ test then else :as form] name _] + (when (< (count form) 3) + (throw (compile-syntax-error env "Too few arguments to if" 'if))) + (when (> (count form) 4) + (throw (compile-syntax-error env "Too many arguments to if" 'if))) + (let [test-expr (disallowing-recur (analyze (assoc env :context :expr) test)) + then-expr (allowing-redef (analyze (set-test-induced-tags env test) then)) + else-expr (allowing-redef (analyze env else))] + {:env env :op :if :form form + :test test-expr :then then-expr :else else-expr + :unchecked *unchecked-if* + :children [:test :then :else]})) + +(defmethod parse 'case* + [op env [_ sym tests thens default :as form] name _] + (assert (symbol? sym) "case* must switch on symbol") + (assert (every? vector? tests) "case* tests must be grouped in vectors") + (let [expr-env (assoc env :context :expr) + v (disallowing-recur (analyze expr-env sym)) + tests (mapv #(mapv (fn [t] (analyze expr-env t)) %) tests) + thens (mapv #(analyze env %) thens) + nodes (mapv (fn [tests then] + {:op :case-node + ;synthetic node, no :form + :env env + :tests (mapv (fn [test] + {:op :case-test + :form (:form test) + :env expr-env + :test test + :children [:test]}) + tests) + :then {:op :case-then + :form (:form then) + :env env + :then then + :children [:then]} + :children [:tests :then]}) + tests + thens) + default (analyze env default)] + (assert (every? (fn [t] + (or + (-> t :info :const) + (and (= :const (:op t)) + ((some-fn number? string? char?) (:form t))))) + (apply concat tests)) + "case* tests must be numbers, strings, or constants") + {:env env :op :case :form form + :test v :nodes nodes :default default + :children [:test :nodes :default]})) + +(defmethod parse 'throw + [op env [_ throw-form :as form] name _] + (cond + (= 1 (count form)) + (throw + (error env "Too few arguments to throw, throw expects a single Error instance")) + (< 2 (count form)) + (throw + (error env "Too many arguments to throw, throw expects a single Error instance"))) + (let [throw-expr (disallowing-recur (analyze (assoc env :context :expr) throw-form))] + {:env env :op :throw :form form + :exception throw-expr + :children [:exception]})) + +(defmethod parse 'try + [op env [_ & body :as form] name _] + (let [catchenv (update-in env [:context] #(if (= :expr %) :return %)) + catch? (every-pred seq? #(= (first %) 'catch)) + default? (every-pred catch? #(= (second %) :default)) + finally? (every-pred seq? #(= (first %) 'finally)) + + {:keys [body cblocks dblock fblock]} + (loop [parser {:state :start :forms body + :body [] :cblocks [] :dblock nil :fblock nil}] + (if (seq? (:forms parser)) + (let [[form & forms*] (:forms parser) + parser* (assoc parser :forms forms*)] + (case (:state parser) + :start (cond + (catch? form) (recur (assoc parser :state :catches)) + (finally? form) (recur (assoc parser :state :finally)) + :else (recur (update-in parser* [:body] conj form))) + :catches (cond + (default? form) (recur (assoc parser* :dblock form :state :finally)) + (catch? form) (recur (update-in parser* [:cblocks] conj form)) + (finally? form) (recur (assoc parser :state :finally)) + :else (throw (error env "Invalid try form"))) + :finally (recur (assoc parser* :fblock form :state :done)) + :done (throw (error env "Unexpected form after finally")))) + parser)) + + finally (when (seq fblock) + (-> (disallowing-recur (analyze (assoc env :context :statement) `(do ~@(rest fblock)))) + (assoc :body? true))) + e (when (or (seq cblocks) dblock) (gensym "e")) + default (if-let [[_ _ name & cb] dblock] + `(cljs.core/let [~name ~e] ~@cb) + `(throw ~e)) + cblock (if (seq cblocks) + `(cljs.core/cond + ~@(mapcat + (fn [[_ type name & cb]] + (when name (assert (not (namespace name)) "Can't qualify symbol in catch")) + `[(cljs.core/instance? ~type ~e) + (cljs.core/let [~name ~e] ~@cb)]) + cblocks) + :else ~default) + default) + locals (:locals catchenv) + locals (if e + (assoc locals e + {:name e + :line (get-line e env) + :column (get-col e env)}) + locals) + catch (when cblock + (disallowing-recur (analyze (assoc catchenv :locals locals) cblock))) + try (disallowing-recur (analyze (if (or e finally) catchenv env) `(do ~@body)))] + + {:env env :op :try :form form + :body (assoc try :body? true) + :finally finally + :name e + :catch catch + :children (vec + (concat [:body] + (when catch + [:catch]) + (when finally + [:finally])))})) + +(defn valid-proto [x] + (when (symbol? x) x)) + +(defn elide-env [env ast opts] + (dissoc ast :env)) + +(defn replace-env-pass [new-env] + (fn [env ast opts] + (assoc ast :env new-env))) + +(defn ast-children [ast] + (mapcat (fn [c] + (let [g (get ast c)] + (cond + (vector? g) g + g [g]))) + (:children ast))) + +(defn constant-value? + [{:keys [op] :as ast}] + (or (#{:quote :const} op) + (and (#{:map :set :vector} op) + (every? constant-value? (ast-children ast))))) + +(defn const-expr->constant-value [{:keys [op] :as e}] + (case op + :quote (const-expr->constant-value (:expr e)) + :const (:val e) + :map (zipmap (map const-expr->constant-value (:keys e)) + (map const-expr->constant-value (:vals e))) + :set (into #{} (map const-expr->constant-value (:items e))) + :vector (into [] (map const-expr->constant-value (:items e))))) + +(defn- earmuffed? [sym] + (let [s (name sym)] + (and (> (count s) 2) + (string/starts-with? s "*") + (string/ends-with? s "*")))) + +(defn- core-ns? [ns-sym] + (let [s (name ns-sym)] + (and (not= 'cljs.user ns-sym) + (or (string/starts-with? s "cljs.") + (string/starts-with? s "clojure."))))) + +(defmethod parse 'def + [op env form _ _] + (when (> (count form) 4) + (throw (error env "Too many arguments to def"))) + (let [pfn (fn + ([_ sym] {:sym sym}) + ([_ sym init] {:sym sym :init init}) + ([_ sym doc init] {:sym sym :doc doc :init init})) + args (apply pfn form) + sym (:sym args) + const? (-> sym meta :const) + sym-meta (meta sym) + tag (-> sym meta :tag) + protocol (-> sym meta :protocol valid-proto) + dynamic (-> sym meta :dynamic) + ns-name (-> env :ns :name) + locals (:locals env) + clash-ns (symbol (str ns-name "." sym)) + sym-ns (namespace sym) + sym (cond + (and sym-ns (not #?(:clj (= (symbol sym-ns) ns-name) + :cljs (symbol-identical? (symbol sym-ns) ns-name)))) + (throw (error env (str "Can't def ns-qualified name in namespace " sym-ns))) + + (some? sym-ns) + (symbol (name sym)) + + :else sym)] + (when (some? (get-in @env/*compiler* [::namespaces clash-ns])) + (warning :ns-var-clash env + {:ns (symbol (str ns-name "." sym)) + :var (symbol (str ns-name) (str sym))})) + (when (some? (:const (resolve-var (dissoc env :locals) sym))) + (throw (error env "Can't redefine a constant"))) + (when-some [doc (:doc args)] + (when-not (string? doc) + (throw (error env "Too many arguments to def")))) + (when (and (not dynamic) + (earmuffed? sym) + (not (core-ns? ns-name))) + (warning :non-dynamic-earmuffed-var env + {:var (str sym)})) + (when-some [v (get-in @env/*compiler* [::namespaces ns-name :defs sym])] + (when (and (not *allow-redef*) + (not (:declared v)) + (not (:declared sym-meta)) + *file-defs* + (get @*file-defs* sym)) + (warning :redef-in-file env {:sym sym :line (:line v)})) + (when (and (:declared v) + (:arglists v) + (not= (:arglists v) (:arglists sym-meta))) + (warning :declared-arglists-mismatch env {:ns-name ns-name :sym sym + :declared (second (:arglists v)) + :defined (second (:arglists sym-meta))}))) + (let [env (if (or (and (not= ns-name 'cljs.core) + (core-name? env sym)) + (some? (get-in @env/*compiler* [::namespaces ns-name :uses sym]))) + (let [ev (resolve-existing-var (dissoc env :locals) + ;; ::no-resolve true is to suppress "can't take value + ;; of macro warning" when sym resolves to a macro + (with-meta sym {::no-resolve true})) + conj-to-set (fnil conj #{})] + (when (public-name? (:ns ev) sym) + (warning :redef env {:sym sym :ns (:ns ev) :ns-name ns-name})) + (swap! env/*compiler* update-in [::namespaces ns-name :excludes] + conj-to-set sym) + (update-in env [:ns :excludes] conj-to-set sym)) + env) + var-name (:name (resolve-var (dissoc env :locals) sym)) + init-expr (when (contains? args :init) + (swap! env/*compiler* assoc-in [::namespaces ns-name :defs sym] + (merge + {:name var-name} + sym-meta + (when (true? dynamic) {:dynamic true}) + (source-info var-name env))) + (disallowing-recur + (disallowing-ns* + (analyze (assoc env :context :expr) (:init args) sym)))) + fn-var? (and (some? init-expr) (= (:op init-expr) :fn)) + tag (cond + fn-var? (or (:ret-tag init-expr) tag (:inferred-ret-tag init-expr)) + tag tag + dynamic impl/ANY_SYM + :else (:tag init-expr)) + export-as (when-let [export-val (-> sym meta :export)] + (if (= true export-val) var-name export-val)) + doc (or (:doc args) (-> sym meta :doc))] + (when-some [v (get-in @env/*compiler* [::namespaces ns-name :defs sym])] + (when (and (not (-> sym meta :declared)) + (and (true? (:fn-var v)) (not fn-var?))) + (warning :fn-var env {:ns-name ns-name :sym sym}))) + + ;; declare must not replace any analyzer data of an already def'd sym + (when (or (nil? (get-in @env/*compiler* [::namespaces ns-name :defs sym])) + (not (:declared sym-meta))) + (when *file-defs* + (swap! *file-defs* conj sym)) + + (swap! env/*compiler* assoc-in [::namespaces ns-name :defs sym] + (merge + {:name var-name} + ;; remove actual test metadata, as it includes non-valid EDN and + ;; cannot be present in analysis cached to disk - David + (cond-> sym-meta + (:test sym-meta) (assoc :test true)) + {:meta (-> sym-meta + (dissoc :test) + (update-in [:file] + (fn [f] + (if (= (-> env :ns :name) 'cljs.core) + "cljs/core.cljs" + f))))} + (when doc {:doc doc}) + (when const? + (let [const-expr + (binding [*passes* (conj *passes* (replace-env-pass {:context :expr}))] + (analyze env (:init args)))] + (when (constant-value? const-expr) + {:const-expr const-expr}))) + (when (true? dynamic) {:dynamic true}) + (source-info var-name env) + ;; the protocol a protocol fn belongs to + (when protocol + {:protocol protocol}) + ;; symbol for reified protocol + (when-let [protocol-symbol (-> sym meta :protocol-symbol)] + {:protocol-symbol protocol-symbol + :info (-> protocol-symbol meta :protocol-info) + :impls #{}}) + (when fn-var? + (let [params (map #(vec (map :name (:params %))) (:methods init-expr))] + (merge + {:fn-var (not (:macro sym-meta)) + ;; protocol implementation context + :protocol-impl (:protocol-impl init-expr) + ;; inline protocol implementation context + :protocol-inline (:protocol-inline init-expr)} + (if-some [top-fn-meta (:top-fn sym-meta)] + top-fn-meta + {:variadic? (:variadic? init-expr) + :max-fixed-arity (:max-fixed-arity init-expr) + :method-params params + :arglists (:arglists sym-meta) + :arglists-meta (doall (map meta (:arglists sym-meta)))})))) + (when (and (:declared sym-meta) + (:arglists sym-meta)) + {:declared true + :fn-var true + :method-params (second (:arglists sym-meta))}) + (if (and fn-var? (some? tag)) + {:ret-tag tag} + (when tag {:tag tag}))))) + (merge + {:env env + :op :def + :form form + :ns ns-name + :name var-name + :var (assoc + (analyze + (-> env (dissoc :locals) + (assoc :context :expr) + (assoc :def-var true)) + sym) + :op :var) + :doc doc + :jsdoc (:jsdoc sym-meta)} + (when-let [goog-type (:goog-define sym-meta)] + {:goog-define goog-type}) + (when (true? (:def-emits-var env)) + {:var-ast (var-ast env sym)}) + (when-some [test (:test sym-meta)] + {:test (analyze (assoc env :context :expr) test)}) + (when (some? tag) + (if fn-var? + {:ret-tag tag} + {:tag tag})) + (when (true? dynamic) {:dynamic true}) + (when (some? export-as) {:export export-as}) + (if (some? init-expr) + {:init init-expr + :children [:var :init]} + {:children [:var]}))))) + +(defn analyze-fn-method-param [env] + (fn [[locals params] [arg-id name]] + (when (namespace name) + (throw (error env (str "Can't use qualified name as parameter: " name)))) + (let [line (get-line name env) + column (get-col name env) + nmeta (meta name) + tag (:tag nmeta) + shadow (when (some? locals) + (handle-symbol-local name (locals name))) + env (merge (select-keys env [:context]) + {:line line :column column}) + param {:op :binding + :name name + :line line + :column column + :tag tag + :shadow shadow + :local :arg + :arg-id arg-id + ;; Give the fn params the same shape + ;; as a :var, so it gets routed + ;; correctly in the compiler + :env env + :info {:name name :shadow shadow} + :binding-form? true}] + [(assoc locals name param) (conj params param)]))) + +(defn analyze-fn-method-body [env form recur-frames] + (binding [*recur-frames* recur-frames] + (analyze env form))) + +(defn- analyze-fn-method [env locals form type analyze-body?] + (let [param-names (first form) + variadic (boolean (some '#{&} param-names)) + param-names (vec (remove '#{&} param-names)) + body (next form) + step (analyze-fn-method-param env) + step-init [locals []] + [locals params] (reduce step step-init (map-indexed vector param-names)) + params' (if (true? variadic) + (butlast params) + params) + fixed-arity (count params') + recur-frame {:protocol-impl (:protocol-impl env) + :params params + :flag (atom nil) + :tags (atom [])} + recur-frames (cons recur-frame *recur-frames*) + body-env (assoc env :context :return :locals locals) + body-form `(do ~@body) + expr (when analyze-body? + (analyze-fn-method-body body-env body-form recur-frames)) + recurs @(:flag recur-frame)] + (merge + {:env env + :op :fn-method + :variadic? variadic + :params params + :fixed-arity fixed-arity + :type type + :form form + :recurs recurs} + (if (some? expr) + {:body (assoc expr :body? true) + :children [:params :body]} + {:children [:params]})))) + +(declare analyze-wrap-meta) + +(defn fn-name-var [env locals name] + (when (some? name) + (let [ns (-> env :ns :name) + shadow (handle-symbol-local name (get locals name)) + shadow (when (nil? shadow) + (get-in env [:js-globals name])) + fn-scope (:fn-scope env) + name-var {:name name + :op :binding + :local :fn + :info {:fn-self-name true + :fn-scope fn-scope + :ns ns + :shadow shadow}} + tag (-> name meta :tag) + ret-tag (when (some? tag) + {:ret-tag tag})] + (merge name-var ret-tag)))) + +(defn analyze-fn-methods-pass2* [menv locals type meths] + (mapv #(analyze-fn-method menv locals % type true) meths)) + +(defn analyze-fn-methods-pass2 [menv locals type meths] + (analyze-fn-methods-pass2* menv locals type meths)) + +(defmethod parse 'fn* + [op env [_ & args :as form] name _] + (let [named-fn? (symbol? (first args)) + [name meths] (if named-fn? + [(first args) (next args)] + [name (seq args)]) + ;; turn (fn [] ...) into (fn ([]...)) + meths (if (vector? (first meths)) + (list meths) + meths) + locals (:locals env) + name-var (fn-name-var env locals name) + env (if (some? name) + (update-in env [:fn-scope] conj name-var) + env) + locals (if (and (some? locals) + named-fn?) + (assoc locals name name-var) + locals) + form-meta (meta form) + type (::type form-meta) + proto-impl (::protocol-impl form-meta) + proto-inline (::protocol-inline form-meta) + menv (-> env + (cond-> + (> (count meths) 1) + (assoc :context :expr)) + ;; clear loop flag since method bodies won't be in a loop at first + ;; only tracking this to keep track of locals we need to capture + (dissoc :in-loop) + (merge {:protocol-impl proto-impl + :protocol-inline proto-inline})) + methods (map #(disallowing-ns* (analyze-fn-method menv locals % type (nil? name))) meths) + mfa (transduce (map :fixed-arity) max 0 methods) + variadic (boolean (some :variadic? methods)) + locals (if named-fn? + (update-in locals [name] assoc + ;; TODO: can we simplify? - David + :fn-var true + :variadic? variadic + :max-fixed-arity mfa + :method-params (map :params methods)) + locals) + methods (if (some? name) + ;; a second pass with knowledge of our function-ness/arity + ;; lets us optimize self calls + (disallowing-ns* (analyze-fn-methods-pass2 menv locals type meths)) + (vec methods)) + form (vary-meta form dissoc ::protocol-impl ::protocol-inline ::type) + js-doc (when (true? variadic) + "@param {...*} var_args") + children (if (some? name-var) + [:local :methods] + [:methods]) + inferred-ret-tag (let [inferred-tags (map (partial infer-tag env) (map :body methods))] + (when (apply = inferred-tags) + (first inferred-tags))) + ast (merge {:op :fn + :env env + :form form + :name name-var + :methods methods + :variadic? variadic + :tag 'function + :inferred-ret-tag inferred-ret-tag + :recur-frames *recur-frames* + :in-loop (:in-loop env) + :loop-lets *loop-lets* + :jsdoc [js-doc] + :max-fixed-arity mfa + :protocol-impl proto-impl + :protocol-inline proto-inline + :children children} + (when (some? name-var) + {:local name-var}))] + (let [variadic-methods (into [] + (comp (filter :variadic?) (take 1)) + methods) + variadic-params (if (pos? (count variadic-methods)) + (count (:params (nth variadic-methods 0))) + 0) + param-counts (into [] (map (comp count :params)) methods)] + (when (< 1 (count variadic-methods)) + (warning :multiple-variadic-overloads env {:name name-var})) + (when (not (or (zero? variadic-params) (== variadic-params (+ 1 mfa)))) + (warning :variadic-max-arity env {:name name-var})) + (when (not= (distinct param-counts) param-counts) + (warning :overload-arity env {:name name-var}))) + (analyze-wrap-meta ast))) + +(defmethod parse 'letfn* + [op env [_ bindings & exprs :as form] name _] + (when-not (and (vector? bindings) (even? (count bindings))) + (throw (error env "bindings must be vector of even number of elements"))) + (let [n->fexpr (into {} (map (juxt first second) (partition 2 bindings))) + names (keys n->fexpr) + context (:context env) + ;; first pass to collect information for recursive references + [meth-env bes] + (reduce (fn [[{:keys [locals] :as env} bes] n] + (let [ret-tag (-> n meta :tag) + fexpr (no-warn (analyze env (n->fexpr n))) + be (cond-> + {:name n + :op :binding + :fn-var true + :line (get-line n env) + :column (get-col n env) + :local :letfn + :shadow (handle-symbol-local n (locals n)) + :variadic? (:variadic? fexpr) + :max-fixed-arity (:max-fixed-arity fexpr) + :method-params (map :params (:methods fexpr))} + ret-tag (assoc :ret-tag ret-tag))] + [(assoc-in env [:locals n] be) + (conj bes be)])) + [env []] names) + meth-env (assoc meth-env :context :expr) + ;; the real pass + [meth-env bes] + (reduce (fn [[meth-env bes] {:keys [name shadow] :as be}] + (let [env (assoc-in meth-env [:locals name] shadow) + fexpr (analyze env (n->fexpr name)) + be' (assoc be + :init fexpr + :variadic? (:variadic? fexpr) + :max-fixed-arity (:max-fixed-arity fexpr) + :method-params (map :params (:methods fexpr)))] + [(assoc-in env [:locals name] be') + (conj bes be')])) + [meth-env []] bes) + expr (-> (analyze (assoc meth-env :context (if (= :expr context) :return context)) `(do ~@exprs)) + (assoc :body? true))] + {:env env :op :letfn :bindings bes :body expr :form form + :children [:bindings :body]})) + +(defn analyze-do-statements* [env exprs] + (mapv #(analyze (assoc env :context :statement) %) (butlast exprs))) + +(defn analyze-do-statements [env exprs] + (disallowing-recur (analyze-do-statements* env exprs))) + +(defmethod parse 'do + [op env [_ & exprs :as form] _ _] + (let [statements (analyze-do-statements env exprs)] + (if (<= (count exprs) 1) + (let [ret (analyze env (first exprs)) + children [:statements :ret]] + {:op :do + :env env + :form form + :statements statements :ret ret + :children children}) + (let [ret-env (if (= :statement (:context env)) + (assoc env :context :statement) + (assoc env :context :return)) + ret (analyze ret-env (last exprs)) + children [:statements :ret]] + {:op :do + :env env + :form form + :statements statements + :ret ret + :children children})))) + +(defn analyze-let-binding-init [env init loop-lets] + (binding [*loop-lets* loop-lets] + (analyze env init))) + +(defn get-let-tag [name init-expr] + (if-some [tag (-> name meta :tag)] + tag + (if-some [tag (-> init-expr :tag)] + tag + (-> init-expr :info :tag)))) + +(defn analyze-let-bindings* [encl-env bindings op] + (loop [bes [] + env (assoc encl-env :context :expr) + bindings (seq (partition 2 bindings))] + + (if-some [[name init] (first bindings)] + (let [] + (when (or (some? (namespace name)) + #?(:clj (.contains (str name) ".") + :cljs ^boolean (goog.string/contains (str name) "."))) + (throw (error encl-env (str "Invalid local name: " name)))) + (let [init-expr (analyze-let-binding-init env init (cons {:params bes} *loop-lets*)) + line (get-line name env) + col (get-col name env) + shadow (handle-symbol-local name (get-in env [:locals name])) + be {:name name + :line line + :column col + :init init-expr + :tag (get-let-tag name init-expr) + :local op + :shadow shadow + ;; Give let* bindings same shape as var so + ;; they get routed correctly in the compiler + :op :binding + :env {:line line :column col} + :info {:name name + :shadow shadow} + :binding-form? true} + be (if (= :fn (:op init-expr)) + ;; TODO: can we simplify - David + (merge be + {:fn-var true + ;; copy over the :fn-method information we need for invoke type inference + :methods (into [] (map #(select-keys % [:tag :fixed-arity :variadic?]) (:methods init-expr))) + :variadic? (:variadic? init-expr) + :max-fixed-arity (:max-fixed-arity init-expr) + :method-params (map :params (:methods init-expr))}) + be)] + (recur (conj bes be) + (assoc-in env [:locals name] be) + (next bindings)))) + [bes env]))) + +(defn analyze-let-bindings [encl-env bindings op] + (disallowing-recur (analyze-let-bindings* encl-env bindings op))) + +(defn analyze-let-body* [env context exprs] + (analyze (assoc env :context (if (= :expr context) :return context)) `(do ~@exprs))) + +(defn analyze-let-body [env context exprs recur-frames loop-lets] + (binding [*recur-frames* recur-frames + *loop-lets* loop-lets] + (analyze-let-body* env context exprs))) + +(defn analyze-let + [encl-env [_ bindings & exprs :as form] is-loop widened-tags] + (when-not (and (vector? bindings) (even? (count bindings))) + (throw (error encl-env "bindings must be vector of even number of elements"))) + (let [context (:context encl-env) + op (if (true? is-loop) :loop :let) + bindings (if widened-tags + (vec (mapcat + (fn [[name init] widened-tag] + [(vary-meta name assoc :tag widened-tag) init]) + (partition 2 bindings) + widened-tags)) + bindings) + [bes env] (-> encl-env + (cond-> + (true? is-loop) (assoc :in-loop true)) + (analyze-let-bindings bindings op)) + recur-frame (when (true? is-loop) + {:params bes + :flag (atom nil) + :tags (atom (mapv :tag bes))}) + recur-frames (if recur-frame + (cons recur-frame *recur-frames*) + *recur-frames*) + loop-lets (cond + (true? is-loop) *loop-lets* + (some? *loop-lets*) (cons {:params bes} *loop-lets*)) + ;; Accumulate warnings for deferred replay iff there's a possibility of re-analyzing + warn-acc (when (and is-loop + (not widened-tags)) + (atom [])) + expr (if warn-acc + (with-warning-handlers [(accumulating-warning-handler warn-acc)] + (analyze-let-body env context exprs recur-frames loop-lets)) + (analyze-let-body env context exprs recur-frames loop-lets)) + children [:bindings :body] + nil->any (fnil identity 'any)] + (if (and is-loop + (not widened-tags) + (not= (mapv nil->any @(:tags recur-frame)) + (mapv (comp nil->any :tag) bes))) + (recur encl-env form is-loop @(:tags recur-frame)) + (do + (when warn-acc + (replay-accumulated-warnings warn-acc)) + {:op op + :env encl-env + :bindings bes + :body (assoc expr :body? true) + :form form + :children children})))) + +(defmethod parse 'let* + [op encl-env form _ _] + (analyze-let encl-env form false nil)) + +(defmethod parse 'loop* + [op encl-env form _ _] + (analyze-let encl-env form true nil)) + +(defmethod parse 'recur + [op env [_ & exprs :as form] _ _] + (let [context (:context env) + frame (first *recur-frames*) + ;; Add dummy implicit target object if recuring to proto impl method head + add-implicit-target-object? (and (:protocol-impl frame) + (= (count exprs) (dec (count (:params frame))))) + exprs (cond->> exprs add-implicit-target-object? (cons nil)) + exprs (disallowing-recur (vec (map #(analyze (assoc env :context :expr) %) exprs)))] + (when-not frame + (throw (error env "Can't recur here"))) + (when-not (= (count exprs) (count (:params frame))) + (throw (error env (str "recur argument count mismatch, expected: " + (count (:params frame)) " args, got: " (count exprs))))) + (when (and (:protocol-impl frame) + (not add-implicit-target-object?)) + (warning :protocol-impl-recur-with-target env {:form (:form (first exprs))})) + (reset! (:flag frame) true) + (swap! (:tags frame) (fn [tags] + (mapv (fn [tag expr] + ;; Widen by adding the type of the recur expression, except when recurring with a + ;; loop local: Since its final widened type is unknown, conservatively assume 'any. + (if (= :loop (:local expr)) + 'any + (add-types tag (:tag expr)))) + tags exprs))) + (assoc {:env env :op :recur :form form} + :frame frame + :exprs exprs + :children [:exprs]))) + +(defn analyze-const + [env form] + (let [;; register constants + {:keys [tag]} (analyze (assoc env :quoted? true) form)] + {:op :const + :env env + :literal? true + :val form + :tag tag + :form form})) + +(defmethod parse 'quote + [_ env [_ x :as form] _ _] + (when (not= 2 (count form)) + (throw (error env "Wrong number of args to quote"))) + (let [expr (analyze-const env x)] + {:op :quote + :expr expr + :env env + :form form + :tag (:tag expr) + :children [:expr]})) + +(defmethod parse 'new + [_ env [_ ctor & args :as form] _ _] + (disallowing-recur + (let [enve (assoc env :context :expr) + ctorexpr (analyze enve ctor) + ctor-var (when (#{:var :local :js-var} (:op ctorexpr)) + (resolve-existing-var env ctor)) + record-args + (when (and (:record ctor-var) (not (-> ctor meta :internal-ctor))) + (repeat 3 (analyze enve nil))) + argexprs (into (vec (map #(analyze enve %) args)) record-args) + known-num-fields (:num-fields ctor-var) + argc (count args)] + (when (and (not (-> ctor meta :internal-ctor)) + (some? known-num-fields) (not= known-num-fields argc)) + (warning :fn-arity env {:argc argc :ctor ctor})) + {:env env :op :new :form form :class ctorexpr :args argexprs + :children [:class :args] + :tag (let [name (-> ctorexpr :info :name)] + (or ('{js/Object object + js/String string + js/Array array + js/Number number + js/Function function + js/Boolean boolean} name) + name))}))) + +(defmethod parse 'set! + [_ env [_ target val alt :as form] _ _] + (let [[target val] (if alt + ;; (set! o -prop val) + [`(. ~target ~val) alt] + [target val])] + (disallowing-recur + (binding [*private-var-access-nowarn* true] + (let [enve (assoc env :context :expr) + texpr (cond + (symbol? target) + (do + (cond + (and (= target '*unchecked-if*) ;; TODO: proper resolve + (or (true? val) (false? val))) + (set! *unchecked-if* val) + + (and (= target '*unchecked-arrays*) ;; TODO: proper resolve + (or (true? val) (false? val))) + (set! *unchecked-arrays* val) + + (and (= target '*warn-on-infer*) + (or (true? val) (false? val))) + (set! *cljs-warnings* (assoc *cljs-warnings* :infer-warning val))) + (when (some? (:const (resolve-var (dissoc env :locals) target))) + (throw (error env "Can't set! a constant"))) + (let [local (handle-symbol-local target (-> env :locals target))] + (when-not (or (nil? local) + (and (:field local) + (or (:mutable local) + (:unsynchronized-mutable local) + (:volatile-mutable local)))) + (throw (error env "Can't set! local var or non-mutable field")))) + (analyze-symbol enve target)) + + :else + (when (seq? target) + (let [texpr (if (-> target meta :extend-type) + ;; we're setting a prototype via extend-type macro + ;; nothing to warn + (binding [*cljs-warnings* + (assoc *cljs-warnings* :infer-warning false)] + (analyze-seq enve target nil)) + (analyze-seq enve target nil))] + (when (:field texpr) + texpr)))) + vexpr (analyze enve val)] + ;; as top level fns are decomposed for Closure cross-module code motion, we need to + ;; restore their :methods information + (when (seq? target) + (let [sym (some-> target second) + meta (meta sym)] + (when-let [info (and (= :fn (:op vexpr)) (:top-fn meta))] + (swap! env/*compiler* update-in + [::namespaces (-> env :ns :name) :defs sym :methods] + (fnil conj []) + ;; just use original fn meta, as the fn method is already desugared + ;; only get tag from analysis + (merge + (select-keys info [:fixed-arity :variadic?]) + (select-keys (-> vexpr :methods first) [:tag])))))) + (when-not texpr + (throw (error env "set! target must be a field or a symbol naming a var"))) + (cond + (and (not (:def-emits-var env)) ;; non-REPL context + (some? ('#{*unchecked-if* *unchecked-arrays* *warn-on-infer*} target))) + {:env env :op :no-op} + + :else + {:env env :op :set! :form form :target texpr :val vexpr + :children [:target :val]})))))) + +#?(:clj (declare analyze-file)) + +#?(:clj + (defn locate-src + "Given a namespace return the corresponding ClojureScript (.cljs or .cljc) + resource on the classpath or file from the root of the build." + [ns] + (or (util/ns->source ns) + ;; Find sources available in inputs given to cljs.closure/build - Juho Teperi + (some (fn [source] + (if (= ns (:ns source)) + (:source-file source))) + (:sources @env/*compiler*)) + ;; Find sources in directory given to cljs.compiler/compile-root - Juho Teperi + (let [rootp (when-let [root (:root @env/*compiler*)] + (.getPath ^File root)) + cljsf (io/file rootp (ns->relpath ns :cljs)) + cljcf (io/file rootp (ns->relpath ns :cljc))] + (if (and (.exists cljsf) (.isFile cljsf)) + cljsf + (if (and (.exists cljcf) (.isFile cljcf)) + cljcf)))))) + +(defn foreign-dep? + #?(:cljs {:tag boolean}) + [dep] + (let [js-index (:js-dependency-index @env/*compiler*)] + (if-some [[_ {:keys [foreign]}] (find js-index (name (-> dep lib&sublib first)))] + foreign + false))) + +(defn analyze-deps + "Given a lib, a namespace, deps, its dependencies, env, an analysis environment + and opts, compiler options - analyze all of the dependencies. Required to + correctly analyze usage of other namespaces." + ([lib deps env] + (analyze-deps lib deps env + (when env/*compiler* + (:options @env/*compiler*)))) + ([lib deps env opts] + (let [compiler @env/*compiler*] + (binding [*cljs-dep-set* (vary-meta (conj *cljs-dep-set* lib) update-in [:dep-path] conj lib)] + (assert (every? #(not (contains? *cljs-dep-set* %)) deps) + (str "Circular dependency detected, " + (apply str + (interpose " -> " + (conj (-> *cljs-dep-set* meta :dep-path) + (some *cljs-dep-set* deps)))))) + (doseq [dep deps] + (when-not (or (some? (get-in compiler [::namespaces dep :defs])) + (node-module-dep? dep) + (js-module-exists? (name dep)) + #?(:clj (deps/find-classpath-lib dep))) + (let [idx (:js-dependency-index compiler) + dep (-> dep lib&sublib first)] + (if (contains? idx (name dep)) + (let [dep-name (name dep)] + (when (string/starts-with? dep-name "goog.") + #?(:clj (let [js-lib (get idx dep-name) + ns (externs/analyze-goog-file (:file js-lib) (symbol dep-name))] + (swap! env/*compiler* update-in [::namespaces dep] merge ns))))) + #?(:clj (if-some [src (locate-src dep)] + (analyze-file src opts) + (throw + (error env + (error-message :undeclared-ns {:ns-sym dep :js-provide (name dep)})))) + :cljs (throw + (error env + (error-message :undeclared-ns {:ns-sym dep :js-provide (name dep)})))))))))))) + +(defn missing-use? [lib sym cenv] + (let [js-lib (get-in cenv [:js-dependency-index (name lib)])] + (and (= (get-in cenv [::namespaces lib :defs sym] ::not-found) ::not-found) + (not (= (get js-lib :group) :goog)) + (not (get js-lib :closure-lib)) + (not (node-module-dep? lib)) + (not (dep-has-global-exports? lib))))) + +(defn missing-rename? [sym cenv] + (let [lib (symbol (namespace sym)) + sym (symbol (name sym))] + (missing-use? lib sym cenv))) + +(defn missing-use-macro? [lib sym] + ;; guard against string requires + (when (symbol? lib) + (let [the-ns #?(:clj (find-ns lib) :cljs (find-macros-ns lib))] + (or (nil? the-ns) (nil? (.findInternedVar ^clojure.lang.Namespace the-ns sym)))))) + +(defn missing-rename-macro? [sym] + (let [lib (symbol (namespace sym)) + sym (symbol (name sym)) + the-ns #?(:clj (find-ns lib) :cljs (find-macros-ns lib))] + (or (nil? the-ns) (nil? (.findInternedVar ^clojure.lang.Namespace the-ns sym))))) + +;; returns (s/map-of symbol? symbol?) +(defn missing-uses + [uses env] + (let [cenv @env/*compiler*] + (into {} (filter (fn [[sym lib]] (missing-use? lib sym cenv)) uses)))) + +;; returns (s/map-of symbol? qualified-symbol?) +(defn missing-renames [renames env] + (let [cenv @env/*compiler*] + (into {} (filter (fn [[_ qualified-sym]] (missing-rename? qualified-sym cenv)) renames)))) + +;; returns (s/map-of symbol? symbol?) +(defn missing-use-macros [use-macros env] + (let [cenv @env/*compiler*] + (into {} (filter (fn [[sym lib]] (missing-use-macro? lib sym)) use-macros)))) + +;; returns (s/map-of symbol? symbol?) +(defn inferred-use-macros [use-macros env] + (let [cenv @env/*compiler*] + (into {} (filter (fn [[sym lib]] (not (missing-use-macro? lib sym))) use-macros)))) + +;; returns (s/map-of symbol? symbol?) +(defn inferred-rename-macros [rename-macros env] + (into {} (filter (fn [[_ qualified-sym]] (not (missing-rename-macro? qualified-sym))) rename-macros))) + +(defn check-uses [uses env] + (let [cenv @env/*compiler*] + (doseq [[sym lib] uses] + (when (missing-use? lib sym cenv) + (throw + (error env + (error-message :undeclared-ns-form {:type "var" :lib lib :sym sym}))))))) + +(defn check-use-macros + ([use-macros env] + (check-use-macros use-macros nil env)) + ([use-macros missing-uses env] + (let [cenv @env/*compiler*] + (doseq [[sym lib] use-macros] + (when (missing-use-macro? lib sym) + (throw + (error env + (error-message :undeclared-ns-form {:type "macro" :lib lib :sym sym}))))) + (check-uses (missing-use-macros missing-uses env) env) + (inferred-use-macros missing-uses env)))) + +(defn check-use-macros-inferring-missing + [{:keys [name uses use-macros] :as ast} env] + (let [missing-uses (when (and *analyze-deps* (seq uses)) + (missing-uses uses env)) + maybe-macros (apply dissoc uses (keys missing-uses)) + remove-missing-uses #(apply dissoc % (keys missing-uses)) + ast' (-> ast + (update-in [:use-macros] + #(-> % + (merge (check-use-macros use-macros missing-uses env)) + (merge (inferred-use-macros maybe-macros env)))) + (update-in [:uses] remove-missing-uses))] + (swap! env/*compiler* + #(-> % + (update-in [::namespaces name :use-macros] merge (:use-macros ast')) + (update-in [::namespaces name :uses] remove-missing-uses))) + ast')) + +(defn check-rename-macros-inferring-missing + [{:keys [name renames] :as ast} env] + (let [missing-renames (when (and *analyze-deps* (seq renames)) + (missing-renames renames env)) + maybe-macros (apply dissoc renames (keys missing-renames)) + missing-rename-macros (inferred-rename-macros missing-renames env) + remove-missing-renames #(apply dissoc % (keys missing-renames)) + ast' (-> ast + (update-in [:rename-macros] + #(-> % + (merge missing-rename-macros) + (merge (inferred-rename-macros maybe-macros env)))) + (update-in [:renames] remove-missing-renames))] + (swap! env/*compiler* + #(-> % + (update-in [::namespaces name :rename-macros] merge (:rename-macros ast')) + (update-in [::namespaces name :renames] remove-missing-renames))) + ast')) + +(defn parse-ns-error-msg [spec msg] + (str msg "; offending spec: " (pr-str spec))) + +(defn basic-validate-ns-spec [env macros? spec] + (when-not (or (symbol? spec) (string? spec) (sequential? spec)) + (throw + (error env + (parse-ns-error-msg spec + "Only [lib.ns & options] and lib.ns specs supported in :require / :require-macros")))) + (when (sequential? spec) + (when-not (or (symbol? (first spec)) (string? (first spec))) + (throw + (error env + (parse-ns-error-msg spec + "Library name must be specified as a symbol in :require / :require-macros")))) + (when-not (odd? (count spec)) + (throw + (error env + (parse-ns-error-msg spec + "Only :as alias, :refer (names) and :rename {from to} options supported in :require")))) + (when-not (every? #{:as :refer :rename} (map first (partition 2 (next spec)))) + (throw + (error env + (parse-ns-error-msg spec + "Only :as, :refer and :rename options supported in :require / :require-macros")))) + (when-not (let [fs (frequencies (next spec))] + (and (<= (fs :as 0) 1) + (<= (fs :refer 0) 1))) + (throw + (error env + (parse-ns-error-msg spec + "Each of :as and :refer options may only be specified once in :require / :require-macros")))))) + +(defn parse-ns-excludes [env args] + (reduce + (fn [s [k & filters]] + (if (= k :refer-clojure) + (do + (when (seq (:excludes s)) + (throw (error env "Only one :refer-clojure form is allowed per namespace definition"))) + (let [valid-kws #{:exclude :rename} + xs + (loop [fs (seq filters) + ret {:excludes #{} + :renames {}} + err (not (even? (count filters)))] + (cond + (true? err) + (throw + (error env "Only [:refer-clojure :exclude (names)] and optionally `:rename {from to}` specs supported")) + + (some? fs) + (let [kw (first fs)] + (if (valid-kws kw) + (let [refs (second fs)] + (cond + (not (or (and (= kw :exclude) (sequential? refs) (every? symbol? refs)) + (and (= kw :rename) (map? refs) (every? #(every? symbol? %) refs)))) + (recur fs ret true) + + (= kw :exclude) + (recur (nnext fs) (update-in ret [:excludes] into refs) false) + + (= kw :rename) + (recur (nnext fs) (update-in ret [:renames] merge refs) false))) + (recur fs ret true))) + + :else ret))] + (merge-with into s xs))) + s)) + {:excludes #{} + :renames {}} args)) + +(defn use->require [env [lib & filters :as spec]] + (when-not (and (symbol? lib) (odd? (count spec))) + (throw + (error env + (parse-ns-error-msg spec + "Only [lib.ns :only (names)] and optionally `:rename {from to}` specs supported in :use / :use-macros")))) + (loop [fs (seq filters) ret [lib] err false] + (cond + (true? err) + (throw + (error env + (parse-ns-error-msg spec + "Only [lib.ns :only (names)] and optionally `:rename {from to}` specs supported in :use / :use-macros"))) + + (some? fs) + (let [kw (first fs) + only? (= kw :only)] + (if (or only? (= kw :rename)) + (if (some? (some #{(if only? :refer kw)} ret)) + (throw + (error env + (parse-ns-error-msg spec + "Each of :only and :rename options may only be specified once in :use / :use-macros"))) + (let [refs (second fs)] + (if-not (or (and only? (sequential? refs) (every? symbol? refs)) + (and (= kw :rename) (map? refs) (every? #(every? symbol? %) refs))) + (recur fs ret true) + (recur (nnext fs) (into ret [(if only? :refer kw) refs]) false)))) + (recur fs ret true ))) + + :else (if (some? (some #{:refer} ret)) + ret + (recur fs ret true))))) + +(defn parse-require-spec [env macros? deps aliases spec] + (if (or (symbol? spec) (string? spec)) + (recur env macros? deps aliases [spec]) + (do + (basic-validate-ns-spec env macros? spec) + (let [[lib & opts] spec + ;; We need to load JS modules by the name that has been created by the + ;; Google Closure compiler, e.g. module$resources$libs$calculator. + ;; This means that we need to create an alias from the module name + ;; given with :provides to the new name. + [lib js-module-provides] (if-some [js-module-name (gets @env/*compiler* :js-module-index (str lib) :name)] + [(symbol js-module-name) lib] + [lib nil]) + {alias :as referred :refer renamed :rename + :or {alias (if (string? lib) + (symbol (munge lib)) + lib)}} + (apply hash-map opts) + referred-without-renamed (seq (remove (set (keys renamed)) referred)) + [rk uk renk] (if macros? [:require-macros :use-macros :rename-macros] [:require :use :rename])] + (when-not (or (symbol? alias) (nil? alias)) + (throw + (error env + (parse-ns-error-msg spec + ":as must be followed by a symbol in :require / :require-macros")))) + (when (some? alias) + (let [alias-type (if macros? :macros :fns) + lib' ((alias-type @aliases) alias)] + (when (and (some? lib') (not= lib lib')) + (throw (error env (parse-ns-error-msg spec ":as alias must be unique")))) + (swap! aliases + update-in [alias-type] + conj [alias lib] (when js-module-provides [js-module-provides lib])))) + (when-not (or (and (sequential? referred) + (every? symbol? referred)) + (nil? referred)) + (throw + (error env + (parse-ns-error-msg spec + ":refer must be followed by a sequence of symbols in :require / :require-macros")))) + (when-not macros? + (swap! deps conj lib)) + (merge + (when (some? alias) + {rk (merge {alias lib} {lib lib} + (when js-module-provides {js-module-provides lib}))}) + (when (some? referred-without-renamed) + {uk (apply hash-map (interleave referred-without-renamed (repeat lib)))}) + (when (some? renamed) + {renk (reduce (fn [m [original renamed]] + (when-not (some #{original} referred) + (throw (error env + (str "Renamed symbol " original " not referred")))) + (assoc m renamed (symbol (str lib) (str original)))) + {} renamed)})))))) + +(defn parse-import-spec [env deps spec] + (when-not (or (and (sequential? spec) + (every? symbol? spec)) + (and (symbol? spec) (nil? (namespace spec)))) + (throw (error env (parse-ns-error-msg spec "Only lib.ns.Ctor or [lib.ns Ctor*] spec supported in :import")))) + (let [import-map (cond + (sequential? spec) + (->> (rest spec) + (map #(vector % (symbol (str (first spec) "." %)))) + (into {})) + + (not (== -1 (.indexOf (str spec) "."))) + {(symbol (last (string/split (str spec) #"\."))) spec} + + :else {})] + (doseq [[_ spec] import-map] + (swap! deps conj spec)) + {:import import-map + :require import-map})) + +#?(:clj (declare parse-ns)) + +(defn macro-autoload-ns? + "Given a spec form check whether the spec namespace requires a macro file + of the same name. If so return true." + #?(:cljs {:tag boolean}) + [form] + (when *macro-infer* + (let [ns (if (sequential? form) (first form) form) + {:keys [use-macros require-macros]} + (or (get-in @env/*compiler* [::namespaces ns]) + #?(:clj + (when-let [res (util/ns->source ns)] + (:ast (parse-ns res)))))] + (or (some #{ns} (vals use-macros)) + (some #{ns} (vals require-macros)))))) + +(defn clj-ns->cljs-ns + "Given a symbol that starts with clojure as the first segment return the + same symbol with the first segment replaced with cljs" + [sym] + (let [segs (string/split (clojure.core/name sym) #"\.")] + (if (= "clojure" (first segs)) + (symbol (string/join "." (cons "cljs" (next segs)))) + sym))) + +#?(:clj + (defn aliasable-clj-ns? + "Predicate for testing with a symbol represents an aliasable clojure namespace." + [sym] + (when-not (util/ns->source sym) + (let [[seg1 :as segs] (string/split (clojure.core/name sym) #"\.")] + (when (= "clojure" seg1) + (let [sym' (clj-ns->cljs-ns sym)] + (util/ns->source sym'))))))) + +#?(:clj + (defn process-rewrite-form [[k & specs :as form]] + (letfn [(process-spec [maybe-spec] + (let [[lib & xs] (if (sequential? maybe-spec) + maybe-spec + [maybe-spec])] + (if (and (symbol? lib) (aliasable-clj-ns? lib)) + (let [lib' (clj-ns->cljs-ns lib) + spec (cons lib' xs)] + (into (if xs [spec] []) [(list lib' :as lib)])) + [maybe-spec])))] + (if (#{:use :require} k) + (cons k (mapcat process-spec specs)) + form)))) + +#?(:clj + (defn rewrite-cljs-aliases + "Alias non-existing clojure.* namespaces to existing cljs.* namespaces if + possible." + [args] + (map process-rewrite-form args))) + +(defn canonicalize-specs [specs] + (letfn [(canonicalize [quoted-spec-or-kw] + (if (keyword? quoted-spec-or-kw) + quoted-spec-or-kw + (as-> (second quoted-spec-or-kw) spec + (if (or (vector? spec) (map? spec)) spec [spec]))))] + (map canonicalize specs))) + +(defn canonicalize-import-specs [specs] + (letfn [(canonicalize [quoted-spec-or-kw] + (if (keyword? quoted-spec-or-kw) + quoted-spec-or-kw + (second quoted-spec-or-kw)))] + (map canonicalize specs))) + +(defn desugar-ns-specs + "Given an original set of ns specs desugar :include-macros and :refer-macros + usage into only primitive spec forms - :use, :require, :use-macros, + :require-macros. If a library includes a macro file of with the same name + as the namespace will also be desugared." + [args] + (let [{:keys [require] :as indexed} + (->> args + (map (fn [[k & specs]] [k (into [] specs)])) + (into {})) + sugar-keys #{:include-macros :refer-macros} + ;; drop spec k and value from spec for generated :require-macros + remove-from-spec + (fn [pred spec] + (if-not (and (sequential? spec) (some pred spec)) + spec + (let [[l r] (split-with (complement pred) spec)] + (recur pred (concat l (drop 2 r)))))) + ;; rewrite :refer-macros to :refer for generated :require-macros + replace-refer-macros + (fn [spec] + (if-not (sequential? spec) + spec + (map (fn [x] (if (= x :refer-macros) :refer x)) spec))) + reload-spec? #(#{:reload :reload-all} %) + to-macro-specs + (fn [specs] + (->> specs + (filter + (fn [x] + (or (and (sequential? x) + (some sugar-keys x)) + (reload-spec? x) + (macro-autoload-ns? x)))) + (map (fn [x] + (if-not (reload-spec? x) + (->> x (remove-from-spec #{:include-macros}) + (remove-from-spec #{:refer}) + (remove-from-spec #{:rename}) + (replace-refer-macros)) + x))))) + remove-sugar (partial remove-from-spec sugar-keys)] + (if-some [require-specs (seq (to-macro-specs require))] + (map (fn [x] + (if-not (reload-spec? x) + (let [[k v] x] + (cons k (map remove-sugar v))) + x)) + (update-in indexed [:require-macros] (fnil into []) require-specs)) + args))) + +(defn find-def-clash [env ns segments] + (let [to-check (map (fn [xs] + [(symbol (string/join "." (butlast xs))) + (symbol (last xs))]) + (drop 2 (reductions conj [] segments)))] + (doseq [[clash-ns name] to-check] + (when (get-in @env/*compiler* [::namespaces clash-ns :defs name]) + (warning :ns-var-clash env + {:ns ns + :var (symbol (str clash-ns) (str name))}))))) + +(defn macro-ns-name [name] + (let [name-str (str name)] + (if-not #?(:clj (.endsWith name-str "$macros") + :cljs (gstring/endsWith name-str "$macros")) + (symbol (str name-str "$macros")) + name))) + +(defmethod parse 'ns + [_ env [_ name & args :as form] _ opts] + (when-not *allow-ns* + (throw (error env "Namespace declarations must appear at the top-level."))) + (when-not (symbol? name) + (throw (error env "Namespaces must be named by a symbol."))) + (let [name (cond-> name (:macros-ns opts) macro-ns-name)] + (let [segments (string/split (clojure.core/name name) #"\.")] + (when (= 1 (count segments)) + (warning :single-segment-namespace env {:name name})) + (let [segment (some js-reserved segments)] + (when (some? segment) + (warning :munged-namespace env {:name name}))) + (find-def-clash env name segments) + #?(:clj + (when (some (complement util/valid-js-id-start?) segments) + (throw + (AssertionError. + (str "Namespace " name " has a segment starting with an invaild " + "JavaScript identifier")))))) + (let [docstring (when (string? (first args)) (first args)) + mdocstr (-> name meta :doc) + args (if (some? docstring) (next args) args) + metadata (when (map? (first args)) (first args)) + args (desugar-ns-specs + #?(:clj (rewrite-cljs-aliases + (if metadata (next args) args)) + :cljs (if (some? metadata) (next args) args))) + name (vary-meta name merge metadata) + {excludes :excludes core-renames :renames} (parse-ns-excludes env args) + core-renames (reduce (fn [m [original renamed]] + (assoc m renamed (symbol "cljs.core" (str original)))) + {} core-renames) + deps (atom []) + aliases (atom {:fns {} :macros {}}) + spec-parsers {:require (partial parse-require-spec env false deps aliases) + :require-macros (partial parse-require-spec env true deps aliases) + :use (comp (partial parse-require-spec env false deps aliases) + (partial use->require env)) + :use-macros (comp (partial parse-require-spec env true deps aliases) + (partial use->require env)) + :import (partial parse-import-spec env deps)} + valid-forms (atom #{:use :use-macros :require :require-macros :import}) + reload (atom {:use nil :require nil :use-macros nil :require-macros nil}) + reloads (atom {}) + {uses :use requires :require renames :rename + use-macros :use-macros require-macros :require-macros + rename-macros :rename-macros imports :import :as params} + (reduce + (fn [m [k & libs :as libspec]] + (when-not (#{:use :use-macros :require :require-macros :import} k) + (throw (error env (str "Only :refer-clojure, :require, :require-macros, :use, :use-macros, and :import libspecs supported. Got " libspec " instead.")))) + (when-not (@valid-forms k) + (throw (error env (str "Only one " k " form is allowed per namespace definition")))) + (swap! valid-forms disj k) + ;; check for spec type reloads + (when-not (= :import k) + (when (some? (some #{:reload} libs)) + (swap! reload assoc k :reload)) + (when (some? (some #{:reload-all} libs)) + (swap! reload assoc k :reload-all))) + ;; check for individual ns reloads from REPL interactions + (when-let [xs (seq (filter #(-> % meta :reload) libs))] + (swap! reloads assoc k + (zipmap (map first xs) (map #(-> % meta :reload) xs)))) + (apply merge-with merge m + (map (spec-parsers k) + (remove #{:reload :reload-all} libs)))) + {} (remove (fn [[r]] (= r :refer-clojure)) args)) + ;; patch `require-macros` and `use-macros` in Bootstrap for namespaces + ;; that require their own macros + #?@(:cljs [[require-macros use-macros] + (map (fn [spec-map] + (if (:macros-ns opts) + (let [ns (symbol (subs (str name) 0 (- (count (str name)) 7)))] + (reduce (fn [m [k v]] + (cond-> m + (not (symbol-identical? v ns)) + (assoc k v))) + {} spec-map)) + spec-map)) [require-macros use-macros])])] + (set! *cljs-ns* name) + (let [ns-info + {:name name + :doc (or docstring mdocstr) + :excludes excludes + :use-macros use-macros + :require-macros require-macros + :rename-macros rename-macros + :uses uses + :requires requires + :renames (merge renames core-renames) + :imports imports}] + (swap! env/*compiler* update-in [::namespaces name] merge ns-info) + (merge {:op :ns + :env env + :form form + :deps (into [] (distinct @deps)) + :reload @reload + :reloads @reloads} + (cond-> ns-info + (@reload :use) + (update-in [:uses] + (fn [m] (with-meta m {(@reload :use) true}))) + (@reload :require) + (update-in [:requires] + (fn [m] (with-meta m {(@reload :require) true}))))))))) + +(defn- check-duplicate-aliases + [env old new] + (let [ns-name (:name old)] + (doseq [k [:requires :require-macros]] + (let [old-aliases (get old k) + new-aliases (get new k)] + (when-some [alias (some (set (keys new-aliases)) + (->> old-aliases + (remove (fn [[k v :as entry]] + (or (= k v) + (= entry (find new-aliases k))))) + keys))] + (throw (error env + (str "Alias " alias " already exists in namespace " ns-name + ", aliasing " (get old-aliases alias))))))))) + +(defmethod parse 'ns* + [_ env [_ quoted-specs :as form] _ opts] + (when-let [not-quoted (->> (remove keyword? quoted-specs) + (remove #(and (seq? %) (= 'quote (first %))) ) + first)] + (throw (error env (str "Arguments to " (name (first quoted-specs)) + " must be quoted. Offending spec: " not-quoted)))) + (when-not *allow-ns* + (throw (error env (str "Calls to `" (name (first quoted-specs)) + "` must appear at the top-level.")))) + (let [specs (if (= :import (first quoted-specs)) + (canonicalize-import-specs quoted-specs) + (canonicalize-specs quoted-specs)) + name (-> env :ns :name) + args (desugar-ns-specs + #?(:clj (list (process-rewrite-form + specs)) + :cljs (list specs))) + {excludes :excludes core-renames :renames} (parse-ns-excludes env args) + core-renames (reduce (fn [m [original renamed]] + (assoc m renamed (symbol "cljs.core" (str original)))) + {} core-renames) + deps (atom []) + aliases (atom {:fns {} :macros {}}) + spec-parsers {:require (partial parse-require-spec env false deps aliases) + :require-macros (partial parse-require-spec env true deps aliases) + :use (comp (partial parse-require-spec env false deps aliases) + (partial use->require env)) + :use-macros (comp (partial parse-require-spec env true deps aliases) + (partial use->require env)) + :import (partial parse-import-spec env deps)} + reload (atom {:use nil :require nil :use-macros nil :require-macros nil}) + reloads (atom {}) + {uses :use requires :require renames :rename + use-macros :use-macros require-macros :require-macros + rename-macros :rename-macros imports :import :as params} + (reduce + (fn [m [k & libs]] + ;; check for spec type reloads + (when-not (= :import k) + (when (some? (some #{:reload} libs)) + (swap! reload assoc k :reload)) + (when (some? (some #{:reload-all} libs)) + (swap! reload assoc k :reload-all))) + ;; check for individual ns reloads from REPL interactions + (when-some [xs (seq (filter #(-> % meta :reload) libs))] + (swap! reloads assoc k + (zipmap (map first xs) (map #(-> % meta :reload) xs)))) + (apply merge-with merge m + (map (spec-parsers k) + (remove #{:reload :reload-all} libs)))) + {} (remove (fn [[r]] (= r :refer-clojure)) args))] + (set! *cljs-ns* name) + (let [require-info + {:name name + :excludes excludes + :use-macros use-macros + :require-macros require-macros + :rename-macros rename-macros + :uses uses + :requires requires + :renames (merge renames core-renames) + :imports imports} + ns-info + (let [ns-info' (get-in @env/*compiler* [::namespaces name])] + (if (pos? (count ns-info')) + (let [merge-keys + [:use-macros :require-macros :rename-macros + :uses :requires :renames :imports]] + #?(:clj + (when *check-alias-dupes* + (check-duplicate-aliases env ns-info' require-info))) + (merge + ns-info' + {:excludes excludes} + (merge-with merge + (select-keys ns-info' merge-keys) + (select-keys require-info merge-keys)))) + require-info))] + (swap! env/*compiler* update-in [::namespaces name] merge ns-info) + (merge {:op :ns* + :env env + :form form + :deps (into [] (distinct @deps)) + :reload @reload + :reloads @reloads} + (cond-> require-info + (@reload :use) + (update-in [:uses] + (fn [m] (with-meta m {(@reload :use) true}))) + (@reload :require) + (update-in [:requires] + (fn [m] (with-meta m {(@reload :require) true})))))))) + +(defn parse-type + [op env [_ tsym fields pmasks body :as form]] + (let [t (:name (resolve-var (dissoc env :locals) tsym)) + locals (reduce (fn [m fld] + (assoc m fld + {:name fld + :line (get-line fld env) + :column (get-col fld env) + :local :field + :field true + :mutable (-> fld meta :mutable) + :unsynchronized-mutable (-> fld meta :unsynchronized-mutable) + :volatile-mutable (-> fld meta :volatile-mutable) + :tag (-> fld meta :tag) + :shadow (m fld)})) + {} (if (= :defrecord op) + (concat fields '[__meta __extmap ^:mutable __hash]) + fields)) + protocols (-> tsym meta :protocols)] + (swap! env/*compiler* update-in [::namespaces (-> env :ns :name) :defs tsym] + (fn [m] + (let [m (assoc (or m {}) + :name t + :tag 'function + :type true + :num-fields (count fields) + :record (= :defrecord op))] + (merge m + (dissoc (meta tsym) :protocols) + {:protocols protocols} + (source-info tsym env))))) + {:op op :env env :form form :t t :fields fields :pmasks pmasks + :tag 'function + :protocols (disj protocols 'cljs.core/Object) + :children [#_:fields :body] + :body (analyze (assoc env :locals locals) body)})) + +(defmethod parse 'deftype* + [_ env form _ _] + (parse-type :deftype env form)) + +(defmethod parse 'defrecord* + [_ env form _ _] + (parse-type :defrecord env form) ) + +;; dot accessor code + +(def ^:private property-symbol? #(boolean (and (symbol? %) (re-matches #"^-.*" (name %))))) + +(defn- classify-dot-form + [[target member args]] + [(cond (nil? target) ::error + :default ::expr) + (cond (property-symbol? member) ::property + (symbol? member) ::symbol + (seq? member) ::list + :default ::error) + (cond (nil? args) () + :default ::expr)]) + +(defmulti build-dot-form #(classify-dot-form %)) + +;; (. o -p) +;; (. (...) -p) +(defmethod build-dot-form [::expr ::property ()] + [[target prop _]] + {:dot-action ::access :target target + :field (with-meta (-> prop name (.substring 1) symbol) (meta prop))}) + +;; (. o -p ) +(defmethod build-dot-form [::expr ::property ::list] + [[target prop args]] + #?(:clj (throw (Error. (str "Cannot provide arguments " args " on property access " prop))) + :cljs (throw (js/Error. (str "Cannot provide arguments " args " on property access " prop))))) + +(defn- build-method-call + "Builds the intermediate method call map used to reason about the parsed form during + compilation." + [target meth args] + (if (symbol? meth) + {:dot-action ::call :target target :method meth :args args} + {:dot-action ::call :target target :method (first meth) :args args})) + +;; (. o m 1 2) +(defmethod build-dot-form [::expr ::symbol ::expr] + [[target meth args]] + (build-method-call target meth args)) + +;; (. o m) +(defmethod build-dot-form [::expr ::symbol ()] + [[target meth args]] + (build-method-call target meth args)) + +;; (. o (m)) +;; (. o (m 1 2)) +(defmethod build-dot-form [::expr ::list ()] + [[target meth-expr _]] + (build-method-call target (first meth-expr) (rest meth-expr))) + +(defmethod build-dot-form :default + [dot-form] + #?(:clj (throw + (Error. + (str "Unknown dot form of " + (list* '. dot-form) " with classification " + (classify-dot-form dot-form)))) + :cljs (throw + (js/Error. + (str "Unknown dot form of " + (list* '. dot-form) " with classification " + (classify-dot-form dot-form)))))) + +(defn analyze-dot [env target field member+ form] + (let [v [target field member+] + {:keys [dot-action target method field args]} (build-dot-form v) + enve (assoc env :context :expr) + targetexpr (analyze enve target) + form-meta (meta form) + target-tag (:tag targetexpr) + prop (or field method) + tag (or (:tag form-meta) + (and (js-tag? target-tag) + (vary-meta (normalize-js-tag target-tag) + update-in [:prefix] (fnil conj '[Object]) prop)) + nil)] + (when (and (not= 'constructor prop) + (not (string/starts-with? (str prop) "cljs$")) + (not (-> prop meta :protocol-prop))) + ;; Adding to Object + (when (= 'Object (first (-> tag meta :prefix))) + (warning :infer-warning env + {:warn-type :object :form form :property prop})) + (when (not= 'js target-tag) + ;; Cannot determine type of the target + (when (or (nil? target-tag) ('#{any} target-tag)) + (warning :infer-warning env + {:warn-type :target :form form :property prop})) + ;; Unresolveable property on existing extern + (let [[pre' pre] ((juxt butlast identity) (-> tag meta :prefix))] + (when (and (has-extern? pre') (not (has-extern? pre))) + (warning :infer-warning env + {:warn-type :property :form form + :type (symbol "js" + (string/join "." + (cond-> pre' (= 'prototype (last pre')) butlast))) + :property prop}))))) + (when (js-tag? tag) + (let [pre (-> tag meta :prefix)] + (when-not (has-extern? pre) + (swap! env/*compiler* update-in + (into [::namespaces (-> env :ns :name) :externs] pre) merge {})))) + (case dot-action + ::access (let [children [:target]] + {:op :host-field + :env env + :form form + :target targetexpr + :field field + :children children + :tag (if (js-tag? tag) + (or (js-tag (-> tag meta :prefix) :tag) tag) + tag)}) + ::call (let [argexprs (mapv #(analyze enve %) args) + children [:target :args]] + {:op :host-call + :env env + :form form + :target targetexpr + :method method + :args argexprs + :children children + :tag (if (js-tag? tag) + (or (js-tag (-> tag meta :prefix) :ret-tag) 'js) + tag)})))) + +(defmethod parse '. + [_ env [_ target & [field & member+] :as form] _ _] + (disallowing-recur (analyze-dot env target field member+ form))) + +(defn get-js-tag [form] + (let [form-meta (meta form)] + (if-some [tag (:tag form-meta)] + tag + (when (true? (:numeric form-meta)) + 'number)))) + +(defn js-star-interp + [env ^String s] + (let [idx (.indexOf s "~{")] + (if (== -1 idx) + (list s) + (let [end (.indexOf s "}" idx) + inner (:name (resolve-existing-var env (symbol (subs s (+ 2 idx) end))))] + (lazy-seq + (cons (subs s 0 idx) + (cons inner + (js-star-interp env (subs s (inc end)))))))))) + +(defn js-star-seg + [^String s] + (let [idx (.indexOf s "~{")] + (if (== -1 idx) + (list s) + (let [end (.indexOf s "}" idx)] + (lazy-seq + (cons (subs s 0 idx) + (js-star-seg (subs s (inc end))))))))) + +(def NUMERIC_SET '#{any number long double}) + +(defn numeric-type? + #?(:cljs {:tag boolean}) + [t] + ;; TODO: type inference is not strong enough to detect that + ;; when functions like first won't return nil, so variadic + ;; numeric functions like cljs.core/< would produce a spurious + ;; warning without this - David + (cond + (nil? t) true + (= 'clj-nil t) true + (js-tag? t) true ;; TODO: revisit + :else + (if (and (symbol? t) (some? (get NUMERIC_SET t))) + true + (when #?(:clj (set? t) + :cljs (impl/cljs-set? t)) + (or (contains? t 'number) + (contains? t 'long) + (contains? t 'double) + (contains? t 'any) + (contains? t 'js)))))) + +(def array-types + '#{array objects ints longs floats doubles chars shorts bytes boolean}) + +(defn array-type? + #?(:cljs {:tag boolean}) + [t] + ;; TODO same inference caveats as the numeric-type? fn above + (cond + (nil? t) true + (= 'clj-nil t) true + (js-tag? t) true ;; TODO: revisit + (= 'any t) true + (contains? array-types t) true + :else + (boolean + (when #?(:clj (set? t) + :cljs (impl/cljs-set? t)) + (or (contains? t 'any) + (contains? t 'js) + (some array-types t)))))) + +(defn- analyze-js-star-args [js-op env args] + (first (reduce + (fn [[argexprs env] arg] + [(conj argexprs (analyze env arg)) + (if (= js-op 'cljs.core/and) + (set-test-induced-tags env arg) + env)]) + [[] env] + args))) + +(defn analyze-js-star* [env jsform args form] + (let [enve (assoc env :context :expr) + form-meta (meta form) + segs (js-star-seg jsform) + tag (get-js-tag form) + js-op (:js-op form-meta) + argexprs (analyze-js-star-args js-op enve args) + numeric (:numeric form-meta) + validate (fn [warning-type valid-types?] + (let [types (map #(infer-tag env %) argexprs)] + (when-not (valid-types? types) + (warning warning-type env + {:js-op js-op + :types (into [] types)})))) + op-match? (fn [sym] + #?(:clj (= sym (:js-op form-meta)) + :cljs (symbol-identical? sym (:js-op form-meta))))] + (when (true? numeric) + (validate :invalid-arithmetic #(every? numeric-type? %))) + {:op :js + :env env + :segs segs + :args argexprs + :tag tag + :form form + :children [:args] + :js-op js-op + :numeric numeric})) + +(defn analyze-js-star [env jsform args form] + (disallowing-recur (analyze-js-star* env jsform args form))) + +(defmethod parse 'js* + [op env [_ jsform & args :as form] _ _] + (when-not (string? jsform) + (throw (error env "Invalid js* form"))) + (if (some? args) + (analyze-js-star env jsform args form) + (let [code (apply str (js-star-interp env jsform)) + tag (get-js-tag form) + form-meta (meta form) + js-op (:js-op form-meta) + numeric (:numeric form-meta)] + {:op :js + :env env + :form form + :code code + :tag tag + :js-op js-op + :numeric numeric}))) + +;; TODO: analyzed analyzed? should take pass name as qualified keyword arg +;; then compiler passes can mark/check individually - David + +(defn- unsorted-map? [x] + (and (map? x) + (not (sorted? x)))) + +(defn analyzed + "Mark a form as being analyzed. Assumes x satisfies IMeta. Useful to suppress + warnings that will have been caught by a first compiler pass." + [x] + (cond + (unsorted-map? x) (assoc x ::analyzed true) + :else (vary-meta x assoc ::analyzed true))) + +(defn analyzed? + "Returns boolean if the form has already been marked as analyzed." + #?(:cljs {:tag boolean}) + [x] + (boolean + (cond + (unsorted-map? x) (::analyzed x) + :else (::analyzed (meta x))))) + +(defn- all-values? + #?(:cljs {:tag boolean}) + [exprs] + (every? #(or (nil? %) (symbol? %) (string? %) (number? %) (true? %) (false? %)) exprs)) + +(defn- valid-arity? + #?(:cljs {:tag boolean}) + [argc method-params] + (or (nil? method-params) ; Assume valid if method-params unavailable + (boolean (some #{argc} (map count method-params))))) + +(defn- record-tag? + [tag] + (boolean (and (symbol? tag) + (some? (namespace tag)) + (get-in @env/*compiler* [::namespaces (symbol (namespace tag)) :defs (symbol (name tag)) :record])))) + +(defn- record-basis + [tag] + (let [positional-factory (symbol (str "->" (name tag))) + fields (first (get-in @env/*compiler* [::namespaces (symbol (namespace tag)) :defs positional-factory :method-params]))] + (into #{} fields))) + +(defn- record-with-field? + [tag field] + (and (record-tag? tag) + (contains? (record-basis tag) field))) + +(defn- invalid-arity? [argc method-params variadic max-fixed-arity] + (and (not (valid-arity? argc method-params)) + (or (not variadic) + (and variadic (< argc max-fixed-arity))))) + +(defn parse-invoke* + [env [f & args :as form]] + (let [enve (assoc env :context :expr) + fexpr (analyze enve f) + argc (count args) + fn-var? (or (-> fexpr :info :fn-var) + (-> fexpr :info :js-fn-var)) + kw? (= 'cljs.core/Keyword (:tag fexpr)) + cur-ns (-> env :ns :name) + HO-invoke? (and (boolean *cljs-static-fns*) + (not fn-var?) + (not (js-tag? f)) + (not kw?) + (not (analyzed? f))) + ;; function expressions, eg: ((deref m) x) or ((:x m) :a) + bind-f-expr? (and HO-invoke? + (not (symbol? f))) + ;; Higher order invokes with (some) argument expressions. Bind the arguments + ;; to avoid exponential complexity that is created by the IFn arity check branch. + bind-args? (and HO-invoke? + (not (all-values? args)))] + (when ^boolean fn-var? + (let [{^boolean variadic :variadic? :keys [max-fixed-arity method-params name ns macro]} (:info fexpr)] + ;; don't warn about invalid arity when when compiling a macros namespace + ;; that requires itself, as that code is not meant to be executed in the + ;; `$macros` ns - António Monteiro + (when (and #?(:cljs (not (and (gstring/endsWith (str cur-ns) "$macros") + (symbol-identical? cur-ns ns) + (true? macro)))) + (invalid-arity? argc method-params variadic max-fixed-arity)) + (warning :fn-arity env {:name name :argc argc})))) + (when (and kw? (not (or (== 1 argc) (== 2 argc)))) + (warning :fn-arity env {:name (first form) :argc argc})) + (let [deprecated? (-> fexpr :info :deprecated) + no-warn? (-> form meta :deprecation-nowarn)] + (when (and (boolean deprecated?) + (not (boolean no-warn?))) + (warning :fn-deprecated env {:fexpr fexpr}))) + (when (some? (-> fexpr :info :type)) + (warning :invoke-ctor env {:fexpr fexpr})) + (if (or bind-args? bind-f-expr?) + (let [arg-syms (when bind-args? (take argc (repeatedly gensym))) + f-sym (when bind-f-expr? (gensym "fexpr__")) + bindings (cond-> [] + bind-args? (into (interleave arg-syms args)) + bind-f-expr? (conj f-sym (analyzed f))) + tag (:tag (meta form))] + (analyze env + `(let [~@bindings] + ~(with-meta + `(~(analyzed (if bind-f-expr? f-sym f)) + ~@(if bind-args? arg-syms args)) + {:tag tag})))) + (let [ana-expr #(analyze enve %) + argexprs (mapv ana-expr args)] + (if (and (and (keyword? f) + (nil? (namespace f))) + (== 1 (count args)) + (record-with-field? (:tag (first argexprs)) (symbol (name f)))) + (let [field-access-form (list* (symbol (str ".-" (name f))) args)] + (no-warn (analyze env field-access-form))) + {:env env :op :invoke :form form :fn fexpr :args argexprs + :children [:fn :args]}))))) + +(defn parse-invoke + [env form] + (disallowing-recur (parse-invoke* env form))) + +(defn desugar-dotted-expr [{:keys [op] :as expr}] + (case op + (:var :local) (if (dotted-symbol? (symbol (name (:name expr)))) + (let [s (name (:name expr)) + idx (.lastIndexOf s ".") + _ (assert (not= (inc idx) (count s))) + prefix (with-meta (symbol (namespace (:name expr)) (subs s 0 idx)) + (meta (:form expr))) + field (symbol (subs s (inc idx)))] + (assert (not (:const-expr expr))) + {:op :host-field + :env (:env expr) + :form (list '. prefix field) + :target (desugar-dotted-expr (-> expr + (assoc :name prefix + :form prefix) + (dissoc :tag) + (assoc-in [:info :name] prefix) + (assoc-in [:env :context] :expr))) + :field field + :tag (:tag expr) + :children [:target]}) + expr) + ;:var + expr)) + + +(defn analyze-symbol + "Finds the var associated with sym" + [env sym] + (if ^boolean (:quoted? env) + (do + (register-constant! env sym) + (analyze-wrap-meta {:op :const :val sym :env env :form sym :tag 'cljs.core/Symbol})) + (let [{:keys [line column]} (meta sym) + env (if-not (nil? line) + (assoc env :line line) + env) + env (if-not (nil? column) + (assoc env :column column) + env) + ret {:env env :form sym} + lcls (:locals env)] + (if-some [lb (handle-symbol-local sym (get lcls sym))] + (merge + (assoc ret :op :local :info lb) + ;; this is a temporary workaround for core.async see CLJS-3030 - David + (when (map? lb) + (select-keys lb [:name :local :arg-id :variadic? :init]))) + (let [sym-meta (meta sym) + sym-ns (namespace sym) + cur-ns (str (-> env :ns :name)) + ;; when compiling a macros namespace that requires itself, we need + ;; to resolve calls to `my-ns.core/foo` to `my-ns.core$macros/foo` + ;; to avoid undeclared variable warnings - António Monteiro + #?@(:cljs [sym (if (and sym-ns + (not= sym-ns "cljs.core") + (gstring/endsWith cur-ns "$macros") + (not (gstring/endsWith sym-ns "$macros")) + (= sym-ns (subs cur-ns 0 (- (count cur-ns) 7)))) + (symbol (str sym-ns "$macros") (name sym)) + sym)]) + info (if-not (contains? sym-meta ::analyzed) + (resolve-existing-var env sym) + (resolve-var env sym))] + (assert (:op info) (:op info)) + (desugar-dotted-expr + (if-not (true? (:def-var env)) + (merge + (assoc ret :info info) + (select-keys info [:op :name :ns :tag]) + (when-let [const-expr (:const-expr info)] + {:const-expr const-expr})) + (let [info (resolve-var env sym)] + (merge (assoc ret :op :var :info info) + (select-keys info [:op :name :ns :tag])))))))))) + +(defn excluded? + #?(:cljs {:tag boolean}) + [env sym] + (or (some? (gets env :ns :excludes sym)) + (some? (gets @env/*compiler* ::namespaces (gets env :ns :name) :excludes sym)))) + +(defn used? + #?(:cljs {:tag boolean}) + [env sym] + (or (some? (gets env :ns :use-macros sym)) + (some? (gets @env/*compiler* ::namespaces (gets env :ns :name) :use-macros sym)))) + +(defn get-expander-ns [env ^String nstr] + ;; first check for clojure.* -> cljs.* cases + (let [res (or (resolve-macro-ns-alias env nstr nil) + (resolve-ns-alias env nstr nil)) + nstr (if (some? res) (str res) nstr)] + (cond + #?@(:clj [(= "clojure.core" nstr) (find-ns 'cljs.core)] + :cljs [(identical? "clojure.core" nstr) (find-macros-ns impl/CLJS_CORE_MACROS_SYM)]) + #?@(:clj [(= "clojure.repl" nstr) (find-ns 'cljs.repl)] + :cljs [(identical? "clojure.repl" nstr) (find-macros-ns 'cljs.repl)]) + #?@(:clj [(.contains nstr ".") (find-ns (symbol nstr))] + :cljs [(goog.string/contains nstr ".") (find-macros-ns (symbol nstr))]) + :else (some-> env :ns :require-macros (get (symbol nstr)) #?(:clj find-ns + :cljs find-macros-ns))))) + +(defn get-expander* [sym env] + (when-not (or (some? (gets env :locals sym)) ; locals hide macros + (and (excluded? env sym) (not (used? env sym)))) + (let [nstr (namespace sym)] + (cond + (some? nstr) + (let [ns (get-expander-ns env nstr)] + (when (some? ns) + (.findInternedVar ^clojure.lang.Namespace ns (symbol (name sym))))) + + (some? (gets env :ns :rename-macros sym)) + (let [qualified-symbol (gets env :ns :rename-macros sym) + nsym (symbol (namespace qualified-symbol)) + sym (symbol (name qualified-symbol))] + (.findInternedVar ^clojure.lang.Namespace + #?(:clj (find-ns nsym) :cljs (find-macros-ns nsym)) sym)) + + :else + (let [nsym (gets env :ns :use-macros sym)] + (if (and (some? nsym) (symbol? nsym)) + (.findInternedVar ^clojure.lang.Namespace + #?(:clj (find-ns nsym) :cljs (find-macros-ns nsym)) sym) + (.findInternedVar ^clojure.lang.Namespace + #?(:clj (find-ns 'cljs.core) :cljs (find-macros-ns impl/CLJS_CORE_MACROS_SYM)) sym))))))) + +(defn get-expander + "Given a sym, a symbol identifying a macro, and env, an analysis environment + return the corresponding Clojure macroexpander." + [sym env] + (let [mvar (get-expander* sym env)] + (when (and (some? mvar) + #?(:clj (.isMacro ^clojure.lang.Var mvar) + :cljs ^boolean (.isMacro mvar))) + mvar))) + +#?(:cljs + (let [cached-var (delay (get (ns-interns* 'cljs.spec.alpha) 'macroexpand-check))] + (defn get-macroexpand-check-var [] + (when (some? (find-ns-obj 'cljs.spec.alpha)) + @cached-var)))) + +(defn- var->sym [var] + #?(:clj (symbol (str (.-ns ^clojure.lang.Var var)) (str (.-sym ^clojure.lang.Var var))) + :cljs (.-sym var))) + +(defn- do-macroexpand-check + [env form mac-var] + (when (not (-> @env/*compiler* :options :spec-skip-macros)) + (let [mchk #?(:clj (some-> (find-ns 'clojure.spec.alpha) + (ns-resolve 'macroexpand-check)) + :cljs (get-macroexpand-check-var))] + (when (some? mchk) + (try + (mchk mac-var (next form)) + (catch #?(:clj Throwable :cljs :default) e + (throw (ex-info nil (error-data env :macro-syntax-check (var->sym mac-var)) e)))))))) + +#?(:cljs + (defn- check-macro-arity [mac-var form] + (let [mac-sym (.-sym mac-var)] + (when-let [{:keys [variadic? max-fixed-arity method-params]} + (get-in @env/*compiler* [::namespaces (symbol (namespace mac-sym)) :defs (symbol (name mac-sym))])] + (let [argc (count (rest form)) + offset (if (= '&form (ffirst method-params)) 2 0)] + (when (invalid-arity? argc (map #(nthrest %1 offset) method-params) + variadic? (when max-fixed-arity (- max-fixed-arity offset))) + (throw (js/Error. (error-message :fn-arity {:argc argc, :name mac-sym}))))))))) + +(defn macroexpand-1* + [env form] + (let [op (first form)] + (if (contains? specials op) + (do + (when (= 'ns op) + (do-macroexpand-check env form (get-expander 'cljs.core/ns-special-form env))) + form) + ;else + (if-some [mac-var (when (symbol? op) (get-expander op env))] + (#?@(:clj [binding [*ns* (create-ns *cljs-ns*)]] + :cljs [do]) + (do-macroexpand-check env form mac-var) + (let [form' (try + #?(:cljs (check-macro-arity mac-var form)) + (apply @mac-var form env (rest form)) + #?(:clj (catch ArityException e + (throw (ArityException. (- (.actual e) 2) (.name e))))) + (catch #?(:clj Throwable :cljs :default) e + (throw (ex-info nil (error-data env :macroexpansion (var->sym mac-var)) e))))] + (if #?(:clj (seq? form') :cljs (impl/cljs-seq? form')) + (let [sym' (first form') + sym (first form)] + (if #?(:clj (= sym' 'js*) + :cljs (symbol-identical? sym' impl/JS_STAR_SYM)) + (let [sym (if (some? (namespace sym)) + sym + (symbol "cljs.core" (str sym))) + js-op {:js-op sym} + numeric #?(:clj (-> mac-var meta ::numeric) + :cljs (let [mac-var-ns (symbol (namespace (.-sym mac-var))) + mac-var-name (symbol (name (.-sym mac-var)))] + (get-in @env/*compiler* + [::namespaces mac-var-ns :defs mac-var-name :meta ::numeric]))) + js-op (if (true? numeric) + (assoc js-op :numeric true) + js-op)] + (vary-meta form' merge js-op)) + form')) + form'))) + (if (symbol? op) + (let [opname (str op)] + (cond + (identical? \. + #?(:clj (first opname) + :cljs (.charAt opname 0))) + (let [[target & args] (next form)] + (with-meta (list* #?(:clj '. :cljs impl/DOT_SYM) target (symbol (subs opname 1)) args) + (meta form))) + + (identical? \. + #?(:clj (last opname) + :cljs (.charAt opname (dec (. opname -length))))) + (with-meta + (list* #?(:clj 'new :cljs impl/NEW_SYM) (symbol (subs opname 0 (dec (count opname)))) (next form)) + (meta form)) + + :else form)) + form))))) + +(defn macroexpand-1 + "Given a env, an analysis environment, and form, a ClojureScript form, + macroexpand the form once." + [env form] + (wrapping-errors env (macroexpand-1* env form))) + +(declare analyze-list) + +(defn analyze-seq* [op env form name opts] + (if (contains? specials op) + (parse op env form name opts) + (parse-invoke env form))) + +(defn analyze-seq*-wrap [op env form name opts] + (wrapping-errors env + (analyze-seq* op env form name opts))) + +(defn analyze-seq + ([env form name] + (analyze-seq env form name + (when env/*compiler* + (:options @env/*compiler*)))) + ([env form name opts] + (if ^boolean (:quoted? env) + (analyze-list env form) + (let [line (-> form meta :line) + line (if (nil? line) + (:line env) + line) + col (-> form meta :column) + col (if (nil? col) + (:column env) + col) + env (assoc env :line line :column col)] + (let [op (first form)] + (when (nil? op) + (throw (error env "Can't call nil"))) + (let [mform (macroexpand-1 env form)] + (if (identical? form mform) + (analyze-seq*-wrap op env form name opts) + (analyze env mform name opts)))))))) + +(defn analyze-map + [env form] + (let [expr-env (assoc env :context :expr) + ks (disallowing-recur (mapv #(analyze expr-env %) (keys form))) + vs (disallowing-recur (mapv #(analyze expr-env %) (vals form)))] + (analyze-wrap-meta {:op :map :env env :form form + :keys ks :vals vs + :children [:keys :vals] + :tag 'cljs.core/IMap}))) + +;; :list is not used in the emitter any more, but analyze-list is called from analyze-const +;; to hit the `register-constant!` cases for symbols and keywords. +(defn analyze-list + [env form] + (let [expr-env (assoc env :context :expr) + items (disallowing-recur (mapv #(analyze expr-env %) form))] + (analyze-wrap-meta {:op :list :env env :form form :items items :children [:items] :tag 'cljs.core/IList}))) + +(defn analyze-vector + [env form] + (let [expr-env (assoc env :context :expr) + items (disallowing-recur (mapv #(analyze expr-env %) form))] + (analyze-wrap-meta {:op :vector :env env :form form :items items :children [:items] :tag 'cljs.core/IVector}))) + +(defn analyze-set + [env form] + (let [expr-env (assoc env :context :expr) + items (disallowing-recur (mapv #(analyze expr-env %) form))] + (analyze-wrap-meta {:op :set :env env :form form :items items :children [:items] :tag 'cljs.core/ISet}))) + +(defn analyze-js-value + [env ^JSValue form] + (let [val (.-val form) + expr-env (assoc env :context :expr)] + (if (map? val) + (let [keys (vec (keys val)) + vals (disallowing-recur + (mapv #(analyze expr-env %) (vals val)))] + {:op :js-object + :env env + :form form + :keys keys + :vals vals + :children [:vals] + :tag 'object}) + (let [items (disallowing-recur + (mapv #(analyze expr-env %) val))] + {:op :js-array + :env env + :form form + :items items + :children [:items] + :tag 'array})))) + +(defn record-ns+name [x] + (map symbol + #?(:clj + ((juxt (comp #(string/join "." %) butlast) last) + (string/split (.getName ^Class (type x)) #"\.")) + :cljs + (string/split (pr-str (type x)) #"/")))) + +(defn analyze-record + [env x] + (let [;; register constansts + _items_ (disallowing-recur + (analyze (assoc env :context :expr) (into {} x))) + [ns name] (record-ns+name x)] + {:op :const + :val x + :env env + :form x + :tag (symbol (str ns) (str name))})) + +(defn elide-reader-meta [m] + (dissoc m :file :line :column :end-column :end-line :source)) + +(defn elide-analyzer-meta [m] + (dissoc m ::analyzed)) + +(defn elide-irrelevant-meta [m] + (-> m elide-reader-meta elide-analyzer-meta)) + +(defn analyze-wrap-meta [expr] + (let [form (:form expr) + m (elide-irrelevant-meta (meta form))] + (if (some? (seq m)) + (let [env (:env expr) ; take on expr's context ourselves + expr (assoc-in expr [:env :context] :expr) ; change expr to :expr + meta-expr (analyze-map (:env expr) m)] + {:op :with-meta :env env :form form + :meta meta-expr :expr expr :children [:meta :expr]}) + expr))) + +(defn infer-type [env {:keys [tag] :as ast} _] + (if (or (nil? tag) (= 'function tag)) + ;; infer-type won't get a chance to process :methods + ;; so treat :fn as a special case for now, could probably + ;; fix up to use :children to walk child nodes + (if (= :fn (:op ast)) + (update ast :methods + (fn [ms] (into [] (map #(infer-type env % _)) ms))) + (if-some [tag (infer-tag env ast)] + (assoc ast :tag tag) + ast)) + ast)) + +(defn- repl-self-require? [env deps] + (and (:repl-env env) (some #{*cljs-ns*} deps))) + +#?(:clj + (defn ns-side-effects + [env {:keys [op] :as ast} opts] + (if (#{:ns :ns*} op) + (let [{:keys [name deps uses require-macros use-macros reload reloads]} ast] + (when (and *analyze-deps* (seq deps)) + (analyze-deps + (if (repl-self-require? env deps) 'cljs.user name) + deps env (dissoc opts :macros-ns))) + (if *load-macros* + (do + (load-core) + (doseq [nsym (vals use-macros)] + (let [k (or (:use-macros reload) + (get-in reloads [:use-macros nsym]) + (and (= nsym name) *reload-macros* :reload))] + (if k + (locking load-mutex + (clojure.core/require nsym k)) + (locking load-mutex + (clojure.core/require nsym))) + (intern-macros nsym k))) + (doseq [nsym (vals require-macros)] + (let [k (or (:require-macros reload) + (get-in reloads [:require-macros nsym]) + (and (= nsym name) *reload-macros* :reload))] + (if k + (locking load-mutex + (clojure.core/require nsym k)) + (locking load-mutex + (clojure.core/require nsym))) + (intern-macros nsym k))) + (-> ast + (check-use-macros-inferring-missing env) + (check-rename-macros-inferring-missing env))) + (do + (check-uses + (when (and *analyze-deps* (seq uses)) + (missing-uses uses env)) + env) + ast))) + ast))) + +;; A set of validators that can be used to do static type +;; checking of runtime fns based on inferred argument types. +(def invoke-arg-type-validators + (let [aget-validator {:valid? #(and (array-type? (first %)) + (every? numeric-type? (rest %))) + :warning-type :invalid-array-access} + aset-validator {:valid? #(and (array-type? (first %)) + (every? numeric-type? (butlast (rest %)))) + :warning-type :invalid-array-access}] + {'cljs.core/checked-aget aget-validator + 'cljs.core/checked-aset aset-validator + 'cljs.core/checked-aget' aget-validator + 'cljs.core/checked-aset' aset-validator})) + +(defn check-invoke-arg-types + [env {:keys [op] :as ast} opts] + (when (and (not (analyzed? ast)) + #?(:clj (= :invoke op) + :cljs (keyword-identical? :invoke op))) + (when-some [[name {:keys [valid? warning-type]}] (find invoke-arg-type-validators (-> ast :fn :info :name))] + (let [types (mapv :tag (:args ast))] + (when-not (valid? types) + (warning warning-type env + {:name name + :types types}))))) + (analyzed ast)) + +#?(:clj + (defn analyze-form [env form name opts] + (cond + (symbol? form) (analyze-symbol env form) + (and (seq? form) (seq form)) (analyze-seq env form name opts) + (record? form) (analyze-record env form) + (map? form) (analyze-map env form) + (vector? form) (analyze-vector env form) + (set? form) (analyze-set env form) + (keyword? form) (analyze-keyword env form) + (instance? JSValue form) (analyze-js-value env form) + :else + (let [tag (cond + (nil? form) 'clj-nil + (number? form) 'number + (string? form) 'string + (instance? Character form) 'string + (true? form) 'boolean + (false? form) 'boolean + (= () form) 'cljs.core/IList)] + (cond-> {:op :const :val form :env env :form form} + tag (assoc :tag tag)))))) + +#?(:cljs + (defn analyze-form [env form name opts] + (cond + (symbol? form) (analyze-symbol env form) + (and (impl/cljs-seq? form) (some? (seq form))) (analyze-seq env form name opts) + (record? form) (analyze-record env form) + (impl/cljs-map? form) (analyze-map env form) + (impl/cljs-vector? form) (analyze-vector env form) + (impl/cljs-set? form) (analyze-set env form) + (keyword? form) (analyze-keyword env form) + (instance? cljs.tagged-literals/JSValue form) (analyze-js-value env form) + :else + (let [tag (cond + (nil? form) impl/CLJ_NIL_SYM + (number? form) impl/NUMBER_SYM + (string? form) impl/STRING_SYM + (true? form) impl/BOOLEAN_SYM + (false? form) impl/BOOLEAN_SYM + (= () form) 'cljs.core/IList)] + (cond-> {:op :const :val form :env env :form form} + tag (assoc :tag tag)))))) + +(def default-passes + #?(:clj [infer-type check-invoke-arg-types ns-side-effects] + :cljs [infer-type check-invoke-arg-types])) + +(defn analyze* [env form name opts] + (let [passes *passes* + passes (if (nil? passes) + default-passes + passes) + form (if (instance? LazySeq form) + (if (seq form) form ()) + form) + ast (analyze-form env form name opts)] + (reduce (fn [ast pass] (pass env ast opts)) ast passes))) + +(defn analyze + "Given an environment, a map containing {:locals (mapping of names to bindings), :context + (one of :statement, :expr, :return), :ns (a symbol naming the + compilation ns)}, and form, returns an expression object (a map + containing at least :form, :op and :env keys). If expr has any (immediately) + nested exprs, must have a :children entry. This must be a vector of keywords naming + the immediately nested fields mapped to an expr or vector of exprs. This will + facilitate code walking without knowing the details of the op set." + ([env form] (analyze env form nil)) + ([env form name] + (analyze env form name + (when env/*compiler* + (:options @env/*compiler*)))) + ([env form name opts] + (wrapping-errors env + (if (analyzed? form) + (no-warn (analyze* env form name opts)) + (analyze* env form name opts))))) + +(defn add-consts + "Given a compiler state and a map from fully qualified symbols to constant + EDN values, update the compiler state marking these vars as const to support + direct substitution of these vars in source." + [compiler-state constants-map] + (reduce-kv + (fn [compiler-state sym value] + (let [ns (symbol (namespace sym))] + (update-in compiler-state + [::namespaces ns :defs (symbol (name sym))] merge + {:const-expr + (binding [*passes* (conj *passes* (replace-env-pass {:context :expr}))] + (analyze (empty-env) value))}))) + compiler-state constants-map)) + +#?(:clj + (defn- source-path + "Returns a path suitable for providing to tools.reader as a 'filename'." + [x] + (cond + (instance? File x) (.getAbsolutePath ^File x) + :default (str x)))) + +(defn resolve-symbol [sym] + (if (and (not (namespace sym)) + (dotted-symbol? sym)) + sym + (:name (binding [*private-var-access-nowarn* true] + (resolve-var (assoc @env/*compiler* :ns (get-namespace *cljs-ns*)) + sym))))) + +#?(:clj + (defn forms-seq* + "Seq of Clojure/ClojureScript forms from rdr, a java.io.Reader. Optionally + accepts a filename argument which will be used in any emitted errors." + ([^Reader rdr] (forms-seq* rdr nil)) + ([^Reader rdr filename] + {:pre [(instance? Reader rdr)]} + (let [eof-sentinel (Object.) + opts (merge + {:eof eof-sentinel} + (if (and filename (= (util/ext filename) "cljc")) + {:read-cond :allow :features #{:cljs}})) + pbr (readers/indexing-push-back-reader + (PushbackReader. rdr) 1 filename) + data-readers tags/*cljs-data-readers* + forms-seq_ + (fn forms-seq_ [] + (lazy-seq + (let [form (binding [*ns* (create-ns *cljs-ns*) + reader/*data-readers* data-readers + reader/*alias-map* + (apply merge + ((juxt :requires :require-macros) + (get-namespace *cljs-ns*))) + reader/resolve-symbol resolve-symbol] + (reader/read opts pbr))] + (if (identical? form eof-sentinel) + (.close rdr) + (cons form (forms-seq_))))))] + (forms-seq_))))) + +#?(:clj + (defn forms-seq + "DEPRECATED: Seq of Clojure/ClojureScript forms from [f], which can be anything + for which `clojure.java.io/reader` can produce a `java.io.Reader`. Optionally + accepts a [filename] argument, which the reader will use in any emitted errors." + ([f] (forms-seq f (source-path f))) + ([f filename] (forms-seq f filename false)) + ([f filename return-reader?] + (let [rdr (io/reader f) + pbr (readers/indexing-push-back-reader + (PushbackReader. rdr) 1 filename) + data-readers tags/*cljs-data-readers* + forms-seq* + (fn forms-seq* [] + (lazy-seq + (let [eof-sentinel (Object.) + form (binding [*ns* (create-ns *cljs-ns*) + reader/*data-readers* data-readers + reader/*alias-map* + (apply merge + ((juxt :requires :require-macros) + (get-namespace *cljs-ns*)))] + (reader/read pbr nil eof-sentinel))] + (if (identical? form eof-sentinel) + (.close rdr) + (cons form (forms-seq*))))))] + (if (true? return-reader?) + [(forms-seq*) rdr] + (forms-seq*)))))) + +#?(:clj + (defn gen-user-ns + [src] + (if (sequential? src) + (symbol (str "cljs.user.source$form$" (util/content-sha (pr-str src) 7))) + (let [full-name (str src) + name (.substring full-name + (inc (.lastIndexOf full-name "/")) + (.lastIndexOf full-name "."))] + (symbol (str "cljs.user." name (util/content-sha full-name 7))))))) + +#?(:clj + (defn ^:dynamic parse-ns + "Helper for parsing only the essential namespace information from a + ClojureScript source file and returning a cljs.closure/IJavaScript compatible + map _not_ a namespace AST node. + + By default does not load macros or perform any analysis of dependencies. If + opts parameter provided :analyze-deps and :load-macros keys their values will + be used for *analyze-deps* and *load-macros* bindings respectively. This + function does _not_ side-effect the ambient compilation environment unless + requested via opts where :restore is false." + ([src] + (parse-ns src nil + (when env/*compiler* + (:options @env/*compiler*)))) + ([src opts] (parse-ns src nil opts)) + ([src dest opts] + (ensure + (let [src (if (symbol? src) + (util/ns->source src) + src) + ijs + (binding [env/*compiler* (if (false? (:restore opts)) + env/*compiler* + (atom @env/*compiler*)) + *cljs-ns* 'cljs.user + *cljs-file* src + *macro-infer* + (or (when (contains? opts :macro-infer) + (:macro-infer opts)) + false) + *analyze-deps* + (or (when (contains? opts :analyze-deps) + (:analyze-deps opts)) + false) + *load-macros* + (or (when (contains? opts :load-macros) + (:load-macros opts)) + false)] + (let [rdr (when-not (sequential? src) (io/reader src))] + (try + (loop [forms (if rdr + (forms-seq* rdr (source-path src)) + src) + ret (merge + {:file dest + :source-file (when rdr src) + :source-forms (when-not rdr src) + :macros-ns (:macros-ns opts) + :requires (cond-> #{'cljs.core} + (get-in @env/*compiler* [:options :emit-constants]) + (conj constants-ns-sym))} + (when (and dest (.exists ^File dest)) + {:lines (with-open [reader (io/reader dest)] + (-> reader line-seq count))}))] + (if (seq forms) + (let [env (empty-env) + ast (no-warn (analyze env (first forms) nil opts))] + (cond + (= :ns (:op ast)) + (let [ns-name (:name ast) + ns-name (if (and (= 'cljs.core ns-name) + (= "cljc" (util/ext src))) + 'cljs.core$macros + ns-name) + deps (merge (:uses ast) (:requires ast))] + (merge + {:ns (or ns-name 'cljs.user) + :provides [ns-name] + :requires (if (= 'cljs.core ns-name) + (set (vals deps)) + (cond-> (conj (set (vals deps)) 'cljs.core) + (get-in @env/*compiler* [:options :emit-constants]) + (conj constants-ns-sym))) + :file dest + :source-file (when rdr src) + :source-forms (when-not rdr src) + :ast ast + :macros-ns (or (:macros-ns opts) + (= 'cljs.core$macros ns-name))} + (when (and dest (.exists ^File dest)) + {:lines (with-open [reader (io/reader dest)] + (-> reader line-seq count))}))) + + (= :ns* (:op ast)) + (let [deps (merge (:uses ast) (:requires ast))] + (recur (rest forms) + (cond-> (update-in ret [:requires] into (set (vals deps))) + ;; we need to defer generating the user namespace + ;; until we actually need or it will break when + ;; `src` is a sequence of forms - António Monteiro + (not (:ns ret)) + (assoc :ns (gen-user-ns src) :provides [(gen-user-ns src)])))) + + :else ret)) + ret)) + (finally + (when rdr + (.close ^Reader rdr))))))] + (cond-> ijs + (not (contains? ijs :ns)) + (merge + {:ns (gen-user-ns src) + :provides [(gen-user-ns src)]}))))))) + +#?(:clj + (defn- cache-analysis-ext + ([] (cache-analysis-ext (get-in @env/*compiler* [:options :cache-analysis-format] :transit))) + ([format] + (if (and (= format :transit) @transit) "json" "edn")))) + +#?(:clj + (defn build-affecting-options [opts] + (select-keys opts + [:static-fns :fn-invoke-direct :optimize-constants :elide-asserts :target :nodejs-rt + :cache-key :checked-arrays :language-out]))) + +#?(:clj + (defn build-affecting-options-sha [path opts] + (let [m (assoc (build-affecting-options opts) :path path)] + (util/content-sha (pr-str m) 7)))) + +#?(:clj + (defn ^File cache-base-path + ([path] + (cache-base-path path nil)) + ([path opts] + (io/file (System/getProperty "user.home") + ".cljs" ".aot_cache" (util/clojurescript-version) + (build-affecting-options-sha path opts))))) + +#?(:clj + (defn cacheable-files + ([rsrc ext] + (cacheable-files rsrc ext nil)) + ([rsrc ext opts] + (let [{:keys [ns]} (parse-ns rsrc) + path (cache-base-path (util/path rsrc) opts) + name (util/ns->relpath ns nil File/separatorChar)] + (into {} + (map + (fn [[k v]] + [k (io/file path + (if (and (= (str "cljs" File/separatorChar "core$macros") name) + (= :source k)) + (str "cljs" File/separatorChar "core.cljc") + (str name v)))])) + {:source (str "." ext) + :output-file ".js" + :source-map ".js.map" + :analysis-cache-edn (str "." ext ".cache.edn") + :analysis-cache-json (str "." ext ".cache.json")}))))) + +#?(:clj + (defn cache-file + "Given a ClojureScript source file returns the read/write path to the analysis + cache file. Defaults to the read path which is usually also the write path." + ([src] (cache-file src "out")) + ([src output-dir] (cache-file src (parse-ns src) output-dir)) + ([src ns-info output-dir] + (cache-file src ns-info output-dir :read nil)) + ([src ns-info output-dir mode] + (cache-file src ns-info output-dir mode nil)) + ([src ns-info output-dir mode opts] + {:pre [(map? ns-info)]} + (let [ext (cache-analysis-ext)] + (if-let [core-cache + (and (= mode :read) + (= (:ns ns-info) 'cljs.core) + (io/resource (str "cljs/core.cljs.cache.aot." ext)))] + core-cache + (let [aot-cache-file + (when (util/url? src) + ((keyword (str "analysis-cache-" ext)) + (cacheable-files src (util/ext src) opts)))] + (if (and aot-cache-file (.exists ^File aot-cache-file)) + aot-cache-file + (let [target-file (util/to-target-file output-dir ns-info + (util/ext (:source-file ns-info)))] + (io/file (str target-file ".cache." ext)))))))))) + +#?(:clj + (defn requires-analysis? + "Given a src, a resource, and output-dir, a compilation output directory + return true or false depending on whether src needs to be (re-)analyzed. + Can optionally pass cache, the analysis cache file." + ([src] (requires-analysis? src "out")) + ([src output-dir] + (let [cache (cache-file src output-dir)] + (requires-analysis? src cache output-dir nil))) + ([src cache output-dir] + (requires-analysis? src cache output-dir nil)) + ([src cache output-dir opts] + (cond + (util/url? cache) + (let [path (.getPath ^URL cache)] + (if (or (.endsWith path "cljs/core.cljs.cache.aot.edn") + (.endsWith path "cljs/core.cljs.cache.aot.json")) + false + (throw (Exception. (str "Invalid anlaysis cache, must be file not URL " cache))))) + + (and (util/file? cache) + (not (.exists ^File cache))) + true + + :else + (let [out-src (util/to-target-file output-dir (parse-ns src)) + cache-src (:output-file (cacheable-files src (util/ext src) opts))] + (if (and (not (.exists out-src)) + (not (.exists ^File cache-src))) + true + (or (not cache) (util/changed? src cache)))))))) + +#?(:clj + (defn- get-spec-vars + [] + (when-let [spec-ns (find-ns 'cljs.spec.alpha)] + (locking load-mutex + {:registry-ref (ns-resolve spec-ns 'registry-ref) + :speced-vars (ns-resolve spec-ns '_speced_vars)}))) + :cljs + (let [registry-ref (delay (get (ns-interns* 'cljs.spec.alpha$macros) 'registry-ref)) + ;; Here, we look up the symbol '-speced-vars because ns-interns* + ;; is implemented by invoking demunge on the result of js-keys. + speced-vars (delay (get (ns-interns* 'cljs.spec.alpha$macros) '-speced-vars))] + (defn- get-spec-vars [] + (when (some? (find-ns-obj 'cljs.spec.alpha$macros)) + {:registry-ref @registry-ref + :speced-vars @speced-vars})))) + +(defn dump-specs + "Dumps registered speced vars for a given namespace into the compiler + environment." + [ns] + (let [spec-vars (get-spec-vars) + ns-str (str ns)] + (swap! env/*compiler* update-in [::namespaces ns] + merge + (when-let [registry-ref (:registry-ref spec-vars)] + {:cljs.spec/registry-ref + (into [] + (filter (fn [[k _]] (= ns-str (namespace k)))) + @@registry-ref)}) + (when-let [speced-vars (:speced-vars spec-vars)] + {:cljs.spec/speced-vars + (into [] + (filter + (fn [v] + (or (= ns-str (namespace v)) + (= ns (-> v meta :fdef-ns))))) + @@speced-vars)})))) + +(defn register-specs + "Registers speced vars found in a namespace analysis cache." + [cached-ns] + #?(:clj (try + (locking load-mutex + (clojure.core/require 'cljs.spec.alpha)) + (catch Throwable t))) + (let [{:keys [registry-ref speced-vars]} (get-spec-vars)] + (when-let [registry (seq (:cljs.spec/registry-ref cached-ns))] + (when registry-ref + (swap! @registry-ref into registry))) + (when-let [vars (seq (:cljs.spec/speced-vars cached-ns))] + (when speced-vars + (swap! @speced-vars into vars))))) + +#?(:clj + (defn write-analysis-cache + ([ns cache-file] + (write-analysis-cache ns cache-file nil)) + ([ns ^File cache-file src] + (util/mkdirs cache-file) + (dump-specs ns) + (let [ext (util/ext cache-file) + analysis (dissoc (get-in @env/*compiler* [::namespaces ns]) :macros)] + (case ext + "edn" (spit cache-file + (str ";; Analyzed by ClojureScript " (util/clojurescript-version) "\n" + (pr-str analysis))) + "json" (when-let [{:keys [writer write]} @transit] + (with-open [os (io/output-stream cache-file)] + (write (writer os :json transit-write-opts) analysis))))) + (when src + (.setLastModified ^File cache-file (util/last-modified src)))))) + +#?(:clj + (defn read-analysis-cache + ([cache-file src] + (read-analysis-cache cache-file src nil)) + ([^File cache-file src opts] + ;; we want want to keep dependency analysis information + ;; don't revert the environment - David + (let [{:keys [ns]} (parse-ns src + (merge opts + {:restore false + :analyze-deps true + :load-macros true})) + ext (util/ext cache-file) + cached-ns (case ext + "edn" (edn/read-string (slurp cache-file)) + "json" (let [{:keys [reader read]} @transit] + (with-open [is (io/input-stream cache-file)] + (read (reader is :json transit-read-opts)))))] + (when (or *verbose* (:verbose opts)) + (util/debug-prn "Reading analysis cache for" (str src))) + (swap! env/*compiler* + (fn [cenv] + (do + (register-specs cached-ns) + (doseq [x (get-in cached-ns [::constants :order])] + (register-constant! x)) + (-> cenv + (assoc-in [::namespaces ns] cached-ns))))))))) + +(defn analyze-form-seq + ([forms] + (analyze-form-seq forms + (when env/*compiler* + (:options @env/*compiler*)))) + ([forms opts] + (analyze-form-seq forms opts false)) + ([forms opts return-last?] + (let [env (assoc (empty-env) :build-options opts)] + (binding [*file-defs* nil + #?@(:clj [*unchecked-if* false + *unchecked-arrays* false]) + *cljs-ns* 'cljs.user + *cljs-file* nil + reader/*alias-map* (or reader/*alias-map* {})] + (loop [ns nil forms forms last-ast nil] + (if (some? forms) + (let [form (first forms) + env (assoc env :ns (get-namespace *cljs-ns*)) + ast (analyze env form nil opts)] + (if (= (:op ast) :ns) + (recur (:name ast) (next forms) ast) + (recur ns (next forms) ast))) + (if return-last? + last-ast + ns))))))) + +(defn ensure-defs + "Ensures that a non-nil defs map exists in the compiler state for a given + ns. (A non-nil defs map signifies that the namespace has been analyzed.)" + [ns] + (swap! env/*compiler* update-in [::namespaces ns :defs] #(or % {}))) + +#?(:clj + (defn analyze-file + "Given a java.io.File, java.net.URL or a string identifying a resource on the + classpath attempt to analyze it. + + This function side-effects the ambient compilation environment + `cljs.env/*compiler*` to aggregate analysis information. opts argument is + compiler options, if :cache-analysis true will cache analysis to + \":output-dir/some/ns/foo.cljs.cache.edn\". This function does not return a + meaningful value." + ([f] + (analyze-file f + (when env/*compiler* + (:options @env/*compiler*)))) + ([f opts] + (analyze-file f false opts)) + ([f skip-cache opts] + (binding [*file-defs* (atom #{}) + *unchecked-if* false + *unchecked-arrays* false + *cljs-warnings* *cljs-warnings*] + (let [output-dir (util/output-directory opts) + res (cond + (instance? File f) f + (instance? URL f) f + (re-find #"^file://" f) (URL. f) + :else (io/resource f))] + (assert res (str "Can't find " f " in classpath")) + (ensure + (let [ns-info (parse-ns res) + path (if (instance? File res) + (.getPath ^File res) + (.getPath ^URL res)) + cache (when (:cache-analysis opts) + (cache-file res ns-info output-dir :read opts))] + (when-not (get-in @env/*compiler* [::namespaces (:ns ns-info) :defs]) + (if (or skip-cache (not cache) (requires-analysis? res cache output-dir opts)) + (binding [*cljs-ns* 'cljs.user + *cljs-file* path + reader/*alias-map* (or reader/*alias-map* {})] + (when (or *verbose* (:verbose opts)) + (util/debug-prn "Analyzing" (str res))) + (let [env (assoc (empty-env) :build-options opts) + ns (with-open [rdr (io/reader res)] + (loop [ns nil forms (seq (forms-seq* rdr (util/path res)))] + (if forms + (let [form (first forms) + env (assoc env :ns (get-namespace *cljs-ns*)) + ast (analyze env form nil opts)] + (cond + (= (:op ast) :ns) + (recur (:name ast) (next forms)) + + (and (nil? ns) (= (:op ast) :ns*)) + (recur (gen-user-ns res) (next forms)) + + :else + (recur ns (next forms)))) + ns)))] + (ensure-defs ns) + (when (and cache (true? (:cache-analysis opts))) + (write-analysis-cache ns cache res)))) + (try + (read-analysis-cache cache res opts) + (catch Throwable e + (analyze-file f true opts)))))))))))) diff --git a/test/rewrite_clj/zip/walk_test.cljc b/test/rewrite_clj/zip/walk_test.cljc index b168bba6..60e2ace6 100644 --- a/test/rewrite_clj/zip/walk_test.cljc +++ b/test/rewrite_clj/zip/walk_test.cljc @@ -155,9 +155,9 @@ (deftest t-zipper-tree-larger-walks (doseq [larger-sample [;; 11876 lines - "https://raw.githubusercontent.com/clojure/clojurescript/fa4b8d853be08120cb864782e4ea48826b9d757e/src/main/cljs/cljs/core.cljs" + "test-resources/code-samples/clojurescript/fa4b8d853be08120cb864782e4ea48826b9d757e/src/main/cljs/cljs/core.cljs" ;; 4745 lines - "https://raw.githubusercontent.com/clojure/clojurescript/fa4b8d853be08120cb864782e4ea48826b9d757e/src/main/clojure/cljs/analyzer.cljc"]] + "test-resources/code-samples/clojurescript/fa4b8d853be08120cb864782e4ea48826b9d757e/src/main/clojure/cljs/analyzer.cljc"]] (let [s (slurp larger-sample)] (is (= s (walker z/postwalk s)) "postwalk") (is (= s (walker z/prewalk s)) "prewalk")))))