Browse files

Merge branch 'master' into tagged-literals

  • Loading branch information...
2 parents b64cd90 + 0032805 commit 8444ce18469b4b7f81599bd0f498e2859792b23d @fogus fogus committed May 11, 2012
View
69 pom.template.xml
@@ -25,12 +25,12 @@
<dependency>
<groupId>com.google.javascript</groupId>
<artifactId>closure-compiler</artifactId>
- <version>r1592</version>
+ <version>r1918</version>
</dependency>
<dependency>
<groupId>org.clojure</groupId>
<artifactId>google-closure-library</artifactId>
- <version>0.0-790</version>
+ <version>0.0-1376</version>
</dependency>
<dependency>
<groupId>org.mozilla</groupId>
@@ -40,33 +40,44 @@
</dependencies>
<developers>
- <developer><id>abedra</id><name>Aaron Bedra</name></developer>
- <developer><id>alandipert</id><name>Alan Dipert</name></developer>
- <developer><id>amalloy</id><name>Alan Malloy</name></developer>
- <developer><id>aredington</id><name>Alex Redington</name></developer>
- <developer><id>billdozr</id><name>Alen Ribic</name></developer>
- <developer><id>bobby</id><name>Bobby Calderwood</name></developer>
- <developer><id>brentonashworth</id><name>Brenton Ashworth</name></developer>
- <developer><id>Chouser</id><name>Chris Houser</name></developer>
- <developer><id>devn</id><name>Devin Walters</name></developer>
- <developer><id>ffailla</id><name>Frank Failla</name></developer>
- <developer><id>fogus</id><name>Fogus</name></developer>
- <developer><id>hozumi</id><name>Takahiro Hozumi</name></developer>
- <developer><id>hugoduncan</id><name>Hugo Duncan</name></developer>
- <developer><id>jessmartin</id><name>Jess Martin</name></developer>
- <developer><id>jli</id><name>John Li</name></developer>
- <developer><id>juergenhoetzel</id><name>Jürgen Hötzel</name></developer>
- <developer><id>levand</id><name>Luke VanderHart</name></developer>
- <developer><id>lynaghk</id><name>Kevin Lynagh</name></developer>
- <developer><id>michalmarczyk</id><name>Micha Marczyk</name></developer>
- <developer><id>pmbauer</id><name>Paul Michael Bauer</name></developer>
- <developer><id>redinger</id><name>Christopher</name></developer>
- <developer><id>richhickey</id><name>Rich Hickey</name></developer>
- <developer><id>stuarthalloway</id><name>Stuart Halloway</name></developer>
- <developer><id>stuartsierra</id><name>Stuart Sierra</name></developer>
- <developer><id>swannodette</id><name>David Nolen</name></developer>
- <developer><id>thickey</id><name>Tom Hickey</name></developer>
- <developer><id>wilkes</id><name>Wilkes Joiner</name></developer>
+ <developer><name>Aaron Bedra</name></developer>
+ <developer><name>Alan Dipert</name></developer>
+ <developer><name>Alan Malloy</name></developer>
+ <developer><name>Alen Ribic</name></developer>
+ <developer><name>Alex Redington</name></developer>
+ <developer><name>Bobby Calderwood</name></developer>
+ <developer><name>Brandon Bloom</name></developer>
+ <developer><name>Brenton Ashworth</name></developer>
+ <developer><name>Chris Houser</name></developer>
+ <developer><name>Christopher Redinger</name></developer>
+ <developer><name>Creighton Kirkendall</name></developer>
+ <developer><name>David Nolen</name></developer>
+ <developer><name>Devin Walters</name></developer>
+ <developer><name>Eric Thorsen</name></developer>
+ <developer><name>Frank Failla</name></developer>
+ <developer><name>Hubert Iwaniuk</name></developer>
+ <developer><name>Hugo Duncan</name></developer>
+ <developer><name>Jess Martin</name></developer>
+ <developer><name>John Li</name></developer>
+ <developer><name>Jonas Enlund</name></developer>
+ <developer><name>Juergen Hoetzel</name></developer>
+ <developer><name>Kevin J. Lynagh</name></developer>
+ <developer><name>Laszlo Toeroek</name></developer>
+ <developer><name>Luke VanderHart</name></developer>
+ <developer><name>Michael Fogus</name></developer>
+ <developer><name>Michał Marczyk</name></developer>
+ <developer><name>Moritz Ulrich</name></developer>
+ <developer><name>Nicola Mometto</name></developer>
+ <developer><name>Paul Michael Bauer</name></developer>
+ <developer><name>Rich Hickey</name></developer>
+ <developer><name>Roman Gonzalez</name></developer>
+ <developer><name>Russ Olsen</name></developer>
+ <developer><name>Stuart Halloway</name></developer>
+ <developer><name>Stuart Sierra</name></developer>
+ <developer><name>Takahiro Hozumi</name></developer>
+ <developer><name>Thomas Scheiblauer</name></developer>
+ <developer><name>Tom Hickey</name></developer>
+ <developer><name>Wilkes Joiner</name></developer>
</developers>
<scm>
View
47 src/clj/cljs/compiler.clj
@@ -676,6 +676,15 @@
(emitln "continue;")
(emitln "}")))
+(defmethod emit :letfn
+ [{:keys [bindings statements ret env]}]
+ (let [context (:context env)]
+ (when (= :expr context) (emits "(function (){"))
+ (doseq [{:keys [name init]} bindings]
+ (emitln "var " name " = " init ";"))
+ (emit-block (if (= :expr context) :return context) statements ret)
+ (when (= :expr context) (emits "})()"))))
+
(defmethod emit :invoke
[{:keys [f args env]}]
(let [fn? (and *cljs-static-fns*
@@ -804,7 +813,7 @@
(declare analyze analyze-symbol analyze-seq)
-(def specials '#{if def fn* do let* loop* throw try* recur new set! ns deftype* defrecord* . js* & quote})
+(def specials '#{if def fn* do let* loop* letfn* throw try* recur new set! ns deftype* defrecord* . js* & quote})
(def ^:dynamic *recur-frames* nil)
(def ^:dynamic *loop-lets* nil)
@@ -988,6 +997,42 @@
:children (vec (mapcat block-children
methods))}))
+(defmethod parse 'letfn*
+ [op env [_ bindings & exprs :as form] name]
+ (assert (and (vector? bindings) (even? (count bindings))) "bindings must be vector of even number of elements")
+ (let [n->fexpr (into {} (map (juxt first second) (partition 2 bindings)))
+ names (keys n->fexpr)
+ n->gsym (into {} (map (juxt identity #(gensym (str (munge %) "__"))) names))
+ gsym->n (into {} (map (juxt n->gsym identity) names))
+ context (:context env)
+ bes (reduce (fn [bes n]
+ (let [g (n->gsym n)]
+ (conj bes {:name g
+ :tag (-> n meta :tag)
+ :local true})))
+ []
+ names)
+ meth-env (reduce (fn [env be]
+ (let [n (gsym->n (be :name))]
+ (assoc-in env [:locals n] be)))
+ (assoc env :context :expr)
+ bes)
+ [meth-env finits]
+ (reduce (fn [[env finits] n]
+ (let [finit (analyze meth-env (n->fexpr n))
+ be (-> (get-in env [:locals n])
+ (assoc :init finit))]
+ [(assoc-in env [:locals n] be)
+ (conj finits finit)]))
+ [meth-env []]
+ names)
+ {:keys [statements ret]}
+ (analyze-block (assoc meth-env :context (if (= :expr context) :return context)) exprs)
+ bes (vec (map #(get-in meth-env [:locals %]) names))]
+ {:env env :op :letfn :bindings bes :statements statements :ret ret :form form
+ :children (into (vec (map :init bes))
+ (conj (vec statements) ret))}))
+
(defmethod parse 'do
[op env [_ & exprs :as form] _]
(let [block (analyze-block env exprs)]
View
42 src/clj/cljs/core.clj
@@ -20,7 +20,8 @@
aget aset
+ - * / < <= > >= == zero? pos? neg? inc dec max min mod
bit-and bit-and-not bit-clear bit-flip bit-not bit-or bit-set
- bit-test bit-shift-left bit-shift-right bit-xor]))
+ bit-test bit-shift-left bit-shift-right bit-xor])
+ (:require clojure.walk))
(alias 'core 'clojure.core)
@@ -249,6 +250,39 @@
(set! ~hash-key h#)
h#))))
+;;; internal -- reducers-related macros
+
+(defn- do-curried
+ [name doc meta args body]
+ (let [cargs (vec (butlast args))]
+ `(defn ~name ~doc ~meta
+ (~cargs (fn [x#] (~name ~@cargs x#)))
+ (~args ~@body))))
+
+(defmacro ^:private defcurried
+ "Builds another arity of the fn that returns a fn awaiting the last
+ param"
+ [name doc meta args & body]
+ (do-curried name doc meta args body))
+
+(defn- do-rfn [f1 k fkv]
+ `(fn
+ ([] (~f1))
+ ~(clojure.walk/postwalk
+ #(if (sequential? %)
+ ((if (vector? %) vec identity)
+ (core/remove #{k} %))
+ %)
+ fkv)
+ ~fkv))
+
+(defmacro ^:private rfn
+ "Builds 3-arity reducing fn given names of wrapped fn and key, and k/v impl."
+ [[f1 k] fkv]
+ (do-rfn f1 k fkv))
+
+;;; end of reducers macros
+
(defn- protocol-prefix [psym]
(core/str (.replace (core/str psym) \. \$) "$"))
@@ -641,9 +675,9 @@
(last clauses)
`(throw (js/Error. (core/str "No matching clause: " ~e))))
pairs (partition 2 clauses)]
- `(condp = ~e
- ~@(apply concat pairs)
- ~default)))
+ `(cond
+ ~@(mapcat (fn [[m c]] `((identical? ~m ~e) ~c)) pairs)
+ :else ~default)))
(defmacro try
"(try expr* catch-clause* finally-clause?)
View
179 src/cljs/cljs/reader.cljs
@@ -21,7 +21,7 @@ nil if the end of stream has been reached")
(if (empty? @buffer-atom)
(let [idx @index-atom]
(swap! index-atom inc)
- (nth s idx))
+ (aget s idx))
(let [buf @buffer-atom]
(swap! buffer-atom rest)
(first buf))))
@@ -35,22 +35,22 @@ nil if the end of stream has been reached")
;; predicates
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defn- whitespace?
+(defn- ^boolean whitespace?
"Checks whether a given character is whitespace"
[ch]
(or (gstring/isBreakingWhitespace ch) (identical? \, ch)))
-(defn- numeric?
+(defn- ^boolean numeric?
"Checks whether a given character is numeric"
[ch]
(gstring/isNumeric ch))
-(defn- comment-prefix?
+(defn- ^boolean comment-prefix?
"Checks whether the character begins a comment."
[ch]
(identical? \; ch))
-(defn- number-literal?
+(defn- ^boolean number-literal?
"Checks whether the reader is at the start of a number literal"
[reader initch]
(or (numeric? initch)
@@ -70,8 +70,11 @@ nil if the end of stream has been reached")
[rdr & msg]
(throw (apply str msg)))
-(defn macro-terminating? [ch]
- (and (not= ch "#") (not= ch \') (not= ch ":") (contains? macros ch)))
+(defn ^boolean macro-terminating? [ch]
+ (and (coercive-not= ch "#")
+ (coercive-not= ch \')
+ (coercive-not= ch ":")
+ (macros ch)))
(defn read-token
[rdr initch]
@@ -97,50 +100,73 @@ nil if the end of stream has been reached")
(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 (coercive-not= matches nil)
+ (if (== (alength matches) 1)
+ (aget matches 0)
+ matches))))
+
(defn- match-int
[s]
- (let [groups (re-find int-pattern s)
- group3 (nth groups 2)]
- (if (not (or (undefined? group3)
- (< (.-length group3) 1)))
+ (let [groups (re-find* int-pattern s)
+ group3 (aget groups 2)]
+ (if (coercive-not
+ (or (nil? group3)
+ (< (alength group3) 1)))
0
- (let [negate (if (identical? "-" (nth groups 1)) -1 1)
- [n radix] (cond
- (nth groups 3) [(nth groups 3) 10]
- (nth groups 4) [(nth groups 4) 16]
- (nth groups 5) [(nth groups 5) 8]
- (nth groups 7) [(nth groups 7) (js/parseInt (nth groups 7))]
- :default [nil nil])]
+ (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 (nth groups 1)
- denominator (nth groups 2)]
+ (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 (coercive-not= matches nil)
+ (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)))
-
-(def escape-char-map {\t "\t"
- \r "\r"
- \n "\n"
- \\ \\
- \" \"
- \b "\b"
- \f "\f"})
+ (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]
+ (case c
+ \t "\t"
+ \r "\r"
+ \n "\n"
+ \\ \\
+ \" \"
+ \b "\b"
+ \f "\f"
+ nil))
(defn read-unicode-char
[reader initch]
@@ -149,7 +175,7 @@ nil if the end of stream has been reached")
(defn escape-char
[buffer reader]
(let [ch (read-char reader)
- mapresult (get escape-char-map ch)]
+ mapresult (escape-char-map ch)]
(if mapresult
mapresult
(if (or (identical? \u ch) (numeric? ch))
@@ -167,18 +193,18 @@ nil if the end of stream has been reached")
(defn read-delimited-list
[delim rdr recursive?]
- (loop [a []]
+ (loop [a (transient [])]
(let [ch (read-past whitespace? rdr)]
(when-not ch (reader-error rdr "EOF"))
(if (identical? delim ch)
- a
- (if-let [macrofn (get macros ch)]
+ (persistent! a)
+ (if-let [macrofn (macros ch)]
(let [mret (macrofn rdr ch)]
- (recur (if (= mret rdr) a (conj a mret))))
+ (recur (if (identical? mret rdr) a (conj! a mret))))
(do
(unread rdr ch)
(let [o (read rdr true nil recursive?)]
- (recur (if (= o rdr) a (conj a o))))))))))
+ (recur (if (identical? o rdr) a (conj! a o))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; data structure readers
@@ -201,7 +227,7 @@ nil if the end of stream has been reached")
(defn read-dispatch
[rdr _]
(let [ch (read-char rdr)
- dm (get dispatch-macros ch)]
+ dm (dispatch-macros ch)]
(if dm
(dm rdr _)
(if-let [obj (maybe-read-tagged-type rdr ch)]
@@ -233,15 +259,15 @@ nil if the end of stream has been reached")
[reader initch]
(loop [buffer (gstring/StringBuffer. initch)
ch (read-char reader)]
- (if (or (nil? ch) (whitespace? ch) (contains? macros ch))
+ (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
+(defn read-string*
[reader _]
(loop [buffer (gstring/StringBuffer.)
ch (read-char reader)]
@@ -268,11 +294,14 @@ nil if the end of stream has been reached")
(defn read-keyword
[reader initch]
(let [token (read-token reader (read-char reader))
- [token ns name] (re-matches symbol-pattern token)]
- (if (or (and (not (undefined? ns))
+ a (re-matches* symbol-pattern token)
+ token (aget a 0)
+ ns (aget a 1)
+ name (aget a 2)]
+ (if (or (and (coercive-not (undefined? ns))
(identical? (. ns (substring (- (.-length ns) 2) (.-length ns))) ":/"))
(identical? (aget name (dec (.-length name))) ":")
- (not (== (.indexOf token "::" 1) -1)))
+ (coercive-not (== (.indexOf token "::" 1) -1)))
(reader-error reader "Invalid token: " token)
(if ns
(keyword (.substring ns 0 (.indexOf ns "/")) name)
@@ -312,40 +341,43 @@ nil if the end of stream has been reached")
(defn read-regex
[rdr ch]
- (-> (read-string rdr ch) re-pattern))
+ (-> (read-string* rdr ch) re-pattern))
(defn read-discard
[rdr _]
(read rdr true nil true)
rdr)
-(def macros
- { \" read-string
- \: read-keyword
- \; not-implemented ;; never hit this
- \' (wrapping-reader 'quote)
- \@ (wrapping-reader 'deref)
- \^ read-meta
- \` not-implemented
- \~ not-implemented
- \( read-list
- \) read-unmatched-delimiter
- \[ read-vector
- \] read-unmatched-delimiter
- \{ read-map
- \} read-unmatched-delimiter
- \\ read-char
- \% not-implemented
- \# read-dispatch
- })
+(defn macros [c]
+ (case c
+ \" read-string*
+ \: read-keyword
+ \; not-implemented ;; never hit this
+ \' (wrapping-reader 'quote)
+ \@ (wrapping-reader 'deref)
+ \^ read-meta
+ \` not-implemented
+ \~ not-implemented
+ \( read-list
+ \) read-unmatched-delimiter
+ \[ read-vector
+ \] read-unmatched-delimiter
+ \{ read-map
+ \} read-unmatched-delimiter
+ \\ read-char
+ \% not-implemented
+ \# read-dispatch
+ nil))
;; omitted by design: var reader, eval reader
-(def dispatch-macros
- {"{" read-set
- "<" (throwing-reader "Unreadable form")
- "\"" read-regex
- "!" read-comment
- "_" read-discard})
+(defn dispatch-macros [s]
+ (case s
+ "{" read-set
+ "<" (throwing-reader "Unreadable form")
+ "\"" read-regex
+ "!" read-comment
+ "_" read-discard
+ nil))
(defn read
"Reads the first object from a PushbackReader. Returns the object read.
@@ -356,12 +388,13 @@ nil if the end of stream has been reached")
(nil? ch) (if eof-is-error (reader-error reader "EOF") 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 [res
+ :else (let [f (macros ch)
+ res
(cond
- (macros ch) ((macros ch) reader ch)
+ f (f reader ch)
(number-literal? reader ch) (read-number reader ch)
:else (read-symbol reader ch))]
- (if (= res reader)
+ (if (identical? res reader)
(recur reader eof-is-error sentinel is-recursive)
res)))))
View
295 src/cljs/clojure/core/reducers.cljs
@@ -0,0 +1,295 @@
+; 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
+ "A library for reduction and parallel folding. Alpha and subject
+ to change. Note that fold and its derivatives require
+ jsr166y.jar for fork/join support. See Clojure's pom.xml for the
+ dependency info."
+ :author "Rich Hickey"}
+ clojure.core.reducers
+ (:refer-clojure :exclude [reduce map filter remove take take-while drop flatten])
+ (:require [clojure.walk :as walk]
+ [cljs.core :as core]))
+
+(defn reduce
+ "Like core/reduce except:
+ When init is not provided, (f) is used.
+ Maps are reduced with reduce-kv"
+ ([f coll] (reduce f (f) coll))
+ ([f init coll]
+ (if (map? coll)
+ (-kv-reduce coll f init)
+ (-reduce coll f init))))
+
+#_
+(defprotocol CollFold
+ (coll-fold [coll n combinef reducef]))
+
+;;; TODO: update docstring for CLJS
+#_
+(defn fold
+ "Reduces a collection using a (potentially parallel) reduce-combine
+ strategy. The collection is partitioned into groups of approximately
+ n (default 512), each of which is reduced with reducef (with a seed
+ value obtained by calling (combinef) with no arguments). The results
+ of these reductions are then reduced with combinef (default
+ reducef). combinef must be associative, and, when called with no
+ arguments, (combinef) must produce its identity element. These
+ operations may be performed in parallel, but the results will
+ preserve order."
+ ([reducef coll] (fold reducef reducef coll))
+ ([combinef reducef coll] (fold 512 combinef reducef coll))
+ ([n combinef reducef coll]
+ (coll-fold coll n combinef reducef)))
+
+(def fold reduce)
+
+(defn reducer
+ "Given a reducible collection, and a transformation function xf,
+ returns a reducible collection, where any supplied reducing
+ fn will be transformed by xf. xf is a function of reducing fn to
+ reducing fn."
+ ([coll xf]
+ (reify
+ cljs.core/IReduce
+ (-reduce [this f1]
+ (-reduce this f1 (f1)))
+ (-reduce [_ f1 init]
+ (-reduce coll (xf f1) init)))))
+
+(defn folder
+ "Given a foldable collection, and a transformation function xf,
+ returns a foldable collection, where any supplied reducing
+ fn will be transformed by xf. xf is a function of reducing fn to
+ reducing fn."
+ ([coll xf]
+ (reify
+ cljs.core/IReduce
+ (-reduce [_ f1]
+ (-reduce coll (xf f1) (f1)))
+ (-reduce [_ f1 init]
+ (-reduce coll (xf f1) init))
+
+ #_
+ CollFold
+ #_
+ (coll-fold [_ n combinef reducef]
+ (coll-fold coll n combinef (xf reducef))))))
+
+(defcurried map
+ "Applies f to every value in the reduction of coll. Foldable."
+ {}
+ [f coll]
+ (folder coll
+ (fn [f1]
+ (rfn [f1 k]
+ ([ret k v]
+ (f1 ret (f k v)))))))
+
+(defcurried filter
+ "Retains values in the reduction of coll for which (pred val)
+ returns logical true. Foldable."
+ {}
+ [pred coll]
+ (folder coll
+ (fn [f1]
+ (rfn [f1 k]
+ ([ret k v]
+ (if (pred k v)
+ (f1 ret k v)
+ ret))))))
+
+(defcurried remove
+ "Removes values in the reduction of coll for which (pred val)
+ returns logical true. Foldable."
+ {}
+ [pred coll]
+ (filter (complement pred) coll))
+
+(defcurried take-while
+ "Ends the reduction of coll when (pred val) returns logical false."
+ {}
+ [pred coll]
+ (reducer coll
+ (fn [f1]
+ (rfn [f1 k]
+ ([ret k v]
+ (if (pred k v)
+ (f1 ret k v)
+ (reduced ret)))))))
+
+(defcurried take
+ "Ends the reduction of coll after consuming n values."
+ {}
+ [n coll]
+ (reducer coll
+ (fn [f1]
+ (let [cnt (atom n)]
+ (rfn [f1 k]
+ ([ret k v]
+ (swap! cnt dec)
+ (if (neg? @cnt)
+ (reduced ret)
+ (f1 ret k v))))))))
+
+(defcurried drop
+ "Elides the first n values from the reduction of coll."
+ {}
+ [n coll]
+ (reducer coll
+ (fn [f1]
+ (let [cnt (atom n)]
+ (rfn [f1 k]
+ ([ret k v]
+ (swap! cnt dec)
+ (if (neg? @cnt)
+ (f1 ret k v)
+ ret)))))))
+
+(defcurried flatten
+ "Takes any nested combination of sequential things (lists, vectors,
+ etc.) and returns their contents as a single, flat foldable
+ collection."
+ {}
+ [coll]
+ (let [rf (fn [f1]
+ (fn
+ ([] (f1))
+ ([ret v]
+ (if (sequential? v)
+ (-reduce (flatten v) f1 ret)
+ (f1 ret v)))))]
+ (reify
+ cljs.core/IReduce
+ (-reduce [this f1] (-reduce this f1 (f1)))
+ (-reduce [_ f1 init] (-reduce coll (rf f1) init))
+
+ #_
+ CollFold
+ #_
+ (coll-fold [_ n combinef reducef] (coll-fold coll n combinef (rf reducef))))))
+
+;;do not construct this directly, use cat
+(deftype Cat [cnt left right]
+ clojure.lang.Counted
+ (count [_] cnt)
+
+ clojure.lang.Seqable
+ (seq [_] (concat (seq left) (seq right)))
+
+ cljs.core/IReduce
+ (-reduce [this f1] (-reduce this f1 (f1)))
+ (-reduce
+ [_ f1 init]
+ (-reduce
+ right f1
+ (-reduce left f1 init)))
+
+ #_
+ CollFold
+ #_
+ (coll-fold
+ [this n combinef reducef]
+ (-reduce this reducef)))
+
+(defn cat
+ "A high-performance combining fn that yields the catenation of the
+ reduced values. The result is reducible, foldable, seqable and
+ counted, providing the identity collections are reducible, seqable
+ and counted. The single argument version will build a combining fn
+ with the supplied identity constructor. Tests for identity
+ with (zero? (count x)). See also foldcat."
+ ([] (array))
+ ([ctor]
+ (fn
+ ([] (ctor))
+ ([left right] (cat left right))))
+ ([left right]
+ (cond
+ (zero? (count left)) right
+ (zero? (count right)) left
+ :else
+ (Cat. (+ (count left) (count right)) left right))))
+
+(defn append!
+ ".adds x to acc and returns acc"
+ [acc x]
+ (doto acc (.add x)))
+
+(defn foldcat
+ "Equivalent to (fold cat append! coll)"
+ [coll]
+ (fold cat append! coll))
+
+(defn monoid
+ "Builds a combining fn out of the supplied operator and identity
+ constructor. op must be associative and ctor called with no args
+ must return an identity value for it."
+ [op ctor]
+ (fn m
+ ([] (ctor))
+ ([a b] (op a b))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(comment
+(require '[clojure.core.reduce :as r])
+(def v (take 1000000 (range)))
+(reduce + 0 (r/map inc [1 2 3 4]))
+(into [] (r/take 12 (range 100)))
+(into [] (r/drop 12 (range 100)))
+(reduce + 0 (r/filter even? [1 2 3 4]))
+(into [] (r/filter even? [1 2 3 4]))
+(reduce + (filter even? [1 2 3 4]))
+(dotimes [_ 10] (time (reduce + 0 (r/map inc v))))
+(dotimes [_ 10] (time (reduce + 0 (map inc v))))
+(dotimes [_ 100] (time (reduce + 0 v)))
+(dotimes [_ 100] (time (reduce + 0 v)))
+(dotimes [_ 20] (time (reduce + 0 (r/map inc (r/filter even? v)))))
+(dotimes [_ 20] (time (reduce + 0 (map inc (filter even? v)))))
+(reduce + 0 (r/take-while even? [2 4 3]))
+(into [] (r/filter even? (r/flatten (r/remove #{4} [[1 2 3] 4 [5 [6 7 8]] [9] 10]))))
+(into [] (r/flatten nil))
+)
+
+(comment
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; fold impls ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defn- foldvec
+ [v n combinef reducef]
+ (cond
+ (empty? v) (combinef)
+ (<= (count v) n) (reduce reducef (combinef) v)
+ :else
+ (let [split (quot (count v) 2)
+ v1 (subvec v 0 split)
+ v2 (subvec v split (count v))
+ fc (fn [child] #(foldvec child n combinef reducef))]
+ (fjinvoke
+ #(let [f1 (fc v1)
+ t2 (fjtask (fc v2))]
+ (fjfork t2)
+ (combinef (f1) (fjjoin t2)))))))
+
+(extend-protocol CollFold
+ Object
+ (coll-fold
+ [coll n combinef reducef]
+ ;;can't fold, single reduce
+ (reduce reducef (combinef) coll))
+
+ clojure.lang.IPersistentVector
+ (coll-fold
+ [v n combinef reducef]
+ (foldvec v n combinef reducef))
+
+ clojure.lang.PersistentHashMap
+ (coll-fold
+ [m n combinef reducef]
+ (.fold m n combinef reducef fjinvoke fjtask fjfork fjjoin)))
+
+)
View
19 test/cljs/cljs/letfn_test.cljs
@@ -0,0 +1,19 @@
+(ns cljs.letfn-test)
+
+(defn test-letfn []
+ (letfn [(ev? [x]
+ (if (zero? x)
+ true
+ (od? (dec x))))
+ (od? [x]
+ (if (zero? x)
+ false
+ (ev? (dec x))))]
+ (assert (ev? 0))
+ (assert (ev? 10))
+ (assert (not (ev? 1)))
+ (assert (not (ev? 11)))
+ (assert (not (od? 0)))
+ (assert (not (od? 10)))
+ (assert (od? 1))
+ (assert (od? 11))))
View
4 test/cljs/test_runner.cljs
@@ -4,7 +4,8 @@
[cljs.binding-test :as binding-test]
[cljs.ns-test :as ns-test]
[clojure.string-test :as string-test]
- [cljs.macro-test :as macro-test]))
+ [cljs.macro-test :as macro-test]
+ [cljs.letfn-test :as letfn-test]))
(set! *print-fn* js/print)
@@ -14,6 +15,7 @@
(binding-test/test-binding)
(ns-test/test-ns)
(macro-test/test-macros)
+(letfn-test/test-letfn)
(println "Tests completed without exception")

0 comments on commit 8444ce1

Please sign in to comment.