├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── build-docs.sh ├── project.clj ├── src └── flatland │ └── useful │ ├── bean.clj │ ├── cli.clj │ ├── compress.clj │ ├── config.clj │ ├── datatypes.clj │ ├── debug.clj │ ├── deftype.clj │ ├── dispatch.clj │ ├── exception.clj │ ├── experimental.clj │ ├── experimental │ ├── delegate.clj │ └── unicode.clj │ ├── fn.clj │ ├── io.clj │ ├── java.clj │ ├── macro.clj │ ├── map.clj │ ├── ns.clj │ ├── parallel.clj │ ├── seq.clj │ ├── state.clj │ ├── string.clj │ ├── test.clj │ ├── time.clj │ └── utils.clj └── test ├── config1.clj ├── config2.clj └── flatland └── useful ├── bean_test.clj ├── cli_test.clj ├── compress_test.clj ├── config_test.clj ├── datatypes_test.clj ├── debug_test.clj ├── deftype_test.clj ├── dispatch_test.clj ├── exception_test.clj ├── experimental_test.clj ├── fn_test.clj ├── io_test.clj ├── java_test.clj ├── macro_test.clj ├── map_test.clj ├── ns_test.clj ├── parallel_test.clj ├── seq_test.clj ├── state_test.clj ├── string_test.clj ├── test_test.clj └── utils_test.clj /.gitignore: -------------------------------------------------------------------------------- 1 | .cake 2 | pom.xml 3 | *.jar 4 | *~ 5 | lib/ 6 | classes/ 7 | build/ 8 | docs 9 | .lein* 10 | bin/ 11 | target/ 12 | .settings/ 13 | .ritz* 14 | .project 15 | .classpath 16 | doc/ 17 | /.nrepl-port 18 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: clojure 2 | lein: lein2 3 | script: lein2 testall -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Eclipse Public License - v 1.0 2 | 3 | THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE 4 | PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF 5 | THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. 6 | 7 | 1. DEFINITIONS 8 | 9 | "Contribution" means: 10 | 11 | a) in the case of the initial Contributor, the initial code and 12 | documentation distributed under this Agreement, and 13 | 14 | b) in the case of each subsequent Contributor: 15 | 16 | i) changes to the Program, and 17 | 18 | ii) additions to the Program; 19 | 20 | where such changes and/or additions to the Program originate from and 21 | are distributed by that particular Contributor. A Contribution 22 | 'originates' from a Contributor if it was added to the Program by such 23 | Contributor itself or anyone acting on such Contributor's 24 | behalf. Contributions do not include additions to the Program which: 25 | (i) are separate modules of software distributed in conjunction with 26 | the Program under their own license agreement, and (ii) are not 27 | derivative works of the Program. 28 | 29 | "Contributor" means any person or entity that distributes the Program. 30 | 31 | "Licensed Patents" mean patent claims licensable by a Contributor 32 | which are necessarily infringed by the use or sale of its Contribution 33 | alone or when combined with the Program. 34 | 35 | "Program" means the Contributions distributed in accordance with this 36 | Agreement. 37 | 38 | "Recipient" means anyone who receives the Program under this 39 | Agreement, including all Contributors. 40 | 41 | 2. GRANT OF RIGHTS 42 | 43 | a) Subject to the terms of this Agreement, each Contributor hereby 44 | grants Recipient a non-exclusive, worldwide, royalty-free copyright 45 | license to reproduce, prepare derivative works of, publicly display, 46 | publicly perform, distribute and sublicense the Contribution of such 47 | Contributor, if any, and such derivative works, in source code and 48 | object code form. 49 | 50 | b) Subject to the terms of this Agreement, each Contributor hereby 51 | grants Recipient a non-exclusive, worldwide, royalty-free patent 52 | license under Licensed Patents to make, use, sell, offer to sell, 53 | import and otherwise transfer the Contribution of such Contributor, if 54 | any, in source code and object code form. This patent license shall 55 | apply to the combination of the Contribution and the Program if, at 56 | the time the Contribution is added by the Contributor, such addition 57 | of the Contribution causes such combination to be covered by the 58 | Licensed Patents. The patent license shall not apply to any other 59 | combinations which include the Contribution. No hardware per se is 60 | licensed hereunder. 61 | 62 | c) Recipient understands that although each Contributor grants the 63 | licenses to its Contributions set forth herein, no assurances are 64 | provided by any Contributor that the Program does not infringe the 65 | patent or other intellectual property rights of any other entity. Each 66 | Contributor disclaims any liability to Recipient for claims brought by 67 | any other entity based on infringement of intellectual property rights 68 | or otherwise. As a condition to exercising the rights and licenses 69 | granted hereunder, each Recipient hereby assumes sole responsibility 70 | to secure any other intellectual property rights needed, if any. For 71 | example, if a third party patent license is required to allow 72 | Recipient to distribute the Program, it is Recipient's responsibility 73 | to acquire that license before distributing the Program. 74 | 75 | d) Each Contributor represents that to its knowledge it has sufficient 76 | copyright rights in its Contribution, if any, to grant the copyright 77 | license set forth in this Agreement. 78 | 79 | 3. REQUIREMENTS 80 | 81 | A Contributor may choose to distribute the Program in object code form 82 | under its own license agreement, provided that: 83 | 84 | a) it complies with the terms and conditions of this Agreement; and 85 | 86 | b) its license agreement: 87 | 88 | i) effectively disclaims on behalf of all Contributors all warranties 89 | and conditions, express and implied, including warranties or 90 | conditions of title and non-infringement, and implied warranties or 91 | conditions of merchantability and fitness for a particular purpose; 92 | 93 | ii) effectively excludes on behalf of all Contributors all liability 94 | for damages, including direct, indirect, special, incidental and 95 | consequential damages, such as lost profits; 96 | 97 | iii) states that any provisions which differ from this Agreement are 98 | offered by that Contributor alone and not by any other party; and 99 | 100 | iv) states that source code for the Program is available from such 101 | Contributor, and informs licensees how to obtain it in a reasonable 102 | manner on or through a medium customarily used for software exchange. 103 | 104 | When the Program is made available in source code form: 105 | 106 | a) it must be made available under this Agreement; and 107 | 108 | b) a copy of this Agreement must be included with each copy of the Program. 109 | 110 | Contributors may not remove or alter any copyright notices contained 111 | within the Program. 112 | 113 | Each Contributor must identify itself as the originator of its 114 | Contribution, if any, in a manner that reasonably allows subsequent 115 | Recipients to identify the originator of the Contribution. 116 | 117 | 4. COMMERCIAL DISTRIBUTION 118 | 119 | Commercial distributors of software may accept certain 120 | responsibilities with respect to end users, business partners and the 121 | like. While this license is intended to facilitate the commercial use 122 | of the Program, the Contributor who includes the Program in a 123 | commercial product offering should do so in a manner which does not 124 | create potential liability for other Contributors. Therefore, if a 125 | Contributor includes the Program in a commercial product offering, 126 | such Contributor ("Commercial Contributor") hereby agrees to defend 127 | and indemnify every other Contributor ("Indemnified Contributor") 128 | against any losses, damages and costs (collectively "Losses") arising 129 | from claims, lawsuits and other legal actions brought by a third party 130 | against the Indemnified Contributor to the extent caused by the acts 131 | or omissions of such Commercial Contributor in connection with its 132 | distribution of the Program in a commercial product offering. The 133 | obligations in this section do not apply to any claims or Losses 134 | relating to any actual or alleged intellectual property 135 | infringement. In order to qualify, an Indemnified Contributor must: a) 136 | promptly notify the Commercial Contributor in writing of such claim, 137 | and b) allow the Commercial Contributor tocontrol, and cooperate with 138 | the Commercial Contributor in, the defense and any related settlement 139 | negotiations. The Indemnified Contributor may participate in any such 140 | claim at its own expense. 141 | 142 | For example, a Contributor might include the Program in a commercial 143 | product offering, Product X. That Contributor is then a Commercial 144 | Contributor. If that Commercial Contributor then makes performance 145 | claims, or offers warranties related to Product X, those performance 146 | claims and warranties are such Commercial Contributor's responsibility 147 | alone. Under this section, the Commercial Contributor would have to 148 | defend claims against the other Contributors related to those 149 | performance claims and warranties, and if a court requires any other 150 | Contributor to pay any damages as a result, the Commercial Contributor 151 | must pay those damages. 152 | 153 | 5. NO WARRANTY 154 | 155 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS 156 | PROVIDED ON AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 157 | KIND, EITHER EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, ANY 158 | WARRANTIES OR CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY 159 | OR FITNESS FOR A PARTICULAR PURPOSE. Each Recipient is solely 160 | responsible for determining the appropriateness of using and 161 | distributing the Program and assumes all risks associated with its 162 | exercise of rights under this Agreement , including but not limited to 163 | the risks and costs of program errors, compliance with applicable 164 | laws, damage to or loss of data, programs or equipment, and 165 | unavailability or interruption of operations. 166 | 167 | 6. DISCLAIMER OF LIABILITY 168 | 169 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR 170 | ANY CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, 171 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING 172 | WITHOUT LIMITATION LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF 173 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 174 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OR 175 | DISTRIBUTION OF THE PROGRAM OR THE EXERCISE OF ANY RIGHTS GRANTED 176 | HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 177 | 178 | 7. GENERAL 179 | 180 | If any provision of this Agreement is invalid or unenforceable under 181 | applicable law, it shall not affect the validity or enforceability of 182 | the remainder of the terms of this Agreement, and without further 183 | action by the parties hereto, such provision shall be reformed to the 184 | minimum extent necessary to make such provision valid and enforceable. 185 | 186 | If Recipient institutes patent litigation against any entity 187 | (including a cross-claim or counterclaim in a lawsuit) alleging that 188 | the Program itself (excluding combinations of the Program with other 189 | software or hardware) infringes such Recipient's patent(s), then such 190 | Recipient's rights granted under Section 2(b) shall terminate as of 191 | the date such litigation is filed. 192 | 193 | All Recipient's rights under this Agreement shall terminate if it 194 | fails to comply with any of the material terms or conditions of this 195 | Agreement and does not cure such failure in a reasonable period of 196 | time after becoming aware of such noncompliance. If all Recipient's 197 | rights under this Agreement terminate, Recipient agrees to cease use 198 | and distribution of the Program as soon as reasonably 199 | practicable. However, Recipient's obligations under this Agreement and 200 | any licenses granted by Recipient relating to the Program shall 201 | continue and survive. 202 | 203 | Everyone is permitted to copy and distribute copies of this Agreement, 204 | but in order to avoid inconsistency the Agreement is copyrighted and 205 | may only be modified in the following manner. The Agreement Steward 206 | reserves the right to publish new versions (including revisions) of 207 | this Agreement from time to time. No one other than the Agreement 208 | Steward has the right to modify this Agreement. The Eclipse Foundation 209 | is the initial Agreement Steward. The Eclipse Foundation may assign 210 | the responsibility to serve as the Agreement Steward to a suitable 211 | separate entity. Each new version of the Agreement will be given a 212 | distinguishing version number. The Program (including Contributions) 213 | may always be distributed subject to the version of the Agreement 214 | under which it was received. In addition, after a new version of the 215 | Agreement is published, Contributor may elect to distribute the 216 | Program (including its Contributions) under the new version. Except as 217 | expressly stated in Sections 2(a) and 2(b) above, Recipient receives 218 | no rights or licenses to the intellectual property of any Contributor 219 | under this Agreement, whether expressly, by implication, estoppel or 220 | otherwise. All rights in the Program not expressly granted under this 221 | Agreement are reserved. 222 | 223 | This Agreement is governed by the laws of the State of Washington and 224 | the intellectual property laws of the United States of America. No 225 | party to this Agreement will bring a legal action under this Agreement 226 | more than one year after the cause of action arose. Each party waives 227 | its rights to a jury trial in any resulting litigation. 228 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Build Status](https://secure.travis-ci.org/flatland/useful.png)](http://travis-ci.org/flatland/useful) 2 | -------------------------------------------------------------------------------- /build-docs.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | lein doc 6 | echo "*** Docs built ***" 7 | tmpdir=`mktemp -d /tmp/flatland-useful.XXXXXX` 8 | mv doc/** $tmpdir 9 | rmdir doc 10 | git checkout gh-pages 11 | git rm -rf . 12 | mv $tmpdir/** . 13 | git add -Av . 14 | git commit -m "Updated docs" 15 | echo "*** gh-pages branch updated ***" 16 | rmdir $tmpdir 17 | git checkout - 18 | echo "Run this to complete:" 19 | echo "git push origin gh-pages:gh-pages" 20 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject org.flatland/useful "0.11.3" 2 | :description "A collection of generally-useful Clojure utility functions" 3 | :license {:name "Eclipse Public License - v 1.0" 4 | :url "http://www.eclipse.org/legal/epl-v10.html" 5 | :distribution :repo} 6 | :url "https://github.com/flatland/useful" 7 | :dependencies [[org.clojure/clojure "1.6.0"] 8 | [org.clojure/tools.macro "0.1.1"] 9 | [org.clojure/tools.reader "0.7.2"]] 10 | :aliases {"testall" ["with-profile" "dev,default:dev,1.3,default:dev,1.4,default:dev,1.5,default:dev,1.7,default" "test"]} 11 | :profiles {:1.7 {:dependencies [[org.clojure/clojure "1.7.0-alpha2"]]} 12 | :1.5 {:dependencies [[org.clojure/clojure "1.5.1"]]} 13 | :1.4 {:dependencies [[org.clojure/clojure "1.4.0"]]} 14 | :1.3 {:dependencies [[org.clojure/clojure "1.3.0"]]} } 15 | :plugins [[codox "0.8.0"]] 16 | :codox {:src-dir-uri "http://github.com/flatland/useful/blob/develop/" 17 | :src-linenum-anchor-prefix "L"}) 18 | -------------------------------------------------------------------------------- /src/flatland/useful/bean.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.bean 2 | "Modify bean attributes in clojure." 3 | (:require [clojure.string :as s]) 4 | (:import (java.beans Introspector PropertyDescriptor) 5 | (java.lang.reflect Method))) 6 | 7 | (defn- property-key [^PropertyDescriptor property] 8 | (keyword (-> property 9 | .getName 10 | (s/replace #"\B([A-Z])" "-$1") 11 | .toLowerCase))) 12 | 13 | (defn property-setters 14 | "Returns a map of keywords to property setter methods for a given class." 15 | [class] 16 | (reduce 17 | (fn [map ^PropertyDescriptor property] 18 | (assoc map (property-key property) (.getWriteMethod property))) 19 | {} (.getPropertyDescriptors (Introspector/getBeanInfo class)))) 20 | 21 | (defmulti coerce (fn [bean-class type val] [type (class val)])) 22 | (defmethod coerce :default [_ type val] 23 | (when-not (nil? val) 24 | (try (cast type val) 25 | (catch ClassCastException e 26 | val)))) 27 | 28 | (defn update-bean 29 | "Update the given bean instance with attrs by calling the appropriate setter methods on it." 30 | [instance attrs] 31 | (let [bean-class (class instance) 32 | setters (property-setters bean-class)] 33 | (doseq [[key val] attrs] 34 | (if-let [^Method setter (setters key)] 35 | (let [type (first (.getParameterTypes setter))] 36 | (.invoke setter instance (to-array [(coerce bean-class type val)]))) 37 | (throw (Exception. (str "property not found for " key))))) 38 | instance)) 39 | -------------------------------------------------------------------------------- /src/flatland/useful/cli.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.cli 2 | (:refer-clojure :exclude [update]) 3 | (:use [flatland.useful.experimental :only [cond-let]] 4 | [flatland.useful.map :only [update]])) 5 | 6 | (defn- parse-opt [default opts arg] 7 | (let [m re-matches 8 | key (comp keyword str) 9 | into-vec (fnil into []) 10 | conj-vec (fnil conj [])] 11 | (cond-let 12 | [[_ ks] (m #"-(\w+)" arg)] (apply merge-with into-vec opts (for [k ks] {(key k) [""]})) 13 | [[_ k v] (m #"--?([-\w]+)=(.+)" arg)] (update opts (key k) into-vec (.split #"," v)) 14 | [[_ k] (m #"--?([-\w]+)" arg)] (update opts (key k) conj-vec "") 15 | :else (update opts default conj-vec arg)))) 16 | 17 | (defn parse-opts 18 | "Parse command line args or the provided argument list. Returns a map of keys to 19 | vectors of repeated values. Named args begin with --keyname and are mapped to 20 | :keyname. Unnamed arguments are mapped to nil or default. Repeated named values can be 21 | specified by repeating a key or by using commas in the value. Single and double dashes 22 | are both supported though a single dash followed by word characters without internal 23 | dashes or an equal sign is assumed to be single character argument flags and are split 24 | accordingly. 25 | 26 | Example: 27 | (parse-opts [\"foo\" \"-vD\" \"bar\" \"-no-wrap\" \"-color=blue,green\" \"--style=baroque\" \"-color=red\"]) 28 | => {:style [\"baroque\"], :color [\"blue\" \"green\" \"red\"], :no-wrap [\"\"], :D [\"\"], :v [\"\"], nil [\"foo\" \"bar\"]}" 29 | ([] (parse-opts nil *command-line-args*)) 30 | ([args] (parse-opts nil args)) 31 | ([default args] (reduce (partial parse-opt default) {} args))) -------------------------------------------------------------------------------- /src/flatland/useful/compress.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.compress 2 | (:import [java.util.zip DeflaterOutputStream InflaterInputStream] 3 | [java.io ByteArrayOutputStream ByteArrayInputStream] 4 | [sun.misc BASE64Decoder BASE64Encoder])) 5 | 6 | (defn smash [^String str] 7 | (let [out (ByteArrayOutputStream.)] 8 | (doto (DeflaterOutputStream. out) 9 | (.write (.getBytes str)) 10 | (.finish)) 11 | (-> (BASE64Encoder.) 12 | (.encodeBuffer (.toByteArray out))))) 13 | 14 | (defn unsmash [^String str] 15 | (let [bytes (-> (BASE64Decoder.) (.decodeBuffer str)) 16 | in (ByteArrayInputStream. bytes)] 17 | (slurp (InflaterInputStream. in)))) 18 | -------------------------------------------------------------------------------- /src/flatland/useful/config.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.config 2 | (:require [clojure.java.io :as io])) 3 | 4 | (defn read-config [filename & {:keys [optional]}] 5 | (let [resource (io/resource filename)] 6 | (if resource 7 | (with-open [in (java.io.PushbackReader. (io/reader resource))] 8 | (let [eof (Object.) 9 | forms (take-while (complement #{eof}) 10 | (repeatedly #(binding [*read-eval* false] 11 | (read in false eof))))] 12 | (if-let [error (cond (empty? forms) "No config data in %s" 13 | (next forms) "Too many forms in %s")] 14 | (throw (IllegalArgumentException. (format error filename))) 15 | (first forms)))) 16 | (when-not optional 17 | (throw (java.io.FileNotFoundException. (format "Cannot find config resource %s" filename))))))) 18 | 19 | (defn load-config [filename & args] 20 | (eval (apply read-config filename args))) 21 | -------------------------------------------------------------------------------- /src/flatland/useful/datatypes.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.datatypes 2 | (:refer-clojure :exclude [update]) 3 | (:use [flatland.useful.map :only [position into-map update]] 4 | [flatland.useful.utils :only [invoke]] 5 | [flatland.useful.fn :only [fix]]) 6 | (:require [clojure.string :as s]) 7 | (:import (java.lang.reflect Field) 8 | (clojure.lang Compiler$LocalBinding))) 9 | 10 | (defn as-int [x] 11 | (condp invoke x 12 | integer? x 13 | string? (Integer/parseInt x) 14 | float? (int x) 15 | nil)) 16 | 17 | (let [munge-ops [["?" "_QMARK_"] 18 | ["!" "_BANG_"] 19 | ["-" "_"]] 20 | munger (fn [f] 21 | (fn [field] 22 | (symbol (reduce (fn [^String s op] 23 | (let [[from to] (f op)] 24 | (.replaceAll s (java.util.regex.Pattern/quote from) to))) 25 | (name field) 26 | munge-ops))))] 27 | (def clj->java (munger seq)) 28 | (def java->clj (munger rseq))) 29 | 30 | (defn- ^Class coerce-class 31 | "Get a Class object from either a Symbol (by resolving it) or a Class." 32 | [type] 33 | (fix type symbol? resolve)) 34 | 35 | (defn- record-fields 36 | "Uses reflection to get the declared fields passed to the defrecord call for type. If called on a 37 | non-record, the behavior is undefined." 38 | ([type] 39 | (record-fields type clj->java)) 40 | ([type lang] 41 | (->> (.getDeclaredFields (coerce-class type)) 42 | (remove #(java.lang.reflect.Modifier/isStatic (.getModifiers ^Field %))) 43 | (remove #(let [name (.getName ^Field %)] 44 | (and (not (#{"__extmap" "__meta"} name)) 45 | (.startsWith name "__")))) 46 | (map #(lang (.getName ^Field %)))))) 47 | 48 | (defmacro make-record 49 | "Construct a record given a pairs of lists and values. Mapping fields into constuctor arguments is 50 | done at compile time, so this is more efficient than creating an empty record and calling merge." 51 | [type & attrs] 52 | (let [fields (record-fields type clj->java) 53 | index (position fields) 54 | vals (reduce (fn [vals [field val]] 55 | (if-let [i (index (clj->java field))] 56 | (assoc vals i val) 57 | (assoc-in vals 58 | [(index '__extmap) (keyword field)] val))) 59 | (vec (repeat (count fields) nil)) 60 | (into-map attrs))] 61 | `(new ~type ~@vals))) 62 | 63 | (defn- type-hint [form &env fn-name] 64 | (or (:tag (meta form)) 65 | (let [^Compiler$LocalBinding binding (get &env form)] 66 | (and binding (.hasJavaClass binding) (.getJavaClass binding))) 67 | (throw (Exception. (str "type hint required on record to use " fn-name))))) 68 | 69 | (defmacro assoc-record 70 | "Assoc attrs into a record. Mapping fields into constuctor arguments is done at compile time, 71 | so this is more efficient than calling assoc on an existing record." 72 | [record & attrs] 73 | (let [r (gensym 'record) 74 | type (type-hint record &env 'assoc-record) 75 | fields (record-fields type clj->java) 76 | index (position fields) 77 | vals (reduce (fn [vals [field val]] 78 | (if-let [i (index (clj->java field))] 79 | (assoc vals i val) 80 | (assoc-in vals 81 | [(index '__extmap) (keyword field)] val))) 82 | (vec (map #(list '. r %) fields)) 83 | (into-map attrs))] 84 | `(let [~r ~record] 85 | (new ~type ~@vals)))) 86 | 87 | (defmacro update-record 88 | "Construct a record given a list of forms like (update-fn record-field & args). Mapping fields 89 | into constuctor arguments is done at compile time, so this is more efficient than calling assoc on 90 | an existing record." 91 | [record & forms] 92 | (let [r (gensym 'record) 93 | type (type-hint record &env 'update-record) 94 | fields (record-fields type clj->java) 95 | index (position fields) 96 | vals (reduce (fn [vals [f field & args]] 97 | (if-let [i (index (clj->java field))] 98 | (assoc vals 99 | i `(~f ~(get vals i) ~@args)) 100 | (let [i (index '__extmap)] 101 | (assoc vals 102 | i `(update ~(get vals i) ~(keyword field) ~@args))))) 103 | (vec (map #(list '. r %) fields)) 104 | forms)] 105 | `(let [~r ~record] 106 | (new ~type ~@vals)))) 107 | 108 | (defmacro record-accessors 109 | "Defines optimized macro accessors using interop and typehints for all fields in the given records." 110 | [& types] 111 | `(do ~@(for [type types 112 | :let [tag (symbol (.getName (coerce-class type)))] 113 | field (record-fields type clj->java) 114 | :when (not (.startsWith (name field) "__"))] 115 | `(defmacro ~(java->clj field) [~'record] 116 | (with-meta 117 | (list '. (with-meta ~'record {:tag '~tag}) 118 | '~field) 119 | (meta ~'&form)))))) 120 | -------------------------------------------------------------------------------- /src/flatland/useful/debug.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.debug) 2 | 3 | ;; leave out of ns decl so we can load with classlojure.io/resource-forms 4 | (require '[clojure.pprint :as p]) 5 | (require '[clojure.stacktrace :as s]) 6 | 7 | (letfn [(interrogate-form [list-head form] 8 | `(let [display# (fn [val#] 9 | (let [form# (with-out-str 10 | (clojure.pprint/with-pprint-dispatch 11 | clojure.pprint/code-dispatch 12 | (clojure.pprint/pprint '~form))) 13 | val# (with-out-str (clojure.pprint/pprint val#))] 14 | (~@list-head 15 | (if (every? (partial > clojure.pprint/*print-miser-width*) 16 | [(count form#) (count val#)]) 17 | (str (subs form# 0 (dec (count form#))) " is " val#) 18 | (str form# "--------- is ---------\n" val#)))))] 19 | (try (doto ~form display#) 20 | (catch Throwable t# 21 | (display# {:thrown t# 22 | :trace (with-out-str 23 | (clojure.stacktrace/print-cause-trace t#))}) 24 | (throw t#)))))] 25 | 26 | (defmacro ? 27 | "A useful debugging tool when you can't figure out what's going on: 28 | wrap a form with ?, and the form will be printed alongside 29 | its result. The result will still be passed along." 30 | [val] 31 | (interrogate-form `(#(do (print %) (flush))) val)) 32 | 33 | (defmacro ^{:dont-test "Complicated to test, and should work if ? does"} 34 | ?! 35 | ([val] `(?! "/tmp/spit" ~val)) 36 | ([file val] 37 | (interrogate-form `(#(spit ~file % :append true)) val)))) 38 | -------------------------------------------------------------------------------- /src/flatland/useful/deftype.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.deftype 2 | (:use [flatland.useful.experimental.delegate :only [parse-deftype-specs emit-deftype-specs]] 3 | [flatland.useful.map :only [merge-in]]) 4 | (:require [clojure.string :as s]) 5 | (:import (clojure.lang IObj MapEntry IPersistentVector 6 | IPersistentMap APersistentMap MapEquivalence) 7 | (java.util Map Map$Entry))) 8 | 9 | ;; to define a new map type, you still must provide: 10 | ;; - IPersistentMap: 11 | ;; - (.count this) 12 | ;; - (.valAt this k not-found) 13 | ;; - (.empty this) 14 | ;; - (.assoc this k v) 15 | ;; - (.without this k) 16 | ;; - (.seq this) 17 | ;; - recommended but not required: (.entryAt this k) 18 | ;; - IObj 19 | ;; - (.meta this) 20 | ;; - (.withMeta this m) 21 | 22 | (defmacro defmap [name fields & specs] 23 | `(deftype ~name ~fields 24 | ~@(emit-deftype-specs 25 | (->> (parse-deftype-specs specs) 26 | (merge-in (parse-deftype-specs 27 | `(java.util.Map 28 | (size [this#] 29 | (count this#)) 30 | (containsKey [this# k#] 31 | (contains? this# k#)) 32 | (isEmpty [this#] 33 | (empty? this#)) 34 | (keySet [this#] 35 | (set (keys this#))) 36 | (values [this#] 37 | (vals this#)) 38 | (get [this# k#] 39 | (get this# k#)) 40 | (containsValue [this# v#] 41 | (boolean (seq (filter #(= % v#) (vals this#))))) 42 | 43 | Object 44 | (toString [this#] 45 | (str "{" (s/join ", " (for [[k# v#] this#] (str k# " " v#))) "}")) 46 | (equals [this# other#] 47 | (= this# other#)) 48 | (hashCode [this#] 49 | (APersistentMap/mapHash this#)) 50 | 51 | clojure.lang.IFn 52 | (invoke [this# k#] 53 | (get this# k#)) 54 | (invoke [this# k# not-found#] 55 | (get this# k# not-found#)) 56 | 57 | MapEquivalence 58 | 59 | IPersistentMap 60 | (equiv [this# other#] 61 | (and (instance? Map other#) 62 | (or (instance? MapEquivalence other#) 63 | (not (instance? IPersistentMap other#))) 64 | (= (count this#) (count other#)) 65 | (every? (fn [e#] 66 | (let [k# (key e#) 67 | o# ^Map other#] 68 | (and (.containsKey o# k#) 69 | (= (.get o# k#) (val e#))))) 70 | (seq this#)))) 71 | (entryAt [this# k#] 72 | (let [not-found# (Object.) 73 | v# (get this# k# not-found#)] 74 | (when (not= v# not-found#) 75 | (MapEntry. k# v#)))) 76 | (valAt [this# k#] 77 | (get this# k# nil)) 78 | (cons [this# obj#] 79 | (condp instance? obj# 80 | Map$Entry (assoc this# (key obj#) (val obj#)) 81 | IPersistentVector (if (= 2 (count obj#)) 82 | (assoc this# (nth obj# 0) (nth obj# 1)) 83 | (throw (IllegalArgumentException. 84 | "Vector arg to map conj must be a pair"))) 85 | (reduce (fn [m# e#] 86 | (assoc m# (key e#) (val e#))) 87 | this# obj#))) 88 | (iterator [this#] 89 | (clojure.lang.SeqIterator. (seq this#)))))))))) 90 | 91 | (defmap AList [entries meta] 92 | IPersistentMap 93 | (count [this] 94 | (count entries)) 95 | (valAt [this k not-found] 96 | (if-let [e (find this k)] 97 | (val e) 98 | not-found)) 99 | (entryAt [this k] 100 | (first (filter #(= k (key %)) entries))) 101 | (empty [this] 102 | (AList. () meta)) 103 | (seq [this] 104 | (seq entries)) 105 | (assoc [this k v] 106 | (AList. (conj entries (MapEntry. k v)) meta)) 107 | (without [this k] 108 | (AList. (->> entries (remove #(= k (key %))) 109 | (apply list)) 110 | meta)) 111 | 112 | IObj 113 | (meta [this] 114 | meta) 115 | (withMeta [this meta] 116 | (AList. entries meta))) 117 | 118 | (defn alist 119 | "A map stored like a common-lisp alist, ie a seq of [key, value] pairs. A new entry can simply be 120 | consed onto the front, without having to do any additional work to update the rest of the entries." 121 | [& kvs] 122 | (AList. (apply list (map vec (partition 2 kvs))) nil)) 123 | -------------------------------------------------------------------------------- /src/flatland/useful/dispatch.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.dispatch 2 | (:use [flatland.useful.map :only [into-map]] 3 | [flatland.useful.fn :only [any]] 4 | [flatland.useful.utils :only [verify]])) 5 | 6 | (defn get-sub-type [hierarchy ns] 7 | (let [sub-type (get hierarchy ns)] 8 | (verify (not= sub-type ns) "a node type cannot have itself as a sub-type") 9 | sub-type)) 10 | 11 | (defn dispatcher 12 | "Returns a function that dispatches using the given dispatch function to determine the 13 | namespace and function to call." 14 | [dispatch-fn & options] 15 | (let [{:keys [hierarchy wrap default]} (into-map options) 16 | wrap (or wrap identity) 17 | publics (memoize (fn [ns] 18 | (try (require ns) 19 | (ns-publics (find-ns ns)) 20 | (catch java.io.FileNotFoundException e))))] 21 | (fn [& args] 22 | (let [fname (apply dispatch-fn args) 23 | default (or default 24 | (with-meta (fn [& args] 25 | (throw (IllegalArgumentException. (str "cannot resolve function: " fname)))) 26 | {:no-wrap true}))] 27 | (loop [[ns method] (map symbol ((juxt namespace name) (symbol fname)))] 28 | (if-let [f (if ns 29 | (get (publics ns) method) 30 | default)] 31 | (let [wrap (if (:no-wrap (meta f)) 32 | identity 33 | wrap)] 34 | (apply (wrap f) args)) 35 | (recur [(get-sub-type hierarchy ns) method]))))))) 36 | 37 | (defmacro defdispatch 38 | "Defines a function that dispatches using the given dispatch function to determine the 39 | namespace and function to call." 40 | {:arglists '([name docstring? attr-map? dispatch-fn & options])} 41 | [name & options] 42 | (let [[defn-options [dispatch-fn & options]] (split-with (any string? map?) options)] 43 | `(let [dispatcher# (dispatcher ~dispatch-fn ~@options)] 44 | (defn ~name ~@defn-options [& args#] 45 | (apply dispatcher# args#))))) -------------------------------------------------------------------------------- /src/flatland/useful/exception.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.exception 2 | (:use [clojure.stacktrace :only [print-cause-trace]] 3 | [clojure.string :only [split-lines trim]])) 4 | 5 | (defmacro rescue 6 | "Evaluate form, returning error-form on any Exception." 7 | [form error-form] 8 | `(try ~form (catch Exception e# ~error-form))) 9 | 10 | (defn cause-trace 11 | "Return an Exception's cause trace as an array of lines" 12 | [exception] 13 | (map trim (split-lines (with-out-str (print-cause-trace exception))))) 14 | 15 | (defn exception-map 16 | "Return a map with the keys: :name, :message, and :trace. :trace is the cause trace as an array of lines " 17 | [exception] 18 | {:name (.getName (class exception)) 19 | :message (.getMessage exception) 20 | :trace (cause-trace exception)}) 21 | -------------------------------------------------------------------------------- /src/flatland/useful/experimental.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.experimental 2 | (:use [flatland.useful.utils :only [split-vec]] 3 | [flatland.useful.seq :only [alternates find-first]] 4 | [flatland.useful.map :only [keyed]] 5 | [clojure.tools.macro :only [name-with-attributes]] 6 | [flatland.useful.fn :only [any as-fn knit]])) 7 | 8 | (defn comp-partial 9 | "A version of comp that \"rescues\" the first N args, passing them to every composed function 10 | instead of just the first one. 11 | 12 | For example, ((comp-partial 2 * +) 3 4 5 6) is equivalent to (* 3 4 (+ 3 4 5 6))." 13 | [n & fns] 14 | (let [split (if (neg? n) 15 | #(split-vec (vec %) n) 16 | #(split-at n %))] 17 | (fn [& args] 18 | (let [[rescued more] (split n args) 19 | fns (for [f fns] (apply partial f rescued))] 20 | (apply (apply comp fns) more))))) 21 | 22 | (defmacro while-let 23 | "Repeatedly executes body, which presumably has side-effects, while let binding is not false." 24 | [bindings & body] 25 | (let [[form test] bindings] 26 | `(loop [~form ~test] 27 | (when ~form 28 | ~@body 29 | (recur ~test))))) 30 | 31 | (defmacro cond-let 32 | "An implementation of cond-let that is as similar as possible to if-let. Takes multiple 33 | test-binding/then-form pairs and evalutes the form if the binding is true. Also supports 34 | :else in the place of test-binding and always evaluates the form in that case. 35 | 36 | Example: 37 | (cond-let [b (bar 1 2 3)] (println :bar b) 38 | [f (foo 3 4 5)] (println :foo f) 39 | [b (baz 6 7 8)] (println :baz b) 40 | :else (println :no-luck))" 41 | [test-binding then-form & more] 42 | (let [test-binding (if (= :else test-binding) `[t# true] test-binding) 43 | else-form (when (seq more) `(cond-let ~@more))] 44 | `(if-let ~test-binding 45 | ~then-form 46 | ~else-form))) 47 | 48 | (defmacro let-if 49 | "Choose a set of bindings based on the result of a conditional test. 50 | 51 | Example: 52 | (let-if (even? a) 53 | [b (bar 1 2 3) (baz 1 2 3) 54 | c (foo 1) (foo 3)] 55 | (println (combine b c)))" 56 | [test bindings & forms] 57 | (let [[names thens elses] (alternates 3 bindings)] 58 | `(if ~test 59 | (let [~@(interleave names thens)] ~@forms) 60 | (let [~@(interleave names elses)] ~@forms)))) 61 | 62 | (defmacro order-let-if 63 | "If predicate is true, bind the names provided, otherwise reverse those bindings. 64 | 65 | Example: 66 | (order-let-if false [a \"foo\" b \"bar\"] [a b]) = [\"bar\" \"foo\"]" 67 | [pred bindings & body] 68 | `(if ~pred 69 | (let ~bindings ~@body) 70 | (let 71 | ~(vec 72 | (let [parts (partition 2 bindings)] 73 | (mapcat #(vector % (second %2)) 74 | (reverse (map first parts)) 75 | parts))) 76 | ~@body))) 77 | 78 | (letfn [(mapify [coll] (into {} coll)) ;; just for less-deep indenting 79 | (symbol ([ns sym] ;; annoying that (symbol 'x 'y) fails 80 | (clojure.core/symbol (name ns) (name sym)))) 81 | (behavior ([name default exceptions] 82 | (= :forward 83 | (if (exceptions name) 84 | ({:forward :stub, :stub :forward} default) 85 | default)))) 86 | (analyze-var [v] 87 | (let [{:keys [ns name]} (meta v) 88 | ns (ns-name ns) 89 | sigs (:sigs @v)] 90 | (keyed [ns name sigs]))) 91 | (append-if [test item coll] 92 | (if-not test 93 | coll 94 | (concat coll [item])))] 95 | 96 | (defmacro protocol-stub 97 | "Define a new type of record implementing the specified protocols. Its 98 | constructor will take two arguments: 99 | - An object which already satisfies the given protocols. This object will 100 | be delegated to for functions which are not stubbed out. 101 | - A \"log\" function to be called (for side effects) every time a protocol 102 | function is called. For functions marked as :stub (see below), the 103 | log function will be called with two arguments: the function name (an 104 | unqualified symbol), and the arglist (including \"this\"). Functions 105 | marked :forward will have a third argument, the function's return value. 106 | Use this function to implement your logging (or whatever else). 107 | 108 | The macro itself needs two arguments: the name of the record to define, and: 109 | - A map of protocol stubbing specifications. Each key should be a protocol, 110 | and the value another map. It may have zero or more of these keys: 111 | - A :default key specifying either :stub or :forward, to control whether 112 | the underlying implementation is called after logging. Defaults to :stub, 113 | meaning that only the logging function will be called, completely 114 | stubbing out the backing implementation. 115 | - An :exceptions key, listing the functions of this protocol that should 116 | behave the opposite of the :default." 117 | [name proto-specs] 118 | (let [[trace-field impl-field ret] (map gensym '(trace impl ret)) 119 | [impl-kw trace-kw] (map keyword [impl-field trace-field]) 120 | trace (fn [this] `(~trace-kw ~this)) 121 | 122 | proto-fns 123 | (mapify 124 | (for [[name opts] proto-specs 125 | :let [default-behavior (:default opts :stub) 126 | exceptions (set (:exceptions opts)) 127 | proto-var (resolve name) 128 | {:keys [ns name sigs]} (analyze-var proto-var)]] 129 | {(symbol ns name) 130 | (mapify 131 | (for [[fn-key {arglists :arglists, short-name :name}] sigs 132 | :let [forward? (behavior short-name default-behavior exceptions) 133 | fn-name (symbol ns short-name)]] 134 | {fn-key 135 | (cons `fn 136 | (for [[this & args :as argvec] arglists 137 | :let [proxy-args `((~impl-kw ~this) ~@args)]] 138 | `([~@argvec] 139 | (let [~ret ~(when forward? 140 | `(~fn-name ~@proxy-args))] 141 | ~(->> `(~(trace this) '~short-name (list ~@proxy-args)) 142 | (append-if forward? ret)) 143 | ~ret))))}))}))] 144 | `(do 145 | (defrecord ~name [~impl-field ~trace-field]) 146 | (extend ~name 147 | ~@(apply concat proto-fns)))))) 148 | 149 | (defn wrap-with ^{:dont-test "Tested by make-wrappable!, wrap-multiple"} 150 | [f wrapper-var & [name]] 151 | (with-meta 152 | (fn [& args] 153 | (let [wrappers (not-empty @wrapper-var)] 154 | (if-not wrappers 155 | (apply f args) 156 | (with-bindings {wrapper-var 157 | (vary-meta wrappers assoc 158 | ::call-data {:fn-name name})} 159 | (apply (reduce (fn [f wrapper] 160 | (wrapper f)) 161 | f 162 | wrappers) 163 | args))))) 164 | (meta f))) 165 | 166 | (defn make-wrappable! [fn-var wrappers-var & [name]] 167 | (alter-var-root fn-var wrap-with wrappers-var name)) 168 | 169 | (defmacro wrap-multiple [wrappers-var & fn-syms] 170 | (cons `do 171 | (for [f fn-syms] 172 | `(make-wrappable! #'~f ~wrappers-var '~f)))) 173 | 174 | (defmacro defn-wrapping 175 | "Define a function as with defn, which checks the contents of wrappers-var 176 | whenever it is called. If that var is empty, the underlying defn is called 177 | without modification. Otherwise, it is treated as a list of wrapper functions, 178 | which are wrapped around the underlying implementation before it is called. 179 | 180 | The wrappers are applied left-to-right, which means that the rightmost 181 | wrapper is outermost, and the leftmost wrapper is applied just before the base 182 | function. 183 | 184 | The wrappers are not called \"directly\" on the arguments, but are 185 | instead called like Ring wrappers, to create a single function composed of 186 | all of them; the resulting function is called with the actual arguments to 187 | the defn-wrapping function. 188 | 189 | For example, if the wrapped function is -, and the wrappers are 190 | [(fn [f] (fn [x] (* 2 (f x)))), (fn [f] (fn [x] (f (+ 10 x))))], 191 | then the eventual function will behave like (fn [x] (* 2 (- (+ 10 x)))). 192 | 193 | Swapping the order of the wrappers would yield a function behaving like 194 | (fn [x] (* 2 (+ 10 (- x)))). 195 | 196 | Note the order of the wrapping: when called with 10 as an argument, the former 197 | will return -40, and the latter 0." 198 | [name wrappers-var & defn-args] 199 | (let [[name macro-args] (name-with-attributes name defn-args)] 200 | `(doto (defn ~name ~@macro-args) 201 | (make-wrappable! ~wrappers-var '~name)))) 202 | 203 | (defmacro with-wrappers 204 | "Dynamically bind some additional wrappers to the specified wrapper-var 205 | (see defn-wrapping). Each wrapper function will be conj-ed onto the current 206 | set of wrappers." 207 | [wrappers-var wrap-fns & body] 208 | `(with-bindings {~wrappers-var (into @~wrappers-var ~wrap-fns)} 209 | ~@body)) 210 | 211 | (defmacro with-wrapper 212 | "Dynamically bind an additional wrapper to the specified wrapper-var 213 | (see defn-wrapping). The wrapper function will be conj-ed onto the current 214 | set of wrappers." 215 | [wrappers-var wrap-fn & body] 216 | `(with-wrappers ~wrappers-var [~wrap-fn] ~@body)) 217 | 218 | (defn fixes 219 | "Like fix, but each clause is tested whether or not the previous clauses matched, so multiple 220 | transformations may be applied. Unlike fix, fixes does not support a final one-element \"pair\"." 221 | [x & clauses] 222 | (if (odd? (count clauses)) 223 | (throw (IllegalArgumentException. "Fixes does not support a fallback clause.")) 224 | (reduce (fn [acc [pred transform]] 225 | (if ((as-fn pred) acc) 226 | ((as-fn transform) acc) 227 | acc)) 228 | x 229 | (partition 2 clauses)))) 230 | 231 | (defn lift-meta 232 | "Move some of the keys from m into its metadata, overriding existing values. 233 | (lift-meta {:a 1 :b 2} [:a]) -> ^{:a 1} {:b 2}" 234 | [m & ks] 235 | (-> (apply dissoc m ks) 236 | (vary-meta merge (select-keys m ks)))) 237 | 238 | (defn prefix-lookup 239 | "Takes a map whose keys are names, and returns a function that does fast prefix 240 | matching on its input against the names in the original map, returning the 241 | first value whose key is a prefix. 242 | 243 | If order is important (eg because your prefixes overlap, or you want to test 244 | common prefixes first for performance), you can pass a sequence of pairs 245 | instead of a map." 246 | [prefix-map] 247 | (let [name-pairs (map (knit name identity) prefix-map)] 248 | (fn [^String s] 249 | (when-let [pair (find-first #(.startsWith s (first %)) 250 | name-pairs)] 251 | (second pair))))) 252 | -------------------------------------------------------------------------------- /src/flatland/useful/experimental/delegate.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.experimental.delegate 2 | (:use flatland.useful.debug) 3 | (:require [flatland.useful.ns :as ns])) 4 | 5 | (defn canonical-name 6 | "Resolve a symbol in the current namespace; but intead of returning its value, 7 | return a canonical name that can be used to name the same thing in any 8 | namespace." 9 | [sym] 10 | (if-let [val (resolve sym)] 11 | (condp instance? val 12 | java.lang.Class (symbol (pr-str val)) 13 | clojure.lang.Var (ns/var-name val) 14 | (throw (IllegalArgumentException. 15 | (format "%s names %s, an instance of %s, which has no canonical name." 16 | sym val (class val))))) 17 | sym)) 18 | 19 | (defn parse-deftype-specs 20 | "Given a mess of deftype specs, possibly with classes/interfaces specified multiple times, 21 | collapse it into a map like {interface => (method1 method2...)}. 22 | Needed because core.deftype only allows specifying a class ONCE, so our delegating versions would 23 | clash with client's custom methods." 24 | [decls] 25 | (loop [ret {}, curr-key nil, decls decls] 26 | (if-let [[x & xs] (seq decls)] 27 | (if (seq? x) 28 | (let [mname (symbol (name (first x))) 29 | nargs (count (second x))] 30 | (recur (assoc-in ret [curr-key [mname nargs]] x), 31 | curr-key, xs)) 32 | (let [interface-name (canonical-name x)] 33 | (recur (update-in ret [interface-name] #(or % {})), 34 | interface-name, xs))) 35 | ret))) 36 | 37 | (defn emit-deftype-specs 38 | "Given a map returned by aggregate, spit out a flattened deftype body." 39 | [specs] 40 | (apply concat 41 | (for [[interface methods] specs] 42 | (cons interface 43 | (for [[[method-name num-args] method] methods] 44 | method))))) 45 | 46 | (letfn [;; Output the method body for a delegating implementation 47 | (delegating-method [method-name args delegate] 48 | `(~method-name [~'_ ~@args] 49 | (. ~delegate (~method-name ~@args)))) 50 | 51 | ;; Create a series of Interface (method...) (method...) expressions, 52 | ;; suitable for creating the entire body of a deftype or reify. 53 | (type-body [delegate-map other-args] 54 | (let [our-stuff (for [[send-to interfaces] delegate-map 55 | [interface which] interfaces 56 | :let [send-to (vary-meta send-to 57 | assoc :tag interface)] 58 | [name args] which] 59 | [interface (delegating-method name args send-to)])] 60 | (emit-deftype-specs 61 | (parse-deftype-specs 62 | (apply concat other-args our-stuff)))))] 63 | 64 | (defmacro delegating-deftype 65 | "Shorthand for defining a new type with deftype, which delegates the methods you name to some 66 | other object or objects. Delegates are usually a member field, but can be any expression: the 67 | expression will be evaluated every time a method is delegated. The delegate object (or 68 | expression) will be type-hinted with the type of the interface being delegated. 69 | 70 | The delegate-map argument should be structured like: 71 | {object-to-delegate-to {Interface1 [(method1 []) 72 | (method2 [foo bar baz])] 73 | Interface2 [(otherMethod [other])]}, 74 | another-object {Interface1 [(method3 [whatever])]}}. 75 | 76 | This will cause your deftype to include an implementation of Interface1.method1 which does its 77 | work by forwarding to (.method1 object-to-delegate-to), and likewise for the other 78 | methods. Arguments will be forwarded on untouched, and you should not include a `this` 79 | parameter. Note especially that you can have methods from Interface1 implemented by delegating 80 | to multiple objects if you choose, and can also include custom implementations for the remaining 81 | methods of Interface1 if you have no suitable delegate. 82 | 83 | Arguments after `delegate-map` are as with deftype, although if deftype ever has options defined 84 | for it, delegating-deftype may break with them." 85 | [cname [& fields] delegate-map & deftype-args] 86 | `(deftype ~cname [~@fields] 87 | ~@(type-body delegate-map deftype-args))) 88 | 89 | (defmacro delegating-defrecord 90 | "Like delegating-deftype, but creates a defrecod body instead of a deftype." 91 | [cname [& fields] delegate-map & deftype-args] 92 | `(defrecord ~cname [~@fields] 93 | ~@(type-body delegate-map deftype-args))) 94 | 95 | (defmacro delegating-reify 96 | "Like delegating-deftype, but creates a reify body instead of a deftype." 97 | [delegate-map & reify-args] 98 | `(reify ~@(type-body delegate-map reify-args)))) -------------------------------------------------------------------------------- /src/flatland/useful/experimental/unicode.clj: -------------------------------------------------------------------------------- 1 | (ns ^{:dont-test "Just aliases for other functions/macros"} 2 | flatland.useful.experimental.unicode 3 | (:use [flatland.useful.utils :only [map-entry]] 4 | [flatland.useful.macro :only [macro-do]] 5 | [flatland.useful.ns :only [defalias]])) 6 | 7 | (macro-do [dest src] 8 | `(defalias ~dest ~src) 9 | ∮ map-entry 10 | ! complement 11 | ∘ comp 12 | φ partial) 13 | -------------------------------------------------------------------------------- /src/flatland/useful/fn.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.fn) 2 | 3 | (def ! complement) 4 | 5 | (defn validator 6 | "Create a version of a predicate that only tests its output for truthiness, 7 | returning the original input value if the predicate evaluates to anything 8 | truthy, and nil otherwise. ((validator even?) 10) => 10, even though 9 | (even? 10) is true." 10 | [pred] 11 | (fn [x] 12 | (when (pred x) 13 | x))) 14 | 15 | (defn decorate 16 | "Return a function f such that (f x) => [x (f1 x) (f2 x) ...]." 17 | [& fs] 18 | (apply juxt identity fs)) 19 | 20 | (defn annotate 21 | "A vector of [x (f1 x) (f2 x) ...]." 22 | [x & fs] 23 | ((apply decorate fs) x)) 24 | 25 | (defn as-fn 26 | "Turn an object into a fn if it is not already, by wrapping it in constantly." 27 | [x] 28 | (if (ifn? x) x, (constantly x))) 29 | 30 | (defn fix 31 | "Walk through clauses, a series of predicate/transform pairs. The 32 | first predicate that x satisfies has its transformation clause 33 | called on x. Predicates or transforms may be values (eg true or nil) 34 | rather than functions; these will be treated as functions that 35 | return that value. 36 | 37 | The last \"pair\" may be only a transform with no pred: in that case it 38 | is unconditionally used to transform x, if nothing previously matched. 39 | 40 | If no predicate matches, then x is returned unchanged." 41 | [x & clauses] 42 | (let [call #((as-fn %) x)] 43 | (first (or (seq (for [[pred & [transform :as exists?]] (partition-all 2 clauses) 44 | :let [[pred transform] ;; handle odd number of clauses 45 | (if exists? [pred transform] [true pred])] 46 | :when (call pred)] 47 | (call transform))) 48 | [x])))) 49 | 50 | (defn to-fix 51 | "A \"curried\" version of fix, which sets the clauses once, yielding a 52 | function that calls fix with the specified first argument." 53 | [& clauses] 54 | (fn [x] 55 | (apply fix x clauses))) 56 | 57 | (defn fixing 58 | "A version of fix that fits better with the unified update model: instead of multiple clauses, 59 | additional args to the transform function are permitted. For example, 60 | (swap! my-atom fixing map? update-in [k] inc)" 61 | [x pred transform & args] 62 | (if ((as-fn pred) x) 63 | (apply (as-fn transform) x args) 64 | x)) 65 | 66 | (defmacro given 67 | "A macro combining the features of fix and fixing, by using parentheses to group the 68 | additional arguments to each clause: 69 | (-> x 70 | (given string? read-string 71 | map? (dissoc :x :y :z) 72 | even? (/ 2)))" 73 | [x & clauses] 74 | (let [[clauses default] (if (even? (count clauses)) 75 | [clauses `identity] 76 | [(butlast clauses) (last clauses)])] 77 | `(fix ~x ~@(for [[pred transform] (partition 2 clauses) 78 | arg [pred `#(-> % ~transform)]] 79 | arg) 80 | ~default))) 81 | 82 | (defn any 83 | "Takes a list of predicates and returns a new predicate that returns true if any do." 84 | [& preds] 85 | (fn [& args] 86 | (some #(apply % args) preds))) 87 | 88 | (defn all 89 | "Takes a list of predicates and returns a new predicate that returns true if all do." 90 | [& preds] 91 | (fn [& args] 92 | (every? #(apply % args) preds))) 93 | 94 | (defn knit 95 | "Takes a list of functions (f1 f2 ... fn) and returns a new function F. F takes 96 | a collection of size n (x1 x2 ... xn) and returns a vector [(f1 x1) (f2 x2) ... (fn xn)]. 97 | Similar to Haskell's ***, and a nice complement to juxt (which is Haskell's &&&)." 98 | [& fs] 99 | (fn [arg-coll] 100 | (vec (map #(% %2) fs arg-coll)))) 101 | 102 | (defn thrush 103 | "Takes the first argument and applies the remaining arguments to it as functions from left to right. 104 | This tiny implementation was written by Chris Houser. http://blog.fogus.me/2010/09/28/thrush-in-clojure-redux" 105 | [& args] 106 | (reduce #(%2 %1) args)) 107 | 108 | (defn ignoring-nils 109 | "Create a new version of a function which ignores all nils in its arguments: 110 | ((ignoring-nils +) 1 nil 2 3 nil) yields 6." 111 | [f] 112 | (fn 113 | ([] (f)) 114 | ([a] (if (nil? a) 115 | (f) 116 | (f a))) 117 | ([a b] 118 | (if (nil? a) 119 | (if (nil? b) 120 | (f) 121 | (f b)) 122 | (if (nil? b) 123 | (f a) 124 | (f a b)))) 125 | ([a b & more] 126 | (when-let [items (seq (remove nil? (list* a b more)))] 127 | (apply f items))))) 128 | 129 | (defn key-comparator 130 | "Given a transformation function (and optionally a direction), return a 131 | comparator which does its work by comparing the values of (transform x) and 132 | (transform y)." 133 | ([modifier] 134 | (fn [a b] 135 | (compare (modifier a) (modifier b)))) 136 | ([direction modifier] 137 | (let [f (key-comparator modifier)] 138 | (condp #(% %2) direction 139 | #{:desc :descending -} (comp - f) 140 | #{:asc :ascending +} f)))) 141 | 142 | (defn rate-limited 143 | "Create a version of a function which 'refuses' to be called too 144 | frequently. If it has successfully been called in the last N milliseconds, 145 | calls to it will return nil; if no calls have succeeded in that period, args 146 | will be passed along to the base function." 147 | [f ms-period] 148 | (let [tracker (atom {:last-sent 0})] 149 | (fn [& args] 150 | (when (:accepted (swap! tracker 151 | (fn [{:keys [last-sent]}] 152 | (let [now (System/currentTimeMillis) 153 | ok (< ms-period (- now last-sent))] 154 | {:accepted ok 155 | :last-sent (if ok now last-sent)})))) 156 | (apply f args))))) 157 | 158 | (defn memoize-last 159 | "A version of memoize that only remembers the result for a single input 160 | argument at a time. eg, if you call (f 1) (f 1) (f 2) (f 1), only the 161 | second call is memoized, because it is the same argument you just gave. 162 | The third and fourth calls see a new argument, and therefore refresh the 163 | cached value." 164 | [f] 165 | (let [cache (atom nil)] 166 | (fn [& args] 167 | (:value (swap! cache 168 | (fn [cache] 169 | (if (= args (get cache :args ::not-found)) 170 | cache 171 | {:args args, :value (apply f args)}))))))) 172 | 173 | (defn applied 174 | "A version of f that uses apply on its args." 175 | [f] 176 | (partial apply f)) 177 | 178 | (def ap "A shorthand version of applied" applied) 179 | -------------------------------------------------------------------------------- /src/flatland/useful/io.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.io 2 | (:use [clojure.java.io :only [reader]] 3 | [flatland.useful.ns :only [defalias]] 4 | [flatland.useful.map :only [keyed]]) 5 | (:require [clojure.tools.reader.edn :as edn]) 6 | (:import (java.io Reader PushbackReader 7 | ByteArrayInputStream ByteArrayOutputStream 8 | DataOutputStream DataInputStream 9 | RandomAccessFile) 10 | (java.nio.channels FileChannel$MapMode))) 11 | 12 | (defprotocol PushbackFactory 13 | (^{:added "1.4"} pushback-reader [x] "Creates a PushbackReader from an object.")) 14 | 15 | (extend-protocol PushbackFactory 16 | PushbackReader 17 | (pushback-reader [this] 18 | this) 19 | 20 | Reader 21 | (pushback-reader [this] 22 | (PushbackReader. this)) 23 | 24 | Object 25 | (pushback-reader [this] 26 | (pushback-reader (reader this)))) 27 | 28 | (defalias pbr pushback-reader) 29 | 30 | (let [sentinel (Object.) 31 | valid? #(not (identical? % sentinel))] 32 | (defn read-seq 33 | "Read a lazy sequence of Clojure forms from an input reader." 34 | [in] 35 | (let [in (pushback-reader in)] 36 | (take-while valid? 37 | (repeatedly #(edn/read {:eof sentinel} in)))))) 38 | 39 | (defn bytes->long 40 | "Read the first eight bytes of a byte-array and convert them to a Long using the standard 41 | network order (by delegating to DataInputStream)." 42 | [bytes] 43 | (-> bytes (ByteArrayInputStream.) (DataInputStream.) (.readLong))) 44 | 45 | (defn long->bytes 46 | "Create an eight-byte array from a Long, using the standard 47 | network order (by delegating to DataOutputStream)." 48 | [long] 49 | (-> (ByteArrayOutputStream. 8) 50 | (doto (-> (DataOutputStream.) (.writeLong long))) 51 | (.toByteArray))) 52 | 53 | (defn compare-bytes [^"[B" a ^"[B" b] 54 | (let [alen (alength a) 55 | blen (alength b) 56 | len (int (min alen blen))] 57 | (loop [idx (int 0)] 58 | (if (= idx len) 59 | (compare alen blen) 60 | (let [ai (long (aget a idx)) 61 | bi (long (aget b idx)) 62 | neg-ai? (neg? ai) 63 | diff (if (= neg-ai? (neg? bi)) 64 | (unchecked-subtract ai bi) 65 | (if neg-ai? 1 -1))] ;; cannot subtract if signs are different 66 | (if (zero? diff) 67 | (recur (unchecked-inc-int idx)) 68 | diff)))))) 69 | 70 | (defn mmap-file 71 | "Memory map a file. Returns a map containing a :buffer key which holds the 72 | mapped buffer and a :close key containing a function that, when called, 73 | closes the file." 74 | [^RandomAccessFile file] 75 | (let [channel (.getChannel file) 76 | buffer (.map channel FileChannel$MapMode/READ_WRITE 0 (.size channel)) 77 | close #(.close file)] 78 | (keyed [buffer close]))) 79 | -------------------------------------------------------------------------------- /src/flatland/useful/java.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.java 2 | (:import (java.lang.reflect Method))) 3 | 4 | (defn ^{:dont-test "Can't test killing the JVM"} abort 5 | "Print message then exit." 6 | [& message] 7 | (apply println message) 8 | (System/exit 1)) 9 | 10 | (defn ^{:dont-test "Can't send a signal in order to catch it!"} trap 11 | "Register signal handling function." 12 | [signal f] 13 | (sun.misc.Signal/handle 14 | (sun.misc.Signal. signal) 15 | (proxy [sun.misc.SignalHandler] [] 16 | (handle [sig] (f sig))))) 17 | 18 | (defn construct 19 | "Construct a new instance of class using reflection." 20 | [class & args] 21 | (clojure.lang.Reflector/invokeConstructor class (into-array Object args))) 22 | 23 | (defn invoke-private 24 | "Invoke a private or protected Java method. Be very careful when using this! 25 | I take no responsibility for the trouble you get yourself into." 26 | [instance method & params] 27 | (let [signature (into-array Class (map class params)) 28 | c (class instance)] 29 | (when-let [^Method method (some #(try 30 | (.getDeclaredMethod ^Class % method signature) 31 | (catch NoSuchMethodException e)) 32 | (conj (ancestors c) c))] 33 | (let [accessible (.isAccessible method)] 34 | (.setAccessible method true) 35 | (let [result (.invoke method instance (into-array params))] 36 | (.setAccessible method accessible) 37 | result))))) 38 | 39 | (defn ^{:dont-test "Can't test shutting down JVM"} on-shutdown 40 | "Execute the given function on jvm shutdown." 41 | [^Runnable f] 42 | (.addShutdownHook 43 | (Runtime/getRuntime) 44 | (Thread. f))) 45 | 46 | (defmacro multi-hinted-let 47 | "Test expr for instance-of each class in classes. When a match is found, 48 | evaluate body with name bound to expr and type-hinted as the matching class. 49 | 50 | For example, (multi-hinted-let [x {:foo 1} [Collection Map]] (.size x))." 51 | [[name expr classes] & body] 52 | (let [x (gensym)] 53 | `(let [~x ~expr] 54 | (condp instance? ~x 55 | ~@(interleave classes 56 | (for [class classes] 57 | `(let [~(vary-meta name assoc :tag class) ~x] ~@body))) 58 | (throw (IllegalArgumentException. (str "No matching class for " ~x " in " '~classes))))))) 59 | -------------------------------------------------------------------------------- /src/flatland/useful/macro.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.macro 2 | (:use [clojure.tools.macro :only [macrolet]])) 3 | 4 | (defmacro anon-macro 5 | "Define, and then immediately use, an anonymous macro. For 6 | example, (anon-macro [x y] `(def ~x ~y) myconst 10) expands to (def 7 | myconst 10)." 8 | ([args macro-body & body] 9 | `(macrolet [(name# ~args ~macro-body)] 10 | (name# ~@body)))) 11 | 12 | (letfn [(partition-params [argvec actual-args] 13 | (if (some #{'&} argvec) 14 | [actual-args] ; one seq with all args 15 | (vec (map vec (partition (count argvec) actual-args)))))] 16 | 17 | (defmacro macro-do 18 | "Wrap a list of forms with an anonymous macro, which partitions the 19 | forms into chunks of the right size for the macro's arglists. The 20 | macro's body will be called once for every N items in the args 21 | list, where N is the number of arguments the macro accepts. The 22 | result of all expansions will be glued together in a (do ...) form. 23 | 24 | Really, the macro is only called once, and is adjusted to expand 25 | into a (do ...) form, but this is probably an implementation detail 26 | that I'm not sure how a client could detect. 27 | 28 | For example, 29 | (macro-do [[f & args]] 30 | `(def ~(symbol (str \"basic-\" f)) 31 | (partial ~f ~@args)) 32 | [f 'test] [y 1 2 3]) 33 | expands into (do 34 | (def basic-f (partial f 'test)) 35 | (def basic-y (partial y 1 2 3)))" 36 | ([macro-args body & args] 37 | `(anon-macro [arg#] 38 | (cons 'do 39 | (for [~macro-args arg#] 40 | ~body)) 41 | ~(partition-params macro-args args))))) 42 | -------------------------------------------------------------------------------- /src/flatland/useful/map.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.map 2 | (:refer-clojure :exclude [update]) 3 | (:use [flatland.useful.utils :only [map-entry pop-if]] 4 | [flatland.useful.fn :only [to-fix !]])) 5 | 6 | (let [transforms {:keys keyword 7 | :strs str 8 | :syms identity}] 9 | (defmacro keyed 10 | "Create a map in which, for each symbol S in vars, (keyword S) is a 11 | key mapping to the value of S in the current scope. If passed an optional 12 | :strs or :syms first argument, use strings or symbols as the keys instead." 13 | ([vars] `(keyed :keys ~vars)) 14 | ([key-type vars] 15 | (let [transform (comp (partial list `quote) 16 | (transforms key-type))] 17 | (into {} (map (juxt transform identity) vars)))))) 18 | 19 | (defn assoc-or 20 | "Create mapping from each key to val in map only if existing val is nil." 21 | ([m key val] 22 | (if (nil? (m key)) 23 | (assoc m key val) 24 | m)) 25 | ([m key val & kvs] 26 | (let [m (assoc-or m key val)] 27 | (if kvs 28 | (recur m (first kvs) (second kvs) (nnext kvs)) 29 | m)))) 30 | 31 | (defn into-map 32 | "Convert a list of heterogeneous args into a map. Args can be alternating keys and values, 33 | maps of keys to values or collections of alternating keys and values. If the first arg is 34 | a function, it will be used for merging duplicate values." 35 | [& args] 36 | (let [[args combine] (pop-if (apply list args) fn? (fn [_ x] x))] 37 | (loop [args args m {}] 38 | (if (empty? args) 39 | m 40 | (let [arg (first args) 41 | args (rest args)] 42 | (condp #(%1 %2) arg 43 | nil? (recur args m) 44 | map? (recur args (merge-with combine m arg)) 45 | coll? (recur (into args (reverse arg)) m) 46 | (recur (conj (rest args) {arg (first args)}) m))))))) 47 | 48 | (defn map-vals 49 | "Create a new map from m by calling function f on each value to get a new value." 50 | [m f & args] 51 | (when m 52 | (into {} 53 | (for [[k v] m] 54 | (map-entry k (apply f v args)))))) 55 | 56 | (defn map-keys 57 | "Create a new map from m by calling function f on each key to get a new key." 58 | [m f & args] 59 | (when m 60 | (into {} 61 | (for [[k v] m] 62 | (map-entry (apply f k args) v))))) 63 | 64 | (defn map-vals-with-keys 65 | "Create a new map from m by calling function f, with two arguments (the key and value) 66 | to get a new value." 67 | [m f & args] 68 | (when m 69 | (into {} 70 | (for [[k v] m] 71 | (map-entry k (apply f k v args)))))) 72 | 73 | (defn map-keys-and-vals 74 | "Create a new map from m by calling function f on each key & each value to get a new key & value" 75 | [m f & args] 76 | (when m 77 | (into {} 78 | (for [[k v] m] 79 | (map-entry (apply f k args) (apply f v args)))))) 80 | 81 | (defn dissoc-in* 82 | "Dissociates a value in a nested associative structure, where ks is a sequence of keys and returns 83 | a new nested structure. If any resulting maps are empty, they will be removed from the new 84 | structure. This implementation was adapted from clojure.core.contrib, but the behavior is more 85 | correct if keys is empty." 86 | [m keys] 87 | (if-let [[k & ks] (seq keys)] 88 | (let [old (get m k ::sentinel)] 89 | (if-not (= old ::sentinel) 90 | (let [new (dissoc-in* old ks)] 91 | (if (seq new) 92 | (assoc m k new) 93 | (dissoc m k))) 94 | m)) 95 | {})) 96 | 97 | (defn assoc-in* 98 | "Associates a value in a nested associative structure, where ks is a sequence of keys and v is the 99 | new value and returns a new nested structure. If any levels do not exist, hash-maps will be 100 | created. This implementation was adapted from clojure.core, but the behavior is more correct if 101 | keys is empty." 102 | [m keys v] 103 | (if-let [[k & ks] (seq keys)] 104 | (assoc m k (assoc-in* (get m k) ks v)) 105 | v)) 106 | 107 | (defn update-in* 108 | "Updates a value in a nested associative structure, where ks is a sequence of keys and f is a 109 | function that will take the old value and any supplied args and return the new value, and returns 110 | a new nested structure. If any levels do not exist, hash-maps will be created. This implementation 111 | was adapted from clojure.core, but the behavior is more correct if keys is empty and unchanged 112 | values are not re-assoc'd." 113 | [m keys f & args] 114 | (if-let [[k & ks] (seq keys)] 115 | (let [old (get m k) 116 | new (apply update-in* old ks f args)] 117 | (if (identical? old new) 118 | m 119 | (assoc m k new))) 120 | (apply f m args))) 121 | 122 | (defn update 123 | "Update a value for the given key in a map where f is a function that takes the previous value and 124 | the supplied args and returns the new value. Like update-in*, unchanged values are not 125 | re-assoc'd." 126 | [m key f & args] 127 | (apply update-in* m [key] f args)) 128 | 129 | (defn update-each 130 | "Update the values for each of the given keys in a map where f is a function that takes each 131 | previous value and the supplied args and returns a new value. Like update-in*, unchanged values 132 | are not re-assoc'd." 133 | [m keys f & args] 134 | (reduce (fn [m key] 135 | (apply update-in* m [key] f args)) 136 | m keys)) 137 | 138 | (defn update-within 139 | "Like update-in*, but don't call f at all unless the map contains something at the given keyseq." 140 | [m keyseq f & args] 141 | (if (seq keyseq) 142 | (update-in* m (butlast keyseq) 143 | (fn [m*] 144 | (let [k (last keyseq)] 145 | (if (contains? m* k) 146 | (apply update m* k f args) 147 | m*)))) 148 | (apply f m args))) 149 | 150 | (letfn [(merge-in* [a b] 151 | (if (map? a) 152 | (merge-with merge-in* a b) 153 | b))] 154 | (defn merge-in 155 | "Merge multiple nested maps." 156 | [& args] 157 | (reduce merge-in* nil args))) 158 | 159 | (defn update-in! 160 | "'Updates' a value in a nested associative structure, where ks is a sequence of keys and 161 | f is a function that will take the old value and any supplied args and return the new 162 | value, and returns a new nested structure. The associative structure can have transients 163 | in it, but if any levels do not exist, non-transient hash-maps will be created." 164 | [m [k & ks] f & args] 165 | (let [assoc (if (instance? clojure.lang.ITransientCollection m) assoc! assoc) 166 | val (get m k)] 167 | (assoc m k (if ks 168 | (apply update-in! val ks f args) 169 | (apply f val args))))) 170 | 171 | (defn assoc-in! 172 | "Associates a value in a nested associative structure, where ks is a sequence of keys 173 | and v is the new value and returns a new nested structure. The associative structure 174 | can have transients in it, but if any levels do not exist, non-transient hash-maps will 175 | be created." 176 | [m ks v] 177 | (update-in! m ks (constantly v))) 178 | 179 | (defn map-to 180 | "Returns a map from each item in coll to f applied to that item." 181 | [f coll] 182 | (into {} 183 | (for [item (distinct coll)] 184 | (map-entry item (f item))))) 185 | 186 | (defn index-by 187 | "Returns a map from the result of calling f on each item in coll to that item." 188 | [f coll] 189 | (into {} 190 | (for [item coll] 191 | (map-entry (f item) item)))) 192 | 193 | (defn position 194 | "Returns a map from item to the position of its first occurence in coll." 195 | [coll] 196 | (into {} (reverse (map-indexed (fn [idx val] (map-entry val idx)) coll)))) 197 | 198 | (defn filter-keys-by-val 199 | "Returns all keys in map for which (pred value) returns true." 200 | [pred m] 201 | (when m 202 | (for [[key val] m :when (pred val)] key))) 203 | 204 | (defn remove-keys-by-val 205 | "Returns all keys of map for which (pred value) returns false." 206 | [pred m] 207 | (filter-keys-by-val (complement pred) m)) 208 | 209 | (defn filter-vals [m pred] 210 | (when m 211 | (persistent! (reduce (fn [m [k v]] 212 | (if (pred v) 213 | m 214 | (dissoc! m k))) 215 | (transient m) 216 | m)))) 217 | 218 | (defn remove-vals 219 | "Returns a map that only contains values where (pred value) returns false." 220 | [m pred] 221 | (filter-vals m (complement pred))) 222 | 223 | (defn filter-keys 224 | "Returns a map that only contains keys where (pred key) returns true." 225 | [m pred] 226 | (when m 227 | (select-keys m (filter pred (keys m))))) 228 | 229 | (defn remove-keys 230 | "Returns a map that only contains keys where (pred key) returns false." 231 | [m pred] 232 | (filter-keys m (complement pred))) 233 | 234 | (defn multi-map 235 | "Takes a map with keys and values that can be sets or individual objects and returns a map from 236 | objects to sets. Used to create associations between two sets of objects." 237 | [m] 238 | (apply merge-with into 239 | (for [entry m, :let [[ks vs] (map (to-fix (! set?) hash-set) entry)] 240 | k ks] 241 | {k vs}))) 242 | 243 | (defn ordering-map 244 | "Create an empty map with a custom comparator that puts the given keys first, in the order 245 | specified. Other keys will be placed after the special keys, sorted by the default-comparator." 246 | ([key-order] (ordering-map key-order compare)) 247 | ([key-order default-comparator] 248 | (let [indices (into {} (map-indexed (fn [i x] [x i]) key-order))] 249 | (sorted-map-by (fn [a b] 250 | (if-let [a-idx (indices a)] 251 | (if-let [b-idx (indices b)] 252 | (compare a-idx b-idx) 253 | -1) 254 | (if-let [b-idx (indices b)] 255 | 1 256 | (default-comparator a b)))))))) 257 | -------------------------------------------------------------------------------- /src/flatland/useful/ns.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.ns) 2 | 3 | (defn var-name 4 | "Get the namespace-qualified name of a var." 5 | [v] 6 | (apply symbol (map str ((juxt (comp ns-name :ns) 7 | :name) 8 | (meta v))))) 9 | 10 | (defn alias-var 11 | "Create a var with the supplied name in the current namespace, having the same 12 | metadata and root-binding as the supplied var." 13 | [name ^clojure.lang.Var var] 14 | (apply intern *ns* (with-meta name (merge {:dont-test (str "Alias of " (var-name var))} 15 | (meta var) 16 | (meta name))) 17 | (when (.hasRoot var) [@var]))) 18 | 19 | (defmacro defalias 20 | "Defines an alias for a var: a new var with the same root binding (if 21 | any) and similar metadata. The metadata of the alias is its initial 22 | metadata (as provided by def) merged into the metadata of the original." 23 | [dst src] 24 | `(alias-var (quote ~dst) (var ~src))) 25 | 26 | (defn alias-ns 27 | "Create vars in the current namespace to alias each of the public vars in 28 | the supplied namespace." 29 | [ns-name] 30 | (require ns-name) 31 | (doseq [[name var] (ns-publics (the-ns ns-name))] 32 | (alias-var name var))) 33 | -------------------------------------------------------------------------------- /src/flatland/useful/parallel.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.parallel 2 | (:use [flatland.useful.seq :only [slice]])) 3 | 4 | (def ^{:dynamic true} *pcollect-thread-num* (.. Runtime getRuntime availableProcessors)) 5 | 6 | (defn pcollect 7 | "Like pmap but not lazy and more efficient for less computationally intensive functions 8 | because there is less coordination overhead. The collection is sliced among the 9 | available processors and f is applied to each sub-collection in parallel using map." 10 | ([f coll] 11 | (pcollect identity f coll)) 12 | ([wrap-fn f coll] 13 | (if (<= *pcollect-thread-num* 1) 14 | ((wrap-fn #(doall (map f coll)))) 15 | (mapcat deref 16 | (map (fn [slice] 17 | (let [body (wrap-fn #(doall (map f slice)))] 18 | (future-call body))) 19 | (slice *pcollect-thread-num* coll)))))) 20 | 21 | 22 | (defn- assoc-noclobber 23 | "An assoc wrapper which ensures that existing keys will not be 24 | clobbered by subsequent assoc invocations. 25 | 26 | Used as a helper for locking-memoize to ensure that (delay) refs 27 | cannot be lost by swap! retry behavior." 28 | 29 | [m k v] 30 | (if (contains? m k) m 31 | (assoc m k v))) 32 | 33 | (defn pmemoize 34 | "Memoizes the function f, using the same approach as 35 | clojure.core/memoize. The practical difference is that this function 36 | provides the gurantee that in spite of parallel invocations of the 37 | memoized function each input to f will only ever be memoized 38 | once. This resolves an implementation detail in clojure.core/memoize 39 | which allows f to be applied to args without locking the cache to 40 | prevent other threads duplicating the work." 41 | 42 | [f] 43 | (let [mem (atom {})] 44 | (fn [ & args ] 45 | (if-let [e (find @mem args)] 46 | (deref (val e)) 47 | (-> (swap! mem assoc-noclobber 48 | args (delay (apply f args))) 49 | (get args) 50 | (deref)))))) 51 | -------------------------------------------------------------------------------- /src/flatland/useful/seq.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.seq 2 | (:use [flatland.useful.fn :only [decorate]] 3 | [flatland.useful.utils :only [pair]]) 4 | (:import (java.util.concurrent LinkedBlockingQueue 5 | BlockingQueue))) 6 | 7 | (defn find-first 8 | "Returns the first item of coll where (pred item) returns logical true." 9 | [pred coll] 10 | (first (filter pred coll))) 11 | 12 | (defn find-with 13 | "Returns the val corresponding to the first key where (pred key) returns true." 14 | [pred keys vals] 15 | (->> (map vector keys vals) 16 | (find-first (comp pred first)) 17 | last)) 18 | 19 | (defn extract 20 | "Extracts the first item that matches pred from coll, returning a vector of that item 21 | followed by coll with the item removed." 22 | [pred coll] 23 | (let [[head [item & tail]] (split-with (complement pred) coll)] 24 | [item (concat head tail)])) 25 | 26 | (defn separate 27 | "Split coll into two sequences, one that matches pred and one that doesn't. Unlike the 28 | version in clojure.contrib.seq-utils, pred is only called once per item." 29 | [pred coll] 30 | (let [pcoll (map (decorate pred) coll)] 31 | (vec (for [f [filter remove]] 32 | (map first (f second pcoll)))))) 33 | 34 | (defn include? 35 | "Check if val exists in coll." 36 | [val coll] 37 | (some (partial = val) coll)) 38 | 39 | (defn zip 40 | "Returns a lazy sequence of vectors of corresponding items from each collection. If one collection 41 | is longer than the others, the missing items will be filled in with nils." 42 | [& colls] 43 | (lazy-seq 44 | (when (some seq colls) 45 | (cons (vec (map first colls)) 46 | (apply zip (map rest colls)))))) 47 | 48 | (defn insert 49 | "Inserts a seq of items into coll at position n." 50 | [items n coll] 51 | (let [[before after] (split-at n coll)] 52 | (concat before items after))) 53 | 54 | (defn slice 55 | "Divide coll into n approximately equal slices." 56 | [n coll] 57 | (loop [num n, slices [], items (vec coll)] 58 | (if (empty? items) 59 | slices 60 | (let [size (Math/ceil (/ (count items) num))] 61 | (recur (dec num) (conj slices (subvec items 0 size)) (subvec items size)))))) 62 | 63 | (defn cross 64 | "Computes the cartesian-product of the provided seqs. In other words, compute the set of all 65 | possible combinations of ways you can choose one item from each seq." 66 | [& seqs] 67 | (if (seq (rest seqs)) 68 | (for [x (first seqs) 69 | y (apply cross (rest seqs))] 70 | (cons x y)) 71 | (map list (first seqs)))) 72 | 73 | (defn lazy-cross 74 | "Compute a lazy cartesian-product of the provided seqs. The provided seqs can be lazy or even 75 | infinite, and lazy-cross will consume all sequences equally, only consuming more of any sequence 76 | when all possible combinations at the current level have been exhausted. This can be thought of 77 | intuitively as a breadth-first search of the cartesian product set." 78 | [& seqs] 79 | (letfn [(step [heads tails dim] 80 | (lazy-seq 81 | (when (< dim (count tails)) 82 | (let [tail (get tails dim)] 83 | (concat (apply cross (assoc heads dim tail)) 84 | (step (update-in heads [dim] concat tail) 85 | tails (inc dim))))))) 86 | (lazy-cross [seqs level] 87 | (lazy-seq 88 | (let [heads (vec (map #(take level %) seqs)) 89 | tails (vec (map #(take 1 (drop level %)) seqs))] 90 | (when-not (every? empty? tails) 91 | (concat (step heads tails 0) 92 | (lazy-cross seqs (inc level)))))))] 93 | (lazy-cross seqs 0))) 94 | 95 | (defn alternates 96 | "Split coll into 'threads' subsequences (defaults to 2), feeding 97 | each alternately from the input sequence. Effectively the inverse of 98 | interleave: 99 | 100 | (alternates 3 (range 9)) 101 | ;=> ((0 3 6) (1 4 7) (2 5 8))" 102 | ([coll] (alternates 2 coll)) 103 | ([threads coll] 104 | (lazy-seq 105 | (when (seq coll) 106 | (apply map list (partition threads coll)))))) 107 | 108 | (defmacro lazy-loop 109 | "Provide a simplified version of lazy-seq to eliminate 110 | boilerplate. Arguments are as to the built-in (loop...recur), 111 | and (lazy-recur) will be defined for you. However, instead of doing 112 | actual tail recursion, lazy-recur trampolines through lazy-seq. In 113 | addition to enabling laziness, this means you can call lazy-recur 114 | when not in the tail position. 115 | 116 | Regular recurs are also supported, if they are in tail position and don't 117 | need any laziness." 118 | [bindings & body] 119 | (let [f 'lazy-recur 120 | [names values] (alternates bindings)] 121 | `(letfn [(~f [~@names] 122 | (lazy-seq 123 | (iter# ~@names))) 124 | (iter# [~@names] 125 | ~@body)] 126 | (~f ~@values)))) 127 | 128 | (defn unfold 129 | "Traditionally unfold is the 'opposite of reduce': it turns a single 130 | seed value into a (possibly infinite) lazy sequence of output 131 | values. 132 | 133 | Next is a function that operates on a seed: it should 134 | return a pair, [value new-seed]; the value half of the pair is 135 | inserted into the resulting list, while the new seed is used to 136 | continue unfolding. Notably, the value is never passed as an 137 | argument to next. If nil is returned instead of a pair, the resulting 138 | sequence will terminate. 139 | 140 | (defn fibs [] 141 | (unfold (fn [[a b]] 142 | [a [b (+ a b)]]) 143 | [0 1]))" 144 | [next seed] 145 | (lazy-loop [seed seed] 146 | (when-let [[val seed] (next seed)] 147 | (cons val (lazy-recur seed))))) 148 | 149 | (defn take-shuffled 150 | "Lazily take (at most) n elements at random from coll, without 151 | replacement. For n=1, this is equivalent to rand-nth; for n>=(count 152 | coll) it is equivalent to shuffle. 153 | 154 | Clarification of \"without replacement\": each index in the original 155 | collection is chosen at most once. Thus if the original collection 156 | contains no duplicates, neither will the result of this 157 | function. But if the original collection contains duplicates, this 158 | function may include them in its output: it does not do any 159 | uniqueness checking aside from being careful not to use the same 160 | index twice." 161 | [n coll] 162 | (let [coll (vec coll) 163 | n (min n (count coll))] 164 | (take n 165 | (lazy-loop [coll coll] 166 | (let [idx (rand-int (count coll)) 167 | val (coll idx) 168 | coll (-> coll 169 | (assoc idx (peek coll)) 170 | pop)] 171 | (cons val (lazy-recur coll))))))) 172 | 173 | (defn foldr 174 | "http://www.haskell.org/haskellwiki/Fold" 175 | [f start coll] 176 | (reduce #(f %2 %1) start (reverse coll))) 177 | 178 | (defn unchunk 179 | "Create a one-at-a-time sequence out of a chunked sequence." 180 | [s] 181 | (lazy-seq 182 | (when-let [s (seq s)] 183 | (cons (first s) 184 | (unchunk (rest s)))))) 185 | 186 | (defmacro lazy 187 | "Return a lazy sequence of the passed-in expressions. Each will be evaluated 188 | only if necessary." 189 | [& exprs] 190 | `(map force (list ~@(for [expr exprs] 191 | `(delay ~expr))))) 192 | 193 | (defn glue 194 | "Walk over an input sequence, \"gluing\" together elements to create batches. 195 | Batches may be of any type you like, and are computed as follows: 196 | - Each batch is initialized by combining init (default false) with next-item. 197 | - For each additional item in coll, functions glue? and unglue? are consulted to 198 | decide whether the next item should be included into the current batch. 199 | - If (glue? current-batch next-item) returns truthy, then a prospective 200 | updated-batch is computed, as (combine current-batch next-item). If 201 | (unglue? updated-batch) returns falsey, then updated-batch is accepted and 202 | may be used as the target for further gluing. 203 | - If glue? returned falsey, or unglue? returned truthy, then the current batch 204 | is inserted into the output sequence, and a new batch is started as 205 | (combine init next-item)." 206 | ([combine glue? coll] 207 | (glue combine nil glue? coll)) 208 | ([combine init glue? coll] 209 | (glue combine init glue? (constantly false) coll)) 210 | ([combine init glue? unglue? coll] 211 | (lazy-seq 212 | (when-let [coll (seq coll)] 213 | (lazy-loop [glob (combine init (first coll)), coll (rest coll)] 214 | (if-let [coll (seq coll)] 215 | (let [x (first coll) 216 | more (rest coll) 217 | glued (delay (combine glob x))] 218 | (if (and (glue? glob x) 219 | (not (unglue? @glued))) 220 | (recur @glued more) 221 | (cons glob (lazy-recur (combine init x) more)))) 222 | (list glob))))))) 223 | 224 | (defn partition-between 225 | "Partition an input seq into multiple sequences, as with partition-by. 226 | Walks the collection two at a time, calling (split? [a b]) for each pair. 227 | Any time split? returns truthy, the partition containing a ends, and a new 228 | one containing b begins. Note that the split? predicate should not take two 229 | arguments, but instead a single argument, a pair. 230 | 231 | Like partition-by, a lazy sequence of partitions is returned, but the 232 | partitions themselves are eager. 233 | 234 | For example, to cause each nil to be folded into the next partition: 235 | (partition-between (fn [[a b]] (not (nil? a))) '[1 nil nil 2 nil 3]) 236 | => ([1] [nil nil 2] [nil 3])" 237 | [split? coll] 238 | (glue conj [] 239 | (fn [v x] 240 | (not (split? [(peek v) x]))) 241 | (constantly false) 242 | coll)) 243 | 244 | (defn remove-prefix 245 | "Remove prefix from coll, returning the remaining suffix. Returns nil if prefix does not 246 | match coll." 247 | [prefix coll] 248 | (if (seq prefix) 249 | (and (seq coll) 250 | (= (first prefix) (first coll)) 251 | (recur (rest prefix) (rest coll))) 252 | coll)) 253 | 254 | (defn prefix-of? 255 | "Given prefix is N elements long, are the first N elements of coll equal to prefix?" 256 | [coll prefix] 257 | (boolean (remove-prefix prefix coll))) 258 | 259 | (defn merge-sorted 260 | "Merge N sorted sequences together, as in the merge phase of a merge-sort. 261 | Comparator should be a two-argument predicate like `<`, which returns true if 262 | its first argument belongs before its second element in the merged sequence. 263 | The collections themselves should already be sorted in the order your 264 | comparator would put them; otherwise ordering is undefined." 265 | ([comparator] 266 | nil) 267 | ([comparator xs] 268 | xs) 269 | ([comparator xs ys] 270 | (lazy-loop [xs xs, ys ys] 271 | (if-let [xs (seq xs)] 272 | (if-let [ys (seq ys)] 273 | (let [x (first xs), y (first ys)] 274 | (if (comparator x y) 275 | (cons x (lazy-recur (rest xs) ys)) 276 | (cons y (lazy-recur xs (rest ys))))) 277 | xs) 278 | ys))) 279 | ([comparator xs ys & more] 280 | (apply merge-sorted comparator 281 | (merge-sorted comparator xs ys) 282 | more))) 283 | 284 | (defn indexed 285 | "Returns a lazy sequence of pairs of index and item." 286 | [coll] 287 | (map-indexed pair coll)) 288 | 289 | (defn sequeue 290 | "A version of seque from clojure.core that uses a future instead of an agent. 291 | The agent version was causing problems because you can't depend on an agent from 292 | within another agent's action, which means you can't use seque inside an agent. 293 | 294 | This version is probably less performant, because it keeps a thread running 295 | until the sequence is entirely consumed, and it attempts to refill the queue as 296 | soon as there is space, rather than when the queue is emptied. 297 | 298 | More importantly, though, this version may be *DANGEROUS* if you are not careful: 299 | if you do not consume the entire output sequence, the future-thread will remain 300 | active indefinitely, blocking on the queue and holding the lazy sequence open, 301 | ineligible for garbage collection." 302 | ([s] (sequeue 100 s)) 303 | ([n-or-q s] 304 | (let [^BlockingQueue q (if (instance? BlockingQueue n-or-q) 305 | n-or-q 306 | (LinkedBlockingQueue. (int n-or-q))) 307 | NIL (Object.) ;nil sentinel since LBQ doesn't support nils 308 | worker (future 309 | (try 310 | (loop [[x & xs :as s] (seq s)] 311 | (if s 312 | (do (.put q (if (nil? x) NIL x)) 313 | (recur xs)) 314 | (.put q q))) ; q itself is eos sentinel 315 | (catch Exception e 316 | (.put q q) 317 | (throw e))))] 318 | (lazy-loop [] 319 | (let [x (.take q)] 320 | (if (identical? x q) ;q itself is eos sentinel 321 | (do @worker nil) ;just to propagate errors 322 | (cons (if (identical? x NIL) nil x) 323 | (lazy-recur)))))))) 324 | 325 | (defn seque* 326 | "A version of clojure.core/seque that fixes a memory/thread-handle leak." 327 | {:added "1.0" 328 | :static true} 329 | ([s] (seque 100 s)) 330 | ([n-or-q s] 331 | (let [^BlockingQueue q (if (instance? BlockingQueue n-or-q) 332 | n-or-q 333 | (LinkedBlockingQueue. (int n-or-q))) 334 | NIL (Object.) ;nil sentinel since LBQ doesn't support nils 335 | agt (agent (sequence s)) ; never start with nil; that signifies we've already put eos 336 | log-error (fn [q e] 337 | (if (.offer q q) 338 | (throw e) 339 | e)) 340 | fill (fn [s] 341 | (when s 342 | (if (instance? Exception s) ; we failed to .offer an error earlier 343 | (log-error q s) 344 | (try 345 | (loop [[x & xs :as s] (seq s)] 346 | (if s 347 | (if (.offer q (if (nil? x) NIL x)) 348 | (recur xs) 349 | s) 350 | (when-not (.offer q q) ; q itself is eos sentinel 351 | ()))) ; empty seq, not nil, so we know to put eos next time 352 | (catch Exception e 353 | (log-error q e)))))) 354 | drain (fn drain [] 355 | (lazy-seq 356 | (let [x (.take q)] 357 | (if (identical? x q) ;q itself is eos sentinel 358 | (do @agt nil) ;touch agent just to propagate errors 359 | (do 360 | (send-off agt fill) 361 | (cons (if (identical? x NIL) nil x) (drain)))))))] 362 | (send-off agt fill) 363 | (drain)))) 364 | 365 | (defn take-until 366 | "Take from coll up to and including the first item that satisfies pred." 367 | [pred coll] 368 | (lazy-seq 369 | (when-let [coll (seq coll)] 370 | (let [x (first coll)] 371 | (cons x (when-not (pred x) 372 | (take-until pred (rest coll)))))))) 373 | 374 | (defn map-nth 375 | "Calls f on every nth element of coll. If start is passed, starts 376 | at that element (counting from zero), otherwise starts with zero." 377 | ([f nth coll] (map-nth f 0 nth coll)) 378 | ([f start nth coll] 379 | (map #(% %2) 380 | (concat (repeat start identity) 381 | (cycle (cons f (repeat (dec nth) identity)))) 382 | coll))) 383 | 384 | (defn update-first 385 | "Returns a lazy-seq that is a version of coll with the first item matching 386 | pred updated by calling f on it with the supplied args." 387 | ([coll pred f] 388 | (lazy-seq 389 | (if-let [coll (seq coll)] 390 | (let [x (first coll) 391 | xs (rest coll)] 392 | (if (pred x) 393 | (cons (f x) xs) 394 | (cons x (update-first xs pred f)))) 395 | (list (f nil))))) 396 | ([coll pred f & args] 397 | (update-first coll pred #(apply f % args)))) 398 | 399 | (defn single? 400 | "Does coll have only one element?" 401 | [coll] 402 | (and (seq coll) 403 | (not (next coll)))) 404 | 405 | (defn assert-length 406 | "Assert, as a side effect, that coll has exactly len elements, and then 407 | return coll." 408 | [len coll] 409 | (if (zero? len) 410 | (assert (empty? coll) "Too many elements") 411 | (let [last-expected (nthnext coll (dec len))] 412 | (assert last-expected "Too few elements") 413 | (assert (not (next last-expected)) "Too many elements"))) 414 | coll) 415 | 416 | (defn flatten-all 417 | "Takes a nested collection and flattens it into one flat collection. 418 | Like clojure.core/flatten, but also works with maps and collections 419 | containing nested maps." 420 | [form] (remove coll? (tree-seq coll? seq form))) 421 | 422 | (defn groupings 423 | "Similar to clojure.core/group-by, but allowing you to specify how to add items to each group. 424 | For example, if you are grouping by :name, you may want to remove the :name key from each map 425 | before adding it to the list. So, you can specify #(dissoc % :name) as your transform. 426 | 427 | If you need finer-grained control, you can specify a reduce function for accumulating each group, 428 | rather than mapping over the items in it. For example, (groupings even? + 0 coll) finds you the 429 | sum of all odd numbers in coll and the sum of all even numbers in coll." 430 | ([group transform coll] 431 | (groupings group #(conj %1 (transform %2)) [] coll)) 432 | ([group reductor init coll] 433 | (loop [ret {}, coll (seq coll)] 434 | (if-not coll 435 | ret 436 | (let [x (first coll) 437 | category (group x)] 438 | (recur (assoc ret category (reductor (get ret category init) x)) 439 | (next coll))))))) 440 | 441 | (defn increasing* 442 | "Scans through a collection, comparing items via (comp (keyfn x) (keyfn y)), and finding those 443 | which are in increasing order. Each input item x is output once, as part of a pair, [included? 444 | x]. Those items which are part of an increasing sequence will have included? true, while any that 445 | go \"backwards\" from the current max will have included? false." 446 | [keyfn comp coll] 447 | (lazy-seq 448 | (when-first [x coll] 449 | (let [max (keyfn x)] 450 | (cons [true x] 451 | (lazy-loop [max max, coll (rest coll)] 452 | (when-first [x coll] 453 | (let [key (keyfn x)] 454 | (if (neg? (comp key max)) 455 | (cons [false x] (lazy-recur max (rest coll))) 456 | (cons [true x] (lazy-recur key (rest coll)))))))))))) 457 | 458 | (defn increasing 459 | "Throw away any elements from coll which are not in increasing order, according to keyfn and 460 | comp (used similarly to the arguments to sort-by)." 461 | ([coll] 462 | (increasing identity compare coll)) 463 | ([keyfn coll] 464 | (increasing keyfn compare coll)) 465 | ([keyfn comp coll] 466 | (map second (filter first (increasing* keyfn comp coll))))) 467 | -------------------------------------------------------------------------------- /src/flatland/useful/state.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.state 2 | (:require [flatland.useful.time :as time]) 3 | (:use [flatland.useful.utils :only [returning]]) 4 | (:import [clojure.lang IDeref IObj] 5 | [java.util.concurrent ScheduledThreadPoolExecutor ThreadFactory])) 6 | 7 | (defprotocol Mutable 8 | (put! [self v])) 9 | 10 | (deftype Volatile [^{:volatile-mutable true} val validator meta] 11 | IDeref 12 | (deref [self] val) 13 | Mutable 14 | (put! [self v] 15 | (if (and validator (not (validator v))) 16 | (throw (IllegalStateException. "Invalid reference state")) 17 | (set! val v))) 18 | IObj 19 | (meta [self] 20 | meta) 21 | (withMeta [self meta] 22 | (Volatile. val validator meta))) 23 | 24 | (defn volatile 25 | "Creates and returns a Volatile with an initial value of x and zero or 26 | more options (in any order): 27 | 28 | :meta metadata-map 29 | 30 | :validator validate-fn 31 | 32 | If metadata-map is supplied, it will become the metadata on the 33 | Volatile. validate-fn must be nil or a side-effect-free fn of one 34 | argument, which will be passed the intended new state on any state 35 | change. If the new state is unacceptable, the validate-fn should 36 | return false or throw an exception." 37 | ([x] 38 | (Volatile. x nil {})) 39 | ([x & options] 40 | (let [opts (apply hash-map options)] 41 | (Volatile. x (:validator opts) (:meta opts))))) 42 | 43 | (defn trade! 44 | "Like swap!, except it returns the old value of the atom." 45 | [atom f & args] 46 | (let [m (volatile nil)] 47 | (apply swap! atom 48 | (fn [val & args] 49 | (put! m val) 50 | (apply f val args)) 51 | args) 52 | @m)) 53 | 54 | (defn wait-until [reference pred] 55 | (let [curr @reference] ;; try to get out fast - not needed for correctness, just performance 56 | (if (pred curr) 57 | curr 58 | (let [result (promise)] 59 | (add-watch reference result 60 | (fn this [_ _ old new] 61 | (when (pred new) 62 | (try ;; multiple delivers throw an exception in clojure 1.2 63 | (when (deliver result new) 64 | (remove-watch reference result)) 65 | (catch Exception e 66 | nil))))) 67 | (let [curr @reference] ; needed for correctness, in case it's become acceptable since adding 68 | ; watcher and will never change again 69 | (if (pred curr) 70 | (do (remove-watch reference result) 71 | curr) 72 | @result)))))) 73 | 74 | (let [executor (ScheduledThreadPoolExecutor. 1 (reify ThreadFactory 75 | (newThread [this r] 76 | (doto (Thread. r) 77 | (.setDaemon true)))))] 78 | (defn periodic-recompute 79 | "Takes a thunk and a duration (from flatland.useful.time), and yields a function 80 | that attempts to pre-cache calls to that thunk. The first time you call 81 | the returned function, it starts a background thread that re-computes the 82 | thunk's result according to the requested duration. 83 | 84 | If you call the returned function with no arguments, it blocks until 85 | some cached value is available; with one not-found argument, it returns 86 | the not-found value if no cached value has yet been computed. 87 | 88 | Take care: if the duration you specify causes your task to be scheduled 89 | again while it is still running, the task will wait in a queue. That queue 90 | will continue to grow unless your task is able to complete more quickly 91 | than the duration you specified." 92 | [f duration] 93 | (let [{:keys [unit num]} duration 94 | cache (agent {:ready false}) 95 | task (delay (.scheduleAtFixedRate executor 96 | (fn [] 97 | (send cache 98 | (fn [_] 99 | {:ready true 100 | :value (f)}))) 101 | 0, num unit)) 102 | get-ready (fn [] (do @task nil))] 103 | (fn 104 | ([] 105 | (do (get-ready) 106 | (:value (wait-until cache :ready)))) 107 | ([not-found] 108 | (do (get-ready) 109 | (let [{:keys [ready value]} @cache] 110 | (if ready 111 | value 112 | not-found)))))))) 113 | 114 | (defmacro with-altered-vars 115 | "Binds each var-name to the result of (apply f current-value args) for the dynamic 116 | scope of body. Basically like swap! or alter, but for vars. bindings should be a 117 | vector, each element of which should look like a function call: 118 | 119 | (with-altered-vars [(+ x 10)] body) ;; binds x to (+ x 10)" 120 | [bindings & body] 121 | `(binding [~@(for [[f var-name & args] bindings 122 | binding `[~var-name (~f ~var-name ~@args)]] 123 | binding)] 124 | ~@body)) 125 | 126 | (defmacro with-altered-roots 127 | "Use alter-var-root to temporarily modify the root bindings of some vars. 128 | For each var, the temporary value will be (apply f current-value args). 129 | 130 | bindings should be a vector, each element of which should look like a function call: 131 | (with-altered-roots [(+ x 10)] body) ;; sets x to (+ x 10) 132 | 133 | Use with caution: this is not thread-safe, and multiple concurrent calls 134 | can leave vars' root values in an unpredictable state." 135 | [bindings & body] 136 | (let [inits (gensym 'init-vals)] 137 | `(let [~inits (atom {})] 138 | ~@(for [[f var-name & args] bindings] 139 | (let [v (gensym var-name)] 140 | `(alter-var-root (var ~var-name) 141 | (fn [~v] 142 | (swap! ~inits assoc '~var-name ~v) 143 | (~f ~v ~@args))))) 144 | (returning (do ~@body) 145 | ~@(for [[f var-name & args] (reverse bindings)] 146 | `(alter-var-root (var ~var-name) (constantly ('~var-name @~inits)))))))) 147 | -------------------------------------------------------------------------------- /src/flatland/useful/string.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.string 2 | (:require [clojure.string :as s])) 3 | 4 | (defn camelize [string] 5 | (s/replace string 6 | #"[-_](\w)" 7 | (comp s/upper-case second))) 8 | 9 | (defn classify [string] 10 | (apply str (map s/capitalize 11 | (s/split string #"[-_]")))) 12 | 13 | (letfn [(from-camel-fn [separator] 14 | (fn [string] 15 | (-> string 16 | (s/replace #"^[A-Z]+" s/lower-case) 17 | (s/replace #"_?([A-Z]+)" 18 | (comp (partial str separator) 19 | s/lower-case second)) 20 | (s/replace #"-|_" separator))))] 21 | 22 | (def dasherize (from-camel-fn "-")) 23 | (def underscore (from-camel-fn "_"))) 24 | 25 | (defn pluralize 26 | "Return a pluralized phrase, appending an s to the singular form if no plural is provided. 27 | For example: 28 | (pluralize 5 \"month\") => \"5 months\" 29 | (pluralize 1 \"month\") => \"1 month\" 30 | (pluralize 1 \"radius\" \"radii\") => \"1 radius\" 31 | (pluralize 9 \"radius\" \"radii\") => \"9 radii\"" 32 | [num singular & [plural]] 33 | (str num " " (if (= 1 num) singular (or plural (str singular "s"))))) 34 | 35 | (defn substring-after 36 | "Find the part of the string s which comes after the last instance of delim." 37 | [^String delim] 38 | (fn [^String s] 39 | (let [idx (.lastIndexOf s delim)] 40 | (if (neg? idx) 41 | s ;; no match 42 | (subs s (+ (.length delim) idx)))))) 43 | 44 | (defn substring-before 45 | "Find the part of the string s which comes before the first instance of delim." 46 | [^String delim] 47 | (fn [^String s] 48 | (let [idx (.indexOf s delim)] 49 | (if (= -1 idx) 50 | s 51 | (subs s 0 idx))))) 52 | -------------------------------------------------------------------------------- /src/flatland/useful/test.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.test 2 | (:use [clojure.tools.macro :only [macrolet]])) 3 | 4 | (defmacro with-test-tags [tags & body] 5 | (let [tags (set (map keyword tags)) 6 | deftest-decl 7 | (list 'deftest '[name & body] 8 | (list 'let ['n `(vary-meta ~'name update-in [:tags] 9 | (fnil into #{}) ~tags) 10 | 'form `(list* '~'clojure.test/deftest ~'n ~'body)] 11 | 'form)) 12 | with-test-tags-decl 13 | (list 'with-test-tags '[tags & body] 14 | `(list* 'with-test-tags 15 | (into ~tags (map keyword ~'tags)) ~'body))] 16 | `(macrolet [~deftest-decl 17 | ~with-test-tags-decl] 18 | ~@body))) 19 | -------------------------------------------------------------------------------- /src/flatland/useful/time.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.time 2 | (:import [java.util.concurrent TimeUnit])) 3 | 4 | (def ^{:doc "Convert a Clojure keyword into a java.util.concurrent.TimeUnit" 5 | :attribution "I stole this from my Clojail implementation"} 6 | unit 7 | (into {} (for [[enum aliases] {TimeUnit/NANOSECONDS [:ns :nanoseconds] 8 | TimeUnit/MICROSECONDS [:us :microseconds] 9 | TimeUnit/MILLISECONDS [:ms :milliseconds] 10 | TimeUnit/SECONDS [:s :sec :seconds] 11 | TimeUnit/MINUTES [:m :min :minutes] 12 | TimeUnit/HOURS [:h :hr :hours] 13 | TimeUnit/DAYS [:d :day :days]} 14 | alias aliases] 15 | {alias enum}))) 16 | 17 | (defn duration [num unit-keyword] 18 | {:num num, :unit (unit unit-keyword)}) 19 | -------------------------------------------------------------------------------- /src/flatland/useful/utils.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.utils 2 | (:use [clojure.walk :only [walk]] 3 | [flatland.useful.fn :only [decorate ignoring-nils fix]] 4 | [clojure.tools.macro :only [symbol-macrolet]]) 5 | (:import (clojure.lang IDeref ISeq IPersistentMap IPersistentSet IPersistentCollection))) 6 | 7 | (defn invoke 8 | "Like clojure.core/apply, but doesn't expand/splice the last argument." 9 | ([f] (f)) 10 | ([f x] (f x)) 11 | ([f x & more] (apply f x more))) 12 | 13 | (defn fail 14 | "Raise an exception. Takes an exception or a string with format args." 15 | ([exception] 16 | (throw (fix exception string? #(Exception. ^String %)))) 17 | ([string & args] 18 | (fail (apply format string args)))) 19 | 20 | (defmacro verify 21 | "Raise exception unless test returns true." 22 | [test & args] 23 | `(when-not ~test 24 | (fail ~@args))) 25 | 26 | (defmacro returning 27 | "Compute a return value, then execute other forms for side effects. 28 | Like prog1 in common lisp, or a (do) that returns the first form." 29 | [value & forms] 30 | `(let [value# ~value] 31 | ~@forms 32 | value#)) 33 | 34 | (letfn [(no-arg-nil [f] 35 | (fn 36 | ([] nil) 37 | ([& args] (apply f args))))] 38 | 39 | (def ^{:doc "The minimium value of vals, ignoring nils." 40 | :arglists '([& args])} 41 | or-min (ignoring-nils (no-arg-nil min))) 42 | 43 | (def ^{:doc "The maximium value of vals, ignoring nils." 44 | :arglists '([& args])} 45 | or-max (ignoring-nils (no-arg-nil max)))) 46 | 47 | (defn split-vec 48 | "Split the given vector at the provided offsets using subvec. Supports negative offsets." 49 | [v & ns] 50 | (let [ns (map #(if (neg? %) (+ % (count v)) %) ns)] 51 | (lazy-seq 52 | (if-let [n (first ns)] 53 | (cons (subvec v 0 n) 54 | (apply split-vec 55 | (subvec v n) 56 | (map #(- % n) (rest ns)))) 57 | (list v))))) 58 | 59 | (defmacro if-ns 60 | "Try to load a namespace reference. If successful, evaluate then-form otherwise evaluate else-form." 61 | [ns-reference then-form & [else-form]] 62 | `(try (ns ~(ns-name *ns*) ~ns-reference) 63 | (eval '~then-form) 64 | (catch Exception e# 65 | (when-not (some #(instance? % e#) [java.io.FileNotFoundException 66 | java.lang.ClassNotFoundException]) 67 | (printf "%s: %s %s" (.getName (class e#)) (.getMessage e#) '~ns-reference)) 68 | (eval '~else-form)))) 69 | 70 | (defn into-set 71 | "Update the given set using an existence map." 72 | [set map] 73 | (if (map? map) 74 | (reduce (fn [set [k v]] ((if v conj disj) set k)) 75 | set map) 76 | (into set map))) 77 | 78 | (defprotocol Adjoin 79 | (adjoin-onto [left right] 80 | "Merge two data structures by combining the contents. For maps, merge recursively by 81 | adjoining values with the same key. For collections, combine the right and left using 82 | into or conj. If the left value is a set and the right value is a map, the right value 83 | is assumed to be an existence map where the value determines whether the key is in the 84 | merged set. This makes sets unique from other collections because items can be deleted 85 | from them.")) 86 | 87 | (extend-protocol Adjoin 88 | IPersistentMap 89 | (adjoin-onto [this other] 90 | (merge-with adjoin-onto this other)) 91 | 92 | IPersistentSet 93 | (adjoin-onto [this other] 94 | (into-set this other)) 95 | 96 | ISeq 97 | (adjoin-onto [this other] 98 | (concat this other)) 99 | 100 | IPersistentCollection 101 | (adjoin-onto [this other] 102 | (into this other)) 103 | 104 | Object 105 | (adjoin-onto [this other] 106 | other) 107 | 108 | nil 109 | (adjoin-onto [this other] 110 | other)) 111 | 112 | (defn adjoin 113 | "Merge two data structures by combining the contents. For maps, merge recursively by 114 | adjoining values with the same key. For collections, combine the right and left using 115 | into or conj. If the left value is a set and the right value is a map, the right value 116 | is assumed to be an existence map where the value determines whether the key is in the 117 | merged set. This makes sets unique from other collections because items can be deleted 118 | from them." 119 | [a b] 120 | (adjoin-onto a b)) 121 | 122 | (defn pop-if 123 | "Pop item off the given stack if (pred? item) returns true, returning both the item and the 124 | modified stack. If (pred? item) is false, return nil or the optional default value." 125 | [stack pred? & [default]] 126 | (let [[peek pop] (if (instance? clojure.lang.IPersistentStack stack) 127 | [peek pop] 128 | [first rest]) 129 | item (peek stack)] 130 | (if (pred? item) 131 | [(pop stack) item] 132 | [stack default]))) 133 | 134 | (defn update-peek 135 | "Update the element in stack that would be returned by peek, returning a new stack." 136 | [stack f & args] 137 | (conj (pop stack) 138 | (apply f (peek stack) args))) 139 | 140 | (defmacro with-adjustments 141 | "Create new bindings for binding args, by applying adjustment 142 | function to current values of bindings." 143 | [adjustment bindings & body] 144 | (let [bindings (vec bindings)] 145 | `(let [~bindings (map ~adjustment ~bindings)] 146 | ~@body))) 147 | 148 | (defn queue 149 | "Create an empty persistent queue or a persistent queue from a sequence." 150 | ([] clojure.lang.PersistentQueue/EMPTY) 151 | ([seq] (into (queue) seq))) 152 | 153 | (defmacro defm 154 | "Define a function with memoization. Takes the same arguments as defn." 155 | [& defn-args] 156 | `(doto (defn ~@defn-args) 157 | (alter-var-root #(with-meta (memoize %) (meta %))))) 158 | 159 | (defn memoize-deref 160 | "Returns a memoized version a non-referentially transparent function, calling deref on each 161 | provided var (or ref or atom) and using that in the cache key to prevent cross-contamination if 162 | any of the values change." 163 | [vars f] 164 | (let [mem (memoize 165 | (fn [args vals] 166 | (apply f args)))] 167 | (fn [& args] 168 | (mem args (doall (map deref vars)))))) 169 | 170 | (defn syntax-quote ;; from leiningen.core/unquote-project 171 | "Syntax quote the given form, wrapping all seqs and symbols in quote." 172 | [form] 173 | (walk (fn [form] 174 | (cond (and (seq? form) (= `unquote (first form))) (second form) 175 | (or (seq? form) (symbol? form)) (list 'quote form) 176 | :else (syntax-quote form))) 177 | identity 178 | form)) 179 | 180 | (defmacro map-entry 181 | "Create a clojure.lang.MapEntry from a and b. Equivalent to a cons cell. 182 | flatland.useful.experimental.unicode contains a shortcut to this, named ·." 183 | [a b] 184 | `(clojure.lang.MapEntry. ~a ~b)) 185 | 186 | (defn pair 187 | "Create a clojure.lang.MapEntry from a and b. Equivalent to a cons cell" 188 | [a b] 189 | (map-entry a b)) 190 | 191 | (defn ^{:dont-test "Used in impl of thread-local"} 192 | thread-local* 193 | "Non-macro version of thread-local - see documentation for same." 194 | [init] 195 | (let [generator (proxy [ThreadLocal] [] 196 | (initialValue [] (init)))] 197 | (reify IDeref 198 | (deref [this] 199 | (.get generator))))) 200 | 201 | (defmacro thread-local 202 | "Takes a body of expressions, and returns a java.lang.ThreadLocal object. 203 | (see http://download.oracle.com/javase/6/docs/api/java/lang/ThreadLocal.html). 204 | 205 | To get the current value of the thread-local binding, you must deref (@) the 206 | thread-local object. The body of expressions will be executed once per thread 207 | and future derefs will be cached. 208 | 209 | Note that while nothing is preventing you from passing these objects around 210 | to other threads (once you deref the thread-local, the resulting object knows 211 | nothing about threads), you will of course lose some of the benefit of having 212 | thread-local objects." 213 | [& body] 214 | `(thread-local* (fn [] ~@body))) 215 | 216 | (defn read-seq 217 | "Read all forms from *in* until an EOF is reached. Throws an exception on incomplete forms." 218 | [] 219 | (lazy-seq 220 | (let [form (read *in* false ::EOF)] 221 | (when-not (= ::EOF form) 222 | (cons form (read-seq)))))) 223 | 224 | (defmacro let-later 225 | "Behaves like let, but bindings which have :delay metadata on them are 226 | evaluated lazily, by placing their values in a delay and forcing the 227 | delay whenever the body of the let-later needs the value. For example, 228 | 229 | (let-later [^:delay a (do-stuff)] 230 | (when (whatever) a)) 231 | 232 | will only evaluate (do-stuff) if (whatever) is true." 233 | [bindings & body] 234 | (letfn [(let-delayed [body name val] 235 | (let [delay-sym (gensym (str "delay-" name))] 236 | `(let [~delay-sym (delay ~val)] 237 | (symbol-macrolet [~name (force ~delay-sym)] 238 | ~body)))) 239 | (destructure-delayed [body name val] 240 | `(let-later [~@(apply concat 241 | (for [[k v] (partition 2 (destructure [name val]))] 242 | [(vary-meta k assoc :delay true) 243 | v]))] 244 | ~body))] 245 | (reduce (fn [body [name val]] 246 | (if (:delay (meta name)) 247 | (if (symbol? name) 248 | (let-delayed body name val) 249 | (destructure-delayed body name val)) 250 | `(let [~name ~val] 251 | ~body))) 252 | `(do ~@body) 253 | (reverse (partition 2 bindings))))) 254 | 255 | (defn copy-meta 256 | "Copy all the metadata from src to dest." 257 | [dest src] 258 | (with-meta dest (meta src))) 259 | 260 | (defn empty-coll? 261 | "Is x a collection and also empty?" 262 | [x] 263 | (or (nil? x) 264 | (and (coll? x) 265 | (empty? x)))) 266 | 267 | (defmacro switch 268 | "Like case, but uses object equality instead of the compile-time hash. Also, switch does not 269 | require a default clause. Of course, switch is not as efficient as case, but it works for things 270 | like functions, which case cannot support." 271 | [expr & clauses] 272 | (let [[clauses default] (if (even? (count clauses)) 273 | [clauses nil] 274 | [(butlast clauses) (last clauses)])] 275 | `(condp contains? ~expr 276 | ~@(mapcat (fn [[val form]] 277 | [(fix val, list? set, hash-set) form]) 278 | (partition 2 clauses)) 279 | ~default))) 280 | 281 | (defmacro with-timing 282 | "Same as clojure.core/time but returns a vector of the result of 283 | the code and the milliseconds rather than printing a string. Runs 284 | the code in an implicit do." 285 | [& body] 286 | `(let [start# (System/nanoTime) 287 | ret# ~(cons 'do body)] 288 | [ret# (/ (double (- (System/nanoTime) start#)) 1000000.0)])) 289 | -------------------------------------------------------------------------------- /test/config1.clj: -------------------------------------------------------------------------------- 1 | {size 1} 2 | -------------------------------------------------------------------------------- /test/config2.clj: -------------------------------------------------------------------------------- 1 | (let [point [1 1]] 2 | {:x point, :y point}) 3 | -------------------------------------------------------------------------------- /test/flatland/useful/bean_test.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.bean-test 2 | (:use clojure.test flatland.useful.bean) 3 | (:import (java.beans PropertyDescriptor))) 4 | 5 | (defmethod coerce [Boolean/TYPE nil] [_ _ val] false) 6 | (defmethod coerce [Boolean/TYPE Object] [_ _ val] (boolean val)) 7 | 8 | (deftest beans 9 | (let [b (PropertyDescriptor. "bound" PropertyDescriptor)] 10 | (is (= false (.isBound b))) 11 | (is (= false (.isConstrained b))) 12 | (update-bean b {:bound true :constrained true}) 13 | (is (= true (.isBound b))) 14 | (is (= true (.isConstrained b))) 15 | (testing "coercion" 16 | (update-bean b {:bound nil :constrained nil}) 17 | (is (= false (.isBound b))) 18 | (is (= false (.isConstrained b)))))) -------------------------------------------------------------------------------- /test/flatland/useful/cli_test.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.cli-test 2 | (:use clojure.test flatland.useful.cli)) 3 | 4 | (deftest test-parse-opts 5 | (is (= {:foo ["a"] :bar [""]} (parse-opts ["--foo=a" "--bar"])))) 6 | -------------------------------------------------------------------------------- /test/flatland/useful/compress_test.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.compress-test 2 | (:use clojure.test flatland.useful.compress)) 3 | 4 | 5 | (deftest round-trip 6 | (let [s "f3509ruwqerfwoa reo1u30`1 ewf dfgjdsf sfc saf65sad+ f5df3 7 | g2 sd35g4szdf sdf4 as89faw76fwfwf210 8 | "] 9 | (is (= s (unsmash (smash s)))))) 10 | -------------------------------------------------------------------------------- /test/flatland/useful/config_test.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.config-test 2 | (:use clojure.test flatland.useful.config)) 3 | 4 | (deftest reading 5 | (is (= '{size 1} (read-config "config1.clj"))) 6 | 7 | (is (thrown-with-msg? java.io.FileNotFoundException #"Cannot find config resource config3.clj" 8 | (read-config "config3.clj"))) 9 | 10 | (is (= nil (read-config "config3.clj" :optional true)))) 11 | 12 | (deftest loading 13 | (is (= {:x [1 1] 14 | :y [1 1]} 15 | (load-config "config2.clj"))) 16 | 17 | (is (thrown-with-msg? java.io.FileNotFoundException #"Cannot find config resource config3.clj" 18 | (load-config "config3.clj"))) 19 | 20 | (is (= nil (load-config "config3.clj" :optional true)))) 21 | -------------------------------------------------------------------------------- /test/flatland/useful/datatypes_test.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.datatypes-test 2 | (:use clojure.test flatland.useful.datatypes)) 3 | 4 | (deftest test-as-int 5 | (are [in out] (= (as-int in) out) 6 | "1" 1 7 | 2 2 8 | 4.5 4 9 | nil nil)) 10 | 11 | (defrecord Test [a b c]) 12 | (defrecord Other [dash-thing question? bang!]) 13 | (record-accessors Test Other) 14 | 15 | (deftest test-munged-names 16 | (let [x (Other. 1 2 3)] 17 | (testing "Accessor functions" 18 | (is (= 1 (dash-thing x))) 19 | (is (= 2 (question? x))) 20 | (is (= 3 (bang! x)))) 21 | 22 | (testing "assoc-record" 23 | (is (= x (assoc-record x :dash-thing 1))) 24 | (is (= x (assoc-record x :question? 2))) 25 | (is (= x (assoc-record x :bang! 3)))) 26 | 27 | (testing "update-record" 28 | (is (= x (update-record x 29 | (identity dash-thing) 30 | (identity question?) 31 | (identity bang!))))))) 32 | 33 | (defprotocol Inline 34 | (foo [this])) 35 | (defprotocol Dynamic 36 | (bar [this])) 37 | 38 | (defrecord Implementor [x] 39 | Inline 40 | (foo [this] (bar this))) 41 | 42 | (extend-type Implementor 43 | Dynamic 44 | (bar [this] "y")) 45 | 46 | (deftest test-record 47 | (let [init (Test. 1 2 3) 48 | second (Test. 1 5 4)] 49 | (is (= init (make-record Test :b 2 :a 1 :c 3))) 50 | (is (= second (assoc-record init :b 5 :c 4))) 51 | (is (= second (update-record init (+ b 3) (inc c)))) 52 | (is (= (:a init) (a init))) 53 | (testing "Preserves metadata" 54 | (let [m {:test 1} 55 | r (Test. 1 2 3 m {})] 56 | (is (= m (meta (assoc-record r :b 10)))))) 57 | (testing "Inline typehinting" 58 | (is (= second (assoc-record ^Test (assoc init :b 5) :c 4)))) 59 | 60 | (testing "Don't eval more than once" 61 | (let [times-evaled (atom 0) 62 | r (Test. 1 2 3)] 63 | (assoc-record ^Test (do (swap! times-evaled inc) r) :a :x :b :y :c :z) 64 | (is (= 1 @times-evaled)))) 65 | 66 | (testing "Works calling implemented protocols" 67 | (let [r (Implementor. 1)] 68 | (assoc-record r :x 5))))) 69 | -------------------------------------------------------------------------------- /test/flatland/useful/debug_test.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.debug-test 2 | (use flatland.useful.debug clojure.test)) 3 | 4 | (defmacro test-? [form] 5 | `(let [form# '~form 6 | expected# ~form 7 | collector# (java.io.StringWriter.)] 8 | (binding [*out* collector#] 9 | (is (= expected# (? ~form))) 10 | (let [written# (str collector#)] 11 | (are [val#] (.contains written# (pr-str val#)) 12 | form# expected#))))) 13 | 14 | (deftest ?-test ;; macro to avoid repeating expr with various levels of quoting 15 | (test-? (str "test" "more"))) 16 | -------------------------------------------------------------------------------- /test/flatland/useful/deftype_test.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.deftype-test 2 | (:use clojure.test flatland.useful.deftype)) 3 | 4 | (defn is-valid-map [inst] 5 | (let [m (into (empty inst) 6 | [[1 :a] [:foo [1 2 3]] ["bar" 42] [:none nil]])] 7 | (testing "find" 8 | (is (= [1 :a] (find m 1))) 9 | (is (= [:foo [1 2 3]] (find m :foo))) 10 | (is (= ["bar" 42] (find m "bar"))) 11 | (is (= [:none nil] (find m :none))) 12 | (is (= nil (find m 3)))) 13 | (testing "get" 14 | (is (= :a (get m 1))) 15 | (is (= [1 2 3] (get m :foo))) 16 | (is (= 42 (get m "bar"))) 17 | (is (= nil (get m 3))) 18 | (is (= :nope (get m 3 :nope))) 19 | (is (= :a (get m 1 :yep))) 20 | (is (= nil (get m :none 42)))) 21 | (testing "keys" 22 | (is (= #{1 :foo "bar" :none} (set (keys m))))) 23 | (testing "vals" 24 | (is (= #{:a [1 2 3] 42 nil} (set (vals m))))) 25 | (testing "assoc" 26 | (let [m2 (assoc m 1 :one :b 4 :c 8)] 27 | (is (= :one (get m2 1))) 28 | (is (= 4 (get m2 :b))) 29 | (is (= 8 (get m2 :c))) 30 | (is (= #{1 :foo "bar" :none :b :c} (set (keys m2)))) 31 | (let [m3 (assoc m2 1 nil :b 5)] 32 | (is (= nil (get m3 1))) 33 | (is (= 5 (get m3 :b))) 34 | (is (= #{1 :foo "bar" :none :b :c} (set (keys m3))))))) 35 | (testing "dissoc" 36 | (let [m2 (dissoc m 1 :foo :bar)] 37 | (is (= nil (find m2 1))) 38 | (is (= nil (find m2 :foo))) 39 | (is (= ["bar" 42] (find m2 "bar"))) 40 | (is (= #{"bar" :none} (set (keys m2)))) 41 | (is (= #{42 nil} (set (vals m2)))))))) 42 | 43 | (deftest test-alist 44 | (is-valid-map (alist))) 45 | -------------------------------------------------------------------------------- /test/flatland/useful/dispatch_test.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.dispatch-test 2 | (:use clojure.test flatland.useful.dispatch 3 | [clojure.walk :only [stringify-keys]]) 4 | 5 | ;; not used directly, but added to verify that imported functions aren't exposed via dispatcher 6 | (:require [clojure.set :refer [rename-keys]])) 7 | 8 | (deftest test-dispatcher-fn 9 | (let [dispatch (dispatcher (fn [f & args] (symbol "clojure.core" f)))] 10 | (is (= "str5" (dispatch "str" 5))))) 11 | 12 | (deftest test-imported-functions 13 | (let [fn-name 'flatland.useful.dispatch-test/rename-keys 14 | dispatch (dispatcher (constantly fn-name))] 15 | (is (thrown? Exception (dispatch {:a 1} {:a :b}))))) 16 | 17 | (deftest test-dispatch 18 | (testing "simple dispatch" 19 | (defdispatch invert #(cond (map? %) 20 | (symbol "clojure.set" "map-invert") 21 | 22 | (vector? %) 23 | (symbol "clojure.core" "reverse"))) 24 | (is (= {2 :b, 1 :a} (invert {:a 1 :b 2}))) 25 | (is (= [:bar :foo] (invert [:foo :bar])))) 26 | 27 | (testing "flat hierarchy" 28 | (defdispatch invert #(cond (map? %) 29 | (symbol "clojure.core" "map-invert") 30 | 31 | (vector? %) 32 | (symbol "clojure.core" "reverse")) 33 | :hierarchy '{clojure.core clojure.set}) 34 | (is (= {2 :b, 1 :a} (invert {:a 1 :b 2}))) 35 | (is (= [:bar :foo] (invert [:foo :bar])))) 36 | 37 | (testing "deep hierarchy" 38 | (defdispatch invert #(cond (map? %) 39 | (symbol "clojure.core" "map-invert") 40 | 41 | (vector? %) 42 | (symbol "clojure.core" "reverse")) 43 | :hierarchy '{clojure.core clojure.foo 44 | clojure.foo clojure.bar 45 | clojure.bar clojure.set}) 46 | (is (= {2 :b, 1 :a} (invert {:a 1 :b 2}))) 47 | (is (= [:bar :foo] (invert [:foo :bar])))) 48 | 49 | (testing "dispatch to ns does not exist" 50 | (defdispatch invert #(cond (map? %) 51 | (symbol "clojure.foo" "map-invert") 52 | 53 | (vector? %) 54 | (symbol "clojure.core" "reverse"))) 55 | (is (thrown? java.lang.IllegalArgumentException 56 | (invert {:a 1 :b 2})))) 57 | 58 | (testing "dispatch to fn does not exist" 59 | (defdispatch invert #(cond (map? %) 60 | (symbol "clojure.set" "foo") 61 | 62 | (vector? %) 63 | (symbol "clojure.core" "reverse"))) 64 | (is (thrown? java.lang.IllegalArgumentException 65 | (invert {:a 1 :b 2})))) 66 | 67 | (testing "middleware" 68 | (defdispatch invert #(cond (map? %) 69 | (symbol "clojure.set" "map-invert") 70 | 71 | (vector? %) 72 | (symbol "clojure.core" "reverse")) 73 | :wrap #(fn [arg] 74 | (if (map? arg) 75 | (% (stringify-keys arg)) 76 | (% arg)))) 77 | (is (= {2 "b" 1 "a"} (invert {:a 1 :b 2}))) 78 | (is (= [:bar :foo] (invert [:foo :bar])))) 79 | 80 | (testing "self as sub-type" 81 | (defdispatch invert #(cond (map? %) 82 | (symbol "clojure.core" "map-invert") 83 | 84 | (vector? %) 85 | (symbol "clojure.core" "reverse")) 86 | :hierarchy '{clojure.core clojure.foo 87 | clojure.foo clojure.foo}) 88 | (is (thrown? java.lang.Exception 89 | (invert {:a 1 :b 2}))))) -------------------------------------------------------------------------------- /test/flatland/useful/exception_test.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.exception-test 2 | (:use clojure.test flatland.useful.exception)) 3 | 4 | (deftest test-rescue 5 | (is (= nil (rescue (/ 9 0) nil))) 6 | (is (= 3 (rescue (/ 9 3) nil)))) 7 | -------------------------------------------------------------------------------- /test/flatland/useful/experimental_test.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.experimental-test 2 | (:refer-clojure :exclude [update]) 3 | (:use clojure.test flatland.useful.map 4 | flatland.useful.experimental 5 | flatland.useful.experimental.delegate) 6 | (:require [flatland.useful.utils :as utils])) 7 | 8 | (deftest test-while-let 9 | (let [a (atom '(1 2 3 4 5))] 10 | (while-let [val (seq @a)] 11 | (is val) 12 | (swap! a rest)) 13 | (is (empty? @a)))) 14 | 15 | (deftest test-let-if 16 | (doseq [a [1 2]] 17 | (let-if (even? a) 18 | [odd false true 19 | even true false] 20 | (is (= even (even? a))) 21 | (is (= odd (odd? a)))))) 22 | 23 | (deftest test-order-let-if 24 | (order-let-if true 25 | [a 1, b 2] 26 | (is (and (= a 1) (= b 2)))) 27 | (order-let-if false 28 | [a 1, b 2] 29 | (is (and (= a 2) (= b 1))))) 30 | 31 | 32 | ;;; protocols defined for testing protocol-stub 33 | (defprotocol Sample 34 | (sample [this data])) 35 | 36 | (defprotocol Define 37 | (define [this k v]) 38 | (lookup [this k])) 39 | 40 | (defrecord Implementor [] 41 | Sample 42 | (sample [this data] 10) 43 | 44 | Define 45 | (define [this k v] false) 46 | (lookup [this k] :not-found)) 47 | 48 | (protocol-stub StubImpl 49 | {Sample {:default :forward} 50 | Define {:default :stub, 51 | :exceptions [lookup]}}) 52 | 53 | (deftest stub-test 54 | (let [call-log (atom []) 55 | real-impl (Implementor.) 56 | stub-impl (StubImpl. real-impl 57 | (fn 58 | ([f [this & args]] 59 | (reset! call-log (keyed [f args]))) 60 | ([f [this & args] ret] 61 | (reset! call-log (keyed [f args ret])))))] 62 | (testing "default action works without exceptions" 63 | (is (= [] @call-log)) 64 | (is (= 10 (sample real-impl 'whatever))) 65 | (is (= [] @call-log)) 66 | (is (= 10 (sample stub-impl 'whatever))) 67 | (is (= {:f 'sample, :args ['whatever], :ret 10} @call-log))) 68 | 69 | (testing "default action works with a different exception" 70 | (is (false? (define real-impl 1 2))) 71 | (is (nil? (define stub-impl 1 2))) 72 | (is (= {:f 'define :args [1 2]} @call-log))) 73 | 74 | (testing "exceptions are applied" 75 | (is (= :not-found (lookup real-impl 1))) 76 | (is (= :not-found (lookup stub-impl 1))) 77 | (is (= {:f 'lookup :args [1] :ret :not-found} @call-log))))) 78 | 79 | (deftest wrapper-test 80 | (with-local-vars [dummy-wrapper ()] 81 | (testing "Wrapping respects manually-established bindings" 82 | (with-local-vars [wrappers ()] 83 | (defn-wrapping my-inc wrappers "add one" [x] 84 | (+ 1 x)) 85 | (is (= 2 (my-inc 1))) 86 | (let [start-num 1] 87 | (is (= (* 2 (inc (+ 10 start-num))) 88 | (with-bindings {wrappers (list (fn [f] ;; outermost wrapper 89 | (fn [x] 90 | (* 2 (f x)))) 91 | (fn [f] ;; innermost wrapper 92 | (fn [x] 93 | (f (+ 10 x)))))} 94 | (my-inc start-num))))) 95 | (let [call-log (atom nil)] 96 | (is (= 2 (with-bindings {wrappers (list (fn [f] 97 | (fn [x] 98 | (let [ret (f x)] 99 | (reset! call-log [(-> wrappers deref meta :flatland.useful.experimental/call-data :fn-name) x ret]) 100 | ret))))} 101 | (my-inc 1)))) 102 | (testing "Wrapping-related metadata bound correctly" 103 | (is (= ['my-inc 1 2] @call-log)))))) 104 | 105 | (testing "with-wrapper(s) works" 106 | (let [prepend (fn [item] (fn [f] (fn [& args] (apply f item args)))) 107 | append (fn [item] (fn [f] (fn [& args] (apply f (concat args [item])))))] 108 | (with-local-vars [vec-wrapper [] 109 | cons-wrapper ()] 110 | (defn-wrapping vec-str vec-wrapper "Make stuff a string" [& args] 111 | (apply str args)) 112 | (defn-wrapping cons-str cons-wrapper "Make stuff a string" [& args] 113 | (apply str args)) 114 | (with-wrapper vec-wrapper (prepend 'foo) 115 | (is (= "foo123" (vec-str 1 2 3))) 116 | (with-wrapper vec-wrapper (append 'bar) 117 | (is (= "foo123bar" (vec-str 1 2 3))) 118 | (with-wrapper vec-wrapper (prepend 'baz) 119 | (is (= "foobaz123bar" (vec-str 1 2 3)))))) 120 | (with-wrappers cons-wrapper [(prepend 'foo) (append 'bar) (prepend 'baz)] 121 | (is (= "bazfoo123bar" (cons-str 1 2 3))))))) 122 | 123 | (testing "Metadata is applied properly" 124 | (defn-wrapping myfn dummy-wrapper "re-implement clojure.core/first." [[x]] 125 | x) 126 | (let [meta (meta #'myfn)] 127 | (is (= '([[x]]) (:arglists meta))) 128 | (is (= "re-implement clojure.core/first." (:doc meta)))) 129 | 130 | (testing "Docstring is optional" 131 | (defn-wrapping testfn dummy-wrapper [x] 132 | (inc x)) 133 | (is (= 1 (testfn 0))))) 134 | 135 | (let [inc-fn (fn [f] (comp inc f))] 136 | (testing "Wrapper can be added after function is defined" 137 | (defn frizzle [x] (inc x)) 138 | (make-wrappable! #'frizzle dummy-wrapper) 139 | (is (= 3 (with-wrapper dummy-wrapper inc-fn 140 | (frizzle 1))))) 141 | 142 | (testing "wrap-multiple" 143 | (defn frazzle [x] (inc x)) 144 | (defn zazzle [x] (inc x)) 145 | (wrap-multiple dummy-wrapper frazzle zazzle) 146 | (are [f] (= 3 (with-wrapper dummy-wrapper inc-fn 147 | (f 1))) 148 | frazzle zazzle))))) 149 | 150 | (deftest fixes-test 151 | (is (= 4 (fixes {:value 9} 152 | map? :value 153 | string? read-string 154 | odd? dec 155 | even? #(/ % 2)))) 156 | (let [a (atom 0)] 157 | (is (thrown? Exception 158 | (fixes a 159 | identity #(swap! % inc) 160 | identity))) 161 | (is (= 0 @a) "Should throw an exception before trying any clauses"))) 162 | 163 | (deftest lift-meta-test 164 | (let [m (lift-meta {:a 1 :b 2} :a)] 165 | (is (= {:b 2} m)) 166 | (is (= {:a 1} (meta m))))) 167 | 168 | (deftest prefix-lookup-test 169 | (let [lookup (prefix-lookup [["a" :apple] 170 | ["person" :person] 171 | [:p :pineapple] 172 | ["abbrev" :abbreviation]])] 173 | (are [in out] (= out (lookup in)) 174 | "apropos" :apple 175 | "persona" :person 176 | "pursues" :pineapple ;; keywords should work 177 | "abbrev." :apple ;; should test in order, and short-circuit 178 | ))) 179 | 180 | (deftest canonical-name-test 181 | (is (= 'clojure.core/inc (canonical-name 'inc))) 182 | (is (= 'java.lang.Object (canonical-name 'Object))) 183 | (is (= 'flatland.useful.utils/adjoin (canonical-name `utils/adjoin)))) 184 | -------------------------------------------------------------------------------- /test/flatland/useful/fn_test.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.fn-test 2 | (:use clojure.test flatland.useful.fn)) 3 | 4 | (deftest test-validator 5 | (is (= [0 2 4 6 8] 6 | (keep (validator even?) 7 | (range 10))))) 8 | 9 | (deftest test-decorate 10 | (is (= [[1 2] [2 3] [3 4]] (map (decorate inc) [1 2 3])))) 11 | 12 | (deftest test-annotate 13 | (is (= [1 2] (annotate 1 inc)))) 14 | 15 | (deftest test-fix 16 | (let [repair (fn [val] 17 | (-> (* val 2) 18 | int 19 | (fix zero? dec, even? (partial * 3), inc)))] 20 | (is (= 12 (repair 2))) 21 | (is (= 4 (repair 1.5))) 22 | (is (= -1 (repair 0))))) 23 | 24 | (deftest test-to-fix 25 | (is (= [1 -2 3 -4] (map (to-fix (! odd?) -) [1 2 3 4])))) 26 | 27 | (deftest test-as-fn 28 | (is (= 3 ((as-fn 3) :foo))) 29 | (is (= :foo ((as-fn #{:foo}) :foo))) 30 | (is (= 9 ((as-fn inc) 8)))) 31 | 32 | (deftest test-fixing 33 | (let [m (atom {:x 1})] 34 | (is (= {:x 3} 35 | (swap! m update-in [:x] fixing odd? + 2))) 36 | (is (= {:x 1} 37 | (fixing {:x 1} seq? conj 1 2 3 4))))) 38 | 39 | (deftest test-given 40 | (is (= 1 41 | (-> {:value 0} 42 | (given map? (update-in [:value] inc)) ; matches 43 | (given sequential? reverse) ; doesn't match 44 | (given :value :value)))) 45 | (is (= {:value 1} 46 | (-> {:value 0} 47 | (given map? (update-in [:value] inc) ; matches 48 | sequential? reverse ; these next two are never tested 49 | :value :value)))) 50 | (is (= 4 51 | (-> 3 52 | (given map? (update-in [:value] inc) ; matches 53 | sequential? reverse ; these next two are never tested 54 | inc))))) 55 | 56 | (deftest test-any 57 | (is (= [0 2 3 4 6 8 9 10] 58 | (filter (any #(zero? (rem % 2)) 59 | #(zero? (rem % 3))) 60 | (range 11))))) 61 | 62 | (deftest test-all 63 | (is (= [0 6] 64 | (filter (all #(zero? (rem % 2)) 65 | #(zero? (rem % 3))) 66 | (range 11))))) 67 | 68 | (deftest test-knit 69 | (is (= [5 \t 9] 70 | ((knit inc last #(* 3 %)) 71 | [4 "last" 3]))) 72 | (is (= {"A" 10 "B" 1} 73 | (into {} 74 | (map (knit #(.toUpperCase %) inc) 75 | {"a" 9 "b" 0}))))) 76 | 77 | (deftest test-thrush 78 | (is (= 5 (thrush 1 inc inc inc inc)))) 79 | 80 | (deftest test-ignoring-nils 81 | (is (= 6 ((ignoring-nils +) 1 nil 2 nil nil 3)))) 82 | 83 | (deftest test-key-comparator 84 | (let [subtract-comparator-fn-breaks-on-this [2147483650 2147483651 85 | 2147483652 4 2 3 1] 86 | normal-cmp (key-comparator identity)] 87 | (is (= (sort subtract-comparator-fn-breaks-on-this) 88 | (sort normal-cmp subtract-comparator-fn-breaks-on-this)))) 89 | (let [square (fn [x] (* x x)) 90 | by-square (key-comparator :ascending square)] 91 | (is (= (sort-by square [-9 -5 1 -2]) 92 | (sort by-square [-9 -5 1 -2]))))) 93 | -------------------------------------------------------------------------------- /test/flatland/useful/io_test.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.io-test 2 | (:use flatland.useful.io clojure.test) 3 | (:import (java.io StringReader RandomAccessFile))) 4 | 5 | (deftest test-read-seq 6 | (let [forms '(this (is) #(100 %) ~of a [long, [complicated, [nested]]] {:quoted #{form}}) 7 | form-str (with-out-str (doseq [form forms] 8 | (prn form)))] 9 | (is (= forms (read-seq (StringReader. form-str)))))) 10 | 11 | (deftest test-bytes-and-longs 12 | (are [x bs] (and (= x (bytes->long (into-array Byte/TYPE (map byte bs)))) 13 | (= bs (seq (long->bytes x)))) 14 | 10 [0 0 0 0 0 0 0 10] 15 | 255 [0 0 0 0 0 0 0 -1] 16 | 256 [0 0 0 0 0 0 1 0] 17 | 65540 [0 0 0 0 0 1 0 4])) 18 | 19 | (deftest test-mmap-file 20 | (let [{:keys [buffer close]} (mmap-file (RandomAccessFile. "project.clj" "rw")) 21 | a (byte-array (.capacity buffer))] 22 | (is (= (slurp "project.clj") 23 | (do (.get buffer a 0 (alength a)) 24 | (apply str (map char a))))) 25 | (close))) 26 | 27 | (deftest test-compare-bytes 28 | (letfn [(bytes [& xs] 29 | (byte-array (map unchecked-byte xs)))] 30 | (is (neg? (compare-bytes (bytes 1 2 3) 31 | (bytes 3)))) 32 | (is (neg? (compare-bytes (bytes 1 2 3) 33 | (bytes 1 2 3 4)))) 34 | (is (zero? (compare-bytes (bytes 1 2 3) 35 | (bytes 1 2 3)))) 36 | (is (pos? (compare-bytes (bytes 1 2 -3) 37 | (bytes 1 2 3)))) 38 | (is (pos? (compare-bytes (bytes 1 2 -3) 39 | (bytes 1 2 -4)))) 40 | (is (neg? (compare-bytes (bytes 100) 41 | (bytes -100)))) 42 | (is (pos? (compare-bytes (bytes -100) 43 | (bytes 100)))) 44 | (is (pos? (compare-bytes (bytes -1) 45 | (bytes 0)))) 46 | (is (neg? (compare-bytes (bytes 0) 47 | (bytes -128)))))) 48 | -------------------------------------------------------------------------------- /test/flatland/useful/java_test.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.java-test 2 | (:use clojure.test flatland.useful.java) 3 | (:import (java.util Collection Map))) 4 | 5 | (deftest test-construct 6 | (is (= "test" (construct String "test")))) 7 | 8 | (deftest test-invoke-private 9 | (let [hash (doto (java.util.Hashtable.) 10 | (.put 1 2) 11 | (.put 3 4))] 12 | (is (thrown? Throwable (.rehash hash))) 13 | (is (= {1 2 3 4} 14 | (doto hash (invoke-private "rehash")))) 15 | (is (thrown? Throwable (.rehash hash))))) 16 | 17 | (deftest test-hinted-let 18 | (let [item {:foo 10}] 19 | (is (= 1 (multi-hinted-let [x item [Collection Map]] (.size x))) 20 | "Should work when actual class matches.") 21 | (is (thrown? Throwable (multi-hinted-let [x item [Collection]] (.size x)) 22 | "Should fail when no class matches.")) 23 | ;; TODO find a way to assert no reflection happens? 24 | )) 25 | -------------------------------------------------------------------------------- /test/flatland/useful/macro_test.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.macro-test 2 | (:use clojure.test flatland.useful.macro)) 3 | 4 | ;; necessary because deftest does weird shit with namespaces, resolution, and 5 | ;; macroexpansion, so this can't be inside there 6 | (let [strip-extraneous-do (fn [form] 7 | (->> form 8 | (iterate second) 9 | (drop-while (comp #{`do} first)) 10 | first)) 11 | expansion (macroexpand '(anon-macro [name num] 12 | `(inc ~(symbol (str name num))) 13 | test 1))] 14 | 15 | (deftest test-macro-toys 16 | (is (= `(inc ~'test1) 17 | (strip-extraneous-do expansion))) 18 | (is (= "123abc" 19 | (with-out-str 20 | (macro-do [x] `(print '~x) 21 | 123 22 | abc)))))) 23 | -------------------------------------------------------------------------------- /test/flatland/useful/map_test.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.map-test 2 | (:refer-clojure :exclude [update]) 3 | (:use clojure.test flatland.useful.map)) 4 | 5 | (deftest test-assoc-or 6 | (is (= {:a 1 :b 2 :c 3} 7 | (-> {:a 1 :b nil} 8 | (assoc-or :a 2) 9 | (assoc-or :b 2) 10 | (assoc-or :c 3))))) 11 | 12 | (deftest test-keyed 13 | (let [a 1 b 2] 14 | (is (= {:a 1 :b 2} (keyed [a b]))) 15 | (is (= '{a 1 b 2} (keyed :syms [a b]))))) 16 | 17 | (deftest test-into-map 18 | (is (= {:foo "1", :bar "2", :bang "3", :baz "4", :blah 5} 19 | (into-map :foo 1 :bar 2 :bang 3 [:foo "1" :baz "4"] :bar "2" '(:bang "3") {:blah 5}))) 20 | (is (= {:foo {:bap 3, :baz 2, :bar 1}} 21 | (into-map merge-in :foo {:bar 1} {:foo {:baz 2}} [:foo {:bap 3}])))) 22 | 23 | (deftest test-map-vals 24 | (is (= {:foo 1 :bar 9 :baz 4} 25 | (map-vals {:foo 0 :bar 8 :baz 3} inc)))) 26 | 27 | (deftest test-map-keys 28 | (is (= {"foo" 1 "bar" 2 "baz" 3} 29 | (map-keys {:foo 1 :bar 2 :baz 3} name)))) 30 | 31 | (deftest test-map-vals-with-keys 32 | (is (= {1 3, 7 8, 9 14} 33 | (map-vals-with-keys {1 2, 7 1, 9 5} +)))) 34 | 35 | (deftest test-map-keys-and-vals 36 | (is (= {"a" "b" "c" "d"} 37 | (map-keys-and-vals {:a :b :c :d} name)))) 38 | 39 | (deftest test-update 40 | (is (= {:a 3 :b 3 :c nil} 41 | (-> {:a 2 :b 4 :c ()} 42 | (update :a inc) 43 | (update :b dec) 44 | (update :c seq))))) 45 | 46 | (deftest test-update-each 47 | (is (= {:a 6 :b 8} 48 | (-> {:a 3 :b 4} 49 | (update-each [:a :b] * 2)))) 50 | 51 | (let [m {:a 1 :b 2}] 52 | (is (identical? m (update-each m [:a :b] identity))))) 53 | 54 | (deftest test-update-within 55 | (is (= {:foo 1} 56 | (update-within {:foo 0} [] update :foo inc) 57 | (update-within {:foo 0} [:foo] inc) 58 | (update-within {:foo 1} [:bar] inc)))) 59 | 60 | (deftest test-merge-in 61 | (is (= {:a {:b {:c 4} :d 2 :e 3} :e 3 :f 2 :g 1} 62 | (merge-in {:a {:b {:c 1} :d 2} :e 3 :f 4} 63 | {:a {:b {:c 4} :e 3} :f 2 :g 1}))) 64 | (is (= {:a {:b {:c 1 :d 2} :e 2}} 65 | (merge-in {:a {:b {:c 1}}} 66 | {:a {:b {:d 2}}} 67 | {:a {:b {} :e 2}}))) 68 | (is (= {:a 1 :b 2} 69 | (merge-in nil 70 | {:a 1} 71 | {:b 2}))) 72 | (is (= nil (merge-in))) 73 | (is (= nil (merge-in nil))) 74 | (is (= {} (merge-in {})))) 75 | 76 | (deftest test-map-to 77 | (is (= {1 2 3 4 5 6} (map-to inc [1 3 5]))) 78 | (is (= {2 1} (map-to dec [2 2 2])))) 79 | 80 | (deftest test-index-by 81 | (is (= {true 3 false 4} (index-by odd? [1 3 4]))) 82 | (is (= {1 2 3 4 5 6} (index-by dec [2 4 6])))) 83 | 84 | (deftest test-position 85 | (is (= (position [1 3 5 3]) 86 | {1 0 3 1 5 2}))) 87 | 88 | (deftest map-filtering-tests 89 | (let [m '{a 0, b 1, c 11, d 92}] 90 | (is (= '(a d) (filter-keys-by-val even? m))) 91 | (is (= '(b c) (remove-keys-by-val even? m))) 92 | (is (= '{a 0} (filter-vals m zero?))) 93 | (is (= '{b 1, c 11, d 92} (remove-vals m zero?))) 94 | (is (= '{a 0} (filter-keys m '#{a}))) 95 | (is (= '{b 1, c 11, d 92} (remove-keys m '#{a}))))) 96 | 97 | (deftest test-update-in 98 | (is (= [1] (-> (update-in! {:foo (transient {:bar []})} [:foo :bar] conj 1) 99 | :foo :bar)))) 100 | 101 | (deftest test-assoc-in 102 | (is (= [1] (-> (assoc-in! {:foo {}} [:foo :bar] [1]) 103 | :foo :bar)))) 104 | 105 | (deftest test-dissoc-in* 106 | (is (= {} 107 | (dissoc-in* {:foo {:bar 3}} [:foo :bar]))) 108 | (is (= {:foo {:baz 8}} 109 | (dissoc-in* {:foo {:bar 3 :baz 8}} [:foo :bar]))) 110 | (is (= {:bam 3} 111 | (dissoc-in* {:foo {:bar 3 :baz 8} :bam 3} [:foo]))) 112 | (is (= {} 113 | (dissoc-in* {:foo {:bar 3 :baz 8}} []))) 114 | (is (= {} 115 | (dissoc-in* {:foo {:bar false}} [:foo :bar]))) 116 | (is (= {} 117 | (dissoc-in* {:foo {:bar nil}} [:foo :bar])))) 118 | 119 | (deftest test-assoc-in* 120 | (is (= {:foo {:bar 1}} 121 | (assoc-in* {} [:foo :bar] 1))) 122 | (is (= {:foo {}} 123 | (assoc-in* {:foo {:bar 3 :baz 8}} [:foo] {}))) 124 | (is (= {:foo {:bar 3 :baz 8} :bam 3} 125 | (assoc-in* {:foo {:bar 3} :bam 3} [:foo :baz] 8))) 126 | (is (= {:bar 1} 127 | (assoc-in* {:foo 1} [] {:bar 1})))) 128 | 129 | (deftest test-update-in* 130 | (is (= {:foo {:bar 1}} 131 | (update-in* {} [:foo :bar] (constantly 1)))) 132 | (is (= {:foo 2} 133 | (update-in* {:foo {:bar 3 :baz 8}} [:foo] count))) 134 | (is (= {:foo {:bar 4} :bam 3} 135 | (update-in* {:foo {:bar 3} :bam 3} [:foo :bar] inc))) 136 | (is (= 2 137 | (update-in* {:foo 1 :bar 2} [] count))) 138 | (is (= {} 139 | (update-in* {} [:foo :bar :baz] identity)))) 140 | 141 | (deftest test-multi-map 142 | (is (= {:foo #{1 2 3 4}, :bar #{2 3 4 5 6}, :baz #{5 6}} 143 | (multi-map {:foo 1, #{:foo :bar} #{2 3 4}, #{:baz :bar} #{5 6}}))) 144 | (is (= {:foo #{1 2}, :bar #{2 3}} 145 | (multi-map {:foo #{1 2}, :bar #{2 3}})))) 146 | 147 | (deftest test-ordering-map 148 | (let [template (ordering-map [:b :c :a])] 149 | (is (= {} template)) 150 | (is (= [[:b 2] [:c 3] [:a 1]] 151 | (seq (into template {:a 1 :b 2 :c 3})))) 152 | (is (= [[:c 3] [:a 1] [1 :a] [5 :e]] 153 | (seq (into template {:a 1, 5 :e, :c 3, 1 :a})))))) 154 | -------------------------------------------------------------------------------- /test/flatland/useful/ns_test.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.ns-test 2 | (:use clojure.test flatland.useful.ns) 3 | (:require [flatland.useful.fn :as fn] 4 | [flatland.useful.macro :as macro])) 5 | 6 | (defalias fixit fn/fix) 7 | (alias-var 'as-macro #'macro/anon-macro) 8 | (alias-ns 'flatland.useful.string) 9 | 10 | (deftest test-var-name 11 | (is (= 'clojure.core/inc (var-name #'inc)))) 12 | 13 | (deftest test-defalias 14 | (is (= 1 (fixit 0 even? inc)))) 15 | 16 | (deftest test-alias-var 17 | (is (= 3 (as-macro [x y] `(+ ~x ~y) 1 2)))) 18 | 19 | (deftest test-alias-ns 20 | (is (bound? #'flatland.useful.ns-test/camelize))) -------------------------------------------------------------------------------- /test/flatland/useful/parallel_test.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.parallel-test 2 | (:use clojure.test flatland.useful.parallel)) 3 | 4 | (def ^{:dynamic true} *i* 1) 5 | 6 | (defn mult [num] 7 | (* num *i*)) 8 | 9 | (defn wrap-i [f] 10 | (fn [] 11 | (binding [*i* 2] 12 | (f)))) 13 | 14 | (deftest test-pcollect 15 | (doseq [n [1 2 3 4]] 16 | (binding [*pcollect-thread-num* n] 17 | (is (= [1 2 3 4 5 6 7 8 9 10] 18 | (pcollect inc [0 1 2 3 4 5 6 7 8 9]))) 19 | (is (= [2 4 6 8 10 12 14 16 18 20] 20 | (pcollect wrap-i mult 21 | [1 2 3 4 5 6 7 8 9 10])))))) 22 | -------------------------------------------------------------------------------- /test/flatland/useful/seq_test.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.seq-test 2 | (:use clojure.test flatland.useful.seq clojure.set)) 3 | 4 | (deftest test-zip 5 | (is (= [[1 4 8] [2 5 9] [3 6 nil] [nil 7 nil]] (zip [1 2 3] [4 5 6 7] [8 9])))) 6 | 7 | (deftest test-insert 8 | (is (= [1 2 3 4 5] (insert [2 3] 1 [1 4 5])))) 9 | 10 | (deftest test-find-with 11 | (is (= :foo (find-with odd? [2 4 5 7] [:bar :baz :foo :bap]))) 12 | (is (= nil (find-with even? [1 3 5 9] [:bar :baz :foo :bap])))) 13 | 14 | (deftest test-cross 15 | (is (= '((0 0) (0 1) (1 0) (1 1)) (cross [0 1] [0 1]))) 16 | (is (= '((0 0 2) (0 1 2) (1 0 2) (1 1 2)) (cross [0 1] [0 1] [2])))) 17 | 18 | (deftest test-lazy-cross 19 | (is (= '((0 0) (1 0) (0 1) (1 1)) (lazy-cross [0 1] [0 1]))) 20 | (is (= '((0 0 2) (1 0 2) (0 1 2) (1 1 2)) (lazy-cross [0 1] [0 1] [2])))) 21 | 22 | (deftest test-extract 23 | (is (= [5 '(2 4 6 1 2 7)] (extract odd? [2 4 6 5 1 2 7]))) 24 | (is (= [2 '(4 6 5 1 2 7)] (extract even? [2 4 6 5 1 2 7]))) 25 | (is (= [7 '(2 4 6 5 1 2)] (extract #(< 6 %) [2 4 6 5 1 2 7])))) 26 | 27 | (deftest test-separate 28 | (is (= ['(5 1 7) '(2 4 6 2)] (separate odd? [2 4 6 5 1 2 7]))) 29 | (is (= ['(2 4 6 2) '(5 1 7)] (separate even? [2 4 6 5 1 2 7])))) 30 | 31 | ;; TODO test unglue? option to glue 32 | 33 | (deftest test-glue 34 | ;; Make sure all items of the same type wind up in the same batch, 35 | ;; and each batch is as close to size 6 as possible without going over. 36 | 37 | ;; The D batch is too large, and glue promises to return a too-large batch 38 | ;; in preference to splitting up a batch. 39 | (is (= '((a1 a2 a3 a4 b1) 40 | (c1 c2) 41 | (d1 d2 d3 d4 d5 d6 d7) 42 | (e8)) 43 | (glue into [] 44 | (fn [batch more] 45 | (>= 6 (+ (count batch) (count more)))) 46 | '((a1 a2 a3 a4) 47 | (b1) 48 | (c1 c2) 49 | (d1 d2 d3 d4 d5 d6 d7) 50 | (e8)))))) 51 | 52 | (deftest test-partition-between 53 | (testing "returns a totally lazy sequence" 54 | (is (= (lazy-seq nil) 55 | (partition-between (fn [& _] (throw (Exception. "Never call me"))) 56 | nil)))) 57 | (testing "doesn't force input sequence more than necessary" 58 | ;; partition-between should be forcing elements 1 and 2 of this sequence 59 | ;; to compute the first partition. 60 | (let [input (list* 1 2 (lazy-seq (throw (Exception. "broken")))) 61 | partitioned (partition-between (constantly true) input)] 62 | (is (= [1] (first partitioned))) 63 | (is (thrown? Exception (second partitioned))))) 64 | (let [input [1 nil nil 2 3 nil 4]] 65 | (are [f output] (= output (partition-between f input)) 66 | (fn [[a b]] (not (nil? a))) [[1] [nil nil 2] [3] [nil 4]], 67 | (fn [[a b]] (not (nil? b))) [[1 nil nil] [2] [3 nil] [4]], 68 | (partial some nil?) [[1] [nil] [nil] [2 3] [nil] [4]], 69 | (fn [[a b]] (not= (nil? a) (nil? b))) [[1] [nil nil] [2 3] [nil] [4]]))) 70 | 71 | (deftest test-include? 72 | (is (include? 5 [1 2 3 4 5])) 73 | (is (include? :bar '(1 4 :bar))) 74 | (is (not (include? 2 '(1 3 4)))) 75 | (is (not (include? :foo [1 :bar :baz 3])))) 76 | 77 | (deftest test-unfold 78 | (is (= [0 1 1 2 3 5 8 13 21 34] 79 | (take 10 (unfold (fn [[a b]] 80 | [a [b (+ a b)]]) 81 | [0 1]))))) 82 | 83 | (deftest test-take-shuffled 84 | (let [nums (set (range 10))] 85 | (is (= nums (set (take-shuffled (count nums) nums)))) 86 | (is (= 5 (count (take-shuffled 5 nums)))) 87 | (is (subset? (set (take-shuffled 3 nums)) nums)))) 88 | 89 | (deftest test-find-first 90 | (is (= 5 (find-first odd? [2 5 9]))) 91 | (is (nil? (find-first (constantly false) (range 1000))))) 92 | 93 | (deftest test-lazy-loop 94 | (is (= (range 10) 95 | (lazy-loop [i 0] 96 | (when-not (= i 10) 97 | (cons i (lazy-recur (inc i))))))) 98 | (testing "0-arg lazy-loop" 99 | (is (= [1 1 1] (take 3 100 | (lazy-loop [] 101 | (cons 1 (lazy-recur)))))))) 102 | 103 | (deftest test-alternates 104 | (is (= '[[a b] [1 2]] 105 | (alternates '[a 1 b 2]))) 106 | (is (= '[[0 3 6] [1 4 7] [2 5 8]] 107 | (alternates 3 (range 9)))) 108 | (testing "Doesn't blow up for empty seqs" 109 | (let [a (alternates [])] 110 | (testing "Lazy if nothing forced." 111 | (is a)) 112 | (is (not (seq a)))))) 113 | 114 | (deftest test-slice 115 | (let [size 900, slices 7, coll (range size), 116 | sliced (slice slices coll), largest (apply max (map count sliced))] 117 | (testing "We get all the items back in order" 118 | (is (= coll (apply concat sliced)))) 119 | (testing "We get the right number of slices" 120 | (is (= slices (count sliced)))) 121 | (testing "Slices are sized regularly" 122 | (is (every? #(<= (Math/abs (- % largest)) 1) 123 | (map count sliced)))))) 124 | 125 | (deftest test-foldr 126 | (is (= [1 2 3 4] 127 | (foldr cons nil [1 2 3 4])))) 128 | 129 | (deftest test-unchunk 130 | (let [a (atom 0) 131 | f (fn [_] (swap! a inc)) 132 | coll (range 100)] 133 | (is (= 1 (first (map f coll)))) 134 | (is (< 1 @a)) ;; multiple elements realized 135 | 136 | (reset! a 0) 137 | (is (= 1 (first (map f (unchunk coll))))) 138 | (is (= 1 @a)))) ;; only one element realized 139 | 140 | (deftest test-lazy 141 | (let [realized (atom 0) 142 | realize (fn [x] (swap! realized inc) x) 143 | the-list (lazy (realize 1) (realize 2))] 144 | (is (= 0 @realized)) 145 | (is (= 1 (first the-list))) 146 | (is (= 1 @realized)) 147 | (is (= 2 (second the-list))) 148 | (is (= 2 @realized)) 149 | (is (nil? (next (next the-list)))) 150 | (is (= 2 @realized)))) 151 | 152 | (deftest test-remove-prefix 153 | (let [a [1 2 3], b [1 2], c [2 3], d []] 154 | (is (= [3] (remove-prefix [1 2] [1 2 3]))) 155 | (is (= [] (remove-prefix [1 2] [1 2]))) 156 | (is (= [1 2] (remove-prefix [] [1 2]))) 157 | (is (= false (remove-prefix [1 2] [3 2]))) 158 | (is (= nil (remove-prefix [1 2 3] [1 2]))))) 159 | 160 | (deftest test-prefix-of? 161 | (is (prefix-of? [1 2 3] [1 2])) 162 | (is (prefix-of? [1 2] [1 2])) 163 | (is (not (prefix-of? [1 2] [1 2 3]))) 164 | (is (not (prefix-of? [1 2 3] [2 3]))) 165 | (is (prefix-of? [1 2 3] [])) 166 | (is (prefix-of? [1 2] []))) 167 | 168 | (deftest test-sequeue 169 | (testing "lookahead" 170 | (let [a (atom 0) 171 | xs (list* 1 2 3 4 5 6 7 8 9 [10]) ;; avoid chunking 172 | coll (for [x xs] (do (swap! a inc) x))] 173 | (is (zero? @a)) 174 | (let [s (sequeue 5 coll)] 175 | (Thread/sleep 100) 176 | (is (< 0 @a 10)) ;; should have some queued, but not all 177 | (is (= coll (doall s))) 178 | (is (= 10 @a))))) 179 | (testing "error propagation" 180 | (let [coll (lazy-seq 181 | (list* 1 2 3 4 5 6 7 8 9 182 | (lazy-seq 183 | (cons 10 184 | (lazy-seq 185 | (throw (IllegalStateException. "Broken"))))))) 186 | s (sequeue 2 coll)] 187 | (is (= 1 (first s))) 188 | (is (thrown? Throwable (dorun s)))))) 189 | 190 | (deftest test-map-nth 191 | (is (= [2 2 4 4 6 6 8 8 10 10] 192 | (map-nth inc 2 [1 2 3 4 5 6 7 8 9 10]))) 193 | (is (= ["" "x" "" "x"] (map-nth #(str % "x") 1 2 ["" "" "" ""])))) 194 | 195 | (deftest test-update-first 196 | (is (= [1 3 3 4 5] 197 | (update-first [1 2 3 4 5] even? inc))) 198 | 199 | (is (= [1 2 3 4 5 15] 200 | (update-first [1 2 3 4 5] zero? (fnil + 0) 1 2 3 4 5)))) 201 | 202 | (deftest test-assert-length 203 | (is (= [1 2 3] (assert-length 3 [1 2 3]))) 204 | (is (thrown? Throwable (assert-length 3 [1])))) 205 | 206 | (deftest test-flatten-all 207 | (is (= [:a 1 2 :e 1 2] (flatten-all {:a [1 2 {:e '(1 2)}]})))) 208 | 209 | (deftest test-groupings 210 | (is (= {true ["0" "2" "4" "6" "8"] 211 | false ["1" "3" "5" "7" "9"]} 212 | (groupings even? str (range 10)))) 213 | (is (= {true 20, false 25} 214 | (groupings even? + 0 (range 10))))) 215 | 216 | (deftest test-increasing 217 | (let [input [3 4 2 3 5 9 1]] 218 | (are [args output] (= output (apply increasing (conj args input))) 219 | [] [3 4 5 9] 220 | [-] [3 2 1] 221 | [identity #(if (< %2 %) -1 1)] [3 2 1] 222 | 223 | [- ;; descending, but even numbers sort before odds 224 | (fn [a b] 225 | (cond (and (even? a) (odd? b)) -1 226 | (and (even? b) (odd? a)) 1 227 | :else (compare a b)))] 228 | [3 3 1]))) 229 | -------------------------------------------------------------------------------- /test/flatland/useful/state_test.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.state-test 2 | (:use clojure.test flatland.useful.state)) 3 | 4 | (deftest test-volatile 5 | (testing "volatile returns a mutable ref" 6 | (let [a (volatile 1)] 7 | (is (= 1 @a)) 8 | (is (= 2 (put! a 2))) 9 | (is (= 2 @a))) 10 | (let [a (volatile 1 :meta {:foo 1} :validator pos?)] 11 | (is (= 1 (:foo (meta a)))) 12 | (is (= 1 @a)) 13 | (is (= 2 (put! a 2))) 14 | (is (= 1 (:foo (meta a)))) 15 | (is (= 2 @a)) 16 | (is (thrown-with-msg? java.lang.IllegalStateException #"Invalid reference state" 17 | (put! a 0)))))) 18 | 19 | (deftest test-trade 20 | (testing "trade! returns the old atom value" 21 | (let [a (atom 1)] 22 | (is (= 1 (trade! a inc))) 23 | (is (= 2 @a)) 24 | (is (= 2 (trade! a + 100))) 25 | (is (= 102 @a))))) 26 | 27 | (deftest test-wait-until 28 | (let [a (atom 0)] 29 | (is (zero? (wait-until a even?))) 30 | (let [f (future (Thread/sleep 250) 31 | (swap! a inc))] 32 | (is (odd? (wait-until a odd?)))))) 33 | 34 | (def ^{:dynamic true} *value* 1) 35 | 36 | (deftest test-alter-var 37 | (let [get-value (fn [] *value*)] 38 | (is (= 1 *value*)) 39 | (is (= 4 (with-altered-vars [(+ *value* 3)] 40 | (get-value)))))) 41 | 42 | (def const 20) 43 | (deftest test-alter-root 44 | (let [get-value (fn [] const)] 45 | (is (= 20 (get-value))) 46 | (is (= 10 (with-altered-roots [(- const 10)] 47 | (get-value)))) 48 | (is (= 20 (get-value))))) 49 | -------------------------------------------------------------------------------- /test/flatland/useful/string_test.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.string-test 2 | (:use flatland.useful.string clojure.test)) 3 | 4 | (deftest to-camel 5 | (are [in out] (= out (camelize in)) 6 | "the-string" "theString" 7 | "this-is-real" "thisIsReal" 8 | "untouched" "untouched")) 9 | 10 | (deftest to-class 11 | (are [in out] (= out (classify in)) 12 | "the-string" "TheString" 13 | "this-is-real" "ThisIsReal" 14 | "touched" "Touched")) 15 | 16 | (deftest from-camel 17 | (are [in dashed underscored] (= [dashed underscored] 18 | ((juxt dasherize underscore) in)) 19 | "setSize" "set-size" "set_size" 20 | "theURL" "the-url" "the_url" 21 | "ClassName" "class-name" "class_name" 22 | "LOUD_CONSTANT" "loud-constant" "loud_constant" 23 | "the_CRAZY_train" "the-crazy-train" "the_crazy_train" 24 | "with-dashes" "with-dashes" "with_dashes" 25 | "with_underscores" "with-underscores" "with_underscores")) 26 | 27 | (deftest pluralize-test 28 | (is (= "10 dogs" (pluralize 10 "dog"))) 29 | (is (= "1 cat" (pluralize 1 "cat"))) 30 | (is (= "0 octopodes" (pluralize 0 "octopus" "octopodes"))) 31 | (is (= "1 fish" (pluralize 1 "fish" "fishes")))) 32 | 33 | (deftest substring-after-test 34 | (let [s "foo:bar:baz-10"] 35 | (is (= "baz-10" ((substring-after ":") s))) 36 | (is (= "10" ((substring-after "-") s))) 37 | (is (= s ((substring-after "Q") s))) 38 | (is (= "z-10" ((substring-after "ba") s))) 39 | (is (= "" ((substring-after "0") s))))) 40 | -------------------------------------------------------------------------------- /test/flatland/useful/test_test.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.test-test 2 | (:use flatland.useful.test clojure.test)) 3 | 4 | (defmacro tags? [test expected] 5 | `(is (= ~(set (map keyword expected)) 6 | (-> ~test var meta :tags)))) 7 | 8 | (with-test-tags [unit] 9 | (deftest test-unit 10 | (tags? test-unit [unit])) 11 | (with-test-tags [debug] 12 | (deftest test-debug 13 | (tags? test-debug [unit debug]))) 14 | (deftest more-unit-tests 15 | (tags? more-unit-tests [unit]))) 16 | 17 | 18 | ;; defines a test with no tags attached: 19 | (deftest plain-deftest 20 | (is (not (contains? (meta #'plain-deftest) :tags)))) 21 | 22 | (with-test-tags [foo] 23 | 24 | ;; this test will be tagged #{:foo}: 25 | (deftest foo 26 | (tags? foo [foo])) 27 | 28 | (with-test-tags [bar] 29 | 30 | ;; this test will be tagged #{:foo :bar}: 31 | (deftest foo-bar 32 | (tags? foo-bar [foo bar])))) 33 | 34 | ;; tests inside with-test-args can be closures: 35 | (with-test-tags [foo] 36 | (let [x #{:foo}] 37 | (deftest lexical-bindings-with-tags 38 | (is (= x (:tags (meta #'lexical-bindings-with-tags))))))) 39 | -------------------------------------------------------------------------------- /test/flatland/useful/utils_test.clj: -------------------------------------------------------------------------------- 1 | (ns flatland.useful.utils-test 2 | (:use clojure.test flatland.useful.utils)) 3 | 4 | (deftest test-invoke 5 | (is (= 1 (invoke inc 0))) 6 | (is (= (range 5) 7 | (map invoke 8 | (map constantly 9 | (range 5)))))) 10 | 11 | (deftest test-or-min 12 | (is (= 3 (or-min nil 4 3 nil 9))) 13 | (is (= 1 (or-min 1 2 3 4))) 14 | (is (= 1 (or-min 1 nil))) 15 | (is (= nil (or-min nil nil nil)))) 16 | 17 | (deftest test-or-max 18 | (is (= 9 (or-max nil 4 3 nil 9))) 19 | (is (= 4 (or-max 1 2 3 4))) 20 | (is (= 1 (or-max 1 nil))) 21 | (is (= nil (or-max nil nil nil)))) 22 | 23 | (deftest test-split-vec 24 | (is (= [[1 2] [3 4]] (split-vec [1 2 3 4] 2))) 25 | (is (= [[1 2] [3 4] [5 6]] (split-vec [1 2 3 4 5 6] 2 4))) 26 | (is (= [[1] [2 3 4 5] [6]] (split-vec [1 2 3 4 5 6] 1 5))) 27 | (is (= [[1] [2 3 4] [5 6]] (split-vec [1 2 3 4 5 6] 1 -2)))) 28 | 29 | (deftest test-if-ns 30 | (if-ns (:use this-namespace.should-not-exist) 31 | (is false) 32 | (is true)) 33 | (if-ns (:require clojure.string) 34 | (is true) 35 | (is false))) 36 | 37 | (deftest test-returning 38 | (let [side-effects (atom 0)] 39 | (is (= "TEST" 40 | (returning "TEST" 41 | (swap! side-effects inc)))) 42 | (is (= 1 @side-effects)))) 43 | 44 | (deftest test-into-set 45 | (is (= #{1 2 3 4} 46 | (into-set #{3 1 5} {5 false 4 true 2 true})))) 47 | 48 | (deftest test-adjoin 49 | (is (= {:a [1 2 3] :b {"foo" [2 3 5] "bar" 7 "bap" 9 "baz" 2} :c #{2 4 6 8}} 50 | (adjoin 51 | {:a [1] :b {"foo" [2 3] "bar" 8 "bap" 9} :c #{2 3 4 6}} 52 | {:a [2 3] :b {"foo" [5] "bar" 7 "baz" 2} :c {3 false 8 true}})))) 53 | 54 | (deftest test-pop-if 55 | (is (= [[1 2 3] 4] (pop-if [1 2 3 4] even?))) 56 | (is (= [[1 2 3 4] 1] (pop-if [1 2 3 4] odd? 1))) 57 | (is (= ['(2 3) 1] (pop-if '(1 2 3) odd?))) 58 | (is (= ['(1 2 3) nil] (pop-if '(1 2 3) even?))) 59 | (is (= ['(2) 1] (pop-if (cons 1 [2]) odd?))) 60 | (is (= ['(1 2) nil] (pop-if (cons 1 [2]) neg?)))) 61 | 62 | (deftest test-update-peek 63 | (is (= [1 2 4] (update-peek [1 2 3] inc))) 64 | (is (= [1 2 6] (update-peek [1 2 3] + 1 2))) 65 | (is (= '(2 2 3) (update-peek '(1 2 3) inc))) 66 | (is (= [{:foo 1}] (update-peek [{}] assoc :foo 1)))) 67 | 68 | (deftest test-queue 69 | (let [q (queue)] 70 | (is (instance? clojure.lang.PersistentQueue q)) 71 | (is (empty? q))) 72 | (let [q (queue [1 2 3 4])] 73 | (is (= 1 (first q))) 74 | (is (= 2 (-> q pop first))) 75 | (is (= 3 (-> q pop pop first))) 76 | (is (= 4 (-> q pop pop pop first))) 77 | (is (= 4 (count q))))) 78 | 79 | (def ^{:dynamic true} *i* 1) 80 | 81 | (deftest test-memoize-deref 82 | (let [count (atom 0) 83 | incr (memoize-deref [#'*i*] 84 | (fn [i] 85 | (swap! count inc) 86 | (+ i *i*)))] 87 | (dotimes [n 5] 88 | (binding [*i* 4] 89 | (is (= 9 (incr 5))) 90 | (is (= 1 (incr -3)))) 91 | (binding [*i* 1] 92 | (is (= 6 (incr 5))) 93 | (is (= -2 (incr -3))))) 94 | (is (= 4 @count)))) 95 | 96 | (deftest test-fail 97 | (is (thrown? Throwable 98 | (fail "Test"))) 99 | (is (thrown-with-msg? Throwable #"foo bar 2" 100 | (fail "%s bar %d" "foo" 2)))) 101 | 102 | (deftest test-verify 103 | (is (thrown? Throwable 104 | (verify false "Test"))) 105 | (is (thrown-with-msg? Throwable #"error 10" 106 | (verify nil "error %d" 10))) 107 | (testing "exception clause is not evaluated when verify succeeds" 108 | (is (= nil (verify true 109 | (throw (Exception.))))))) 110 | 111 | (def memo-called (atom 0)) 112 | (defm sample-memoized [x] 113 | (swap! memo-called inc) 114 | (inc x)) 115 | 116 | (deftest test-defm 117 | (let [i @memo-called 118 | j (inc i)] 119 | (is (= j (sample-memoized i))) 120 | (is (= j @memo-called)) 121 | (is (= j (sample-memoized i))) 122 | (is (= j @memo-called)))) 123 | 124 | (deftest test-with-adjustments 125 | (is (= 1 (with-adjustments #(fnil % 0) [+ inc] 126 | (+ nil (inc nil)))))) 127 | 128 | (deftest test-syntax-quote 129 | (is (= '((quote foo) (quote (bar [baz] "hi"))) (syntax-quote '(foo (bar [baz] "hi")))))) 130 | 131 | (deftest test-pair 132 | (testing "map-entry is a macro (for performance)" 133 | (let [form `(map-entry 1 2)] 134 | (is (not= form (macroexpand form))))) 135 | (testing "map-entry works, and is a MapEntry" 136 | (let [p (map-entry 1 2) 137 | [x y] p] 138 | (is (= x 1)) 139 | (is (= y 2)) 140 | (is (= p [1 2])) 141 | (are [c] (instance? c p) 142 | clojure.lang.IMapEntry 143 | clojure.lang.IPersistentVector))) 144 | (testing "pair is a non-macro version of map-entry" 145 | (is (= [(map-entry 1 2) (map-entry 3 4)] 146 | (map pair [1 3] [2 4]))))) 147 | 148 | (deftest thread-locals 149 | (let [times-called (atom 0) 150 | inst (thread-local 151 | (swap! times-called inc) 152 | (gensym))] 153 | (testing "thread-local caches return values" 154 | (is (= 0 @times-called)) 155 | (is (symbol? @inst)) 156 | (is (= 1 @times-called)) 157 | (is (symbol? @inst)) 158 | (is (= 1 @times-called))) 159 | 160 | (testing "thread has only one thread-local" 161 | (is (= @inst @inst))) 162 | 163 | (testing "new thread gets new value" 164 | (is (not= @inst @(future @inst)))))) 165 | 166 | (deftest test-let-later 167 | (let-later [a (atom 0) 168 | b (swap! a inc) 169 | ^{:delay true} c (swap! a inc) 170 | ^{:delay true} [x y] [@a (swap! a inc)]] 171 | (is (= 1 b)) 172 | (is (= 1 @a) "delay shouldn't have been forced yet") 173 | (is (= 2 c) "delay should fire when its value is needed") 174 | (is (= 2 @a) "and now the atom should have changed") 175 | (is (= 2 c) "shouldn't be eval'd again") 176 | (is (= 2 @a)) 177 | 178 | (is (= 2 x)) 179 | (is (= 3 y)))) 180 | 181 | (deftest test-copy-meta 182 | (let [x (-> [1 2 3] 183 | (with-meta {:foo 1})) 184 | y [4 5 6] 185 | z (copy-meta y x)] 186 | (is (= y z)) 187 | (is (= (meta z) (meta x))))) 188 | 189 | (deftest test-empty-coll 190 | (are [x] (empty-coll? x) 191 | nil, (), {}, []) 192 | (are [x] (not (empty-coll? x)) 193 | "", [1], [[]], '(()), 194 | 1, {1 2})) 195 | 196 | (deftest test-switch 197 | (testing "without default" 198 | (is (= :a (switch #{1}, #{1} :a, (2 3) :b, inc :c))) 199 | (is (= :b (switch 2, #{1} :a, (2 3) :b, inc :c))) 200 | (is (= :b (switch 3, #{1} :a, (2 3) :b, inc :c))) 201 | (is (= :c (switch inc, #{1} :a, (2 3) :b, inc :c))) 202 | (is (= nil (switch :foo, #{1} :a, (2 3) :b, inc :c)))) 203 | (testing "with default" 204 | (is (= :a (switch #{1}, #{1} :a, (2 3) :b, inc :c, :d))) 205 | (is (= :b (switch 2, #{1} :a, (2 3) :b, inc :c, :d))) 206 | (is (= :b (switch 3, #{1} :a, (2 3) :b, inc :c, :d))) 207 | (is (= :c (switch inc, #{1} :a, (2 3) :b, inc :c, :d))) 208 | (is (= :d (switch :foo, #{1} :a, (2 3) :b, inc :c, :d))))) 209 | 210 | (deftest test-with-timing 211 | (let [[ret ms] (with-timing 212 | (+ 2 2) 213 | (+ 3 3))] 214 | (is (= ret 6)) 215 | (is (float? ms)))) 216 | --------------------------------------------------------------------------------