+
+YourKit has given an open source license for their profiler, greatly simplifying the profiling of ClojureScript performance.
+
+YourKit supports open source projects with its full-featured Java Profiler.
+YourKit, LLC is the creator of YourKit Java Profiler
+and YourKit .NET Profiler,
+innovative and intelligent tools for profiling Java and .NET applications.
## License ##
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)
+ Public License 1.0 (https://opensource.org/license/epl-1-0/)
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
diff --git a/appveyor.yml b/appveyor.yml
new file mode 100644
index 0000000000..6ed0cdaba6
--- /dev/null
+++ b/appveyor.yml
@@ -0,0 +1,52 @@
+image: Visual Studio 2017
+
+environment:
+ nodejs_version: "6"
+
+platform:
+ - x64
+
+configuration:
+ - Release
+
+matrix:
+ allow_failures:
+ - platform: x64
+ configuration: Release
+
+cache:
+ - '%UserProfile%\.m2'
+
+install:
+ # these need to have a line in between because of Windows line endings
+ - ps: >-
+ New-Item c:\scripts -type directory
+
+ $env:Path += ";C:\scripts"
+
+ Invoke-WebRequest -Uri https://raw.githubusercontent.com/technomancy/leiningen/stable/bin/lein.bat -OutFile "C:\scripts\lein.bat"
+
+ lein self-install
+
+ lein version
+ - ps: Install-Product node $env:nodejs_version x64
+ - ps: wget 'http://ftp.mozilla.org/pub/firefox/nightly/latest-mozilla-central/jsshell-win64.zip' -OutFile "$pwd\jsshell.zip"
+ - ps: 7z x "-o$pwd\jsshell" jsshell.zip -r
+ - ps: wget 'https://aka.ms/chakracore/cc_windows_all_1_8_1' -OutFile "$pwd\chakra-core.zip"
+ - ps: 7z x "-o$pwd\chakra-core" chakra-core.zip -r
+ - ps: .\script\bootstrap.ps1
+ - ps: "[Console]::OutputEncoding = [Text.UTF8Encoding]::UTF8"
+ - ps: $env:SPIDERMONKEY_HOME = "$pwd/jsshell"
+ - ps: $SPIDERMONKEY_HOME = "$pwd/jsshell"
+ - ps: $env:CHAKRACORE_HOME = "$pwd/chakra-core/x64_release"
+ - ps: $CHAKRACORE_HOME = "$pwd/chakra-core/x64_release"
+
+test_script:
+ - cmd: lein test
+ - cmd: powershell -noninteractive -noprofile -command .\script\test.ps1 > test-out.txt
+ - cmd: type test-out.txt
+ # Since tests are currently only run in 2 JavaScript environments, look for exactly 2 counts of "0 failures, 0 errors."
+ - cmd: powershell -noninteractive -noprofile -command if (-not ((sls -Pattern '0 failures, 0 errors.' -SimpleMatch test-out.txt).count -eq 2)) { exit 1 }
+
+# Don't actually build (MSBuild).
+build: off
diff --git a/ast-ref/ast-ref.edn b/ast-ref/ast-ref.edn
new file mode 100644
index 0000000000..a0ca1a42bd
--- /dev/null
+++ b/ast-ref/ast-ref.edn
@@ -0,0 +1,313 @@
+{:all-keys
+
+ [[:op "The node op"]
+ [:form "The ClojureScript form from which the node originated"]
+ [:env "The environment map"]
+ [:context "Either :expr, :return or :statement."]
+ ^:optional
+ [:children "A vector of keywords, representing the children nodes of this node, in order of evaluation"]
+; ^:optional
+; [:raw-forms "If this node's :form has been macroexpanded, a sequence of all the intermediate forms from the original form to the macroexpanded form"]
+ ;^:optional
+ ;[:top-level "`true` if this is the root node"]
+ [:tag "The tag this expression is required to have"]
+; [:o-tag "The tag of this expression, based on the node's children"]
+; ^:optional
+; [:ignore-tag "`true` if this node returns a statement rather than an expression"]
+ ; ^:optional
+ ; [:loops "A set of the loop-ids that might cause this node to recur"]
+ ]
+
+ :node-keys
+ [{:op :binding
+ :doc "Node for a binding symbol"
+ :keys [[:form "The binding symbol"]
+ [:name "The binding symbol"]
+ [:local "One of :arg, :catch, :fn, :let, :letfn, :loop or :field"]
+ ^:optional
+ [:variadic? "When :local is :arg, a boolean indicating whether this parameter binds to a variable number of arguments"]
+ ^:optional ^:children
+ [:init "When :local is :let, :letfn or :loop, an AST node representing the bound value"]
+ ^:optional ;^:children
+ [:shadow "When this binding shadows another local binding, an AST node representing the shadowed local"]
+ ]}
+ {:op :case
+ :doc "Node for a case* special-form expression"
+ :keys [[:form "`(case* expr shift maks default case-map switch-type test-type skip-check?)`"]
+ ^:children
+ [:test "The AST node for the expression to test against"]
+ ^:children
+ [:nodes "A vector of :case-node AST nodes representing the test/then clauses of the case* expression"]
+ ^:children
+ [:default "An AST node representing the default value of the case expression"]
+ ]}
+ {:op :case-node
+ :doc "Grouping node for tests/then expressions in a case* expression"
+ :keys [^:children
+ [:tests "A vector of :case-test AST nodes representing the test values"]
+ ^:children
+ [:then "A :case-then AST node representing the value the case expression will evaluate to when one of the :tests expressions matches the :case :test value"]]}
+ {:op :case-test
+ :doc "Node for a test value in a case* expression"
+ :keys [^:children
+ [:test "A :const AST node representing the test value"]
+ #_[:hash]]}
+ {:op :case-then
+ :doc "Node for a then expression in a case* expression"
+ :keys [^:children
+ [:then "An AST node representing the expression the case will evaluate to when the :test expression matches this node's corresponding :case-test value"]
+ #_[:hash]]}
+ {:op :const
+ :doc "Node for a constant literal or a quoted collection literal"
+ :keys [[:form "A constant literal or a quoted collection literal"]
+ [:literal? "`true`"]
+ [:type "one of :nil, :bool, :keyword, :symbol, :string, :number, :type, :record, :map, :vector, :set, :seq, :char, :regex, :class, :var, or :unknown"]
+ [:val "The value of the constant node"]
+ ;^:optional ^:children
+ ;; FIXME
+ ;[:meta "An AST node representing the metadata of the constant value, if present. The node will be either a :map node or a :const node with :type :map"]
+ ;
+ ;^:optional
+ ;[:id "A numeric id for the constant value, will be the same for every instance of this constant inside the same compilation unit, not present if :type is :nil or :bool"]
+ ]}
+ {:op :def
+ :doc "Node for a def special-form expression"
+ :keys [[:form "`(def name docstring? init?)`"]
+ [:name "The var symbol to define in the current namespace"]
+ ;[:var "The Var object created (or found, if it already existed) named by the symbol :name in the current namespace"]
+ ;^:optional ^:children
+ ;[:meta "An AST node representing the metadata attached to :name, if present. The node will be either a :map node or a :const node with :type :map"]
+ ^:optional ^:children
+ [:init "An AST node representing the initial value of the var"]
+ ^:children
+ [:the-var "A :the-var AST node representing the return of this :def."]
+ ;^:optional
+ ;[:doc "The docstring for this var"]
+ ]}
+ {:op :defrecord
+ :doc "Node for a defrecord* special-form expression"
+ :keys [[:form "`(deftype* name class.name [arg*] :implements [interface*] method*)`"]
+ ;[:interfaces "A set of the interfaces implemented by the type"]
+ [:t "The symbol name of the defrecord."]
+ ^:children
+ [:body "An AST node containing method implementations for this record."]
+ ;^:children
+ ;[:fields "A vector of :binding AST nodes with :local :field representing the deftype fields"]
+ ]}
+ {:op :deftype
+ :doc "Node for a deftype* special-form expression"
+ :keys [[:form "`(deftype* name class.name [arg*] :implements [interface*] method*)`"]
+ ;[:interfaces "A set of the interfaces implemented by the type"]
+ [:t "The symbol name of the deftype"]
+ ;[:class-name "A class for the deftype, should *never* be instantiated or used on instance? checks as this will not be the same class the deftype will evaluate to after compilation"]
+ ^:children
+ [:body "An AST node containing method implemented for this type."]
+ ;^:children
+ ;[:fields "A vector of :binding AST nodes with :local :field representing the deftype fields"]
+ ]}
+ {:op :do
+ :doc "Node for a do special-form expression or for another special-form's body"
+ :keys [[:form "`(do statement* ret)`"]
+ ^:children
+ [:statements "A vector of AST nodes representing all but the last expression in the do body"]
+ ^:children
+ [:ret "An AST node representing the last expression in the do body (the block's return value)"]
+ ^:optional
+ [:body? "`true` if this node is a synthetic body"]]}
+ {:op :fn
+ :doc "Node for a fn* special-form expression"
+ :keys [[:form "`(fn* name? [arg*] body*)` or `(fn* name? method*)`"]
+ [:variadic? "`true` if this function contains a variadic arity method"]
+ [:max-fixed-arity "The number of arguments taken by the fixed-arity method taking the most arguments"]
+ ^:optional ^:children
+ [:local "A :binding AST node with :local :fn representing the function's local name, if one is supplied"]
+ ^:children
+ [:methods "A vector of :fn-method AST nodes representing the fn method arities"]
+ ]}
+ {:op :fn-method
+ :doc "Node for an arity method in a fn* expression"
+ :keys [[:form "`([arg*] body*)`"]
+ [:variadic? "`true` if this fn-method takes a variable number of arguments"]
+ ^:children
+ [:params "A vector of :binding AST nodes with :local :arg representing this fn-method args"]
+ [:fixed-arity "The number of non-variadic args this fn-method takes"]
+ ^:children
+ [:body "Synthetic :do node (with :body? `true`) representing the body of this fn-method"]]}
+ {:op :host-call
+ :doc "Node for a host interop call"
+ :keys [[:form "`(.method target arg*)`"]
+ [:method "Symbol naming the method to call"]
+ ^:children
+ [:target "An AST node representing the target object"]
+ ^:children
+ [:args "A vector of AST nodes representing the args passed to the method call"]]}
+ {:op :host-field
+ :doc "Node for a host interop field access"
+ :keys [[:form "`(.-field target)`"]
+ [:field "Symbol naming the field to access"]
+ ^:children
+ [:target "An AST node representing the target object"]]}
+ {:op :if
+ :doc "Node for an if special-form expression"
+ :keys [[:form "`(if test then else?)`"]
+ ^:children
+ [:test "An AST node representing the test expression"]
+ ^:children
+ [:then "An AST node representing the expression's return value if :test evaluated to a truthy value"]
+ ^:children
+ [:else "An AST node representing the expression's return value if :test evaluated to a falsey value, if not supplied it will default to a :const node representing nil"]]}
+ {:op :invoke
+ :doc "Node for an invoke expression"
+ :keys [[:form "`(f arg*)`"]
+ ^:children
+ [:fn "An AST node representing the function to invoke"]
+ ^:children
+ [:args "A vector of AST nodes representing the args to the function"]
+ ;FIXME
+ ;^:optional
+ ;[:meta "Map of metadata attached to the invoke :form"]
+ ]}
+ {:op :js
+ :doc "Node for a js* special-form expression"
+ :keys [[:form "`(js* js-string arg*)`"]
+ [:segs "A vector of js strings that delimit the compiled args"]
+ ^:children
+ [:args "A vector of AST nodes representing the cljs expressions that will be interposed with the strings in segs"]]}
+ {:op :js-array
+ :doc "Node for a js array literal"
+ :keys [[:form "`#js [item*]`"]
+ ^:children
+ [:items "A vector of AST nodes representing the items of the js array"]]}
+ {:op :js-object
+ :doc "Node for a js object literal"
+ :keys [[:form "`#js {[key value]*}`"]
+ [:keys "A vector of values representing the keys of the js object"]
+ ^:children
+ [:vals "A vector of AST nodes representing the vals of the js object"]]}
+ {:op :js-var
+ :doc "Node for a js-var symbol"
+ :keys [[:form "A symbol naming the js-var in the form: `js/foo`, `js-ns/foo` or `js-var`"]
+ [:ns "The namespace symbol for this js-var."]
+ [:name "The fully qualified symbol naming this js-var."]
+ ]}
+ {:op :let
+ :doc "Node for a let* special-form expression"
+ :keys [[:form "`(let* [binding*] body*)`"]
+ ^:children
+ [:bindings "A vector of :binding AST nodes with :local :let"]
+ ^:children
+ [:body "Synthetic :do node (with :body? `true`) representing the body of the let expression"]]}
+ {:op :letfn
+ :doc "Node for a letfn* special-form expression"
+ :keys [[:form "`(letfn* [binding*] body*)`"]
+ ^:children
+ [:bindings "A vector of :binding AST nodes with :local :letfn"]
+ ^:children
+ [:body "Synthetic :do node (with :body? `true`) representing the body of the letfn expression"]]}
+ {:op :local
+ :doc "Node for a local symbol"
+ :keys [[:form "The local symbol"]
+ [:name "The uniquified local symbol"]
+ [:local "One of :arg, :catch, :fn, :let, :letfn, :loop, :field or :this"]
+ ]}
+ {:op :loop
+ :doc "Node a loop* special-form expression"
+ :keys [[:form "`(loop* [binding*] body*)`"]
+ ^:children
+ [:bindings "A vector of :binding AST nodes with :local :loop"]
+ ^:children
+ [:body "Synthetic :do node (with :body? `true`) representing the body of the loop expression"]]}
+ {:op :map
+ :doc "Node for a map literal with attached metadata and/or non literal elements"
+ :keys [[:form "`{[key val]*}`"]
+ ^:children
+ [:keys "A vector of AST nodes representing the keys of the map"]
+ ^:children
+ [:vals "A vector of AST nodes representing the vals of the map"]]}
+ {:op :new
+ :doc "Node for a new special-form expression"
+ :keys [[:form "`(new Class arg*)`"]
+ ^:children
+ [:class "A :const AST node with :type :class representing the Class to instantiate"]
+ ^:children
+ [:args "A vector of AST nodes representing the arguments passed to the Class constructor"]
+ ]}
+ {:op :no-op
+ :doc "Node for a no-op"
+ :keys [
+ ]}
+ {:op :ns
+ :doc "Node for a clojure.core/ns form."
+ :keys [
+ ]}
+ {:op :ns*
+ :doc "Node for a special file-loading form."
+ :keys [
+ ]}
+ {:op :quote
+ :doc "Node for a quote special-form expression"
+ :keys [[:form "`(quote expr)`"]
+ ^:children
+ [:expr "A :const AST node representing the quoted value"]
+ [:literal? "`true`"]]}
+ {:op :recur
+ :doc "Node for a recur special-form expression"
+ :keys [[:form "`(recur expr*)`"]
+ ^:children
+ [:exprs "A vector of AST nodes representing the new bound values for the loop binding on the next loop iteration"]]}
+ {:op :set
+ :doc "Node for a set literal with attached metadata and/or non literal elements"
+ :keys [[:form "`#{item*}`"]
+ ^:children
+ [:items "A vector of AST nodes representing the items of the set"]]}
+ {:op :set!
+ :doc "Node for a set! special-form expression"
+ :keys [[:form "`(set! target val)`"]
+ ^:children
+ [:target "An AST node representing the target of the set! expression, must be :assignable?"]
+ ^:children
+ [:val "An AST node representing the new value for the target"]]}
+ {:op :the-var
+ :doc "Node for a var special-form expression"
+ :keys [[:form "`(var var-name)`"]
+ ^:children
+ [:var "A :var AST node that this expression refers to"]
+ ^:children
+ [:sym "An AST node for the quoted fully qualified name of this var."]
+ ^:children
+ [:meta "A :map AST node of this var's metadata."]
+ ]}
+ {:op :throw
+ :doc "Node for a throw special-form statement"
+ :keys [[:form "`(throw exception)`"]
+ ^:children
+ [:exception "An AST node representing the exception to throw"]]}
+ {:op :try
+ :doc "Node for a try special-form expression"
+ :keys [[:form "`(try body* catch* finally?)`"]
+ ^:children
+ [:body "Synthetic :do AST node (with :body? `true`) representing the body of this try expression"]
+ ^:optional
+ [:name "A binding in scope in :catch. (symbol)"]
+ ^:optional ^:children
+ [:catch "An AST node representing an unconditional JavaScript catch."]
+ ^:optional ^:children
+ [:finally "Synthetic :do AST node (with :body? `true`) representing the final clause of this try expression"]]}
+ {:op :var
+ :doc "Node for a var symbol"
+ :keys [[:form "A symbol naming the var"]
+ [:ns "The namespace symbol this var is defined in."]
+ [:name "The fully qualified symbol naming this var."]
+ ]}
+ {:op :vector
+ :doc "Node for a vector literal with attached metadata and/or non literal elements"
+ :keys [[:form "`[item*]`"]
+ ^:children
+ [:items "A vector of AST nodes representing the items of the vector"]]}
+ {:op :with-meta
+ :doc "Node for a non quoted collection literal or fn/reify expression with attached metadata"
+ :keys [[:form "Non quoted collection literal or fn/reify expression with attached metadata"]
+ ^:children
+ [:meta "An AST node representing the metadata of expression. The node will be either a :map node or a :const node with :type :map"]
+ ^:children
+ [:expr "The expression this metadata is attached to, :op is one of :vector, :map, :set, :fn or :reify"]]}]}
diff --git a/ast-ref/buildref.sh b/ast-ref/buildref.sh
new file mode 100755
index 0000000000..639710eb9e
--- /dev/null
+++ b/ast-ref/buildref.sh
@@ -0,0 +1,15 @@
+#!/bin/sh
+
+java -cp .:`lein cp` clojure.main <$1")
+ (replace #":([a-zA-Z\?!\-]*)" ":$1")))
+
+(defn build-children [children]
+ (if (some #(:optional (meta %)) children)
+ (let [[c & rest] children]
+ (let [k (build-children rest)
+ kc (mapv (fn [x] (cons c x)) k)]
+ (if (:optional (meta c))
+ (into k kc)
+ kc)))
+ (if (seq children)
+ [children]
+ [[]])))
+
+(defn children [keys]
+ (when-let [children (seq (filter #(:children (meta %)) keys))]
+ (mapv #(mapv first %) (build-children children))))
+
+(def nodes
+ (apply str (for [{:keys [op doc keys]} (:node-keys tej-ref) :let [op (name op)]]
+ (str "" "#" op "
" + "" doc "
" + "- "
+ "
- :op
-
:" op ""
+ (apply str (for [[k d :as f] keys]
+ (str " - " k " " + "
- " (if (:optional (meta f)) + "optional ") (fix d) " "))) + (if-let [c (children keys)] + (str "
- :children
- "
+ (join ", " (mapv (fn [c] (str "
" c "")) c)) " "))
+ "
- "
+ (apply str (for [[k d :as f] (:all-keys tej-ref)]
+ (str "
- " k " " + "
- " (if (:optional (meta f)) + "optional ") (fix d) " "))) + "
Page not found
" - "No page " path " found on this server." - "") - "text/html")) - -(defn- dispatch-request [request conn opts] - (if-let [handlers ((:method request) @handlers)] - (if-let [handler (some (fn [{:keys [pred handler]}] - (when (pred request conn opts) - handler)) - handlers)] - (if (= :post (:method request)) - (handler (read-string (:content request)) conn opts ) - (handler request conn opts)) - (send-404 conn (:path request))) - (.close conn))) - -(defn- handle-connection - [opts conn] - (let [rdr (BufferedReader. (InputStreamReader. (.getInputStream conn)))] - (if-let [request (read-request rdr)] - (dispatch-request request conn opts) - (.close conn)))) - -(defn- server-loop - [opts server-socket] - (let [conn (.accept server-socket)] - (do (.setKeepAlive conn true) - (future (handle-connection opts conn)) - (recur opts server-socket)))) - -(defn start - "Start the server on the specified port." - [opts] - (let [ss (ServerSocket. (:port opts))] - (future (server-loop opts ss)) - (swap! state (fn [old] (assoc old :socket ss :port (:port opts)))))) - -(defn stop - [] - (.close (:socket @state))) diff --git a/src/clj/cljs/source_map/base64.clj b/src/clj/cljs/source_map/base64.clj deleted file mode 100644 index 58505748d0..0000000000 --- a/src/clj/cljs/source_map/base64.clj +++ /dev/null @@ -1,17 +0,0 @@ -(ns cljs.source-map.base64) - -(def chars64 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") -(def char->int (zipmap chars64 (range 0 64))) -(def int->char (zipmap (range 0 64) chars64)) - -(defn encode [n] - (let [e (find int->char n)] - (if e - (second e) - (throw (Error. (str "Must be between 0 and 63: " n)))))) - -(defn ^Character decode [c] - (let [e (find char->int c)] - (if e - (second e) - (throw (Error. (str "Not a valid base 64 digit: " c)))))) \ No newline at end of file diff --git a/src/clj/cljs/tagged_literals.clj b/src/clj/cljs/tagged_literals.clj deleted file mode 100644 index 52a6e09457..0000000000 --- a/src/clj/cljs/tagged_literals.clj +++ /dev/null @@ -1,48 +0,0 @@ -(ns cljs.tagged-literals - (:require [clojure.instant :as inst])) - -(defn read-queue - [form] - (when-not (vector? form) - (throw (RuntimeException. "Queue literal expects a vector for its elements."))) - (list 'cljs.core/into 'cljs.core.PersistentQueue.EMPTY form)) - -(defn read-uuid - [form] - (when-not (string? form) - (throw (RuntimeException. "UUID literal expects a string as its representation."))) - (try - (java.util.UUID/fromString form) - (catch Throwable e - (throw (RuntimeException. (.getMessage e)))))) - -(defn read-inst - [form] - (when-not (string? form) - (throw (RuntimeException. "Instance literal expects a string for its timestamp."))) - (try - (inst/read-instant-date form) - (catch Throwable e - (throw (RuntimeException. (.getMessage e)))))) - -(defn valid-js-literal-key? [k] - (or (string? k) - (and (keyword? k) - (nil? (namespace k))))) - -(deftype JSValue [val]) - -(defn read-js - [form] - (when-not (or (vector? form) (map? form)) - (throw (RuntimeException. "JavaScript literal must use map or vector notation"))) - (when-not (or (not (map? form)) - (every? valid-js-literal-key? (keys form))) - (throw (RuntimeException. "JavaScript literal keys must be strings or unqualified keywords"))) - (JSValue. form)) - -(def ^:dynamic *cljs-data-readers* - {'queue read-queue - 'uuid read-uuid - 'inst read-inst - 'js read-js}) diff --git a/src/cljs/cljs/core.cljs b/src/cljs/cljs/core.cljs deleted file mode 100644 index 6b559e11fc..0000000000 --- a/src/cljs/cljs/core.cljs +++ /dev/null @@ -1,7778 +0,0 @@ -; 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.string :as gstring] - [goog.string.StringBuffer :as gstringbuf] - [goog.object :as gobject] - [goog.array :as garray])) - -;; next line is auto-generated by the build-script - Do not edit! -(def *clojurescript-version*) - -(def *unchecked-if* false) - -(def - ^{: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* - (fn [_] - (throw (js/Error. "No *print-fn* fn set for evaluation environment")))) - -(defn set-print-fn! - "Set *print-fn* to f." - [f] (set! *print-fn* f)) - -(def ^:dynamic *flush-on-newline* true) -(def ^:dynamic *print-newline* true) -(def ^:dynamic *print-readably* true) -(def ^:dynamic *print-meta* false) -(def ^:dynamic *print-dup* false) -(def ^:dynamic *print-length* nil) -(def ^:dynamic *print-level* 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 [& args] - (.apply js/console.log js/console (into-array args))))) - -(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) - -(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? [x] - (cljs.core/array? x)) - -(defn ^boolean number? [n] - (cljs.core/number? n)) - -(defn ^boolean not - "Returns true if x is logical false, false otherwise." - [x] (if x false true)) - -(defn ^boolean object? [x] - (if-not (nil? x) - (identical? (.-constructor x) js/Object) - false)) - -(defn ^boolean string? [x] - (goog/isString x)) - -(set! *unchecked-if* true) -(defn ^boolean native-satisfies? - "Internal - do not use!" - [p x] - (let [x (if (nil? x) nil x)] - (cond - (aget p (goog.typeOf x)) true - (aget 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-fn* is set to will be called with the command-line - argv as arguments"} - *main-cli-fn* nil) - -(defn type [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))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; arrays ;;;;;;;;;;;;;;;; - -(defn ^array make-array - ([size] - (js/Array. size)) - ([type size] - (make-array size))) - -(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] - (.call (.-slice (.-prototype js/Array)) (cljs.core/js-arguments))) - -(declare apply) - -(defn aget - "Returns the value at the index." - ([array i] - (cljs.core/aget array i)) - ([array i & idxs] - (apply aget (aget array i) idxs))) - -(defn aset - "Sets the value at the index." - ([array i val] - (cljs.core/aset array i 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 - ([aseq] - (into-array nil aseq)) - ([type aseq] - (reduce (fn [a x] (.push a x) a) (array) aseq))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;; core protocols ;;;;;;;;;;;;; - -(defprotocol Fn - "Marker protocol") - -(defprotocol IFn - (-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 s] - [this a b c d e f g h i j k l m n o p q s t] - [this a b c d e f g h i j k l m n o p q s t rest])) - -(defprotocol ICloneable - (^clj -clone [value])) - -(defprotocol ICounted - (^number -count [coll] "constant time count")) - -(defprotocol IEmptyableCollection - (-empty [coll])) - -(defprotocol ICollection - (^clj -conj [coll o])) - -#_(defprotocol IOrdinal - (-index [coll])) - -(defprotocol IIndexed - (-nth [coll n] [coll n not-found])) - -(defprotocol ASeq) - -(defprotocol ISeq - (-first [coll]) - (^clj -rest [coll])) - -(defprotocol INext - (^clj-or-nil -next [coll])) - -(defprotocol ILookup - (-lookup [o k] [o k not-found])) - -(defprotocol IAssociative - (^boolean -contains-key? [coll k]) - #_(-entry-at [coll k]) - (^clj -assoc [coll k v])) - -(defprotocol IMap - #_(-assoc-ex [coll k v]) - (^clj -dissoc [coll k])) - -(defprotocol IMapEntry - (-key [coll]) - (-val [coll])) - -(defprotocol ISet - (^clj -disjoin [coll v])) - -(defprotocol IStack - (-peek [coll]) - (^clj -pop [coll])) - -(defprotocol IVector - (^clj -assoc-n [coll n val])) - -(defprotocol IDeref - (-deref [o])) - -(defprotocol IDerefWithTimeout - (-deref-with-timeout [o msec timeout-val])) - -(defprotocol IMeta - (^clj-or-nil -meta [o])) - -(defprotocol IWithMeta - (^clj -with-meta [o meta])) - -(defprotocol IReduce - (-reduce [coll f] [coll f start])) - -(defprotocol IKVReduce - (-kv-reduce [coll f init])) - -(defprotocol IEquiv - (^boolean -equiv [o other])) - -(defprotocol IHash - (-hash [o])) - -(defprotocol ISeqable - (^clj-or-nil -seq [o])) - -(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 - (^clj -rseq [coll])) - -(defprotocol ISorted - (^clj -sorted-seq [coll ascending?]) - (^clj -sorted-seq-from [coll k ascending?]) - (-entry-key [coll entry]) - (-comparator [coll])) - -(defprotocol IWriter - (-write [writer s]) - (-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 - (^boolean -realized? [d])) - -(defprotocol IWatchable - (-notify-watches [this oldval newval]) - (-add-watch [this key f]) - (-remove-watch [this key])) - -(defprotocol IEditableCollection - (^clj -as-transient [coll])) - -(defprotocol ITransientCollection - (^clj -conj! [tcoll val]) - (^clj -persistent! [tcoll])) - -(defprotocol ITransientAssociative - (^clj -assoc! [tcoll key val])) - -(defprotocol ITransientMap - (^clj -dissoc! [tcoll key])) - -(defprotocol ITransientVector - (^clj -assoc-n! [tcoll n val]) - (^clj -pop! [tcoll])) - -(defprotocol ITransientSet - (^clj -disjoin! [tcoll v])) - -(defprotocol IComparable - (^number -compare [x y])) - -(defprotocol IChunk - (-drop-first [coll])) - -(defprotocol IChunkedSeq - (-chunked-first [coll]) - (-chunked-rest [coll])) - -(defprotocol IChunkedNext - (-chunked-next [coll])) - -(defprotocol INamed - (^string -name [x]) - (^string -namespace [x])) - -;; 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 (gstring/StringBuffer.) - writer (StringBufferWriter. sb)] - (-pr-writer obj writer (pr-opts)) - (-flush writer) - (str sb))) - -;;;;;;;;;;;;;;;;;;; symbols ;;;;;;;;;;;;;;; - -(declare list hash-combine hash Symbol = compare) - -(defn ^boolean instance? [t o] - (cljs.core/instance? t o)) - -(defn ^boolean symbol? [x] - (instance? Symbol x)) - -(defn- hash-symbol [sym] - (hash-combine (hash (.-ns sym)) (hash (.-name sym)))) - -(defn- compare-symbols [a b] - (cond - (= a b) 0 - (and (not (.-ns a)) (.-ns b)) -1 - (.-ns a) (if-not (.-ns b) - 1 - (let [nsc (compare (.-ns a) (.-ns b))] - (if (zero? nsc) - (compare (.-name a) (.-name b)) - nsc))) - :default (compare (.-name a) (.-name b)))) - -(deftype Symbol [ns name str ^:mutable _hash _meta] - Object - (toString [_] str) - IEquiv - (-equiv [_ other] - (if (instance? Symbol other) - (identical? str (.-str other)) - false)) - IFn - (-invoke [sym coll] - (-lookup coll sym nil)) - (-invoke [sym coll not-found] - (-lookup 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 symbol - ([name] - (if (symbol? name) - name - (symbol nil name))) - ([ns name] - (let [sym-str (if-not (nil? ns) - (str ns "/" name) - name)] - (Symbol. ns name sym-str nil nil)))) - -;;;;;;;;;;;;;;;;;;; fundamentals ;;;;;;;;;;;;;;; - -(declare array-seq prim-seq IndexedSeq) - -(defn clone [value] - (-clone value)) - -(defn cloneable? [value] - (satisfies? ICloneable value)) - -(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 ^not-native coll) - - (array? coll) - (when-not (zero? (alength coll)) - (IndexedSeq. coll 0)) - - (string? coll) - (when-not (zero? (alength coll)) - (IndexedSeq. coll 0)) - - (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 ^not-native 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 ^not-native 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 ^not-native 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))) - -;;;;;;;;;;;;;;;;;;; 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) - (identical? (.toString o) (.toString other))))) - -(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 ^boolean reduced? - "Returns true if x is the result of a call to reduced" - [r] - (instance? Reduced r)) - -(defn- ci-reduce - "Accepts any collection which satisfies the ICount and IIndexed protocols and -reduces them without incurring seq initialization" - ([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))))) - ([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)))) - ([cicoll f val idx] - (let [cnt (-count cicoll)] - (loop [val val, n idx] - (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 RSeq) - -(defn ^boolean counted? - "Returns true if coll implements count in constant time" - [x] (satisfies? ICounted x)) - -(defn ^boolean indexed? - "Returns true if coll implements nth in constant time" - [x] (satisfies? IIndexed x)) - -(deftype IndexedSeq [arr i] - Object - (toString [coll] - (pr-str* coll)) - - ICloneable - (-clone [_] (IndexedSeq. arr i)) - - ISeqable - (-seq [this] this) - - ASeq - ISeq - (-first [_] (aget arr i)) - (-rest [_] (if (< (inc i) (alength arr)) - (IndexedSeq. arr (inc i)) - (list))) - - INext - (-next [_] (if (< (inc i) (alength arr)) - (IndexedSeq. arr (inc i)) - nil)) - - ICounted - (-count [_] (- (alength arr) i)) - - IIndexed - (-nth [coll n] - (let [i (+ n i)] - (when (< i (alength arr)) - (aget arr i)))) - (-nth [coll n not-found] - (let [i (+ n i)] - (if (< i (alength arr)) - (aget arr i) - not-found))) - - ISequential - IEquiv - (-equiv [coll other] (equiv-sequential coll other)) - - ICollection - (-conj [coll o] (cons o coll)) - - IEmptyableCollection - (-empty [coll] cljs.core.List.EMPTY) - - 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-coll coll)) - - IReversible - (-rseq [coll] - (let [c (-count coll)] - (if (pos? c) - (RSeq. coll (dec c) nil))))) - -(defn prim-seq - ([prim] - (prim-seq prim 0)) - ([prim i] - (when (< i (alength prim)) - (IndexedSeq. prim i)))) - -(defn array-seq - ([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)) - - ICloneable - (-clone [_] (RSeq. ci i meta)) - - IMeta - (-meta [coll] meta) - IWithMeta - (-with-meta [coll new-meta] - (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))) - - ICounted - (-count [coll] (inc i)) - - ICollection - (-conj [coll o] - (cons o coll)) - - IEmptyableCollection - (-empty [coll] (with-meta cljs.core.List.EMPTY meta)) - - IHash - (-hash [coll] (hash-coll coll)) - - IReduce - (-reduce [col f] (seq-reduce f col)) - (-reduce [col f start] (seq-reduce f start col))) - -(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 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) - (-empty coll))) - -(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 ^not-native coll) - - (array? coll) - (alength coll) - - (string? coll) - (alength coll) - - (native-satisfies? ICounted coll) - (-count coll) - - :else (accumulating-seq-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 ^not-native coll n) - - (array? coll) - (when (< n (.-length coll)) - (aget coll n)) - - (string? coll) - (when (< n (.-length coll)) - (aget coll n)) - - (native-satisfies? IIndexed coll) - (-nth coll n) - - (satisfies? ISeq coll) - (linear-traversal-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 ^not-native coll n not-found) - - (array? coll) - (if (< n (.-length coll)) - (aget coll n) - not-found) - - (string? coll) - (if (< n (.-length coll)) - (aget coll n) - not-found) - - (native-satisfies? IIndexed coll) - (-nth coll n) - - (satisfies? ISeq coll) - (linear-traversal-nth coll n not-found) - - :else - (throw (js/Error. (str "nth not supported on this type " - (type->str (type coll)))))))) - -(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 ^not-native o k) - - (array? o) - (when (< k (.-length o)) - (aget o k)) - - (string? o) - (when (< k (.-length o)) - (aget o k)) - - (native-satisfies? ILookup o) - (-lookup o k) - - :else nil))) - ([o k not-found] - (if-not (nil? o) - (cond - (implements? ILookup o) - (-lookup ^not-native o k not-found) - - (array? o) - (if (< k (.-length o)) - (aget o k) - not-found) - - (string? o) - (if (< k (.-length o)) - (aget o k) - not-found) - - (native-satisfies? ILookup o) - (-lookup o k not-found) - - :else not-found) - not-found))) - -(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." - ([coll k v] - (if-not (nil? coll) - (-assoc coll k v) - (hash-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 ^boolean fn? [f] - (or ^boolean (goog/isFunction f) (satisfies? Fn f))) - -(defn with-meta - "Returns an object of the same type and value as obj, with - map m as its metadata." - [o meta] - (if (and (fn? o) (not (satisfies? IWithMeta o))) - (with-meta - (reify - Fn - IFn - (-invoke [_ & args] - (apply o args))) - 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))))) - -;; Simple caching of string hashcode -(def string-hash-cache (js-obj)) -(def string-hash-cache-count 0) - -(defn add-to-string-hash-cache [k] - (let [h (goog.string/hashCode k)] - (aset string-hash-cache k h) - (set! string-hash-cache-count (inc string-hash-cache-count)) - h)) - -(defn check-string-hash-cache [k] - (when (> string-hash-cache-count 255) - (set! string-hash-cache (js-obj)) - (set! string-hash-cache-count 0)) - (let [h (aget string-hash-cache k)] - (if (number? h) - h - (add-to-string-hash-cache k)))) - -(defn hash [o] - (cond - (implements? IHash o) - (-hash ^not-native o) - - (number? o) - (js-mod (.floor js/Math o) 2147483647) - - (true? o) 1 - - (false? o) 0 - - (string? o) - (check-string-hash-cache o) - - (nil? o) 0 - - :else - (-hash o))) - -(defn ^boolean 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 ^boolean coll? - "Returns true if x satisfies ICollection" - [x] - (if (nil? x) - false - (satisfies? ICollection x))) - -(defn ^boolean set? - "Returns true if x satisfies ISet" - [x] - (if (nil? x) - false - (satisfies? ISet x))) - -(defn ^boolean associative? - "Returns true if coll implements Associative" - [x] (satisfies? IAssociative x)) - -(defn ^boolean sequential? - "Returns true if coll satisfies ISequential" - [x] (satisfies? ISequential x)) - -(defn ^boolean sorted? - "Returns true if coll satisfies ISorted" - [x] (satisfies? ISorted x)) - -(defn ^boolean reduceable? - "Returns true if coll satisfies IReduce" - [x] (satisfies? IReduce x)) - -(defn ^boolean map? - "Return true if x satisfies IMap" - [x] - (if (nil? x) - false - (satisfies? IMap x))) - -(defn ^boolean vector? - "Return true if x satisfies IVector" - [x] (satisfies? IVector x)) - -(declare ChunkedCons ChunkedSeq) - -(defn ^boolean chunked-seq? - [x] (implements? IChunkedSeq x)) - -;;;;;;;;;;;;;;;;;;;; js primitives ;;;;;;;;;;;; -(defn js-obj - ([] - (cljs.core/js-obj)) - ([& keyvals] - (apply gobject/create keyvals))) - -(defn js-keys [obj] - (let [keys (array)] - (goog.object/forEach obj (fn [val key obj] (.push keys key))) - keys)) - -(defn js-delete [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 undefined? [x] - (cljs.core/undefined? x)) - -(defn ^boolean seq? - "Return true if s satisfies ISeq" - [s] - (if (nil? s) - false - (satisfies? ISeq s))) - -(defn ^boolean seqable? - "Return true if s satisfies ISeqable" - [s] - (satisfies? ISeqable s)) - -(defn ^boolean boolean [x] - (if x true false)) - -(defn ^boolean ifn? [f] - (or (fn? f) (satisfies? IFn f))) - -(defn ^boolean integer? - "Returns true if n is an integer." - [n] - (and (number? n) - (not ^boolean (js/isNaN n)) - (not (identical? n js/Infinity)) - (== (js/parseFloat n) (js/parseInt n 10)))) - -(defn ^boolean 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] - (when (and (not (nil? coll)) - (associative? coll) - (contains? coll k)) - [k (get coll k)])) - -(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 ^seq sequence - "Coerces coll to a (possibly empty) sequence, if it is not already - one. Will not force a lazy seq. (sequence nil) yields ()" - [coll] - (if (seq? coll) - coll - (or (seq coll) ()))) - -(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 - - (identical? (type x) (type y)) - (if (implements? IComparable x) - (-compare ^not-native x y) - (garray/defaultCompare x y)) - - :else - (throw (js/Error. "compare on non-nil objects of different types")))) - -(defn ^:private compare-indexed - "Compare indexed collection." - ([xs ys] - (let [xl (count xs) - yl (count ys)] - (cond - (< xl yl) -1 - (> xl yl) 1 - :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 funcion, 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)) - (seq a)) - ()))) - -(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 funcion, 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 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 ^not-native coll f) - - (array? coll) - (array-reduce coll f) - - (string? coll) - (array-reduce coll f) - - (native-satisfies? IReduce coll) - (-reduce coll f) - - :else - (seq-reduce f coll))) - ([f val coll] - (cond - (implements? IReduce coll) - (-reduce ^not-native 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) - - :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))) - -;;; 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 [x] - (cljs.core/unchecked-dec x)) - -(defn unchecked-dec-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-substract - "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-substract (cljs.core/unchecked-subtract x y) more))) - -(defn ^number unchecked-substract-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-substract-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 ^number rand - "Returns a random floating point number between 0 (inclusive) and n (default 1) (exclusive)." - ([] (Math/random)) - ([n] (* n (rand)))) - -(defn rand-int - "Returns a random integer between 0 (inclusive) and n (exclusive)." - [n] (fix (rand n))) - -(defn bit-xor - "Bitwise exclusive or" - [x y] (cljs.core/bit-xor x y)) - -(defn bit-and - "Bitwise and" - [x y] (cljs.core/bit-and x y)) - -(defn bit-or - "Bitwise or" - [x y] (cljs.core/bit-or x y)) - -(defn bit-and-not - "Bitwise and" - [x y] (cljs.core/bit-and-not x y)) - -(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 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" - [n] (cljs.core/pos? n)) - -(defn ^boolean zero? [n] - (cljs.core/zero? n)) - -(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) - "" - (.toString x))) - ([x & ys] - (loop [sb (gstring/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] (.substring s start)) - ([s start end] (.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) - (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-combine [seed hash] - ; a la boost - (bit-xor seed (+ hash 0x9e3779b9 - (bit-shift-left seed 6) - (bit-shift-right seed 2)))) - -(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 implict 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)] - (aset obj str-name f))) - obj) - -;;;;;;;;;;;;;;;; cons ;;;;;;;;;;;;;;;; -(deftype List [meta first rest count ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - - IList - - ICloneable - (-clone [_] (List. meta first rest count __hash)) - - IWithMeta - (-with-meta [coll meta] (List. 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] cljs.core.List.EMPTY) - - ISequential - IEquiv - (-equiv [coll other] (equiv-sequential coll other)) - - IHash - (-hash [coll] (caching-hash coll hash-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))) - -(deftype EmptyList [meta] - Object - (toString [coll] - (pr-str* coll)) - - IList - - ICloneable - (-clone [_] (EmptyList. meta)) - - IWithMeta - (-with-meta [coll meta] (EmptyList. 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] (equiv-sequential coll other)) - - IHash - (-hash [coll] 0) - - 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! cljs.core.List.EMPTY (EmptyList. nil)) - -(defn ^boolean reversible? [coll] - (satisfies? IReversible coll)) - -(defn ^seq rseq [coll] - (-rseq coll)) - -(defn reverse - "Returns a seq of the items in coll in reverse order. Not lazy." - [coll] - (if (reversible? coll) - (rseq coll) - (reduce conj () coll))) - -(defn list [& 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) ^not-native 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)) - - IList - - ICloneable - (-clone [_] (Cons. meta first rest __hash)) - - IWithMeta - (-with-meta [coll meta] (Cons. 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 __hash)) - - IEmptyableCollection - (-empty [coll] (with-meta cljs.core.List.EMPTY meta)) - - ISequential - IEquiv - (-equiv [coll other] (equiv-sequential coll other)) - - IHash - (-hash [coll] (caching-hash coll hash-coll __hash)) - - ISeqable - (-seq [coll] coll) - - IReduce - (-reduce [coll f] (seq-reduce f coll)) - (-reduce [coll f start] (seq-reduce f start coll))) - -(defn cons - "Returns a new seq where x is the first element and seq is the rest." - [x coll] - (if (or (nil? coll) - (implements? ISeq coll)) - (Cons. nil x coll nil) - (Cons. nil x (seq coll) nil))) - -(defn ^boolean list? [x] - (satisfies? IList x)) - -(deftype Keyword [ns name fqn ^:mutable _hash] - Object - (toString [_] (str ":" fqn)) - - 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 was checking if _hash == -1, should it stay that way? - (if (nil? _hash) - (do - (set! _hash (+ (hash-combine (hash ns) (hash name)) - 0x9e3779b9)) - _hash) - _hash)) - - INamed - (-name [_] name) - (-namespace [_] ns) - - IPrintWithWriter - (-pr-writer [o writer _] (-write writer (str ":" fqn)))) - -(defn ^boolean keyword? [x] - (instance? Keyword x)) - -(defn ^boolean keyword-identical? [x y] - (if (identical? x y) - true - (if (and (keyword? x) - (keyword? y)) - (identical? (.-fqn x) (.-fqn y)) - false))) - -(defn namespace - "Returns the namespace String of a symbol or keyword, or nil if not present." - [x] - (if (implements? INamed x) - (-namespace ^not-native x) - (throw (js/Error. (str "Doesn't support namespace: " x))))) - -(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) - (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] (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)) - - (sval [coll] - (if (nil? fn) - s - (do - (set! s (fn)) - (set! fn nil) - s))) - - IWithMeta - (-with-meta [coll meta] (LazySeq. meta fn s __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 cljs.core.List.EMPTY meta)) - - ISequential - IEquiv - (-equiv [coll other] (equiv-sequential coll other)) - - IHash - (-hash [coll] (caching-hash coll hash-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))) - -(declare ArrayChunk) - -(deftype ChunkBuffer [^:mutable buf ^:mutable end] - Object - (add [_ o] - (aset buf end o) - (set! end (inc end))) - - (chunk [_ o] - (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)) - - IWithMeta - (-with-meta [coll m] - (ChunkedCons. chunk more m __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 meta nil) - (if (nil? more) - () - more))) - - INext - (-next [coll] - (if (> (-count chunk) 1) - (ChunkedCons. (-drop-first chunk) more meta nil) - (let [more (-seq more)] - (when-not (nil? more) - 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] (with-meta cljs.core.List.EMPTY meta)) - - IHash - (-hash [coll] (caching-hash coll hash-coll __hash))) - -(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 - "Naive impl of to-array as a start." - [s] - (let [ary (array)] - (loop [s s] - (if (seq 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 xs - (aset ret i (to-array (first xs))) - (recur (inc i) (next xs)))) - ret)) - -(defn int-array - ([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 - ([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 - ([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 - ([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 [s n] - (if (counted? s) - (count s) - (loop [s s i n sum 0] - (if (and (pos? i) (seq s)) - (recur (next s) (dec i) (inc sum)) - sum)))) - -(defn spread - [arglist] - (cond - (nil? arglist) nil - (nil? (next arglist)) (seq (first arglist)) - :else (cons (first arglist) - (spread (next arglist))))) - -(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 x to the transient collection, and return coll. The 'addition' - may happen at different 'places' depending on the concrete type." - ([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 coll" - [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 apply - "Applies fn f to the argument list formed by prepending intervening arguments to args. - First cut. Not lazy. Needs to use emitted toApply." - ([f args] - (let [fixed-arity (.-cljs$lang$maxFixedArity f)] - (if (.-cljs$lang$applyTo f) - (let [bc (bounded-count args (inc fixed-arity))] - (if (<= bc fixed-arity) - (apply-to f bc args) - (.cljs$lang$applyTo f args))) - (.apply f f (to-array args))))) - ([f x args] - (let [arglist (list* x args) - fixed-arity (.-cljs$lang$maxFixedArity f)] - (if (.-cljs$lang$applyTo f) - (let [bc (bounded-count arglist (inc fixed-arity))] - (if (<= bc fixed-arity) - (apply-to f bc arglist) - (.cljs$lang$applyTo f arglist))) - (.apply f f (to-array arglist))))) - ([f x y args] - (let [arglist (list* x y args) - fixed-arity (.-cljs$lang$maxFixedArity f)] - (if (.-cljs$lang$applyTo f) - (let [bc (bounded-count arglist (inc fixed-arity))] - (if (<= bc fixed-arity) - (apply-to f bc arglist) - (.cljs$lang$applyTo f arglist))) - (.apply f f (to-array arglist))))) - ([f x y z args] - (let [arglist (list* x y z args) - fixed-arity (.-cljs$lang$maxFixedArity f)] - (if (.-cljs$lang$applyTo f) - (let [bc (bounded-count arglist (inc fixed-arity))] - (if (<= bc fixed-arity) - (apply-to f bc arglist) - (.cljs$lang$applyTo f arglist))) - (.apply f f (to-array arglist))))) - ([f a b c d & args] - (let [arglist (cons a (cons b (cons c (cons d (spread args))))) - fixed-arity (.-cljs$lang$maxFixedArity f)] - (if (.-cljs$lang$applyTo f) - (let [bc (bounded-count arglist (inc fixed-arity))] - (if (<= bc fixed-arity) - (apply-to f bc arglist) - (.cljs$lang$applyTo f arglist))) - (.apply f f (to-array arglist)))))) -(set! *unchecked-if* false) - -(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 ^boolean 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 ^boolean 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 (seq coll) - (or (pred (first coll)) (recur pred (next coll))))) - -(defn ^boolean not-any? - "Returns false if (pred x) is logical true for any x in coll, - else true." - [pred coll] (not (some pred coll))) - -(defn ^boolean 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 ^boolean odd? - "Returns true if n is odd, throws an exception if n is not an integer" - [n] (not (even? n))) - -(defn identity [x] x) - -(defn ^boolean 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 [& args] (apply f arg1 args))) - ([f arg1 arg2] - (fn [& args] (apply f arg1 arg2 args))) - ([f arg1 arg2 arg3] - (fn [& args] (apply f arg1 arg2 arg3 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))))) - -(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." - [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." - ([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)))))))))) - -(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." - ([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." - ([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." - [n coll] - (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." - [n coll] - (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 nil." - [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)))) - -(defn cycle - "Returns a lazy (infinite!) sequence of repetitions of the items in coll." - [coll] (lazy-seq - (when-let [s (seq coll)] - (concat s (cycle s))))) - -(defn split-at - "Returns a vector of [(take n coll) (drop n coll)]" - [n coll] - [(take n coll) (drop n coll)]) - -(defn repeat - "Returns a lazy (infinite!, or length n if supplied) sequence of xs." - ([x] (lazy-seq (cons x (repeat x)))) - ([n x] (take n (repeat x)))) - -(defn replicate - "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)))) - -(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] (cons x (lazy-seq (iterate f (f x))))) - -(defn interleave - "Returns a lazy seq of the first item in each coll, then the second etc." - ([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" - [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))) - -(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." - ([f coll] - (flatten1 (map f coll))) - ([f coll & colls] - (flatten1 (apply map f coll colls)))) - -(defn filter - "Returns a lazy sequence of the items in coll for which - (pred item) returns true. pred must be free of side-effects." - ([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 false. pred must be free of side-effects." - [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." - [to from] - (if-not (nil? to) - (if (implements? IEditableCollection to) - (persistent! (reduce -conj! (transient to) from)) - (reduce -conj to from)) - (reduce conj () 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 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 upto 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] - (get-in m ks nil)) - ([m ks not-found] - (loop [sentinel lookup-sentinel - m m - ks (seq ks)] - (if ks - (if (not (satisfies? ILookup m)) - not-found - (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))))) - -;;; 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)))) - -(declare tv-editable-root tv-editable-tail TransientVector deref - pr-sequential-writer pr-writer chunked-seq) - -(deftype PersistentVector [meta cnt shift root tail ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - - ICloneable - (-clone [_] (PersistentVector. meta cnt shift root tail __hash)) - - IWithMeta - (-with-meta [coll meta] (PersistentVector. 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 cljs.core.PersistentVector.EMPTY 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) cljs.core.PersistentVector.EMPTY_NODE 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 cljs.core.PersistentVector.EMPTY meta)) - - ISequential - IEquiv - (-equiv [coll other] (equiv-sequential coll other)) - - IHash - (-hash [coll] (caching-hash coll hash-coll __hash)) - - ISeqable - (-seq [coll] - (cond - (zero? cnt) nil - (<= cnt 32) (IndexedSeq. tail 0) - :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)) - - IMapEntry - (-key [coll] - (-nth coll 0)) - (-val [coll] - (-nth coll 1)) - - 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.")))) - - 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] - (ci-reduce v f)) - (-reduce [v f start] - (ci-reduce v f start)) - - IKVReduce - (-kv-reduce [v f init] - (let [step-init (array 0 init)] ; [step 0 init init] - (loop [i 0] - (if (< i cnt) - (let [arr (unchecked-array-for v i) - len (alength arr)] - (let [init (loop [j 0 init (aget step-init 1)] - (if (< j len) - (let [init (f init (+ j i) (aget arr j))] - (if (reduced? init) - init - (recur (inc j) init))) - (do (aset step-init 0 len) - (aset step-init 1 init) - init)))] - (if (reduced? init) - @init - (recur (+ i (aget step-init 0)))))) - (aget step-init 1))))) - - 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] - (if (pos? cnt) - (RSeq. coll (dec cnt) nil)))) - -(set! cljs.core.PersistentVector.EMPTY_NODE (VectorNode. nil (make-array 32))) - -(set! cljs.core.PersistentVector.EMPTY - (PersistentVector. nil 0 5 cljs.core.PersistentVector.EMPTY_NODE (array) 0)) - -(set! cljs.core.PersistentVector.fromArray - (fn [xs ^boolean no-clone] - (let [l (alength xs) - xs (if no-clone xs (aclone xs))] - (if (< l 32) - (PersistentVector. nil l 5 cljs.core.PersistentVector.EMPTY_NODE xs nil) - (let [node (.slice xs 0 32) - v (PersistentVector. nil 32 5 cljs.core.PersistentVector.EMPTY_NODE node nil)] - (loop [i 32 out (-as-transient v)] - (if (< i l) - (recur (inc i) (conj! out (aget xs i))) - (persistent! out)))))))) - -(defn vec [coll] - (-persistent! - (reduce -conj! - (-as-transient cljs.core.PersistentVector.EMPTY) - coll))) - -(defn vector [& args] - (if (and (instance? IndexedSeq args) (zero? (.-i args))) - (cljs.core.PersistentVector.fromArray (.-arr args) true) - (vec args))) - -(declare subvec) - -(deftype ChunkedSeq [vec node i off meta ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - - IWithMeta - (-with-meta [coll m] - (chunked-seq vec node i off m)) - (-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] - (with-meta cljs.core.PersistentVector.EMPTY meta)) - - 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-coll __hash)) - - IReduce - (-reduce [coll f] - (ci-reduce (subvec vec (+ i off) (count vec)) f)) - - (-reduce [coll f start] - (ci-reduce (subvec vec (+ i off) (count vec)) f start))) - -(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)) - - ICloneable - (-clone [_] (Subvec. meta v start end __hash)) - - IWithMeta - (-with-meta [coll meta] (build-subvec meta v start end __hash)) - - IMeta - (-meta [coll] meta) - - IStack - (-peek [coll] - (-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 cljs.core.PersistentVector.EMPTY meta)) - - ISequential - IEquiv - (-equiv [coll other] (equiv-sequential coll other)) - - IHash - (-hash [coll] (caching-hash coll hash-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.")))) - - IVector - (-assoc-n [coll n val] - (let [v-pos (+ start n)] - (build-subvec meta (assoc v v-pos val) start (max end (inc v-pos)) nil))) - - IReduce - (-reduce [coll f] - (ci-reduce coll f)) - (-reduce [coll f start] - (ci-reduce coll f start)) - - IFn - (-invoke [coll k] - (-nth coll k)) - (-invoke [coll k not-found] - (-nth coll k not-found))) - -(defn- build-subvec [meta v start end __hash] - (if (instance? Subvec v) - (recur meta (.-v v) (+ (.-start v) start) (+ (.-start v) end) __hash) - (let [c (count v)] - (when (or (neg? start) - (neg? end) - (> start c) - (> end c)) - (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] - (build-subvec nil v start 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] (if (number? k) - (-nth coll k not-found) - not-found)) - - IFn - (-invoke [coll k] - (-lookup coll k)) - - (-invoke [coll k not-found] - (-lookup coll k not-found))) - -;;; PersistentQueue ;;; - -(deftype PersistentQueueSeq [meta front rear ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - - IWithMeta - (-with-meta [coll meta] (PersistentQueueSeq. 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)))) - - ICollection - (-conj [coll o] (cons o coll)) - - IEmptyableCollection - (-empty [coll] (with-meta cljs.core.List.EMPTY meta)) - - ISequential - IEquiv - (-equiv [coll other] (equiv-sequential coll other)) - - IHash - (-hash [coll] (caching-hash coll hash-coll __hash)) - - ISeqable - (-seq [coll] coll)) - -(deftype PersistentQueue [meta count front rear ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - - ICloneable - (-clone [coll] (PersistentQueue. meta count front rear __hash)) - - IWithMeta - (-with-meta [coll meta] (PersistentQueue. 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] cljs.core.PersistentQueue.EMPTY) - - ISequential - IEquiv - (-equiv [coll other] (equiv-sequential coll other)) - - IHash - (-hash [coll] (caching-hash coll hash-coll __hash)) - - ISeqable - (-seq [coll] - (let [rear (seq rear)] - (if (or front rear) - (PersistentQueueSeq. nil front (seq rear) nil)))) - - ICounted - (-count [coll] count)) - -(set! cljs.core.PersistentQueue.EMPTY (PersistentQueue. nil 0 nil [] 0)) - -(deftype NeverEquiv [] - IEquiv - (-equiv [o other] false)) - -(def ^:private never-equiv (NeverEquiv.)) - -(defn- equiv-map - "Assumes y is a map. Returns true if x equals y, otherwise returns - false." - [x y] - (boolean - (when (map? y) - ; assume all maps are counted - (when (== (count x) (count y)) - (every? identity - (map (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 cljs.core.PersistentHashMap.EMPTY)] - (if (< i len) - (let [k (aget ks i)] - (recur (inc i) (assoc! out k (aget 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)] - (aset new-obj k (aget obj k)) - (recur (inc i))))) - new-obj)) - -(deftype ObjMap [meta keys strobj update-count ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - - IWithMeta - (-with-meta [coll meta] (ObjMap. 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 cljs.core.ObjMap.EMPTY meta)) - - IEquiv - (-equiv [coll other] (equiv-map coll other)) - - IHash - (-hash [coll] (caching-hash coll hash-imap __hash)) - - ISeqable - (-seq [coll] - (when (pos? (alength keys)) - (map #(vector % (aget 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)))) - (aget strobj k) - not-found)) - - IAssociative - (-assoc [coll k v] - (if ^boolean (goog/isString k) - (if (or (> update-count cljs.core.ObjMap.HASHMAP_THRESHOLD) - (>= (alength keys) cljs.core.ObjMap.HASHMAP_THRESHOLD)) - (obj-map->hash-map coll k v) - (if-not (nil? (scan-array 1 k keys)) - (let [new-strobj (obj-clone strobj keys)] - (aset 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)] - (aset 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)) - - 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 (aget 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! cljs.core.ObjMap.EMPTY (ObjMap. nil (array) (js-obj) 0 0)) - -(set! cljs.core.ObjMap.HASHMAP_THRESHOLD 8) - -(set! cljs.core.ObjMap.fromObject (fn [ks obj] (ObjMap. nil ks obj 0 nil))) - -;;; PersistentArrayMap - -(defn- array-map-index-of-nil? [arr m k] - (let [len (alength arr)] - (loop [i 0] - (cond - (<= len i) -1 - (nil? (aget arr i)) i - :else (recur (+ i 2)))))) - -(defn- array-map-index-of-keyword? [arr m k] - (let [len (alength arr) - kstr (.-fqn k)] - (loop [i 0] - (cond - (<= len i) -1 - (let [k' (aget arr i)] - (and (keyword? k') - (identical? kstr (.-fqn k')))) i - :else (recur (+ i 2)))))) - -(defn- array-map-index-of-symbol? [arr m k] - (let [len (alength arr) - kstr (.-str k)] - (loop [i 0] - (cond - (<= len i) -1 - (let [k' (aget arr i)] - (and (symbol? k') - (identical? kstr (.-str k')))) i - :else (recur (+ i 2)))))) - -(defn- array-map-index-of-identical? [arr m k] - (let [len (alength arr)] - (loop [i 0] - (cond - (<= len i) -1 - (identical? k (aget arr i)) i - :else (recur (+ i 2)))))) - -(defn- array-map-index-of-equiv? [arr m k] - (let [len (alength arr)] - (loop [i 0] - (cond - (<= len i) -1 - (= k (aget arr i)) i - :else (recur (+ i 2)))))) - -(defn- array-map-index-of [m k] - (let [arr (.-arr m)] - (cond - (keyword? k) (array-map-index-of-keyword? arr m k) - - (or ^boolean (goog/isString k) (number? k)) - (array-map-index-of-identical? arr m k) - - (symbol? k) (array-map-index-of-symbol? arr m k) - - (nil? k) - (array-map-index-of-nil? arr m k) - - :else (array-map-index-of-equiv? arr m k)))) - -(defn- array-map-extend-kv [m k v] - (let [arr (.-arr m) - 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)) - -(declare TransientArrayMap) - -(deftype PersistentArrayMapSeq [arr i _meta] - Object - (toString [coll] - (pr-str* coll)) - - IMeta - (-meta [coll] _meta) - - IWithMeta - (-with-meta [coll new-meta] - (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] (with-meta cljs.core.List.EMPTY _meta)) - - IHash - (-hash [coll] (hash-coll coll)) - - ISeq - (-first [coll] - [(aget arr i) (aget arr (inc i))]) - - (-rest [coll] - (if (< i (- (alength arr) 2)) - (PersistentArrayMapSeq. arr (+ i 2) _meta) - ())) - - INext - (-next [coll] - (when (< i (- (alength arr) 2)) - (PersistentArrayMapSeq. arr (+ i 2) _meta))) - - IReduce - (-reduce [coll f] (seq-reduce f coll)) - (-reduce [coll f start] (seq-reduce f start coll))) - -(defn persistent-array-map-seq [arr i _meta] - (when (<= i (- (alength arr) 2)) - (PersistentArrayMapSeq. arr i _meta))) - -(deftype PersistentArrayMap [meta cnt arr ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - - ICloneable - (-clone [_] (PersistentArrayMap. meta cnt arr __hash)) - - IWithMeta - (-with-meta [coll meta] (PersistentArrayMap. meta cnt arr __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 cljs.core.PersistentArrayMap.EMPTY meta)) - - IEquiv - (-equiv [coll other] (equiv-map coll other)) - - IHash - (-hash [coll] (caching-hash coll hash-imap __hash)) - - 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 cljs.core.PersistentArrayMap.HASHMAP_THRESHOLD) - (let [arr (array-map-extend-kv coll k v)] - (PersistentArrayMap. meta (inc cnt) arr nil)) - (-> (into cljs.core.PersistentHashMap.EMPTY 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))) - - 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)))) - - 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! cljs.core.PersistentArrayMap.EMPTY (PersistentArrayMap. nil 0 (array) nil)) - -(set! cljs.core.PersistentArrayMap.HASHMAP_THRESHOLD 8) - -(set! cljs.core.PersistentArrayMap.fromArray - (fn [arr ^boolean no-clone ^boolean no-check] - (let [arr (if no-clone arr (aclone arr))] - (if no-check - (let [cnt (/ (alength arr) 2)] - (PersistentArrayMap. nil cnt arr nil)) - (let [len (alength arr)] - (loop [i 0 - ret (transient cljs.core.PersistentArrayMap.EMPTY)] - (if (< i len) - (recur (+ i 2) - (-assoc! ret (aget arr i) (aget arr (inc i)))) - (-persistent! ret)))))))) - -(declare array->transient-hash-map) - -(deftype TransientArrayMap [^:mutable 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? - (if (satisfies? IMapEntry o) - (-assoc! tcoll (key o) (val o)) - (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 cljs.core.PersistentArrayMap.HASHMAP_THRESHOLD)) - (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!"))))) - -(declare TransientHashMap PersistentHashMap) - -(defn- array->transient-hash-map [len arr] - (loop [out (transient cljs.core.PersistentHashMap.EMPTY) - 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 ^boolean 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 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 cljs.core.BitmapIndexedNode.EMPTY (+ 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 cljs.core.BitmapIndexedNode.EMPTY - (+ 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) [key-or-nil val-or-node] - :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! cljs.core.BitmapIndexedNode.EMPTY 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! cljs.core.BitmapIndexedNode.EMPTY - 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 (aset removed-leaf? 0 true) - (.edit-and-remove-pair inode edit bit idx)) - :else inode))))) - - (kv-reduce [inode f init] - (inode-kv-reduce arr f init))) - -(set! cljs.core.BitmapIndexedNode.EMPTY (BitmapIndexedNode. nil 0 (make-array 0))) - -(defn- pack-array-node [array-node edit idx] - (let [arr (.-arr array-node) - len (* 2 (dec (.-cnt array-node))) - new-arr (make-array len)] - (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 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 cljs.core.BitmapIndexedNode.EMPTY (+ 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! cljs.core.BitmapIndexedNode.EMPTY 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))))) - -(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 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)) [(aget arr idx) (aget arr (inc idx))] - :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 (aset removed-leaf? 0 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))) - -(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)] - (-> cljs.core.BitmapIndexedNode.EMPTY - (.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)] - (-> cljs.core.BitmapIndexedNode.EMPTY - (.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)) - - IMeta - (-meta [coll] meta) - - IWithMeta - (-with-meta [coll meta] (NodeSeq. meta nodes i s __hash)) - - ICollection - (-conj [coll o] (cons o coll)) - - IEmptyableCollection - (-empty [coll] (with-meta cljs.core.List.EMPTY meta)) - - ICollection - (-conj [coll o] (cons o coll)) - - IEmptyableCollection - (-empty [coll] (with-meta cljs.core.List.EMPTY meta)) - - ISequential - ISeq - (-first [coll] - (if (nil? s) - [(aget nodes i) (aget nodes (inc i))] - (first s))) - - (-rest [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-coll __hash)) - - IReduce - (-reduce [coll f] (seq-reduce f coll)) - (-reduce [coll f start] (seq-reduce f start coll))) - -(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)) - - IMeta - (-meta [coll] meta) - - IWithMeta - (-with-meta [coll meta] (ArrayNodeSeq. meta nodes i s __hash)) - - ICollection - (-conj [coll o] (cons o coll)) - - IEmptyableCollection - (-empty [coll] (with-meta cljs.core.List.EMPTY meta)) - - ICollection - (-conj [coll o] (cons o coll)) - - IEmptyableCollection - (-empty [coll] (with-meta cljs.core.List.EMPTY meta)) - - ISequential - ISeq - (-first [coll] (first s)) - (-rest [coll] (create-array-node-seq nil nodes i (next s))) - - ISeqable - (-seq [this] this) - - IEquiv - (-equiv [coll other] (equiv-sequential coll other)) - - IHash - (-hash [coll] (caching-hash coll hash-coll __hash)) - - IReduce - (-reduce [coll f] (seq-reduce f coll)) - (-reduce [coll f start] (seq-reduce f start coll))) - -(defn- create-array-node-seq - ([nodes] (create-array-node-seq nil nodes 0 nil)) - ([meta 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. meta nodes (inc j) ns nil) - (recur (inc j))) - (recur (inc j)))))) - (ArrayNodeSeq. meta nodes i s nil)))) - -(declare TransientHashMap) - -(deftype PersistentHashMap [meta cnt root ^boolean has-nil? nil-val ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - - ICloneable - (-clone [_] (PersistentHashMap. meta cnt root has-nil? nil-val __hash)) - - IWithMeta - (-with-meta [coll meta] (PersistentHashMap. 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)) - (reduce -conj coll entry))) - - IEmptyableCollection - (-empty [coll] (-with-meta cljs.core.PersistentHashMap.EMPTY meta)) - - IEquiv - (-equiv [coll other] (equiv-map coll other)) - - IHash - (-hash [coll] (caching-hash coll hash-imap __hash)) - - ISeqable - (-seq [coll] - (when (pos? cnt) - (let [s (if-not (nil? root) (.inode-seq root))] - (if has-nil? - (cons [nil nil-val] 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) - cljs.core.BitmapIndexedNode.EMPTY - 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)))) - - 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)) (.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! cljs.core.PersistentHashMap.EMPTY (PersistentHashMap. nil 0 nil false nil 0)) - -(set! cljs.core.PersistentHashMap.fromArrays - (fn [ks vs] - (let [len (alength ks)] - (loop [i 0 ^not-native out (transient cljs.core.PersistentHashMap.EMPTY)] - (if (< i len) - (recur (inc i) (-assoc! out (aget ks i) (aget vs i))) - (persistent! out)))))) - -(deftype TransientHashMap [^:mutable ^boolean edit - ^:mutable root - ^:mutable count - ^:mutable ^boolean has-nil? - ^:mutable nil-val] - Object - (conj! [tcoll o] - (if edit - (if (satisfies? IMapEntry o) - (.assoc! tcoll (key o) (val o)) - (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) - cljs.core.BitmapIndexedNode.EMPTY - 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 (aget removed-leaf? 0) - (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))) - -;;; 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)) - - 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) - ()))) - - 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] (with-meta cljs.core.List.EMPTY meta)) - - IHash - (-hash [coll] (caching-hash coll hash-coll __hash)) - - IMeta - (-meta [coll] meta) - - IWithMeta - (-with-meta [coll meta] - (PersistentTreeMapSeq. meta stack ascending? cnt __hash)) - - IReduce - (-reduce [coll f] (seq-reduce f coll)) - (-reduce [coll f start] (seq-reduce f start coll))) - -(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 - (let [init (if-not (nil? (.-right node)) - (tree-map-kv-reduce (.-right node) f init) - init)] - (if (reduced? init) - @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)) - - IMapEntry - (-key [node] key) - (-val [node] val) - - IHash - (-hash [coll] (caching-hash coll hash-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] []) - - ISequential - ISeqable - (-seq [node] (list key val)) - - ICounted - (-count [node] 2) - - IIndexed - (-nth [node n] - (cond (== n 0) key - (== n 1) val - :else nil)) - - (-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)) - - 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] - (-lookup node k)) - - (-invoke [node k not-found] - (-lookup node k not-found))) - -(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)) - - IMapEntry - (-key [node] key) - (-val [node] val) - - IHash - (-hash [coll] (caching-hash coll hash-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] []) - - ISequential - ISeqable - (-seq [node] (list key val)) - - ICounted - (-count [node] 2) - - IIndexed - (-nth [node n] - (cond (== n 0) key - (== n 1) val - :else nil)) - - (-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)) - - 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] - (-lookup node k)) - - (-invoke [node k not-found] - (-lookup node k not-found))) - -(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)) - - (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 meta] (PersistentTreeMap. comp tree cnt meta __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 cljs.core.PersistentTreeMap.EMPTY meta)) - - IEquiv - (-equiv [coll other] (equiv-map coll other)) - - IHash - (-hash [coll] (caching-hash coll hash-imap __hash)) - - ICounted - (-count [coll] cnt) - - IKVReduce - (-kv-reduce [coll f init] - (if-not (nil? tree) - (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)))) - - 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! cljs.core.PersistentTreeMap.EMPTY (PersistentTreeMap. compare nil 0 nil 0)) - -(defn hash-map - "keyval => key val - Returns a new hash map with supplied mappings." - [& keyvals] - (loop [in (seq keyvals), out (transient cljs.core.PersistentHashMap.EMPTY)] - (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] - (PersistentArrayMap. nil (quot (count keyvals) 2) (apply array keyvals) nil)) - -(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)) - (aset obj (first kvs) (second kvs)) - (recur (nnext kvs))) - (cljs.core.ObjMap.fromObject ks obj))))) - -(defn sorted-map - "keyval => key val - Returns a new sorted map with supplied mappings." - ([& keyvals] - (loop [in (seq keyvals) out cljs.core.PersistentTreeMap.EMPTY] - (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 (cljs.core.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)) - - IMeta - (-meta [coll] _meta) - - IWithMeta - (-with-meta [coll new-meta] (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] (with-meta cljs.core.List.EMPTY _meta)) - - IHash - (-hash [coll] (hash-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 _meta) - ()))) - - INext - (-next [coll] - (let [nseq (if (satisfies? INext mseq) - (-next mseq) - (next mseq))] - (when-not (nil? nseq) - (KeySeq. nseq _meta)))) - - IReduce - (-reduce [coll f] (seq-reduce f coll)) - (-reduce [coll f start] (seq-reduce f start coll))) - -(defn keys - "Returns a sequence of the map's keys." - [hash-map] - (when-let [mseq (seq hash-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)) - - IMeta - (-meta [coll] _meta) - - IWithMeta - (-with-meta [coll new-meta] (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] (with-meta cljs.core.List.EMPTY _meta)) - - IHash - (-hash [coll] (hash-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 _meta) - ()))) - - INext - (-next [coll] - (let [nseq (if (satisfies? INext mseq) - (-next mseq) - (next mseq))] - (when-not (nil? nseq) - (ValSeq. nseq _meta)))) - - IReduce - (-reduce [coll f] (seq-reduce f coll)) - (-reduce [coll f start] (seq-reduce f start coll))) - -(defn vals - "Returns a sequence of the map's values." - [hash-map] - (when-let [mseq (seq hash-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 (first e) v (second 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))) - ret))) - -;;; PersistentHashSet - -(declare TransientHashSet) - -(deftype PersistentHashSet [meta hash-map ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - - ICloneable - (-clone [_] (PersistentHashSet. meta hash-map __hash)) - - IWithMeta - (-with-meta [coll meta] (PersistentHashSet. 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 cljs.core.PersistentHashSet.EMPTY meta)) - - IEquiv - (-equiv [coll other] - (and - (set? other) - (== (count coll) (count other)) - (every? #(contains? coll %) - other))) - - IHash - (-hash [coll] (caching-hash coll hash-iset __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 (-contains-key? hash-map v) - v - 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! cljs.core.PersistentHashSet.EMPTY - (PersistentHashSet. nil cljs.core.PersistentArrayMap.EMPTY 0)) - -(set! cljs.core.PersistentHashSet.fromArray - (fn [items ^boolean no-clone] - (let [len (alength items)] - (if (<= len cljs.core.PersistentArrayMap.HASHMAP_THRESHOLD) - (let [arr (if no-clone items (aclone items))] - (loop [i 0 - out (transient cljs.core.PersistentArrayMap.EMPTY)] - (if (< i len) - (recur (inc i) (-assoc! out (aget items i) nil)) - (cljs.core.PersistentHashSet. nil (-persistent! out) nil)))) - (loop [i 0 - out (transient cljs.core.PersistentHashSet.EMPTY)] - (if (< i len) - (recur (inc i) (-conj! out (aget items i))) - (-persistent! out))))))) - -(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)) - - ICloneable - (-clone [_] (PersistentTreeSet. meta tree-map __hash)) - - IWithMeta - (-with-meta [coll meta] (PersistentTreeSet. meta tree-map __hash)) - - IMeta - (-meta [coll] meta) - - ICollection - (-conj [coll o] - (PersistentTreeSet. meta (assoc tree-map o nil) nil)) - - IEmptyableCollection - (-empty [coll] (with-meta cljs.core.PersistentTreeSet.EMPTY meta)) - - IEquiv - (-equiv [coll other] - (and - (set? other) - (== (count coll) (count other)) - (every? #(contains? coll %) - other))) - - IHash - (-hash [coll] (caching-hash coll hash-iset __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! cljs.core.PersistentTreeSet.EMPTY - (PersistentTreeSet. nil cljs.core.PersistentTreeMap.EMPTY 0)) - -(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] - (let [^not-native in (seq coll)] - (cond - (nil? in) #{} - - (and (instance? IndexedSeq in) (zero? (.-i in))) - (set-from-indexed-seq in) - - :else - (loop [in in - ^not-native out (-as-transient #{})] - (if-not (nil? in) - (recur (-next in) (-conj! out (-first in))) - (-persistent! out)))))) - -(defn hash-set - ([] #{}) - ([& keys] (set keys))) - -(defn sorted-set - "Returns a new sorted set with supplied keys." - ([& keys] - (reduce -conj cljs.core.PersistentTreeSet.EMPTY keys))) - -(defn sorted-set-by - "Returns a new sorted set with supplied keys, using the supplied comparator." - ([comparator & keys] - (reduce -conj - (cljs.core.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" - [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" - [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 [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 ^not-native 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." - ([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." - ([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))) - -(defn partition-all - "Returns a lazy sequence of lists like partition, but may include - partitions with fewer than n items at the end." - ([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 true. pred must be free of side-effects." - [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 Range [meta start end step ^:mutable __hash] - Object - (toString [coll] - (pr-str* coll)) - - ICloneable - (-clone [_] (Range. meta start end step __hash)) - - IWithMeta - (-with-meta [rng meta] (Range. meta start end step __hash)) - - IMeta - (-meta [rng] meta) - - ISeqable - (-seq [rng] - (if (pos? step) - (when (< start end) - rng) - (when (> start end) - rng))) - - ISeq - (-first [rng] - (when-not (nil? (-seq rng)) start)) - (-rest [rng] - (if-not (nil? (-seq rng)) - (Range. meta (+ start step) end step nil) - ())) - - INext - (-next [rng] - (if (pos? step) - (when (< (+ start step) end) - (Range. meta (+ start step) end step nil)) - (when (> (+ start step) end) - (Range. meta (+ start step) end step nil)))) - - ICollection - (-conj [rng o] (cons o rng)) - - IEmptyableCollection - (-empty [rng] (with-meta cljs.core.List.EMPTY meta)) - - ISequential - IEquiv - (-equiv [rng other] (equiv-sequential rng other)) - - IHash - (-hash [rng] (caching-hash rng hash-coll __hash)) - - ICounted - (-count [rng] - (if-not (-seq rng) - 0 - (js/Math.ceil (/ (- end start) step)))) - - IIndexed - (-nth [rng n] - (if (< n (-count rng)) - (+ start (* n step)) - (if (and (> start end) (zero? step)) - start - (throw (js/Error. "Index out of bounds"))))) - (-nth [rng n not-found] - (if (< n (-count rng)) - (+ start (* n step)) - (if (and (> start end) (zero? step)) - start - not-found))) - - IReduce - (-reduce [rng f] (ci-reduce rng f)) - (-reduce [rng f s] (ci-reduce rng f s))) - -(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 js/Number.MAX_VALUE 1)) - ([end] (range 0 end 1)) - ([start end] (range start end 1)) - ([start end step] (Range. nil start end step nil))) - -(defn take-nth - "Returns a lazy seq of every nth item in coll." - [n coll] - (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." - [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 (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] - (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 (seq coll) - (recur (next coll)))) - ([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? [o] - (instance? js/RegExp o)) - -(defn re-matches - "Returns the result of (re-find re s) if re fully matches s." - [re s] - (let [matches (.exec re s)] - (when (= (first matches) s) - (if (== (count matches) 1) - (first matches) - (vec matches))))) - -(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] - (let [matches (.exec re s)] - (when-not (nil? matches) - (if (== (count matches) 1) - (first matches) - (vec matches))))) - -(defn re-seq - "Returns a lazy sequence of successive matches of re in s." - [re s] - (let [match-data (re-find re s) - match-idx (.search s re) - match-str (if (coll? match-data) (first match-data) match-data) - post-match (subs s (+ match-idx (count match-str)))] - (when match-data (lazy-seq (cons match-data (when (seq post-match) (re-seq re post-match))))))) - -(defn re-pattern - "Returns an instance of RegExp which has compiled the provided string." - [s] - (let [[_ flags pattern] (re-find #"^(?:\(\?([idmsux]*)\))?(.*)" s)] - (js/RegExp. pattern 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) - (when (seq coll) - (print-one (first coll) writer opts)) - (loop [coll (next coll) n (:print-length opts)] - (when (and coll (or (nil? n) (not (zero? n)))) - (-write writer sep) - (print-one (first coll) writer opts) - (recur (next coll) (dec n)))) - (when (:print-length opts) - (-write writer sep) - (print-one "..." writer opts)) - (-write writer end))))) - -(defn write-all [writer & ss] - (doseq [s ss] - (-write writer s))) - -(defn string-print [x] - (*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] (aget char-escapes match))) - \")) - -(declare print-map) - -(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] - (cond - (nil? obj) (-write writer "nil") - (undefined? obj) (-write writer "#
- * require('./bootstrap/nodejs')
- * goog.require('goog.ui.Component')
- *
- *
- * This loads goog.ui.Component in the global scope.
- *
- * If you want to load custom libraries, you can require the custom deps file
- * directly. If your custom libraries introduce new globals, you may
- * need to run goog.nodeGlobalRequire to get them to load correctly.
- *
- *
- * require('./path/to/my/deps.js')
- * goog.bootstrap.nodeJs.nodeGlobalRequire('./path/to/my/base.js')
- * goog.require('my.Class')
- *
- *
- * @author nick@medium.com (Nick Santos)
- *
- * @nocompile
- */
-
-
-var fs = require('fs');
-var path = require('path');
-
-
-/**
- * The goog namespace in the global scope.
- */
-global.goog = {};
-
-
-/**
- * Imports a script using Node's require() API.
- *
- * @param {string} src The script source.
- * @return {boolean} True if the script was imported, false otherwise.
- */
-global.CLOSURE_IMPORT_SCRIPT = function(src) {
- // Sources are always expressed relative to closure's base.js, but
- // require() is always relative to the current source.
- require('./../' + src);
- return true;
-};
-
-
-// Declared here so it can be used to require base.js
-function nodeGlobalRequire(file) {
- process.binding('evals').NodeScript.runInThisContext.call(
- global, fs.readFileSync(file), file);
-}
-
-
-// Load Closure's base.js into memory. It is assumed base.js is in the
-// directory above this directory given this script's location in
-// bootstrap/nodejs.js.
-nodeGlobalRequire(path.resolve(__dirname, '..', 'base.js'));
-
-
-/**
- * Bootstraps a file into the global scope.
- *
- * This is strictly for cases where normal require() won't work,
- * because the file declares global symbols with 'var' that need to
- * be added to the global scope.
- * @suppress {missingProvide}
- *
- * @param {string} file The path to the file.
- */
-goog.nodeGlobalRequire = nodeGlobalRequire;
-
diff --git a/src/cljs/cljs/nodejs_externs.js b/src/cljs/cljs/nodejs_externs.js
deleted file mode 100644
index 708db372ba..0000000000
--- a/src/cljs/cljs/nodejs_externs.js
+++ /dev/null
@@ -1,2 +0,0 @@
-function require(){}
-function process(){}
diff --git a/src/cljs/cljs/nodejscli.cljs b/src/cljs/cljs/nodejscli.cljs
deleted file mode 100644
index 20acc8d89b..0000000000
--- a/src/cljs/cljs/nodejscli.cljs
+++ /dev/null
@@ -1,9 +0,0 @@
-; Projects compiled with :target :nodejs have this file appended. Its
-; job is to make sure cljs.nodejs is loaded and that the *main-cli-fn*
-; is called with the script's command-line arguments.
-(ns cljs.nodejscli
- (:require [cljs.nodejs :as nodejs]))
-
-; Call the user's main function
-(apply cljs.core/*main-cli-fn* (drop 2 (.-argv nodejs/process)))
-
diff --git a/src/cljs/cljs/reader.cljs b/src/cljs/cljs/reader.cljs
deleted file mode 100644
index 782d07a09d..0000000000
--- a/src/cljs/cljs/reader.cljs
+++ /dev/null
@@ -1,599 +0,0 @@
-; 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.reader
- (:require [goog.string :as gstring]))
-
-(defprotocol PushbackReader
- (read-char [reader] "Returns the next char from the Reader,
-nil if the end of stream has been reached")
- (unread [reader ch] "Push back a single character on to the stream"))
-
-(deftype StringPushbackReader [s buffer ^:mutable idx]
- PushbackReader
- (read-char [reader]
- (if (zero? (alength buffer))
- (do
- (set! idx (inc idx))
- (aget s idx))
- (.pop buffer)))
- (unread [reader ch]
- (.push buffer ch)))
-
-(defn push-back-reader [s]
- "Creates a StringPushbackReader from a given string"
- (StringPushbackReader. s (array) -1))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; predicates
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defn- ^boolean whitespace?
- "Checks whether a given character is whitespace"
- [ch]
- (or (gstring/isBreakingWhitespace ch) (identical? \, ch)))
-
-(defn- ^boolean numeric?
- "Checks whether a given character is numeric"
- [ch]
- (gstring/isNumeric ch))
-
-(defn- ^boolean comment-prefix?
- "Checks whether the character begins a comment."
- [ch]
- (identical? \; ch))
-
-(defn- ^boolean number-literal?
- "Checks whether the reader is at the start of a number literal"
- [reader initch]
- (or (numeric? initch)
- (and (or (identical? \+ initch) (identical? \- initch))
- (numeric? (let [next-ch (read-char reader)]
- (unread reader next-ch)
- next-ch)))))
-
-(declare read macros dispatch-macros)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; read helpers
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-; later will do e.g. line numbers...
-(defn reader-error
- [rdr & msg]
- (throw (js/Error. (apply str msg))))
-
-(defn ^boolean macro-terminating? [ch]
- (and (not (identical? ch "#"))
- (not (identical? ch \'))
- (not (identical? ch ":"))
- (macros ch)))
-
-(defn read-token
- [rdr initch]
- (loop [sb (gstring/StringBuffer. initch)
- ch (read-char rdr)]
- (if (or (nil? ch)
- (whitespace? ch)
- (macro-terminating? ch))
- (do (unread rdr ch) (. sb (toString)))
- (recur (do (.append sb ch) sb) (read-char rdr)))))
-
-(defn skip-line
- "Advances the reader to the end of a line. Returns the reader"
- [reader _]
- (loop []
- (let [ch (read-char reader)]
- (if (or (identical? ch \newline) (identical? ch \return) (nil? ch))
- reader
- (recur)))))
-
-(def int-pattern (re-pattern "([-+]?)(?:(0)|([1-9][0-9]*)|0[xX]([0-9A-Fa-f]+)|0([0-7]+)|([1-9][0-9]?)[rR]([0-9A-Za-z]+)|0[0-9]+)(N)?"))
-(def ratio-pattern (re-pattern "([-+]?[0-9]+)/([0-9]+)"))
-(def float-pattern (re-pattern "([-+]?[0-9]+(\\.[0-9]*)?([eE][-+]?[0-9]+)?)(M)?"))
-(def symbol-pattern (re-pattern "[:]?([^0-9/].*/)?([^0-9/][^/]*)"))
-
-(defn- re-find*
- [re s]
- (let [matches (.exec re s)]
- (when-not (nil? matches)
- (if (== (alength matches) 1)
- (aget matches 0)
- matches))))
-
-(defn- match-int
- [s]
- (let [groups (re-find* int-pattern s)
- group3 (aget groups 2)]
- (if-not (or (nil? group3)
- (< (alength group3) 1))
- 0
- (let [negate (if (identical? "-" (aget groups 1)) -1 1)
- a (cond
- (aget groups 3) (array (aget groups 3) 10)
- (aget groups 4) (array (aget groups 4) 16)
- (aget groups 5) (array (aget groups 5) 8)
- (aget groups 7) (array (aget groups 7) (js/parseInt (aget groups 7)))
- :default (array nil nil))
- n (aget a 0)
- radix (aget a 1)]
- (if (nil? n)
- nil
- (* negate (js/parseInt n radix)))))))
-
-
-(defn- match-ratio
- [s]
- (let [groups (re-find* ratio-pattern s)
- numinator (aget groups 1)
- denominator (aget groups 2)]
- (/ (js/parseInt numinator) (js/parseInt denominator))))
-
-(defn- match-float
- [s]
- (js/parseFloat s))
-
-(defn- re-matches*
- [re s]
- (let [matches (.exec re s)]
- (when (and (not (nil? matches))
- (identical? (aget matches 0) s))
- (if (== (alength matches) 1)
- (aget matches 0)
- matches))))
-
-(defn- match-number
- [s]
- (cond
- (re-matches* int-pattern s) (match-int s)
- (re-matches* ratio-pattern s) (match-ratio s)
- (re-matches* float-pattern s) (match-float s)))
-
-(defn escape-char-map [c]
- (cond
- (identical? c \t) "\t"
- (identical? c \r) "\r"
- (identical? c \n) "\n"
- (identical? c \\) \\
- (identical? c \") \"
- (identical? c \b) "\b"
- (identical? c \f) "\f"
- :else nil))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; unicode
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defn read-2-chars [reader]
- (.toString
- (gstring/StringBuffer.
- (read-char reader)
- (read-char reader))))
-
-(defn read-4-chars [reader]
- (.toString
- (gstring/StringBuffer.
- (read-char reader)
- (read-char reader)
- (read-char reader)
- (read-char reader))))
-
-(def unicode-2-pattern (re-pattern "[0-9A-Fa-f]{2}"))
-(def unicode-4-pattern (re-pattern "[0-9A-Fa-f]{4}"))
-
-(defn validate-unicode-escape [unicode-pattern reader escape-char unicode-str]
- (if (re-matches unicode-pattern unicode-str)
- unicode-str
- (reader-error reader "Unexpected unicode escape \\" escape-char unicode-str)))
-
-(defn make-unicode-char [code-str]
- (let [code (js/parseInt code-str 16)]
- (.fromCharCode js/String code)))
-
-(defn escape-char
- [buffer reader]
- (let [ch (read-char reader)
- mapresult (escape-char-map ch)]
- (if mapresult
- mapresult
- (cond
- (identical? ch \x)
- (->> (read-2-chars reader)
- (validate-unicode-escape unicode-2-pattern reader ch)
- (make-unicode-char))
-
- (identical? ch \u)
- (->> (read-4-chars reader)
- (validate-unicode-escape unicode-4-pattern reader ch)
- (make-unicode-char))
-
- (numeric? ch)
- (.fromCharCode js/String ch)
-
- :else
- (reader-error reader "Unexpected unicode escape \\" ch )))))
-
-(defn read-past
- "Read until first character that doesn't match pred, returning
- char."
- [pred rdr]
- (loop [ch (read-char rdr)]
- (if (pred ch)
- (recur (read-char rdr))
- ch)))
-
-(defn read-delimited-list
- [delim rdr recursive?]
- (loop [a (transient [])]
- (let [ch (read-past whitespace? rdr)]
- (when-not ch (reader-error rdr "EOF while reading"))
- (if (identical? delim ch)
- (persistent! a)
- (if-let [macrofn (macros ch)]
- (let [mret (macrofn rdr ch)]
- (recur (if (identical? mret rdr) a (conj! a mret))))
- (do
- (unread rdr ch)
- (let [o (read rdr true nil recursive?)]
- (recur (if (identical? o rdr) a (conj! a o))))))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; data structure readers
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defn not-implemented
- [rdr ch]
- (reader-error rdr "Reader for " ch " not implemented yet"))
-
-(declare maybe-read-tagged-type)
-
-(defn read-dispatch
- [rdr _]
- (let [ch (read-char rdr)
- dm (dispatch-macros ch)]
- (if dm
- (dm rdr _)
- (if-let [obj (maybe-read-tagged-type rdr ch)]
- obj
- (reader-error rdr "No dispatch macro for " ch)))))
-
-(defn read-unmatched-delimiter
- [rdr ch]
- (reader-error rdr "Unmached delimiter " ch))
-
-(defn read-list
- [rdr _]
- (apply list (read-delimited-list ")" rdr true)))
-
-(def read-comment skip-line)
-
-(defn read-vector
- [rdr _]
- (read-delimited-list "]" rdr true))
-
-(defn read-map
- [rdr _]
- (let [l (read-delimited-list "}" rdr true)]
- (when (odd? (count l))
- (reader-error rdr "Map literal must contain an even number of forms"))
- (apply hash-map l)))
-
-(defn read-number
- [reader initch]
- (loop [buffer (gstring/StringBuffer. initch)
- ch (read-char reader)]
- (if (or (nil? ch) (whitespace? ch) (macros ch))
- (do
- (unread reader ch)
- (let [s (. buffer (toString))]
- (or (match-number s)
- (reader-error reader "Invalid number format [" s "]"))))
- (recur (do (.append buffer ch) buffer) (read-char reader)))))
-
-(defn read-string*
- [reader _]
- (loop [buffer (gstring/StringBuffer.)
- ch (read-char reader)]
- (cond
- (nil? ch) (reader-error reader "EOF while reading")
- (identical? "\\" ch) (recur (do (.append buffer (escape-char buffer reader)) buffer)
- (read-char reader))
- (identical? \" ch) (. buffer (toString))
- :default (recur (do (.append buffer ch) buffer) (read-char reader)))))
-
-(defn special-symbols [t not-found]
- (cond
- (identical? t "nil") nil
- (identical? t "true") true
- (identical? t "false") false
- :else not-found))
-
-(defn read-symbol
- [reader initch]
- (let [token (read-token reader initch)]
- (if (gstring/contains token "/")
- (symbol (subs token 0 (.indexOf token "/"))
- (subs token (inc (.indexOf token "/")) (.-length token)))
- (special-symbols token (symbol token)))))
-
-(defn read-keyword
- [reader initch]
- (let [token (read-token reader (read-char reader))
- a (re-matches* symbol-pattern token)
- token (aget a 0)
- ns (aget a 1)
- name (aget a 2)]
- (if (or (and (not (undefined? ns))
- (identical? (. ns (substring (- (.-length ns) 2) (.-length ns))) ":/"))
- (identical? (aget name (dec (.-length name))) ":")
- (not (== (.indexOf token "::" 1) -1)))
- (reader-error reader "Invalid token: " token)
- (if (and (not (nil? ns)) (> (.-length ns) 0))
- (keyword (.substring ns 0 (.indexOf ns "/")) name)
- (keyword token)))))
-
-(defn desugar-meta
- [f]
- (cond
- (symbol? f) {:tag f}
- (string? f) {:tag f}
- (keyword? f) {f true}
- :else f))
-
-(defn wrapping-reader
- [sym]
- (fn [rdr _]
- (list sym (read rdr true nil true))))
-
-(defn throwing-reader
- [msg]
- (fn [rdr _]
- (reader-error rdr msg)))
-
-(defn read-meta
- [rdr _]
- (let [m (desugar-meta (read rdr true nil true))]
- (when-not (map? m)
- (reader-error rdr "Metadata must be Symbol,Keyword,String or Map"))
- (let [o (read rdr true nil true)]
- (if (satisfies? IWithMeta o)
- (with-meta o (merge (meta o) m))
- (reader-error rdr "Metadata can only be applied to IWithMetas")))))
-
-(defn read-set
- [rdr _]
- (set (read-delimited-list "}" rdr true)))
-
-(defn read-regex
- [rdr ch]
- (-> (read-string* rdr ch) re-pattern))
-
-(defn read-discard
- [rdr _]
- (read rdr true nil true)
- rdr)
-
-(defn macros [c]
- (cond
- (identical? c \") read-string*
- (identical? c \:) read-keyword
- (identical? c \;) read-comment
- (identical? c \') (wrapping-reader 'quote)
- (identical? c \@) (wrapping-reader 'deref)
- (identical? c \^) read-meta
- (identical? c \`) not-implemented
- (identical? c \~) not-implemented
- (identical? c \() read-list
- (identical? c \)) read-unmatched-delimiter
- (identical? c \[) read-vector
- (identical? c \]) read-unmatched-delimiter
- (identical? c \{) read-map
- (identical? c \}) read-unmatched-delimiter
- (identical? c \\) read-char
- (identical? c \#) read-dispatch
- :else nil))
-
-;; omitted by design: var reader, eval reader
-(defn dispatch-macros [s]
- (cond
- (identical? s "{") read-set
- (identical? s "<") (throwing-reader "Unreadable form")
- (identical? s "\"") read-regex
- (identical? s"!") read-comment
- (identical? s "_") read-discard
- :else nil))
-
-(defn read
- "Reads the first object from a PushbackReader. Returns the object read.
- If EOF, throws if eof-is-error is true. Otherwise returns sentinel."
- [reader eof-is-error sentinel is-recursive]
- (let [ch (read-char reader)]
- (cond
- (nil? ch) (if eof-is-error (reader-error reader "EOF while reading") sentinel)
- (whitespace? ch) (recur reader eof-is-error sentinel is-recursive)
- (comment-prefix? ch) (recur (read-comment reader ch) eof-is-error sentinel is-recursive)
- :else (let [f (macros ch)
- res
- (cond
- f (f reader ch)
- (number-literal? reader ch) (read-number reader ch)
- :else (read-symbol reader ch))]
- (if (identical? res reader)
- (recur reader eof-is-error sentinel is-recursive)
- res)))))
-
-(defn read-string
- "Reads one object from the string s"
- [s]
- (let [r (push-back-reader s)]
- (read r true nil false)))
-
-
-;; read instances
-
-(defn ^:private zero-fill-right-and-truncate [s width]
- (cond (= width (count s)) s
- (< width (count s)) (subs s 0 width)
- :else (loop [b (gstring/StringBuffer. s)]
- (if (< (.getLength b) width)
- (recur (.append b "0"))
- (.toString b)))))
-
-(defn ^:private divisible?
- [num div]
- (zero? (mod num div)))
-
-(defn ^:private indivisible?
- [num div]
- (not (divisible? num div)))
-
-(defn ^:private leap-year?
- [year]
- (and (divisible? year 4)
- (or (indivisible? year 100)
- (divisible? year 400))))
-
-(def ^:private days-in-month
- (let [dim-norm [nil 31 28 31 30 31 30 31 31 30 31 30 31]
- dim-leap [nil 31 29 31 30 31 30 31 31 30 31 30 31]]
- (fn [month leap-year?]
- (get (if leap-year? dim-leap dim-norm) month))))
-
-(def ^:private timestamp-regex #"(\d\d\d\d)(?:-(\d\d)(?:-(\d\d)(?:[T](\d\d)(?::(\d\d)(?::(\d\d)(?:[.](\d+))?)?)?)?)?)?(?:[Z]|([-+])(\d\d):(\d\d))?")
-
-(defn ^:private parse-int [s]
- (let [n (js/parseInt s)]
- (if-not (js/isNaN n)
- n)))
-
-(defn ^:private check [low n high msg]
- (when-not (<= low n high)
- (reader-error nil (str msg " Failed: " low "<=" n "<=" high)))
- n)
-
-(defn parse-and-validate-timestamp [s]
- (let [[_ years months days hours minutes seconds fraction offset-sign offset-hours offset-minutes :as v]
- (re-matches timestamp-regex s)]
- (if-not v
- (reader-error nil (str "Unrecognized date/time syntax: " s))
- (let [years (parse-int years)
- months (or (parse-int months) 1)
- days (or (parse-int days) 1)
- hours (or (parse-int hours) 0)
- minutes (or (parse-int minutes) 0)
- seconds (or (parse-int seconds) 0)
- fraction (or (parse-int (zero-fill-right-and-truncate fraction 3)) 0)
- offset-sign (if (= offset-sign "-") -1 1)
- offset-hours (or (parse-int offset-hours) 0)
- offset-minutes (or (parse-int offset-minutes) 0)
- offset (* offset-sign (+ (* offset-hours 60) offset-minutes))]
- [years
- (check 1 months 12 "timestamp month field must be in range 1..12")
- (check 1 days (days-in-month months (leap-year? years)) "timestamp day field must be in range 1..last day in month")
- (check 0 hours 23 "timestamp hour field must be in range 0..23")
- (check 0 minutes 59 "timestamp minute field must be in range 0..59")
- (check 0 seconds (if (= minutes 59) 60 59) "timestamp second field must be in range 0..60")
- (check 0 fraction 999 "timestamp millisecond field must be in range 0..999")
- offset]))))
-
-(defn parse-timestamp
- [ts]
- (if-let [[years months days hours minutes seconds ms offset]
- (parse-and-validate-timestamp ts)]
- (js/Date.
- (- (.UTC js/Date years (dec months) days hours minutes seconds ms)
- (* offset 60 1000)))
- (reader-error nil (str "Unrecognized date/time syntax: " ts))))
-
-(defn ^:private read-date
- [s]
- (if (string? s)
- (parse-timestamp s)
- (reader-error nil "Instance literal expects a string for its timestamp.")))
-
-
-(defn ^:private read-queue
- [elems]
- (if (vector? elems)
- (into cljs.core.PersistentQueue.EMPTY elems)
- (reader-error nil "Queue literal expects a vector for its elements.")))
-
-
-(defn ^:private read-js
- [form]
- (cond
- (vector? form)
- (let [arr (array)]
- (doseq [x form]
- (.push arr x))
- arr)
-
- (map? form)
- (let [obj (js-obj)]
- (doseq [[k v] form]
- (aset obj (name k) v))
- obj)
-
- :else
- (reader-error nil
- (str "JS literal expects a vector or map containing "
- "only string or unqualified keyword keys"))))
-
-
-(defn ^:private read-uuid
- [uuid]
- (if (string? uuid)
- (UUID. uuid)
- (reader-error nil "UUID literal expects a string as its representation.")))
-
-(def *tag-table* (atom {"inst" read-date
- "uuid" read-uuid
- "queue" read-queue
- "js" read-js}))
-
-(def *default-data-reader-fn*
- (atom nil))
-
-(defn maybe-read-tagged-type
- [rdr initch]
- (let [tag (read-symbol rdr initch)
- pfn (get @*tag-table* (str tag))
- dfn @*default-data-reader-fn*]
- (cond
- pfn (pfn (read rdr true nil false))
- dfn (dfn tag (read rdr true nil false))
- :else (reader-error rdr
- "Could not find tag parser for " (str tag)
- " in " (pr-str (keys @*tag-table*))))))
-
-(defn register-tag-parser!
- [tag f]
- (let [tag (str tag)
- old-parser (get @*tag-table* tag)]
- (swap! *tag-table* assoc tag f)
- old-parser))
-
-(defn deregister-tag-parser!
- [tag]
- (let [tag (str tag)
- old-parser (get @*tag-table* tag)]
- (swap! *tag-table* dissoc tag)
- old-parser))
-
-(defn register-default-tag-parser!
- [f]
- (let [old-parser @*default-data-reader-fn*]
- (swap! *default-data-reader-fn* (fn [_] f))
- old-parser))
-
-(defn deregister-default-tag-parser!
- []
- (let [old-parser @*default-data-reader-fn*]
- (swap! *default-data-reader-fn* (fn [_] nil))
- old-parser))
diff --git a/src/cljs/clojure/browser/repl.cljs b/src/cljs/clojure/browser/repl.cljs
deleted file mode 100644
index 5038e4addb..0000000000
--- a/src/cljs/clojure/browser/repl.cljs
+++ /dev/null
@@ -1,109 +0,0 @@
-;; 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 ^{:doc "Receive - Eval - Print - Loop
-
- Receive a block of JS (presumably generated by a ClojureScript compiler)
- Evaluate it naively
- Print the result of evaluation to a string
- Send the resulting string back to the server Loop!"
-
- :author "Bobby Calderwood and Alex Redington"}
- clojure.browser.repl
- (:require [clojure.browser.net :as net]
- [clojure.browser.event :as event]))
-
-(def xpc-connection (atom nil))
-
-(defn repl-print [data]
- (if-let [conn @xpc-connection]
- (net/transmit conn :print (pr-str data))))
-
-(defn evaluate-javascript
- "Process a single block of JavaScript received from the server"
- [conn block]
- (let [result (try {:status :success :value (str (js* "eval(~{block})"))}
- (catch :default e
- {:status :exception :value (pr-str e)
- :stacktrace (if (.hasOwnProperty e "stack")
- (.-stack e)
- "No stacktrace available.")}))]
- (pr-str result)))
-
-(defn send-result [connection url data]
- (net/transmit connection url "POST" data nil 0))
-
-(defn send-print
- "Send data to be printed in the REPL. If there is an error, try again
- up to 10 times."
- ([url data]
- (send-print url data 0))
- ([url data n]
- (let [conn (net/xhr-connection)]
- (event/listen conn :error
- (fn [_]
- (if (< n 10)
- (send-print url data (inc n))
- (.log js/console (str "Could not send " data " after " n " attempts.")))))
- (net/transmit conn url "POST" data nil 0))))
-
-(def order (atom 0))
-
-(defn wrap-message [t data]
- (pr-str {:type t :content data :order (swap! order inc)}))
-
-(defn start-evaluator
- "Start the REPL server connection."
- [url]
- (if-let [repl-connection (net/xpc-connection)]
- (let [connection (net/xhr-connection)]
- (event/listen connection
- :success
- (fn [e]
- (net/transmit
- repl-connection
- :evaluate-javascript
- (.getResponseText (.-currentTarget e)
- ()))))
-
- (net/register-service repl-connection
- :send-result
- (fn [data]
- (send-result connection url (wrap-message :result data))))
-
- (net/register-service repl-connection
- :print
- (fn [data]
- (send-print url (wrap-message :print data))))
-
- (net/connect repl-connection
- (constantly nil))
-
- (js/setTimeout #(send-result connection url (wrap-message :ready "ready")) 50))
- (js/alert "No 'xpc' param provided to child iframe.")))
-
-(defn connect
- "Connects to a REPL server from an HTML document. After the
- connection is made, the REPL will evaluate forms in the context of
- the document that called this function."
- [repl-server-url]
- (let [repl-connection (net/xpc-connection
- {:peer_uri repl-server-url})]
- (swap! xpc-connection (constantly repl-connection))
- (net/register-service repl-connection
- :evaluate-javascript
- (fn [js]
- (net/transmit
- repl-connection
- :send-result
- (evaluate-javascript repl-connection js))))
- (net/connect repl-connection
- (constantly nil)
- (fn [iframe]
- (set! (.-display (.-style iframe))
- "none")))))
diff --git a/src/cljs/clojure/string.cljs b/src/cljs/clojure/string.cljs
deleted file mode 100644
index 0ced536247..0000000000
--- a/src/cljs/clojure/string.cljs
+++ /dev/null
@@ -1,180 +0,0 @@
-; 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 clojure.string
- (:refer-clojure :exclude [replace reverse])
- (:require [goog.string :as gstring]
- [goog.string.StringBuffer :as gstringbuf]))
-
-(defn- seq-reverse
- [coll]
- (reduce conj () coll))
-
-(defn reverse
- "Returns s with its characters reversed."
- [s]
- (.. s (split "") (reverse) (join "")))
-
-(defn replace
- "Replaces all instance of match with replacement in s.
- match/replacement can be:
-
- string / string
- pattern / (string or function of match)."
- [s match replacement]
- (cond (string? match)
- (.replace s (js/RegExp. (gstring/regExpEscape match) "g") replacement)
- (.hasOwnProperty match "source")
- (.replace s (js/RegExp. (.-source match) "g") replacement)
- :else (throw (str "Invalid match arg: " match))))
-
-(defn replace-first
- "Replaces the first instance of match with replacement in s.
- match/replacement can be:
-
- string / string
- pattern / (string or function of match)."
- [s match replacement]
- (.replace s match replacement))
-
-(defn join
- "Returns a string of all elements in coll, as returned by (seq coll),
- separated by an optional separator."
- ([coll]
- (apply str coll))
- ([separator coll]
- (apply str (interpose separator coll))))
-
-(defn upper-case
- "Converts string to all upper-case."
- [s]
- (.toUpperCase s))
-
-(defn lower-case
- "Converts string to all lower-case."
- [s]
- (.toLowerCase s))
-
-(defn capitalize
- "Converts first character of the string to upper-case, all other
- characters to lower-case."
- [s]
- (if (< (count s) 2)
- (upper-case s)
- (str (upper-case (subs s 0 1))
- (lower-case (subs s 1)))))
-
-;; The JavaScript split function takes a limit argument but the return
-;; value is not the same as the Java split function.
-;;
-;; Java: (.split "a-b-c" #"-" 2) => ["a" "b-c"]
-;; JavaScript: (.split "a-b-c" #"-" 2) => ["a" "b"]
-;;
-;; For consistency, the three arg version has been implemented to
-;; mimic Java's behavior.
-
-(defn- pop-last-while-empty
- [v]
- (loop [v v]
- (if (= "" (peek v))
- (recur (pop v))
- v)))
-
-(defn- discard-trailing-if-needed
- [limit v]
- (if (= 0 limit)
- (pop-last-while-empty v)
- v))
-
-(defn- split-with-empty-regex
- [s limit]
- (if (or (<= limit 0) (>= limit (+ 2 (count s))))
- (conj (vec (cons "" (map str (seq s)))) "")
- (condp = limit
- 1 (vector s)
- 2 (vector "" s)
- (let [c (- limit 2)]
- (conj (vec (cons "" (subvec (vec (map str (seq s))) 0 c))) (subs s c))))))
-
-(defn split
- "Splits string on a regular expression. Optional argument limit is
- the maximum number of splits. Not lazy. Returns vector of the splits."
- ([s re]
- (split s re 0))
- ([s re limit]
- (discard-trailing-if-needed limit
- (if (= (str re) "/(?:)/")
- (split-with-empty-regex s limit)
- (if (< limit 1)
- (vec (.split (str s) re))
- (loop [s s
- limit limit
- parts []]
- (if (= limit 1)
- (conj parts s)
- (if-let [m (re-find re s)]
- (let [index (.indexOf s m)]
- (recur (.substring s (+ index (count m)))
- (dec limit)
- (conj parts (.substring s 0 index))))
- (conj parts s)))))))))
-
-(defn split-lines
- "Splits s on \n or \r\n."
- [s]
- (split s #"\n|\r\n"))
-
-(defn trim
- "Removes whitespace from both ends of string."
- [s]
- (gstring/trim s))
-
-(defn triml
- "Removes whitespace from the left side of string."
- [s]
- (gstring/trimLeft s))
-
-(defn trimr
- "Removes whitespace from the right side of string."
- [s]
- (gstring/trimRight s))
-
-(defn trim-newline
- "Removes all trailing newline \\n or return \\r characters from
- string. Similar to Perl's chomp."
- [s]
- (loop [index (.-length s)]
- (if (zero? index)
- ""
- (let [ch (get s (dec index))]
- (if (or (= ch \newline) (= ch \return))
- (recur (dec index))
- (.substring s 0 index))))))
-
-(defn blank?
- "True is s is nil, empty, or contains only whitespace."
- [s]
- (gstring/isEmptySafe s))
-
-(defn escape
- "Return a new string, using cmap to escape each character ch
- from s as follows:
-
- If (cmap ch) is nil, append ch to the new string.
- If (cmap ch) is non-nil, append (str (cmap ch)) instead."
- [s cmap]
- (let [buffer (gstring/StringBuffer.)
- length (.-length s)]
- (loop [index 0]
- (if (= length index)
- (. buffer (toString))
- (let [ch (.charAt s index)]
- (if-let [replacement (get cmap ch)]
- (.append buffer (str replacement))
- (.append buffer ch))
- (recur (inc index)))))))
diff --git a/src/main/cljs/cljs/analyzer/passes.cljc b/src/main/cljs/cljs/analyzer/passes.cljc
new file mode 100644
index 0000000000..422504493c
--- /dev/null
+++ b/src/main/cljs/cljs/analyzer/passes.cljc
@@ -0,0 +1,32 @@
+;; 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.passes)
+
+(defn apply-passes
+ ([ast passes]
+ (apply-passes ast passes nil))
+ ([ast passes opts]
+ (reduce
+ (fn [ast pass]
+ (pass (:env ast) ast opts))
+ ast passes)))
+
+(defn walk
+ ([ast passes]
+ (walk ast passes nil))
+ ([ast passes opts]
+ (reduce
+ (fn [ast child-k]
+ (assoc ast
+ child-k
+ (let [child (get ast child-k)]
+ (if (vector? child)
+ (into [] (map #(walk % passes opts)) child)
+ (walk child passes opts)))))
+ (some-> ast (apply-passes passes opts)) (:children ast))))
diff --git a/src/main/cljs/cljs/analyzer/passes/and_or.cljc b/src/main/cljs/cljs/analyzer/passes/and_or.cljc
new file mode 100644
index 0000000000..52bc76c8a6
--- /dev/null
+++ b/src/main/cljs/cljs/analyzer/passes/and_or.cljc
@@ -0,0 +1,118 @@
+;; 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.passes.and-or
+ (:require [cljs.analyzer.passes :as passes]))
+
+(def simple-ops
+ #{:var :js-var :local :invoke :const :host-field :host-call :js :quote})
+
+(defn ->expr-env [ast]
+ (assoc-in ast [:env :context] :expr))
+
+(defn simple-op? [ast]
+ (contains? simple-ops (:op ast)))
+
+(defn simple-test-expr?
+ [{:keys [op] :as ast}]
+ (boolean
+ (and (simple-op? ast)
+ ('#{boolean seq}
+ (or (:tag ast)
+ (when (#{:local :var} op)
+ (-> ast :info :tag)))))))
+
+(defn single-binding-let? [ast]
+ (and (= :let (:op ast))
+ (= 1 (count (-> ast :bindings)))))
+
+(defn no-statements? [let-ast]
+ (= [] (-> let-ast :body :statements)))
+
+(defn returns-if? [let-ast]
+ (= :if (-> let-ast :body :ret :op)))
+
+(defn simple-test-binding-let? [ast]
+ (and (single-binding-let? ast)
+ (no-statements? ast)
+ (simple-test-expr? (-> ast :bindings first :init))
+ (returns-if? ast)))
+
+(defn test=then? [if-ast]
+ ;; remove :env, if same, local will differ only by
+ ;; :context (:expr | :statement)
+ (= (dissoc (:test if-ast) :env)
+ (dissoc (:then if-ast) :env)))
+
+(defn test=else? [if-ast]
+ ;; remove :env, if same, local will differ only by
+ ;; :context (:expr | :statement)
+ (= (dissoc (:test if-ast) :env)
+ (dissoc (:else if-ast) :env)))
+
+(defn simple-and? [ast]
+ (and (simple-test-binding-let? ast)
+ (test=else? (-> ast :body :ret))))
+
+(defn simple-or? [ast]
+ (and (simple-test-binding-let? ast)
+ (test=then? (-> ast :body :ret))))
+
+(defn optimizable-and? [ast]
+ (and (simple-and? ast)
+ (simple-test-expr? (-> ast :body :ret :then))))
+
+(defn optimizable-or? [ast]
+ (and (simple-or? ast)
+ (simple-test-expr? (-> ast :body :ret :else))))
+
+(defn remove-loop-let [fn-ast local]
+ (update fn-ast :loop-lets
+ (fn [loop-lets]
+ (map
+ (fn [m]
+ (update m :params
+ (fn [xs] (remove #(= local (:name %)) xs))))
+ loop-lets))))
+
+(defn remove-local-pass [local]
+ (fn [env ast opts]
+ (cond-> (update-in ast [:env :locals] dissoc local)
+ (= :fn (:op ast)) (remove-loop-let local))))
+
+(defn optimize-and [ast]
+ (let [{:keys [init name]} (-> ast :bindings first)]
+ {:op :js
+ :env (:env ast)
+ :segs ["((" ") && (" "))"]
+ :args [init
+ (passes/walk
+ (->expr-env (-> ast :body :ret :then))
+ [(remove-local-pass name)])]
+ :form (:form ast)
+ :children [:args]
+ :tag 'boolean}))
+
+(defn optimize-or [ast]
+ (let [{:keys [init name]} (-> ast :bindings first)]
+ {:op :js
+ :env (:env ast)
+ :segs ["((" ") || (" "))"]
+ :args [init
+ (passes/walk
+ (->expr-env (-> ast :body :ret :else))
+ [(remove-local-pass name)])]
+ :form (:form ast)
+ :children [:args]
+ :tag 'boolean}))
+
+(defn optimize [env ast _]
+ (cond
+ (optimizable-and? ast) (optimize-and ast)
+ (optimizable-or? ast) (optimize-or ast)
+ :else ast))
diff --git a/src/main/cljs/cljs/analyzer/passes/lite.cljc b/src/main/cljs/cljs/analyzer/passes/lite.cljc
new file mode 100644
index 0000000000..d0ea8c659b
--- /dev/null
+++ b/src/main/cljs/cljs/analyzer/passes/lite.cljc
@@ -0,0 +1,32 @@
+;; 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.passes.lite
+ (:refer-clojure :exclude [var?]))
+
+(defn var? [ast]
+ (= :var (:op ast)))
+
+(def ctor->ctor-lite
+ '{cljs.core/vector cljs.core/vector-lite
+ cljs.core/vec cljs.core/vec-lite})
+
+(defn update-var [{:keys [name] :as ast}]
+ (let [replacement (get ctor->ctor-lite name)]
+ (-> ast
+ (assoc :name replacement)
+ (assoc-in [:info :name] replacement))))
+
+(defn replace-var? [ast]
+ (and (var? ast)
+ (contains? ctor->ctor-lite (:name ast))))
+
+(defn use-lite-types
+ [env ast _]
+ (cond-> ast
+ (replace-var? ast) update-var))
diff --git a/src/main/cljs/cljs/bootstrap_nodejs.js b/src/main/cljs/cljs/bootstrap_nodejs.js
new file mode 100644
index 0000000000..a1cbd771c1
--- /dev/null
+++ b/src/main/cljs/cljs/bootstrap_nodejs.js
@@ -0,0 +1,154 @@
+// Copyright 2013 The Closure Library Authors.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS-IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+
+/**
+ * @fileoverview A nodejs script for dynamically requiring Closure within
+ * nodejs.
+ *
+ * Example of usage:
+ *
+ * require('./bootstrap/nodejs')
+ * goog.require('goog.ui.Component')
+ *
+ *
+ * This loads goog.ui.Component in the global scope.
+ *
+ * If you want to load custom libraries, you can require the custom deps file
+ * directly. If your custom libraries introduce new globals, you may
+ * need to run goog.nodeGlobalRequire to get them to load correctly.
+ *
+ *
+ * require('./path/to/my/deps.js')
+ * goog.bootstrap.nodeJs.nodeGlobalRequire('./path/to/my/base.js')
+ * goog.require('my.Class')
+ *
+ *
+ * @author nick@medium.com (Nick Santos)
+ *
+ * @nocompile
+ */
+
+var fs = require("fs");
+var vm = require("vm");
+var path = require("path");
+var CLJS_ROOT = ".";
+
+
+/**
+ * The goog namespace in the global scope.
+ */
+global.goog = {};
+
+
+/**
+ * Imports a script using Node's require() API.
+ *
+ * @param {string} src The script source.
+ * @return {boolean} True if the script was imported, false otherwise.
+ */
+global.CLOSURE_IMPORT_SCRIPT = function(src, opt_sourceText) {
+ // if CLJS_ROOT has been rewritten (by REPLs) need to compute require path
+ // so we can delete the old entry from the Node.js require cache
+ if(CLJS_ROOT !== ".") {
+ var cached = null;
+ if(src.substring(0, 2) == "..") {
+ cached = path.join(CLJS_ROOT, src.substring(3));
+ } else {
+ cached = path.join(CLJS_ROOT, "goog", src);
+ }
+ if(require.cache[cached]) delete require.cache[cached];
+ }
+
+ // Sources are always expressed relative to closure's base.js, but
+ // require() is always relative to the current source.
+ if (opt_sourceText === undefined) {
+ var flags = null;
+ if (goog.debugLoader_) {
+ var dep = goog.debugLoader_.dependencies_[src];
+ if (dep) {
+ flags = dep.loadFlags;
+ }
+ } else {
+ flags = goog.dependencies_.loadFlags[src];
+ }
+ if (flags && flags["foreign-lib"]) {
+ nodeGlobalRequire(path.resolve(__dirname, "..", src));
+ } else {
+ require(path.join(".", "..", src));
+ }
+ } else {
+ eval(opt_sourceText);
+ }
+ return true;
+};
+
+
+/**
+ * Loads a file when using Closure's goog.require() API with goog.modules.
+ *
+ * @param {string} src The file source.
+ * @return {string} The file contents.
+ */
+global.CLOSURE_LOAD_FILE_SYNC = function(src) {
+ return fs.readFileSync(
+ path.resolve(__dirname, "..", src), {encoding: "utf-8"});
+};
+
+
+// Declared here so it can be used to require base.js
+function nodeGlobalRequire(file) {
+ var _module = global.module,
+ _exports = global.exports,
+ exportedRequire = false;
+
+ // to circumvent Node.js environment detection in bundled libraries
+ global.module = undefined;
+ global.exports = undefined;
+
+ // to allow requires of Node.js libraries (i.e. platform libs) that
+ // couldn't be bundled for some reason
+ if(global.require == undefined) {
+ exportedRequire = true;
+ global.require = require;
+ }
+
+ vm.runInThisContext.call(global, fs.readFileSync(file), file);
+
+ global.exports = _exports;
+ global.module = _module;
+
+ if(exportedRequire) {
+ global.require = undefined;
+ }
+}
+
+
+// Load Closure's base.js into memory. It is assumed base.js is in the
+// directory above this directory given this script's location in
+// bootstrap/nodejs.js.
+nodeGlobalRequire(path.resolve(__dirname, "..", "base.js"));
+
+
+/**
+ * Bootstraps a file into the global scope.
+ *
+ * This is strictly for cases where normal require() won't work,
+ * because the file declares global symbols with 'var' that need to
+ * be added to the global scope.
+ * @suppress {missingProvide}
+ *
+ * @param {string} file The path to the file.
+ */
+goog.nodeGlobalRequire = nodeGlobalRequire;
+
diff --git a/src/main/cljs/cljs/core.cljs b/src/main/cljs/cljs/core.cljs
new file mode 100644
index 0000000000..c5d1866893
--- /dev/null
+++ b/src/main/cljs/cljs/core.cljs
@@ -0,0 +1,13148 @@
+; 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")
+
+(goog-define
+ ^{:doc "Boolean flag for LITE_MODE"}
+ LITE_MODE false)
+
+(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
+ ^{:dynamic true
+ :doc "bound in a repl thread to the most recent value printed"}
+ *1)
+
+(def
+ ^{:dynamic true
+ :doc "bound in a repl thread to the second most recent value printed"}
+ *2)
+
+(def
+ ^{:dynamic true
+ :doc "bound in a repl thread to the third most recent value printed"}
+ *3)
+
+(def
+ ^{:dynamic true
+ :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 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- pr-opts-fnl [opts]
+ (if-not (nil? opts)
+ (:flush-on-newline opts)
+ *flush-on-newline*))
+
+(defn- pr-opts-readably [opts]
+ (if-not (nil? opts)
+ (:readably opts)
+ *print-readably*))
+
+(defn- pr-opts-meta [opts]
+ (if-not (nil? opts)
+ (:meta opts)
+ *print-meta*))
+
+(defn- pr-opts-dup [opts]
+ (if-not (nil? opts)
+ (:dup opts)
+ *print-dup*))
+
+(defn- pr-opts-len [opts]
+ (if-not (nil? opts)
+ (:print-length opts)
+ *print-length*))
+
+(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]
+ (identical? "string" (goog/typeOf 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 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."))
+
+(defprotocol IDrop
+ "Protocol for persistent or algorithmically defined collections to provide a
+ means of dropping N items that is more efficient than sequential walking."
+ (^clj-or-nil -drop [coll n]
+ "Returns a collection that is ISequential, ISeq, and IReduce, or nil if past
+ the end. The number of items to drop n must be > 0. It is also useful if the
+ returned coll implements IDrop for subsequent use in a partition-like scenario."))
+
+;; 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 nil)
+ (-flush writer)
+ (.toString 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 hash-long [high low]
+ (bit-xor high low))
+
+(defn hash-double [f]
+ (let [arr (doto (js/Float64Array. 1) (aset 0 f))
+ buf (.-buffer arr)
+ high (.getInt32 (js/DataView. buf 0 4))
+ low (.getInt32 (js/DataView. buf 4 4))]
+ (hash-long high low)))
+
+(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 1024)
+ (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)
+ (if-not (.isSafeInteger js/Number o)
+ (hash-double 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)))
+
+(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
+ "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
+ "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))
+
+(defn- root-obj
+ []
+ (->> js/Function
+ (.getPrototypeOf js/Object)
+ (.getPrototypeOf js/Object)))
+
+(extend-type default
+ IHash
+ (-hash [o]
+ (if (identical? o (root-obj))
+ 0
+ (goog/getUid o))))
+
+(extend-type symbol
+ IHash
+ (-hash [o]
+ (hash (.toString 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) (unchecked-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) (unchecked-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)
+ ()))
+
+ INext
+ (-next [_] (if (< (inc i) (alength arr))
+ (IndexedSeq. arr (inc i) nil)
+ nil))
+
+ IDrop
+ (-drop [coll n]
+ (if (pos? n)
+ (if (< (+ i n) (alength arr))
+ (IndexedSeq. arr (+ i n) nil)
+ nil)
+ coll))
+
+ ICounted
+ (-count [_]
+ (unchecked-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).
+ (conj coll) returns coll. (conj) returns [].
+ 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]
+ (if (implements? IDrop coll)
+ (if (pos? n)
+ (or (-drop coll (Math/ceil n)) ())
+ coll)
+ (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
+ in associative collection, set, string, array, or ILookup instance."
+ ([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)
+ {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 (js-fn? 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 (js-fn? 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. To check the emptiness of a seq,
+ please use the idiom (seq x) rather than (not (empty? x))"
+ [coll]
+ (cond
+ (nil? coll)
+ true
+
+ (satisfies? ICounted coll)
+ (zero? (-count coll))
+
+ :else
+ (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]
+ (if-not ^boolean LITE_MODE
+ (implements? IChunkedSeq x)
+ false))
+
+;;;;;;;;;;;;;;;;;;;; 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)
+ (js-iterable? 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 (js/isNaN n))
+ (not (identical? n js/Infinity))
+ (== (js/parseFloat n) (js/parseInt n 10))))
+
+(def
+ ^{:doc "INTERNAL: do not use"}
+ LongImpl goog.math.Long)
+
+(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 ^boolean 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]
+ (cond
+ (implements? IAssociative coll)
+ (-contains-key? coll v)
+
+ (native-satisfies? IAssociative coll)
+ (-contains-key? coll v)
+
+ (identical? (get coll v lookup-sentinel) lookup-sentinel)
+ false
+
+ :else
+ 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 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 (satisfies? IKVReduce coll)
+ (-kv-reduce coll f init)
+ (reduce (fn [ret me]
+ (f ret (-key me) (-val me)))
+ init coll))))
+
+(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 abs
+ {:doc "Returns the absolute value of a."
+ :added "1.11.10"}
+ [a] (Math/abs a))
+
+(defn NaN?
+ "Returns true if num is NaN, else false"
+ [val]
+ (js/isNaN val))
+
+(defn ^number max
+ "Returns the greatest of the nums."
+ ([x] x)
+ ([x y]
+ (cond
+ (NaN? x) x
+ (NaN? y) y
+ (> x y) x
+ :else 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]
+ (cond
+ (NaN? x) x
+ (NaN? y) y
+ (< x y) x
+ :else 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."
+ [x]
+ (bit-or x 0))
+
+(defn unchecked-int
+ "Coerce to int."
+ [x]
+ (fix x))
+
+(defn long
+ "Coerce to long. Identical to `int'."
+ [x]
+ (fix x))
+
+(defn unchecked-long
+ "Coerce to long. 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]
+ (if (implements? IDrop coll)
+ (if (pos? n)
+ (-drop coll (Math/ceil n))
+ (seq coll))
+ (loop [n n xs (seq coll)]
+ (if (and xs (pos? n))
+ (recur (dec n) (next xs))
+ xs))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;; basics ;;;;;;;;;;;;;;;;;;
+
+(defn- str_
+ "Implementation detail. Internal str without circularity on IndexedSeq.
+ @param x
+ @param {...*} var_args"
+ [x var-args]
+ (cond
+ ;; works whether x is undefined or null (cljs nil)
+ (nil? x) ""
+ ;; if we have no more parameters, return
+ (undefined? var-args) (.join #js [x] "")
+ ;; var arg case without relying on CLJS fn machinery which creates
+ ;; a circularity via IndexedSeq
+ :else
+ (let [sb (StringBuffer.)
+ args (js-arguments)
+ len (alength args)]
+ (loop [i 0]
+ (if (< i len)
+ (do
+ (.append sb (cljs.core/str_ (aget args i)))
+ (recur (inc i)))
+ (.toString sb))))))
+
+(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)
+ ""
+ (.toString 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] "()")
+ (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]
+ ;; MAYBE FIXME: :lite-mode testing uncovered a very old bug, empty on seq
+ ;; should discard the metadata, we changed the behavior in LITE_MODE for now
+ ;; to avoid a breaking change
+ (if-not ^boolean LITE_MODE
+ (-with-meta (.-EMPTY List) meta)
+ (.-EMPTY List)))
+
+ 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)
+
+(declare ObjMap)
+
+;; 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 [gmap]
+ (if ^boolean LITE_MODE
+ (if (implements? ISeq gmap)
+ (if (next gmap)
+ (.createAsIfByAssoc ObjMap (to-array gmap))
+ (if (seq gmap)
+ (first gmap)
+ (.-EMPTY ObjMap)))
+ gmap)
+ (if (implements? ISeq gmap)
+ (if (next gmap)
+ (.createAsIfByAssoc PersistentArrayMap (to-array gmap))
+ (if (seq gmap)
+ (first gmap)
+ (.-EMPTY PersistentArrayMap)))
+ gmap)))
+
+(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]
+ (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))
+ [old-value new-value]))
+ [(-deref a) (-reset! a 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]
+ (if (instance? Atom a)
+ (reset-vals! a (f (.-state a)))
+ [(-deref a) (-swap! a f)]))
+ ([a f x]
+ (if (instance? Atom a)
+ (reset-vals! a (f (.-state a) x))
+ [(-deref a) (-swap! a f x)]))
+ ([a f x y]
+ (if (instance? Atom a)
+ (reset-vals! a (f (.-state a) x y))
+ [(-deref a) (-swap! a f x y)]))
+ ([a f x y & more]
+ (if (instance? Atom a)
+ (reset-vals! a (apply f (.-state a) x y more))
+ [(-deref a) (-swap! a f 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) (p1 y) (p2 x) (p2 y) (p3 x) (p3 y))))
+ ([x y z] (boolean (and (p1 x) (p1 y) (p1 z) (p2 x) (p2 y) (p2 z) (p3 x) (p3 y) (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) (p1 y) (p2 x) (p2 y) (p3 x) (p3 y)))
+ ([x y z] (or (p1 x) (p1 y) (p1 z) (p2 x) (p2 y) (p2 z) (p3 x) (p3 y) (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 laziness-preserving 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)]}
+ (if (implements? IDrop coll)
+ (or
+ (if (pos? n)
+ (-drop coll (Math/ceil n))
+ (seq coll))
+ ())
+ (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))
+
+ IDrop
+ (-drop [coll n]
+ (if (== count -1)
+ coll
+ (let [dropped-count (- count n)]
+ (when (pos? dropped-count)
+ (Repeat. nil dropped-count val nil nil)))))
+
+ 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)
+ (let [tm (meta to)
+ rf (fn
+ ([coll] (-> (persistent! coll) (-with-meta tm)))
+ ([coll v] (conj! coll v)))]
+ (transduce xform rf (transient to) from))
+ (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]
+ (loop [m m
+ ks (seq ks)]
+ (if (nil? ks)
+ m
+ (recur (get m (first ks))
+ (next 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
+ 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)))
+
+ IDrop
+ (-drop [coll n]
+ (if (< n cnt)
+ (let [offset (js-mod n 32)]
+ (chunked-seq coll (unchecked-array-for coll n) (- n offset) offset))
+ nil))
+
+ 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]
+ (if (number? k)
+ (-nth coll k)
+ (throw (js/Error. "Key must be integer"))))
+
+ 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)))
+
+ IDrop
+ (-drop [coll n]
+ (let [o (+ off n)]
+ (if (< o (alength node))
+ (chunked-seq vec node i o)
+ (let [i (+ i o)]
+ (if (< i (-count vec))
+ (let [new-offset (js-mod i 32)]
+ (chunked-seq vec (unchecked-array-for vec i) (- i new-offset) new-offset))
+ nil)))))
+
+ ICollection
+ (-conj [coll o]
+ (cons o coll))
+
+ IEmptyableCollection
+ (-empty [coll]
+ ())
+
+ ICounted
+ (-count [coll]
+ (- (-count vec) (+ i off)))
+
+ 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."))))
+ (-contains-key? [coll key]
+ (if (integer? key)
+ (and (<= 0 key) (< key (- end start)))
+ false))
+
+ 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 (unchecked-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 PersistentVector) 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))))))
+
+;; 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")))
+
+(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)))
+
+(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 (string? 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]
+ (case n
+ 0 key
+ 1 val
+ (throw (js/Error. "Index out of bounds"))))
+
+ (-nth [node n not-found]
+ (case n
+ 0 key
+ 1 val
+ 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]
+ (case k
+ 0 true
+ 1 true
+ false))
+
+ 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)))
+
+ IDrop
+ (-drop [coll n]
+ (when (< n (-count coll))
+ (PersistentArrayMapSeq. arr (+ i (* 2 n)) 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))
+ (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))
+
+ IDrop
+ (-drop [coll n]
+ (when-some [s (-seq coll)]
+ (-drop s n)))
+
+ 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)))))
+
+(defn key-test [key other]
+ (cond
+ (identical? key other) true
+ (keyword-identical? key other) true
+ :else (= key other)))
+
+(defn- ^boolean pam-dupes? [arr]
+ (loop [i 0]
+ (if (< i (alength arr))
+ (let [dupe? (loop [j 0]
+ (if (< j i)
+ (or
+ (key-test (aget arr i) (aget arr j))
+ (recur (+ 2 j)))
+ false))]
+ (or dupe? (recur (+ 2 i))))
+ false)))
+
+(defn- pam-new-size [arr]
+ (loop [i 0 n 0]
+ (if (< i (alength arr))
+ (let [dupe? (loop [j 0]
+ (if (< j i)
+ (or
+ (key-test (aget arr i) (aget arr j))
+ (recur (+ 2 j)))
+ false))]
+ (recur (+ 2 i) (if dupe? n (+ n 2))))
+ n)))
+
+(defn- pam-grow-seed-array [seed trailing]
+ (let [seed-cnt (dec (alength seed))
+ extra-kvs (seq trailing)
+ ret (make-array (+ seed-cnt (* 2 (count extra-kvs))))
+ ret (array-copy seed 0 ret 0 seed-cnt)]
+ (loop [i seed-cnt extra-kvs extra-kvs]
+ (if extra-kvs
+ (let [kv (first extra-kvs)]
+ (aset ret i (-key kv))
+ (aset ret (inc i) (-val kv))
+ (recur (+ 2 i) (next extra-kvs)))
+ ret))))
+
+(set! (.-createAsIfByAssoc PersistentArrayMap)
+ (fn [init]
+ ;; check trailing element
+ (let [len (alength init)
+ has-trailing? (== 1 (bit-and len 1))]
+ (if-not (or has-trailing? (pam-dupes? init))
+ (PersistentArrayMap. nil (/ len 2) init nil)
+ (.createAsIfByAssocComplexPath PersistentArrayMap init has-trailing?)))))
+
+(set! (.-createAsIfByAssocComplexPath PersistentArrayMap)
+ (fn [init ^boolean has-trailing?]
+ (let [init (if has-trailing?
+ (pam-grow-seed-array init
+ ;; into {} in case the final element is not a map but something conj-able
+ ;; for parity with Clojure implementation of CLJ-2603
+ (into {} (aget init (dec (alength init)))))
+ init)
+ n (pam-new-size init)
+ len (alength init)]
+ (if (< n len)
+ (let [nodups (make-array n)]
+ (loop [i 0 m 0]
+ (if (< i len)
+ (let [dupe? (loop [j 0]
+ (if (< j m)
+ (or
+ (key-test (aget init i) (aget init j))
+ (recur (+ 2 j)))
+ false))]
+ (if-not dupe?
+ (let [j (loop [j (- len 2)]
+ (if (>= j i)
+ (if (key-test (aget init i) (aget init j))
+ j
+ (recur (- j 2)))
+ j))]
+ (aset nodups m (aget init i))
+ (aset nodups (inc m) (aget init (inc j)))
+ (recur (+ 2 i) (+ 2 m)))
+ (recur (+ 2 i) m)))))
+ (PersistentArrayMap. nil (/ (alength nodups) 2) nodups nil))
+ (PersistentArrayMap. nil (/ (alength init) 2) init 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 create-node)
+
+(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)
+ (if (== bitmap bit)
+ 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
+ :else (aget arr (inc idx)))))
+
+ (inode-find [inode shift hash key not-found]
+ (let [idx (hash-collision-node-find-index arr cnt key)]
+ (cond (< idx 0) not-found
+ :else (MapEntry. (aget arr idx) (aget arr (inc idx)) nil))))
+
+ (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))
+ (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)
+ (if (<= (alength vs) i)
+ (throw (js/Error. (str_ "No value supplied for key: " (aget ks i))))
+ (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))
+ ;; FIXME: can we figure out something better here?
+ (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))
+ ;; FIXME: can we figure out something better here?
+ (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))
+ (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
+ (let [in' (next in)]
+ (if (nil? in')
+ (throw (js/Error. (str_ "No value supplied for key: " (first in))))
+ (recur (next in') (assoc! out (first in) (first 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))]
+ (if (odd? (alength arr))
+ (throw (js/Error. (str_ "No value supplied for key: " (last arr))))
+ (.createAsIfByAssoc PersistentArrayMap arr))))
+
+(defn seq-to-map-for-destructuring
+ "Builds a map from a seq as described in
+ https://clojure.org/reference/special_forms#keyword-arguments"
+ [s]
+ (if ^boolean LITE_MODE
+ (if (next s)
+ (.createAsIfByAssoc ObjMap (to-array s))
+ (if (seq s) (first s) (.-EMPTY ObjMap)))
+ (if (next s)
+ (.createAsIfByAssoc PersistentArrayMap (to-array s))
+ (if (seq s) (first s) (.-EMPTY PersistentArrayMap)))))
+
+(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))
+ (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]
+ (let [m (-assoc hash-map o nil)]
+ (if (identical? m hash-map)
+ coll
+ (PersistentHashSet. meta m 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]
+ (let [m (-dissoc hash-map v)]
+ (if (identical? m hash-map)
+ coll
+ (PersistentHashSet. meta m 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))
+ (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]
+ (let [m (-assoc tree-map o nil)]
+ (if (identical? m tree-map)
+ coll
+ (PersistentTreeSet. meta m 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]
+ (let [m (-dissoc tree-map v)]
+ (if (identical? m tree-map)
+ coll
+ (PersistentTreeSet. meta m 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 splitv-at
+ "Returns a vector of [(into [] (take n) coll) (drop n coll)]"
+ [n coll]
+ [(into [] (take n) coll) (drop n coll)])
+
+(defn partitionv
+ "Returns a lazy sequence of vectors 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 upto n items. In case there are
+ not enough padding elements, return a partition with less than n items."
+ ([n coll]
+ (partitionv n n coll))
+ ([n step coll]
+ (lazy-seq
+ (when-let [s (seq coll)]
+ (let [p (into [] (take n) s)]
+ (when (= n (count p))
+ (cons p (partitionv n step (nthrest s step))))))))
+ ([n step pad coll]
+ (lazy-seq
+ (when-let [s (seq coll)]
+ (let [p (into [] (take n) s)]
+ (if (= n (count p))
+ (cons p (partitionv n step pad (nthrest s step)))
+ (list (into [] (take n) (concat p pad)))))))))
+
+(defn partitionv-all
+ "Returns a lazy sequence of vector partitions, but may include
+ partitions with fewer than n items at the end.
+ Returns a stateful transducer when no collection is provided."
+ ([n]
+ (partition-all n))
+ ([n coll]
+ (partitionv-all n n coll))
+ ([n step coll]
+ (lazy-seq
+ (when-let [s (seq coll)]
+ (let [seg (into [] (take n) coll)]
+ (cons seg (partitionv-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)))
+
+(defn- range-count
+ "Returns exact size of remaining items in an IntegerRange."
+ [start end step]
+ (Math/ceil (/ (- end start) step)))
+
+(deftype IntegerRange [meta start end step 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))
+
+ ICloneable
+ (-clone [_] (IntegerRange. meta start end step cnt __hash))
+
+ IWithMeta
+ (-with-meta [rng new-meta]
+ (if (identical? new-meta meta)
+ rng
+ (IntegerRange. new-meta start end step cnt __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 (range-count (+ start step) end step) nil))
+ (when (> (+ start step) end)
+ (IntegerRange. nil (+ start step) end step (range-count (+ start step) end step) nil))))
+
+ IDrop
+ (-drop [rng n]
+ (if (pos? n)
+ (if (< n cnt)
+ (IntegerRange. nil (+ start (* step n)) end step (- cnt n) nil)
+ nil)
+ rng))
+
+ IChunkedSeq
+ (-chunked-first [rng]
+ (IntegerRangeChunk. start step (unchecked-min cnt 32)))
+ (-chunked-rest [rng]
+ (if (<= cnt 32)
+ ()
+ (let [start (+ start (* step 32))]
+ (cond
+ (pos? step)
+ (if (<= end start)
+ ()
+ (IntegerRange. nil start end step (range-count start end step) nil))
+
+ (neg? step)
+ (if (>= end start)
+ ()
+ (IntegerRange. nil start end step (range-count start end step) nil))
+
+ :else
+ (if (== end start)
+ ()
+ (repeat start))))))
+
+ 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]
+ cnt)
+
+ 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 (range-count start end step) 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 (range-count start end step) 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)
+ (unchecked-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? (pr-opts-len 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 (pr-opts-len 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]
+ (loop [ss (seq ss)]
+ (when-not (nil? ss)
+ (-write writer (first ss))
+ (recur (next ss)))))
+
+(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 (pr-opts-meta opts))
+ (implements? IMeta obj)
+ (not (nil? (meta obj)))))
+
+(declare VectorLite)
+
+(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
+ ;; FIXME: can we figure out something better here?
+ ;; 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
+ (js/isNaN obj) "##NaN"
+ (identical? obj js/Number.POSITIVE_INFINITY) "##Inf"
+ (identical? obj js/Number.NEGATIVE_INFINITY) "##-Inf"
+ (js/Object.is obj -0.0) "-0.0"
+ :else (str_ obj)))
+
+ (object? obj)
+ (do
+ (-write writer "#js ")
+ (print-map
+ (.map
+ (js-keys obj)
+ (fn [k]
+ (MapEntry.
+ (cond-> k (some? (.match k #"^[A-Za-z_\*\+\?!\-'][\w\*\+\?!\-']*$")) keyword)
+ (unchecked-get obj k)
+ nil)))
+ pr-writer writer opts))
+
+ (array? obj)
+ (pr-sequential-writer writer pr-writer "#js [" " " "]" opts obj)
+
+ (string? obj)
+ (if (pr-opts-readably opts)
+ (-write writer (quote-string obj))
+ (-write writer obj))
+
+ (js-fn? 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)
+ (loop [objs (next objs)]
+ (when-not (nil? objs)
+ (-write writer " ")
+ (pr-writer (first objs) writer opts)
+ (recur (next objs)))))
+
+(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 (pr-opts-fnl opts)
+ (flush))))
+
+(defn pr-str
+ "pr to a string, returning it. Fundamental entrypoint to IPrintWithWriter."
+ [& objs]
+ (pr-str-with-opts objs nil))
+
+(defn prn-str
+ "Same as pr-str followed by (newline)"
+ [& objs]
+ (prn-str-with-opts objs nil))
+
+(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 nil))
+
+(def ^{:doc
+ "Prints the object(s) using string-print.
+ print and println produce output for human consumption."}
+ print
+ (fn cljs-core-print [& objs]
+ (binding [*print-readably* false]
+ (pr-with-opts objs nil))))
+
+(defn print-str
+ "print to a string, returning it"
+ [& objs]
+ (binding [*print-readably* false]
+ (pr-str-with-opts objs nil)))
+
+(defn println
+ "Same as print followed by (newline)"
+ [& objs]
+ (binding [*print-readably* false]
+ (pr-with-opts objs nil))
+ (when *print-newline*
+ (newline nil)))
+
+(defn println-str
+ "println to a string, returning it"
+ [& objs]
+ (binding [*print-readably* false]
+ (prn-str-with-opts objs nil)))
+
+(defn prn
+ "Same as pr followed by (newline)."
+ [& objs]
+ (pr-with-opts objs nil)
+ (when *print-newline*
+ (newline nil)))
+
+(defn- strip-ns
+ [named]
+ (if (symbol? named)
+ (symbol nil (name named))
+ (keyword nil (name named))))
+
+(defn- lift-ns
+ "Returns #js [lifted-ns lifted-map] or nil if m can't be lifted."
+ [m]
+ (when *print-namespace-maps*
+ (let [lm #js []]
+ (loop [ns nil
+ [[k v :as entry] & entries] (seq m)]
+ (if entry
+ (when (or (keyword? k) (symbol? k))
+ (if ns
+ (when (= ns (namespace k))
+ (.push lm (MapEntry. (strip-ns k) v nil))
+ (recur ns entries))
+ (when-let [new-ns (namespace k)]
+ (.push lm (MapEntry. (strip-ns k) v nil))
+ (recur new-ns entries))))
+ #js [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))
+ ns (some-> ns&lift-map (aget 0))]
+ (if ns
+ (print-prefix-map (str_ "#:" ns) (aget ns&lift-map 1) 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))
+
+ 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)
+
+(defn iteration
+ "Creates a seqable/reducible via repeated calls to step,
+ a function of some (continuation token) 'k'. The first call to step
+ will be passed initk, returning 'ret'. Iff (somef ret) is true,
+ (vf ret) will be included in the iteration, else iteration will
+ terminate and vf/kf will not be called. If (kf ret) is non-nil it
+ will be passed to the next step call, else iteration will terminate.
+ This can be used e.g. to consume APIs that return paginated or batched data.
+ step - (possibly impure) fn of 'k' -> 'ret'
+ :somef - fn of 'ret' -> logical true/false, default 'some?'
+ :vf - fn of 'ret' -> 'v', a value produced by the iteration, default 'identity'
+ :kf - fn of 'ret' -> 'next-k' or nil (signaling 'do not continue'), default 'identity'
+ :initk - the first value passed to step, default 'nil'
+ It is presumed that step with non-initk is unreproducible/non-idempotent.
+ If step with initk is unreproducible it is on the consumer to not consume twice."
+ {:added "1.11"}
+ [step & {:keys [somef vf kf initk]
+ :or {vf identity
+ kf identity
+ somef some?
+ initk nil}}]
+ (reify
+ ISeqable
+ (-seq [_]
+ ((fn next [ret]
+ (when (somef ret)
+ (cons (vf ret)
+ (when-some [k (kf ret)]
+ (lazy-seq (next (step k)))))))
+ (step initk)))
+ IReduce
+ (-reduce [_ rf init]
+ (loop [acc init
+ ret (step initk)]
+ (if (somef ret)
+ (let [acc (rf acc (vf ret))]
+ (if (reduced? acc)
+ @acc
+ (if-some [k (kf ret)]
+ (recur acc (step k))
+ acc)))
+ acc)))))
+
+(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 bases
+ "Returns the immediate prototype of c"
+ [c]
+ (when c
+ (let [s (.getPrototypeOf js/Object c)]
+ (when s
+ (list s)))))
+
+(defn supers
+ "Returns the immediate and indirect prototypes of c, if any"
+ [c]
+ (loop [ret (set (bases c)) cs ret]
+ (if (seq cs)
+ (let [c (first cs) bs (bases c)]
+ (recur (into ret bs) (into (disj cs c) bs)))
+ (not-empty ret))))
+
+(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 (js-fn? parent) (js-fn? child)
+ (instance? parent child))
+ (contains? ((:ancestors h) child) parent)
+ (and (js-fn? 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
+ (let [tp (get (:parents h) tag)]
+ (if (js-fn? tag)
+ (into (set (bases tag)) tp)
+ tp)))))
+
+(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
+ (let [ta (get (:ancestors h) tag)]
+ (if (js-fn? tag)
+ (let [superclasses (set (supers tag))]
+ (reduce into superclasses
+ (cons ta
+ (map #(get (:ancestors h) %) superclasses))))
+ ta)))))
+
+(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]
+ (if (js-fn? tag)
+ (throw (js/Error. "Can't get descendants of constructors"))
+ (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 (js-fn? tag) (and (implements? INamed tag) (namespace tag))))
+ (swap-global-hierarchy! derive tag parent) nil)
+ ([h tag parent]
+ (assert (not= tag parent))
+ (assert (or (js-fn? tag) (implements? INamed tag)))
+ (assert (implements? 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-y dispatch-val-x 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 its default-dispatch-val."
+ [multifn] (-default-dispatch-val multifn))
+
+(defn dispatch-fn
+ "Given a multimethod, return its 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 (implements? IUUID 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
+ "Returns a UUID consistent with the string s."
+ [s]
+ (assert (string? s))
+ (UUID. (.toLowerCase s) nil))
+
+(defn random-uuid
+ "Returns a pseudo-randomly generated UUID instance (i.e. type 4)."
+ []
+ (letfn [(^string quad-hex []
+ (let [unpadded-hex ^string (.toString (rand-int 65536) 16)]
+ (case (count unpadded-hex)
+ 1 (str_ "000" unpadded-hex)
+ 2 (str_ "00" unpadded-hex)
+ 3 (str_ "0" unpadded-hex)
+ unpadded-hex)))]
+ (let [ver-tripple-hex ^string (.toString (bit-or 0x4000 (bit-and 0x0fff (rand-int 65536))) 16)
+ res-tripple-hex ^string (.toString (bit-or 0x8000 (bit-and 0x3fff (rand-int 65536))) 16)]
+ (uuid
+ (str_ (quad-hex) (quad-hex) "-" (quad-hex) "-"
+ ver-tripple-hex "-" res-tripple-hex "-"
+ (quad-hex) (quad-hex) (quad-hex))))))
+
+(defn uuid?
+ "Return true if x is a 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 Throwable->map
+ "Constructs a data representation for an Error with keys:
+ :cause - root cause message
+ :phase - error phase
+ :via - cause chain, with cause keys:
+ :type - exception class symbol
+ :message - exception message
+ :data - ex-data
+ :at - top stack element
+ :trace - root cause stack elements"
+ [o]
+ (let [base (fn [t]
+ (merge {:type (cond
+ (instance? ExceptionInfo t) `ExceptionInfo
+ (instance? js/Error t) (symbol "js" (.-name t))
+ :else nil)}
+ (when-let [msg (ex-message t)]
+ {:message msg})
+ (when-let [ed (ex-data t)]
+ {:data ed})
+ #_(let [st (extract-canonical-stacktrace t)]
+ (when (pos? (count st))
+ {:at st}))))
+ via (loop [via [], t o]
+ (if t
+ (recur (conj via t) (ex-cause t))
+ via))
+ root (peek via)]
+ (merge {:via (vec (map base via))
+ :trace nil #_(extract-canonical-stacktrace (or root o))}
+ (when-let [root-msg (ex-message root)]
+ {:cause root-msg})
+ (when-let [data (ex-data root)]
+ {:data data})
+ (when-let [phase (-> o ex-data :clojure.error/phase)]
+ {:phase phase}))))
+
+(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 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] - if var, finds fn at key :test in var metadata, if function, finds
+ special test property. Calls it, presuming failure will throw exception.
+
+ Examples:
+
+ (test my-fn) ;; :ok
+ (test #'my-fn) ;; :ok"
+ [v]
+ (let [f (if (instance? Var v)
+ (-> v meta :test)
+ (some-> v .-cljs$lang$test))]
+ (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
+ "Munge string `name` without considering `..` or JavaScript reserved keywords."
+ [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
+ "Munge symbol or string `name` for safe use in JavaScript.
+
+ - Replaces '..' with '_DOT__DOT_'.
+ - Appends '$' to JavaScript reserved keywords.
+ - Returns a symbol if `name` was a symbol, otherwise a string."
+ [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))))))
+
+(defn update-vals
+ "m f => {k (f v) ...}
+ Given a map m and a function f of 1-argument, returns a new map where the keys of m
+ are mapped to result of applying f to the corresponding values of m."
+ {:added "1.11"}
+ [m f]
+ (with-meta
+ (persistent!
+ (reduce-kv (fn [acc k v] (assoc! acc k (f v)))
+ (if (implements? IEditableCollection m)
+ (transient m)
+ (transient {}))
+ m))
+ (meta m)))
+
+(defn update-keys
+ "m f => {(f k) v ...}
+ Given a map m and a function f of 1-argument, returns a new map whose
+ keys are the result of applying f to the keys of m, mapped to the
+ corresponding values of m.
+ f must return a unique key for each key of m, else the behavior is undefined."
+ {:added "1.11"}
+ [m f]
+ (let [ret (persistent!
+ (reduce-kv (fn [acc k v] (assoc! acc (f k) v))
+ (transient {})
+ m))]
+ (with-meta ret (meta m))))
+
+;; -----------------------------------------------------------------------------
+;; 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 (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 (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 ^:private parsing-err
+ "Construct message for parsing for non-string parsing error"
+ [val]
+ (str_ "Expected string, got: " (if (nil? val) "nil" (goog/typeOf val))))
+
+(defn ^number parse-long
+ "Parse string of decimal digits with optional leading -/+ and return an
+ integer value, or nil if parse fails"
+ [s]
+ (if (string? s)
+ (and (re-matches #"[+-]?\d+" s)
+ (let [i (js/parseInt s)]
+ (when (and (<= i js/Number.MAX_SAFE_INTEGER)
+ (>= i js/Number.MIN_SAFE_INTEGER))
+ i)))
+ (throw (js/Error. (parsing-err s)))))
+
+(defn ^number parse-double
+ "Parse string with floating point components and return a floating point value,
+ or nil if parse fails.
+ Grammar: https://docs.oracle.com/javase/8/docs/api/java/lang/Double.html#valueOf-java.lang.String-"
+ [s]
+ (if (string? s)
+ (cond
+ ;; FIXME: another cases worth thinking about
+ ^boolean (re-matches #"[\x00-\x20]*[+-]?NaN[\x00-\x20]*" s) ##NaN
+ ^boolean (re-matches
+ #"[\x00-\x20]*[+-]?(Infinity|((\d+\.?\d*|\.\d+)([eE][+-]?\d+)?)[dDfF]?)[\x00-\x20]*"
+ s) (js/parseFloat s)
+ :default nil)
+ (throw (js/Error. (parsing-err s)))))
+
+(def ^:private uuid-regex
+ #"^[0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F]-[0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F]-[0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F]-[0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F]-[0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F]$")
+
+(defn parse-uuid
+ "Parse a string representing a UUID and return a UUID instance,
+ or nil if parse fails.
+ Grammar: https://docs.oracle.com/javase/8/docs/api/java/util/UUID.html#toString--"
+ [s]
+ (if (string? s)
+ (when ^boolean (re-matches uuid-regex s)
+ (uuid s))
+ (throw (js/Error. (parsing-err s)))))
+
+(defn parse-boolean
+ "Parse strings \"true\" or \"false\" and return a boolean, or nil if invalid. Note that this explicitly
+ excludes strings with different cases, or space characters."
+ [s]
+ (if (string? s)
+ (case s
+ "true" true
+ "false" false
+ nil)
+ (throw (js/Error. (parsing-err s)))))
+
+(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)))
+
+;; -----------------------------------------------------------------------------
+;; Original 2011 Copy-on-Write Types
+
+;;; VectorLite
+
+(deftype VectorLiteIterator [arr ^:mutable i]
+ Object
+ (hasNext [_]
+ (< i (alength arr)))
+ (next [_]
+ (let [x (aget arr i)]
+ (set! i (inc i))
+ x)))
+
+(deftype VectorLite [meta array ^:mutable __hash]
+ Object
+ (toString [coll]
+ (pr-str* coll))
+ (equiv [coll other]
+ (-equiv coll other))
+ (indexOf [coll x start]
+ (let [start (if (nil? start) 0 start)
+ len (-count coll)]
+ (if (>= start len)
+ -1
+ (loop [idx (cond
+ (pos? start) start
+ (neg? start) (unchecked-max 0 (+ start len))
+ :else start)]
+ (if (< idx len)
+ (if (= (-nth coll idx) x)
+ idx
+ (recur (inc idx)))
+ -1)))))
+ (lastIndexOf [coll x start]
+ (let [start (if (nil? start) (alength array) start)
+ len (-count coll)]
+ (if (zero? len)
+ -1
+ (loop [idx (cond
+ (pos? start) (unchecked-min (dec len) start)
+ (neg? start) (+ len start)
+ :else start)]
+ (if (>= idx 0)
+ (if (= (-nth coll idx) x)
+ idx
+ (recur (dec idx)))
+ -1)))))
+
+ IWithMeta
+ (-with-meta [coll new-meta]
+ (if (identical? new-meta meta)
+ coll
+ (VectorLite. new-meta array __hash)))
+
+ ICloneable
+ (-clone [coll] (VectorLite. meta array __hash))
+
+ IMeta
+ (-meta [coll] meta)
+
+ IStack
+ (-peek [coll]
+ (let [count (alength array)]
+ (when (> count 0)
+ (aget array (dec count)))))
+ (-pop [coll]
+ (if (> (alength array) 0)
+ (let [new-array (aclone array)]
+ (. new-array (pop))
+ (VectorLite. meta new-array nil))
+ (throw (js/Error. "Can't pop empty vector"))))
+
+ ICollection
+ (-conj [coll o]
+ (let [new-array (aclone array)]
+ (.push new-array o)
+ (VectorLite. meta new-array nil)))
+
+ IEmptyableCollection
+ (-empty [coll] (with-meta (. VectorLite -EMPTY) meta))
+
+ ISequential
+ IEquiv
+ (-equiv [coll other] (equiv-sequential coll other))
+
+ IHash
+ (-hash [coll] (hash-ordered-coll coll))
+
+ ISeqable
+ (-seq [coll]
+ (when (> (alength array) 0)
+ (prim-seq array)))
+
+ ICounted
+ (-count [coll] (alength array))
+
+ IIndexed
+ (-nth [coll n]
+ (if (and (<= 0 n) (< n (alength array)))
+ (aget array (int n))
+ (throw (js/Error. (str "No item " n " in vector of length " (alength array))))))
+ (-nth [coll n not-found]
+ (if (and (<= 0 n) (< n (alength array)))
+ (aget array (int n))
+ not-found))
+
+ ILookup
+ (-lookup [coll k]
+ (when (number? k)
+ (-nth 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)
+ (let [new-array (aclone array)]
+ (aset new-array k v)
+ (VectorLite. meta new-array nil))
+ (throw (js/Error. "Vector's key for assoc must be a number."))))
+ (-contains-key? [coll k]
+ (if (integer? k)
+ (and (<= 0 k) (< k (alength array)))
+ false))
+
+ IVector
+ (-assoc-n [coll n val] (-assoc coll n val))
+
+ IReversible
+ (-rseq [coll]
+ (let [cnt (alength array)]
+ (when (pos? cnt)
+ (RSeq. coll (dec cnt) nil))))
+
+ IReduce
+ (-reduce [v f]
+ (array-reduce array f))
+ (-reduce [v f start]
+ (array-reduce array f start))
+
+ IKVReduce
+ (-kv-reduce [v f init]
+ (let [len (alength array)]
+ (loop [i 0 init init]
+ (if (< i len)
+ (let [init (f init i (aget array i))]
+ (if (reduced? init)
+ @init
+ (recur (inc i) init)))
+ init))))
+
+ IDrop
+ (-drop [v n]
+ (let [cnt (alength array)]
+ (if (< n cnt)
+ (prim-seq array n)
+ nil)))
+
+ IComparable
+ (-compare [x y]
+ (if (vector? y)
+ (compare-indexed x y)
+ (throw (js/Error. "Cannot compare with Vector"))))
+
+ IFn
+ (-invoke [coll k]
+ (if (number? k)
+ (-nth coll k)
+ (throw (js/Error. "Key must be integer"))))
+
+ IEditableCollection
+ (-as-transient [coll]
+ coll)
+
+ ITransientCollection
+ (-conj! [coll val]
+ (-conj coll val))
+ (-persistent! [coll]
+ coll)
+
+ ITransientAssociative
+ (-assoc! [tcoll key val]
+ (-assoc-n! tcoll key val))
+
+ ITransientVector
+ (-assoc-n! [tcoll key val]
+ (if (number? key)
+ (-assoc-n tcoll key val)
+ (throw (js/Error. "Vector's key for assoc! must be a number."))))
+
+ (-pop! [tcoll]
+ (-pop tcoll))
+
+ IIterable
+ (-iterator [coll]
+ (VectorLiteIterator. array 0))
+
+ IPrintWithWriter
+ (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "[" " " "]" opts coll)))
+
+(es6-iterable VectorLite)
+
+(set! (. VectorLite -EMPTY) (VectorLite. nil (array) nil))
+
+(set! (. VectorLite -fromArray) (fn [xs] (VectorLite. nil xs nil)))
+
+(defn vector-lite
+ ":lite-mode version of vector, not intended to be used directly."
+ [& args]
+ (if (and (instance? IndexedSeq args) (zero? (.-i args)))
+ (.fromArray VectorLite (aclone (.-arr args)))
+ (VectorLite. nil (into-array args) nil)))
+
+(defn vec-lite
+ ":lite-mode version of vec, not intended to be used directly."
+ [coll]
+ (cond
+ (map-entry? coll)
+ [(key coll) (val coll)]
+
+ (vector? coll)
+ (with-meta coll nil)
+
+ (array? coll)
+ (.fromArray VectorLite coll)
+
+ :else
+ (into [] coll)))
+
+; 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-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))
+
+(declare hash-map-lite HashMapLite)
+
+(defn- keyword->obj-map-key
+ [k]
+ (str "\uFDD0" "'" (. k -fqn)))
+
+(defn- obj-map-key->keyword
+ [k]
+ (if (.startsWith k "\uFDD0")
+ (keyword (.substring k 2 (. k -length)))
+ k))
+
+(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)))))))
+
+(deftype ObjMapIterator [strkeys strobj ^:mutable i]
+ Object
+ (hasNext [_]
+ (< i (alength strkeys)))
+ (next [_]
+ (let [k (aget strkeys i)]
+ (set! i (inc i))
+ (MapEntry. (obj-map-key->keyword k) (unchecked-get strobj k) nil))))
+
+(deftype ObjMap [meta strkeys strobj ^:mutable __hash]
+ Object
+ (toString [coll]
+ (pr-str* coll))
+ (keys [coll]
+ (es6-iterator
+ (prim-seq
+ (.map (.sort strkeys obj-map-compare-keys)
+ obj-map-key->keyword))))
+ (entries [coll]
+ (es6-entries-iterator (-seq coll)))
+ (values [coll]
+ (es6-iterator
+ (prim-seq
+ (.map (.sort strkeys obj-map-compare-keys)
+ #(unchecked-get strobj %)))))
+ (has [coll k]
+ (contains? coll k))
+ (get [coll k not-found]
+ (-lookup coll k not-found))
+ (forEach [coll f]
+ (.forEach (.sort strkeys obj-map-compare-keys)
+ #(f (unchecked-get strobj %) (obj-map-key->keyword %))))
+
+ IWithMeta
+ (-with-meta [coll meta] (ObjMap. meta strkeys strobj __hash))
+
+ IMeta
+ (-meta [coll] meta)
+
+ ICloneable
+ (-clone [coll] (ObjMap. meta strkeys strobj __hash))
+
+ ICollection
+ (-conj [coll entry]
+ (if (vector? entry)
+ (-assoc coll (-nth entry 0) (-nth entry 1))
+ (reduce -conj coll entry)))
+
+ IEmptyableCollection
+ (-empty [coll] (-with-meta (. ObjMap -EMPTY) 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 strkeys))
+ (prim-seq
+ (.map (.sort strkeys obj-map-compare-keys)
+ #(MapEntry. (obj-map-key->keyword %) (unchecked-get strobj %) nil)))))
+
+ ICounted
+ (-count [coll] (alength strkeys))
+
+ ILookup
+ (-lookup [coll k] (-lookup coll k nil))
+ (-lookup [coll k not-found]
+ (let [k (if-not (keyword? k) k (keyword->obj-map-key k))]
+ (if (and (string? k)
+ (not (nil? (scan-array 1 k strkeys))))
+ (unchecked-get strobj k)
+ not-found)))
+
+ IAssociative
+ (-assoc [coll k v]
+ (let [k (if-not (keyword? k) k (keyword->obj-map-key k))]
+ (if (string? k)
+ (if-not (nil? (scan-array 1 k strkeys))
+ (if (identical? v (gobject/get strobj k))
+ coll
+ ; overwrite
+ (let [new-strobj (obj-clone strobj strkeys)]
+ (gobject/set new-strobj k v)
+ (ObjMap. meta strkeys new-strobj nil)))
+ ; append
+ (let [new-strobj (obj-clone strobj strkeys)
+ new-keys (aclone strkeys)]
+ (gobject/set new-strobj k v)
+ (.push new-keys k)
+ (ObjMap. meta new-keys new-strobj nil)))
+ ; non-string key. game over.
+ (-with-meta
+ (-kv-reduce coll
+ (fn [ret k v]
+ (-assoc ret k v))
+ (hash-map-lite k v))
+ meta))))
+ (-contains-key? [coll k]
+ (let [k (if-not (keyword? k) k (keyword->obj-map-key k))]
+ (if (and (string? k)
+ (not (nil? (scan-array 1 k strkeys))))
+ true
+ false)))
+
+ IFind
+ (-find [coll k]
+ (let [k' (if-not (keyword? k) k (keyword->obj-map-key k))]
+ (when (and (string? k')
+ (not (nil? (scan-array 1 k' strkeys))))
+ (MapEntry. k (unchecked-get strobj k') nil))))
+
+ IKVReduce
+ (-kv-reduce [coll f init]
+ (let [len (alength strkeys)]
+ (loop [keys (.sort strkeys obj-map-compare-keys)
+ init init]
+ (if (seq keys)
+ (let [k (first keys)
+ init (f init (obj-map-key->keyword k) (unchecked-get strobj k))]
+ (if (reduced? init)
+ @init
+ (recur (rest keys) init)))
+ init))))
+
+ IIterable
+ (-iterator [coll]
+ (ObjMapIterator. strkeys strobj 0))
+
+ IReduce
+ (-reduce [coll f]
+ (iter-reduce coll f))
+ (-reduce [coll f start]
+ (iter-reduce coll f start))
+
+ IMap
+ (-dissoc [coll k]
+ (let [k (if-not (keyword? k) k (keyword->obj-map-key k))]
+ (if (and (string? k)
+ (not (nil? (scan-array 1 k strkeys))))
+ (let [new-keys (aclone strkeys)
+ new-strobj (obj-clone strobj strkeys)]
+ (.splice new-keys (scan-array 1 k new-keys) 1)
+ (js-delete new-strobj k)
+ (ObjMap. meta new-keys new-strobj 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]
+ coll)
+
+ ITransientCollection
+ (-conj! [coll val]
+ (-conj coll val))
+ (-persistent! [coll]
+ coll)
+
+ ITransientAssociative
+ (-assoc! [coll key val]
+ (-assoc coll key val))
+
+ ITransientMap
+ (-dissoc! [coll key]
+ (-dissoc coll key))
+
+ IPrintWithWriter
+ (-pr-writer [coll writer opts]
+ (print-map coll pr-writer writer opts)))
+
+(es6-iterable ObjMap)
+
+(set! (. ObjMap -EMPTY) (ObjMap. nil (array) (js-obj) empty-unordered-hash))
+
+(set! (. ObjMap -fromObject) (fn [ks obj] (ObjMap. nil ks obj nil)))
+
+(defn obj-map
+ ":lite-mode simple key hash-map, not intended to be used directly."
+ [& keyvals]
+ (let [ks (array)
+ obj (js-obj)]
+ (loop [kvs (seq keyvals)]
+ (if kvs
+ (let [k (-> kvs first keyword->obj-map-key)]
+ (.push ks k)
+ (gobject/set obj k (second kvs))
+ (recur (nnext kvs)))
+ (.fromObject ObjMap ks obj)))))
+
+(set! (. ObjMap -createAsIfByAssoc)
+ (fn [init]
+ ;; check trailing element
+ (let [len (alength init)
+ has-trailing? (== 1 (bit-and len 1))
+ init (if has-trailing?
+ (pam-grow-seed-array init
+ (into {} (aget init (dec len))))
+ init)
+ len (alength init)]
+ (loop [i 0 ret {}]
+ (if (< i len)
+ (recur (+ i 2) (assoc ret (aget init i) (aget init (inc i))))
+ ret)))))
+
+(defn- scan-array-equiv [incr k array]
+ (let [len (alength array)]
+ (loop [i 0]
+ (when (< i len)
+ (if (= k (aget array i))
+ i
+ (recur (+ i incr)))))))
+
+; The keys field is an array of all keys of this map, in no particular
+; order. Each key is hashed and the result used as a property name of
+; hashobj. Each values in hashobj is actually a bucket in order to handle hash
+; collisions. A bucket is an array of alternating keys (not their hashes) and
+; vals.
+(deftype HashMapLite [meta count hashobj ^:mutable __hash]
+ Object
+ (toString [coll]
+ (pr-str* coll))
+ (keys [coll]
+ (let [arr (. (-seq coll) -arr)]
+ (es6-iterator (prim-seq (.map arr -key (-seq coll))))))
+ (entries [coll]
+ (es6-entries-iterator (-seq coll)))
+ (values [coll]
+ (let [arr (. (-seq coll) -arr)]
+ (es6-iterator (prim-seq (.map arr -val (-seq coll))))))
+ (has [coll k]
+ (contains? coll k))
+ (get [coll k not-found]
+ (-lookup coll k not-found))
+ (forEach [coll f]
+ (let [xs (-seq coll)]
+ (when-not (nil? xs)
+ (.forEach (.-arr xs)
+ #(f (-val %) (-key %))))))
+
+ IWithMeta
+ (-with-meta [coll meta] (HashMapLite. meta count hashobj __hash))
+
+ IMeta
+ (-meta [coll] meta)
+
+ ICloneable
+ (-clone [coll] (HashMapLite. meta count hashobj __hash))
+
+ ICollection
+ (-conj [coll entry]
+ (if (vector? entry)
+ (-assoc coll (-nth entry 0) (-nth entry 1))
+ (reduce -conj coll entry)))
+
+ IEmptyableCollection
+ (-empty [coll] (with-meta (. HashMapLite -EMPTY) meta))
+
+ IEquiv
+ (-equiv [coll other] (equiv-map coll other))
+
+ IHash
+ (-hash [coll] (caching-hash coll hash-unordered-coll __hash))
+
+ ISeqable
+ (-seq [coll]
+ (when (pos? count)
+ (let [hashes (.sort (js-keys hashobj))
+ cnt (alength hashes)
+ arr (array)]
+ (loop [i 0]
+ (if (< i cnt)
+ (let [bckt (unchecked-get hashobj (aget hashes i))
+ len (alength bckt)]
+ (loop [j 0]
+ (when (< j len)
+ (do
+ (.push arr (MapEntry. (aget bckt j) (aget bckt (inc j)) nil))
+ (recur (+ j 2)))))
+ (recur (inc i)))
+ (prim-seq arr))))))
+
+ ICounted
+ (-count [coll] count)
+
+ ILookup
+ (-lookup [coll k] (-lookup coll k nil))
+ (-lookup [coll k not-found]
+ (let [bucket (unchecked-get hashobj (hash k))
+ i (when bucket (scan-array-equiv 2 k bucket))]
+ (if (some? i)
+ (aget bucket (inc i))
+ not-found)))
+
+ IAssociative
+ (-assoc [coll k v]
+ (let [h (hash k)
+ bucket (unchecked-get hashobj h)]
+ (if (some? bucket)
+ (let [new-bucket (aclone bucket)
+ new-hashobj (gobject/clone hashobj)
+ i (scan-array-equiv 2 k new-bucket)]
+ (aset new-hashobj h new-bucket)
+ (if (some? i)
+ (if (identical? v (aget new-bucket (inc i)))
+ coll
+ (do
+ ; found key, replace
+ (aset new-bucket (inc i) v)
+ (HashMapLite. meta count new-hashobj nil)))
+ (do
+ ; did not find key, append
+ (.push new-bucket k v)
+ (HashMapLite. meta (inc count) new-hashobj nil))))
+ (let [new-hashobj (gobject/clone hashobj)]
+ ; did not find bucket
+ (unchecked-set new-hashobj h (array k v))
+ (HashMapLite. meta (inc count) new-hashobj nil)))))
+ (-contains-key? [coll k]
+ (let [bucket (unchecked-get hashobj (hash k))
+ i (when bucket (scan-array-equiv 2 k bucket))]
+ (if (some? i)
+ true
+ false)))
+
+ IMap
+ (-dissoc [coll k]
+ (let [h (hash k)
+ bucket (unchecked-get hashobj h)
+ i (when bucket (scan-array-equiv 2 k bucket))]
+ (if (some? i)
+ (let [new-hashobj (gobject/clone hashobj)]
+ (if (> 3 (alength bucket))
+ (js-delete new-hashobj h)
+ (let [new-bucket (aclone bucket)]
+ (.splice new-bucket i 2)
+ (unchecked-set new-hashobj h new-bucket)))
+ (HashMapLite. meta (dec count) new-hashobj nil))
+ ; key not found, return coll unchanged
+ coll)))
+
+ IFn
+ (-invoke [coll k]
+ (-lookup coll k))
+ (-invoke [coll k not-found]
+ (-lookup coll k not-found))
+
+ IEditableCollection
+ (-as-transient [coll]
+ coll)
+
+ ITransientCollection
+ (-conj! [coll val]
+ (-conj coll val))
+ (-persistent! [coll]
+ coll)
+
+ ITransientAssociative
+ (-assoc! [coll key val]
+ (-assoc coll key val))
+
+ ITransientMap
+ (-dissoc! [coll key]
+ (-dissoc coll key))
+
+ IIterable
+ (-iterator [coll]
+ (let [xs (-seq coll)]
+ (if (some? xs)
+ (-iterator xs)
+ (nil-iter))))
+
+ IKVReduce
+ (-kv-reduce [coll f init]
+ (let [hashes (.sort (js-keys hashobj))
+ ilen (alength hashes)]
+ (loop [i 0 init init]
+ (if (< i ilen)
+ (let [bckt (unchecked-get hashobj (aget hashes i))
+ jlen (alength bckt)
+ init (loop [j 0 init init]
+ (if (< j jlen)
+ (let [init (f init (aget bckt j) (aget bckt (inc j)))]
+ (if (reduced? init)
+ init
+ (recur (+ j 2) init)))
+ init))]
+ (if (reduced? init)
+ @init
+ (recur (inc i) init)))
+ init))))
+
+ IPrintWithWriter
+ (-pr-writer [coll writer opts]
+ (print-map coll pr-writer writer opts)))
+
+(es6-iterable HashMapLite)
+
+(set! (. HashMapLite -EMPTY) (HashMapLite. nil 0 (js-obj) empty-unordered-hash))
+
+(set! (. HashMapLite -fromArrays) (fn [ks vs]
+ (let [len (.-length ks)]
+ (loop [i 0, out (. HashMapLite -EMPTY)]
+ (if (< i len)
+ (recur (inc i) (assoc out (aget ks i) (aget vs i)))
+ out)))))
+
+(defn hash-map-lite
+ ":lite-mode version of hash-map, not intended to be used directly."
+ [& keyvals]
+ (loop [in (seq keyvals), out (. HashMapLite -EMPTY)]
+ (if in
+ (recur (nnext in) (-assoc out (first in) (second in)))
+ out)))
+
+(deftype SetLite [meta hash-map ^:mutable __hash]
+ Object
+ (toString [coll]
+ (pr-str* coll))
+ (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]
+ (let [xs (-seq hash-map)]
+ (when (some? xs)
+ (.forEach (.-arr xs)
+ #(f (-val %) (-key %))))))
+
+ IWithMeta
+ (-with-meta [coll new-meta]
+ (if (identical? new-meta meta)
+ coll
+ (SetLite. new-meta hash-map __hash)))
+
+ IMeta
+ (-meta [coll] meta)
+
+ ICloneable
+ (-clone [coll] (SetLite. meta hash-map __hash))
+
+ ICollection
+ (-conj [coll o]
+ (let [new-hash-map (assoc hash-map o o)]
+ (if (identical? new-hash-map hash-map)
+ coll
+ (SetLite. meta new-hash-map nil))))
+
+ IEmptyableCollection
+ (-empty [coll] (with-meta (. SetLite -EMPTY) meta))
+
+ IEquiv
+ (-equiv [coll other]
+ (and
+ (set? other)
+ (= (-count coll) (count other))
+ (every? #(contains? coll %)
+ other)))
+
+ IHash
+ (-hash [coll] (caching-hash coll hash-unordered-coll __hash))
+
+ ISeqable
+ (-seq [coll]
+ (let [xs (-seq hash-map)]
+ (when (some? xs)
+ (prim-seq (.map (.-arr xs) (fn [kv] (-key kv)))))))
+
+ ICounted
+ (-count [coll]
+ (let [xs (-seq coll)]
+ (if (some? xs)
+ (-count xs)
+ 0)))
+
+ ILookup
+ (-lookup [coll v]
+ (-lookup coll v nil))
+ (-lookup [coll v not-found]
+ (if (-contains-key? hash-map v)
+ (-lookup hash-map v)
+ not-found))
+
+ ISet
+ (-disjoin [coll v]
+ (let [new-hash-map (-dissoc hash-map v)]
+ (if (identical? new-hash-map hash-map)
+ coll
+ (SetLite. meta new-hash-map nil))))
+
+ IEditableCollection
+ (-as-transient [coll]
+ coll)
+
+ ITransientCollection
+ (-conj! [coll val]
+ (-conj coll val))
+ (-persistent! [coll]
+ coll)
+
+ ITransientSet
+ (-disjoin! [coll key]
+ (-disjoin coll key))
+
+ IFn
+ (-invoke [coll k]
+ (-lookup coll k))
+ (-invoke [coll k not-found]
+ (-lookup coll k not-found))
+
+ IIterable
+ (-iterator [coll]
+ (let [xs (-seq coll)]
+ (if (some? xs)
+ (-iterator xs)
+ (nil-iter))))
+
+ IPrintWithWriter
+ (-pr-writer [coll writer opts] (pr-sequential-writer writer pr-writer "#{" " " "}" opts coll)))
+
+(es6-iterable SetLite)
+
+(set! (. SetLite -EMPTY) (SetLite. nil (. HashMapLite -EMPTY) empty-unordered-hash))
+
+(defn set-lite
+ ":lite-mode version of set, not intended ot be used directly."
+ [coll]
+ (if (set? coll)
+ (-with-meta coll nil)
+ (let [in (seq coll)]
+ (if (nil? in)
+ #{}
+ (loop [in in out (. SetLite -EMPTY)]
+ (if-not (nil? in)
+ (recur (next in) (-conj out (first in)))
+ out))))))
diff --git a/src/main/cljs/cljs/core/specs/alpha.cljc b/src/main/cljs/cljs/core/specs/alpha.cljc
new file mode 100644
index 0000000000..f2475aeae5
--- /dev/null
+++ b/src/main/cljs/cljs/core/specs/alpha.cljc
@@ -0,0 +1,235 @@
+; 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.specs.alpha
+ (:require [clojure.spec.alpha :as s]
+ #?(:clj [cljs.core :as core]
+ :cljs [cljs.core$macros :as core])))
+
+;;;; destructure
+
+(s/def ::local-name (s/and simple-symbol? #(not= '& %)))
+
+(s/def ::binding-form
+ (s/or :local-symbol ::local-name
+ :seq-destructure ::seq-binding-form
+ :map-destructure ::map-binding-form))
+
+;; sequential destructuring
+
+(s/def ::seq-binding-form
+ (s/and vector?
+ (s/cat :forms (s/* ::binding-form)
+ :rest-forms (s/? (s/cat :ampersand #{'&} :form ::binding-form))
+ :as-form (s/? (s/cat :as #{:as} :as-sym ::local-name)))))
+
+;; map destructuring
+
+(s/def ::keys (s/coll-of ident? :kind vector?))
+(s/def ::syms (s/coll-of symbol? :kind vector?))
+(s/def ::strs (s/coll-of simple-symbol? :kind vector?))
+(s/def ::or (s/map-of simple-symbol? any?))
+(s/def ::as ::local-name)
+
+(s/def ::map-special-binding
+ (s/keys :opt-un [::as ::or ::keys ::syms ::strs]))
+
+(s/def ::map-binding (s/tuple ::binding-form any?))
+
+(s/def ::ns-keys
+ (s/tuple
+ (s/and qualified-keyword? #(-> % name #{"keys" "syms"}))
+ (s/coll-of simple-symbol? :kind vector?)))
+
+(s/def ::map-bindings
+ (s/every (s/or :map-binding ::map-binding
+ :qualified-keys-or-syms ::ns-keys
+ :special-binding (s/tuple #{:as :or :keys :syms :strs} any?)) :kind map?))
+
+(s/def ::map-binding-form (s/merge ::map-bindings ::map-special-binding))
+
+;; bindings
+
+(defn even-number-of-forms?
+ "Returns true if there are an even number of forms in a binding vector"
+ [forms]
+ (even? (count forms)))
+
+(s/def ::binding (s/cat :form ::binding-form :init-expr any?))
+(s/def ::bindings (s/and vector? even-number-of-forms? (s/* ::binding)))
+
+;; let, if-let, when-let
+
+(s/fdef core/let
+ :args (s/cat :bindings ::bindings
+ :body (s/* any?)))
+
+(s/fdef core/if-let
+ :args (s/cat :bindings (s/and vector? ::binding)
+ :then any?
+ :else (s/? any?)))
+
+(s/fdef core/when-let
+ :args (s/cat :bindings (s/and vector? ::binding)
+ :body (s/* any?)))
+
+;; defn, defn-, fn
+
+(s/def ::param-list
+ (s/and
+ vector?
+ (s/cat :params (s/* ::binding-form)
+ :var-params (s/? (s/cat :ampersand #{'&} :var-form ::binding-form)))))
+
+(s/def ::params+body
+ (s/cat :params ::param-list
+ :body (s/alt :prepost+body (s/cat :prepost map?
+ :body (s/+ any?))
+ :body (s/* any?))))
+
+(s/def ::defn-args
+ (s/cat :fn-name simple-symbol?
+ :docstring (s/? string?)
+ :meta (s/? map?)
+ :fn-tail (s/alt :arity-1 ::params+body
+ :arity-n (s/cat :bodies (s/+ (s/spec ::params+body))
+ :attr-map (s/? map?)))))
+
+(s/fdef core/defn
+ :args ::defn-args
+ :ret any?)
+
+(s/fdef core/defn-
+ :args ::defn-args
+ :ret any?)
+
+(s/fdef core/fn
+ :args (s/cat :fn-name (s/? simple-symbol?)
+ :fn-tail (s/alt :arity-1 ::params+body
+ :arity-n (s/+ (s/spec ::params+body))))
+ :ret any?)
+
+;;;; ns
+
+(s/def ::exclude (s/coll-of simple-symbol?))
+(s/def ::only (s/coll-of simple-symbol?))
+(s/def ::rename (s/map-of simple-symbol? simple-symbol?))
+(s/def ::filters (s/keys* :opt-un [::exclude ::only ::rename]))
+
+(s/def ::ns-refer-clojure
+ (s/spec (s/cat :clause #{:refer-clojure}
+ :refer-filters ::filters)))
+
+(s/def ::refer (s/coll-of simple-symbol?))
+(s/def ::refer-macros (s/coll-of simple-symbol?))
+(s/def ::include-macros #{true})
+
+(s/def ::lib (s/or :sym simple-symbol?
+ :str string?))
+
+(s/def ::libspec
+ (s/alt :lib ::lib
+ :lib+opts (s/spec (s/cat :lib ::lib
+ :options (s/keys* :opt-un [::as ::refer ::refer-macros ::include-macros])))))
+
+(s/def ::macros-libspec
+ (s/alt :lib simple-symbol?
+ :lib+opts (s/spec (s/cat :lib simple-symbol?
+ :options (s/keys* :opt-un [::as ::refer])))))
+
+(s/def ::ns-require
+ (s/spec (s/cat :clause #{:require}
+ :body (s/+ (s/alt :libspec ::libspec
+ :flag #{:reload :reload-all :verbose})))))
+
+(s/def ::ns-require-macros
+ (s/spec (s/cat :clause #{:require-macros}
+ :body (s/+ (s/alt :libspec ::macros-libspec
+ :flag #{:reload :reload-all :verbose})))))
+
+(s/def ::package-list
+ (s/spec
+ (s/cat :package simple-symbol?
+ :classes (s/+ simple-symbol?))))
+
+(s/def ::import-list
+ (s/* (s/alt :class simple-symbol?
+ :package-list ::package-list)))
+
+(s/def ::ns-import
+ (s/spec
+ (s/cat :clause #{:import}
+ :classes ::import-list)))
+
+;; same as ::libspec, but also supports the ::filters options in the libspec
+(s/def ::use-libspec
+ (s/alt :lib ::lib
+ :lib+opts (s/spec (s/cat :lib ::lib
+ :options (s/keys* :req-un [::only] :opt-un [::rename])))))
+
+(s/def ::ns-use
+ (s/spec (s/cat :clause #{:use}
+ :libs (s/+ (s/alt :libspec ::use-libspec
+ :flag #{:reload :reload-all :verbose})))))
+
+;; same as ::libspec-macros, but also supports the ::filters options in the libspec
+(s/def ::use-macros-libspec
+ (s/alt :lib simple-symbol?
+ :lib+opts (s/spec (s/cat :lib simple-symbol?
+ :options (s/keys* :req-un [::only] :opt-un [::rename])))))
+
+(s/def ::ns-use-macros
+ (s/spec (s/cat :clause #{:use-macros}
+ :libs (s/+ (s/alt :libspec ::use-macros-libspec
+ :flag #{:reload :reload-all :verbose})))))
+
+
+(s/def ::ns-clauses
+ (s/* (s/alt :refer-clojure ::ns-refer-clojure
+ :require ::ns-require
+ :require-macros ::ns-require-macros
+ :import ::ns-import
+ :use ::ns-use
+ :use-macros ::ns-use-macros)))
+
+(s/def ::ns-form
+ (s/cat :ns-name simple-symbol?
+ :docstring (s/? string?)
+ :attr-map (s/? map?)
+ :ns-clauses ::ns-clauses))
+
+(s/fdef core/ns-special-form
+ :args ::ns-form)
+
+(defn- quoted
+ "Returns a spec that accepts a (quote ...) form of the spec"
+ [spec]
+ (s/spec (s/cat :quote #{'quote} :spec spec)))
+
+(s/def ::quoted-import-list
+ (s/* (s/alt :class (quoted simple-symbol?)
+ :package-list (quoted ::package-list))))
+
+(s/fdef core/import
+ :args ::quoted-import-list)
+
+(s/fdef core/require
+ :args (s/+ (s/alt :libspec (quoted ::libspec)
+ :flag #{:reload :reload-all :verbose})))
+
+(s/fdef core/require-macros
+ :args (s/+ (s/alt :libspec (quoted ::macros-libspec)
+ :flag #{:reload :reload-all :verbose})))
+
+(s/fdef core/use
+ :args (s/+ (s/alt :libspec (quoted ::use-libspec)
+ :flag #{:reload :reload-all :verbose})))
+
+(s/fdef core/use-macros
+ :args (s/+ (s/alt :libspec (quoted ::use-macros-libspec)
+ :flag #{:reload :reload-all :verbose})))
diff --git a/src/main/cljs/cljs/core/specs/alpha.cljs b/src/main/cljs/cljs/core/specs/alpha.cljs
new file mode 100644
index 0000000000..eba64b09df
--- /dev/null
+++ b/src/main/cljs/cljs/core/specs/alpha.cljs
@@ -0,0 +1,10 @@
+; 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.specs.alpha
+ (:require-macros [cljs.core.specs.alpha]))
diff --git a/src/main/cljs/cljs/externs.js b/src/main/cljs/cljs/externs.js
new file mode 100644
index 0000000000..4d0e0f200b
--- /dev/null
+++ b/src/main/cljs/cljs/externs.js
@@ -0,0 +1,27 @@
+/**
+ * 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.
+ */
+
+Math.imul = function(a, b) {};
+
+Object.prototype.done;
+Object.prototype.value;
+Object.prototype.next = function() {};
+
+/**
+ * @constructor;
+ */
+function IEquiv() {};
+IEquiv.prototype.equiv = function() {};
+
+/**
+ * @constructor
+ */
+function Java() {};
+Java.prototype.type = function() {};
\ No newline at end of file
diff --git a/src/main/cljs/cljs/imul.js b/src/main/cljs/cljs/imul.js
new file mode 100644
index 0000000000..d28a33c35e
--- /dev/null
+++ b/src/main/cljs/cljs/imul.js
@@ -0,0 +1,11 @@
+if(typeof Math.imul == "undefined" || (Math.imul(0xffffffff,5) == 0)) {
+ Math.imul = function (a, b) {
+ var ah = (a >>> 16) & 0xffff;
+ var al = a & 0xffff;
+ var bh = (b >>> 16) & 0xffff;
+ var bl = b & 0xffff;
+ // the shift by 0 fixes the sign on the high part
+ // the final |0 converts the unsigned value into a signed value
+ return ((al * bl) + (((ah * bl + al * bh) << 16) >>> 0)|0);
+ }
+}
diff --git a/src/main/cljs/cljs/js.clj b/src/main/cljs/cljs/js.clj
new file mode 100644
index 0000000000..1c4a51a6bd
--- /dev/null
+++ b/src/main/cljs/cljs/js.clj
@@ -0,0 +1,24 @@
+; 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.js
+ (:require [cljs.env :as env]
+ [cljs.env.macros :as menv]
+ [cljs.analyzer :as ana]
+ [clojure.java.io :as io]))
+
+(defmacro with-state
+ [state & body]
+ `(menv/with-compiler-env ~state
+ ~@body))
+
+(defmacro dump-core []
+ (let [state @env/*compiler*]
+ (if-not (false? (get-in state [:options :dump-core]))
+ `(quote ~(get-in state [::ana/namespaces 'cljs.core]))
+ `(hash-map))))
diff --git a/src/main/cljs/cljs/js.cljs b/src/main/cljs/cljs/js.cljs
new file mode 100644
index 0000000000..bb8e7fbc42
--- /dev/null
+++ b/src/main/cljs/cljs/js.cljs
@@ -0,0 +1,1432 @@
+; 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.js
+ (:refer-clojure :exclude [require eval])
+ (:require-macros [cljs.js :refer [dump-core]]
+ [cljs.env.macros :as env])
+ (:require [clojure.string :as string]
+ [clojure.walk :as walk]
+ [cljs.env :as env]
+ [cljs.spec.alpha]
+ [cljs.analyzer :as ana]
+ [cljs.compiler :as comp]
+ [cljs.tools.reader :as r]
+ [cljs.tools.reader.reader-types :as rt]
+ [cljs.tagged-literals :as tags]
+ [goog.crypt.base64 :as base64]
+ [cljs.source-map :as sm])
+ (:import [goog.string StringBuffer]))
+
+(js/goog.require "cljs.core$macros")
+
+(defn- debug-prn
+ [& args]
+ (binding [*print-fn* *print-err-fn*]
+ (apply println args)))
+
+(defn ns->relpath
+ "Given a namespace as a symbol return the relative path sans extension"
+ [ns-sym]
+ (string/replace (ana/munge-path ns-sym) \. \/))
+
+(defn file->ns
+ [file]
+ (let [lib-name (subs (string/replace file "/" ".")
+ 0 (- (count file) 5))]
+ (symbol (demunge lib-name))))
+
+(defn- drop-macros-suffix
+ [ns-name]
+ (when ns-name
+ (if (string/ends-with? ns-name "$macros")
+ (subs ns-name 0 (- (count ns-name) 7))
+ ns-name)))
+
+(defn- elide-macros-suffix
+ [sym]
+ (symbol (drop-macros-suffix (namespace sym)) (name sym)))
+
+(defn- resolve-symbol
+ [sym]
+ (if (string/starts-with? (str sym) ".")
+ sym
+ (elide-macros-suffix (ana/resolve-symbol sym))))
+
+(defn- read [eof rdr]
+ (binding [*ns* (symbol (drop-macros-suffix (str *ns*)))]
+ (r/read {:eof eof :read-cond :allow :features #{:cljs}} rdr)))
+
+(defn- atom? [x]
+ (instance? Atom x))
+
+(defn- valid-name? [x]
+ (or (nil? x) (symbol? x) (string? x)))
+
+(defn- valid-opts? [x]
+ (or (nil? x) (map? x)))
+
+(defonce
+ ^{:doc "Each runtime environment provides a different way to load a library.
+ Whatever function *load-fn* is bound to will be passed two arguments - a
+ map and a callback function: The map will have the following keys:
+
+ :name - the name of the library (a symbol)
+ :macros - modifier signaling a macros namespace load
+ :path - munged relative library path (a string)
+
+ It is up to the implementor to correctly resolve the corresponding .cljs,
+ .cljc, or .js resource (the order must be respected). If :macros is true
+ resolution should only consider .clj or .cljc resources (the order must be
+ respected). Upon resolution the callback should be invoked with a map
+ containing the following keys:
+
+ :lang - the language, :clj or :js
+ :source - the source of the library (a string)
+ :file - optional, the file path, it will be added to AST's :file keyword
+ (but not in :meta)
+ :cache - optional, if a :clj namespace has been precompiled to :js, can
+ give an analysis cache for faster loads.
+ :source-map - optional, if a :clj namespace has been precompiled to :js, can
+ give a V3 source map JSON
+
+ If the resource could not be resolved, the callback should be invoked with
+ nil."
+ :dynamic true}
+ *load-fn*
+ (fn [m cb]
+ (throw (js/Error. "No *load-fn* set"))))
+
+(defonce
+ ^{:doc "Each runtime environment provides various ways to eval JavaScript
+ source. Whatever function *eval-fn* is bound to will be passed a map
+ containing the following keys:
+
+ :source - the source of the library (string)
+ :name - used to unique identify the script (symbol)
+ :cache - if the source was originally ClojureScript, will be given the
+ analysis cache.
+
+ The result of evaluation should be the return value."
+ :dynamic true}
+ *eval-fn*
+ (fn [m]
+ (throw (js/Error. "No *eval-fn* set"))))
+
+(defn js-eval
+ "A default JavaScript evaluation function."
+ [{:keys [source] :as resource}]
+ (js/eval source))
+
+(defn- wrap-error [ex]
+ {:error ex})
+
+(defn empty-state
+ "Construct an empty compiler state. Required to invoke analyze, compile,
+ eval and eval-str."
+ ([]
+ (doto (env/default-compiler-env)
+ (swap!
+ (fn [state]
+ (-> state
+ (assoc-in [::ana/namespaces 'cljs.core] (dump-core)))))))
+ ([init]
+ (doto (empty-state) (swap! init))))
+
+(defn load-analysis-cache! [state ns cache]
+ (swap! state assoc-in [::ana/namespaces ns] cache))
+
+(defn load-source-map! [state ns sm-json]
+ (let [sm (sm/decode (.parse js/JSON sm-json))]
+ (swap! state assoc-in [:source-maps ns] sm)))
+
+(defn- sm-data []
+ (atom
+ {:source-map (sorted-map)
+ :gen-col 0
+ :gen-line 0}))
+
+(defn- prefix [s pre]
+ (str pre s))
+
+(defn- append-source-map
+ [state name source sb sm-data {:keys [output-dir asset-path source-map-timestamp] :as opts}]
+ (let [t (.valueOf (js/Date.))
+ mn (if name
+ (munge (str name))
+ (str "cljs-" t))
+ smn (cond-> mn
+ name (string/replace "." "/"))
+ ts (.valueOf (js/Date.))
+ out (or output-dir asset-path)
+ src (cond-> (str smn ".cljs")
+ (true? source-map-timestamp) (str "?rel=" ts)
+ out (prefix (str out "/")))
+ file (cond-> (str smn ".js")
+ (true? source-map-timestamp) (str "?rel=" ts)
+ out (prefix (str out "/")))
+ json (sm/encode {src (:source-map sm-data)}
+ {:lines (+ (:gen-line sm-data) 3)
+ :file file :sources-content [source]})]
+ (when (:verbose opts) (debug-prn json))
+ (swap! state assoc-in
+ [:source-maps (symbol mn)] (sm/invert-reverse-map (:source-map sm-data)))
+ (.append sb
+ (str "\n//# sourceURL=" file
+ "\n//# sourceMappingURL=data:application/json;base64,"
+ (-> (js/encodeURIComponent json)
+ (string/replace #"%([0-9A-F]{2})" (fn [[_ match]]
+ (.fromCharCode js/String (str "0x" match))))
+ (base64/encodeString))))))
+
+(defn- alias-map
+ [compiler cljs-ns]
+ (->> (env/with-compiler-env compiler
+ (ana/get-aliases cljs-ns))
+ (remove (fn [[k v]] (symbol-identical? k v)))
+ (into {})))
+
+;; -----------------------------------------------------------------------------
+;; Analyze
+
+(declare ^{:arglists '([bound-vars source name opts cb])} eval-str*)
+
+(def *loaded* (atom #{}))
+
+(defn- run-async!
+ "Like cljs.core/run!, but for an async procedure, and with the
+ ability to break prior to processing the entire collection.
+
+ Chains successive calls to the supplied procedure for items in
+ the collection. The procedure should accept an item from the
+ collection and a callback of one argument. If the break? predicate,
+ when applied to the procedure callback value, yields a truthy
+ result, terminates early calling the supplied cb with the callback
+ value. Otherwise, when complete, calls cb with nil."
+ [proc coll break? cb]
+ (if (seq coll)
+ (proc (first coll)
+ (fn [res]
+ (if (break? res)
+ (cb res)
+ (run-async! proc (rest coll) break? cb))))
+ (cb nil)))
+
+(declare ^{:arglists '([name cb]
+ [name opts cb]
+ [bound-vars name opts cb]
+ [bound-vars name reload opts cb])} require)
+
+(defn- process-deps
+ [bound-vars names opts cb]
+ (run-async! (fn [name cb]
+ (require bound-vars name nil opts cb))
+ names
+ :error
+ cb))
+
+(defn- process-macros-deps
+ [bound-vars cache opts cb]
+ (process-deps bound-vars
+ (distinct (vals (:require-macros cache)))
+ (-> opts
+ (assoc :macros-ns true)
+ (dissoc :emit-constants :optimize-constants))
+ cb))
+
+(defn- process-libs-deps
+ [bound-vars cache opts cb]
+ (process-deps bound-vars
+ (distinct (concat (vals (:requires cache)) (vals (:imports cache))))
+ (dissoc opts :macros-ns)
+ cb))
+
+(defn- pre-file-side-effects
+ [st name file opts]
+ (when (:verbose opts)
+ (debug-prn "Pre-file side-effects" file))
+ ;; In case any constants are defined in the namespace, flush any analysis metadata
+ ;; so that the constants can be defined wihtout triggering re-defined errors.
+ (when (and (get-in @st [::ana/namespaces name :defs])
+ (not ('#{cljs.core cljs.core$macros} name)))
+ (swap! st update ::ana/namespaces dissoc name)))
+
+(defn- post-file-side-effects
+ [file opts]
+ (when (:verbose opts)
+ (debug-prn "Post-file side-effects" file))
+ ;; Note, we don't (set! *unchecked-arrays* false) here, as that would interpreted
+ ;; an intrinsic affecting the compilation of this file, emitting a no-op. We bypass this
+ ;; and emit our own runtime assignment code.
+ (js* "cljs.core._STAR_unchecked_arrays_STAR_ = false;"))
+
+(defn require
+ ([name cb]
+ (require name nil cb))
+ ([name opts cb]
+ (require nil name opts cb))
+ ([bound-vars name opts cb]
+ (require bound-vars name nil opts cb))
+ ([bound-vars name reload opts cb]
+ (let [bound-vars (merge
+ {:*compiler* (env/default-compiler-env)
+ :*data-readers* tags/*cljs-data-readers*
+ :*load-macros* (:load-macros opts true)
+ :*analyze-deps* (:analyze-deps opts true)
+ :*load-fn* (or (:load opts) *load-fn*)
+ :*eval-fn* (or (:eval opts) *eval-fn*)}
+ bound-vars)
+ aname (cond-> name (:macros-ns opts) ana/macro-ns-name)]
+ (when (= :reload reload)
+ (swap! *loaded* disj aname))
+ (when (= :reload-all reload)
+ (reset! *loaded* #{}))
+ (when (:verbose opts)
+ (debug-prn (str "Loading " name (when (:macros-ns opts) " macros") " namespace")))
+ (if-not (contains? @*loaded* aname)
+ (let [env (:*env* bound-vars)]
+ (try
+ ((:*load-fn* bound-vars)
+ {:name name
+ :macros (:macros-ns opts)
+ :path (ns->relpath name)}
+ (fn [resource]
+ (assert (or (map? resource) (nil? resource))
+ "*load-fn* may only return a map or nil")
+ (if resource
+ (let [{:keys [lang source cache source-map file]} resource]
+ (condp keyword-identical? lang
+ :clj (do
+ (pre-file-side-effects (:*compiler* bound-vars) aname file opts)
+ (eval-str* bound-vars source name (assoc opts :cljs-file file)
+ (fn [res]
+ (post-file-side-effects file opts)
+ (if (:error res)
+ (cb res)
+ (do
+ (swap! *loaded* conj aname)
+ (cb {:value true}))))))
+ :js (process-macros-deps bound-vars cache opts
+ (fn [res]
+ (if (:error res)
+ (cb res)
+ (process-libs-deps bound-vars cache opts
+ (fn [res]
+ (if (:error res)
+ (cb res)
+ (let [res (try
+ ((:*eval-fn* bound-vars) resource)
+ (when cache
+ (load-analysis-cache!
+ (:*compiler* bound-vars) aname cache)
+ (ana/register-specs cache))
+ (when source-map
+ (load-source-map!
+ (:*compiler* bound-vars) aname source-map))
+ (catch :default cause
+ (wrap-error
+ (ana/error env
+ (str "Could not require " name) cause))))]
+ (if (:error res)
+ (cb res)
+ (do
+ (swap! *loaded* conj aname)
+ (cb {:value true}))))))))))
+ (cb (wrap-error
+ (ana/error env
+ (str "Invalid :lang specified " lang ", only :clj or :js allowed"))))))
+ (cb (wrap-error
+ (ana/error env
+ (ana/error-message (if (:macros-ns opts)
+ :undeclared-macros-ns
+ :undeclared-ns)
+ {:ns-sym name :js-provide (cljs.core/name name)})))))))
+ (catch :default cause
+ (cb (wrap-error
+ (ana/error env
+ (str "Could not require " name) cause))))))
+ (cb {:value true})))))
+
+(defn- patch-alias-map
+ [compiler in from to]
+ (let [patch (fn [k add-if-present?]
+ (swap! compiler update-in [::ana/namespaces in k]
+ (fn [m]
+ (let [replaced (walk/postwalk-replace {from to} m)]
+ (if (and add-if-present?
+ (some #{to} (vals replaced)))
+ (assoc replaced from to)
+ replaced)))))
+ patch-renames (fn [k]
+ (swap! compiler update-in [::ana/namespaces in k]
+ (fn [m]
+ (when m
+ (reduce (fn [acc [renamed qualified-sym :as entry]]
+ (if (= (str from) (namespace qualified-sym))
+ (assoc acc renamed (symbol (str to) (name qualified-sym)))
+ (merge acc entry)))
+ {} m)))))]
+ (patch :requires true)
+ (patch :require-macros true)
+ (patch :uses false)
+ (patch :use-macros false)
+ (patch-renames :renames)
+ (patch-renames :rename-macros)))
+
+(defn- self-require? [deps opts]
+ (and (true? (:def-emits-var opts)) (some #{ana/*cljs-ns*} deps)))
+
+(defn- load-deps
+ ([bound-vars ana-env lib deps cb]
+ (load-deps bound-vars ana-env lib deps nil nil cb))
+ ([bound-vars ana-env lib deps reload opts cb]
+ (when (:verbose opts)
+ (debug-prn "Loading dependencies for" lib))
+ (binding [ana/*cljs-dep-set* (let [lib (if (self-require? deps opts)
+ 'cljs.user
+ lib)]
+ (vary-meta (conj (:*cljs-dep-set* bound-vars) lib)
+ update-in [:dep-path] conj lib))]
+ (let [bound-vars (assoc bound-vars :*cljs-dep-set* ana/*cljs-dep-set*)]
+ (if-not (every? #(not (contains? ana/*cljs-dep-set* %)) deps)
+ (cb (wrap-error
+ (ana/error ana-env
+ (str "Circular dependency detected "
+ (apply str
+ (interpose " -> "
+ (conj (-> ana/*cljs-dep-set* meta :dep-path)
+ (some ana/*cljs-dep-set* deps))))))))
+ (if (seq deps)
+ (let [dep (first deps)
+ opts' (-> opts
+ (dissoc :context)
+ (dissoc :def-emits-var)
+ (dissoc :ns))]
+ (require bound-vars dep reload opts'
+ (fn [res]
+ (when (:verbose opts)
+ (debug-prn "Loading result:" res))
+ (if-not (:error res)
+ (load-deps bound-vars ana-env lib (next deps) nil opts cb)
+ (if-let [cljs-dep (let [cljs-ns (ana/clj-ns->cljs-ns dep)]
+ (get {dep nil} cljs-ns cljs-ns))]
+ (require bound-vars cljs-dep opts'
+ (fn [res]
+ (if (:error res)
+ (cb res)
+ (do
+ (patch-alias-map (:*compiler* bound-vars) lib dep cljs-dep)
+ (load-deps bound-vars ana-env lib (next deps) nil opts
+ (fn [res]
+ (if (:error res)
+ (cb res)
+ (cb (update res :aliased-loads assoc dep cljs-dep)))))))))
+ (cb res))))))
+ (cb {:value nil})))))))
+
+(declare ^{:arglists '([bound-vars source name opts cb])} analyze-str*)
+
+(defn- analyze-deps
+ ([bound-vars ana-env lib deps cb]
+ (analyze-deps bound-vars ana-env lib deps nil cb))
+ ([bound-vars ana-env lib deps opts cb]
+ (binding [ana/*cljs-dep-set* (vary-meta (conj (:*cljs-dep-set* bound-vars) lib)
+ update-in [:dep-path] conj lib)]
+ (let [compiler @(:*compiler* bound-vars)
+ bound-vars (assoc bound-vars :*cljs-dep-set* ana/*cljs-dep-set*)]
+ (if-not (every? #(not (contains? ana/*cljs-dep-set* %)) deps)
+ (cb (wrap-error
+ (ana/error ana-env
+ (str "Circular dependency detected "
+ (apply str
+ (interpose " -> "
+ (conj (-> ana/*cljs-dep-set* meta :dep-path)
+ (some ana/*cljs-dep-set* deps))))))))
+ (if (seq deps)
+ (let [dep (first deps)]
+ (try
+ ((:*load-fn* bound-vars) {:name dep :path (ns->relpath dep)}
+ (fn [resource]
+ (assert (or (map? resource) (nil? resource))
+ "*load-fn* may only return a map or nil")
+ (if-not resource
+ (if-let [cljs-dep (let [cljs-ns (ana/clj-ns->cljs-ns dep)]
+ (get {dep nil} cljs-ns cljs-ns))]
+ (do
+ (patch-alias-map (:*compiler* bound-vars) lib dep cljs-dep)
+ (analyze-deps bound-vars ana-env lib (cons cljs-dep (next deps)) opts
+ (fn [res]
+ (if (:error res)
+ (cb res)
+ (cb (update res :aliased-loads assoc dep cljs-dep))))))
+ (cb (wrap-error
+ (ana/error ana-env
+ (ana/error-message :undeclared-ns
+ {:ns-sym dep :js-provide (name dep)})))))
+ (let [{:keys [name lang source file]} resource]
+ (condp keyword-identical? lang
+ :clj (do
+ (pre-file-side-effects (:*compiler* bound-vars) name file opts)
+ (analyze-str* bound-vars source name (assoc opts :cljs-file file)
+ (fn [res]
+ (post-file-side-effects file opts)
+ (if-not (:error res)
+ (analyze-deps bound-vars ana-env lib (next deps) opts cb)
+ (cb res)))))
+ :js (analyze-deps bound-vars ana-env lib (next deps) opts cb)
+ (wrap-error
+ (ana/error ana-env
+ (str "Invalid :lang specified " lang ", only :clj or :js allowed"))))))))
+ (catch :default cause
+ (cb (wrap-error
+ (ana/error ana-env
+ (str "Could not analyze dep " dep) cause))))))
+ (cb {:value nil})))))))
+
+(defn- load-macros [bound-vars k macros lib reload reloads opts cb]
+ (if (seq macros)
+ (let [nsym (first (vals macros))
+ k (or (reload k)
+ (get-in reloads [k nsym])
+ (and (= nsym name) (:*reload-macros* bound-vars) :reload)
+ nil)
+ opts' (-> opts
+ (assoc :macros-ns true)
+ (dissoc :context)
+ (dissoc :def-emits-var)
+ (dissoc :ns)
+ (dissoc :emit-constants :optimize-constants))]
+ (require bound-vars nsym k opts'
+ (fn [res]
+ (if-not (:error res)
+ (load-macros bound-vars k (next macros) lib reload reloads opts cb)
+ (if-let [cljs-dep (let [cljs-ns (ana/clj-ns->cljs-ns nsym)]
+ (get {nsym nil} cljs-ns cljs-ns))]
+ (require bound-vars cljs-dep k opts'
+ (fn [res]
+ (if (:error res)
+ (cb res)
+ (do
+ (patch-alias-map (:*compiler* bound-vars) lib nsym cljs-dep)
+ (load-macros bound-vars k (next macros) lib reload reloads opts
+ (fn [res]
+ (if (:error res)
+ (cb res)
+ (cb (update res :aliased-loads assoc nsym cljs-dep)))))))))
+ (cb res))))))
+ (cb {:value nil})))
+
+(defn- rewrite-ns-ast
+ ([ast smap]
+ (rewrite-ns-ast ast smap false))
+ ([ast smap macros?]
+ (let [[uk rk renk] (if macros?
+ [:use-macros :require-macros :rename-macros]
+ [:uses :requires :renames])
+ rewrite-renames (fn [m]
+ (when m
+ (reduce (fn [acc [renamed qualified-sym :as entry]]
+ (let [from (symbol (namespace qualified-sym))
+ to (get smap from)]
+ (if (some? to)
+ (assoc acc renamed (symbol (str to) (name qualified-sym)))
+ (merge acc entry))))
+ {} m)))
+ rewrite-deps (fn [deps]
+ (into []
+ (map (fn [dep]
+ (if-let [new-dep (get smap dep)]
+ new-dep
+ dep)))
+ deps))]
+ (-> ast
+ (update uk #(walk/postwalk-replace smap %))
+ (update rk #(merge smap (walk/postwalk-replace smap %)))
+ (update renk rewrite-renames)
+ (update :deps rewrite-deps)))))
+
+(defn- check-macro-autoload-inferring-missing
+ [{:keys [requires name] :as ast} cenv]
+ (let [namespaces (-> @cenv ::ana/namespaces)
+ missing-require-macros (into {}
+ (filter (fn [[_ full-ns]]
+ (let [{:keys [use-macros require-macros]} (get namespaces full-ns)]
+ (or (some #{full-ns} (vals use-macros))
+ (some #{full-ns} (vals require-macros))))))
+ requires)
+ ast' (update-in ast [:require-macros] merge missing-require-macros)]
+ (swap! cenv update-in [::ana/namespaces name :require-macros] merge missing-require-macros)
+ ast'))
+
+(defn- ns-side-effects
+ ([bound-vars ana-env ast opts cb]
+ (ns-side-effects false bound-vars ana-env ast opts cb))
+ ([load bound-vars ana-env {:keys [op] :as ast} opts cb]
+ (when (:verbose opts)
+ (debug-prn "Namespace side effects for" (:name ast)))
+ (if (#{:ns :ns*} op)
+ (letfn [(check-uses-and-load-macros [res rewritten-ast]
+ (let [env (:*compiler* bound-vars)
+ {:keys [uses use-macros reload reloads name]} rewritten-ast]
+ (if (:error res)
+ (cb res)
+ (if (:*load-macros* bound-vars)
+ (do
+ (when (:verbose opts) (debug-prn "Processing :use-macros for" name))
+ (load-macros bound-vars :use-macros use-macros name reload reloads opts
+ (fn [res]
+ (if (:error res)
+ (cb res)
+ (let [{:keys [require-macros] :as rewritten-ast} (rewrite-ns-ast rewritten-ast (:aliased-loads res) true)]
+ (when (:verbose opts) (debug-prn "Processing :require-macros for" (:name ast)))
+ (load-macros bound-vars :require-macros require-macros name reload reloads opts
+ (fn [res']
+ (if (:error res')
+ (cb res')
+ (let [{:keys [use-macros] :as rewritten-ast} (rewrite-ns-ast rewritten-ast (:aliased-loads res) true)
+ res' (try
+ (when (seq use-macros)
+ (when (:verbose opts) (debug-prn "Checking :use-macros for" (:name ast)))
+ (binding [ana/*analyze-deps* (:*analyze-deps* bound-vars)
+ env/*compiler* (:*compiler* bound-vars)]
+ (ana/check-use-macros use-macros env)))
+ {:value nil}
+ (catch :default cause
+ (wrap-error
+ (ana/error ana-env
+ (str "Could not parse ns form " (:name ast)) cause))))]
+ (if (:error res')
+ (cb res')
+ (try
+ (binding [ana/*analyze-deps* (:*analyze-deps* bound-vars)
+ env/*compiler* (:*compiler* bound-vars)]
+ (let [ast' (-> rewritten-ast
+ (ana/check-use-macros-inferring-missing env)
+ (ana/check-rename-macros-inferring-missing env)
+ (check-macro-autoload-inferring-missing env))]
+ (cb {:value ast'})))
+ (catch :default cause
+ (cb (wrap-error
+ (ana/error ana-env
+ (str "Could not parse ns form " (:name ast)) cause)))))))))))))))
+ (try
+ (when (:verbose opts) (debug-prn "Checking uses"))
+ (ana/check-uses
+ (when (and (:*analyze-deps* bound-vars) (seq uses))
+ (ana/missing-uses uses env))
+ env)
+ (cb {:value ast})
+ (catch :default cause
+ (cb (wrap-error
+ (ana/error ana-env
+ (str "Could not parse ns form " (:name ast)) cause)))))))))]
+ (cond
+ (and load (seq (:deps ast)))
+ (let [{:keys [reload name deps]} ast]
+ (load-deps bound-vars ana-env name deps (or (:require reload) (:use reload)) (dissoc opts :macros-ns)
+ #(check-uses-and-load-macros % (rewrite-ns-ast ast (:aliased-loads %)))))
+
+ (and (not load) (:*analyze-deps* bound-vars) (seq (:deps ast)))
+ (analyze-deps bound-vars ana-env (:name ast) (:deps ast) (dissoc opts :macros-ns)
+ #(check-uses-and-load-macros % (rewrite-ns-ast ast (:aliased-loads %))))
+
+ :else
+ (check-uses-and-load-macros {:value nil} ast)))
+ (cb {:value ast}))))
+
+(defn- node-side-effects
+ [bound-vars sb deps ns-name emit-nil-result?]
+ (doseq [dep deps]
+ (.append sb
+ (with-out-str
+ (comp/emitln (munge ns-name) "."
+ (ana/munge-node-lib dep)
+ " = require('" dep "');"))))
+ (when (and (seq deps) emit-nil-result?)
+ (.append sb "null;")))
+
+(defn- global-exports-side-effects
+ [bound-vars sb deps ns-name opts]
+ (let [{:keys [js-dependency-index]} @(:*compiler* bound-vars)]
+ (doseq [dep deps]
+ (let [{:keys [global-exports]} (get js-dependency-index (name dep))]
+ (.append sb
+ (with-out-str
+ (comp/emit-global-export ns-name global-exports dep opts)))))
+ (when (and (seq deps) (:def-emits-var opts))
+ (.append sb "null;"))))
+
+(defn- trampoline-safe
+ "Returns a new function that calls f but discards any return value,
+ returning nil instead, thus avoiding any inadvertent trampoline continuation
+ if a function happens to be returned."
+ [f]
+ (comp (constantly nil) f))
+
+(defn- analyze-str* [bound-vars source name opts cb]
+ (let [rdr (rt/indexing-push-back-reader source 1 name)
+ cb (trampoline-safe cb)
+ eof (js-obj)
+ aenv (ana/empty-env)
+ the-ns (or (:ns opts) 'cljs.user)
+ bound-vars (cond-> (merge bound-vars {:*cljs-ns* the-ns})
+ (:source-map opts) (assoc :*sm-data* (sm-data)))]
+ (trampoline
+ (fn analyze-loop [last-ast ns]
+ (binding [env/*compiler* (:*compiler* bound-vars)
+ ana/*cljs-ns* ns
+ ana/*checked-arrays* (:checked-arrays opts)
+ ana/*cljs-static-fns* (:static-fns opts)
+ ana/*fn-invoke-direct* (and (:static-fns opts) (:fn-invoke-direct opts))
+ *ns* (create-ns ns)
+ ana/*passes* (:*passes* bound-vars)
+ r/*alias-map* (alias-map @(:*compiler* bound-vars) ns)
+ r/*data-readers* (:*data-readers* bound-vars)
+ r/resolve-symbol resolve-symbol
+ comp/*source-map-data* (:*sm-data* bound-vars)
+ ana/*cljs-file* (:cljs-file opts)]
+ (let [res (try
+ {:value (read eof rdr)}
+ (catch :default cause
+ (wrap-error
+ (ana/error aenv
+ (str "Could not analyze " name) cause))))]
+ (if (:error res)
+ (cb res)
+ (let [form (:value res)]
+ (if-not (identical? eof form)
+ (let [aenv (cond-> (assoc aenv :ns (ana/get-namespace ana/*cljs-ns*))
+ (:context opts) (assoc :context (:context opts))
+ (:def-emits-var opts) (assoc :def-emits-var true))
+ res (try
+ {:value (ana/analyze aenv form nil opts)}
+ (catch :default cause
+ (wrap-error
+ (ana/error aenv
+ (str "Could not analyze " name) cause))))]
+ (if (:error res)
+ (cb res)
+ (let [ast (:value res)]
+ (if (#{:ns :ns*} (:op ast))
+ ((trampoline-safe ns-side-effects) bound-vars aenv ast opts
+ (fn [res]
+ (if (:error res)
+ (cb res)
+ (trampoline analyze-loop ast (:name ast)))))
+ #(analyze-loop ast ns)))))
+ (cb {:value last-ast}))))))) nil the-ns)))
+
+(defn analyze-str
+ "Analyze ClojureScript source. The compiler state will be populated with
+ the results of analyzes. The parameters:
+
+ state (atom)
+ the compiler state
+
+ source (string)
+ the ClojureScript source
+
+ name (symbol or string)
+ optional, the name of the source
+
+ opts (map)
+ compilation options.
+
+ :eval - eval function to invoke, see *eval-fn*
+ :load - library resolution function, see *load-fn*
+ :source-map - set to true to generate inline source map information
+ :def-emits-var - sets whether def (and derived) forms return either a Var
+ (if set to true) or the def init value (if false).
+ Defaults to false.
+ :checked-arrays - if :warn or :error, checks inferred types and values passed
+ to aget/aset. Logs for incorrect values if :warn, throws if
+ :error. Defaults to false.
+ :static-fns - employ static dispatch to specific function arities in
+ emitted JavaScript, as opposed to making use of the
+ `call` construct. Defaults to false.
+ :fn-invoke-direct - if `true`, does not generate `.call(null...)` calls for
+ unknown functions, but instead direct invokes via
+ `f(a0,a1...)`. Defaults to `false`.
+ :target - use `:nodejs` if targeting Node.js. Takes no other options
+ at the moment.
+ :ns - optional, the namespace in which to evaluate the source.
+ :verbose - optional, emit details from compiler activity. Defaults to
+ false.
+ :context - optional, sets the context for the source. Possible values
+ are `:expr`, `:statement` and `:return`. Defaults to
+ `:statement`.
+
+ cb (function)
+ callback, will be invoked with a map. If successful the map will contain
+ a key :value, the actual value is not meaningful. If unsuccessful the
+ map will contain a key :error with an ex-info instance describing the cause
+ of failure."
+ ([state source cb]
+ (analyze-str state source nil cb))
+ ([state source name cb]
+ (analyze-str state source name nil cb))
+ ([state source name opts cb]
+ {:pre [(atom? state) (string? source)
+ (valid-name? name) (valid-opts? opts) (fn? cb)]}
+ (analyze-str*
+ {:*compiler* state
+ :*data-readers* tags/*cljs-data-readers*
+ :*passes* (or (:passes opts) ana/*passes*)
+ :*analyze-deps* (:analyze-deps opts true)
+ :*cljs-dep-set* ana/*cljs-dep-set*
+ :*load-macros* (:load-macros opts true)
+ :*load-fn* (or (:load opts) *load-fn*)
+ :*eval-fn* (or (:eval opts) *eval-fn*)}
+ source name opts cb)))
+
+;; -----------------------------------------------------------------------------
+;; Eval
+
+(declare ^{:arglists '([])} clear-fns!)
+
+(defn- eval* [bound-vars form opts cb]
+ (let [the-ns (or (:ns opts) 'cljs.user)
+ bound-vars (cond-> (merge bound-vars {:*cljs-ns* the-ns})
+ (:source-map opts) (assoc :*sm-data* (sm-data)))]
+ (clear-fns!)
+ (binding [env/*compiler* (:*compiler* bound-vars)
+ *eval-fn* (:*eval-fn* bound-vars)
+ ana/*cljs-ns* (:*cljs-ns* bound-vars)
+ ana/*checked-arrays* (:checked-arrays opts)
+ ana/*cljs-static-fns* (:static-fns opts)
+ ana/*fn-invoke-direct* (and (:static-fns opts) (:fn-invoke-direct opts))
+ *ns* (create-ns (:*cljs-ns* bound-vars))
+ r/*alias-map* (alias-map @(:*compiler* bound-vars) (:*cljs-ns* bound-vars))
+ r/*data-readers* (:*data-readers* bound-vars)
+ r/resolve-symbol resolve-symbol
+ comp/*source-map-data* (:*sm-data* bound-vars)]
+ (let [aenv (ana/empty-env)
+ aenv (cond-> (assoc aenv :ns (ana/get-namespace ana/*cljs-ns*))
+ (:context opts) (assoc :context (:context opts))
+ (:def-emits-var opts) (assoc :def-emits-var true))
+ res (try
+ {:value (ana/analyze aenv form nil opts)}
+ (catch :default cause
+ (wrap-error
+ (ana/error aenv
+ (str "Could not eval " form) cause))))]
+ (if (:error res)
+ (cb res)
+ (let [ast (:value res)
+ [node-deps ast] (if (keyword-identical? (:target opts) :nodejs)
+ (let [{node-libs true libs-to-load false} (group-by ana/node-module-dep? (:deps ast))]
+ [node-libs (assoc ast :deps libs-to-load)])
+ [nil ast])]
+ (if (#{:ns :ns*} (:op ast))
+ (ns-side-effects true bound-vars aenv ast opts
+ (fn [res]
+ (if (:error res)
+ (cb res)
+ (let [ns-name (:name ast)
+ sb (StringBuffer.)]
+ (.append sb
+ (with-out-str (comp/emitln (str "goog.provide(\"" (comp/munge ns-name) "\");"))))
+ (when-not (nil? node-deps)
+ (node-side-effects bound-vars sb node-deps ns-name (:def-emits-var opts)))
+ (global-exports-side-effects bound-vars sb
+ (filter ana/dep-has-global-exports? (:deps ast))
+ ns-name opts)
+ (cb (try
+ {:ns ns-name :value ((:*eval-fn* bound-vars) {:source (.toString sb)})}
+ (catch :default cause
+ (wrap-error (ana/error aenv "ERROR" cause)))))))))
+ (let [src (with-out-str (comp/emit ast))]
+ (cb (try
+ {:value ((:*eval-fn* bound-vars) {:source src})}
+ (catch :default cause
+ (wrap-error (ana/error aenv "ERROR" cause)))))))))))))
+
+(defn eval
+ "Evaluate a single ClojureScript form. The parameters:
+
+ state (atom)
+ the compiler state
+
+ form (s-expr)
+ the ClojureScript source
+
+ opts (map)
+ compilation options.
+
+ :eval - eval function to invoke, see *eval-fn*
+ :load - library resolution function, see *load-fn*
+ :source-map - set to true to generate inline source map information
+ :def-emits-var - sets whether def (and derived) forms return either a Var
+ (if set to true) or the def init value (if false). Default
+ is false.
+ :checked-arrays - if :warn or :error, checks inferred types and values passed
+ to aget/aset. Logs for incorrect values if :warn, throws if
+ :error. Defaults to false.
+ :static-fns - employ static dispatch to specific function arities in
+ emitted JavaScript, as opposed to making use of the
+ `call` construct. Defaults to false.
+ :fn-invoke-direct - if `true`, does not generate `.call(null...)` calls for
+ unknown functions, but instead direct invokes via
+ `f(a0,a1...)`. Defaults to `false`.
+ :target - use `:nodejs` if targeting Node.js. Takes no other options
+ at the moment.
+ :ns - optional, the namespace in which to evaluate the source.
+ :verbose - optional, emit details from compiler activity. Defaults to
+ false.
+ :context - optional, sets the context for the source. Possible values
+ are `:expr`, `:statement` and `:return`. Defaults to
+ `:statement`.
+
+ cb (function)
+ callback, will be invoked with a map. If successful the map will contain
+ a key :value with the result of evalution. If unsuccessful the map will
+ contain a key :error with an ex-info instance describing the cause of
+ failure."
+ ([state form cb]
+ (eval state form nil cb))
+ ([state form opts cb]
+ (eval*
+ {:*compiler* state
+ :*data-readers* tags/*cljs-data-readers*
+ :*analyze-deps* (:analyze-deps opts true)
+ :*cljs-dep-set* ana/*cljs-dep-set*
+ :*load-macros* (:load-macros opts true)
+ :*load-fn* (or (:load opts) *load-fn*)
+ :*eval-fn* (or (:eval opts) *eval-fn*)}
+ form opts cb)))
+
+;; -----------------------------------------------------------------------------
+;; Compile
+
+(defn- compile-str* [bound-vars source name opts cb]
+ (let [rdr (rt/indexing-push-back-reader source 1 name)
+ cb (trampoline-safe cb)
+ eof (js-obj)
+ aenv (ana/empty-env)
+ sb (StringBuffer.)
+ the-ns (or (:ns opts) 'cljs.user)
+ bound-vars (cond-> (merge bound-vars {:*cljs-ns* the-ns})
+ (:source-map opts) (assoc :*sm-data* (sm-data)))]
+ (trampoline
+ (fn compile-loop [ns]
+ (binding [env/*compiler* (:*compiler* bound-vars)
+ *eval-fn* (:*eval-fn* bound-vars)
+ ana/*cljs-ns* ns
+ ana/*checked-arrays* (:checked-arrays opts)
+ ana/*cljs-static-fns* (:static-fns opts)
+ ana/*fn-invoke-direct* (and (:static-fns opts) (:fn-invoke-direct opts))
+ *ns* (create-ns ns)
+ r/*alias-map* (alias-map @(:*compiler* bound-vars) ns)
+ r/*data-readers* (:*data-readers* bound-vars)
+ r/resolve-symbol resolve-symbol
+ comp/*source-map-data* (:*sm-data* bound-vars)]
+ (let [res (try
+ {:value (read eof rdr)}
+ (catch :default cause
+ (wrap-error
+ (ana/error aenv
+ (str "Could not compile " name) cause))))]
+ (if (:error res)
+ (cb res)
+ (let [form (:value res)]
+ (if-not (identical? eof form)
+ (let [aenv (cond-> (assoc aenv :ns (ana/get-namespace ana/*cljs-ns*))
+ (:context opts) (assoc :context (:context opts))
+ (:def-emits-var opts) (assoc :def-emits-var true))
+ res (try
+ {:value (ana/analyze aenv form nil opts)}
+ (catch :default cause
+ (wrap-error
+ (ana/error aenv
+ (str "Could not compile " name) cause))))]
+ (if (:error res)
+ (cb res)
+ (let [ast (:value res)
+ [node-deps ast] (if (keyword-identical? (:target opts) :nodejs)
+ (let [{node-libs true libs-to-load false} (group-by ana/node-module-dep? (:deps ast))]
+ [node-libs (assoc ast :deps libs-to-load)])
+ [nil ast])]
+ (if (#{:ns :ns*} (:op ast))
+ ((trampoline-safe ns-side-effects) bound-vars aenv ast opts
+ (fn [res]
+ (if (:error res)
+ (cb res)
+ (let [ns-name (:name ast)]
+ (.append sb (with-out-str (comp/emit (:value res))))
+ (when-not (nil? node-deps)
+ (node-side-effects bound-vars sb node-deps ns-name (:def-emits-var opts)))
+ (trampoline compile-loop (:name ast))))))
+ (do
+ (.append sb (with-out-str (comp/emit ast)))
+ #(compile-loop ns))))))
+ (do
+ (when (:source-map opts)
+ (append-source-map env/*compiler*
+ name source sb @comp/*source-map-data* opts))
+ (cb {:value (.toString sb)})))))))) the-ns)))
+
+(defn compile-str
+ "Compile ClojureScript source into JavaScript. The parameters:
+
+ state (atom)
+ the compiler state
+
+ source (string)
+ the ClojureScript source
+
+ name (symbol or string)
+ optional, the name of the source - used as key in :source-maps
+
+ opts (map)
+ compilation options.
+
+ :eval - eval function to invoke, see *eval-fn*
+ :load - library resolution function, see *load-fn*
+ :source-map - set to true to generate inline source map information
+ :def-emits-var - sets whether def (and derived) forms return either a Var
+ (if set to true) or the def init value (if false). Default
+ is false.
+ :checked-arrays - if :warn or :error, checks inferred types and values passed
+ to aget/aset. Logs for incorrect values if :warn, throws if
+ :error. Defaults to false.
+ :static-fns - employ static dispatch to specific function arities in
+ emitted JavaScript, as opposed to making use of the
+ `call` construct. Defaults to false.
+ :fn-invoke-direct - if `true`, does not generate `.call(null...)` calls for
+ unknown functions, but instead direct invokes via
+ `f(a0,a1...)`. Defaults to `false`.
+ :target - use `:nodejs` if targeting Node.js. Takes no other options
+ at the moment.
+ :ns - optional, the namespace in which to evaluate the source.
+ :verbose - optional, emit details from compiler activity. Defaults to
+ false.
+ :context - optional, sets the context for the source. Possible values
+ are `:expr`, `:statement` and `:return`. Defaults to
+ `:statement`.
+
+ cb (function)
+ callback, will be invoked with a map. If successful the map will contain
+ a key :value with the compilation result (string). If unsuccessful the map
+ will contain a key :error with an ex-info instance describing the cause
+ of failure."
+ ([state source cb]
+ (compile-str state source nil cb))
+ ([state source name cb]
+ (compile-str state source name nil cb))
+ ([state source name opts cb]
+ {:pre [(atom? state) (string? source)
+ (valid-name? name) (valid-opts? opts) (fn? cb)]}
+ (compile-str*
+ {:*compiler* state
+ :*data-readers* tags/*cljs-data-readers*
+ :*cljs-dep-set* ana/*cljs-dep-set*
+ :*analyze-deps* (:analyze-deps opts true)
+ :*load-macros* (:load-macros opts true)
+ :*load-fn* (or (:load opts) *load-fn*)
+ :*eval-fn* (or (:eval opts) *eval-fn*)
+ :*sm-data* (when (:source-map opts) (sm-data))}
+ source name opts cb)))
+
+;; -----------------------------------------------------------------------------
+;; Evaluate String
+
+(defn- eval-str* [bound-vars source name opts cb]
+ (let [rdr (rt/indexing-push-back-reader source 1 name)
+ cb (trampoline-safe cb)
+ eof (js-obj)
+ aenv (ana/empty-env)
+ sb (StringBuffer.)
+ the-ns (or (:ns opts) 'cljs.user)
+ bound-vars (cond-> (merge bound-vars {:*cljs-ns* the-ns})
+ (:source-map opts) (assoc :*sm-data* (sm-data)))
+ aname (cond-> name (:macros-ns opts) ana/macro-ns-name)]
+ (when (:verbose opts) (debug-prn "Evaluating" name))
+ (clear-fns!)
+ (trampoline
+ (fn compile-loop [ns]
+ (binding [env/*compiler* (:*compiler* bound-vars)
+ *eval-fn* (:*eval-fn* bound-vars)
+ ana/*cljs-ns* ns
+ ana/*checked-arrays* (:checked-arrays opts)
+ ana/*cljs-static-fns* (:static-fns opts)
+ ana/*fn-invoke-direct* (and (:static-fns opts) (:fn-invoke-direct opts))
+ *ns* (create-ns ns)
+ r/*alias-map* (alias-map @(:*compiler* bound-vars) ns)
+ r/*data-readers* (:*data-readers* bound-vars)
+ r/resolve-symbol resolve-symbol
+ comp/*source-map-data* (:*sm-data* bound-vars)
+ ana/*cljs-file* (:cljs-file opts)]
+ (let [res (try
+ {:value (read eof rdr)}
+ (catch :default cause
+ (wrap-error
+ (ana/error aenv
+ (str "Could not eval " name) cause))))]
+ (if (:error res)
+ (cb res)
+ (let [form (:value res)]
+ (if-not (identical? eof form)
+ (let [aenv (cond-> (assoc aenv :ns (ana/get-namespace ns))
+ (:context opts) (assoc :context (:context opts))
+ (:def-emits-var opts) (assoc :def-emits-var true))
+ res (try
+ {:value (ana/analyze aenv form nil opts)}
+ (catch :default cause
+ (wrap-error
+ (ana/error aenv
+ (str "Could not eval " name) cause))))]
+ (if (:error res)
+ (cb res)
+ (let [ast (:value res)
+ ns' ana/*cljs-ns*
+ [node-deps ast] (if (keyword-identical? (:target opts) :nodejs)
+ (let [{node-libs true libs-to-load false} (group-by ana/node-module-dep? (:deps ast))]
+ [node-libs (assoc ast :deps libs-to-load)])
+ [nil ast])]
+ (if (#{:ns :ns*} (:op ast))
+ (do
+ (.append sb
+ (with-out-str (comp/emitln (str "goog.provide(\"" (comp/munge (:name ast)) "\");"))))
+ ((trampoline-safe ns-side-effects) true bound-vars aenv ast opts
+ (fn [res]
+ (if (:error res)
+ (cb res)
+ (let [ns-name (:name ast)]
+ (when-not (nil? node-deps)
+ (node-side-effects bound-vars sb node-deps ns-name (:def-emits-var opts)))
+ (global-exports-side-effects bound-vars sb
+ (filter ana/dep-has-global-exports? (:deps ast))
+ ns-name opts)
+ (trampoline compile-loop ns'))))))
+ (do
+ (env/with-compiler-env (assoc @(:*compiler* bound-vars) :options opts)
+ (.append sb (with-out-str (comp/emit ast))))
+ #(compile-loop ns'))))))
+ (do
+ (when (:source-map opts)
+ (append-source-map env/*compiler*
+ aname source sb @comp/*source-map-data* opts))
+ (when (symbol? aname)
+ (ana/dump-specs aname))
+ (let [js-source (.toString sb)
+ evalm {:lang :clj
+ :name name
+ :path (ns->relpath name)
+ :source js-source
+ :cache (get-in @env/*compiler* [::ana/namespaces aname])}
+ complete (fn [res]
+ (if (:error res)
+ (cb res)
+ (do
+ (when (:verbose opts)
+ (debug-prn js-source))
+ (let [res (try
+ {:ns ns :value (*eval-fn* evalm)}
+ (catch :default cause
+ (wrap-error (ana/error aenv "ERROR" cause))))]
+ (cb res)))))]
+ (if-let [f (:cache-source opts)]
+ ((trampoline-safe f) evalm complete)
+ (complete {:value nil}))))))))))
+ (:*cljs-ns* bound-vars))))
+
+(defn eval-str
+ "Evalute ClojureScript source given as a string. The parameters:
+
+ state (atom)
+ the compiler state
+
+ source (string)
+ the ClojureScript source
+
+ name (symbol or string)
+ optional, the name of the source - used as key in :source-maps
+
+ opts (map)
+ compilation options.
+
+ :eval - eval function to invoke, see *eval-fn*
+ :load - library resolution function, see *load-fn*
+ :source-map - set to true to generate inline source map information
+ :cache-source - optional, a function to run side-effects with the
+ compilation result prior to actual evalution. This function
+ takes two arguments, the first is the eval map, the source
+ will be under :source. The second argument is a callback of
+ one argument. If an error occurs an :error key should be
+ supplied.
+ :def-emits-var - sets whether def (and derived) forms return either a Var
+ (if set to true) or the def init value (if false). Default
+ is false.
+ :checked-arrays - if :warn or :error, checks inferred types and values passed
+ to aget/aset. Logs for incorrect values if :warn, throws if
+ :error. Defaults to false.
+ :static-fns - employ static dispatch to specific function arities in
+ emitted JavaScript, as opposed to making use of the
+ `call` construct. Defaults to false.
+ :fn-invoke-direct - if `true`, does not generate `.call(null...)` calls for
+ unknown functions, but instead direct invokes via
+ `f(a0,a1...)`. Defaults to `false`.
+ :target - use `:nodejs` if targeting Node.js. Takes no other options
+ at the moment.
+ :ns - optional, the namespace in which to evaluate the source.
+ :verbose - optional, emit details from compiler activity. Defaults to
+ false.
+ :context - optional, sets the context for the source. Possible values
+ are `:expr`, `:statement` and `:return`. Defaults to
+ `:statement`.
+
+ cb (function)
+ callback, will be invoked with a map. If succesful the map will contain
+ a :value key with the result of evaluation and :ns the current namespace.
+ If unsuccessful will contain a :error key with an ex-info instance describing
+ the cause of failure."
+ ([state source cb]
+ (eval-str state source nil cb))
+ ([state source name cb]
+ (eval-str state source name nil cb))
+ ([state source name opts cb]
+ {:pre [(atom? state) (string? source)
+ (valid-name? name) (valid-opts? opts) (fn? cb)]}
+ (eval-str*
+ {:*compiler* state
+ :*data-readers* tags/*cljs-data-readers*
+ :*analyze-deps* (:analyze-deps opts true)
+ :*cljs-dep-set* ana/*cljs-dep-set*
+ :*load-macros* (:load-macros opts true)
+ :*load-fn* (or (:load opts) *load-fn*)
+ :*eval-fn* (or (:eval opts) *eval-fn*)}
+ source name opts cb)))
+
+;;; Support for cljs.core/eval
+
+;; The following volatiles and fns set up a scheme to
+;; emit function values into JavaScript as numeric
+;; references that are looked up. Needed to implement eval.
+
+(defonce ^:private fn-index (volatile! 0))
+(defonce ^:private fn-refs (volatile! {}))
+
+(defn- clear-fns!
+ "Clears saved functions."
+ []
+ (vreset! fn-refs {}))
+
+(defn- put-fn
+ "Saves a function, returning a numeric representation."
+ [f]
+ (let [n (vswap! fn-index inc)]
+ (vswap! fn-refs assoc n f)
+ n))
+
+(defn- get-fn
+ "Gets a function, given its numeric representation."
+ [n]
+ (get @fn-refs n))
+
+(defn- emit-fn [f]
+ (print "cljs.js.get_fn(" (put-fn f) ")"))
+
+(defmethod comp/emit-constant* js/Function
+ [f]
+ (emit-fn f))
+
+(defmethod comp/emit-constant* cljs.core/Var
+ [f]
+ (emit-fn f))
+
+(defn- eval-impl
+ ([form]
+ (eval-impl form (.-name *ns*)))
+ ([form ns]
+ (let [result (atom nil)]
+ (let [st env/*compiler*]
+ (eval st form
+ {:ns ns
+ :context :expr
+ :def-emits-var true}
+ (fn [{:keys [value error]}]
+ (if error
+ (throw error)
+ (reset! result value)))))
+ @result)))
+
+(set! *eval* eval-impl)
+
+(comment
+ (require '[cljs.js :as cljs]
+ '[cljs.analyzer :as ana])
+
+ (def vm (js/require "vm"))
+ (def fs (js/require "fs"))
+ (def st (cljs/empty-state))
+
+ (set! *target* "nodejs")
+
+ (defn node-eval [{:keys [name source]}]
+ (.runInThisContext vm source (str (munge name) ".js")))
+
+ (def libs
+ {'bootstrap-test.core :cljs
+ 'bootstrap-test.macros :clj
+ 'bootstrap-test.helper :clj})
+
+ (defn node-load [{:keys [name macros]} cb]
+ (if (contains? libs name)
+ (let [path (str "src/test/cljs/" (cljs/ns->relpath name)
+ "." (cljs.core/name (get libs name)))]
+ (.readFile fs path "utf-8"
+ (fn [err src]
+ (cb (if-not err
+ {:lang :clj :source src}
+ (.error js/console err))))))
+ (cb nil)))
+
+ (defn elide-env [env ast opts]
+ (dissoc ast :env))
+
+ (cljs/analyze-str st "(+ 1 1)" nil
+ {:passes [ana/infer-type elide-env]
+ :eval node-eval}
+ (fn [{:keys [value]}]
+ (println value)))
+
+ (cljs/eval st '(defn foo [a b] (+ a b))
+ {:eval node-eval}
+ (fn [res]
+ (println res)))
+
+ (cljs/compile-str st "(defprotocol IFoo (foo [this]))"
+ (fn [{:keys [value]}]
+ (println "Source:")
+ (println value)))
+
+ (cljs/eval-str st
+ "(defn foo [a b] (+ a b))
+ (defn bar [c d] (+ c d))"
+ nil
+ {:eval node-eval}
+ (fn [res]
+ (println res)))
+
+ (cljs/eval-str st "1"
+ nil
+ {:eval node-eval
+ :context :expr}
+ (fn [res]
+ (println res)))
+
+ (cljs/eval-str st "(def x 1)"
+ nil
+ {:eval node-eval
+ :context :expr
+ :def-emits-var true}
+ (fn [res]
+ (println res)))
+
+ (cljs/eval st '(ns foo.bar)
+ {:eval node-eval}
+ (fn [res]
+ (println res)))
+
+ (cljs/eval st '(def x 1)
+ {:eval node-eval
+ :context :expr
+ :def-emits-var true
+ :ns 'foo.bar}
+ (fn [res]
+ (println res)))
+
+ (cljs/compile-str st "(defn foo\n[a b]\n(+ a b))" 'cljs.foo
+ {:verbose true :source-map true}
+ (fn [js-source]
+ (println "Source:")
+ (println js-source)))
+
+ (cljs/eval-str st
+ "(ns foo.bar (:require [bootstrap-test.core]))\n(bootstrap-test.core/foo 3 4)"
+ 'foo.bar
+ {:verbose true
+ :source-map true
+ :eval node-eval
+ :load node-load}
+ (fn [ret]
+ (println ret)))
+
+ (cljs/eval-str st
+ "(ns foo.bar (:require-macros [bootstrap-test.macros :refer [foo]]))\n(foo 4 4)"
+ 'foo.bar
+ {:verbose true
+ :source-map true
+ :eval node-eval
+ :load node-load}
+ (fn [{:keys [error] :as res}]
+ (if error
+ (do
+ (println "Error:" error)
+ (println (.. error -cause -stack)))
+ (println "Result:" res))))
+
+ (cljs/compile-str st
+ "(ns foo.bar (:require-macros [bootstrap-test.macros :refer [foo]]))\n(foo 4 4)"
+ 'foo.bar
+ {:verbose true
+ :source-map true
+ :eval node-eval
+ :load node-load}
+ (fn [{:keys [error] :as res}]
+ (if error
+ (do
+ (println "Error:" error)
+ (println (.. error -cause -stack)))
+ (println "Result:" res))))
+
+ (cljs/eval-str st
+ "(ns foo.bar)\n(first [1 2 3])"
+ 'foo.bar
+ {:verbose true
+ :source-map true
+ :eval node-eval
+ :load node-load}
+ (fn [{:keys [error] :as res}]
+ (if error
+ (do
+ (println error)
+ (println (.. error -cause -stack)))
+ (println res))))
+
+ (cljs/eval-str st
+ "(ns foo.bar)\n(map inc [1 2 3])"
+ 'foo.bar
+ {:verbose true
+ :source-map true
+ :eval node-eval
+ :load node-load}
+ (fn [{:keys [error] :as res}]
+ (if error
+ (do
+ (println error)
+ (println (.. error -cause -stack)))
+ (println res))))
+
+ ;; *NOT* source mapped under Node.js
+ ;; source-map-support does not yet work, users will need to map
+ ;; themselves
+ (cljs/eval-str st
+ "(ns foo.bar)\n(ffirst [1 2 3])"
+ 'foo.bar
+ {:verbose true
+ :source-map true
+ :eval node-eval
+ :load node-load}
+ (fn [{:keys [error] :as res}]
+ (if error
+ (do
+ (println error)
+ (println (.. error -cause -stack)))
+ (println res))))
+ )
diff --git a/src/main/cljs/cljs/loader.cljs b/src/main/cljs/cljs/loader.cljs
new file mode 100644
index 0000000000..473d0e5b86
--- /dev/null
+++ b/src/main/cljs/cljs/loader.cljs
@@ -0,0 +1,107 @@
+; 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.loader
+ (:require [goog.object :as gobj]
+ [goog.html.legacyconversions :as legacy])
+ (:import [goog.module ModuleManager]
+ [goog.module ModuleLoader]))
+
+(def module-infos MODULE_INFOS) ;; set by compiler
+(def module-uris
+ (if (exists? js/COMPILED_MODULE_URIS)
+ js/COMPILED_MODULE_URIS
+ MODULE_URIS)) ;; set by compiler
+
+(defn deps-for [x graph]
+ (let [depends-on (get graph x)]
+ (-> (mapcat #(deps-for % graph) depends-on)
+ (concat depends-on) distinct vec)))
+
+(defn munge-kw [x]
+ (cond-> x
+ (keyword? x) (-> name munge)))
+
+(defn to-tr-url [x]
+ (cond-> x
+ (not (keyword? x)) legacy/trustedResourceUrlFromString))
+
+(defn to-js [m]
+ (reduce-kv
+ (fn [ret k xs]
+ (let [arr (into-array (map (comp munge-kw to-tr-url) xs))]
+ (doto ret (gobj/set (-> k name munge) arr))))
+ #js {} m))
+
+(defn create-module-manager []
+ (let [mm (ModuleManager.)
+ ml (ModuleLoader.)]
+ (.setLoader mm ml)
+ mm))
+
+(defonce ^:dynamic *module-manager* (create-module-manager))
+
+(.setAllModuleInfo *module-manager* (to-js module-infos))
+(.setModuleTrustedUris *module-manager*
+ (cond-> module-uris (map? module-uris) to-js))
+
+(defn loaded?
+ "Return true if modules is loaded. module-name should be a keyword matching
+ a :modules module definition."
+ [module-name]
+ (assert (contains? module-infos module-name)
+ (str "Module " module-name " does not exist"))
+ (let [mname (-> module-name name munge)
+ module (.getModuleInfo *module-manager* mname)]
+ (when (some? module)
+ (.isLoaded module))))
+
+(defn load
+ "Load a module. module-name should be a keyword matching a :modules module
+ definition."
+ ([module-name]
+ (load module-name nil))
+ ([module-name cb]
+ (assert (contains? module-infos module-name)
+ (str "Module " module-name " does not exist"))
+ (let [mname (-> module-name name munge)]
+ (.beforeLoadModuleCode *module-manager* mname)
+ (if-not (nil? cb)
+ (.execOnLoad *module-manager* mname cb)
+ (.load *module-manager* mname)))))
+
+(defn set-loaded!
+ "Set a module as being loaded. module-name should be a keyword matching a
+ :modules module definition. Will mark all parent modules as also being
+ loaded."
+ [module-name]
+ (assert (contains? module-infos module-name)
+ (str "Module " module-name " does not exist"))
+ (let [deps (deps-for module-name module-infos)]
+ (doseq [dep deps]
+ (let [dep' (munge-kw dep)]
+ (when (.isModuleLoading *module-manager* dep')
+ (.setLoaded *module-manager* dep'))
+ (.setLoaded (.getModuleInfo *module-manager* dep'))))
+ (let [module-name' (munge-kw module-name)]
+ (when (.isModuleLoading *module-manager* module-name')
+ (.setLoaded *module-manager* module-name'))
+ (.setLoaded (.getModuleInfo *module-manager* module-name')))))
+
+(defn prefetch
+ "Prefetch a module. module-name should be a keyword matching a :modules
+ module definition. Will download the module but not evaluate it. To
+ complete module load, one must also call cljs.loader/load after prefetching
+ the module. Does nothing if the module is loading or has been loaded."
+ [module-name]
+ (assert (contains? module-infos module-name)
+ (str "Module " module-name " does not exist"))
+ (when-not (loaded? module-name)
+ (let [mname (-> module-name name munge)]
+ (when-not (.isModuleLoading *module-manager* mname)
+ (.prefetchModule *module-manager* mname)))))
diff --git a/src/main/cljs/cljs/main.clj b/src/main/cljs/cljs/main.clj
new file mode 100644
index 0000000000..eec3fb5ac7
--- /dev/null
+++ b/src/main/cljs/cljs/main.clj
@@ -0,0 +1,67 @@
+;; 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.main
+ (:require [cljs.repl.browser :as browser]
+ [cljs.cli :as cli]
+ [clojure.string :as string])
+ (:gen-class))
+
+(defn single-segment? [x]
+ (== 1 (count (string/split x #"\."))))
+
+(defn- get-js-opt [args]
+ (if (= 2 (count args))
+ (let [ns-frag (nth args 1)
+ repl-ns (symbol
+ (cond->> ns-frag
+ (single-segment? ns-frag)
+ (str "cljs.repl.")))]
+ (try
+ (require repl-ns)
+ (if-let [repl-env (ns-resolve repl-ns 'repl-env)]
+ repl-env
+ (throw
+ (ex-info (str "REPL namespace " repl-ns " does not define repl-env var")
+ {:repl-ns repl-ns})))
+ (catch Throwable t
+ (throw
+ (ex-info (str "Failed to load REPL namespace " repl-ns)
+ {:repl-ns repl-ns} t)))))
+ browser/repl-env))
+
+(defn- normalize* [args]
+ (if (not (cli/dispatch? cli/default-commands :main (first args)))
+ (let [pred (complement #{"-re" "--repl-env"})
+ [pre post] ((juxt #(take-while pred %)
+ #(drop-while pred %))
+ args)]
+ (if (= pre args)
+ [nil pre]
+ (let [[js-opt post'] (normalize* (nnext post))]
+ (if js-opt
+ [js-opt (concat pre post')]
+ [[(first post) (fnext post)] (concat pre post')]))))
+ [nil args]))
+
+(defn normalize [args]
+ (let [[js-opt args] (normalize* args)]
+ (concat js-opt args)))
+
+(defn -main [& args]
+ (let [args (normalize (cli/normalize cli/default-commands args))
+ pred (complement #{"-re" "--repl-env"})
+ [pre post] ((juxt #(take-while pred %)
+ #(drop-while pred %))
+ args)
+ [js-args args] ((juxt #(take 2 %) #(drop 2 %)) post)
+ repl-opt (get-js-opt js-args)]
+ (try
+ (apply cli/main repl-opt (concat pre args))
+ (finally
+ (shutdown-agents)))))
diff --git a/src/main/cljs/cljs/math.cljs b/src/main/cljs/cljs/math.cljs
new file mode 100644
index 0000000000..1d6c4ff204
--- /dev/null
+++ b/src/main/cljs/cljs/math.cljs
@@ -0,0 +1,869 @@
+(ns ^{:doc "ClojureScript wrapper functions for math operations"
+ :author "Paula Gearon" }
+ cljs.math)
+
+(def
+ ^{:doc "Constant for Euler's number e, the base for natural logarithms.
+ See: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/E"
+ :added "1.11.10"
+ :tag number
+ :const true} E Math/E)
+
+(def
+ ^{:doc "Constant for pi, the ratio of the circumference of a circle to its diameter.
+ See: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/PI"
+ :added "1.11.10"
+ :tag number
+ :const true} PI Math/PI)
+
+(def
+ ^{:doc "Constant used to convert an angular value in degrees to the equivalent in radians"
+ :private true
+ :added "1.11.10"
+ :const true} DEGREES-TO-RADIANS 0.017453292519943295)
+
+(def
+ ^{:doc "Constant used to convert an angular value in radians to the equivalent in degrees"
+ :private true
+ :added "1.11.10"
+ :const true} RADIANS-TO-DEGREES 57.29577951308232)
+
+(def ^{:private true :const true} TWO-TO-THE-52 0x10000000000000)
+
+(def ^{:private true :const true} SIGNIFICAND-WIDTH32 21)
+
+(def ^{:private true :const true} EXP-BIAS 1023)
+
+(def ^{:private true :const true} EXP-BITMASK32 0x7FF00000)
+
+(def ^{:private true :const true} EXP-MAX EXP-BIAS)
+
+(def ^{:private true :const true} EXP-MIN -1022)
+
+;; js/Number.MIN_VALUE has a bit representation of 0x0000000000000001
+
+;; js/Number.MAX_VALUE has a bit representation of 0x7FEFFFFFFFFFFFFF
+
+(defn- get-little-endian
+ "Tests the platform for endianness. Returns true when little-endian, false otherwise."
+ []
+ (let [a (js/ArrayBuffer. 4)
+ i (js/Uint32Array. a)
+ b (js/Uint8Array. a)]
+ (aset i 0 0x33221100)
+ (zero? (aget b 0))))
+
+(defonce ^:private little-endian? (get-little-endian))
+
+;; the HI and LO labels are terse to reflect the C macros they represent
+(def ^{:private true :doc "offset of hi integers in 64-bit values"} HI (if little-endian? 1 0))
+
+(def ^{:private true :doc "offset of hi integers in 64-bit values"} LO (- 1 HI))
+
+(def ^{:private true :const true} INT32-MASK 0xFFFFFFFF)
+
+(def ^{:private true :const true} INT32-NON-SIGN-BIT 0x80000000)
+
+(def ^{:private true :const true} INT32-NON-SIGN-BITS 0x7FFFFFFF)
+
+(defn u<
+ {:doc "unsigned less-than comparator for 32-bit values"
+ :private true}
+ [a b]
+ ;; compare the top nybble
+ (let [ab (unsigned-bit-shift-right a 28)
+ bb (unsigned-bit-shift-right b 28)]
+ (or (< ab bb) ;; if the top nybble of a is less then the whole value is less
+ (and (== ab bb) ;; if the top nybble is equal then compare the remaining bits of both
+ (< (bit-and a 0x0fffffff) (bit-and b 0x0fffffff))))))
+
+(defn ^number sin
+ {:doc "Returns the sine of an angle.
+ If a is ##NaN, ##-Inf, ##Inf => ##NaN
+ If a is zero => zero with the same sign as a
+ See: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/sin"
+ :added "1.11.10"}
+ [a] (Math/sin a))
+
+(defn ^number cos
+ {:doc "Returns the cosine of an angle.
+ If a is ##NaN, ##-Inf, ##Inf => ##NaN
+ See: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/cos"
+ :added "1.11.10"}
+ [a] (Math/cos a))
+
+(defn ^number tan
+ {:doc "Returns the tangent of an angle.
+ If a is ##NaN, ##-Inf, ##Inf => ##NaN
+ If a is zero => zero with the same sign as a
+ See: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/tan"
+ :added "1.11.10"}
+ [a] (Math/tan a))
+
+(defn ^number asin
+ {:doc "Returns the arc sine of an angle, in the range -pi/2 to pi/2.
+ If a is ##NaN or |a|>1 => ##NaN
+ If a is zero => zero with the same sign as a
+ See: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/asin"
+ :added "1.11.10"}
+ [a] (Math/asin a))
+
+(defn ^number acos
+ {:doc "Returns the arc cosine of a, in the range 0.0 to pi.
+ If a is ##NaN or |a|>1 => ##NaN
+ See: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/acos"
+ :added "1.11.10"}
+ [a] (Math/acos a))
+
+(defn ^number atan
+ {:doc "Returns the arc tangent of a, in the range of -pi/2 to pi/2.
+ If a is ##NaN => ##NaN
+ If a is zero => zero with the same sign as a
+ See: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/atan"
+ :added "1.11.10"}
+ [a] (Math/atan a))
+
+(defn ^number to-radians
+ {:doc "Converts an angle in degrees to an approximate equivalent angle in radians.
+ See: https://docs.oracle.com/javase/8/docs/api/java/lang/Math.html#toRadians-double-"
+ :added "1.11.10"}
+ [deg]
+ (* deg DEGREES-TO-RADIANS))
+
+(defn ^number to-degrees
+ {:doc "Converts an angle in radians to an approximate equivalent angle in degrees.
+ See: https://docs.oracle.com/javase/8/docs/api/java/lang/Math.html#toDegrees-double-"
+ :added "1.11.10"}
+ [r]
+ (* r RADIANS-TO-DEGREES))
+
+(defn ^number exp
+ {:doc "Returns Euler's number e raised to the power of a.
+ If a is ##NaN => ##NaN
+ If a is ##Inf => ##Inf
+ If a is ##-Inf => +0.0
+ See: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/exp"
+ :added "1.11.10"}
+ [a] (Math/exp a))
+
+(defn ^number log
+ {:doc "Returns the natural logarithm (base e) of a.
+ If a is ##NaN or negative => ##NaN
+ If a is ##Inf => ##Inf
+ If a is zero => ##-Inf
+ See: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/log"
+ :added "1.11.10"}
+ [a] (Math/log a))
+
+(defn ^number log10
+ {:doc "Returns the logarithm (base 10) of a.
+ If a is ##NaN or negative => ##NaN
+ If a is ##Inf => ##Inf
+ If a is zero => ##-Inf
+ See: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/log10"
+ :added "1.11.10"}
+ [a] (Math/log10 a))
+
+(defn ^number sqrt
+ {:doc "Returns the positive square root of a.
+ If a is ##NaN or negative => ##NaN
+ If a is ##Inf => ##Inf
+ If a is zero => a
+ See: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/sqrt"
+ :added "1.11.10"}
+ [a] (Math/sqrt a))
+
+(defn ^number cbrt
+ {:doc "Returns the cube root of a.
+ If a is ##NaN => ##NaN
+ If a is ##Inf or ##-Inf => a
+ If a is zero => zero with sign matching a
+ See: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/cbrt"
+ :added "1.11.10"}
+ [a] (Math/cbrt a))
+
+(defn ^number fabs
+ {:doc "Internal function to convert doubles to absolute values.
+ This duplicates the C implementations in Java, in case there is are corner-case differences."
+ :private true
+ :added "1.11.10"}
+ [x]
+ ;; create a buffer large enough for a double
+ (let [a (js/ArrayBuffer. 8)
+ ;; represent the buffer as a double array
+ d (js/Float64Array. a)
+ ;; represent the buffer as 32 bit ints
+ i (js/Uint32Array. a)
+ hi (if little-endian? 1 0)]
+ ;; insert the double value into the buffer
+ (aset d 0 x)
+ ;; update the sign bit
+ (aset i hi (bit-and (aget i hi) INT32-NON-SIGN-BITS))
+ ;; return the new double
+ (aget d 0)))
+
+(def ^{:private true} Zero
+ ;; a buffer that can hold a pair of 64 bit doubles
+ (let [a (js/ArrayBuffer. 16)
+ ;; represent the buffer as a 2 double array
+ d (js/Float64Array. a)
+ ;; represent the buffer as an array of bytes
+ b (js/Uint8Array. a)]
+ ;; initialize both doubles to 0.0
+ (aset d 0 0.0)
+ (aset d 1 0.0)
+ ;; update the sign bit on the second double
+ (aset b (if little-endian? 15 8) -0x80)
+ ;; save the array of 2 doubles [0.0, -0.0]
+ d))
+
+(def ^{:private true :const true} xpos 0)
+(def ^{:private true :const true} ypos 1)
+(def ^{:private true} HI-x (+ (* 2 xpos) HI))
+(def ^{:private true} LO-x (+ (* 2 xpos) LO))
+(def ^{:private true} HI-y (+ (* 2 ypos) HI))
+(def ^{:private true} LO-y (+ (* 2 ypos) LO))
+
+(defn ^number ilogb
+ {:doc "internal function for ilogb(x)"
+ :private true}
+ [hx lx]
+ (if (< hx 0x00100000) ;; subnormal
+ (let [hx-zero? (zero? hx)
+ start-ix (if hx-zero? -1043 -1022)
+ start-i (if hx-zero? lx (bit-shift-left hx 11))]
+ (loop [ix start-ix i start-i]
+ (if-not (> i 0)
+ ix
+ (recur (dec ix) (bit-shift-left i 1)))))
+ (- (bit-shift-right hx 20) 1023)))
+
+(defn ^number setup-hl
+ {:doc "internal function to setup and align integer words"
+ :private true}
+ [i h l]
+ (if (>= i -1022)
+ [(bit-or 0x00100000 (bit-and 0x000fffff h)) l]
+ (let [n (- -1022 i)]
+ (if (<= n 31)
+ [(bit-or (bit-shift-left h n) (unsigned-bit-shift-right l (- 32 n))) (bit-shift-left l n)]
+ [(bit-shift-left l (- n 32)) 0]))))
+
+(defn ^number IEEE-fmod
+ {:doc "Return x mod y in exact arithmetic. Method: shift and subtract.
+ Reimplements __ieee754_fmod from the JDK.
+ Ported from: https://github.com/openjdk/jdk/blob/master/src/java.base/share/native/libfdlibm/e_fmod.c
+ bit-shift-left and bit-shift-right convert numbers to signed 32-bit
+ Fortunately the values that are shifted are expected to be 32 bit signed."
+ :private true}
+ [x y]
+ ;; return exception values
+ (if (or (zero? y) ^boolean (js/isNaN y) (not ^boolean (js/isFinite x)))
+ ##NaN
+
+ ;; create a buffer large enough for 2 doubles
+ (let [a (js/ArrayBuffer. 16)
+ ;; represent the buffer as a double array
+ d (js/Float64Array. a)
+ ;; represent the buffer as 32 bit ints
+ i (js/Uint32Array. a)
+ ;; set the doubles to x and y
+ _ (aset d xpos x)
+ _ (aset d ypos y)
+ hx (aget i HI-x)
+ lx (aget i LO-x)
+ hy (aget i HI-y)
+ ly (aget i LO-y)
+ sx (bit-and hx INT32-NON-SIGN-BIT) ;; capture the sign of x
+ hx (bit-and hx INT32-NON-SIGN-BITS) ;; set x to |x|
+ hy (bit-and hy INT32-NON-SIGN-BITS) ;; set y to |y|
+ hx<=hy (<= hx hy)]
+ (cond
+ ;; additional exception values
+ (and hx<=hy (or (< hx hy) (< lx ly))) x ;; |x|<|y| return x
+ (and hx<=hy (== lx ly)) (aget Zero (unsigned-bit-shift-right sx 31)) ;; |x|=|y| return x*0
+
+ :default
+ ;; determine ix = ilogb(x), iy = ilogb(y)
+ (try
+ (let [ix (ilogb hx lx)
+ iy (ilogb hy ly)
+ ;; set up {hx,lx}, {hy,ly} and align y to x
+ [hx lx] (setup-hl ix hx lx)
+ [hy ly] (setup-hl iy hy ly)
+ ;; fix point fmod
+ [hx lx] (loop [n (- ix iy) hx hx lx lx]
+ (if (zero? n)
+ [hx lx]
+ (let [hz (if (u< lx ly) (- hx hy 1) (- hx hy))
+ lz (- lx ly)
+ [hx lx] (if (< hz 0)
+ [(+ hx hx (unsigned-bit-shift-right lx 31)) (+ lx lx)]
+ (if (zero? (bit-or hz lz))
+ (throw (ex-info "Signed zero" {:zero true}))
+ [(+ hz hz (unsigned-bit-shift-right lz 31)) (+ lz lz)]))]
+ (recur (dec n) (bit-and INT32-MASK hx) (bit-and INT32-MASK lx)))))
+ hz (if (u< lx ly) (- hx hy 1) (- hx hy))
+ lz (- lx ly)
+ [hx lx] (if (>= hz 0) [hz lz] [hx lx])
+
+ _ (when (zero? (bit-or hx lx))
+ (throw (ex-info "Signed zero" {:zero true})))
+ ;; convert back to floating value and restore the sign
+ [hx lx iy] (loop [hx hx lx lx iy iy]
+ (if-not (< hx 0x00100000)
+ [hx lx iy]
+ (recur (+ hx hx (unsigned-bit-shift-right lx 31)) (+ lx lx) (dec iy))))]
+ ;; use these high and low ints to update the double and return it
+ (if (>= iy -1022)
+ (let [hx (bit-or (- hx 0x00100000) (bit-shift-left (+ iy 1023) 20))]
+ (aset i HI-x (bit-or hx sx))
+ (aset i LO-x lx)
+ (aget d xpos))
+ (let [n (- -1022 iy)
+ [hx lx] (cond
+ (<= n 20) [(bit-shift-right hx n)
+ (bit-or (unsigned-bit-shift-right lx n) (bit-shift-left hx (- 32 n)))]
+ (<= n 31) [sx
+ (bit-or (bit-shift-left hx (- 32 n)) (unsigned-bit-shift-right lx n))]
+ :default [sx (bit-shift-right hx (- n 32))])]
+ (aset i HI-x (bit-or hx sx))
+ (aset i LO-x lx)
+ (* (aget d xpos) 1.0))))
+ (catch :default _ (aget Zero (unsigned-bit-shift-right sx 31))))))))
+
+(defn ^number IEEE-remainder
+ {:doc "Returns the remainder per IEEE 754 such that
+ remainder = dividend - divisor * n
+ where n is the integer closest to the exact value of dividend / divisor.
+ If two integers are equally close, then n is the even one.
+ If the remainder is zero, sign will match dividend.
+ If dividend or divisor is ##NaN, or dividend is ##Inf or ##-Inf, or divisor is zero => ##NaN
+ If dividend is finite and divisor is infinite => dividend
+
+ Method: based on fmod return x-[x/p]chopped*p exactlp.
+ Ported from: https://github.com/openjdk/jdk/blob/master/src/java.base/share/native/libfdlibm/e_remainder.c
+ See: https://docs.oracle.com/javase/8/docs/api/java/lang/Math.html#IEEEremainder-double-double-"
+ :added "1.11.10"}
+ [dividend divisor]
+ ;; check for exception values
+ (cond
+ (zero? divisor) ##NaN
+ ^boolean (js/isNaN divisor) ##NaN
+ ;; check if dividend is ##Inf ##-Inf or ##NaN
+ ^boolean (js/isNaN dividend) ##NaN
+ (not ^boolean (js/isFinite dividend)) ##NaN
+ ;; dividend is finish, check if divisor is infinite
+ (not ^boolean (js/isFinite divisor)) dividend
+
+ :default
+ ;; create a buffer large enough for 2 doubles
+ (let [a (js/ArrayBuffer. 16)
+ ;; represent the buffer as a double array
+ d (js/Float64Array. a)
+ ;; represent the buffer as 32 bit ints
+ i (js/Uint32Array. a)]
+ (aset d 0 dividend)
+ (aset d 1 divisor)
+ ;; x gets the dividend high and low ints
+ (let [hx (aget i HI)
+ lx (aget i LO)
+ ;; p gets the divisor high and low ints
+ hp (aget i (+ HI 2))
+ lp (aget i (+ LO 2))
+ ;; sx is the sign bit
+ sx (bit-and hx INT32-NON-SIGN-BIT)
+ ;; strip the sign bit from hp and hx
+ hp (bit-and hp INT32-NON-SIGN-BITS)
+ hx (bit-and hx INT32-NON-SIGN-BITS)
+
+ ;;make x < 2p
+ dividend (if (<= hp 0x7FDFFFFF) (IEEE-fmod dividend (+ divisor divisor)) dividend)]
+ (if (zero? (bit-or (- hx hp) (- lx lp)))
+ (* 0.0 dividend)
+ ;; convert dividend and divisor to absolute values.
+ (let [dividend (Math/abs dividend)
+ divisor (Math/abs divisor)
+ ;; reduce dividend within range of the divisor
+ dividend (if (< hp 0x00200000)
+ ;; smaller divisor compare 2*dividend to the divisor
+ (if (> (+ dividend dividend) divisor)
+ (let [dividend (- dividend divisor)] ;; reduce the dividend
+ (if (>= (+ dividend dividend) divisor) ;; 2*dividend still larger
+ (- dividend divisor) ;; reduce again
+ dividend))
+ dividend)
+ ;; compare dividend to half the divisor
+ (let [divisor-half (* 0.5 divisor)]
+ (if (> dividend divisor-half)
+ (let [dividend (- dividend divisor)] ;; reduce the dividend
+ (if (>= dividend divisor-half) ;; still larger than half divisor
+ (- dividend divisor) ;; reduce again
+ dividend))
+ dividend)))]
+ ;; update the buffer with the new dividend value
+ (aset d 0 dividend)
+ ;; calculate a new hi int for the dividend using the saved sign bit
+ (let [hx (bit-xor (aget i HI) sx)]
+ ;; set the dividend with this new sign bit
+ (aset i HI hx)
+ ;; retrieve the updated dividend
+ (aget d 0))))))))
+
+(defn ^number ceil
+ {:doc "Returns the smallest double greater than or equal to a, and equal to a
+ mathematical integer.
+ If a is ##NaN or ##Inf or ##-Inf or already equal to an integer => a
+ Note that if a is `nil` then an exception will be thrown. This matches Clojure, rather than js/Math.ceil
+ See: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/ceil"
+ :added "1.11.10"}
+ [a]
+ (if (some? a)
+ (Math/ceil a)
+ (throw (ex-info "Unexpected Null passed to ceil" {:fn "ceil"}))))
+
+(defn ^number floor
+ {:doc "Returns the largest double less than or equal to a, and equal to a
+ mathematical integer.
+ If a is ##NaN or ##Inf or ##-Inf or already equal to an integer => a
+ If a is less than zero but greater than -1.0 => -0.0
+ Note that if a is `nil` then an exception will be thrown. This matches Clojure, rather than js/Math.floor
+ See: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/floor"
+ :added "1.11.10"}
+ [a]
+ (if (some? a)
+ (Math/floor a)
+ (throw (ex-info "Unexpected Null passed to floor" {:fn "floor"}))))
+
+(defn ^number copy-sign
+ {:doc "Returns a double with the magnitude of the first argument and the sign of
+ the second.
+ See: https://docs.oracle.com/javase/8/docs/api/java/lang/Math.html#copySign-double-double-"
+ :added "1.11.10"}
+ [magnitude sign]
+ ;; create a buffer large enough for 2 doubles
+ (let [a (js/ArrayBuffer. 16)
+ ;; represent the buffer as a double array
+ d (js/Float64Array. a)
+ ;; represent the buffer as bytes
+ b (js/Uint8Array. a)
+ ;; find the offset of the byte that holds the sign bit
+ sbyte (if little-endian? 7 0)]
+ ;; the first double holds the magnitude, the second holds the sign value
+ (aset d 0 magnitude)
+ (aset d 1 sign)
+ ;; read the sign bit from the sign value
+ (let [sign-sbyte (bit-and 0x80 (aget b (+ 8 sbyte)))
+ ;; read all the bits that aren't the sign bit in the same byte of the magnitude
+ mag-sbyte (bit-and 0x7F (aget b sbyte))]
+ ;; combine the sign bit from the sign value and the non-sign-bits from the magnitude value
+ ;; write it back into the byte in the magnitude
+ (aset b sbyte (bit-or sign-sbyte mag-sbyte))
+ ;; retrieve the full magnitude value with the updated byte
+ (aget d 0))))
+
+(defn ^number rint
+ {:doc "Returns the double closest to a and equal to a mathematical integer.
+ If two values are equally close, return the even one.
+ If a is ##NaN or ##Inf or ##-Inf or zero => a
+ See: https://docs.oracle.com/javase/8/docs/api/java/lang/Math.html#rint-double-"
+ :added "1.11.10"}
+ [a]
+ (let [sign (copy-sign 1.0, a)
+ a (Math/abs a)
+ a (if (< a TWO-TO-THE-52)
+ (- (+ TWO-TO-THE-52 a) TWO-TO-THE-52) a)]
+ (* sign a)))
+
+(defn ^number atan2
+ {:doc "Returns the angle theta from the conversion of rectangular coordinates (x, y) to polar coordinates (r, theta).
+ Computes the phase theta by computing an arc tangent of y/x in the range of -pi to pi.
+ For more details on special cases, see:
+ https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/atan"
+ :added "1.11.10"}
+ [y x] (Math/atan2 y x))
+
+(defn ^number pow
+ {:doc "Returns the value of a raised to the power of b.
+ For more details on special cases, see:
+ https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/pow"
+ :added "1.11.10"}
+ [a b] (Math/pow a b))
+
+(defn ^number round
+ {:doc "Returns the closest long to a. If equally close to two values, return the one
+ closer to ##Inf.
+ If a is ##NaN => 0
+ If a is ##-Inf => js/Number.MIN_SAFE_INTEGER
+ If a is ##Inf => js/Number.MAX_SAFE_INTEGER
+ See: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/round"
+ :added "1.11.10"}
+ [a]
+ (cond
+ ^boolean (js/isNaN a) 0
+ ^boolean (js/isFinite a) (Math/round a)
+ (== ##Inf a) js/Number.MAX_SAFE_INTEGER
+ :default js/Number.MIN_SAFE_INTEGER))
+
+(defn ^number random
+ {:doc "Returns a positive double between 0.0 and 1.0, chosen pseudorandomly with
+ approximately random distribution. Not cryptographically secure. The seed is chosen internally
+ and cannot be selected.
+ See: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/random"
+ :added "1.11.10"}
+ [] (Math/random))
+
+(defn ^number add-exact
+ {:doc "Returns the sum of x and y, throws an exception on overflow. "
+ :added "1.11.10"}
+ [x y]
+ (let [r (clojure.core/+ x y)]
+ (if (or (> r js/Number.MAX_SAFE_INTEGER) (< r js/Number.MIN_SAFE_INTEGER))
+ (throw (ex-info "Integer overflow" {:fn "add-exact"}))
+ r)))
+
+(defn ^number subtract-exact
+ {:doc "Returns the difference of x and y, throws ArithmeticException on overflow. "
+ :added "1.11.10"}
+ [x y]
+ (let [r (- x y)]
+ (if (or (> r js/Number.MAX_SAFE_INTEGER) (< r js/Number.MIN_SAFE_INTEGER))
+ (throw (ex-info "Integer overflow" {:fn "subtract-exact"}))
+ r)))
+
+(defn ^number multiply-exact
+ {:doc "Returns the product of x and y, throws ArithmeticException on overflow. "
+ :added "1.11.10"}
+ [x y]
+ (let [r (* x y)]
+ (if (or (> r js/Number.MAX_SAFE_INTEGER) (< r js/Number.MIN_SAFE_INTEGER))
+ (throw (ex-info "Integer overflow" {:fn "multiply-exact"}))
+ r)))
+
+(defn ^number increment-exact
+ {:doc "Returns a incremented by 1, throws ArithmeticException on overflow."
+ :added "1.11.10"}
+ [a]
+ (if (or (>= a js/Number.MAX_SAFE_INTEGER) (< a js/Number.MIN_SAFE_INTEGER))
+ (throw (ex-info "Integer overflow" {:fn "increment-exact"}))
+ (inc a)))
+
+(defn ^number decrement-exact
+ {:doc "Returns a decremented by 1, throws ArithmeticException on overflow. "
+ :added "1.11.10"}
+ [a]
+ (if (or (<= a js/Number.MIN_SAFE_INTEGER) (> a js/Number.MAX_SAFE_INTEGER))
+ (throw (ex-info "Integer overflow" {:fn "decrement-exact"}))
+ (dec a)))
+
+(defn ^number negate-exact
+ {:doc "Returns the negation of a, throws ArithmeticException on overflow. "
+ :added "1.11.10"}
+ [a]
+ (if (or (> a js/Number.MAX_SAFE_INTEGER) (< a js/Number.MIN_SAFE_INTEGER))
+ (throw (ex-info "Integer overflow" {:fn "negate-exact"}))
+ (- a)))
+
+(defn- xor
+ [^boolean a ^boolean b]
+ (or (and a (not b)) (and (not a) b)))
+
+(defn ^number floor-div
+ {:doc "Integer division that rounds to negative infinity (as opposed to zero).
+ See: https://docs.oracle.com/javase/8/docs/api/java/lang/Math.html#floorDiv-long-long-"
+ :added "1.11.10"}
+ [x y]
+ (if-not (and ^boolean (js/Number.isSafeInteger x) ^boolean (js/Number.isSafeInteger y))
+ (throw (ex-info "floor-div called with non-safe-integer arguments"
+ {:x-int? (js/Number.isSafeInteger x) :y-int? (js/Number.isSafeInteger y)}))
+ (let [r (long (/ x y))]
+ (if (and (xor (< x 0) (< y 0)) (not (== (* r y) x)))
+ (dec r)
+ r))))
+
+(defn ^number floor-mod
+ {:doc "Integer modulus x - (floorDiv(x, y) * y). Sign matches y and is in the
+ range -|y| < r < |y|.
+ See: https://docs.oracle.com/javase/8/docs/api/java/lang/Math.html#floorMod-long-long-"
+ :added "1.11.10"}
+ [x y]
+ (if-not (and ^boolean (js/Number.isSafeInteger x) ^boolean (js/Number.isSafeInteger y))
+ (throw (ex-info "floor-mod called with non-safe-integer arguments"
+ {:x-int? (js/Number.isSafeInteger x) :y-int? (js/Number.isSafeInteger y)}))
+ ;; this avoids using floor-div to keep within the safe integer range
+ (let [r (long (/ x y))]
+ (if (and (xor (< x 0) (< y 0)) (not (== (* r y) x)))
+ (- x (* y r) (- y))
+ (- x (* y r))))))
+
+(defn ^number get-exponent
+ {:doc "Returns the exponent of d.
+ If d is ##NaN, ##Inf, ##-Inf => max_Float64_exponent + 1
+ If d is zero or subnormal => min_Float64_exponent - 1
+ See: https://docs.oracle.com/javase/8/docs/api/java/lang/Math.html#getExponent-double-"
+ :added "1.11.10"}
+ [d]
+ (cond
+ (or ^boolean (js/isNaN d) (not ^boolean (js/isFinite d))) (inc EXP-MAX)
+ (zero? d) (dec EXP-MIN)
+ :default (let [a (js/ArrayBuffer. 8)
+ f (js/Float64Array. a)
+ i (js/Uint32Array. a)
+ hi (if little-endian? 1 0)]
+ (aset f 0 d)
+ (- (bit-shift-right (bit-and (aget i hi) EXP-BITMASK32) (dec SIGNIFICAND-WIDTH32)) EXP-BIAS))))
+
+(defn ^number hi-lo->double
+ {:doc "Converts a pair of 32 bit integers into an IEEE-754 64 bit floating point number.
+ h is the high 32 bits, l is the low 32 bits."
+ :private true}
+ [h l]
+ (let [a (js/ArrayBuffer. 8)
+ f (js/Float64Array. a)
+ i (js/Uint32Array. a)]
+ (aset i LO l)
+ (aset i HI h)
+ (aget f 0)))
+
+(defn ^number power-of-two
+ {:doc "returns a floating point power of two in the normal range"
+ :private true}
+ [n]
+ (assert (and (>= n EXP-MIN) (<= n EXP-MAX)))
+ (hi-lo->double
+ (bit-and (bit-shift-left (+ n EXP-BIAS) (dec SIGNIFICAND-WIDTH32)) EXP-BITMASK32) 0))
+
+(defn ^number ulp
+ {:doc "Returns the size of an ulp (unit in last place) for d.
+ If d is ##NaN => ##NaN
+ If d is ##Inf or ##-Inf => ##Inf
+ If d is zero => Number/MIN_VALUE
+ If d is +/- Number/MAX_VALUE => 2^971
+ See: https://docs.oracle.com/javase/8/docs/api/java/lang/Math.html#ulp-double-"
+ :added "1.11.10"}
+ [d]
+ (cond
+ ^boolean (js/isNaN d) d
+ ^boolean (js/isFinite d)
+ (let [e (get-exponent d)]
+ (case e
+ 1024 (Math/abs d) ;; EXP-MAX + 1
+ -1023 js/Number.MIN_VALUE ;; EXP-MIN - 1
+ (let [e (- e (+ 31 SIGNIFICAND-WIDTH32))] ;; SIGNIFICAND_WIDTH64 -1
+ (if (>= e EXP-MIN)
+ (power-of-two e)
+ (let [shift (- e (- EXP-MIN 31 SIGNIFICAND-WIDTH32))]
+ (if (< shift 32)
+ (hi-lo->double 0 (bit-shift-left 1 shift))
+ (hi-lo->double (bit-shift-left 1 (- shift 32)) 0)))))))
+ :default ##Inf))
+
+(defn ^number signum
+ {:doc "Returns the signum function of d - zero for zero, 1.0 if >0, -1.0 if <0.
+ If d is ##NaN => ##NaN
+ If d is ##Inf or ##-Inf => sign of d
+ See: https://docs.oracle.com/javase/8/docs/api/java/lang/Math.html#signum-double-"
+ :added "1.11.10"}
+ [d]
+ (if (or (zero? d) ^boolean (js/isNaN d))
+ d
+ (copy-sign 1.0 d)))
+
+(defn ^number sinh
+ {:doc "Returns the hyperbolic sine of x, (e^x - e^-x)/2.
+ If x is ##NaN => ##NaN
+ If x is ##Inf or ##-Inf or zero => x
+ See: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/sinh"
+ :added "1.11.10"}
+ [x] (Math/sinh x))
+
+(defn ^number cosh
+ {:doc "Returns the hyperbolic cosine of x, (e^x + e^-x)/2.
+ If x is ##NaN => ##NaN
+ If x is ##Inf or ##-Inf => ##Inf
+ If x is zero => 1.0
+ See: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/cosh"
+ :added "1.11.10"}
+ [x] (Math/cosh x))
+
+(defn ^number tanh
+ {:doc "Returns the hyperbolic tangent of x, sinh(x)/cosh(x).
+ If x is ##NaN => ##NaN
+ If x is zero => zero, with same sign
+ If x is ##Inf => +1.0
+ If x is ##-Inf => -1.0
+ See: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/tanh"
+ :added "1.11.10"}
+ [x] (Math/tanh x))
+
+(defn ^number hypot
+ {:doc "Returns sqrt(x^2 + y^2) without intermediate underflow or overflow.
+ If x or y is ##Inf or ##-Inf => ##Inf
+ If x or y is ##NaN and neither is ##Inf or ##-Inf => ##NaN
+ See: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/hypot"
+ :added "1.11.10"}
+ [x y] (Math/hypot x y))
+
+(defn ^number expm1
+ {:doc "Returns e^x - 1. Near 0, expm1(x)+1 is more accurate to e^x than exp(x).
+ If x is ##NaN => ##NaN
+ If x is ##Inf => #Inf
+ If x is ##-Inf => -1.0
+ If x is zero => x
+ See: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/expm1"
+ :added "1.11.10"}
+ [x] (Math/expm1 x))
+
+(defn ^number log1p
+ {:doc "Returns ln(1+x). For small values of x, log1p(x) is more accurate than
+ log(1.0+x).
+ If x is ##NaN or ##-Inf or < -1 => ##NaN
+ If x is -1 => ##-Inf
+ If x is ##Inf => ##Inf
+ See: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/log1p"
+ :added "1.11.10"}
+ [x] (Math/log1p x))
+
+(defn ^number add64
+ {:doc "Takes the high and low words for 2 different 64 bit integers, and adds them.
+ This handles overflow from the low-order words into the high order words."
+ :private true}
+ [hx lx hy ly]
+ (let [sx (unsigned-bit-shift-right (bit-and lx INT32-NON-SIGN-BIT) 31)
+ sy (unsigned-bit-shift-right (bit-and ly INT32-NON-SIGN-BIT) 31)
+ lr (+ (bit-and INT32-NON-SIGN-BITS lx) (bit-and INT32-NON-SIGN-BITS ly))
+ c31 (unsigned-bit-shift-right (bit-and lr INT32-NON-SIGN-BIT) 31)
+ b31 (+ sx sy c31)
+ lr (bit-or (bit-and lr INT32-NON-SIGN-BITS) (bit-shift-left b31 31))
+ c32 (bit-shift-right b31 1)
+ hr (bit-and INT32-MASK (+ hx hy c32))]
+ [hr lr]))
+
+(defn ^number next-after
+ {:doc "Returns the adjacent floating point number to start in the direction of
+ the second argument. If the arguments are equal, the second is returned.
+ If either arg is #NaN => #NaN
+ If both arguments are signed zeros => direction
+ If start is +-Number/MIN_VALUE and direction would cause a smaller magnitude
+ => zero with sign matching start
+ If start is ##Inf or ##-Inf and direction would cause a smaller magnitude
+ => Number/MAX_VALUE with same sign as start
+ If start is equal to +=Number/MAX_VALUE and direction would cause a larger magnitude
+ => ##Inf or ##-Inf with sign matching start
+ See: https://docs.oracle.com/javase/8/docs/api/java/lang/Math.html#nextAfter-double-double-"
+ :added "1.11.10"}
+ [start direction]
+ ; Branch to descending case first as it is more costly than ascending
+ ; case due to start != 0.0f conditional.
+ (let [a (js/ArrayBuffer. 8)
+ f (js/Float64Array. a)
+ i (js/Uint32Array. a)]
+ (cond
+ (> start direction) (if-not (zero? start)
+ (let [_ (aset f 0 start)
+ ht (aget i HI)
+ lt (aget i LO)
+ ;; ht< != 0 since start != 0.0
+ ;; So long as the top bit is not set, then whole number is > 0
+ [hr lr] (if (zero? (bit-and ht INT32-NON-SIGN-BIT))
+ (add64 ht lt 0xFFFFFFFF 0xFFFFFFFF)
+ (add64 ht lt 0 1))]
+ (aset i HI hr)
+ (aset i LO lr)
+ (aget f 0))
+ ;; start == 0.0 && direction < 0.0
+ (- js/Number.MIN_VALUE))
+ ;; Add +0.0 to get rid of a -0.0 (+0.0 + -0.0 => +0.0)
+ ;; then bitwise convert start to integer
+ (< start direction) (let [_ (aset f 0 (+ start 0.0))
+ ht (aget i HI)
+ lt (aget i LO)
+ [hr lr] (if (zero? (bit-and ht INT32-NON-SIGN-BIT))
+ (add64 ht lt 0 1)
+ (add64 ht lt 0xFFFFFFFF 0xFFFFFFFF))]
+ (aset i HI hr)
+ (aset i LO lr)
+ (aget f 0))
+ (== start direction) direction
+ :default (+ start direction)))) ;; isNaN(start) || isNaN(direction)
+
+(defn ^number next-up
+ {:doc "Returns the adjacent double of d in the direction of ##Inf.
+ If d is ##NaN => ##NaN
+ If d is ##Inf => ##Inf
+ If d is zero => Number/MIN_VALUE
+ See: https://docs.oracle.com/javase/8/docs/api/java/lang/Math.html#nextUp-double-"
+ :added "1.11.10"}
+ [d]
+ ;; Use a single conditional and handle the likely cases first
+ (if (< d js/Number.POSITIVE_INFINITY)
+ (let [a (js/ArrayBuffer. 8)
+ f (js/Float64Array. a)
+ i (js/Uint32Array. a)
+ ;; Add +0.0 to get rid of a -0.0 (+0.0 + -0.0 => +0.0)
+ _ (aset f 0 (+ d 0.0))
+ ht (aget i HI)
+ lt (aget i LO)
+ [hr lr] (if (zero? (bit-and ht INT32-NON-SIGN-BIT))
+ (add64 ht lt 0 1)
+ (add64 ht lt 0xFFFFFFFF 0xFFFFFFFF))]
+ (aset i HI hr)
+ (aset i LO lr)
+ (aget f 0))
+ ;; d is NaN or +Infinity
+ d))
+
+(defn ^number next-down
+ {:doc "Returns the adjacent double of d in the direction of ##-Inf.
+ If d is ##NaN => ##NaN
+ If d is ##Inf => Number/MAX_VALUE
+ If d is zero => -Number/MIN_VALUE
+ See: https://docs.oracle.com/javase/8/docs/api/java/lang/Math.html#nextDown-double-"
+ :added "1.11.10"}
+ [d]
+ (cond
+ (or ^boolean (js/isNaN d) (== ##-Inf d)) d
+ (zero? d) (- js/Number.MIN_VALUE)
+ :default
+ (let [a (js/ArrayBuffer. 8)
+ f (js/Float64Array. a)
+ i (js/Uint32Array. a)
+ _ (aset f 0 d)
+ ht (aget i HI)
+ lt (aget i LO)
+ [hr lr] (if (> d 0)
+ (add64 ht lt 0xFFFFFFFF 0xFFFFFFFF)
+ (add64 ht lt 0 1))]
+ (aset i HI hr)
+ (aset i LO lr)
+ (aget f 0))))
+
+(def ^:private MAX_SCALE (+ EXP-MAX (- EXP-MIN) SIGNIFICAND-WIDTH32 32 1))
+
+(def ^:private two-to-the-double-scale-up (power-of-two 512))
+
+(def ^:private two-to-the-double-scale-down (power-of-two -512))
+
+(defn ^number scalb
+ {:doc "Returns d * 2^scaleFactor, scaling by a factor of 2. If the exponent
+ is between min_Float64_exponent and max_Float64_exponent.
+ scaleFactor is an integer
+ If d is ##NaN => ##NaN
+ If d is ##Inf or ##-Inf => ##Inf or ##-Inf respectively
+ If d is zero => zero of same sign as d
+ See: https://docs.oracle.com/javase/8/docs/api/java/lang/Math.html#nextDown-double-"
+ :added "1.11.10"}
+ [d scaleFactor]
+ (let [[scale-factor
+ scale-increment
+ exp-delta] (if (< scaleFactor 0)
+ [(Math/max scaleFactor (- MAX_SCALE)) -512 two-to-the-double-scale-down]
+ [(Math/min scaleFactor MAX_SCALE) 512 two-to-the-double-scale-up])
+ ;; Calculate (scaleFactor % +/-512), 512 = 2^9
+ ;; technique from "Hacker's Delight" section 10-2
+ t (unsigned-bit-shift-right (bit-shift-right scale-factor 8) 23)
+ exp-adjust (- (bit-and (+ scale-factor t) 511) t)]
+ (loop [d (* d (power-of-two exp-adjust)) scale-factor (- scale-factor exp-adjust)]
+ (if (zero? scale-factor)
+ d
+ (recur (* d exp-delta) (- scale-factor scale-increment))))))
diff --git a/src/main/cljs/cljs/module_deps.js b/src/main/cljs/cljs/module_deps.js
new file mode 100644
index 0000000000..6b38cd083d
--- /dev/null
+++ b/src/main/cljs/cljs/module_deps.js
@@ -0,0 +1,250 @@
+// NOTE: This code should only employ single quotes for strings.
+// If double quotes are used, then when the contents of this file
+// are passed to node via --eval on Windows, the double quotes
+// will be elided, leading to syntactically incorrect JavaScript.
+
+let fs = require('fs');
+let path = require('path');
+let mdeps = require('@cljs-oss/module-deps');
+let nodeResolve = require('resolve');
+let babylon = require('babylon');
+let traverse = require('babel-traverse').default;
+let enhancedResolve = require('enhanced-resolve');
+
+let target = 'CLJS_TARGET';
+let filename = fs.realpathSync(path.resolve(__dirname, 'JS_FILE'));
+let mainFields = MAIN_ENTRIES;
+let aliasFields = target === 'nodejs' ? [] : ['browser'];
+
+// https://github.com/egoist/konan
+let getDeps = function (src, {dynamicImport = true, parse = {sourceType: 'module', plugins: '*'}} = {}) {
+ const modules = {strings: [], expressions: []};
+
+ let ast;
+
+ if (typeof src === 'string') {
+ const moduleRe = /\b(require|import|export)\b/;
+
+ if (!moduleRe.test(src)) {
+ return modules;
+ }
+
+ ast = babylon.parse(src, parse);
+ } else {
+ ast = src;
+ }
+
+ traverse(ast, {
+ enter(path) {
+ if (path.node.type === 'CallExpression') {
+ const callee = path.get('callee');
+ const isDynamicImport = dynamicImport && callee.isImport();
+ if (callee.isIdentifier({name: 'require'}) || isDynamicImport) {
+ const arg = path.node.arguments[0];
+ if (arg.type === 'StringLiteral') {
+ modules.strings.push(arg.value);
+ } else {
+ modules.expressions.push(src.slice(arg.start, arg.end));
+ }
+ }
+ } else if (path.node.type === 'ImportDeclaration' ||
+ path.node.type === 'ExportNamedDeclaration' ||
+ path.node.type === 'ExportAllDeclaration') {
+ const source = path.node.source;
+
+ if (source != null) {
+ modules.strings.push(path.node.source.value);
+ }
+ }
+ }
+ });
+
+ return modules;
+};
+
+let resolver = enhancedResolve.create({
+ fileSystem: new enhancedResolve.CachedInputFileSystem(
+ new enhancedResolve.NodeJsInputFileSystem(),
+ 4000
+ ),
+ extensions: ['.js', '.json'],
+ mainFields: mainFields,
+ aliasFields: target === 'nodejs' ? [] : ['browser'],
+ moduleExtensions: ['.js', '.json'],
+ symlinks: false
+});
+
+let md = mdeps({
+ resolve: function (id, parentOpts, cb) {
+ // set the basedir properly so we don't try to resolve requires in the Closure
+ // Compiler processed `node_modules` folder.
+ parentOpts.basedir =
+ parentOpts.filename === filename
+ ? path.resolve(__dirname)
+ : path.dirname(parentOpts.filename);
+
+ resolver(parentOpts.basedir, id, cb);
+ },
+ filter: function (id) {
+ return !(target === 'nodejs' && nodeResolve.isCore(id)) &&
+ !id.startsWith('goog:');
+ },
+ detect: function (src) {
+ let deps = getDeps(src);
+
+ return deps.strings;
+ }
+});
+
+function getPackageJsonMainEntry(pkgJson) {
+ for (let i = 0; i < mainFields.length; i++) {
+ let entry = mainFields[i];
+ const entryVal = pkgJson[entry];
+
+ if (entryVal != null) {
+ if (typeof entryVal === 'string') {
+ return entryVal;
+ } else if (typeof entryVal === 'object') {
+ for (let j = i; j < mainFields.length; j++) {
+ let otherEntry = mainFields[j];
+ const otherEntryVal = pkgJson[entry];
+
+ if (entryVal[otherEntryVal] != null) {
+ return entryVal[otherEntryVal]
+ }
+ }
+ }
+ }
+ }
+ return null;
+}
+
+function depProvides(provides, file) {
+ const result = provides != null ? provides.slice(0) : [];
+
+ let providedModule = file
+ .substring(file.lastIndexOf('node_modules'))
+ .replace(/\\/g, '/')
+ .replace('node_modules/', '');
+
+ result.push(
+ providedModule,
+ providedModule.replace(/\.js(on)?$/, '')
+ );
+
+ let indexReplaced = providedModule.replace(/\/index\.js(on)?$/, '');
+
+ if (
+ /\/index\.js(on)?$/.test(providedModule) &&
+ result.indexOf(indexReplaced) === -1
+ ) {
+ result.push(indexReplaced);
+ }
+
+ return result;
+}
+
+let pkgJsons = [];
+let deps_files = {};
+
+md.on('package', function (pkg) {
+ // we don't want to include the package.json for users' projects
+ if (/node_modules/.test(pkg.__dirname)) {
+ let pkgJson = {
+ basedir: pkg.__dirname,
+ file: path.join(pkg.__dirname, 'package.json'),
+ };
+
+ if (pkg.name != null) {
+ pkgJson.provides = [pkg.name];
+ }
+
+ let pkgJsonMainEntry = getPackageJsonMainEntry(pkg);
+ if (pkgJsonMainEntry != null) {
+ pkgJson.mainEntry = path.join(pkg.__dirname, pkgJsonMainEntry);
+ }
+
+ // we'll need these later
+ for (let i = 0; i < aliasFields.length; i++) {
+ const field = aliasFields[i];
+ if (pkg[field] != null) {
+ pkgJson[field] = pkg[field];
+ }
+ }
+
+ pkgJsons.push(pkgJson);
+ }
+});
+
+md.on('file', function (file) {
+ deps_files[file] = {file: file};
+});
+
+md.on('end', function () {
+ for (let i = 0; i < pkgJsons.length; i++) {
+ let pkgJson = pkgJsons[i];
+ const candidates = /\.js(on)?$/.test(pkgJson.mainEntry)
+ ? [pkgJson.mainEntry]
+ : [pkgJson.mainEntry, pkgJson.mainEntry + '.js', pkgJson.mainEntry + 'FILE_SEPARATOR' + 'index.js', pkgJson.mainEntry + '.json'];
+
+ for (let j = 0; j < candidates.length; j++) {
+ const candidate = candidates[j];
+
+ if (deps_files[candidate] != null && pkgJson.provides != null) {
+ deps_files[candidate].provides = pkgJson.provides;
+ }
+ }
+
+ for (let j = 0; j < aliasFields.length; j++) {
+ const field = aliasFields[j];
+ const fieldValue = pkgJson[field];
+
+ if (fieldValue != null && typeof fieldValue === 'object') {
+ for (let key in fieldValue) {
+ // TODO: False value means that the module should be ignored
+ if (typeof fieldValue[key] === 'string') {
+ const replacement = path.resolve(pkgJson.basedir, fieldValue[key]);
+
+ if (deps_files[replacement] != null) {
+ const file = path.resolve(pkgJson.basedir, key);
+ deps_files[replacement].provides = depProvides(deps_files[replacement].provides, file);
+
+ if (file === pkgJson.mainEntry) {
+ Array.prototype.push.apply(deps_files[replacement].provides, pkgJson.provides);
+ }
+ }
+ }
+ }
+ }
+ }
+
+
+ deps_files[pkgJson.file] = {file: pkgJson.file};
+ }
+
+ let values = [];
+ for (let key in deps_files) {
+ let dep = deps_files[key];
+
+ // add provides to files that are not `package.json`s
+ if (
+ !/node_modules[/\\](@[^/\\]+?[/\\])?[^/\\]+?[/\\]package\.json$/.test(
+ dep.file
+ )
+ ) {
+ if (dep.file.indexOf('node_modules') !== -1) {
+ dep.provides = depProvides(dep.provides, dep.file);
+ }
+ }
+
+ values.push(dep);
+ }
+
+ process.stdout.write(JSON.stringify(values));
+});
+
+md.end({
+ file: filename
+});
+
+md.resume();
diff --git a/src/main/cljs/cljs/nodejs.cljs b/src/main/cljs/cljs/nodejs.cljs
new file mode 100644
index 0000000000..ca587888d6
--- /dev/null
+++ b/src/main/cljs/cljs/nodejs.cljs
@@ -0,0 +1,27 @@
+; 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.
+
+; Projects compiled with :target :nodejs can 'require' this namespace
+; to get the nodejs globals loaded into cljs.nodejs and get
+; ClojureScript's 'print' set up correctly.
+(ns cljs.nodejs
+ (:refer-clojure :exclude [require]))
+
+; Define namespaced references to Node's externed globals:
+(def require (js* "require"))
+(def process (js* "process"))
+
+(defn enable-util-print! []
+ (set! *print-newline* false)
+ (set-print-fn!
+ (fn [& args]
+ (.apply (.-log js/console) js/console (into-array args))))
+ (set-print-err-fn!
+ (fn [& args]
+ (.apply (.-error js/console) js/console (into-array args))))
+ nil)
diff --git a/src/main/cljs/cljs/nodejs_externs.js b/src/main/cljs/cljs/nodejs_externs.js
new file mode 100644
index 0000000000..2dda100551
--- /dev/null
+++ b/src/main/cljs/cljs/nodejs_externs.js
@@ -0,0 +1,3 @@
+var global = {};
+function require(){};
+function process(){};
diff --git a/src/main/cljs/cljs/nodejscli.cljs b/src/main/cljs/cljs/nodejscli.cljs
new file mode 100644
index 0000000000..256a4fa97f
--- /dev/null
+++ b/src/main/cljs/cljs/nodejscli.cljs
@@ -0,0 +1,22 @@
+; 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.
+
+; Projects compiled with :target :nodejs have this file appended. Its
+; job is to make sure cljs.nodejs is loaded and that the *main-cli-fn*
+; is called with the script's command-line arguments.
+(ns cljs.nodejscli
+ (:require [cljs.nodejs :as nodejs]
+ [goog.object :as gobj]))
+
+;; need to set goog.global if COMPILED
+(when ^boolean js/COMPILED
+ (set! goog/global js/global))
+
+;; Call the user's main function
+(when (fn? cljs.core/*main-cli-fn*)
+ (apply cljs.core/*main-cli-fn* (drop 2 (gobj/get js/process "argv"))))
diff --git a/src/main/cljs/cljs/pprint.cljc b/src/main/cljs/cljs/pprint.cljc
new file mode 100644
index 0000000000..6793c38c27
--- /dev/null
+++ b/src/main/cljs/cljs/pprint.cljc
@@ -0,0 +1,167 @@
+;; 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.pprint
+ (:refer-clojure :exclude [deftype #?(:cljs macroexpand)])
+ (:require [clojure.walk :as walk]
+ #?(:cljs [cljs.analyzer :as ana])))
+
+
+;; required the following changes:
+;; replace .ppflush with -ppflush to switch from Interface to Protocol
+
+(defmacro with-pretty-writer [base-writer & body]
+ `(let [base-writer# ~base-writer
+ new-writer# (not (pretty-writer? base-writer#))]
+ (cljs.core/binding [cljs.core/*out* (if new-writer#
+ (make-pretty-writer base-writer# *print-right-margin* *print-miser-width*)
+ base-writer#)]
+ ~@body
+ (-ppflush cljs.core/*out*))))
+
+
+(defmacro getf
+ "Get the value of the field a named by the argument (which should be a keyword)."
+ [sym]
+ `(~sym @@~'this))
+
+;; change alter to swap!
+
+(defmacro setf
+ "Set the value of the field SYM to NEW-VAL"
+ [sym new-val]
+ `(swap! @~'this assoc ~sym ~new-val))
+
+(defmacro deftype
+ [type-name & fields]
+ (let [name-str (name type-name)
+ fields (map (comp symbol name) fields)]
+ `(do
+ (defrecord ~type-name [~'type-tag ~@fields])
+ (defn- ~(symbol (str "make-" name-str))
+ ~(vec fields)
+ (~(symbol (str type-name ".")) ~(keyword name-str) ~@fields))
+ (defn- ~(symbol (str name-str "?")) [x#] (= (:type-tag x#) ~(keyword name-str))))))
+
+(defn- parse-lb-options [opts body]
+ (loop [body body
+ acc []]
+ (if (opts (first body))
+ (recur (drop 2 body) (concat acc (take 2 body)))
+ [(apply hash-map acc) body])))
+
+(defmacro pprint-logical-block
+ "Execute the body as a pretty printing logical block with output to *out* which
+ must be a pretty printing writer. When used from pprint or cl-format, this can be
+ assumed.
+
+ This function is intended for use when writing custom dispatch functions.
+
+ Before the body, the caller can optionally specify options: :prefix, :per-line-prefix
+ and :suffix."
+ [& args]
+ (let [[options body] (parse-lb-options #{:prefix :per-line-prefix :suffix} args)]
+ `(do (if (cljs.pprint/level-exceeded)
+ (~'-write cljs.core/*out* "#")
+ (do
+ (cljs.core/binding [cljs.pprint/*current-level* (inc cljs.pprint/*current-level*)
+ cljs.pprint/*current-length* 0]
+ (cljs.pprint/start-block cljs.core/*out*
+ ~(:prefix options)
+ ~(:per-line-prefix options)
+ ~(:suffix options))
+ ~@body
+ (cljs.pprint/end-block cljs.core/*out*))))
+ nil)))
+
+#?(:cljs
+ (defn macroexpand [env form]
+ (loop [form form
+ form' (ana/macroexpand-1 env form)]
+ (if-not (identical? form form')
+ (recur form' (ana/macroexpand-1 env form'))
+ form'))))
+
+(defn- pll-mod-body [env var-sym body]
+ (letfn [(inner [form]
+ (if (seq? form)
+ (let [form #?(:clj (macroexpand form)
+ :cljs (macroexpand env form))]
+ (condp = (first form)
+ 'loop* form
+ 'recur (concat `(recur (inc ~var-sym)) (rest form))
+ (walk/walk inner identity form)))
+ form))]
+ (walk/walk inner identity body)))
+
+(defmacro print-length-loop
+ "A version of loop that iterates at most *print-length* times. This is designed
+ for use in pretty-printer dispatch functions."
+ [bindings & body]
+ (let [count-var (gensym "length-count")
+ mod-body (pll-mod-body &env count-var body)]
+ `(loop ~(apply vector count-var 0 bindings)
+ (if (or (not cljs.core/*print-length*) (< ~count-var cljs.core/*print-length*))
+ (do ~@mod-body)
+ (~'-write cljs.core/*out* "...")))))
+
+(defn- process-directive-table-element [[char params flags bracket-info & generator-fn]]
+ [char,
+ {:directive char,
+ :params `(array-map ~@params),
+ :flags flags,
+ :bracket-info bracket-info,
+ :generator-fn (concat '(fn [params offset]) generator-fn)}])
+
+(defmacro ^{:private true}
+ defdirectives
+ [& directives]
+ `(def ^{:private true}
+ ~'directive-table (hash-map ~@(mapcat process-directive-table-element directives))))
+
+(defmacro formatter
+ "Makes a function which can directly run format-in. The function is
+fn [stream & args] ... and returns nil unless the stream is nil (meaning
+output to a string) in which case it returns the resulting string.
+
+format-in can be either a control string or a previously compiled format."
+ [format-in]
+ `(let [format-in# ~format-in
+ my-c-c# cljs.pprint/cached-compile
+ my-e-f# cljs.pprint/execute-format
+ my-i-n# cljs.pprint/init-navigator
+ cf# (if (string? format-in#) (my-c-c# format-in#) format-in#)]
+ (fn [stream# & args#]
+ (let [navigator# (my-i-n# args#)]
+ (my-e-f# stream# cf# navigator#)))))
+
+(defmacro formatter-out
+ "Makes a function which can directly run format-in. The function is
+fn [& args] ... and returns nil. This version of the formatter macro is
+designed to be used with *out* set to an appropriate Writer. In particular,
+this is meant to be used as part of a pretty printer dispatch method.
+
+format-in can be either a control string or a previously compiled format."
+ [format-in]
+ `(let [format-in# ~format-in
+ cf# (if (string? format-in#) (cljs.pprint/cached-compile format-in#) format-in#)]
+ (fn [& args#]
+ (let [navigator# (cljs.pprint/init-navigator args#)]
+ (cljs.pprint/execute-format cf# navigator#)))))
+
+(defmacro with-pprint-dispatch
+ "Execute body with the pretty print dispatch function bound to function."
+ [function & body]
+ `(cljs.core/binding [cljs.pprint/*print-pprint-dispatch* ~function]
+ ~@body))
+
+(defmacro pp
+ "A convenience macro that pretty prints the last thing output. This is
+exactly equivalent to (pprint *1)."
+ {:added "1.2"}
+ [] `(cljs.pprint/pprint *1))
diff --git a/src/main/cljs/cljs/pprint.cljs b/src/main/cljs/cljs/pprint.cljs
new file mode 100644
index 0000000000..718ba6ec11
--- /dev/null
+++ b/src/main/cljs/cljs/pprint.cljs
@@ -0,0 +1,3325 @@
+; 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.pprint
+ (:refer-clojure :exclude [deftype print println pr prn float?])
+ (:require-macros
+ [cljs.pprint :as m :refer [with-pretty-writer getf setf deftype
+ pprint-logical-block print-length-loop
+ defdirectives formatter-out]])
+ (:require
+ [cljs.core :refer [IWriter IDeref]]
+ [clojure.string :as string]
+ [goog.string :as gstring])
+ (:import [goog.string StringBuffer]))
+
+;;======================================================================
+;; override print fns to use *out*
+;;======================================================================
+
+(defn- print [& more]
+ (-write *out* (apply print-str more)))
+
+(defn- println [& more]
+ (apply print more)
+ (-write *out* \newline))
+
+(defn- print-char [c]
+ (-write *out* (condp = c
+ \backspace "\\backspace"
+ \space "\\space"
+ \tab "\\tab"
+ \newline "\\newline"
+ \formfeed "\\formfeed"
+ \return "\\return"
+ \" "\\\""
+ \\ "\\\\"
+ (str "\\" c))))
+
+(defn- ^:dynamic pr [& more]
+ (-write *out* (apply pr-str more)))
+
+(defn- prn [& more]
+ (apply pr more)
+ (-write *out* \newline))
+
+;;======================================================================
+;; cljs specific utils
+;;======================================================================
+
+(defn float?
+ "Returns true if n is an float."
+ [n]
+ (and (number? n)
+ (not ^boolean (js/isNaN n))
+ (not (identical? n js/Infinity))
+ (not (== (js/parseFloat n) (js/parseInt n 10)))))
+
+(defn char-code
+ "Convert char to int"
+ [c]
+ (cond
+ (number? c) c
+ (and (string? c) (== (.-length c) 1)) (.charCodeAt c 0)
+ :else (throw (js/Error. "Argument to char must be a character or number"))))
+
+;;======================================================================
+;; Utilities
+;;======================================================================
+
+(defn- map-passing-context [func initial-context lis]
+ (loop [context initial-context
+ lis lis
+ acc []]
+ (if (empty? lis)
+ [acc context]
+ (let [this (first lis)
+ remainder (next lis)
+ [result new-context] (apply func [this context])]
+ (recur new-context remainder (conj acc result))))))
+
+(defn- consume [func initial-context]
+ (loop [context initial-context
+ acc []]
+ (let [[result new-context] (apply func [context])]
+ (if (not result)
+ [acc new-context]
+ (recur new-context (conj acc result))))))
+
+(defn- consume-while [func initial-context]
+ (loop [context initial-context
+ acc []]
+ (let [[result continue new-context] (apply func [context])]
+ (if (not continue)
+ [acc context]
+ (recur new-context (conj acc result))))))
+
+(defn- unzip-map [m]
+ "Take a map that has pairs in the value slots and produce a pair of maps,
+ the first having all the first elements of the pairs and the second all
+ the second elements of the pairs"
+ [(into {} (for [[k [v1 v2]] m] [k v1]))
+ (into {} (for [[k [v1 v2]] m] [k v2]))])
+
+(defn- tuple-map [m v1]
+ "For all the values, v, in the map, replace them with [v v1]"
+ (into {} (for [[k v] m] [k [v v1]])))
+
+(defn- rtrim [s c]
+ "Trim all instances of c from the end of sequence s"
+ (let [len (count s)]
+ (if (and (pos? len) (= (nth s (dec (count s))) c))
+ (loop [n (dec len)]
+ (cond
+ (neg? n) ""
+ (not (= (nth s n) c)) (subs s 0 (inc n))
+ true (recur (dec n))))
+ s)))
+
+(defn- ltrim [s c]
+ "Trim all instances of c from the beginning of sequence s"
+ (let [len (count s)]
+ (if (and (pos? len) (= (nth s 0) c))
+ (loop [n 0]
+ (if (or (= n len) (not (= (nth s n) c)))
+ (subs s n)
+ (recur (inc n))))
+ s)))
+
+(defn- prefix-count [aseq val]
+ "Return the number of times that val occurs at the start of sequence aseq,
+if val is a seq itself, count the number of times any element of val occurs at the
+beginning of aseq"
+ (let [test (if (coll? val) (set val) #{val})]
+ (loop [pos 0]
+ (if (or (= pos (count aseq)) (not (test (nth aseq pos))))
+ pos
+ (recur (inc pos))))))
+
+;; Flush the pretty-print buffer without flushing the underlying stream
+(defprotocol IPrettyFlush
+ (-ppflush [pp]))
+
+;;======================================================================
+;; column_writer.clj
+;;======================================================================
+
+(def ^:dynamic ^{:private true} *default-page-width* 72)
+
+(defn- get-field [this sym]
+ (sym @@this))
+
+(defn- set-field [this sym new-val]
+ (swap! @this assoc sym new-val))
+
+(defn- get-column [this]
+ (get-field this :cur))
+
+(defn- get-line [this]
+ (get-field this :line))
+
+(defn- get-max-column [this]
+ (get-field this :max))
+
+(defn- set-max-column [this new-max]
+ (set-field this :max new-max)
+ nil)
+
+(defn- get-writer [this]
+ (get-field this :base))
+
+;; Why is the c argument an integer?
+(defn- c-write-char [this c]
+ (if (= c \newline)
+ (do
+ (set-field this :cur 0)
+ (set-field this :line (inc (get-field this :line))))
+ (set-field this :cur (inc (get-field this :cur))))
+ (-write (get-field this :base) c))
+
+(defn- column-writer
+ ([writer] (column-writer writer *default-page-width*))
+ ([writer max-columns]
+ (let [fields (atom {:max max-columns, :cur 0, :line 0 :base writer})]
+ (reify
+
+ IDeref
+ (-deref [_] fields)
+
+ IWriter
+ (-flush [_]
+ (-flush writer))
+ (-write
+ ;;-write isn't multi-arity, so need different way to do this
+ #_([this ^chars cbuf ^Number off ^Number len]
+ (let [writer (get-field this :base)]
+ (-write writer cbuf off len)))
+ [this x]
+ (condp = (type x)
+ js/String
+ (let [s x
+ nl (.lastIndexOf s \newline)]
+ (if (neg? nl)
+ (set-field this :cur (+ (get-field this :cur) (count s)))
+ (do
+ (set-field this :cur (- (count s) nl 1))
+ (set-field this :line (+ (get-field this :line)
+ (count (filter #(= % \newline) s))))))
+ (-write (get-field this :base) s))
+ js/Number
+ (c-write-char this x)))))))
+
+;;======================================================================
+;; pretty_writer.clj
+;;======================================================================
+
+;;======================================================================
+;; Forward declarations
+;;======================================================================
+
+(declare ^{:arglists '([this])} get-miser-width)
+
+;;======================================================================
+;; The data structures used by pretty-writer
+;;======================================================================
+
+(defrecord ^{:private true} logical-block
+ [parent section start-col indent
+ done-nl intra-block-nl
+ prefix per-line-prefix suffix
+ logical-block-callback])
+
+(defn- ancestor? [parent child]
+ (loop [child (:parent child)]
+ (cond
+ (nil? child) false
+ (identical? parent child) true
+ :else (recur (:parent child)))))
+
+(defn- buffer-length [l]
+ (let [l (seq l)]
+ (if l
+ (- (:end-pos (last l)) (:start-pos (first l)))
+ 0)))
+
+;; A blob of characters (aka a string)
+(deftype buffer-blob :data :trailing-white-space :start-pos :end-pos)
+
+;; A newline
+(deftype nl-t :type :logical-block :start-pos :end-pos)
+
+(deftype start-block-t :logical-block :start-pos :end-pos)
+
+(deftype end-block-t :logical-block :start-pos :end-pos)
+
+(deftype indent-t :logical-block :relative-to :offset :start-pos :end-pos)
+
+(def ^:private pp-newline (fn [] "\n"))
+
+(declare emit-nl)
+
+(defmulti ^{:private true} write-token #(:type-tag %2))
+
+(defmethod write-token :start-block-t [this token]
+ (when-let [cb (getf :logical-block-callback)] (cb :start))
+ (let [lb (:logical-block token)]
+ (when-let [prefix (:prefix lb)]
+ (-write (getf :base) prefix))
+ (let [col (get-column (getf :base))]
+ (reset! (:start-col lb) col)
+ (reset! (:indent lb) col))))
+
+(defmethod write-token :end-block-t [this token]
+ (when-let [cb (getf :logical-block-callback)] (cb :end))
+ (when-let [suffix (:suffix (:logical-block token))]
+ (-write (getf :base) suffix)))
+
+(defmethod write-token :indent-t [this token]
+ (let [lb (:logical-block token)]
+ (reset! (:indent lb)
+ (+ (:offset token)
+ (condp = (:relative-to token)
+ :block @(:start-col lb)
+ :current (get-column (getf :base)))))))
+
+(defmethod write-token :buffer-blob [this token]
+ (-write (getf :base) (:data token)))
+
+(defmethod write-token :nl-t [this token]
+ (if (or (= (:type token) :mandatory)
+ (and (not (= (:type token) :fill))
+ @(:done-nl (:logical-block token))))
+ (emit-nl this token)
+ (if-let [tws (getf :trailing-white-space)]
+ (-write (getf :base) tws)))
+ (setf :trailing-white-space nil))
+
+(defn- write-tokens [this tokens force-trailing-whitespace]
+ (doseq [token tokens]
+ (if-not (= (:type-tag token) :nl-t)
+ (if-let [tws (getf :trailing-white-space)]
+ (-write (getf :base) tws)))
+ (write-token this token)
+ (setf :trailing-white-space (:trailing-white-space token))
+ (let [tws (getf :trailing-white-space)]
+ (when (and force-trailing-whitespace tws)
+ (-write (getf :base) tws)
+ (setf :trailing-white-space nil)))))
+
+;;======================================================================
+;; emit-nl? method defs for each type of new line. This makes
+;; the decision about whether to print this type of new line.
+;;======================================================================
+
+(defn- tokens-fit? [this tokens]
+ (let [maxcol (get-max-column (getf :base))]
+ (or
+ (nil? maxcol)
+ (< (+ (get-column (getf :base)) (buffer-length tokens)) maxcol))))
+
+(defn- linear-nl? [this lb section]
+ (or @(:done-nl lb)
+ (not (tokens-fit? this section))))
+
+(defn- miser-nl? [this lb section]
+ (let [miser-width (get-miser-width this)
+ maxcol (get-max-column (getf :base))]
+ (and miser-width maxcol
+ (>= @(:start-col lb) (- maxcol miser-width))
+ (linear-nl? this lb section))))
+
+(defmulti ^{:private true} emit-nl? (fn [t _ _ _] (:type t)))
+
+(defmethod emit-nl? :linear [newl this section _]
+ (let [lb (:logical-block newl)]
+ (linear-nl? this lb section)))
+
+(defmethod emit-nl? :miser [newl this section _]
+ (let [lb (:logical-block newl)]
+ (miser-nl? this lb section)))
+
+(defmethod emit-nl? :fill [newl this section subsection]
+ (let [lb (:logical-block newl)]
+ (or @(:intra-block-nl lb)
+ (not (tokens-fit? this subsection))
+ (miser-nl? this lb section))))
+
+(defmethod emit-nl? :mandatory [_ _ _ _]
+ true)
+
+;;======================================================================
+;; Various support functions
+;;======================================================================
+
+(defn- get-section [buffer]
+ (let [nl (first buffer)
+ lb (:logical-block nl)
+ section (seq (take-while #(not (and (nl-t? %) (ancestor? (:logical-block %) lb)))
+ (next buffer)))]
+ [section (seq (drop (inc (count section)) buffer))]))
+
+(defn- get-sub-section [buffer]
+ (let [nl (first buffer)
+ lb (:logical-block nl)
+ section (seq (take-while #(let [nl-lb (:logical-block %)]
+ (not (and (nl-t? %) (or (= nl-lb lb) (ancestor? nl-lb lb)))))
+ (next buffer)))]
+ section))
+
+(defn- update-nl-state [lb]
+ (reset! (:intra-block-nl lb) true)
+ (reset! (:done-nl lb) true)
+ (loop [lb (:parent lb)]
+ (if lb
+ (do (reset! (:done-nl lb) true)
+ (reset! (:intra-block-nl lb) true)
+ (recur (:parent lb))))))
+
+(defn- emit-nl [this nl]
+ (-write (getf :base) (pp-newline))
+ (setf :trailing-white-space nil)
+ (let [lb (:logical-block nl)
+ prefix (:per-line-prefix lb)]
+ (if prefix
+ (-write (getf :base) prefix))
+ (let [istr (apply str (repeat (- @(:indent lb) (count prefix)) \space))]
+ (-write (getf :base) istr))
+ (update-nl-state lb)))
+
+(defn- split-at-newline [tokens]
+ (let [pre (seq (take-while #(not (nl-t? %)) tokens))]
+ [pre (seq (drop (count pre) tokens))]))
+
+;; write-token-string is called when the set of tokens in the buffer
+;; is long than the available space on the line
+(defn- write-token-string [this tokens]
+ (let [[a b] (split-at-newline tokens)]
+ (if a (write-tokens this a false))
+ (if b
+ (let [[section remainder] (get-section b)
+ newl (first b)]
+ (let [do-nl (emit-nl? newl this section (get-sub-section b))
+ result (if do-nl
+ (do
+ (emit-nl this newl)
+ (next b))
+ b)
+ long-section (not (tokens-fit? this result))
+ result (if long-section
+ (let [rem2 (write-token-string this section)]
+ (if (= rem2 section)
+ (do ; If that didn't produce any output, it has no nls
+ ; so we'll force it
+ (write-tokens this section false)
+ remainder)
+ (into [] (concat rem2 remainder))))
+ result)]
+ result)))))
+
+(defn- write-line [this]
+ (loop [buffer (getf :buffer)]
+ (setf :buffer (into [] buffer))
+ (if (not (tokens-fit? this buffer))
+ (let [new-buffer (write-token-string this buffer)]
+ (if-not (identical? buffer new-buffer)
+ (recur new-buffer))))))
+
+;; Add a buffer token to the buffer and see if it's time to start
+;; writing
+(defn- add-to-buffer [this token]
+ (setf :buffer (conj (getf :buffer) token))
+ (if (not (tokens-fit? this (getf :buffer)))
+ (write-line this)))
+
+;; Write all the tokens that have been buffered
+(defn- write-buffered-output [this]
+ (write-line this)
+ (if-let [buf (getf :buffer)]
+ (do
+ (write-tokens this buf true)
+ (setf :buffer []))))
+
+(defn- write-white-space [this]
+ (when-let [tws (getf :trailing-white-space)]
+ (-write (getf :base) tws)
+ (setf :trailing-white-space nil)))
+
+;;; If there are newlines in the string, print the lines up until the last newline,
+;;; making the appropriate adjustments. Return the remainder of the string
+(defn- write-initial-lines
+ [^Writer this ^String s]
+ (let [lines (string/split s "\n" -1)]
+ (if (= (count lines) 1)
+ s
+ (let [^String prefix (:per-line-prefix (first (getf :logical-blocks)))
+ ^String l (first lines)]
+ (if (= :buffering (getf :mode))
+ (let [oldpos (getf :pos)
+ newpos (+ oldpos (count l))]
+ (setf :pos newpos)
+ (add-to-buffer this (make-buffer-blob l nil oldpos newpos))
+ (write-buffered-output this))
+ (do
+ (write-white-space this)
+ (-write (getf :base) l)))
+ (-write (getf :base) \newline)
+ (doseq [^String l (next (butlast lines))]
+ (-write (getf :base) l)
+ (-write (getf :base) (pp-newline))
+ (if prefix
+ (-write (getf :base) prefix)))
+ (setf :buffering :writing)
+ (last lines)))))
+
+(defn- p-write-char [this c]
+ (if (= (getf :mode) :writing)
+ (do
+ (write-white-space this)
+ (-write (getf :base) c))
+ (if (= c \newline)
+ (write-initial-lines this \newline)
+ (let [oldpos (getf :pos)
+ newpos (inc oldpos)]
+ (setf :pos newpos)
+ (add-to-buffer this (make-buffer-blob (char c) nil oldpos newpos))))))
+
+;;======================================================================
+;; Initialize the pretty-writer instance
+;;======================================================================
+
+(defn- pretty-writer [writer max-columns miser-width]
+ (let [lb (logical-block. nil nil (atom 0) (atom 0) (atom false) (atom false)
+ nil nil nil nil)
+ ; NOTE: may want to just `specify!` #js { ... fields ... } with the protocols
+ fields (atom {:pretty-writer true
+ :base (column-writer writer max-columns)
+ :logical-blocks lb
+ :sections nil
+ :mode :writing
+ :buffer []
+ :buffer-block lb
+ :buffer-level 1
+ :miser-width miser-width
+ :trailing-white-space nil
+ :pos 0})]
+ (reify
+
+ IDeref
+ (-deref [_] fields)
+
+ IWriter
+ (-write [this x]
+ (condp = (type x)
+ js/String
+ (let [s0 (write-initial-lines this x)
+ s (string/replace-first s0 #"\s+$" "")
+ white-space (subs s0 (count s))
+ mode (getf :mode)]
+ (if (= mode :writing)
+ (do
+ (write-white-space this)
+ (-write (getf :base) s)
+ (setf :trailing-white-space white-space))
+ (let [oldpos (getf :pos)
+ newpos (+ oldpos (count s0))]
+ (setf :pos newpos)
+ (add-to-buffer this (make-buffer-blob s white-space oldpos newpos)))))
+ js/Number
+ (p-write-char this x)))
+ (-flush [this]
+ (-ppflush this)
+ (-flush (getf :base)))
+
+ IPrettyFlush
+ (-ppflush [this]
+ (if (= (getf :mode) :buffering)
+ (do
+ (write-tokens this (getf :buffer) true)
+ (setf :buffer []))
+ (write-white-space this)))
+
+ )))
+
+;;======================================================================
+;; Methods for pretty-writer
+;;======================================================================
+
+(defn- start-block
+ [this prefix per-line-prefix suffix]
+ (let [lb (logical-block. (getf :logical-blocks) nil (atom 0) (atom 0)
+ (atom false) (atom false)
+ prefix per-line-prefix suffix nil)]
+ (setf :logical-blocks lb)
+ (if (= (getf :mode) :writing)
+ (do
+ (write-white-space this)
+ (when-let [cb (getf :logical-block-callback)] (cb :start))
+ (if prefix
+ (-write (getf :base) prefix))
+ (let [col (get-column (getf :base))]
+ (reset! (:start-col lb) col)
+ (reset! (:indent lb) col)))
+ (let [oldpos (getf :pos)
+ newpos (+ oldpos (if prefix (count prefix) 0))]
+ (setf :pos newpos)
+ (add-to-buffer this (make-start-block-t lb oldpos newpos))))))
+
+(defn- end-block [this]
+ (let [lb (getf :logical-blocks)
+ suffix (:suffix lb)]
+ (if (= (getf :mode) :writing)
+ (do
+ (write-white-space this)
+ (if suffix
+ (-write (getf :base) suffix))
+ (when-let [cb (getf :logical-block-callback)] (cb :end)))
+ (let [oldpos (getf :pos)
+ newpos (+ oldpos (if suffix (count suffix) 0))]
+ (setf :pos newpos)
+ (add-to-buffer this (make-end-block-t lb oldpos newpos))))
+ (setf :logical-blocks (:parent lb))))
+
+(defn- nl [this type]
+ (setf :mode :buffering)
+ (let [pos (getf :pos)]
+ (add-to-buffer this (make-nl-t type (getf :logical-blocks) pos pos))))
+
+(defn- indent [this relative-to offset]
+ (let [lb (getf :logical-blocks)]
+ (if (= (getf :mode) :writing)
+ (do
+ (write-white-space this)
+ (reset! (:indent lb)
+ (+ offset (condp = relative-to
+ :block @(:start-col lb)
+ :current (get-column (getf :base))))))
+ (let [pos (getf :pos)]
+ (add-to-buffer this (make-indent-t lb relative-to offset pos pos))))))
+
+(defn- get-miser-width [this]
+ (getf :miser-width))
+
+;;======================================================================
+;; pprint_base.clj
+;;======================================================================
+
+;;======================================================================
+;; Variables that control the pretty printer
+;;======================================================================
+
+;; *print-length*, *print-level*, *print-namespace-maps* and *print-dup* are defined in cljs.core
+(def ^:dynamic
+ ^{:doc "Bind to true if you want write to use pretty printing"}
+ *print-pretty* true)
+
+(defonce ^:dynamic
+ ^{:doc "The pretty print dispatch function. Use with-pprint-dispatch or
+set-pprint-dispatch to modify."
+ :added "1.2"}
+ *print-pprint-dispatch* nil)
+
+(def ^:dynamic
+ ^{:doc "Pretty printing will try to avoid anything going beyond this column.
+Set it to nil to have pprint let the line be arbitrarily long. This will ignore all
+non-mandatory newlines.",
+ :added "1.2"}
+ *print-right-margin* 72)
+
+(def ^:dynamic
+ ^{:doc "The column at which to enter miser style. Depending on the dispatch table,
+miser style add newlines in more places to try to keep lines short allowing for further
+levels of nesting.",
+ :added "1.2"}
+ *print-miser-width* 40)
+
+;;; TODO implement output limiting
+(def ^:dynamic
+^{:private true,
+ :doc "Maximum number of lines to print in a pretty print instance (N.B. This is not yet used)"}
+*print-lines* nil)
+
+;;; TODO: implement circle and shared
+(def ^:dynamic
+^{:private true,
+ :doc "Mark circular structures (N.B. This is not yet used)"}
+*print-circle* nil)
+
+;;; TODO: should we just use *print-dup* here?
+(def ^:dynamic
+^{:private true,
+ :doc "Mark repeated structures rather than repeat them (N.B. This is not yet used)"}
+*print-shared* nil)
+
+(def ^:dynamic
+^{:doc "Don't print namespaces with symbols. This is particularly useful when
+pretty printing the results of macro expansions"
+ :added "1.2"}
+*print-suppress-namespaces* nil)
+
+;;; TODO: support print-base and print-radix in cl-format
+;;; TODO: support print-base and print-radix in rationals
+(def ^:dynamic
+^{:doc "Print a radix specifier in front of integers and rationals. If *print-base* is 2, 8,
+or 16, then the radix specifier used is #b, #o, or #x, respectively. Otherwise the
+radix specifier is in the form #XXr where XX is the decimal value of *print-base* "
+ :added "1.2"}
+*print-radix* nil)
+
+(def ^:dynamic
+^{:doc "The base to use for printing integers and rationals."
+ :added "1.2"}
+*print-base* 10)
+
+;;======================================================================
+;; Internal variables that keep track of where we are in the
+;; structure
+;;======================================================================
+
+(def ^:dynamic ^{:private true} *current-level* 0)
+
+(def ^:dynamic ^{:private true} *current-length* nil)
+
+;;======================================================================
+;; Support for the write function
+;;======================================================================
+
+(declare ^{:arglists '([n])} format-simple-number)
+
+;; This map causes var metadata to be included in the compiled output, even
+;; in advanced compilation. See CLJS-1853 - António Monteiro
+;; (def ^{:private true} write-option-table
+;; {;:array *print-array*
+;; :base #'cljs.pprint/*print-base*,
+;; ;;:case *print-case*,
+;; :circle #'cljs.pprint/*print-circle*,
+;; ;;:escape *print-escape*,
+;; ;;:gensym *print-gensym*,
+;; :length #'cljs.core/*print-length*,
+;; :level #'cljs.core/*print-level*,
+;; :lines #'cljs.pprint/*print-lines*,
+;; :miser-width #'cljs.pprint/*print-miser-width*,
+;; :dispatch #'cljs.pprint/*print-pprint-dispatch*,
+;; :pretty #'cljs.pprint/*print-pretty*,
+;; :radix #'cljs.pprint/*print-radix*,
+;; :readably #'cljs.core/*print-readably*,
+;; :right-margin #'cljs.pprint/*print-right-margin*,
+;; :suppress-namespaces #'cljs.pprint/*print-suppress-namespaces*})
+
+(defn- table-ize [t m]
+ (apply hash-map (mapcat
+ #(when-let [v (get t (key %))] [v (val %)])
+ m)))
+
+(defn- pretty-writer?
+ "Return true iff x is a PrettyWriter"
+ [x] (and (satisfies? IDeref x) (:pretty-writer @@x)))
+
+(defn- make-pretty-writer
+ "Wrap base-writer in a PrettyWriter with the specified right-margin and miser-width"
+ [base-writer right-margin miser-width]
+ (pretty-writer base-writer right-margin miser-width))
+
+(defn write-out
+ "Write an object to *out* subject to the current bindings of the printer control
+variables. Use the kw-args argument to override individual variables for this call (and
+any recursive calls).
+
+*out* must be a PrettyWriter if pretty printing is enabled. This is the responsibility
+of the caller.
+
+This method is primarily intended for use by pretty print dispatch functions that
+already know that the pretty printer will have set up their environment appropriately.
+Normal library clients should use the standard \"write\" interface. "
+ [object]
+ (let [length-reached (and *current-length*
+ *print-length*
+ (>= *current-length* *print-length*))]
+ (if-not *print-pretty*
+ (pr object)
+ (if length-reached
+ (-write *out* "...") ;;TODO could this (incorrectly) print ... on the next line?
+ (do
+ (if *current-length* (set! *current-length* (inc *current-length*)))
+ (*print-pprint-dispatch* object))))
+ length-reached))
+
+(defn write
+ "Write an object subject to the current bindings of the printer control variables.
+Use the kw-args argument to override individual variables for this call (and any
+recursive calls). Returns the string result if :stream is nil or nil otherwise.
+
+The following keyword arguments can be passed with values:
+ Keyword Meaning Default value
+ :stream Writer for output or nil true (indicates *out*)
+ :base Base to use for writing rationals Current value of *print-base*
+ :circle* If true, mark circular structures Current value of *print-circle*
+ :length Maximum elements to show in sublists Current value of *print-length*
+ :level Maximum depth Current value of *print-level*
+ :lines* Maximum lines of output Current value of *print-lines*
+ :miser-width Width to enter miser mode Current value of *print-miser-width*
+ :dispatch The pretty print dispatch function Current value of *print-pprint-dispatch*
+ :pretty If true, do pretty printing Current value of *print-pretty*
+ :radix If true, prepend a radix specifier Current value of *print-radix*
+ :readably* If true, print readably Current value of *print-readably*
+ :right-margin The column for the right margin Current value of *print-right-margin*
+ :suppress-namespaces If true, no namespaces in symbols Current value of *print-suppress-namespaces*
+
+ * = not yet supported
+"
+ [object & kw-args]
+ (let [options (merge {:stream true} (apply hash-map kw-args))]
+ ;;TODO rewrite this as a macro
+ (binding [cljs.pprint/*print-base* (:base options cljs.pprint/*print-base*)
+ ;;:case *print-case*,
+ cljs.pprint/*print-circle* (:circle options cljs.pprint/*print-circle*)
+ ;;:escape *print-escape*
+ ;;:gensym *print-gensym*
+ cljs.core/*print-length* (:length options cljs.core/*print-length*)
+ cljs.core/*print-level* (:level options cljs.core/*print-level*)
+ cljs.pprint/*print-lines* (:lines options cljs.pprint/*print-lines*)
+ cljs.pprint/*print-miser-width* (:miser-width options cljs.pprint/*print-miser-width*)
+ cljs.pprint/*print-pprint-dispatch* (:dispatch options cljs.pprint/*print-pprint-dispatch*)
+ cljs.pprint/*print-pretty* (:pretty options cljs.pprint/*print-pretty*)
+ cljs.pprint/*print-radix* (:radix options cljs.pprint/*print-radix*)
+ cljs.core/*print-readably* (:readably options cljs.core/*print-readably*)
+ cljs.pprint/*print-right-margin* (:right-margin options cljs.pprint/*print-right-margin*)
+ cljs.pprint/*print-suppress-namespaces* (:suppress-namespaces options cljs.pprint/*print-suppress-namespaces*)]
+ ;;TODO enable printing base
+ #_[bindings (if (or (not (= *print-base* 10)) *print-radix*)
+ {#'pr pr-with-base}
+ {})]
+ (binding []
+ (let [sb (StringBuffer.)
+ optval (if (contains? options :stream)
+ (:stream options)
+ true)
+ base-writer (if (or (true? optval) (nil? optval))
+ (StringBufferWriter. sb)
+ optval)]
+ (if *print-pretty*
+ (with-pretty-writer base-writer
+ (write-out object))
+ (binding [*out* base-writer]
+ (pr object)))
+ (if (true? optval)
+ (string-print (str sb)))
+ (if (nil? optval)
+ (str sb)))))))
+
+(defn pprint
+ ([object]
+ (let [sb (StringBuffer.)]
+ (binding [*out* (StringBufferWriter. sb)]
+ (pprint object *out*)
+ (string-print (str sb)))))
+ ([object writer]
+ (with-pretty-writer writer
+ (binding [*print-pretty* true]
+ (write-out object))
+ (if (not (= 0 (get-column *out*)))
+ (-write *out* \newline)))))
+
+(defn set-pprint-dispatch
+ [function]
+ (set! *print-pprint-dispatch* function)
+ nil)
+
+;;======================================================================
+;; Support for the functional interface to the pretty printer
+;;======================================================================
+
+(defn- check-enumerated-arg [arg choices]
+ (if-not (choices arg)
+ ;; TODO clean up choices string
+ (throw (js/Error. (str "Bad argument: " arg ". It must be one of " choices)))))
+
+(defn- level-exceeded []
+ (and *print-level* (>= *current-level* *print-level*)))
+
+(defn pprint-newline
+ "Print a conditional newline to a pretty printing stream. kind specifies if the
+ newline is :linear, :miser, :fill, or :mandatory.
+
+ This function is intended for use when writing custom dispatch functions.
+
+ Output is sent to *out* which must be a pretty printing writer."
+ [kind]
+ (check-enumerated-arg kind #{:linear :miser :fill :mandatory})
+ (nl *out* kind))
+
+(defn pprint-indent
+ "Create an indent at this point in the pretty printing stream. This defines how
+following lines are indented. relative-to can be either :block or :current depending
+whether the indent should be computed relative to the start of the logical block or
+the current column position. n is an offset.
+
+This function is intended for use when writing custom dispatch functions.
+
+Output is sent to *out* which must be a pretty printing writer."
+ [relative-to n]
+ (check-enumerated-arg relative-to #{:block :current})
+ (indent *out* relative-to n))
+
+;; TODO a real implementation for pprint-tab
+(defn pprint-tab
+ "Tab at this point in the pretty printing stream. kind specifies whether the tab
+is :line, :section, :line-relative, or :section-relative.
+
+Colnum and colinc specify the target column and the increment to move the target
+forward if the output is already past the original target.
+
+This function is intended for use when writing custom dispatch functions.
+
+Output is sent to *out* which must be a pretty printing writer.
+
+THIS FUNCTION IS NOT YET IMPLEMENTED."
+ {:added "1.2"}
+ [kind colnum colinc]
+ (check-enumerated-arg kind #{:line :section :line-relative :section-relative})
+ (throw (js/Error. "pprint-tab is not yet implemented")))
+
+;;======================================================================
+;; cl_format.clj
+;;======================================================================
+
+;; Forward references
+(declare ^{:arglists '([format-str])} compile-format)
+(declare ^{:arglists '([stream format args] [format args])} execute-format)
+(declare ^{:arglists '([s])} init-navigator)
+;; End forward references
+
+(defn cl-format
+ "An implementation of a Common Lisp compatible format function. cl-format formats its
+arguments to an output stream or string based on the format control string given. It
+supports sophisticated formatting of structured data.
+
+Writer satisfies IWriter, true to output via *print-fn* or nil to output
+to a string, format-in is the format control string and the remaining arguments
+are the data to be formatted.
+
+The format control string is a string to be output with embedded 'format directives'
+describing how to format the various arguments passed in.
+
+If writer is nil, cl-format returns the formatted result string. Otherwise, cl-format
+returns nil.
+
+For example:
+ (let [results [46 38 22]]
+ (cl-format true \"There ~[are~;is~:;are~]~:* ~d result~:p: ~{~d~^, ~}~%\"
+ (count results) results))
+
+Prints via *print-fn*:
+ There are 3 results: 46, 38, 22
+
+Detailed documentation on format control strings is available in the \"Common Lisp the
+Language, 2nd edition\", Chapter 22 (available online at:
+http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000)
+and in the Common Lisp HyperSpec at
+http://www.lispworks.com/documentation/HyperSpec/Body/22_c.htm"
+ {:see-also [["http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000"
+ "Common Lisp the Language"]
+ ["http://www.lispworks.com/documentation/HyperSpec/Body/22_c.htm"
+ "Common Lisp HyperSpec"]]}
+ [writer format-in & args]
+ (let [compiled-format (if (string? format-in) (compile-format format-in) format-in)
+ navigator (init-navigator args)]
+ (execute-format writer compiled-format navigator)))
+
+(def ^:dynamic ^{:private true} *format-str* nil)
+
+(defn- format-error [message offset]
+ (let [full-message (str message \newline *format-str* \newline
+ (apply str (repeat offset \space)) "^" \newline)]
+ (throw (js/Error full-message))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Argument navigators manage the argument list
+;; as the format statement moves through the list
+;; (possibly going forwards and backwards as it does so)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defrecord ^{:private true}
+ arg-navigator [seq rest pos])
+
+(defn- init-navigator
+ "Create a new arg-navigator from the sequence with the position set to 0"
+ {:skip-wiki true}
+ [s]
+ (let [s (seq s)]
+ (arg-navigator. s s 0)))
+
+;; TODO call format-error with offset
+(defn- next-arg [navigator]
+ (let [rst (:rest navigator)]
+ (if rst
+ [(first rst) (arg-navigator. (:seq navigator) (next rst) (inc (:pos navigator)))]
+ (throw (js/Error "Not enough arguments for format definition")))))
+
+(defn- next-arg-or-nil [navigator]
+ (let [rst (:rest navigator)]
+ (if rst
+ [(first rst) (arg-navigator. (:seq navigator) (next rst) (inc (:pos navigator)))]
+ [nil navigator])))
+
+;; Get an argument off the arg list and compile it if it's not already compiled
+(defn- get-format-arg [navigator]
+ (let [[raw-format navigator] (next-arg navigator)
+ compiled-format (if (string? raw-format)
+ (compile-format raw-format)
+ raw-format)]
+ [compiled-format navigator]))
+
+(declare relative-reposition)
+
+(defn- absolute-reposition [navigator position]
+ (if (>= position (:pos navigator))
+ (relative-reposition navigator (- (:pos navigator) position))
+ (arg-navigator. (:seq navigator) (drop position (:seq navigator)) position)))
+
+(defn- relative-reposition [navigator position]
+ (let [newpos (+ (:pos navigator) position)]
+ (if (neg? position)
+ (absolute-reposition navigator newpos)
+ (arg-navigator. (:seq navigator) (drop position (:rest navigator)) newpos))))
+
+(defrecord ^{:private true}
+ compiled-directive [func def params offset])
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; When looking at the parameter list, we may need to manipulate
+;; the argument list as well (for 'V' and '#' parameter types).
+;; We hide all of this behind a function, but clients need to
+;; manage changing arg navigator
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; TODO: validate parameters when they come from arg list
+(defn- realize-parameter [[param [raw-val offset]] navigator]
+ (let [[real-param new-navigator]
+ (cond
+ (contains? #{:at :colon} param) ;pass flags through unchanged - this really isn't necessary
+ [raw-val navigator]
+
+ (= raw-val :parameter-from-args)
+ (next-arg navigator)
+
+ (= raw-val :remaining-arg-count)
+ [(count (:rest navigator)) navigator]
+
+ true
+ [raw-val navigator])]
+ [[param [real-param offset]] new-navigator]))
+
+(defn- realize-parameter-list [parameter-map navigator]
+ (let [[pairs new-navigator]
+ (map-passing-context realize-parameter navigator parameter-map)]
+ [(into {} pairs) new-navigator]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Functions that support individual directives
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Common handling code for ~A and ~S
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declare ^{:arglists '([base val])} opt-base-str)
+
+(def ^{:private true}
+ special-radix-markers {2 "#b" 8 "#o" 16 "#x"})
+
+(defn- format-simple-number [n]
+ (cond
+ (integer? n) (if (= *print-base* 10)
+ (str n (if *print-radix* "."))
+ (str
+ (if *print-radix* (or (get special-radix-markers *print-base*) (str "#" *print-base* "r")))
+ (opt-base-str *print-base* n)))
+ ;;(ratio? n) ;;no ratio support
+ :else nil))
+
+(defn- format-ascii [print-func params arg-navigator offsets]
+ (let [[arg arg-navigator] (next-arg arg-navigator)
+ base-output (or (format-simple-number arg) (print-func arg))
+ base-width (.-length base-output)
+ min-width (+ base-width (:minpad params))
+ width (if (>= min-width (:mincol params))
+ min-width
+ (+ min-width
+ (* (+ (quot (- (:mincol params) min-width 1)
+ (:colinc params))
+ 1)
+ (:colinc params))))
+ chars (apply str (repeat (- width base-width) (:padchar params)))]
+ (if (:at params)
+ (print (str chars base-output))
+ (print (str base-output chars)))
+ arg-navigator))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Support for the integer directives ~D, ~X, ~O, ~B and some
+;; of ~R
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- integral?
+ "returns true if a number is actually an integer (that is, has no fractional part)"
+ [x]
+ (cond
+ (integer? x) true
+ ;;(decimal? x) ;;no decimal support
+ (float? x) (= x (Math/floor x))
+ ;;(ratio? x) ;;no ratio support
+ :else false))
+
+(defn- remainders
+ "Return the list of remainders (essentially the 'digits') of val in the given base"
+ [base val]
+ (reverse
+ (first
+ (consume #(if (pos? %)
+ [(rem % base) (quot % base)]
+ [nil nil])
+ val))))
+
+;; TODO: xlated-val does not seem to be used here.
+;; NB
+(defn- base-str
+ "Return val as a string in the given base"
+ [base val]
+ (if (zero? val)
+ "0"
+ (let [xlated-val (cond
+ ;(float? val) (bigdec val) ;;No bigdec
+ ;(ratio? val) nil ;;No ratio
+ :else val)]
+ (apply str
+ (map
+ #(if (< % 10) (char (+ (char-code \0) %)) (char (+ (char-code \a) (- % 10))))
+ (remainders base val))))))
+
+;;Not sure if this is accurate or necessary
+(def ^{:private true}
+ javascript-base-formats {8 "%o", 10 "%d", 16 "%x"})
+
+(defn- opt-base-str
+ "Return val as a string in the given base. No cljs format, so no improved performance."
+ [base val]
+ (base-str base val))
+
+(defn- group-by* [unit lis]
+ (reverse
+ (first
+ (consume (fn [x] [(seq (reverse (take unit x))) (seq (drop unit x))]) (reverse lis)))))
+
+(defn- format-integer [base params arg-navigator offsets]
+ (let [[arg arg-navigator] (next-arg arg-navigator)]
+ (if (integral? arg)
+ (let [neg (neg? arg)
+ pos-arg (if neg (- arg) arg)
+ raw-str (opt-base-str base pos-arg)
+ group-str (if (:colon params)
+ (let [groups (map #(apply str %) (group-by* (:commainterval params) raw-str))
+ commas (repeat (count groups) (:commachar params))]
+ (apply str (next (interleave commas groups))))
+ raw-str)
+ signed-str (cond
+ neg (str "-" group-str)
+ (:at params) (str "+" group-str)
+ true group-str)
+ padded-str (if (< (.-length signed-str) (:mincol params))
+ (str (apply str (repeat (- (:mincol params) (.-length signed-str))
+ (:padchar params)))
+ signed-str)
+ signed-str)]
+ (print padded-str))
+ (format-ascii print-str {:mincol (:mincol params) :colinc 1 :minpad 0
+ :padchar (:padchar params) :at true}
+ (init-navigator [arg]) nil))
+ arg-navigator))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Support for english formats (~R and ~:R)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def ^{:private true}
+ english-cardinal-units
+ ["zero" "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"
+ "ten" "eleven" "twelve" "thirteen" "fourteen"
+ "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"])
+
+(def ^{:private true}
+ english-ordinal-units
+ ["zeroth" "first" "second" "third" "fourth" "fifth" "sixth" "seventh" "eighth" "ninth"
+ "tenth" "eleventh" "twelfth" "thirteenth" "fourteenth"
+ "fifteenth" "sixteenth" "seventeenth" "eighteenth" "nineteenth"])
+
+(def ^{:private true}
+ english-cardinal-tens
+ ["" "" "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety"])
+
+(def ^{:private true}
+ english-ordinal-tens
+ ["" "" "twentieth" "thirtieth" "fortieth" "fiftieth"
+ "sixtieth" "seventieth" "eightieth" "ninetieth"])
+
+;; We use "short scale" for our units (see http://en.wikipedia.org/wiki/Long_and_short_scales)
+;; Number names from http://www.jimloy.com/math/billion.htm
+;; We follow the rules for writing numbers from the Blue Book
+;; (http://www.grammarbook.com/numbers/numbers.asp)
+(def ^{:private true}
+ english-scale-numbers
+ ["" "thousand" "million" "billion" "trillion" "quadrillion" "quintillion"
+ "sextillion" "septillion" "octillion" "nonillion" "decillion"
+ "undecillion" "duodecillion" "tredecillion" "quattuordecillion"
+ "quindecillion" "sexdecillion" "septendecillion"
+ "octodecillion" "novemdecillion" "vigintillion"])
+
+(defn- format-simple-cardinal
+ "Convert a number less than 1000 to a cardinal english string"
+ [num]
+ (let [hundreds (quot num 100)
+ tens (rem num 100)]
+ (str
+ (if (pos? hundreds) (str (nth english-cardinal-units hundreds) " hundred"))
+ (if (and (pos? hundreds) (pos? tens)) " ")
+ (if (pos? tens)
+ (if (< tens 20)
+ (nth english-cardinal-units tens)
+ (let [ten-digit (quot tens 10)
+ unit-digit (rem tens 10)]
+ (str
+ (if (pos? ten-digit) (nth english-cardinal-tens ten-digit))
+ (if (and (pos? ten-digit) (pos? unit-digit)) "-")
+ (if (pos? unit-digit) (nth english-cardinal-units unit-digit)))))))))
+
+(defn- add-english-scales
+ "Take a sequence of parts, add scale numbers (e.g., million) and combine into a string
+ offset is a factor of 10^3 to multiply by"
+ [parts offset]
+ (let [cnt (count parts)]
+ (loop [acc []
+ pos (dec cnt)
+ this (first parts)
+ remainder (next parts)]
+ (if (nil? remainder)
+ (str (apply str (interpose ", " acc))
+ (if (and (not (empty? this)) (not (empty? acc))) ", ")
+ this
+ (if (and (not (empty? this)) (pos? (+ pos offset)))
+ (str " " (nth english-scale-numbers (+ pos offset)))))
+ (recur
+ (if (empty? this)
+ acc
+ (conj acc (str this " " (nth english-scale-numbers (+ pos offset)))))
+ (dec pos)
+ (first remainder)
+ (next remainder))))))
+
+(defn- format-cardinal-english [params navigator offsets]
+ (let [[arg navigator] (next-arg navigator)]
+ (if (= 0 arg)
+ (print "zero")
+ (let [abs-arg (if (neg? arg) (- arg) arg) ; some numbers are too big for Math/abs (is this true?)
+ parts (remainders 1000 abs-arg)]
+ (if (<= (count parts) (count english-scale-numbers))
+ (let [parts-strs (map format-simple-cardinal parts)
+ full-str (add-english-scales parts-strs 0)]
+ (print (str (if (neg? arg) "minus ") full-str)))
+ (format-integer ;; for numbers > 10^63, we fall back on ~D
+ 10
+ {:mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true}
+ (init-navigator [arg])
+ {:mincol 0, :padchar 0, :commachar 0 :commainterval 0}))))
+ navigator))
+
+(defn- format-simple-ordinal
+ "Convert a number less than 1000 to a ordinal english string
+ Note this should only be used for the last one in the sequence"
+ [num]
+ (let [hundreds (quot num 100)
+ tens (rem num 100)]
+ (str
+ (if (pos? hundreds) (str (nth english-cardinal-units hundreds) " hundred"))
+ (if (and (pos? hundreds) (pos? tens)) " ")
+ (if (pos? tens)
+ (if (< tens 20)
+ (nth english-ordinal-units tens)
+ (let [ten-digit (quot tens 10)
+ unit-digit (rem tens 10)]
+ (if (and (pos? ten-digit) (not (pos? unit-digit)))
+ (nth english-ordinal-tens ten-digit)
+ (str
+ (if (pos? ten-digit) (nth english-cardinal-tens ten-digit))
+ (if (and (pos? ten-digit) (pos? unit-digit)) "-")
+ (if (pos? unit-digit) (nth english-ordinal-units unit-digit))))))
+ (if (pos? hundreds) "th")))))
+
+(defn- format-ordinal-english [params navigator offsets]
+ (let [[arg navigator] (next-arg navigator)]
+ (if (= 0 arg)
+ (print "zeroth")
+ (let [abs-arg (if (neg? arg) (- arg) arg) ; some numbers are too big for Math/abs (is this true?)
+ parts (remainders 1000 abs-arg)]
+ (if (<= (count parts) (count english-scale-numbers))
+ (let [parts-strs (map format-simple-cardinal (drop-last parts))
+ head-str (add-english-scales parts-strs 1)
+ tail-str (format-simple-ordinal (last parts))]
+ (print (str (if (neg? arg) "minus ")
+ (cond
+ (and (not (empty? head-str)) (not (empty? tail-str)))
+ (str head-str ", " tail-str)
+
+ (not (empty? head-str)) (str head-str "th")
+ :else tail-str))))
+ (do (format-integer ;for numbers > 10^63, we fall back on ~D
+ 10
+ {:mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true}
+ (init-navigator [arg])
+ {:mincol 0, :padchar 0, :commachar 0 :commainterval 0})
+ (let [low-two-digits (rem arg 100)
+ not-teens (or (< 11 low-two-digits) (> 19 low-two-digits))
+ low-digit (rem low-two-digits 10)]
+ (print (cond
+ (and (== low-digit 1) not-teens) "st"
+ (and (== low-digit 2) not-teens) "nd"
+ (and (== low-digit 3) not-teens) "rd"
+ :else "th")))))))
+ navigator))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Support for roman numeral formats (~@R and ~@:R)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def ^{:private true}
+ old-roman-table
+ [[ "I" "II" "III" "IIII" "V" "VI" "VII" "VIII" "VIIII"]
+ [ "X" "XX" "XXX" "XXXX" "L" "LX" "LXX" "LXXX" "LXXXX"]
+ [ "C" "CC" "CCC" "CCCC" "D" "DC" "DCC" "DCCC" "DCCCC"]
+ [ "M" "MM" "MMM"]])
+
+(def ^{:private true}
+ new-roman-table
+ [[ "I" "II" "III" "IV" "V" "VI" "VII" "VIII" "IX"]
+ [ "X" "XX" "XXX" "XL" "L" "LX" "LXX" "LXXX" "XC"]
+ [ "C" "CC" "CCC" "CD" "D" "DC" "DCC" "DCCC" "CM"]
+ [ "M" "MM" "MMM"]])
+
+(defn- format-roman
+ "Format a roman numeral using the specified look-up table"
+ [table params navigator offsets]
+ (let [[arg navigator] (next-arg navigator)]
+ (if (and (number? arg) (> arg 0) (< arg 4000))
+ (let [digits (remainders 10 arg)]
+ (loop [acc []
+ pos (dec (count digits))
+ digits digits]
+ (if (empty? digits)
+ (print (apply str acc))
+ (let [digit (first digits)]
+ (recur (if (= 0 digit)
+ acc
+ (conj acc (nth (nth table pos) (dec digit))))
+ (dec pos)
+ (next digits))))))
+ (format-integer ; for anything <= 0 or > 3999, we fall back on ~D
+ 10
+ {:mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true}
+ (init-navigator [arg])
+ {:mincol 0, :padchar 0, :commachar 0 :commainterval 0}))
+ navigator))
+
+(defn- format-old-roman [params navigator offsets]
+ (format-roman old-roman-table params navigator offsets))
+
+(defn- format-new-roman [params navigator offsets]
+ (format-roman new-roman-table params navigator offsets))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Support for character formats (~C)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def ^{:private true}
+ special-chars {8 "Backspace", 9 "Tab", 10 "Newline", 13 "Return", 32 "Space"})
+
+(defn- pretty-character [params navigator offsets]
+ (let [[c navigator] (next-arg navigator)
+ as-int (char-code c)
+ base-char (bit-and as-int 127)
+ meta (bit-and as-int 128)
+ special (get special-chars base-char)]
+ (if (> meta 0) (print "Meta-"))
+ (print (cond
+ special special
+ (< base-char 32) (str "Control-" (char (+ base-char 64)))
+ (= base-char 127) "Control-?"
+ :else (char base-char)))
+ navigator))
+
+(defn- readable-character [params navigator offsets]
+ (let [[c navigator] (next-arg navigator)]
+ (condp = (:char-format params)
+ \o (cl-format true "\\o~3,'0o" (char-code c))
+ \u (cl-format true "\\u~4,'0x" (char-code c))
+ nil (print-char c))
+ navigator))
+
+(defn- plain-character [params navigator offsets]
+ (let [[char navigator] (next-arg navigator)]
+ (print char)
+ navigator))
+
+;; Check to see if a result is an abort (~^) construct
+;; TODO: move these funcs somewhere more appropriate
+(defn- abort? [context]
+ (let [token (first context)]
+ (or (= :up-arrow token) (= :colon-up-arrow token))))
+
+;; Handle the execution of "sub-clauses" in bracket constructions
+(defn- execute-sub-format [format args base-args]
+ (second
+ (map-passing-context
+ (fn [element context]
+ (if (abort? context)
+ [nil context] ; just keep passing it along
+ (let [[params args] (realize-parameter-list (:params element) context)
+ [params offsets] (unzip-map params)
+ params (assoc params :base-args base-args)]
+ [nil (apply (:func element) [params args offsets])])))
+ args
+ format)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Support for real number formats
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; TODO - return exponent as int to eliminate double conversion
+(defn- float-parts-base
+ "Produce string parts for the mantissa (normalize 1-9) and exponent"
+ [f]
+ (let [s (string/lower-case (str f))
+ exploc (.indexOf s \e)
+ dotloc (.indexOf s \.)]
+ (if (neg? exploc)
+ (if (neg? dotloc)
+ [s (str (dec (count s)))]
+ [(str (subs s 0 dotloc) (subs s (inc dotloc))) (str (dec dotloc))])
+ (if (neg? dotloc)
+ [(subs s 0 exploc) (subs s (inc exploc))]
+ [(str (subs s 0 1) (subs s 2 exploc)) (subs s (inc exploc))]))))
+
+(defn- float-parts
+ "Take care of leading and trailing zeros in decomposed floats"
+ [f]
+ (let [[m e] (float-parts-base f)
+ m1 (rtrim m \0)
+ m2 (ltrim m1 \0)
+ delta (- (count m1) (count m2))
+ e (if (and (pos? (count e)) (= (nth e 0) \+)) (subs e 1) e)]
+ (if (empty? m2)
+ ["0" 0]
+ [m2 (- (js/parseInt e 10) delta)])))
+
+(defn- inc-s
+ "Assumption: The input string consists of one or more decimal digits,
+ and no other characters. Return a string containing one or more
+ decimal digits containing a decimal number one larger than the input
+ string. The output string will always be the same length as the input
+ string, or one character longer."
+ [s]
+ (let [len-1 (dec (count s))]
+ (loop [i (int len-1)]
+ (cond
+ (neg? i) (apply str "1" (repeat (inc len-1) "0"))
+ (= \9 (.charAt s i)) (recur (dec i))
+ :else (apply str (subs s 0 i)
+ (char (inc (char-code (.charAt s i))))
+ (repeat (- len-1 i) "0"))))))
+
+(defn- round-str [m e d w]
+ (if (or d w)
+ (let [len (count m)
+ ;; Every formatted floating point number should include at
+ ;; least one decimal digit and a decimal point.
+ w (if w (max 2 w)
+ ;;NB: if w doesn't exist, it won't ever be used because d will
+ ;; satisfy the cond below. cljs gives a compilation warning if
+ ;; we don't provide a value here.
+ 0)
+ round-pos (cond
+ ;; If d was given, that forces the rounding
+ ;; position, regardless of any width that may
+ ;; have been specified.
+ d (+ e d 1)
+ ;; Otherwise w was specified, so pick round-pos
+ ;; based upon that.
+ ;; If e>=0, then abs value of number is >= 1.0,
+ ;; and e+1 is number of decimal digits before the
+ ;; decimal point when the number is written
+ ;; without scientific notation. Never round the
+ ;; number before the decimal point.
+ (>= e 0) (max (inc e) (dec w))
+ ;; e < 0, so number abs value < 1.0
+ :else (+ w e))
+ [m1 e1 round-pos len] (if (= round-pos 0)
+ [(str "0" m) (inc e) 1 (inc len)]
+ [m e round-pos len])]
+ (if round-pos
+ (if (neg? round-pos)
+ ["0" 0 false]
+ (if (> len round-pos)
+ (let [round-char (nth m1 round-pos)
+ result (subs m1 0 round-pos)]
+ (if (>= (char-code round-char) (char-code \5))
+ (let [round-up-result (inc-s result)
+ expanded (> (count round-up-result) (count result))]
+ [(if expanded
+ (subs round-up-result 0 (dec (count round-up-result)))
+ round-up-result)
+ e1 expanded])
+ [result e1 false]))
+ [m e false]))
+ [m e false]))
+ [m e false]))
+
+(defn- expand-fixed [m e d]
+ (let [[m1 e1] (if (neg? e)
+ [(str (apply str (repeat (dec (- e)) \0)) m) -1]
+ [m e])
+ len (count m1)
+ target-len (if d (+ e1 d 1) (inc e1))]
+ (if (< len target-len)
+ (str m1 (apply str (repeat (- target-len len) \0)))
+ m1)))
+
+(defn- insert-decimal
+ "Insert the decimal point at the right spot in the number to match an exponent"
+ [m e]
+ (if (neg? e)
+ (str "." m)
+ (let [loc (inc e)]
+ (str (subs m 0 loc) "." (subs m loc)))))
+
+(defn- get-fixed [m e d]
+ (insert-decimal (expand-fixed m e d) e))
+
+(defn- insert-scaled-decimal
+ "Insert the decimal point at the right spot in the number to match an exponent"
+ [m k]
+ (if (neg? k)
+ (str "." m)
+ (str (subs m 0 k) "." (subs m k))))
+
+;;TODO: No ratio, so not sure what to do here
+(defn- convert-ratio [x]
+ x)
+
+;; the function to render ~F directives
+;; TODO: support rationals. Back off to ~D/~A in the appropriate cases
+(defn- fixed-float [params navigator offsets]
+ (let [w (:w params)
+ d (:d params)
+ [arg navigator] (next-arg navigator)
+ [sign abs] (if (neg? arg) ["-" (- arg)] ["+" arg])
+ abs (convert-ratio abs)
+ [mantissa exp] (float-parts abs)
+ scaled-exp (+ exp (:k params))
+ add-sign (or (:at params) (neg? arg))
+ append-zero (and (not d) (<= (dec (count mantissa)) scaled-exp))
+ [rounded-mantissa scaled-exp expanded] (round-str mantissa scaled-exp
+ d (if w (- w (if add-sign 1 0))))
+ fixed-repr (get-fixed rounded-mantissa (if expanded (inc scaled-exp) scaled-exp) d)
+ fixed-repr (if (and w d
+ (>= d 1)
+ (= (.charAt fixed-repr 0) \0)
+ (= (.charAt fixed-repr 1) \.)
+ (> (count fixed-repr) (- w (if add-sign 1 0))))
+ (subs fixed-repr 1) ;chop off leading 0
+ fixed-repr)
+ prepend-zero (= (first fixed-repr) \.)]
+ (if w
+ (let [len (count fixed-repr)
+ signed-len (if add-sign (inc len) len)
+ prepend-zero (and prepend-zero (not (>= signed-len w)))
+ append-zero (and append-zero (not (>= signed-len w)))
+ full-len (if (or prepend-zero append-zero)
+ (inc signed-len)
+ signed-len)]
+ (if (and (> full-len w) (:overflowchar params))
+ (print (apply str (repeat w (:overflowchar params))))
+ (print (str
+ (apply str (repeat (- w full-len) (:padchar params)))
+ (if add-sign sign)
+ (if prepend-zero "0")
+ fixed-repr
+ (if append-zero "0")))))
+ (print (str
+ (if add-sign sign)
+ (if prepend-zero "0")
+ fixed-repr
+ (if append-zero "0"))))
+ navigator))
+
+;; the function to render ~E directives
+;; TODO: support rationals. Back off to ~D/~A in the appropriate cases
+;; TODO: define ~E representation for Infinity
+(defn- exponential-float [params navigator offset]
+ (let [[arg navigator] (next-arg navigator)
+ arg (convert-ratio arg)]
+ (loop [[mantissa exp] (float-parts (if (neg? arg) (- arg) arg))]
+ (let [w (:w params)
+ d (:d params)
+ e (:e params)
+ k (:k params)
+ expchar (or (:exponentchar params) \E)
+ add-sign (or (:at params) (neg? arg))
+ prepend-zero (<= k 0)
+ scaled-exp (- exp (dec k))
+ scaled-exp-str (str (Math/abs scaled-exp))
+ scaled-exp-str (str expchar (if (neg? scaled-exp) \- \+)
+ (if e (apply str
+ (repeat
+ (- e
+ (count scaled-exp-str))
+ \0)))
+ scaled-exp-str)
+ exp-width (count scaled-exp-str)
+ base-mantissa-width (count mantissa)
+ scaled-mantissa (str (apply str (repeat (- k) \0))
+ mantissa
+ (if d
+ (apply str
+ (repeat
+ (- d (dec base-mantissa-width)
+ (if (neg? k) (- k) 0)) \0))))
+ w-mantissa (if w (- w exp-width))
+ [rounded-mantissa _ incr-exp] (round-str
+ scaled-mantissa 0
+ (cond
+ (= k 0) (dec d)
+ (pos? k) d
+ (neg? k) (dec d))
+ (if w-mantissa
+ (- w-mantissa (if add-sign 1 0))))
+ full-mantissa (insert-scaled-decimal rounded-mantissa k)
+ append-zero (and (= k (count rounded-mantissa)) (nil? d))]
+ (if (not incr-exp)
+ (if w
+ (let [len (+ (count full-mantissa) exp-width)
+ signed-len (if add-sign (inc len) len)
+ prepend-zero (and prepend-zero (not (= signed-len w)))
+ full-len (if prepend-zero (inc signed-len) signed-len)
+ append-zero (and append-zero (< full-len w))]
+ (if (and (or (> full-len w) (and e (> (- exp-width 2) e)))
+ (:overflowchar params))
+ (print (apply str (repeat w (:overflowchar params))))
+ (print (str
+ (apply str
+ (repeat
+ (- w full-len (if append-zero 1 0))
+ (:padchar params)))
+ (if add-sign (if (neg? arg) \- \+))
+ (if prepend-zero "0")
+ full-mantissa
+ (if append-zero "0")
+ scaled-exp-str))))
+ (print (str
+ (if add-sign (if (neg? arg) \- \+))
+ (if prepend-zero "0")
+ full-mantissa
+ (if append-zero "0")
+ scaled-exp-str)))
+ (recur [rounded-mantissa (inc exp)]))))
+ navigator))
+
+;; the function to render ~G directives
+;; This just figures out whether to pass the request off to ~F or ~E based
+;; on the algorithm in CLtL.
+;; TODO: support rationals. Back off to ~D/~A in the appropriate cases
+;; TODO: refactor so that float-parts isn't called twice
+(defn- general-float [params navigator offsets]
+ (let [[arg _] (next-arg navigator)
+ arg (convert-ratio arg)
+ [mantissa exp] (float-parts (if (neg? arg) (- arg) arg))
+ w (:w params)
+ d (:d params)
+ e (:e params)
+ n (if (= arg 0.0) 0 (inc exp))
+ ee (if e (+ e 2) 4)
+ ww (if w (- w ee))
+ d (if d d (max (count mantissa) (min n 7)))
+ dd (- d n)]
+ (if (<= 0 dd d)
+ (let [navigator (fixed-float {:w ww, :d dd, :k 0,
+ :overflowchar (:overflowchar params),
+ :padchar (:padchar params), :at (:at params)}
+ navigator offsets)]
+ (print (apply str (repeat ee \space)))
+ navigator)
+ (exponential-float params navigator offsets))))
+
+;; the function to render ~$ directives
+;; TODO: support rationals. Back off to ~D/~A in the appropriate cases
+(defn- dollar-float [params navigator offsets]
+ (let [[arg navigator] (next-arg navigator)
+ [mantissa exp] (float-parts (Math/abs arg))
+ d (:d params) ; digits after the decimal
+ n (:n params) ; minimum digits before the decimal
+ w (:w params) ; minimum field width
+ add-sign (or (:at params) (neg? arg))
+ [rounded-mantissa scaled-exp expanded] (round-str mantissa exp d nil)
+ fixed-repr (get-fixed rounded-mantissa (if expanded (inc scaled-exp) scaled-exp) d)
+ full-repr (str (apply str (repeat (- n (.indexOf fixed-repr \.)) \0)) fixed-repr)
+ full-len (+ (count full-repr) (if add-sign 1 0))]
+ (print (str
+ (if (and (:colon params) add-sign) (if (neg? arg) \- \+))
+ (apply str (repeat (- w full-len) (:padchar params)))
+ (if (and (not (:colon params)) add-sign) (if (neg? arg) \- \+))
+ full-repr))
+ navigator))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Support for the '~[...~]' conditional construct in its
+;; different flavors
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; ~[...~] without any modifiers chooses one of the clauses based on the param or
+;; next argument
+;; TODO check arg is positive int
+(defn- choice-conditional [params arg-navigator offsets]
+ (let [arg (:selector params)
+ [arg navigator] (if arg [arg arg-navigator] (next-arg arg-navigator))
+ clauses (:clauses params)
+ clause (if (or (neg? arg) (>= arg (count clauses)))
+ (first (:else params))
+ (nth clauses arg))]
+ (if clause
+ (execute-sub-format clause navigator (:base-args params))
+ navigator)))
+
+;; ~:[...~] with the colon reads the next argument treating it as a truth value
+(defn- boolean-conditional [params arg-navigator offsets]
+ (let [[arg navigator] (next-arg arg-navigator)
+ clauses (:clauses params)
+ clause (if arg
+ (second clauses)
+ (first clauses))]
+ (if clause
+ (execute-sub-format clause navigator (:base-args params))
+ navigator)))
+
+;; ~@[...~] with the at sign executes the conditional if the next arg is not
+;; nil/false without consuming the arg
+(defn- check-arg-conditional [params arg-navigator offsets]
+ (let [[arg navigator] (next-arg arg-navigator)
+ clauses (:clauses params)
+ clause (if arg (first clauses))]
+ (if arg
+ (if clause
+ (execute-sub-format clause arg-navigator (:base-args params))
+ arg-navigator)
+ navigator)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Support for the '~{...~}' iteration construct in its
+;; different flavors
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; ~{...~} without any modifiers uses the next argument as an argument list that
+;; is consumed by all the iterations
+(defn- iterate-sublist [params navigator offsets]
+ (let [max-count (:max-iterations params)
+ param-clause (first (:clauses params))
+ [clause navigator] (if (empty? param-clause)
+ (get-format-arg navigator)
+ [param-clause navigator])
+ [arg-list navigator] (next-arg navigator)
+ args (init-navigator arg-list)]
+ (loop [count 0
+ args args
+ last-pos (int -1)]
+ (if (and (not max-count) (= (:pos args) last-pos) (> count 1))
+ ;; TODO get the offset in here and call format exception
+ (throw (js/Error "%{ construct not consuming any arguments: Infinite loop!")))
+ (if (or (and (empty? (:rest args))
+ (or (not (:colon (:right-params params))) (> count 0)))
+ (and max-count (>= count max-count)))
+ navigator
+ (let [iter-result (execute-sub-format clause args (:base-args params))]
+ (if (= :up-arrow (first iter-result))
+ navigator
+ (recur (inc count) iter-result (:pos args))))))))
+
+;; ~:{...~} with the colon treats the next argument as a list of sublists. Each of the
+;; sublists is used as the arglist for a single iteration.
+(defn- iterate-list-of-sublists [params navigator offsets]
+ (let [max-count (:max-iterations params)
+ param-clause (first (:clauses params))
+ [clause navigator] (if (empty? param-clause)
+ (get-format-arg navigator)
+ [param-clause navigator])
+ [arg-list navigator] (next-arg navigator)]
+ (loop [count 0
+ arg-list arg-list]
+ (if (or (and (empty? arg-list)
+ (or (not (:colon (:right-params params))) (> count 0)))
+ (and max-count (>= count max-count)))
+ navigator
+ (let [iter-result (execute-sub-format
+ clause
+ (init-navigator (first arg-list))
+ (init-navigator (next arg-list)))]
+ (if (= :colon-up-arrow (first iter-result))
+ navigator
+ (recur (inc count) (next arg-list))))))))
+
+;; ~@{...~} with the at sign uses the main argument list as the arguments to the iterations
+;; is consumed by all the iterations
+(defn- iterate-main-list [params navigator offsets]
+ (let [max-count (:max-iterations params)
+ param-clause (first (:clauses params))
+ [clause navigator] (if (empty? param-clause)
+ (get-format-arg navigator)
+ [param-clause navigator])]
+ (loop [count 0
+ navigator navigator
+ last-pos (int -1)]
+ (if (and (not max-count) (= (:pos navigator) last-pos) (> count 1))
+ ;; TODO get the offset in here and call format exception
+ (throw (js/Error "%@{ construct not consuming any arguments: Infinite loop!")))
+ (if (or (and (empty? (:rest navigator))
+ (or (not (:colon (:right-params params))) (> count 0)))
+ (and max-count (>= count max-count)))
+ navigator
+ (let [iter-result (execute-sub-format clause navigator (:base-args params))]
+ (if (= :up-arrow (first iter-result))
+ (second iter-result)
+ (recur
+ (inc count) iter-result (:pos navigator))))))))
+
+;; ~@:{...~} with both colon and at sign uses the main argument list as a set of sublists, one
+;; of which is consumed with each iteration
+(defn- iterate-main-sublists [params navigator offsets]
+ (let [max-count (:max-iterations params)
+ param-clause (first (:clauses params))
+ [clause navigator] (if (empty? param-clause)
+ (get-format-arg navigator)
+ [param-clause navigator])]
+ (loop [count 0
+ navigator navigator]
+ (if (or (and (empty? (:rest navigator))
+ (or (not (:colon (:right-params params))) (> count 0)))
+ (and max-count (>= count max-count)))
+ navigator
+ (let [[sublist navigator] (next-arg-or-nil navigator)
+ iter-result (execute-sub-format clause (init-navigator sublist) navigator)]
+ (if (= :colon-up-arrow (first iter-result))
+ navigator
+ (recur (inc count) navigator)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; The '~< directive has two completely different meanings
+;; in the '~<...~>' form it does justification, but with
+;; ~<...~:>' it represents the logical block operation of the
+;; pretty printer.
+;;
+;; Unfortunately, the current architecture decides what function
+;; to call at form parsing time before the sub-clauses have been
+;; folded, so it is left to run-time to make the decision.
+;;
+;; TODO: make it possible to make these decisions at compile-time.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declare ^{:arglists '([params navigator offsets])} format-logical-block)
+(declare ^{:arglists '([params navigator offsets])} justify-clauses)
+
+(defn- logical-block-or-justify [params navigator offsets]
+ (if (:colon (:right-params params))
+ (format-logical-block params navigator offsets)
+ (justify-clauses params navigator offsets)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Support for the '~<...~>' justification directive
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- render-clauses [clauses navigator base-navigator]
+ (loop [clauses clauses
+ acc []
+ navigator navigator]
+ (if (empty? clauses)
+ [acc navigator]
+ (let [clause (first clauses)
+ [iter-result result-str] (let [sb (StringBuffer.)]
+ (binding [*out* (StringBufferWriter. sb)]
+ [(execute-sub-format clause navigator base-navigator)
+ (str sb)]))]
+ (if (= :up-arrow (first iter-result))
+ [acc (second iter-result)]
+ (recur (next clauses) (conj acc result-str) iter-result))))))
+
+;; TODO support for ~:; constructions
+(defn- justify-clauses [params navigator offsets]
+ (let [[[eol-str] new-navigator] (when-let [else (:else params)]
+ (render-clauses else navigator (:base-args params)))
+ navigator (or new-navigator navigator)
+ [else-params new-navigator] (when-let [p (:else-params params)]
+ (realize-parameter-list p navigator))
+ navigator (or new-navigator navigator)
+ min-remaining (or (first (:min-remaining else-params)) 0)
+ max-columns (or (first (:max-columns else-params))
+ (get-max-column *out*))
+ clauses (:clauses params)
+ [strs navigator] (render-clauses clauses navigator (:base-args params))
+ slots (max 1
+ (+ (dec (count strs)) (if (:colon params) 1 0) (if (:at params) 1 0)))
+ chars (reduce + (map count strs))
+ mincol (:mincol params)
+ minpad (:minpad params)
+ colinc (:colinc params)
+ minout (+ chars (* slots minpad))
+ result-columns (if (<= minout mincol)
+ mincol
+ (+ mincol (* colinc
+ (+ 1 (quot (- minout mincol 1) colinc)))))
+ total-pad (- result-columns chars)
+ pad (max minpad (quot total-pad slots))
+ extra-pad (- total-pad (* pad slots))
+ pad-str (apply str (repeat pad (:padchar params)))]
+ (if (and eol-str (> (+ (get-column (:base @@*out*)) min-remaining result-columns)
+ max-columns))
+ (print eol-str))
+ (loop [slots slots
+ extra-pad extra-pad
+ strs strs
+ pad-only (or (:colon params)
+ (and (= (count strs) 1) (not (:at params))))]
+ (if (seq strs)
+ (do
+ (print (str (if (not pad-only) (first strs))
+ (if (or pad-only (next strs) (:at params)) pad-str)
+ (if (pos? extra-pad) (:padchar params))))
+ (recur
+ (dec slots)
+ (dec extra-pad)
+ (if pad-only strs (next strs))
+ false))))
+ navigator))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Support for case modification with ~(...~).
+;;; We do this by wrapping the underlying writer with
+;;; a special writer to do the appropriate modification. This
+;;; allows us to support arbitrary-sized output and sources
+;;; that may block.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- downcase-writer
+ "Returns a proxy that wraps writer, converting all characters to lower case"
+ [writer]
+ (reify
+ IWriter
+ (-flush [_] (-flush writer))
+ (-write
+ ;;no multi-arity, not sure of importance
+ #_([^chars cbuf ^Integer off ^Integer len]
+ (.write writer cbuf off len))
+ [this x]
+ (condp = (type x)
+ js/String
+ (let [s x]
+ (-write writer (string/lower-case s)))
+
+ js/Number
+ (let [c x]
+ ;;TODO need to enforce integers only?
+ (-write writer (string/lower-case (char c))))))))
+
+(defn- upcase-writer
+ "Returns a proxy that wraps writer, converting all characters to upper case"
+ [writer]
+ (reify
+ IWriter
+ (-flush [_] (-flush writer))
+ (-write
+ ;;no multi-arity, not sure of importance
+ #_([^chars cbuf ^Integer off ^Integer len]
+ (.write writer cbuf off len))
+ [this x]
+ (condp = (type x)
+ js/String
+ (let [s x]
+ (-write writer (string/upper-case s)))
+
+ js/Number
+ (let [c x]
+ ;;TODO need to enforce integers only?
+ (-write writer (string/upper-case (char c))))))))
+
+(defn- capitalize-string
+ "Capitalizes the words in a string. If first? is false, don't capitalize the
+ first character of the string even if it's a letter."
+ [s first?]
+ (let [f (first s)
+ s (if (and first? f (gstring/isUnicodeChar f))
+ (str (string/upper-case f) (subs s 1))
+ s)]
+ (apply str
+ (first
+ (consume
+ (fn [s]
+ (if (empty? s)
+ [nil nil]
+ (let [m (.exec (js/RegExp "\\W\\w" "g") s)
+ offset (and m (inc (.-index m)))]
+ (if offset
+ [(str (subs s 0 offset)
+ (string/upper-case (nth s offset)))
+ (subs s (inc offset))]
+ [s nil]))))
+ s)))))
+
+(defn- capitalize-word-writer
+ "Returns a proxy that wraps writer, capitalizing all words"
+ [writer]
+ (let [last-was-whitespace? (atom true)]
+ (reify
+ IWriter
+ (-flush [_] (-flush writer))
+ (-write
+ ;;no multi-arity
+ #_([^chars cbuf ^Integer off ^Integer len]
+ (.write writer cbuf off len))
+ [this x]
+ (condp = (type x)
+ js/String
+ (let [s x]
+ (-write writer
+ (capitalize-string (.toLowerCase s) @last-was-whitespace?))
+ (when (pos? (.-length s))
+ (reset! last-was-whitespace? (gstring/isEmptyOrWhitespace (nth s (dec (count s)))))))
+
+ js/Number
+ (let [c (char x)]
+ (let [mod-c (if @last-was-whitespace? (string/upper-case c) c)]
+ (-write writer mod-c)
+ (reset! last-was-whitespace? (gstring/isEmptyOrWhitespace c)))))))))
+
+(defn- init-cap-writer
+ "Returns a proxy that wraps writer, capitalizing the first word"
+ [writer]
+ (let [capped (atom false)]
+ (reify
+ IWriter
+ (-flush [_] (-flush writer))
+ (-write
+ ;;no multi-arity
+ #_([^chars cbuf ^Integer off ^Integer len]
+ (.write writer cbuf off len))
+ [this x]
+ (condp = (type x)
+ js/String
+ (let [s (string/lower-case x)]
+ (if (not @capped)
+ (let [m (.exec (js/RegExp "\\S" "g") s)
+ offset (and m (.-index m))]
+ (if offset
+ (do (-write writer
+ (str (subs s 0 offset)
+ (string/upper-case (nth s offset))
+ (string/lower-case (subs s (inc offset)))))
+ (reset! capped true))
+ (-write writer s)))
+ (-write writer (string/lower-case s))))
+
+ js/Number
+ (let [c (char x)]
+ (if (and (not @capped) (gstring/isUnicodeChar c))
+ (do
+ (reset! capped true)
+ (-write writer (string/upper-case c)))
+ (-write writer (string/lower-case c)))))))))
+
+(defn- modify-case [make-writer params navigator offsets]
+ (let [clause (first (:clauses params))]
+ (binding [*out* (make-writer *out*)]
+ (execute-sub-format clause navigator (:base-args params)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; If necessary, wrap the writer in a PrettyWriter object
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; TODO update this doc string to show correct way to print
+(defn get-pretty-writer
+ "Returns the IWriter passed in wrapped in a pretty writer proxy, unless it's
+already a pretty writer. Generally, it is unnecessary to call this function, since pprint,
+write, and cl-format all call it if they need to. However if you want the state to be
+preserved across calls, you will want to wrap them with this.
+
+For example, when you want to generate column-aware output with multiple calls to cl-format,
+do it like in this example:
+
+ (defn print-table [aseq column-width]
+ (binding [*out* (get-pretty-writer *out*)]
+ (doseq [row aseq]
+ (doseq [col row]
+ (cl-format true \"~4D~7,vT\" col column-width))
+ (prn))))
+
+Now when you run:
+
+ user> (print-table (map #(vector % (* % %) (* % % %)) (range 1 11)) 8)
+
+It prints a table of squares and cubes for the numbers from 1 to 10:
+
+ 1 1 1
+ 2 4 8
+ 3 9 27
+ 4 16 64
+ 5 25 125
+ 6 36 216
+ 7 49 343
+ 8 64 512
+ 9 81 729
+ 10 100 1000"
+ [writer]
+ (if (pretty-writer? writer)
+ writer
+ (pretty-writer writer *print-right-margin* *print-miser-width*)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Support for column-aware operations ~&, ~T
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn fresh-line
+ "Make a newline if *out* is not already at the beginning of the line. If *out* is
+not a pretty writer (which keeps track of columns), this function always outputs a newline."
+ []
+ (if (satisfies? IDeref *out*)
+ (if (not (= 0 (get-column (:base @@*out*))))
+ (prn))
+ (prn)))
+
+(defn- absolute-tabulation [params navigator offsets]
+ (let [colnum (:colnum params)
+ colinc (:colinc params)
+ current (get-column (:base @@*out*))
+ space-count (cond
+ (< current colnum) (- colnum current)
+ (= colinc 0) 0
+ :else (- colinc (rem (- current colnum) colinc)))]
+ (print (apply str (repeat space-count \space))))
+ navigator)
+
+(defn- relative-tabulation [params navigator offsets]
+ (let [colrel (:colnum params)
+ colinc (:colinc params)
+ start-col (+ colrel (get-column (:base @@*out*)))
+ offset (if (pos? colinc) (rem start-col colinc) 0)
+ space-count (+ colrel (if (= 0 offset) 0 (- colinc offset)))]
+ (print (apply str (repeat space-count \space))))
+ navigator)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Support for accessing the pretty printer from a format
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; TODO: support ~@; per-line-prefix separator
+;; TODO: get the whole format wrapped so we can start the lb at any column
+(defn- format-logical-block [params navigator offsets]
+ (let [clauses (:clauses params)
+ clause-count (count clauses)
+ prefix (cond
+ (> clause-count 1) (:string (:params (first (first clauses))))
+ (:colon params) "(")
+ body (nth clauses (if (> clause-count 1) 1 0))
+ suffix (cond
+ (> clause-count 2) (:string (:params (first (nth clauses 2))))
+ (:colon params) ")")
+ [arg navigator] (next-arg navigator)]
+ (pprint-logical-block :prefix prefix :suffix suffix
+ (execute-sub-format
+ body
+ (init-navigator arg)
+ (:base-args params)))
+ navigator))
+
+(defn- set-indent [params navigator offsets]
+ (let [relative-to (if (:colon params) :current :block)]
+ (pprint-indent relative-to (:n params))
+ navigator))
+
+;;; TODO: support ~:T section options for ~T
+(defn- conditional-newline [params navigator offsets]
+ (let [kind (if (:colon params)
+ (if (:at params) :mandatory :fill)
+ (if (:at params) :miser :linear))]
+ (pprint-newline kind)
+ navigator))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; The table of directives we support, each with its params,
+;;; properties, and the compilation function
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defdirectives
+ (\A
+ [:mincol [0 js/Number] :colinc [1 js/Number] :minpad [0 js/Number] :padchar [\space js/String]]
+ #{:at :colon :both} {}
+ #(format-ascii print-str %1 %2 %3))
+
+ (\S
+ [:mincol [0 js/Number] :colinc [1 js/Number] :minpad [0 js/Number] :padchar [\space js/String]]
+ #{:at :colon :both} {}
+ #(format-ascii pr-str %1 %2 %3))
+
+ (\D
+ [:mincol [0 js/Number] :padchar [\space js/String] :commachar [\, js/String]
+ :commainterval [3 js/Number]]
+ #{:at :colon :both} {}
+ #(format-integer 10 %1 %2 %3))
+
+ (\B
+ [:mincol [0 js/Number] :padchar [\space js/String] :commachar [\, js/String]
+ :commainterval [3 js/Number]]
+ #{:at :colon :both} {}
+ #(format-integer 2 %1 %2 %3))
+
+ (\O
+ [:mincol [0 js/Number] :padchar [\space js/String] :commachar [\, js/String]
+ :commainterval [3 js/Number]]
+ #{:at :colon :both} {}
+ #(format-integer 8 %1 %2 %3))
+
+ (\X
+ [:mincol [0 js/Number] :padchar [\space js/String] :commachar [\, js/String]
+ :commainterval [3 js/Number]]
+ #{:at :colon :both} {}
+ #(format-integer 16 %1 %2 %3))
+
+ (\R
+ [:base [nil js/Number] :mincol [0 js/Number] :padchar [\space js/String] :commachar [\, js/String]
+ :commainterval [3 js/Number]]
+ #{:at :colon :both} {}
+ (do
+ (cond ; ~R is overloaded with bizareness
+ (first (:base params)) #(format-integer (:base %1) %1 %2 %3)
+ (and (:at params) (:colon params)) #(format-old-roman %1 %2 %3)
+ (:at params) #(format-new-roman %1 %2 %3)
+ (:colon params) #(format-ordinal-english %1 %2 %3)
+ true #(format-cardinal-english %1 %2 %3))))
+
+ (\P
+ []
+ #{:at :colon :both} {}
+ (fn [params navigator offsets]
+ (let [navigator (if (:colon params) (relative-reposition navigator -1) navigator)
+ strs (if (:at params) ["y" "ies"] ["" "s"])
+ [arg navigator] (next-arg navigator)]
+ (print (if (= arg 1) (first strs) (second strs)))
+ navigator)))
+
+ (\C
+ [:char-format [nil js/String]]
+ #{:at :colon :both} {}
+ (cond
+ (:colon params) pretty-character
+ (:at params) readable-character
+ :else plain-character))
+
+ (\F
+ [:w [nil js/Number] :d [nil js/Number] :k [0 js/Number] :overflowchar [nil js/String]
+ :padchar [\space js/String]]
+ #{:at} {}
+ fixed-float)
+
+ (\E
+ [:w [nil js/Number] :d [nil js/Number] :e [nil js/Number] :k [1 js/Number]
+ :overflowchar [nil js/String] :padchar [\space js/String]
+ :exponentchar [nil js/String]]
+ #{:at} {}
+ exponential-float)
+
+ (\G
+ [:w [nil js/Number] :d [nil js/Number] :e [nil js/Number] :k [1 js/Number]
+ :overflowchar [nil js/String] :padchar [\space js/String]
+ :exponentchar [nil js/String]]
+ #{:at} {}
+ general-float)
+
+ (\$
+ [:d [2 js/Number] :n [1 js/Number] :w [0 js/Number] :padchar [\space js/String]]
+ #{:at :colon :both} {}
+ dollar-float)
+
+ (\%
+ [:count [1 js/Number]]
+ #{} {}
+ (fn [params arg-navigator offsets]
+ (dotimes [i (:count params)]
+ (prn))
+ arg-navigator))
+
+ (\&
+ [:count [1 js/Number]]
+ #{:pretty} {}
+ (fn [params arg-navigator offsets]
+ (let [cnt (:count params)]
+ (if (pos? cnt) (fresh-line))
+ (dotimes [i (dec cnt)]
+ (prn)))
+ arg-navigator))
+
+ (\|
+ [:count [1 js/Number]]
+ #{} {}
+ (fn [params arg-navigator offsets]
+ (dotimes [i (:count params)]
+ (print \formfeed))
+ arg-navigator))
+
+ (\~
+ [:n [1 js/Number]]
+ #{} {}
+ (fn [params arg-navigator offsets]
+ (let [n (:n params)]
+ (print (apply str (repeat n \~)))
+ arg-navigator)))
+
+ (\newline ;; Whitespace supression is handled in the compilation loop
+ []
+ #{:colon :at} {}
+ (fn [params arg-navigator offsets]
+ (if (:at params)
+ (prn))
+ arg-navigator))
+
+ (\T
+ [:colnum [1 js/Number] :colinc [1 js/Number]]
+ #{:at :pretty} {}
+ (if (:at params)
+ #(relative-tabulation %1 %2 %3)
+ #(absolute-tabulation %1 %2 %3)))
+
+ (\*
+ [:n [1 js/Number]]
+ #{:colon :at} {}
+ (fn [params navigator offsets]
+ (let [n (:n params)]
+ (if (:at params)
+ (absolute-reposition navigator n)
+ (relative-reposition navigator (if (:colon params) (- n) n))))))
+
+ (\?
+ []
+ #{:at} {}
+ (if (:at params)
+ (fn [params navigator offsets] ; args from main arg list
+ (let [[subformat navigator] (get-format-arg navigator)]
+ (execute-sub-format subformat navigator (:base-args params))))
+ (fn [params navigator offsets] ; args from sub-list
+ (let [[subformat navigator] (get-format-arg navigator)
+ [subargs navigator] (next-arg navigator)
+ sub-navigator (init-navigator subargs)]
+ (execute-sub-format subformat sub-navigator (:base-args params))
+ navigator))))
+
+ (\(
+ []
+ #{:colon :at :both} {:right \), :allows-separator nil, :else nil}
+ (let [mod-case-writer (cond
+ (and (:at params) (:colon params))
+ upcase-writer
+
+ (:colon params)
+ capitalize-word-writer
+
+ (:at params)
+ init-cap-writer
+
+ :else
+ downcase-writer)]
+ #(modify-case mod-case-writer %1 %2 %3)))
+
+ (\) [] #{} {} nil)
+
+ (\[
+ [:selector [nil js/Number]]
+ #{:colon :at} {:right \], :allows-separator true, :else :last}
+ (cond
+ (:colon params)
+ boolean-conditional
+
+ (:at params)
+ check-arg-conditional
+
+ true
+ choice-conditional))
+
+ (\; [:min-remaining [nil js/Number] :max-columns [nil js/Number]]
+ #{:colon} {:separator true} nil)
+
+ (\] [] #{} {} nil)
+
+ (\{
+ [:max-iterations [nil js/Number]]
+ #{:colon :at :both} {:right \}, :allows-separator false}
+ (cond
+ (and (:at params) (:colon params))
+ iterate-main-sublists
+
+ (:colon params)
+ iterate-list-of-sublists
+
+ (:at params)
+ iterate-main-list
+
+ true
+ iterate-sublist))
+
+ (\} [] #{:colon} {} nil)
+
+ (\<
+ [:mincol [0 js/Number] :colinc [1 js/Number] :minpad [0 js/Number] :padchar [\space js/String]]
+ #{:colon :at :both :pretty} {:right \>, :allows-separator true, :else :first}
+ logical-block-or-justify)
+
+ (\> [] #{:colon} {} nil)
+
+ ;; TODO: detect errors in cases where colon not allowed
+ (\^ [:arg1 [nil js/Number] :arg2 [nil js/Number] :arg3 [nil js/Number]]
+ #{:colon} {}
+ (fn [params navigator offsets]
+ (let [arg1 (:arg1 params)
+ arg2 (:arg2 params)
+ arg3 (:arg3 params)
+ exit (if (:colon params) :colon-up-arrow :up-arrow)]
+ (cond
+ (and arg1 arg2 arg3)
+ (if (<= arg1 arg2 arg3) [exit navigator] navigator)
+
+ (and arg1 arg2)
+ (if (= arg1 arg2) [exit navigator] navigator)
+
+ arg1
+ (if (= arg1 0) [exit navigator] navigator)
+
+ true ; TODO: handle looking up the arglist stack for info
+ (if (if (:colon params)
+ (empty? (:rest (:base-args params)))
+ (empty? (:rest navigator)))
+ [exit navigator] navigator)))))
+
+ (\W
+ []
+ #{:at :colon :both :pretty} {}
+ (if (or (:at params) (:colon params))
+ (let [bindings (concat
+ (if (:at params) [:level nil :length nil] [])
+ (if (:colon params) [:pretty true] []))]
+ (fn [params navigator offsets]
+ (let [[arg navigator] (next-arg navigator)]
+ (if (apply write arg bindings)
+ [:up-arrow navigator]
+ navigator))))
+ (fn [params navigator offsets]
+ (let [[arg navigator] (next-arg navigator)]
+ (if (write-out arg)
+ [:up-arrow navigator]
+ navigator)))))
+
+ (\_
+ []
+ #{:at :colon :both} {}
+ conditional-newline)
+
+ (\I
+ [:n [0 js/Number]]
+ #{:colon} {}
+ set-indent)
+ )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Code to manage the parameters and flags associated with each
+;; directive in the format string.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def ^{:private true}
+ param-pattern #"^([vV]|#|('.)|([+-]?\d+)|(?=,))")
+
+(def ^{:private true}
+ special-params #{:parameter-from-args :remaining-arg-count})
+
+(defn- extract-param [[s offset saw-comma]]
+ (let [m (js/RegExp. (.-source param-pattern) "g")
+ param (.exec m s)]
+ (if param
+ (let [token-str (first param)
+ remainder (subs s (.-lastIndex m))
+ new-offset (+ offset (.-lastIndex m))]
+ (if (not (= \, (nth remainder 0)))
+ [[token-str offset] [remainder new-offset false]]
+ [[token-str offset] [(subs remainder 1) (inc new-offset) true]]))
+ (if saw-comma
+ (format-error "Badly formed parameters in format directive" offset)
+ [nil [s offset]]))))
+
+(defn- extract-params [s offset]
+ (consume extract-param [s offset false]))
+
+(defn- translate-param
+ "Translate the string representation of a param to the internalized
+ representation"
+ [[p offset]]
+ [(cond
+ (= (.-length p) 0) nil
+ (and (= (.-length p) 1) (contains? #{\v \V} (nth p 0))) :parameter-from-args
+ (and (= (.-length p) 1) (= \# (nth p 0))) :remaining-arg-count
+ (and (= (.-length p) 2) (= \' (nth p 0))) (nth p 1)
+ true (js/parseInt p 10))
+ offset])
+
+(def ^{:private true}
+ flag-defs {\: :colon, \@ :at})
+
+(defn- extract-flags [s offset]
+ (consume
+ (fn [[s offset flags]]
+ (if (empty? s)
+ [nil [s offset flags]]
+ (let [flag (get flag-defs (first s))]
+ (if flag
+ (if (contains? flags flag)
+ (format-error
+ (str "Flag \"" (first s) "\" appears more than once in a directive")
+ offset)
+ [true [(subs s 1) (inc offset) (assoc flags flag [true offset])]])
+ [nil [s offset flags]]))))
+ [s offset {}]))
+
+(defn- check-flags [def flags]
+ (let [allowed (:flags def)]
+ (if (and (not (:at allowed)) (:at flags))
+ (format-error (str "\"@\" is an illegal flag for format directive \"" (:directive def) "\"")
+ (nth (:at flags) 1)))
+ (if (and (not (:colon allowed)) (:colon flags))
+ (format-error (str "\":\" is an illegal flag for format directive \"" (:directive def) "\"")
+ (nth (:colon flags) 1)))
+ (if (and (not (:both allowed)) (:at flags) (:colon flags))
+ (format-error (str "Cannot combine \"@\" and \":\" flags for format directive \""
+ (:directive def) "\"")
+ (min (nth (:colon flags) 1) (nth (:at flags) 1))))))
+
+(defn- map-params
+ "Takes a directive definition and the list of actual parameters and
+a map of flags and returns a map of the parameters and flags with defaults
+filled in. We check to make sure that there are the right types and number
+of parameters as well."
+ [def params flags offset]
+ (check-flags def flags)
+ (if (> (count params) (count (:params def)))
+ (format-error
+ (cl-format
+ nil
+ "Too many parameters for directive \"~C\": ~D~:* ~[were~;was~:;were~] specified but only ~D~:* ~[are~;is~:;are~] allowed"
+ (:directive def) (count params) (count (:params def)))
+ (second (first params))))
+ (doall
+ (map #(let [val (first %1)]
+ (if (not (or (nil? val) (contains? special-params val)
+ (= (second (second %2)) (type val))))
+ (format-error (str "Parameter " (name (first %2))
+ " has bad type in directive \"" (:directive def) "\": "
+ (type val))
+ (second %1))) )
+ params (:params def)))
+
+ (merge ; create the result map
+ (into (array-map) ; start with the default values, make sure the order is right
+ (reverse (for [[name [default]] (:params def)] [name [default offset]])))
+ (reduce #(apply assoc %1 %2) {} (filter #(first (nth % 1)) (zipmap (keys (:params def)) params))) ; add the specified parameters, filtering out nils
+ flags)); and finally add the flags
+
+(defn- compile-directive [s offset]
+ (let [[raw-params [rest offset]] (extract-params s offset)
+ [_ [rest offset flags]] (extract-flags rest offset)
+ directive (first rest)
+ def (get directive-table (string/upper-case directive))
+ params (if def (map-params def (map translate-param raw-params) flags offset))]
+ (if (not directive)
+ (format-error "Format string ended in the middle of a directive" offset))
+ (if (not def)
+ (format-error (str "Directive \"" directive "\" is undefined") offset))
+ [(compiled-directive. ((:generator-fn def) params offset) def params offset)
+ (let [remainder (subs rest 1)
+ offset (inc offset)
+ trim? (and (= \newline (:directive def))
+ (not (:colon params)))
+ trim-count (if trim? (prefix-count remainder [\space \tab]) 0)
+ remainder (subs remainder trim-count)
+ offset (+ offset trim-count)]
+ [remainder offset])]))
+
+(defn- compile-raw-string [s offset]
+ (compiled-directive. (fn [_ a _] (print s) a) nil {:string s} offset))
+
+(defn- right-bracket [this] (:right (:bracket-info (:def this))))
+
+(defn- separator? [this] (:separator (:bracket-info (:def this))))
+
+(defn- else-separator? [this]
+ (and (:separator (:bracket-info (:def this)))
+ (:colon (:params this))))
+
+(declare ^{:arglists '([bracket-info offset remainder])} collect-clauses)
+
+(defn- process-bracket [this remainder]
+ (let [[subex remainder] (collect-clauses (:bracket-info (:def this))
+ (:offset this) remainder)]
+ [(compiled-directive.
+ (:func this) (:def this)
+ (merge (:params this) (tuple-map subex (:offset this)))
+ (:offset this))
+ remainder]))
+
+(defn- process-clause [bracket-info offset remainder]
+ (consume
+ (fn [remainder]
+ (if (empty? remainder)
+ (format-error "No closing bracket found." offset)
+ (let [this (first remainder)
+ remainder (next remainder)]
+ (cond
+ (right-bracket this)
+ (process-bracket this remainder)
+
+ (= (:right bracket-info) (:directive (:def this)))
+ [ nil [:right-bracket (:params this) nil remainder]]
+
+ (else-separator? this)
+ [nil [:else nil (:params this) remainder]]
+
+ (separator? this)
+ [nil [:separator nil nil remainder]] ;; TODO: check to make sure that there are no params on ~;
+
+ true
+ [this remainder]))))
+ remainder))
+
+(defn- collect-clauses [bracket-info offset remainder]
+ (second
+ (consume
+ (fn [[clause-map saw-else remainder]]
+ (let [[clause [type right-params else-params remainder]]
+ (process-clause bracket-info offset remainder)]
+ (cond
+ (= type :right-bracket)
+ [nil [(merge-with concat clause-map
+ {(if saw-else :else :clauses) [clause]
+ :right-params right-params})
+ remainder]]
+
+ (= type :else)
+ (cond
+ (:else clause-map)
+ (format-error "Two else clauses (\"~:;\") inside bracket construction." offset)
+
+ (not (:else bracket-info))
+ (format-error "An else clause (\"~:;\") is in a bracket type that doesn't support it."
+ offset)
+
+ (and (= :first (:else bracket-info)) (seq (:clauses clause-map)))
+ (format-error
+ "The else clause (\"~:;\") is only allowed in the first position for this directive."
+ offset)
+
+ true ; if the ~:; is in the last position, the else clause
+ ; is next, this was a regular clause
+ (if (= :first (:else bracket-info))
+ [true [(merge-with concat clause-map {:else [clause] :else-params else-params})
+ false remainder]]
+ [true [(merge-with concat clause-map {:clauses [clause]})
+ true remainder]]))
+
+ (= type :separator)
+ (cond
+ saw-else
+ (format-error "A plain clause (with \"~;\") follows an else clause (\"~:;\") inside bracket construction." offset)
+
+ (not (:allows-separator bracket-info))
+ (format-error "A separator (\"~;\") is in a bracket type that doesn't support it."
+ offset)
+
+ true
+ [true [(merge-with concat clause-map {:clauses [clause]})
+ false remainder]]))))
+ [{:clauses []} false remainder])))
+
+(defn- process-nesting
+ "Take a linearly compiled format and process the bracket directives to give it
+ the appropriate tree structure"
+ [format]
+ (first
+ (consume
+ (fn [remainder]
+ (let [this (first remainder)
+ remainder (next remainder)
+ bracket (:bracket-info (:def this))]
+ (if (:right bracket)
+ (process-bracket this remainder)
+ [this remainder])))
+ format)))
+
+(defn- compile-format
+ "Compiles format-str into a compiled format which can be used as an argument
+to cl-format just like a plain format string. Use this function for improved
+performance when you're using the same format string repeatedly"
+ [format-str]
+ (binding [*format-str* format-str]
+ (process-nesting
+ (first
+ (consume
+ (fn [[s offset]]
+ (if (empty? s)
+ [nil s]
+ (let [tilde (.indexOf s \~)]
+ (cond
+ (neg? tilde) [(compile-raw-string s offset) ["" (+ offset (.-length s))]]
+ (zero? tilde) (compile-directive (subs s 1) (inc offset))
+ true
+ [(compile-raw-string (subs s 0 tilde) offset) [(subs s tilde) (+ tilde offset)]]))))
+ [format-str 0])))))
+
+(defn- needs-pretty
+ "determine whether a given compiled format has any directives that depend on the
+column number or pretty printing"
+ [format]
+ (loop [format format]
+ (if (empty? format)
+ false
+ (if (or (:pretty (:flags (:def (first format))))
+ (some needs-pretty (first (:clauses (:params (first format)))))
+ (some needs-pretty (first (:else (:params (first format))))))
+ true
+ (recur (next format))))))
+
+;;NB We depart from the original api. In clj, if execute-format is called multiple times with the same stream or
+;; called on *out*, the results are different than if the same calls are made with different streams or printing
+;; to a string. The reason is that mutating the underlying stream changes the result by changing spacing.
+;;
+;; clj:
+;; * stream => "1 2 3"
+;; * true (prints to *out*) => "1 2 3"
+;; * nil (prints to string) => "1 2 3"
+;; cljs:
+;; * stream => "1 2 3"
+;; * true (prints via *print-fn*) => "1 2 3"
+;; * nil (prints to string) => "1 2 3"
+(defn- execute-format
+ "Executes the format with the arguments."
+ {:skip-wiki true}
+ ([stream format args]
+ (let [sb (StringBuffer.)
+ real-stream (if (or (not stream) (true? stream))
+ (StringBufferWriter. sb)
+ stream)
+ wrapped-stream (if (and (needs-pretty format)
+ (not (pretty-writer? real-stream)))
+ (get-pretty-writer real-stream)
+ real-stream)]
+ (binding [*out* wrapped-stream]
+ (try
+ (execute-format format args)
+ (finally
+ (if-not (identical? real-stream wrapped-stream)
+ (-flush wrapped-stream))))
+ (cond
+ (not stream) (str sb)
+ (true? stream) (string-print (str sb))
+ :else nil))))
+ ([format args]
+ (map-passing-context
+ (fn [element context]
+ (if (abort? context)
+ [nil context]
+ (let [[params args] (realize-parameter-list
+ (:params element) context)
+ [params offsets] (unzip-map params)
+ params (assoc params :base-args args)]
+ [nil (apply (:func element) [params args offsets])])))
+ args
+ format)
+ nil))
+
+;;; This is a bad idea, but it prevents us from leaking private symbols
+;;; This should all be replaced by really compiled formats anyway.
+(def ^{:private true} cached-compile (memoize compile-format))
+
+;;======================================================================
+;; dispatch.clj
+;;======================================================================
+
+(defn- use-method
+ "Installs a function as a new method of multimethod associated with dispatch-value. "
+ [multifn dispatch-val func]
+ (-add-method multifn dispatch-val func))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Implementations of specific dispatch table entries
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Handle forms that can be "back-translated" to reader macros
+;;; Not all reader macros can be dealt with this way or at all.
+;;; Macros that we can't deal with at all are:
+;;; ; - The comment character is absorbed by the reader and never is part of the form
+;;; ` - Is fully processed at read time into a lisp expression (which will contain concats
+;;; and regular quotes).
+;;; ~@ - Also fully eaten by the processing of ` and can't be used outside.
+;;; , - is whitespace and is lost (like all other whitespace). Formats can generate commas
+;;; where they deem them useful to help readability.
+;;; ^ - Adding metadata completely disappears at read time and the data appears to be
+;;; completely lost.
+;;;
+;;; Most other syntax stuff is dealt with directly by the formats (like (), [], {}, and #{})
+;;; or directly by printing the objects using Clojure's built-in print functions (like
+;;; :keyword, \char, or ""). The notable exception is #() which is special-cased.
+
+(def ^{:private true} reader-macros
+ {'quote "'"
+ 'var "#'"
+ 'clojure.core/deref "@",
+ 'clojure.core/unquote "~"
+ 'cljs.core/deref "@",
+ 'cljs.core/unquote "~"})
+
+(defn- pprint-reader-macro [alis]
+ (let [macro-char (reader-macros (first alis))]
+ (when (and macro-char (= 2 (count alis)))
+ (-write *out* macro-char)
+ (write-out (second alis))
+ true)))
+
+;;======================================================================
+;; Dispatch for the basic data types when interpreted
+;; as data (as opposed to code).
+;;======================================================================
+
+;;; TODO: inline these formatter statements into funcs so that we
+;;; are a little easier on the stack. (Or, do "real" compilation, a
+;;; la Common Lisp)
+
+;;; (def pprint-simple-list (formatter-out "~:<~@{~w~^ ~_~}~:>"))
+(defn- pprint-simple-list [alis]
+ (pprint-logical-block :prefix "(" :suffix ")"
+ (print-length-loop [alis (seq alis)]
+ (when alis
+ (write-out (first alis))
+ (when (next alis)
+ (-write *out* " ")
+ (pprint-newline :linear)
+ (recur (next alis)))))))
+
+(defn- pprint-list [alis]
+ (if-not (pprint-reader-macro alis)
+ (pprint-simple-list alis)))
+
+;;; (def pprint-vector (formatter-out "~<[~;~@{~w~^ ~_~}~;]~:>"))
+(defn- pprint-vector [avec]
+ (pprint-logical-block :prefix "[" :suffix "]"
+ (print-length-loop [aseq (seq avec)]
+ (when aseq
+ (write-out (first aseq))
+ (when (next aseq)
+ (-write *out* " ")
+ (pprint-newline :linear)
+ (recur (next aseq)))))))
+
+(def ^{:private true} pprint-array (formatter-out "~<[~;~@{~w~^, ~:_~}~;]~:>"))
+
+;;; (def pprint-map (formatter-out "~<{~;~@{~<~w~^ ~_~w~:>~^, ~_~}~;}~:>"))
+(defn- pprint-map [amap]
+ (let [[ns lift-map] (when (not (record? amap))
+ (#'cljs.core/lift-ns amap))
+ amap (or lift-map amap)
+ prefix (if ns (str "#:" ns "{") "{")]
+ (pprint-logical-block :prefix prefix :suffix "}"
+ (print-length-loop [aseq (seq amap)]
+ (when aseq
+ ;;compiler gets confused with nested macro if it isn't namespaced
+ ;;it tries to use clojure.pprint/pprint-logical-block for some reason
+ (m/pprint-logical-block
+ (write-out (ffirst aseq))
+ (-write *out* " ")
+ (pprint-newline :linear)
+ (set! *current-length* 0) ;always print both parts of the [k v] pair
+ (write-out (fnext (first aseq))))
+ (when (next aseq)
+ (-write *out* ", ")
+ (pprint-newline :linear)
+ (recur (next aseq))))))))
+
+(defn- pprint-simple-default [obj]
+ ;;TODO: Update to handle arrays (?) and suppressing namespaces
+ (-write *out* (pr-str obj)))
+
+(def pprint-set (formatter-out "~<#{~;~@{~w~^ ~:_~}~;}~:>"))
+
+(def ^{:private true}
+type-map {"core$future_call" "Future",
+ "core$promise" "Promise"})
+
+(defn- map-ref-type
+ "Map ugly type names to something simpler"
+ [name]
+ (or (when-let [match (re-find #"^[^$]+\$[^$]+" name)]
+ (type-map match))
+ name))
+
+(defn- pprint-ideref [o]
+ (let [prefix (str "#<" (map-ref-type (.-name (type o)))
+ "@" (goog/getUid o) ": ")]
+ (pprint-logical-block :prefix prefix :suffix ">"
+ (pprint-indent :block (-> (count prefix) (- 2) -))
+ (pprint-newline :linear)
+ (write-out
+ (if (and (satisfies? IPending o) (not (-realized? o)))
+ :not-delivered
+ @o)))))
+
+(def ^{:private true} pprint-pqueue (formatter-out "~<<-(~;~@{~w~^ ~_~}~;)-<~:>"))
+
+(defn- type-dispatcher [obj]
+ (cond
+ (instance? PersistentQueue obj) :queue
+ (satisfies? IDeref obj) :deref
+ (symbol? obj) :symbol
+ (seq? obj) :list
+ (map? obj) :map
+ (vector? obj) :vector
+ (set? obj) :set
+ (nil? obj) nil
+ :default :default))
+
+(defmulti simple-dispatch
+ "The pretty print dispatch function for simple data structure format."
+ type-dispatcher)
+
+(use-method simple-dispatch :list pprint-list)
+(use-method simple-dispatch :vector pprint-vector)
+(use-method simple-dispatch :map pprint-map)
+(use-method simple-dispatch :set pprint-set)
+(use-method simple-dispatch nil #(-write *out* (pr-str nil)))
+(use-method simple-dispatch :default pprint-simple-default)
+
+(set-pprint-dispatch simple-dispatch)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Dispatch for the code table
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declare ^{:arglists '([alis])} pprint-simple-code-list)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Format the namespace ("ns") macro. This is quite complicated because of all the
+;;; different forms supported and because programmers can choose lists or vectors
+;;; in various places.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- brackets
+ "Figure out which kind of brackets to use"
+ [form]
+ (if (vector? form)
+ ["[" "]"]
+ ["(" ")"]))
+
+(defn- pprint-ns-reference
+ "Pretty print a single reference (import, use, etc.) from a namespace decl"
+ [reference]
+ (if (sequential? reference)
+ (let [[start end] (brackets reference)
+ [keyw & args] reference]
+ (pprint-logical-block :prefix start :suffix end
+ ((formatter-out "~w~:i") keyw)
+ (loop [args args]
+ (when (seq args)
+ ((formatter-out " "))
+ (let [arg (first args)]
+ (if (sequential? arg)
+ (let [[start end] (brackets arg)]
+ (pprint-logical-block :prefix start :suffix end
+ (if (and (= (count arg) 3) (keyword? (second arg)))
+ (let [[ns kw lis] arg]
+ ((formatter-out "~w ~w ") ns kw)
+ (if (sequential? lis)
+ ((formatter-out (if (vector? lis)
+ "~<[~;~@{~w~^ ~:_~}~;]~:>"
+ "~<(~;~@{~w~^ ~:_~}~;)~:>"))
+ lis)
+ (write-out lis)))
+ (apply (formatter-out "~w ~:i~@{~w~^ ~:_~}") arg)))
+ (when (next args)
+ ((formatter-out "~_"))))
+ (do
+ (write-out arg)
+ (when (next args)
+ ((formatter-out "~:_"))))))
+ (recur (next args))))))
+ (write-out reference)))
+
+(defn- pprint-ns
+ "The pretty print dispatch chunk for the ns macro"
+ [alis]
+ (if (next alis)
+ (let [[ns-sym ns-name & stuff] alis
+ [doc-str stuff] (if (string? (first stuff))
+ [(first stuff) (next stuff)]
+ [nil stuff])
+ [attr-map references] (if (map? (first stuff))
+ [(first stuff) (next stuff)]
+ [nil stuff])]
+ (pprint-logical-block :prefix "(" :suffix ")"
+ ((formatter-out "~w ~1I~@_~w") ns-sym ns-name)
+ (when (or doc-str attr-map (seq references))
+ ((formatter-out "~@:_")))
+ (when doc-str
+ (cl-format true "\"~a\"~:[~;~:@_~]" doc-str (or attr-map (seq references))))
+ (when attr-map
+ ((formatter-out "~w~:[~;~:@_~]") attr-map (seq references)))
+ (loop [references references]
+ (pprint-ns-reference (first references))
+ (when-let [references (next references)]
+ (pprint-newline :linear)
+ (recur references)))))
+ (write-out alis)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Format something that looks like a simple def (sans metadata, since the reader
+;;; won't give it to us now).
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def ^{:private true} pprint-hold-first (formatter-out "~:<~w~^ ~@_~w~^ ~_~@{~w~^ ~_~}~:>"))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Format something that looks like a defn or defmacro
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Format the params and body of a defn with a single arity
+(defn- single-defn [alis has-doc-str?]
+ (if (seq alis)
+ (do
+ (if has-doc-str?
+ ((formatter-out " ~_"))
+ ((formatter-out " ~@_")))
+ ((formatter-out "~{~w~^ ~_~}") alis))))
+
+;;; Format the param and body sublists of a defn with multiple arities
+(defn- multi-defn [alis has-doc-str?]
+ (if (seq alis)
+ ((formatter-out " ~_~{~w~^ ~_~}") alis)))
+
+;;; TODO: figure out how to support capturing metadata in defns (we might need a
+;;; special reader)
+(defn- pprint-defn [alis]
+ (if (next alis)
+ (let [[defn-sym defn-name & stuff] alis
+ [doc-str stuff] (if (string? (first stuff))
+ [(first stuff) (next stuff)]
+ [nil stuff])
+ [attr-map stuff] (if (map? (first stuff))
+ [(first stuff) (next stuff)]
+ [nil stuff])]
+ (pprint-logical-block :prefix "(" :suffix ")"
+ ((formatter-out "~w ~1I~@_~w") defn-sym defn-name)
+ (if doc-str
+ ((formatter-out " ~_~w") doc-str))
+ (if attr-map
+ ((formatter-out " ~_~w") attr-map))
+ ;; Note: the multi-defn case will work OK for malformed defns too
+ (cond
+ (vector? (first stuff)) (single-defn stuff (or doc-str attr-map))
+ :else (multi-defn stuff (or doc-str attr-map)))))
+ (pprint-simple-code-list alis)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Format something with a binding form
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- pprint-binding-form [binding-vec]
+ (pprint-logical-block :prefix "[" :suffix "]"
+ (print-length-loop [binding binding-vec]
+ (when (seq binding)
+ (pprint-logical-block binding
+ (write-out (first binding))
+ (when (next binding)
+ (-write *out* " ")
+ (pprint-newline :miser)
+ (write-out (second binding))))
+ (when (next (rest binding))
+ (-write *out* " ")
+ (pprint-newline :linear)
+ (recur (next (rest binding))))))))
+
+(defn- pprint-let [alis]
+ (let [base-sym (first alis)]
+ (pprint-logical-block :prefix "(" :suffix ")"
+ (if (and (next alis) (vector? (second alis)))
+ (do
+ ((formatter-out "~w ~1I~@_") base-sym)
+ (pprint-binding-form (second alis))
+ ((formatter-out " ~_~{~w~^ ~_~}") (next (rest alis))))
+ (pprint-simple-code-list alis)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Format something that looks like "if"
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def ^{:private true} pprint-if (formatter-out "~:<~1I~w~^ ~@_~w~@{ ~_~w~}~:>"))
+
+(defn- pprint-cond [alis]
+ (pprint-logical-block :prefix "(" :suffix ")"
+ (pprint-indent :block 1)
+ (write-out (first alis))
+ (when (next alis)
+ (-write *out* " ")
+ (pprint-newline :linear)
+ (print-length-loop [alis (next alis)]
+ (when alis
+ (pprint-logical-block alis
+ (write-out (first alis))
+ (when (next alis)
+ (-write *out* " ")
+ (pprint-newline :miser)
+ (write-out (second alis))))
+ (when (next (rest alis))
+ (-write *out* " ")
+ (pprint-newline :linear)
+ (recur (next (rest alis)))))))))
+
+(defn- pprint-condp [alis]
+ (if (> (count alis) 3)
+ (pprint-logical-block :prefix "(" :suffix ")"
+ (pprint-indent :block 1)
+ (apply (formatter-out "~w ~@_~w ~@_~w ~_") alis)
+ (print-length-loop [alis (seq (drop 3 alis))]
+ (when alis
+ (pprint-logical-block alis
+ (write-out (first alis))
+ (when (next alis)
+ (-write *out* " ")
+ (pprint-newline :miser)
+ (write-out (second alis))))
+ (when (next (rest alis))
+ (-write *out* " ")
+ (pprint-newline :linear)
+ (recur (next (rest alis)))))))
+ (pprint-simple-code-list alis)))
+
+;;; The map of symbols that are defined in an enclosing #() anonymous function
+(def ^:dynamic ^{:private true} *symbol-map* {})
+
+(defn- pprint-anon-func [alis]
+ (let [args (second alis)
+ nlis (first (rest (rest alis)))]
+ (if (vector? args)
+ (binding [*symbol-map* (if (= 1 (count args))
+ {(first args) "%"}
+ (into {}
+ (map
+ #(vector %1 (str \% %2))
+ args
+ (range 1 (inc (count args))))))]
+ ((formatter-out "~<#(~;~@{~w~^ ~_~}~;)~:>") nlis))
+ (pprint-simple-code-list alis))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; The master definitions for formatting lists in code (that is, (fn args...) or
+;;; special forms).
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; This is the equivalent of (formatter-out "~:<~1I~@{~w~^ ~_~}~:>"), but is
+;;; easier on the stack.
+
+(defn- pprint-simple-code-list [alis]
+ (pprint-logical-block :prefix "(" :suffix ")"
+ (pprint-indent :block 1)
+ (print-length-loop [alis (seq alis)]
+ (when alis
+ (write-out (first alis))
+ (when (next alis)
+ (-write *out* " ")
+ (pprint-newline :linear)
+ (recur (next alis)))))))
+
+;;; Take a map with symbols as keys and add versions with no namespace.
+;;; That is, if ns/sym->val is in the map, add sym->val to the result.
+(defn- two-forms [amap]
+ (into {}
+ (mapcat
+ identity
+ (for [x amap]
+ [x [(symbol (name (first x))) (second x)]]))))
+
+(defn- add-core-ns [amap]
+ (let [core "clojure.core"]
+ (into {}
+ (map #(let [[s f] %]
+ (if (not (or (namespace s) (special-symbol? s)))
+ [(symbol core (name s)) f]
+ %))
+ amap))))
+
+(def ^:dynamic ^{:private true} *code-table*
+ (two-forms
+ (add-core-ns
+ {'def pprint-hold-first, 'defonce pprint-hold-first,
+ 'defn pprint-defn, 'defn- pprint-defn, 'defmacro pprint-defn, 'fn pprint-defn,
+ 'let pprint-let, 'loop pprint-let, 'binding pprint-let,
+ 'with-local-vars pprint-let, 'with-open pprint-let, 'when-let pprint-let,
+ 'if-let pprint-let, 'doseq pprint-let, 'dotimes pprint-let,
+ 'when-first pprint-let,
+ 'if pprint-if, 'if-not pprint-if, 'when pprint-if, 'when-not pprint-if,
+ 'cond pprint-cond, 'condp pprint-condp,
+ 'fn* pprint-anon-func,
+ '. pprint-hold-first, '.. pprint-hold-first, '-> pprint-hold-first,
+ 'locking pprint-hold-first, 'struct pprint-hold-first,
+ 'struct-map pprint-hold-first, 'ns pprint-ns
+ })))
+
+(defn- pprint-code-list [alis]
+ (if-not (pprint-reader-macro alis)
+ (if-let [special-form (*code-table* (first alis))]
+ (special-form alis)
+ (pprint-simple-code-list alis))))
+
+(defn- pprint-code-symbol [sym]
+ (if-let [arg-num (sym *symbol-map*)]
+ (print arg-num)
+ (if *print-suppress-namespaces*
+ (print (name sym))
+ (pr sym))))
+
+(defmulti
+ code-dispatch
+ "The pretty print dispatch function for pretty printing Clojure code."
+ {:added "1.2" :arglists '[[object]]}
+ type-dispatcher)
+
+(use-method code-dispatch :list pprint-code-list)
+(use-method code-dispatch :symbol pprint-code-symbol)
+
+;; The following are all exact copies of simple-dispatch
+(use-method code-dispatch :vector pprint-vector)
+(use-method code-dispatch :map pprint-map)
+(use-method code-dispatch :set pprint-set)
+(use-method code-dispatch :queue pprint-pqueue)
+(use-method code-dispatch :deref pprint-ideref)
+(use-method code-dispatch nil pr)
+(use-method code-dispatch :default pprint-simple-default)
+
+(set-pprint-dispatch simple-dispatch)
+
+;;; For testing
+(comment
+
+ (with-pprint-dispatch code-dispatch
+ (pprint
+ '(defn cl-format
+ "An implementation of a Common Lisp compatible format function"
+ [stream format-in & args]
+ (let [compiled-format (if (string? format-in) (compile-format format-in) format-in)
+ navigator (init-navigator args)]
+ (execute-format stream compiled-format navigator)))))
+
+ (with-pprint-dispatch code-dispatch
+ (pprint
+ '(defn cl-format
+ [stream format-in & args]
+ (let [compiled-format (if (string? format-in) (compile-format format-in) format-in)
+ navigator (init-navigator args)]
+ (execute-format stream compiled-format navigator)))))
+
+ (with-pprint-dispatch code-dispatch
+ (pprint
+ '(defn- -write
+ ([this x]
+ (condp = (class x)
+ String
+ (let [s0 (write-initial-lines this x)
+ s (.replaceFirst s0 "\\s+$" "")
+ white-space (.substring s0 (count s))
+ mode (getf :mode)]
+ (if (= mode :writing)
+ (dosync
+ (write-white-space this)
+ (.col_write this s)
+ (setf :trailing-white-space white-space))
+ (add-to-buffer this (make-buffer-blob s white-space))))
+
+ Integer
+ (let [c ^Character x]
+ (if (= (getf :mode) :writing)
+ (do
+ (write-white-space this)
+ (.col_write this x))
+ (if (= c (int \newline))
+ (write-initial-lines this "\n")
+ (add-to-buffer this (make-buffer-blob (str (char c)) nil))))))))))
+
+ (with-pprint-dispatch code-dispatch
+ (pprint
+ '(defn pprint-defn [writer alis]
+ (if (next alis)
+ (let [[defn-sym defn-name & stuff] alis
+ [doc-str stuff] (if (string? (first stuff))
+ [(first stuff) (next stuff)]
+ [nil stuff])
+ [attr-map stuff] (if (map? (first stuff))
+ [(first stuff) (next stuff)]
+ [nil stuff])]
+ (pprint-logical-block writer :prefix "(" :suffix ")"
+ (cl-format true "~w ~1I~@_~w" defn-sym defn-name)
+ (if doc-str
+ (cl-format true " ~_~w" doc-str))
+ (if attr-map
+ (cl-format true " ~_~w" attr-map))
+ ;; Note: the multi-defn case will work OK for malformed defns too
+ (cond
+ (vector? (first stuff)) (single-defn stuff (or doc-str attr-map))
+ :else (multi-defn stuff (or doc-str attr-map)))))
+ (pprint-simple-code-list writer alis)))))
+ )
+
+;;======================================================================
+;; print_table.clj
+;;======================================================================
+
+(defn- add-padding [width s]
+ (let [padding (max 0 (- width (count s)))]
+ (apply str (clojure.string/join (repeat padding \space)) s)))
+
+(defn print-table
+ "Prints a collection of maps in a textual table. Prints table headings
+ ks, and then a line of output for each row, corresponding to the keys
+ in ks. If ks are not specified, use the keys of the first item in rows."
+ {:added "1.3"}
+ ([ks rows]
+ (when (seq rows)
+ (let [widths (map
+ (fn [k]
+ (apply max (count (str k)) (map #(count (str (get % k))) rows)))
+ ks)
+ spacers (map #(apply str (repeat % "-")) widths)
+ fmt-row (fn [leader divider trailer row]
+ (str leader
+ (apply str (interpose divider
+ (for [[col width] (map vector (map #(get row %) ks) widths)]
+ (add-padding width (str col)))))
+ trailer))]
+ (cljs.core/println)
+ (cljs.core/println (fmt-row "| " " | " " |" (zipmap ks ks)))
+ (cljs.core/println (fmt-row "|-" "-+-" "-|" (zipmap ks spacers)))
+ (doseq [row rows]
+ (cljs.core/println (fmt-row "| " " | " " |" row))))))
+ ([rows] (print-table (keys (first rows)) rows)))
diff --git a/src/main/cljs/cljs/proxy.cljs b/src/main/cljs/cljs/proxy.cljs
new file mode 100644
index 0000000000..23a85a9f77
--- /dev/null
+++ b/src/main/cljs/cljs/proxy.cljs
@@ -0,0 +1,184 @@
+; 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.proxy
+ (:refer-global :only [isNaN Proxy Symbol])
+ (:require [cljs.proxy.impl :refer [SimpleCache MapIterator]]))
+
+(defn- write-through [f]
+ (let [cache (SimpleCache. #js {} 0)]
+ (fn [x]
+ (let [v (.get cache x)]
+ (if (some? v)
+ v
+ (.set cache x (f x)))))))
+
+(def ^{:private true}
+ desc
+ #js {:configurable true
+ :enumerable true})
+
+(defn builder
+ "EXPERIMENTAL: Returns a JavaScript Proxy ctor fn with the provided
+ key-fn. Invoking the returned fn on ClojureScript maps and vectors
+ will returned proxied values that can be used transparently as
+ JavaScript objects and arrays:
+
+ (def proxy (builder))
+
+ (def proxied-map (proxy {:foo 1 :bar 2}))
+ (goog.object/get proxied-map \"foo\") ;; => 1
+
+ (def proxied-vec (proxy [1 2 3 4]))
+ (aget proxied-vec 1) ;; => 2
+
+ Access patterns from JavaScript on these proxied values will lazily,
+ recursively return further proxied values:
+
+ (def nested-proxies (proxy [{:foo 1 :bar 2}]))
+ (-> nested-proxies (aget 0) (goog.object/get \"foo\")) ;; => 1
+
+ Note key-fn is only used for proxied ClojureScript maps. This
+ function should map strings to the appropriate key
+ representation. If unspecified, key-fn defaults to keyword. All maps
+ proxied from the same ctor fn will share the same key-fn cache.
+
+ A cache-fn may be suppled to override the default cache. This fn
+ should take key-fn and return a memoized version."
+ ([]
+ (builder keyword))
+ ([key-fn]
+ (builder keyword write-through))
+ ([key-fn cache-fn]
+ (js* "var __ctor")
+ (let [cache-key-fn (cache-fn key-fn)
+ vec-handler #js {:get (fn [^cljs.core/IIndexed target prop receiver]
+ (cond
+ (identical? "length" prop)
+ (-count ^cljs.core/ICounted target)
+
+ (identical? (. Symbol -iterator) prop)
+ (fn []
+ (MapIterator.
+ ((.bind (unchecked-get target prop) target)) js/__ctor))
+
+ :else
+ (let [n (js* "+~{}" prop)]
+ (when (and (number? n)
+ (not (isNaN n)))
+ (js/__ctor (-nth target n nil))))))
+
+ :has (fn [^cljs.core/IAssociative target prop]
+ (cond
+ (identical? prop "length") true
+
+ (identical? (. Symbol -iterator) prop) true
+
+ :else
+ (let [n (js* "+~{}" prop)]
+ (and (number? n)
+ (not (isNaN n))
+ (<= 0 n)
+ (< n (-count ^cljs.core/ICounted target))))))
+
+ :getPrototypeOf
+ (fn [target] nil)
+
+ :ownKeys
+ (fn [target] #js ["length"])
+
+ :getOwnPropertyDescriptor
+ (fn [target prop] desc)}
+ map-handler #js {:get (fn [^cljs.core/ILookup target prop receiver]
+ (js/__ctor (-lookup target (cache-key-fn prop))))
+
+ :has (fn [^cljs.core/IAssociative target prop]
+ (-contains-key? target (cache-key-fn prop)))
+
+ :getPrototypeOf
+ (fn [target] nil)
+
+ :ownKeys
+ (fn [target]
+ (when (nil? (.-cljs$cachedOwnKeys target))
+ (set! (. target -cljs$cachedOwnKeys)
+ (into-array (map -name (keys target)))))
+ (.-cljs$cachedOwnKeys target))
+
+ :getOwnPropertyDescriptor
+ (fn [target prop] desc)}
+ __ctor (fn [target]
+ (cond
+ (implements? IMap target) (Proxy. target map-handler)
+ (implements? IVector target) (Proxy. target vec-handler)
+ :else target))]
+ __ctor)))
+
+(def ^{:doc "Default proxy for maps and vectors."}
+ proxy (builder))
+
+(comment
+
+ (def c (SimpleCache. #js {} 0))
+ (.set c "foo" :foo)
+ (.get c "foo")
+ (.-cnt c)
+ (.clear c)
+ (.get c "foo")
+
+ (def kw (write-through keyword))
+ (kw "foo")
+
+ (time
+ (dotimes [i 1e6]
+ (kw "foo")))
+
+ (time
+ (dotimes [i 1e6]
+ (keyword "foo")))
+
+ (def proxy (builder))
+
+ (def raw-map {:foo 1 :bar 2})
+ (def proxied-map (proxy {:foo 1 :bar 2}))
+
+ (require '[goog.object :as gobj])
+ (gobj/get proxied-map "foo")
+ (gobj/get proxied-map "bar")
+ (gobj/getKeys proxied-map)
+ (.keys js/Object proxied-map)
+
+ (time
+ (dotimes [i 1e7]
+ (unchecked-get proxied-map "foo")))
+
+ (def k :foo)
+ (time
+ (dotimes [i 1e7]
+ (get raw-map k)))
+
+ (def proxied-vec (proxy [1 2 3 4]))
+ (alength proxied-vec)
+ (time
+ (dotimes [i 1e6]
+ (alength proxied-vec)))
+
+ (nth [1 2 3 4] 1)
+
+ (aget proxied-vec 1)
+
+ (time
+ (dotimes [i 1e7]
+ (aget proxied-vec 1)))
+
+ (def proxied-deep (proxy [{:foo "Hello"}]))
+ (-> proxied-deep (aget 0) (unchecked-get "foo"))
+
+ (aget ((cljs.proxy/builder) [{}]) 0)
+
+)
diff --git a/src/main/cljs/cljs/proxy/impl.cljs b/src/main/cljs/cljs/proxy/impl.cljs
new file mode 100644
index 0000000000..c476529314
--- /dev/null
+++ b/src/main/cljs/cljs/proxy/impl.cljs
@@ -0,0 +1,32 @@
+; 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.proxy.impl)
+
+(deftype SimpleCache [^:mutable obj ^:mutable cnt]
+ Object
+ (set [this k v]
+ (when (== cnt 1024)
+ (.clear this))
+ (unchecked-set obj k v)
+ (set! cnt (inc cnt))
+ v)
+ (get [this k]
+ (unchecked-get obj k))
+ (clear [this]
+ (set! obj #js {})
+ (set! cnt 0)))
+
+(deftype MapIterator [^:mutable iter f]
+ Object
+ (next [_]
+ (let [x (.next iter)]
+ (if-not ^boolean (. x -done)
+ #js {:value (f (. x -value))
+ :done false}
+ x))))
diff --git a/src/main/cljs/cljs/reader.clj b/src/main/cljs/cljs/reader.clj
new file mode 100644
index 0000000000..09afd3a533
--- /dev/null
+++ b/src/main/cljs/cljs/reader.clj
@@ -0,0 +1,18 @@
+;; 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.reader
+ (:require [cljs.env :as env]))
+
+(defmacro add-data-readers [default-readers]
+ (let [data-readers
+ (->> (get @env/*compiler* :cljs.analyzer/data-readers)
+ (map (fn [[k v]]
+ `['~k (fn [x#] (~(vary-meta (-> v meta :sym) assoc :cljs.analyzer/no-resolve true) x#))]))
+ (into {}))]
+ `(do (merge ~default-readers ~data-readers))))
diff --git a/src/main/cljs/cljs/reader.cljs b/src/main/cljs/cljs/reader.cljs
new file mode 100644
index 0000000000..964f6be313
--- /dev/null
+++ b/src/main/cljs/cljs/reader.cljs
@@ -0,0 +1,214 @@
+; 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.reader
+ (:require-macros [cljs.reader :refer [add-data-readers]])
+ (:require [goog.object :as gobject]
+ [cljs.tools.reader :as treader]
+ [cljs.tools.reader.edn :as edn])
+ (:import [goog.string StringBuffer]))
+
+(defn ^:private zero-fill-right-and-truncate [s width]
+ (cond
+ (= width (count s)) s
+ (< width (count s)) (subs s 0 width)
+ :else
+ (loop [b (StringBuffer. s)]
+ (if (< (.getLength b) width)
+ (recur (.append b "0"))
+ (.toString b)))))
+
+(defn ^:private divisible?
+ [num div]
+ (zero? (mod num div)))
+
+(defn ^:private indivisible?
+ [num div]
+ (not (divisible? num div)))
+
+(defn ^:private leap-year?
+ [year]
+ (and (divisible? year 4)
+ (or (indivisible? year 100)
+ (divisible? year 400))))
+
+(def ^:private days-in-month
+ (let [dim-norm [nil 31 28 31 30 31 30 31 31 30 31 30 31]
+ dim-leap [nil 31 29 31 30 31 30 31 31 30 31 30 31]]
+ (fn [month leap-year?]
+ (get (if leap-year? dim-leap dim-norm) month))))
+
+(def ^:private timestamp-regex #"(\d\d\d\d)(?:-(\d\d)(?:-(\d\d)(?:[T](\d\d)(?::(\d\d)(?::(\d\d)(?:[.](\d+))?)?)?)?)?)?(?:[Z]|([-+])(\d\d):(\d\d))?")
+
+(defn ^:private parse-int [s]
+ (let [n (js/parseInt s 10)]
+ (if-not (js/isNaN n)
+ n)))
+
+(defn ^:private check [low n high msg]
+ (when-not (<= low n high)
+ (throw (js/Error. (str msg " Failed: " low "<=" n "<=" high))))
+ n)
+
+(defn parse-and-validate-timestamp [s]
+ (let [[_ years months days hours minutes seconds fraction offset-sign offset-hours offset-minutes :as v]
+ (re-matches timestamp-regex s)]
+ (if-not v
+ (throw (js/Error. (str "Unrecognized date/time syntax: " s)))
+ (let [years (parse-int years)
+ months (or (parse-int months) 1)
+ days (or (parse-int days) 1)
+ hours (or (parse-int hours) 0)
+ minutes (or (parse-int minutes) 0)
+ seconds (or (parse-int seconds) 0)
+ fraction (or (parse-int (zero-fill-right-and-truncate fraction 3)) 0)
+ offset-sign (if (= offset-sign "-") -1 1)
+ offset-hours (or (parse-int offset-hours) 0)
+ offset-minutes (or (parse-int offset-minutes) 0)
+ offset (* offset-sign (+ (* offset-hours 60) offset-minutes))]
+ [years
+ (check 1 months 12 "timestamp month field must be in range 1..12")
+ (check 1 days (days-in-month months (leap-year? years)) "timestamp day field must be in range 1..last day in month")
+ (check 0 hours 23 "timestamp hour field must be in range 0..23")
+ (check 0 minutes 59 "timestamp minute field must be in range 0..59")
+ (check 0 seconds (if (= minutes 59) 60 59) "timestamp second field must be in range 0..60")
+ (check 0 fraction 999 "timestamp millisecond field must be in range 0..999")
+ offset]))))
+
+(defn parse-timestamp
+ [ts]
+ (if-let [[years months days hours minutes seconds ms offset]
+ (parse-and-validate-timestamp ts)]
+ (js/Date.
+ (- (.UTC js/Date years (dec months) days hours minutes seconds ms)
+ (* offset 60 1000)))
+ (throw (js/Error. (str "Unrecognized date/time syntax: " ts)))))
+
+(defn ^:private read-date
+ [s]
+ (if (string? s)
+ (parse-timestamp s)
+ (throw (js/Error. "Instance literal expects a string for its timestamp."))))
+
+(defn ^:private read-queue
+ [elems]
+ (if (vector? elems)
+ (into cljs.core/PersistentQueue.EMPTY elems)
+ (throw (js/Error. "Queue literal expects a vector for its elements."))))
+
+(defn ^:private read-js
+ [form]
+ (cond
+ (vector? form)
+ (let [arr (array)]
+ (doseq [x form]
+ (.push arr x))
+ arr)
+
+ (map? form)
+ (let [obj (js-obj)]
+ (doseq [[k v] form]
+ (gobject/set obj (name k) v))
+ obj)
+
+ :else
+ (throw
+ (js/Error.
+ (str "JS literal expects a vector or map containing "
+ "only string or unqualified keyword keys")))))
+
+(defn ^:private read-uuid
+ [uuid]
+ (if (string? uuid)
+ (cljs.core/uuid uuid)
+ (throw (js/Error. "UUID literal expects a string as its representation."))))
+
+(def ^:dynamic *default-data-reader-fn*
+ (atom nil))
+
+(def ^:dynamic *tag-table*
+ (atom
+ (add-data-readers
+ {'inst read-date
+ 'uuid read-uuid
+ 'queue read-queue
+ 'js read-js})))
+
+(defn read
+ "Reads the first object from an cljs.tools.reader.reader-types/IPushbackReader.
+ Returns the object read. If EOF, throws if eof-error? is true otherwise returns eof.
+ If no reader is provided, *in* will be used.
+
+ Reads data in the edn format (subset of Clojure data):
+ http://edn-format.org
+
+ cljs.tools.reader.edn/read doesn't depend on dynamic Vars, all configuration
+ is done by passing an opt map.
+
+ opts is a map that can include the following keys:
+ :eof - value to return on end-of-file. When not supplied, eof throws an exception.
+ :readers - a map of tag symbols to data-reader functions to be considered before default-data-readers.
+ When not supplied, only the default-data-readers will be used.
+ :default - A function of two args, that will, if present and no reader is found for a tag,
+ be called with the tag and the value."
+ ([reader]
+ (edn/read
+ {:readers @*tag-table*
+ :default @*default-data-reader-fn*
+ :eof nil}
+ reader))
+ ([{:keys [eof] :as opts} reader]
+ (edn/read
+ (update (merge opts {:default @*default-data-reader-fn*})
+ :readers (fn [m] (merge @*tag-table* m))) reader))
+ ([reader eof-error? eof opts]
+ (edn/read reader eof-error? eof
+ (update (merge opts {:default @*default-data-reader-fn*})
+ :readers (fn [m] (merge @*tag-table* m))))))
+
+(defn read-string
+ "Reads one object from the string s.
+ Returns nil when s is nil or empty.
+
+ Reads data in the edn format (subset of Clojure data):
+ http://edn-format.org
+
+ opts is a map as per cljs.tools.reader.edn/read"
+ ([s]
+ (edn/read-string
+ {:readers @*tag-table*
+ :default @*default-data-reader-fn*
+ :eof nil} s))
+ ([opts s]
+ (edn/read-string
+ (update (merge {:default @*default-data-reader-fn*} opts)
+ :readers (fn [m] (merge @*tag-table* m))) s)))
+
+(defn register-tag-parser!
+ [tag f]
+ (let [old-parser (get @*tag-table* tag)]
+ (swap! *tag-table* assoc tag f)
+ old-parser))
+
+(defn deregister-tag-parser!
+ [tag]
+ (let [old-parser (get @*tag-table* tag)]
+ (swap! *tag-table* dissoc tag)
+ old-parser))
+
+(defn register-default-tag-parser!
+ [f]
+ (let [old-parser @*default-data-reader-fn*]
+ (swap! *default-data-reader-fn* (fn [_] f))
+ old-parser))
+
+(defn deregister-default-tag-parser!
+ []
+ (let [old-parser @*default-data-reader-fn*]
+ (swap! *default-data-reader-fn* (fn [_] nil))
+ old-parser))
diff --git a/src/main/cljs/cljs/repl.cljs b/src/main/cljs/cljs/repl.cljs
new file mode 100644
index 0000000000..16116ea468
--- /dev/null
+++ b/src/main/cljs/cljs/repl.cljs
@@ -0,0 +1,206 @@
+;; 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.repl
+ (:require-macros cljs.repl)
+ (:require [cljs.spec.alpha :as spec]
+ [goog.string :as gstring]
+ [goog.string.format]))
+
+(defn print-doc [{n :ns nm :name :as m}]
+ (println "-------------------------")
+ (println (or (:spec m) (str (when-let [ns (:ns m)] (str ns "/")) (:name m))))
+ (when (:protocol m)
+ (println "Protocol"))
+ (cond
+ (:forms m) (doseq [f (:forms m)]
+ (println " " f))
+ (:arglists m) (let [arglists (:arglists m)]
+ (if (or (:macro m)
+ (:repl-special-function m))
+ (prn arglists)
+ (prn
+ (if (= 'quote (first arglists))
+ (second arglists)
+ arglists)))))
+ (if (:special-form m)
+ (do
+ (println "Special Form")
+ (println " " (:doc m))
+ (if (contains? m :url)
+ (when (:url m)
+ (println (str "\n Please see http://clojure.org/" (:url m))))
+ (println (str "\n Please see http://clojure.org/special_forms#"
+ (:name m)))))
+ (do
+ (when (:macro m)
+ (println "Macro"))
+ (when (:spec m)
+ (println "Spec"))
+ (when (:repl-special-function m)
+ (println "REPL Special Function"))
+ (println " " (:doc m))
+ (when (:protocol m)
+ (doseq [[name {:keys [doc arglists]}] (:methods m)]
+ (println)
+ (println " " name)
+ (println " " arglists)
+ (when doc
+ (println " " doc))))
+ (when n
+ (when-let [fnspec (spec/get-spec (symbol (str (ns-name n)) (name nm)))]
+ (print "Spec")
+ (doseq [role [:args :ret :fn]]
+ (when-let [spec (get fnspec role)]
+ (print (str "\n " (name role) ":") (spec/describe spec)))))))))
+
+(defn Error->map
+ "Constructs a data representation for a Error with keys:
+ :cause - root cause message
+ :phase - error phase
+ :via - cause chain, with cause keys:
+ :type - exception class symbol
+ :message - exception message
+ :data - ex-data
+ :at - top stack element
+ :trace - root cause stack elements"
+ [o]
+ (Throwable->map o))
+
+(defn ex-triage
+ "Returns an analysis of the phase, error, cause, and location of an error that occurred
+ based on Throwable data, as returned by Throwable->map. All attributes other than phase
+ are optional:
+ :clojure.error/phase - keyword phase indicator, one of:
+ :read-source :compile-syntax-check :compilation :macro-syntax-check :macroexpansion
+ :execution :read-eval-result :print-eval-result
+ :clojure.error/source - file name (no path)
+ :clojure.error/line - integer line number
+ :clojure.error/column - integer column number
+ :clojure.error/symbol - symbol being expanded/compiled/invoked
+ :clojure.error/class - cause exception class symbol
+ :clojure.error/cause - cause exception message
+ :clojure.error/spec - explain-data for spec error"
+ [datafied-throwable]
+ (let [{:keys [via trace phase] :or {phase :execution}} datafied-throwable
+ {:keys [type message data]} (last via)
+ {:cljs.spec.alpha/keys [problems fn] :cljs.spec.test.alpha/keys [caller]} data
+ {:keys [:clojure.error/source] :as top-data} (:data (first via))]
+ (assoc
+ (case phase
+ :read-source
+ (let [{:keys [:clojure.error/line :clojure.error/column]} data]
+ (cond-> (merge (-> via second :data) top-data)
+ source (assoc :clojure.error/source source)
+ (#{"NO_SOURCE_FILE" "NO_SOURCE_PATH"} source) (dissoc :clojure.error/source)
+ message (assoc :clojure.error/cause message)))
+
+ (:compile-syntax-check :compilation :macro-syntax-check :macroexpansion)
+ (cond-> top-data
+ source (assoc :clojure.error/source source)
+ (#{"NO_SOURCE_FILE" "NO_SOURCE_PATH"} source) (dissoc :clojure.error/source)
+ type (assoc :clojure.error/class type)
+ message (assoc :clojure.error/cause message)
+ problems (assoc :clojure.error/spec data))
+
+ (:read-eval-result :print-eval-result)
+ (let [[source method file line] (-> trace first)]
+ (cond-> top-data
+ line (assoc :clojure.error/line line)
+ file (assoc :clojure.error/source file)
+ (and source method) (assoc :clojure.error/symbol (vector #_java-loc->source source method))
+ type (assoc :clojure.error/class type)
+ message (assoc :clojure.error/cause message)))
+
+ :execution
+ (let [[source method file line] (->> trace #_(drop-while #(core-class? (name (first %)))) first)
+ file (first (remove #(or (nil? %) (#{"NO_SOURCE_FILE" "NO_SOURCE_PATH"} %)) [(:file caller) file]))
+ err-line (or (:line caller) line)]
+ (cond-> {:clojure.error/class type}
+ err-line (assoc :clojure.error/line err-line)
+ message (assoc :clojure.error/cause message)
+ (or fn (and source method)) (assoc :clojure.error/symbol (or fn (vector #_java-loc->source source method)))
+ file (assoc :clojure.error/source file)
+ problems (assoc :clojure.error/spec data))))
+ :clojure.error/phase phase)))
+
+(defn ex-str
+ "Returns a string from exception data, as produced by ex-triage.
+ The first line summarizes the exception phase and location.
+ The subsequent lines describe the cause."
+ [{:clojure.error/keys [phase source line column symbol class cause spec] :as triage-data}]
+ (let [loc (str (or source "