├── .gitattributes ├── .gitignore ├── LICENSE ├── README.md ├── src ├── bulb │ ├── debug.fnl │ ├── init-macros.fnl │ └── init.fnl └── ns.fnl └── test ├── functional.fnl ├── init.fnl ├── iterators.fnl ├── luaunit.lua ├── macros.fnl ├── math.fnl ├── predicates.fnl └── tables.fnl /.gitattributes: -------------------------------------------------------------------------------- 1 | # Use clojure syntax highlighting for .fnl 2 | *.fnl linguist-language=clojure 3 | *.fnl -linguist-detectable 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | ## Github lua gitignore ## 2 | # Compiled Lua sources 3 | luac.out 4 | 5 | # luarocks build files 6 | *.src.rock 7 | *.zip 8 | *.tar.gz 9 | 10 | # Object files 11 | *.o 12 | *.os 13 | *.ko 14 | *.obj 15 | *.elf 16 | 17 | # Precompiled Headers 18 | *.gch 19 | *.pch 20 | 21 | # Libraries 22 | *.lib 23 | *.a 24 | *.la 25 | *.lo 26 | *.def 27 | *.exp 28 | 29 | # Shared objects (inc. Windows DLLs) 30 | *.dll 31 | *.so 32 | *.so.* 33 | *.dylib 34 | 35 | # Executables 36 | *.exe 37 | *.out 38 | *.app 39 | *.i*86 40 | *.x86_64 41 | *.hex 42 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2021 Mike Richards 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 19 | SOFTWARE. 20 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Bulb 2 | 3 | A "core" library for [Fennel][fennel]. Very much a work-in-progress. 4 | 5 | ## Inspirations and comparisons 6 | 7 | ### [Cljlib][cljlib] 8 | 9 | Cljlib reproduces much much of clojure.core than Bulb does. It includes a 10 | number of features, data structures, and macros that Bulb does not, e.g. 11 | multi-arity functions, sets, multimethods, when-let (and relatives). 12 | 13 | Bulb is not nearly as fully-featured as Cljlib, though it is also inspired by 14 | Clojure. A main difference between the two libraries is that Cljlib's sequences 15 | are primarily based around tables (and are more or less eager), while Bulb's 16 | are implemented using Lua iterators, making them lazy. 17 | 18 | ### [Luafun][luafun] 19 | 20 | Bulb and Luafun have a lot of overlap in terms of both functionality and -- in 21 | my own benchmarking -- speed (similar on Luajit, and Bulb seems to be a bit 22 | faster on Lua 5.4, perhaps since luafun is optimized for Luajit). 23 | 24 | Luafun uses a slightly different iteration protocol, storing state in the 25 | [control variable][control-var] that you are supposed to ignore. This allows 26 | Luafun to return state*less* iterators (as long as the source iterator is 27 | stateless), which have some [benefits][luafun-under-the-hood]. 28 | 29 | Bulb works exclusively with state*ful* iterators, and returns iterators that 30 | work with Lua's normal iteration protocol (i.e. you can use then with the 31 | generic `for`), though you have to wrap Lua's stateless iterators (e.g. `pairs` 32 | and `ipairs`) in order to use them. 33 | 34 | ## License 35 | 36 | Copyright © 2021 Mike Richards 37 | 38 | Released under the MIT license. 39 | 40 | 41 | [fennel]: https://fennel-lang.org 42 | [cljlib]: https://gitlab.com/andreyorst/fennel-cljlib/ 43 | [luafun]: https://github.com/luafun/luafun 44 | [control-var]: https://www.lua.org/pil/7.2.html 45 | [luafun-under-the-hood]: https://luafun.github.io/under_the_hood.html#iterator-types 46 | -------------------------------------------------------------------------------- /src/bulb/debug.fnl: -------------------------------------------------------------------------------- 1 | ;; debug helpers 2 | 3 | (fn locals [?n] 4 | "Returns a table with all locals, of the form [{: name : value} ...]." 5 | (let [ret {}] 6 | (for [i 1 500] 7 | (match (debug.getlocal (+ 1 (or ?n 1)) i) 8 | (name value) (table.insert ret {: name : value}) 9 | _ (lua "do break end"))) 10 | ret)) 11 | 12 | (fn local-names [?n] 13 | (icollect [_ v (ipairs (locals ?n))] 14 | v.name)) 15 | 16 | (fn upvalues [?f] 17 | "Returns a table with all upvalues, of the form [{: name : value} ...]." 18 | (let [ret {} 19 | f (if (= :function (type ?f)) 20 | ?f 21 | (. (debug.getinfo (+ 1 (or ?f 1)) :f) :func))] 22 | (for [i 1 500] 23 | (match (debug.getupvalue f i) 24 | (name value) (table.insert ret {: name : value}) 25 | _ (lua "do break end"))) 26 | ret)) 27 | 28 | (fn upvalue-names [?f] 29 | "Returns the name of all upvalues." 30 | (icollect [_ v (ipairs (upvalues ?f))] 31 | v.name)) 32 | 33 | {: locals 34 | : local-names 35 | : upvalues 36 | : upvalue-names} 37 | -------------------------------------------------------------------------------- /src/bulb/init-macros.fnl: -------------------------------------------------------------------------------- 1 | ;;;; A few each-like macros 2 | 3 | (fn binding? [bind] 4 | (or (sym? bind) 5 | (varg? bind) 6 | (and (or (table? bind) (list? bind)) 7 | (let [(_ v) (next bind)] 8 | (sym? v))))) 9 | 10 | ;; neat, but probably not going to do it since it's pretty inefficient 11 | (fn let-varg [[bind expr & more-bindings] ...] 12 | "Let, but allows binding to the varg symbol (...)." 13 | (if 14 | ;; body 15 | (= nil bind) ... 16 | ;; literal ... 17 | (= `... bind) `((fn [...] ,(let-varg more-bindings ...)) ,expr) 18 | ;; ... in a varg destructure 19 | (and (list? bind) (= `... (. bind (length bind)))) 20 | `((fn [,(unpack bind)] ,(let-varg more-bindings ...)) ,expr) 21 | :else 22 | `(let [,bind ,expr] ,(let-varg more-bindings ...)))) 23 | 24 | ;; the original version using bulb.iter.cat 25 | (fn each-iter-old [bindings body ...] 26 | "Like [[doseq]], but returns an iterator instead of evaluating immediately. 27 | Essentially the same as Clojure's `for`. 28 | 29 | Supports multiple iterators, as well as :let, :when, and :while clauses." 30 | (fn inner-iterator? [more-bindings] 31 | (for [i 1 (length more-bindings) 2] 32 | (when (binding? (. more-bindings i)) 33 | (lua "return false"))) 34 | true) 35 | (fn new-syms [] 36 | {:loop (gensym :loop) :it (gensym :it) :state (gensym :state) :ctrl (gensym :ctrl)}) 37 | (fn parse-1 [syms [fst snd & more-bindings] body] 38 | (match (values fst snd) 39 | (nil nil) body 40 | ;; modifiers -- note that :when and :while have different 'else' 41 | ;; conditions than in doseq, since `nil` halts iteration 42 | (:let let-bindings) `(let ,let-bindings ,(parse-1 syms more-bindings body)) 43 | (:when test) `(if ,test ,(parse-1 syms more-bindings body) (,syms.loop)) 44 | (:while test) `(when ,test ,(parse-1 syms more-bindings body)) 45 | (:until test) `(when (not ,test) ,(parse-1 syms more-bindings body)) 46 | ;; iterator 47 | (where (bind* expr) (binding? bind*)) 48 | (let [user-bindings (if (list? bind*) bind* (list bind*)) 49 | {: it : state : ctrl : loop &as syms} (new-syms) 50 | bind-gen (icollect [i s (ipairs user-bindings)] 51 | (when (< 1 i) ; don't need one for the ctrl sym 52 | (gensym :bind)))] 53 | `(do 54 | (var (,it ,state ,ctrl ,(unpack bind-gen)) ,expr) 55 | (->> (fn ,loop [] 56 | (set (,ctrl ,(unpack bind-gen)) (,it ,state ,ctrl)) 57 | (when (not= nil ,ctrl) 58 | (let [,user-bindings (values ,ctrl ,(unpack bind-gen))] 59 | ,(parse-1 syms more-bindings body)))) 60 | ,(if (not (inner-iterator? more-bindings)) 61 | ;; TODO: inline this? 62 | `((. (require :bulb.iter) :cat)))))) 63 | _ (error (.. "each-iter: expected a binding (symbol, list, or table) or " 64 | ":let, :while, or :when but saw " (view [fst snd]))))) 65 | (assert (= nil ...) "each-iter: one body form allowed") 66 | (assert (not= nil body) "each-iter: body for is required") 67 | (assert (binding? (. bindings 1)) "each-iter: first binding must be to an iterator") 68 | (parse-1 nil bindings body)) 69 | 70 | ;;; The new version, using tail calls like goto, without using cat at all 71 | 72 | (fn partition-bindings [bindings] 73 | ;; partition bindings so that each group only includes one iterator binding 74 | ;; (and any number of modifier bindings) 75 | (let [groups []] 76 | (each [i x (ipairs bindings)] 77 | (if (and (not= 0 (% i 2)) (binding? x)) 78 | (table.insert groups [x]) 79 | (table.insert (. groups (length groups)) x))) 80 | groups)) 81 | 82 | ;; See the end of this file for example macroexpansions 83 | (fn each-iter-1 [inner outer [[bind expr & modifiers] & inner-groups] body] 84 | (let [it (gensym :it) state (gensym :state) ctrl (gensym :ctrl) 85 | loop (gensym :loop) 86 | outer-call (if outer `(,outer) `nil) 87 | do-mods (fn do-mods [[fst snd & more-mods]] 88 | (match (values fst snd) 89 | (nil nil) (if (next inner-groups) 90 | (each-iter-1 inner loop inner-groups body) 91 | body) 92 | (:let let-bindings) `(let ,let-bindings ,(do-mods more-mods)) 93 | (:when test) `(if ,test ,(do-mods more-mods) (,loop)) 94 | (:while test) `(if ,test ,(do-mods more-mods) ,outer-call) 95 | (:until test) `(if (not ,test) ,(do-mods more-mods) ,outer-call) 96 | _ (error (.. "each-iter: expected :let, :while, :when, or :until, " 97 | "but saw " (view [fst snd]))))) 98 | user-bindings (if (list? bind) bind (list bind)) 99 | bind-gen (icollect [i s (ipairs user-bindings)] 100 | (when (< 1 i) ; first binding is ctrl 101 | (gensym :bind))) 102 | init-vars `(var (,it ,state ,ctrl ,(unpack bind-gen)) ,expr) 103 | declare-fn `(fn ,loop [] 104 | (set (,ctrl ,(unpack bind-gen)) (,it ,state ,ctrl)) 105 | (if (not= nil ,ctrl) 106 | (let [,user-bindings (values ,ctrl ,(unpack bind-gen))] 107 | ,(do-mods modifiers)) 108 | ,outer-call))] 109 | (match (values outer (next inner-groups)) 110 | ;; This case means it's a single-level (not nested) iterator, so there 111 | ;; are no chains of iterators to set in action. All we need to do is 112 | ;; return the simple iterator function 113 | (nil nil) `(do ,init-vars ,declare-fn ,loop) 114 | ;; Outermost nested interator -- setup the initial chain 115 | (nil _) `(do (var ,inner nil) 116 | ,init-vars ,declare-fn 117 | ;; the first call kicks off a chain that starts at the 118 | ;; outermost iterator and ends at the innermost iterator, 119 | ;; eventually rebinding `inner` (see the next case) 120 | (set ,inner ,loop) 121 | (fn [] (,inner))) 122 | ;; Innermost nested iterator -- rebind `inner` 123 | (_ nil) `(do ,init-vars ,declare-fn 124 | (set ,inner ,loop) 125 | (,loop)) 126 | ;; Otherwise this is an intermediary iterator, so keep the chain going 127 | _ `(do ,init-vars ,declare-fn 128 | (,loop))))) 129 | 130 | (fn each-iter [bindings body ...] 131 | "Like [[doseq]], but returns an iterator instead of evaluating immediately. 132 | Essentially the same as Clojure's `for`. 133 | 134 | Supports multiple iterators, as well as :let, :when, :while, and :until 135 | clauses." 136 | (assert-compile (= nil ...) "each-iter: one body form allowed" []) 137 | (assert-compile (not= nil body) "each-iter: body form is required" []) 138 | (assert-compile (= 0 (% (length bindings) 2)) 139 | "each-iter: expected an even number of bindings" []) 140 | (assert-compile (binding? (. bindings 1)) 141 | "each-iter: first binding must be to an iterator" []) 142 | (each-iter-1 (gensym :inner) nil (partition-bindings bindings) body)) 143 | 144 | (fn doseq [bindings ...] 145 | "Like [[each]], but supports multiple iterators, and adds support for :let, 146 | :when, :while, and :until clauses. Essentially the same as Clojure's `doseq`. 147 | 148 | Note: multiple returns must be destructured as in [[let]], e.g. 149 | (doseq [(k v) (pairs tbl)] ...) rather than (each [k v (pairs tbl)] ...)" 150 | (fn doseq-1 [[fst snd & more-bindings] ...] 151 | (match (values fst snd) 152 | (nil nil) ... 153 | ;; modifiers 154 | (:let let-bindings) `(let ,let-bindings ,(doseq-1 more-bindings ...)) 155 | (:when test) `(when ,test ,(doseq-1 more-bindings ...)) 156 | (:while test) `(if ,test ,(doseq-1 more-bindings ...) (lua "do break end")) 157 | (:until test) `(if ,test (lua "do break end") ,(doseq-1 more-bindings ...)) 158 | ;; iterator 159 | (where (bind* expr) (binding? bind*)) 160 | (let [each-forms (if (list? bind*) [(unpack bind*)] [bind*])] 161 | (table.insert each-forms expr) 162 | `(each [,(unpack each-forms)] 163 | ,(doseq-1 more-bindings ...))) 164 | _ (error (.. "doseq: expected a binding (symbol, list, or table) or " 165 | ":let, :while, or :when but saw " (view [fst snd]))))) 166 | (assert (binding? (. bindings 1)) "doseq: first binding must be to an iterator") 167 | (doseq-1 bindings ...)) 168 | 169 | ;; maybe doiter, coiter, doseq? 170 | ;; or each-iter coroutine-iter, each+ 171 | (fn coroutine-iter [bindings body ...] 172 | "Like [[each-iter]], but using a coroutine. More efficient for deeply nested 173 | iterators, or if there is a `:when` condition that is rarely satisfied." 174 | `(coroutine.wrap 175 | (fn [] 176 | ,(doseq bindings `(coroutine.yield ,body))))) 177 | 178 | ; ;; multi-iterator-aware collect and icollect versions 179 | 180 | (fn collect* [bindings body] 181 | "Like [[collect]], but with syntax like [[doseq]]; that is: 182 | * multi-values must be wrapped in () 183 | * supports nested iterators 184 | * supports :let, :when, and :while" 185 | `(let [tbl# {}] 186 | ,(doseq bindings 187 | `(let [(k# v#) ,body] 188 | (tset tbl# k# v#))) 189 | tbl#)) 190 | 191 | (fn icollect* [bindings body] 192 | "Like [[icollect]], but with syntax like [[doseq]]; that is: 193 | * multi-values must be wrapped in () 194 | * supports nested iterators 195 | * supports :let, :when, and :while" 196 | `(let [tbl# {}] 197 | (var i# 0) 198 | ,(doseq bindings 199 | `(match ,body 200 | v# (do 201 | (set i# (+ i# 1)) 202 | (tset tbl# i# v#)))) 203 | tbl#)) 204 | 205 | 206 | (comment 207 | 208 | (require-macros :bulb.each-iter) 209 | 210 | (macrodebug (let-varg [a 1 b 2] (+ a b))) 211 | (macrodebug (let-varg [a 1 212 | ... (values 2 3 4) 213 | (x ...) ...] 214 | (+ a x (select "#" ...)))) 215 | 216 | (fn map [f iter] 217 | (each-iter [... iter] 218 | (f ...))) 219 | 220 | (fn filter [pred ...] 221 | (macrodebug 222 | (each-iter [... ... 223 | :when (pred ...)] 224 | ...))) 225 | 226 | (fn keep [f iter] 227 | (each-iter [... iter 228 | :let [... (f ...)] 229 | :when (not= nil ...)] 230 | ...)) 231 | 232 | (fn take-while [pred iter] 233 | (each-iter [... iter 234 | :while (pred ...)] 235 | ...)) 236 | 237 | (fn concat [...] 238 | (each-iter [(_ iterable) (ipairs [...]) 239 | ... (iter iterable)] 240 | ...)) 241 | (fn cat [iter] 242 | (each-iter [it iter 243 | ... it] 244 | ...)) 245 | (fn mapcat [f iter] 246 | (each-iter [... iter 247 | :let [it (f ...)] 248 | ... it] 249 | ...)) 250 | 251 | (fn range [stop] 252 | (var i 0) 253 | (fn [] 254 | (when (< i stop) 255 | (set i (+ i 1)) 256 | i))) 257 | 258 | (fn pythagorean-triples [max-side] 259 | (each-iter [c (range max-side) 260 | b (range c) 261 | a (range b) 262 | :let [a2 (* a a) 263 | b2 (* b b) 264 | c2 (* c c)] 265 | :when (= (+ a2 b2) c2)] 266 | (values a b c))) 267 | 268 | (each [a b c (pythagorean-triples 50)] 269 | (print a b c)) 270 | ; 3 4 5 271 | ; 6 8 10 272 | ; 5 12 13 273 | ; 9 12 15 274 | ; 8 15 17 275 | ; 12 16 20 276 | ; 15 20 25 277 | ; 7 24 25 278 | ; 10 24 26 279 | ; 20 21 29 280 | ; 18 24 30 281 | ; 16 30 34 282 | ; 21 28 35 283 | ; 12 35 37 284 | ; 15 36 39 285 | ; 24 32 40 286 | ; 9 40 41 287 | ; 27 36 45 288 | ; 30 40 50 289 | ; 14 48 50 290 | ) 291 | 292 | 293 | ;;; Annotated macroexpansions of each-iter 294 | 295 | (comment 296 | ;; Single iterator 297 | (macrodebug 298 | (each-iter [(i x) (ipairs [1 2 3])] 299 | x)) 300 | 301 | (do 302 | ;; Intiialize 303 | (var (it1 state1 ctrl1 bind1) (ipairs [1 2 3])) 304 | (fn loop1 [] 305 | ;; Each step: call the iterator, save to temporary variables 306 | (set (ctrl1 bind1) (it1 state1 ctrl1)) 307 | ;; Check for the end of iteration 308 | (if (not= nil ctrl1) 309 | ;; Now bind to (i x). This two-step binding is necessary in case table 310 | ;; destructuring is used, since destructuring on `nil` throws. 311 | (let [(i x) (values ctrl1 bind1)] 312 | x) 313 | nil)) 314 | ;; Return the iterator function 315 | loop1) 316 | ) 317 | 318 | (comment 319 | ;; Nested iterators. The basic framework is the same as above, except for the 320 | ;; addition of an `inner` variable, which (aside from the initialization 321 | ;; phase) is always bound to the innermost iterator function. 322 | (macrodebug 323 | (each-iter [(_ x) (ipairs [1 2 3]) 324 | (_ y) (ipairs (range x)) 325 | (_ z) (ipairs (range y))] 326 | (values x y z))) 327 | 328 | (do 329 | (var inner nil) 330 | ;; init 1 331 | (var (it1 state1 ctrl1 bind1) (ipairs [1 2 3])) 332 | (fn loop1 [] 333 | ;; (in 1) step 1 334 | (set (ctrl1 bind1) (it1 state1 ctrl1)) 335 | (if (not= nil ctrl1) 336 | (let [(_ x) (values ctrl1 bind1)] 337 | (do 338 | ;; (in 1) init 2 339 | (var (it2 state2 ctrl2 bind2) (ipairs (range x))) 340 | (fn loop2 [] 341 | ;; (in 2) step 2 342 | (set (ctrl2 bind2) (it2 state2 ctrl2)) 343 | (if (not= nil ctrl2) 344 | (let [(_ y) (values ctrl2 bind2)] 345 | (do 346 | ;; (in 2) init 3 347 | (var (it3 state3 ctrl3 bind3) (ipairs (range y))) 348 | (fn loop3 [] 349 | ;; (in 3) step 3 350 | (set (ctrl3 bind3) (it3 state3 ctrl3)) 351 | (if (not= nil ctrl3) 352 | (let [(_ z) (values ctrl3 bind3)] 353 | ;; (in 3) yield a value 354 | (values x y z)) 355 | ;; (in 3) end = get the next value from 2 356 | (loop2))) 357 | ;; (in 2) now that 3 is set up, rebind inner and call it, 358 | ;; which will yield a new (values x y z) 359 | (set inner loop3) 360 | (loop3))) 361 | ;; (in 2) end = get the next value from 1 362 | (loop1))) 363 | ;; (in 1) now that 2 is set up, call it, which will cascade down to 364 | ;; setting up and calling 3. 365 | (loop2))) 366 | ;; (in 1) end = we're done 367 | nil)) 368 | ;; Outermost scope again -- in the initialization phase, inner is bound to 369 | ;; the outermost iterator. Calling it starts the following cascade: 370 | ;; * Call it1 371 | ;; * Set up it2 372 | ;; * Call it2 373 | ;; * Set up it3 374 | ;; * Bind inner <- it3 375 | ;; * Call it3 376 | ;; * Return values 377 | ;; After the initialization phase, inner is bound to it3, so on subsequent 378 | ;; iterations, we just call (inner) 379 | (set inner loop1) 380 | (fn [] (inner))) 381 | ) 382 | 383 | (comment 384 | ;; With modifiers 385 | (macrodebug 386 | (each-iter [(_ x) (ipairs [1 2 3]) 387 | :when (= 0 (% x)) 388 | :let [y (* x x)] 389 | :while (< y 10)] 390 | (values x y))) 391 | 392 | (do 393 | (var (it1 state1 ctrl1 bind1) (ipairs [1 2 3])) 394 | (fn loop1 [] 395 | (set (ctrl1 bind1) (it1 state1 ctrl1)) 396 | (if (not= nil ctrl1) 397 | (let [(_ x) (values ctrl1 bind1)] 398 | ;; when modifier 399 | (if (= 0 (% x)) 400 | ;; let modifier 401 | (let [y (* x x)] 402 | ;; while modifier 403 | (if (< y 10) 404 | (values x y) 405 | ;; while false = end of iteration 406 | ;; if this were a nested iterator, this would call the parent 407 | ;; (outer) iterator instead of returning nil 408 | nil)) 409 | ;; when false = try the next iteration 410 | (loop1))) 411 | nil)) 412 | loop1) 413 | ) 414 | 415 | 416 | {: each-iter 417 | : coroutine-iter 418 | :each-iter2 each-iter-old 419 | : doseq 420 | : collect* 421 | : icollect* 422 | : let-varg} 423 | -------------------------------------------------------------------------------- /src/bulb/init.fnl: -------------------------------------------------------------------------------- 1 | (local B 2 | {:__NAME "Bulb" 3 | :__DOC "Fennel 'core' library."}) 4 | 5 | (macro declare [...] 6 | `(var (,...) nil)) 7 | 8 | (macro defn [name ...] 9 | `(values ,(if (in-scope? name) 10 | `(set ,name (fn ,name ,...)) ; forward declaration 11 | `(fn ,name ,...)) 12 | (tset ,(sym :B) ,(tostring name) ,name))) 13 | 14 | ;; [x] TODO assoc, dissoc, update 15 | ;; [x] TODO take-last drop-last? 16 | ;; [x] TODO even?, odd?, pos?, neg?, other math functions, other predicates, like table? true? 17 | ;; false? nil? 18 | ;; [x] TODO flatten? 19 | ;; [ ] TODO memoize 20 | ;; [x] TODO shuffle 21 | ;; [x] TODO slurp?, spit? 22 | ;; [ ] TODO every-pred?, some-fn? <-- not great names 23 | ;; [x] TODO: take-nth 24 | ;; [x] TODO interleave 25 | 26 | ;; TODO: should we have partition into varargs as well? 27 | 28 | (local mfloor math.floor) 29 | (local mrandom math.random) 30 | (local tinsert table.insert) 31 | (local tsort table.sort) 32 | (local sformat string.format) 33 | (local unpack (or table.unpack _G.unpack)) 34 | 35 | ;; lua has a 200 locals limit, and there are a lot of locals in this file, so 36 | ;; it's split up into 2 giant `do` forms -- this one for the top half of the 37 | ;; file, and a second one for the iterators section 38 | (do 39 | 40 | ;;;; == Predicates and coercions ============================================== 41 | 42 | ;; primitives 43 | 44 | (defn table? [x] (= :table (type x))) 45 | (defn string? [x] (= :string (type x))) 46 | (defn number? [x] (= :number (type x))) 47 | (defn function? [x] (= :function (type x))) 48 | (defn userdata? [x] (= :userdata (type x))) 49 | (defn nil? [x] (= :nil (type x))) 50 | (defn boolean? [x] (= :boolean (type x))) 51 | (defn true? [x] (= true x)) 52 | (defn false? [x] (= false x)) 53 | 54 | ;; functions 55 | 56 | (defn callable? [x] 57 | "Is `x` callable? Returns true for functions and anything with a `__call` 58 | metamethod." 59 | (or (= :function (type x)) 60 | (and (-?> (getmetatable x) (. :__call)) true) 61 | false)) 62 | 63 | ;; bools 64 | 65 | (defn boolean [x] 66 | (if x true false)) 67 | 68 | ;; tables 69 | 70 | (defn empty? [x] 71 | "Returns true if `x` is an empty table or string." 72 | (match (type x) 73 | :table (= nil (next x)) 74 | :string (= "" x))) 75 | 76 | (defn not-empty [x] 77 | "Returns `x`, or nil if `x` is an empty table or string." 78 | (if (empty? x) nil x)) 79 | 80 | (defn array? [x] 81 | "Is `x` an array table? Returns true for tables with a non-nil first item (or 82 | are entirely empty) that are not callable." 83 | (and (= :table (type x)) 84 | (or (not= nil (. x 1)) (= nil (next x))) 85 | (not (callable? x)))) 86 | 87 | (defn hash? [x] 88 | "Is `x` a hash table? Returns true for non-empty tables with a nil first item 89 | that are not callable." 90 | (and (= :table (type x)) 91 | (= nil (. x 1)) 92 | (not= nil (next x)) 93 | (not (callable? x)))) 94 | 95 | (defn hash-or-empty? [x] 96 | "Is `x` a hash table or an empty table? Returns true for tables with a nil 97 | first item that are not callable." 98 | (and (= :table (type x)) 99 | (= nil (. x 1)) 100 | (not (callable? x)))) 101 | 102 | (fn deep=-helper [a b seen] 103 | (if 104 | (= a b) true 105 | (not= :table (type a)) false 106 | (not= :table (type b)) false 107 | (?. seen a b) true 108 | (do 109 | (if (. seen a) 110 | (tset seen a b true) 111 | (tset seen a {b true})) 112 | ;; check b's keys first (just that they exist in `a` at all) 113 | (each [k _ (pairs b)] 114 | (when (= nil (. a k)) 115 | (lua "do return false end"))) 116 | ;; then check a's keys and both values simultaneously 117 | (each [k v (pairs a)] 118 | (when (not (deep=-helper (. a k) (. b k) seen)) 119 | (lua "do return false end"))) 120 | true))) 121 | 122 | (defn deep= [a b] 123 | "Returns true when `a` and `b` are equal. Compares hash-table keys by 124 | identity, and everything else by value." 125 | (if 126 | (= a b) true 127 | (not= :table (type a)) false 128 | (not= :table (type b)) false 129 | (deep=-helper a b {}))) 130 | 131 | ;; numbers 132 | 133 | (defn int? [x] 134 | "Returns true if `x` is a number without a fractional part." 135 | (and (= :number (type x)) 136 | (= x (mfloor x)))) 137 | 138 | (defn float? [x] 139 | "Returns true if `x` is a number with a fractional part." 140 | (and (= :number (type x)) 141 | (not= x (mfloor x)))) 142 | 143 | (defn zero? [x] (= 0 x)) 144 | (defn pos? [x] (< 0 x)) 145 | (defn neg? [x] (< x 0)) 146 | (defn even? [x] (= 0 (% x 2))) 147 | (defn odd? [x] (= 1 (% x 2))) 148 | 149 | 150 | 151 | ;;;; == Math ================================================================== 152 | 153 | (defn inc [x] (+ x 1)) 154 | (defn dec [x] (- x 1)) 155 | (defn clamp [x min max] 156 | (if 157 | (< x min) min 158 | (< max x) max 159 | x)) 160 | 161 | 162 | 163 | ;;;; == Tables ================================================================ 164 | 165 | ;; array tables 166 | 167 | (set B.unpack (or table.unpack _G.unpack)) ; export this handy alias 168 | 169 | (defn conj! [tbl ...] 170 | "Appends all values to `tbl`, returning `tbl`." 171 | (var end (length tbl)) ; a bit faster than table.insert 172 | (for [i 1 (select "#" ...)] 173 | (match (select i ...) 174 | x (do (set end (+ 1 end)) 175 | (tset tbl end x)))) 176 | tbl) 177 | 178 | (defn repeat [n x] 179 | "Returns a table that is `n` copies of `x`" 180 | (let [ret []] 181 | (for [i 1 n] 182 | (tset ret i x)) 183 | ret)) 184 | 185 | (fn flatten-into! [tbl last-idx xs] 186 | (var last last-idx) 187 | (for [i 1 (length xs)] 188 | (let [x (. xs i)] 189 | (if (array? x) 190 | (set last (flatten-into! tbl last x)) 191 | (do (tset tbl last x) 192 | (set last (+ last 1)))))) 193 | last) 194 | 195 | (defn flatten [tbl] 196 | "Flattens nested array tables into a single array (does not flatten hashes)." 197 | (let [ret []] 198 | (when (array? tbl) 199 | (flatten-into! ret 1 tbl)) 200 | ret)) 201 | 202 | (defn shuffle! [tbl] 203 | "Shuffles `tbl` in place." 204 | ;; Fisher-yates 205 | (for [i (length tbl) 2 -1] 206 | (let [j (mrandom i) 207 | tmp (. tbl i)] 208 | (tset tbl i (. tbl j)) 209 | (tset tbl j tmp))) 210 | tbl) 211 | 212 | (defn shuffle [tbl] 213 | "Shuffles `tbl`, returning a new table." 214 | ;; The "inside-out" algorithm 215 | (let [ret [(. tbl 1)]] 216 | (for [i 2 (length tbl)] 217 | (let [j (mrandom i)] 218 | (when (not= j i) 219 | (tset ret i (. ret j))) 220 | (tset ret j (. tbl i)))) 221 | ret)) 222 | 223 | (defn rand-nth [tbl] 224 | "Returns a random item in `tbl`." 225 | (. tbl (mrandom (length tbl)))) 226 | 227 | (defn sort! [tbl ?cmp] 228 | "Sorts `tbl` in place, optionally with a comparison function." 229 | (tsort tbl ?cmp) 230 | tbl) 231 | 232 | (defn sort-by! [f tbl] 233 | "Sorts `tbl` in place by the result of calling `f` on each item." 234 | (tsort tbl (fn [a b] (< (f a) (f b)))) 235 | tbl) 236 | 237 | ;; key/value tables (aka hashes, maps) 238 | 239 | (defn assoc! [tbl ...] 240 | "Adds any number of key/value pairs to `tbl`, returning `tbl`. Like [[tset]] 241 | but for multiple pairs." 242 | (for [i 1 (select "#" ...) 2] 243 | (let [(k v) (select i ...)] 244 | (tset tbl k v))) 245 | tbl) 246 | 247 | (defn assoc-in! [tbl ...] 248 | "(assoc-in! tbl key keys... val) 249 | 250 | Sets a value in a nested table. Like [[tset]], but creates missing 251 | intermediate tables." 252 | (let [n (select "#" ...) 253 | last-k (select (- n 1) ...) 254 | val (select n ...)] 255 | (var t tbl) 256 | (for [i 1 (- n 2)] 257 | (let [k (select i ...)] 258 | (when (= nil (. t k)) 259 | (tset t k {})) 260 | (set t (. t k)))) 261 | (tset t last-k val) 262 | tbl)) 263 | 264 | (defn dissoc! [tbl ...] 265 | "Removes any number of keys from `tbl`, returning `tbl`." 266 | (for [i 1 (select "#" ...)] 267 | (let [k (select i ...)] 268 | (tset tbl k nil))) 269 | tbl) 270 | 271 | (defn update! [tbl k f ...] 272 | "Updates the value of `k` in `tbl` by calling `f` on its current value. Any 273 | additional args are passed after the table value, i.e. (f (. tbl k) ...)" 274 | (tset tbl k (f (. tbl k) ...)) 275 | tbl) 276 | 277 | (defn keys [tbl] 278 | "Returns all keys in `tbl`." 279 | (icollect [k _ (pairs tbl)] 280 | k)) 281 | 282 | (defn vals [tbl] 283 | "Returns all values in `tbl`." 284 | (icollect [_ v (pairs tbl)] 285 | v)) 286 | 287 | (defn copy [tbl] 288 | "Returns a (shallow) copy of `tbl`." 289 | (collect [k v (pairs tbl)] 290 | (values k v))) 291 | 292 | (fn deep-copy-helper [x seen copy-keys?] 293 | (if 294 | (not= :table (type x)) x 295 | (. seen x) (. seen x) 296 | (let [ret {}] 297 | (tset seen x ret) 298 | (each [k v (pairs x)] 299 | (let [k* (if copy-keys? 300 | (deep-copy-helper k seen copy-keys?) 301 | k)] 302 | (tset ret k* (deep-copy-helper v seen copy-keys?)))) 303 | ret))) 304 | 305 | (defn deep-copy [x] 306 | "Returns a deep copy of `tbl`. Does not copy hash-table keys that are tables, 307 | since generally table keys are compared by identity, not value." 308 | (deep-copy-helper x {} false)) 309 | 310 | (defn deep-copy-with-keys [x] 311 | "Like [[deep-copy]], but _does_ copy hash-table keys." 312 | (deep-copy-helper x {} true)) 313 | 314 | (defn select-keys [tbl ...] 315 | "Returns a (shallow) copy of `tbl` that only includes the given `keys` (the 316 | remaining args)." 317 | (let [ret {}] 318 | (for [i 1 (select "#" ...)] 319 | (let [k (select i ...)] 320 | (tset ret k (. tbl k)))) 321 | ret)) 322 | 323 | (defn deep-select-keys [tbl ...] 324 | "Returns a deep copy of `tbl` that only includes the given `keys` (the 325 | remaining args)." 326 | (let [ret {}] 327 | (for [i 1 (select "#" ...)] 328 | (let [k (select i ...)] 329 | (let [v (. tbl k)] 330 | (if (= :table (type v)) 331 | (tset ret k (deep-copy v)) 332 | (tset ret k v))))) 333 | ret)) 334 | 335 | (defn merge! [tbl ...] 336 | "Merges any number of other tables into `tbl`, in place. Ignores nils." 337 | (let [others [...]] 338 | (for [i 1 (select "#" ...)] 339 | (match (. others i) 340 | other (each [k v (pairs other)] 341 | (tset tbl k v)))) 342 | tbl)) 343 | 344 | (defn merge [...] 345 | "Like [[merge!]] but returns a new table." 346 | (merge! {} ...)) 347 | 348 | (defn merge-with! [f tbl ...] 349 | "Merges any number of other tables into `tbl`, in place. When the same key 350 | exists in two tables, calls (f left right) and uses the result. Ignores 351 | nils." 352 | (let [others [...]] 353 | (for [i 1 (select "#" ...)] 354 | (match (. others i) 355 | other (each [k v (pairs other)] 356 | (tset tbl k 357 | (match (. tbl k) 358 | oldv (f oldv v) 359 | _ v)))))) 360 | tbl) 361 | 362 | (defn merge-with [f ...] 363 | "Like [[merge-with!]] but returns a new table." 364 | (merge-with! f {} ...)) 365 | 366 | (fn deep-merge-helper [merge-fn f a b] 367 | (if (and (hash-or-empty? a) (hash-or-empty? b)) 368 | (merge-fn f a b) 369 | (f a b))) 370 | 371 | (defn deep-merge-with! [f ...] 372 | "Merges any number of nested hash tables, recursively, in place. When the 373 | same key exists in two tables, and the values are not both hash tables, calls 374 | (f left right) and uses the result. Ignores nils." 375 | (merge-with! (fn [a b] (deep-merge-helper deep-merge-with! f a b)) ...)) 376 | 377 | (defn deep-merge-with [f ...] 378 | "Like [[deep-merge-with]], but returns a new table." 379 | (merge-with (fn [a b] (deep-merge-helper deep-merge-with f a b)) ...)) 380 | 381 | (fn second-arg [_ b] b) 382 | 383 | (defn deep-merge! [...] 384 | "Merges any number of nested hash tables, recursively, in place. Overwrites 385 | array tables instead of merging them. Ignores nils." 386 | (deep-merge-with! second-arg ...)) 387 | 388 | (defn deep-merge [...] 389 | "Like [[deep-merge!]] but returns a new table." 390 | (deep-merge-with second-arg ...)) 391 | 392 | 393 | 394 | 395 | ;;;; == Functional ============================================================ 396 | 397 | (defn identity [...] 398 | "Returns all arguments." 399 | ...) 400 | 401 | (defn identity1 [x] 402 | "Returns just the first argument." 403 | x) 404 | 405 | (defn identity2 [x y] 406 | "Returns just the first two arguments." 407 | (values x y)) 408 | 409 | (defn comp [...] 410 | "Takes any number of functions and composes them together in order, passing 411 | all values from one function to the next: 412 | ((comp f g) x y z) -> (f (g x y z))" 413 | (match (select "#" ...) 414 | 0 identity 415 | 1 ... 416 | 2 (let [(f g) ...] (fn [...] (f (g ...)))) 417 | 3 (let [(f g h) ...] (fn [...] (f (g (h ...))))) 418 | 4 (let [(f g h x) ...] (fn [...] (f (g (h (x ...)))))) 419 | 5 (let [(f g h x y) ...] (fn [...] (f (g (h (x (y ...))))))) 420 | 6 (let [(f g h x y z) ...] (fn [...] (f (g (h (x (y (z ...)))))))) 421 | n (comp (comp (pick-values 6 ...)) (select 7 ...)))) 422 | 423 | (macro comp-body [n ...] 424 | (let [fn-count (select "#" ...) 425 | bindings [] 426 | syms (list)] 427 | (for [i 1 n] 428 | (tset syms i (gensym))) 429 | (for [i fn-count 1 -1] 430 | (let [f (select i ...) 431 | call (if (= i fn-count) 432 | `(,f ...) 433 | `(,f ,(unpack syms)))] 434 | (table.insert bindings syms) 435 | (table.insert bindings call))) 436 | `(fn [...] 437 | (let ,bindings 438 | (values ,(unpack syms)))))) 439 | 440 | (defn comp1 [...] 441 | "Takes any number of functions and composes them together in order, passing 442 | only 1 value from one function to the next: 443 | ((comp1 f g) x) -> (pick-values 1 (f (pick-values 1 (g x))))" 444 | (match (select "#" ...) 445 | 0 identity1 446 | 1 ... 447 | 2 (let [(f g) ...] (comp-body 1 f g)) 448 | 3 (let [(f g h) ...] (comp-body 1 f g h)) 449 | 4 (let [(f g h x) ...] (comp-body 1 f g h x)) 450 | 5 (let [(f g h x y) ...] (comp-body 1 f g h x y)) 451 | 6 (let [(f g h x y z) ...] (comp-body 1 f g h x y z)) 452 | n (let [(f g h x y z) ...] 453 | (comp1 (comp1 f g h x y z) (select 7 ...))))) 454 | 455 | (defn comp2 [...] 456 | "Takes any number of functions and composes them together in order, passing 457 | only 2 values from one function to the next: 458 | ((comp2 f g) x y) -> (pick-values 2 (f (pick-values 2 (g x y))))" 459 | (match (select "#" ...) 460 | 0 identity2 461 | 1 ... 462 | 2 (let [(f g) ...] (comp-body 2 f g)) 463 | 3 (let [(f g h) ...] (comp-body 2 f g h)) 464 | 4 (let [(f g h x) ...] (comp-body 2 f g h x)) 465 | 5 (let [(f g h x y) ...] (comp-body 2 f g h x y)) 466 | 6 (let [(f g h x y z) ...] (comp-body 2 f g h x y z)) 467 | n (let [(f g h x y z) ...] 468 | (comp2 (comp2 f g h x y z) (select 7 ...))))) 469 | 470 | (defn juxt [...] 471 | "Takes any number of functions and returns a fn that returns multiple values, 472 | calling each function in turn: 473 | ((juxt f g h) x) -> (values (f x) (g x) (h x))" 474 | (match (select "#" ...) 475 | 1 ... 476 | 2 (let [(f g) ...] (fn [...] (values (f ...) (g ...)))) 477 | 3 (let [(f g h) ...] (fn [...] (values (f ...) (g ...) (h ...)))) 478 | n (let [fs [...]] (fn [...] (unpack (icollect [_ f (ipairs fs)] (f ...))))))) 479 | 480 | (defn complement [f] 481 | "Returns a function that calls `f` and returns its opposite." 482 | (fn [...] (not (f ...)))) 483 | 484 | (defn fnil [f x ...] 485 | "Returns a function that calls `f`, replacing a nil first argument with `x`. 486 | Takes any number of args, patching as many nil arguments to `f`." 487 | (match (select "#" ...) 488 | 0 (fn [a ...] 489 | (let [a (if (= nil a) x a)] 490 | (f a ...))) 491 | 1 (let [y ...] 492 | (fn [a b ...] 493 | (let [a (if (= nil a) x a) 494 | b (if (= nil b) y b)] 495 | (f a b ...)))) 496 | 2 (let [(y z) ...] 497 | (fn [a b c ...] 498 | (let [a (if (= nil a) x a) 499 | b (if (= nil b) y b) 500 | c (if (= nil c) z c)] 501 | (f a b c ...)))) 502 | nargs (let [replacements [x ...] 503 | n (+ nargs 1)] 504 | (fn [...] 505 | (let [args []] 506 | (for [i 1 (math.max (select "#" ...) n)] 507 | (let [arg (select i ...)] 508 | (if (= nil arg) 509 | (tset args i (. replacements i)) 510 | (tset args i arg)))) 511 | (f (unpack args))))))) 512 | 513 | (local delay-none {}) 514 | (defn delay-fn [f] 515 | "Returns a 'delayed' function. When called the first time, calls `f` and 516 | caches the result for subsequent calls." 517 | (var result delay-none) 518 | (fn [] 519 | (when (= delay-none result) 520 | (set result [(f)])) 521 | (unpack result))) 522 | 523 | 524 | 525 | ;;;; == IO ==================================================================== 526 | 527 | (defn slurp [filename ?mode] 528 | "Reads the full contents of `filename`, optionally with `mode` (default :r)." 529 | (with-open [f (assert (io.open filename (or ?mode :r)))] 530 | (f:read :*a))) 531 | 532 | (defn spit [filename contents ?mode] 533 | "Writes `contents` to `filename`, optionally with `mode` (default :w)." 534 | (with-open [f (assert (io.open filename (or ?mode :w)))] 535 | (f:write contents))) 536 | 537 | (defn pprint [...] 538 | "Like [[print]], but calls [[fennel.view]] on each argument first." 539 | (let [{: view} (require :fennel) 540 | formatted [] 541 | n (select "#" ...)] 542 | (for [i 1 n] 543 | (let [x (select i ...)] 544 | (tset formatted i (view x)))) 545 | (print (unpack formatted 1 n)))) 546 | 547 | (defn printf [fmt ...] 548 | "Calls [[string.format]] on all arguments, and prints the result without a 549 | trailing newline." 550 | (io.write (sformat fmt ...))) 551 | 552 | 553 | 554 | ;;;; == Module utils ========================================================== 555 | 556 | (defn unrequire [mod-name] 557 | "Marks `mod-name` as 'not yet required', so that the next `require` will 558 | reload the module. Works on both lua modules and fennel macro modules." 559 | (tset package :loaded mod-name nil) 560 | (pcall #(tset (require :fennel) :macro-loaded mod-name nil))) 561 | 562 | (defn require! [mod-name] 563 | "Reloads a module." 564 | (unrequire mod-name) 565 | (require mod-name)) 566 | 567 | 568 | ) ; end do 569 | 570 | 571 | ;;;; == Iterators ============================================================= 572 | (do ; see note about locals at the top of the file 573 | 574 | ;;; Stateful vs stateless 575 | 576 | ;; All iterators in this module are stateful, i.e. they are 0-arg functions, 577 | ;; and any state is kept in a closure. This makes the implementation of most 578 | ;; functions simpler, since an there is only one value to keep track of (the 579 | ;; function) per iterator instead of three (function, state, control). 580 | ;; Functions like [[zip]] that use multiple iterators are made significantly 581 | ;; simpler, though of course there are trade-offs. 582 | 583 | ;; The main trade-off is that these iterators are mutable, so you can't copy 584 | ;; them around. For instance, [[cycle]] would be much simpler with stateless 585 | ;; iterators. 586 | 587 | ;; On the other hand, while some of Lua's builtin iterators are stateless 588 | ;; (ipairs and pairs), other are not (string.gmatch and io.lines). Rather than 589 | ;; leaving statefulness or statelessness up to the source iterator, it seemed 590 | ;; simplest to make all iterators stateful and be done with it. 591 | 592 | ;; For a similar library which attempts to preserve stateless iterators, see 593 | ;; luafun. The main disadvantage is that the first value of each of luafun's 594 | ;; iterators is a `state` value which is intended to be discarded from the end 595 | ;; user, but shows up if you iterate manually with for/each, so they provide an 596 | ;; `each` function to deal with that. 597 | 598 | 599 | ;;; Multi-value/varargs treatment 600 | 601 | ;; Most functions in this module know how to handle multiple-value iterators. 602 | ;; Functions that only use the first value returned by an iterator are marked 603 | ;; with "only supports single-value iterators". Some functions come in 604 | ;; single-value and multi-value version: the multi-value version is marked with 605 | ;; `+` (e.g. [[totable]] and [[totable+]]). 606 | 607 | ;; Since multi-vals are not first-class in Lua, we have to jump through some 608 | ;; hoops to get this support. In most situations this means an extra function, 609 | ;; and ends up looking sort of like continuation-passing-style. See [[map]] 610 | ;; (one helper function), and especially [[keep]] (two helper functions) for 611 | ;; examples of this style, although almost every function in this module that 612 | ;; handles multi-vals uses helper functions. When possible, these are lifted 613 | ;; out as (top-level module) locals for efficiency, rather than creating a new 614 | ;; closure each time. 615 | 616 | (local {: array? : callable? : clamp : complement} B) ;; locals from above 617 | (declare iter-cached cached-iter?) 618 | 619 | ;;; -- Basic iterators and predicates ----------------------------------------- 620 | 621 | (defn iterable? [x] 622 | "Is `x` iterable? Returns true for tables, strings, functions, and anything 623 | with a `__call` metamethod." 624 | (match (type x) 625 | :table true 626 | :function true 627 | :string true 628 | _ (callable? x))) 629 | 630 | (fn nil-iter []) ; always returns nil; for internal use only 631 | 632 | (local ipairs-iter (ipairs [])) 633 | 634 | (defn iter-indexed [tbl] 635 | "Iterates over index/value pairs in `tbl`, starting from 1. A stateful 636 | version of [[ipairs]]; identical to (iter (ipairs tbl))." 637 | (var i 0) 638 | (var end (length tbl)) 639 | (fn [] 640 | (when (< i end) 641 | (set i (+ i 1)) 642 | (values i (. tbl i))))) 643 | 644 | (defn iter-kv [tbl] 645 | "Iterates over key/value pairs in `tbl`. A stateful version of [[pairs]]; 646 | identical to (iter (pairs tbl))." 647 | (var last-key nil) 648 | (fn [] 649 | (let [(k v) (next tbl last-key)] 650 | (when (not= nil k) 651 | (set last-key k) 652 | (values k v))))) 653 | 654 | (defn wrap-iter [it state ctrl_] 655 | "Wraps a stateless lua iterator, returning a stateful (single function) 656 | iterator. Typically [[iter]] should be used instead, as it will call this 657 | function when necessary to wrap a stateless iterator." 658 | (var ctrl ctrl_) 659 | (fn step [...] 660 | (when ... 661 | (set ctrl ...) 662 | ...)) 663 | (fn [] 664 | (step (it state ctrl)))) 665 | 666 | (defn iter [x ...] 667 | "Converts a table, function, or string into a stateful iterator. Called by 668 | all iterator functions to coerce their iterable arguments. Typically you only 669 | need to call this function to wrap a stateless iterator. 670 | 671 | Tables are assumed to be arrays and iterate over values, starting from one. 672 | Use [[iter-kv]] to iterate over key/value pairs of hash tables, or the 673 | equivalent (iter (pairs tbl)). Use [[iter-indexed]] to iterate over 674 | index/value pairs of arrays, or the equivalent (iter (ipairs tbl)). 675 | 676 | Strings iterate over each character. 677 | 678 | Functions (and callable tables) are assumed to already be stateful iterators 679 | when passed no additional arguments. With additional arguments, functions are 680 | assumed stateless iterators, and are wrapped using [[wrap-iter]]." 681 | (match (type x) 682 | :function (if 683 | (= 0 (select "#" ...)) x 684 | ;; stateless pairs 685 | (= next x) (iter-kv ...) 686 | ;; stateless ipairs 687 | (= ipairs-iter x) (iter-indexed ...) 688 | ;; otherwise we have to wrap this 689 | (wrap-iter x ...)) 690 | :table (if 691 | (cached-iter? x) (x:copy) 692 | (callable? x) (if (= 0 (select "#" ...)) 693 | x 694 | (wrap-iter x ...)) 695 | :else (do 696 | (var i 0) 697 | (fn [] 698 | (set i (+ i 1)) 699 | (. x i)))) 700 | :string (do 701 | (var i 0) 702 | (var end (length x)) 703 | (fn [] 704 | (when (< i end) 705 | (set i (+ i 1)) 706 | (x:sub i i)))))) 707 | 708 | (defn iterate [f ...] 709 | "Iterates over `f` and any initial values, producing a sequence of 710 | 711 | inits, (f inits), (f (f inits)), ... 712 | 713 | `f` must return the same number of values as it takes, e.g. (iterate f x y z) 714 | returns a 3-value iterator." 715 | (match (select "#" ...) 716 | 0 f 717 | 1 (let [init ...] 718 | (var x nil) 719 | (fn [] 720 | (set x (if (not= nil x) (f x) init)) 721 | x)) 722 | 2 (let [(init-x init-y) ...] 723 | (var (x y) (values nil nil)) 724 | (fn [] 725 | (set (x y) (if (not= nil x) (f x y) (values init-x init-y))) 726 | (values x y))) 727 | 3 (let [(init-x init-y init-z) ...] 728 | (var (x y z) (values nil nil nil)) 729 | (fn [] 730 | (set (x y z) (if (not= nil x) (f x y z) (values init-x init-y init-z))) 731 | (values x y z))) 732 | _ (let [inits [...]] 733 | (var xs nil) 734 | (fn [] 735 | (set xs (if (not= nil xs) [(f (unpack xs))] inits)) 736 | (unpack xs))))) 737 | 738 | (defn range [...] 739 | "(range) -- infinite range 740 | (range end) -- range from 1 to end 741 | (range start end) -- range from start to end 742 | (range start end step) -- range from start to end increasing by step. 743 | 744 | Note that, following lua semantics, ranges start with 1 by default, and `end` 745 | is inclusive. In other words, these are equivalent: 746 | (each [x (range 1 10 3)] (print x)) 747 | (for [x 1 10 3] (print x))" 748 | (match (select "#" ...) 749 | ;; infinite range from 1 750 | 0 (do 751 | (var i 0) 752 | (fn [] (set i (+ 1 i)) i)) 753 | 1 (range 1 ...) 754 | _ (let [(start end step) ...] 755 | (if 756 | (not step) (range start end 1) 757 | (>= step 0) (do 758 | (var i (- start step)) 759 | (fn [] 760 | (set i (+ i step)) 761 | (when (<= i end) 762 | i))) 763 | :else (do 764 | (var i (- start step)) 765 | (fn [] 766 | (set i (+ i step)) 767 | (when (>= i end) 768 | i))))))) 769 | 770 | 771 | ;;; -- Table traversal -------------------------------------------------------- 772 | 773 | ;; Starting with traversal "primitives" that only deal with tables. When passed 774 | ;; iterators, these functions just call the iterator version, i.e. 775 | ;; 776 | ;; (totable (map ...)) 777 | ;; 778 | ;; These are defined before the iterator versions b/c some iterator functions 779 | ;; (e.g. zip) use mapt. 780 | 781 | (declare totable map keep filter remove zip) 782 | 783 | (defn mapt [f ...] 784 | "Like [[map]], but collects results in a table." 785 | (if (and (= :table (type ...)) (= 1 (select "#" ...))) 786 | (let [tbl ... 787 | ret []] 788 | (for [i 1 (length tbl)] 789 | (tset ret i (f (. tbl i)))) 790 | ret) 791 | ;; multiple args or not a table: use the iterator version 792 | (totable (map f ...)))) 793 | 794 | (defn keept [f ...] 795 | "Like [[keep]], but collects results in a table." 796 | (if (and (= :table (type ...)) (= 1 (select "#" ...))) 797 | (let [tbl ... 798 | ret []] 799 | (var last 1) 800 | (for [i 1 (length tbl)] 801 | (let [val (f (. tbl i))] 802 | (when val 803 | (tset ret last val) 804 | (set last (+ last 1))))) 805 | ret) 806 | ;; multiple args or not a table: use the iterator version 807 | (totable (keep f ...)))) 808 | 809 | (defn filtert [f iterable] 810 | "Like [[filter]], but collects results in a table." 811 | (if (= :table (type iterable)) 812 | (let [tbl iterable 813 | ret []] 814 | (var last 1) 815 | (for [i 1 (length tbl)] 816 | (when (f (. tbl i)) 817 | (tset ret last (. tbl i)) 818 | (set last (+ last 1)))) 819 | ret) 820 | ;; not a table: use the iterator version 821 | (totable (filter f iterable)))) 822 | 823 | (defn removet [f iterable] 824 | "Like [[remove]], but collects results in a table." 825 | (filtert (complement f) iterable)) 826 | 827 | (defn ranget [...] 828 | "Like [[range]], but collects results in a table." 829 | (totable (range ...))) 830 | 831 | ;; Hash table versions 832 | 833 | (defn map-kv [f tbl] 834 | "Maps `f` over key/value pairs in `tbl`, returning a new table." 835 | (let [ret {}] 836 | (each [k v (pairs tbl)] 837 | (let [(k* v*) (f k v)] 838 | (if k* (tset ret k* v*)))) 839 | ret)) 840 | 841 | (defn map-vals [f tbl] 842 | "Maps `f` over values in `tbl`, returning a new table." 843 | (map-kv (fn [k v] (values k (f v))) tbl)) 844 | 845 | (defn map-keys [f tbl] 846 | "Maps `f` over keys in `tbl`, returning a new table." 847 | (map-kv (fn [k v] (values (f k) v)) tbl)) 848 | 849 | (defn filter-kv [pred tbl] 850 | "Filters pairs of `tbl` where (pred key val) returns truthy." 851 | (let [ret []] 852 | (each [k v (pairs tbl)] 853 | (if (pred k v) 854 | (tset ret k v))) 855 | ret)) 856 | 857 | (defn filter-keys [pred tbl] 858 | "Filters pairs of `tbl` where (pred key) returns truthy." 859 | (filter-kv (fn [k _] (pred k)) tbl)) 860 | 861 | (defn filter-vals [pred tbl] 862 | "Filters pairs of `tbl` where (pred val) returns truthy." 863 | (filter-kv (fn [_ v] (pred v)) tbl)) 864 | 865 | (defn remove-kv [pred tbl] 866 | "Filters pairs of `tbl` where (pred key val) returns falsey." 867 | (filter-kv (complement pred) tbl)) 868 | 869 | (defn remove-keys [pred tbl] 870 | "Filters pairs of `tbl` where (pred key) returns falsey." 871 | (filter-kv (fn [k _] (not (pred k))) tbl)) 872 | 873 | (defn remove-vals [pred tbl] 874 | "Filters pairs of `tbl` where (pred val) returns falsey." 875 | (filter-kv (fn [_ v] (not (pred v))) tbl)) 876 | 877 | ;;; -- Destructive traversal -------------------------------------------------- 878 | 879 | ;; Same as the above table traversal functions, but mutating the table in-place 880 | ;; instead of returning a new one. 881 | 882 | (defn map! [f tbl] 883 | "Maps `f` over `tbl` in place." 884 | (for [i 1 (length tbl)] 885 | (tset tbl i (f (. tbl i)))) 886 | tbl) 887 | 888 | (defn keep! [f tbl] 889 | "Maps `f` over `tbl` in place, keeping only truthy values." 890 | (let [end (length tbl)] 891 | (var last 1) 892 | (for [i 1 end] 893 | (let [val (f (. tbl i))] 894 | (when val 895 | (tset tbl last val) 896 | (set last (+ last 1))))) 897 | (for [i last end] 898 | (tset tbl i nil)) 899 | tbl)) 900 | 901 | (defn filter! [pred tbl] 902 | "Removes values from `tbl` (in place) where `pred` returns falsey." 903 | (let [end (length tbl)] 904 | (var last 1) 905 | (for [i 1 end] 906 | (when (pred (. tbl i)) 907 | (tset tbl last (. tbl i)) 908 | (set last (+ last 1)))) 909 | (for [i last end] 910 | (tset tbl i nil)) 911 | tbl)) 912 | 913 | (defn remove! [pred tbl] 914 | "Removes values from `tbl` (in place) where `pred` returns truthy." 915 | (filter! (complement pred) tbl)) 916 | 917 | ;; Destructive hash table versions 918 | 919 | (defn map-vals! [f tbl] 920 | "Maps `f` over values in `tbl`, in place." 921 | (each [k v (pairs tbl)] 922 | (tset tbl k (f v))) 923 | tbl) 924 | 925 | (defn remove-kv! [pred tbl] 926 | "Filters pairs of `tbl`, in place, where (pred key val) returns falsey." 927 | (each [k v (pairs tbl)] 928 | (when (pred k v) 929 | (tset tbl k nil))) 930 | tbl) 931 | 932 | (defn remove-keys! [pred tbl] 933 | "Filters pairs of `tbl`, in place, where (pred key) returns falsey." 934 | (remove-kv! (fn [k _] (pred k)) tbl)) 935 | 936 | (defn remove-vals! [pred tbl] 937 | "Filters pairs of `tbl`, in place, where (pred val) returns falsey." 938 | (remove-kv! (fn [_ v] (pred v)) tbl)) 939 | 940 | (defn filter-kv! [pred tbl] 941 | "Filters pairs of `tbl`, in place, where (pred key val) returns truthy." 942 | (remove-kv! (fn [k v] (not (pred k v))) tbl)) 943 | 944 | (defn filter-keys! [pred tbl] 945 | "Filters pairs of `tbl`, in place, where (pred key) returns truthy." 946 | (remove-kv! (fn [k _] (not (pred k))) tbl)) 947 | 948 | (defn filter-vals! [pred tbl] 949 | "Filters pairs of `tbl`, in place, where (pred val) returns truthy." 950 | (remove-kv! (fn [_ v] (not (pred v))) tbl)) 951 | 952 | 953 | ;; -- Extracting values ------------------------------------------------------- 954 | 955 | ;; These mostly return values, not iterators (except for functions that return 956 | ;; slices, like rest/nthrest/butlast) 957 | 958 | (declare drop-last) 959 | 960 | (defn first [x] 961 | "Returns the first item in `x` (any iterable), or nil if empty. 962 | 963 | Note: for iterators, consumes the first value in x and returns it." 964 | (match (type x) 965 | :table (if (callable? x) (x) (. x 1)) 966 | :string (x:sub 1 1) 967 | :function (x) 968 | _ nil)) 969 | 970 | (defn second [x] 971 | "Returns the second item in `x` (any iterable), or nil if empty. 972 | 973 | Note: for iterators, consumes the first two values in x, returning the 974 | second." 975 | (match (type x) 976 | :table (if (callable? x) (do (x) (x)) (. x 2)) 977 | :string (x:sub 2 2) 978 | :function (do (x) (x)) 979 | _ nil)) 980 | 981 | (fn last-iter [it] 982 | (var prev nil) 983 | (fn step [...] 984 | (if (= nil ...) 985 | (if (= :table (type prev)) 986 | (values (unpack prev 1 prev.n)) 987 | prev) 988 | (match (select "#" ...) 989 | 1 (do (set prev ...) (step (it))) 990 | n (do (set prev [...]) (tset prev :n n) (step (it)))))) 991 | (step (it))) 992 | 993 | (defn last [x] 994 | "Returns the last item in `x` (any iterable), or nil if empty. 995 | 996 | Note: for iterators, consumes all values in x and returns the last value." 997 | (match (type x) 998 | :table (if (callable? x) (last-iter x) (. x (length x))) 999 | :string (x:sub -1 -1) 1000 | :function (last-iter x) 1001 | _ nil)) 1002 | 1003 | (defn butlast [x ?n] 1004 | "Returns everything but the last item in `x` (any iterable), or nil if empty. 1005 | With `n`, returns everything but the last `n` items. 1006 | 1007 | Note: for iterators, same as (drop-last 1 x)." 1008 | (let [n (or ?n 1)] 1009 | (match (type x) 1010 | :table (if (callable? x) (drop-last n x) [(unpack x 1 (- (length x) n))]) 1011 | :string (x:sub 1 (- (length x) n)) 1012 | :function (drop-last n x) 1013 | _ nil))) 1014 | 1015 | (fn nthrest-iter [it_ n] 1016 | (var it it_) 1017 | (for [i 1 n] 1018 | (when (= nil (it)) 1019 | (do (set it nil-iter) (lua "do break end")))) 1020 | it) 1021 | 1022 | (defn nthrest [x n] 1023 | "Returns `x` (any iterable) without the first `n` items, or nil if empty. 1024 | 1025 | Note: for iterators, consumes the first n value in x and returns an iterator 1026 | over the remaining values. Essentially an eager version of (drop n x)." 1027 | (match (type x) 1028 | :table (if (callable? x) (nthrest-iter x 1) [(unpack x (+ n 1))]) 1029 | :string (x:sub (+ n 1)) 1030 | :function (nthrest-iter x n) 1031 | _ nil)) 1032 | 1033 | (defn rest [x] 1034 | "Returns `x` (any iterable) without the first item, or nil if empty. 1035 | 1036 | Note: for iterators, consumes the first value in x and returns an iterator 1037 | over the remaining values. Essentially an eager version of (drop 1 x)." 1038 | (nthrest x 1)) 1039 | 1040 | (defn ffirst [x] 1041 | "Same as (first (first x))" 1042 | (first (first x))) 1043 | 1044 | (defn frest [x] 1045 | "Same as (first (rest x))" 1046 | (first (rest x))) 1047 | 1048 | (defn rfirst [x] 1049 | "Same as (rest (first x))" 1050 | (rest (first x))) 1051 | 1052 | (defn llast [x] 1053 | "Same as (last (last x))" 1054 | (last (last x))) 1055 | 1056 | 1057 | ;;; -- Iterator composition --------------------------------------------------- 1058 | 1059 | (defn zip [...] 1060 | "Zips multiple iterables together. Stops with the shortest iterable. Roughly 1061 | equivalent to python's zip(...), or clojure's (map vector ...). Only supports 1062 | single value iterators." 1063 | (match (select "#" ...) 1064 | 1 (iter ...) 1065 | 2 (let [(xs_ ys_) ... 1066 | xs (iter xs_) 1067 | ys (iter ys_)] 1068 | (fn [] 1069 | (let [x (xs) y (ys)] 1070 | (when (not= nil y) 1071 | (values x y))))) 1072 | 3 (let [(xs_ ys_ zs_) ... 1073 | xs (iter xs_) 1074 | ys (iter ys_) 1075 | zs (iter zs_)] 1076 | (fn [] 1077 | (let [x (xs) y (ys) z (zs)] 1078 | (when (and (not= nil y) (not= nil z)) 1079 | (values x y z))))) 1080 | n (let [its (mapt iter [...])] 1081 | (fn [] 1082 | (let [vals (mapt #($) its)] 1083 | (for [i 1 n] 1084 | (when (= nil (. vals i)) 1085 | (lua "do return nil end"))) 1086 | (unpack vals)))))) 1087 | 1088 | (defn enumerate [...] 1089 | "Zips multiple iterables together, prepending the index to each return. 1090 | Essentially (zip (range) ...)." 1091 | (if (and (= :table (type ...)) (= 1 (select "#" ...))) 1092 | (iter-indexed ...) 1093 | (zip (range) ...))) 1094 | 1095 | (defn concat [...] 1096 | "Iterates through any number of iterables, in order." 1097 | (if (= nil ...) 1098 | nil-iter 1099 | (let [its [...]] 1100 | (var i 1) 1101 | (var it (iter (. its 1))) 1102 | (fn step [...] 1103 | (if (not= nil ...) 1104 | ... 1105 | (do 1106 | (set i (+ i 1)) 1107 | (match (. its i) 1108 | it_ (do (set it it_) (step (it))))))) 1109 | #(step (it))))) 1110 | 1111 | (defn cycle [iterable] 1112 | "Repeatedly iterates through all values in `iterable`." 1113 | (let [orig (iter-cached iterable)] 1114 | (var it (orig:copy)) 1115 | (fn step [...] 1116 | (if (not= nil ...) 1117 | ... 1118 | (do 1119 | (set it (orig:copy)) 1120 | (step (it))))) 1121 | #(step (it)))) 1122 | 1123 | (declare catv) 1124 | 1125 | (defn interleave [...] 1126 | "Iterates over the first item in each iterable, then the second, etc. Stops 1127 | at the shortest iterable." 1128 | (catv (zip ...))) 1129 | 1130 | (defn interpose [sep iterable] 1131 | "Iterates over items in `iterable`, adding `sep` between each item. Only 1132 | supports single-value iterators." 1133 | (var it (iter iterable)) 1134 | (var pending nil) 1135 | (var sep? false) 1136 | (fn [] 1137 | (if (and sep? pending) 1138 | (do (set sep? false) sep) 1139 | (match (or pending (it)) 1140 | x (do (set pending (it)) (set sep? true) x) 1141 | _ (do (set it nil-iter) nil))))) 1142 | 1143 | 1144 | 1145 | ;;; -- Traversal (map, filter) ------------------------------------------------ 1146 | 1147 | (fn map-step [f ...] 1148 | (when (not= nil ...) (f ...))) 1149 | 1150 | (defn map [f ...] 1151 | "Maps `f` over any number of `iterables`. `f` should take as many arguments 1152 | as iterables." 1153 | (let [it (zip ...)] 1154 | #(map-step f (it)))) 1155 | 1156 | (fn filter-step [pred it ...] 1157 | (when (not= nil ...) 1158 | (if (pred ...) 1159 | ... 1160 | (filter-step pred it (it))))) 1161 | 1162 | (defn filter [pred iterable] 1163 | "Filters `iterable` to keep only values where `pred` returns truthy." 1164 | (let [it (iter iterable)] 1165 | #(filter-step pred it (it)))) 1166 | 1167 | (defn remove [pred iterable] 1168 | "Filters `iterable` to remove any values where `pred` returns truthy." 1169 | (filter (complement pred) iterable)) 1170 | 1171 | (var keep-step2 nil) 1172 | (var keep-step (fn [f it ...] 1173 | (when (not= nil ...) 1174 | (keep-step2 f it (f ...))))) 1175 | (set keep-step2 (fn [f it ...] 1176 | (if ... 1177 | ... 1178 | (keep-step f it (it))))) 1179 | 1180 | (defn keep [f ...] 1181 | "Maps `f` over any number of iterables, dropping any values where `f` returns 1182 | falsey." 1183 | (let [it (zip ...)] 1184 | #(keep-step f it (it)))) 1185 | 1186 | (defn map-indexed [f ...] 1187 | "Maps `f` over an index and any number of iterables. 1188 | 1189 | Essentially (map f (enumerate ...))." 1190 | (let [it (enumerate ...)] 1191 | #(map-step f (it)))) 1192 | 1193 | (defn keep-indexed [f ...] 1194 | "Maps `f` over an index and any number of iterables, dropping any values 1195 | where `f` returns falsey. 1196 | 1197 | Essentially (keep f (enumerate ...))." 1198 | (let [it (enumerate ...)] 1199 | #(keep-step f it (it)))) 1200 | 1201 | 1202 | ;;; -- Slicing (take, drop) --------------------------------------------------- 1203 | 1204 | (defn take [n iterable] 1205 | "Takes the first `n` items in `iterable`." 1206 | (let [it (iter iterable)] 1207 | (var i (math.max n 0)) 1208 | (fn [] 1209 | (when (not= 0 i) 1210 | (set i (- i 1)) 1211 | (it))))) 1212 | 1213 | (defn take-while [pred iterable] 1214 | "Takes items from `iterable` while (pred item) returns truthy." 1215 | (var it (iter iterable)) 1216 | (fn step [...] 1217 | (if (and (not= nil ...) (pred ...)) 1218 | ... 1219 | (set it nil-iter))) 1220 | #(step (it))) 1221 | 1222 | (defn take-upto [pred iterable] 1223 | "Takes items from `iterable` up to and including the first item for which 1224 | (pred item) returns truthy." 1225 | (var it (iter iterable)) 1226 | (fn step [...] 1227 | (if (and (not= nil ...) (pred ...)) 1228 | (do (set it nil-iter) ...) 1229 | ...)) 1230 | #(step (it))) 1231 | 1232 | (defn take-nth [n iterable] 1233 | "Iterates over each `n` items in `iterable`." 1234 | (let [it (iter iterable)] 1235 | (var first? true) 1236 | (fn [] 1237 | (if (not first?) 1238 | (for [_ 2 n] 1239 | (when (= nil (it)) 1240 | (lua "do return nil end"))) 1241 | (set first? false)) 1242 | (it)))) 1243 | 1244 | (defn drop [n iterable] 1245 | "Drops the first `n` items in `iterable`, iterating over the remainder." 1246 | (let [it (iter iterable)] 1247 | (var i (math.max n 0)) 1248 | (fn loop [] 1249 | (if (= 0 i) 1250 | (it) 1251 | (do 1252 | (set i (- i 1)) 1253 | (when (not= nil (it)) 1254 | (loop))))))) 1255 | 1256 | (defn drop-while [pred iterable] 1257 | "Drops items from `iterable` while (pred item) returns truthy." 1258 | (let [it (iter iterable)] 1259 | (var dropping? true) 1260 | (fn step [...] 1261 | (if dropping? 1262 | (if (and (not= nil ...) (pred ...)) 1263 | (step (it)) 1264 | (do (set dropping? false) ...)) 1265 | ...)) 1266 | #(step (it)))) 1267 | 1268 | (defn drop-upto [pred iterable] 1269 | "Drops items from `iterable` up to and including the first item for which 1270 | (pred item) returns truthy." 1271 | (let [it (iter iterable)] 1272 | (var dropping? true) 1273 | (fn step [...] 1274 | (if (and dropping? (not= nil ...) (pred ...)) 1275 | (do (set dropping? false) (step (it))) 1276 | ...)) 1277 | #(step (it)))) 1278 | 1279 | (defn drop-last [n iterable] 1280 | "Drops the last `n` items in iterable. In other words, _takes_ all but the 1281 | last `n` items." 1282 | (let [head (iter-cached iterable) 1283 | tail (drop n (head:copy))] 1284 | (map #$1 head tail))) 1285 | 1286 | (defn take-last [n iterable] 1287 | "Takes only the last `n` items in iterable. In other words, _drops_ all but 1288 | the last `n` items. Evaluates the entire iterable on the first iteration." 1289 | (let [it (iter-cached iterable)] 1290 | (var first? true) 1291 | (fn [] 1292 | (when first? 1293 | (set first? false) 1294 | ;; run through the whole thing and count how many items there are 1295 | (var count 0) 1296 | (each [_ (it:copy)] (set count (+ count 1))) 1297 | ;; drop all but the last `n` 1298 | (for [_ 1 (- count n)] (it))) 1299 | (it)))) 1300 | 1301 | 1302 | ;;; -- Deduplication ---------------------------------------------------------- 1303 | 1304 | (defn distinct [iterable] 1305 | "Filters `iterable` so that it only contains distinct items. Only supports 1306 | single-value iterators. 1307 | 1308 | Note: values must be table keys. See [[distinct-by]] if you need to use 1309 | multi-value iterators, or for custom equality (e.g. if you need to compare 1310 | tables)." 1311 | (let [it (iter iterable)] 1312 | (var seen {}) 1313 | (fn loop [] 1314 | (match (it) 1315 | x (if (. seen x) 1316 | (loop) 1317 | (do (tset seen x true)) x))))) 1318 | 1319 | (fn distinct-by-step [f seen it ...] 1320 | (when (not= nil ...) 1321 | (let [key (f ...)] 1322 | (if (. seen key) 1323 | (distinct-by-step f seen it (it)) 1324 | (do (tset seen key true) ...))))) 1325 | 1326 | (defn distinct-by [f iterable] 1327 | "Filters `iterable` so that it only contains items that are distinct when 1328 | passed to `f`. Supports multi-value iterators. 1329 | 1330 | NB: `f` must return values that can be used as table keys." 1331 | (let [it (iter iterable) 1332 | seen {}] 1333 | #(distinct-by-step f seen it (it)))) 1334 | 1335 | 1336 | ;;; -- Grouping and flattening (partition, cat) ------------------------------- 1337 | 1338 | ;; Note: grouping functions that have to traverse the whole collection are in 1339 | ;; the "reducing" section (e.g. group-by, frequencies). 1340 | 1341 | (fn partition-table [all? n step pad tbl] 1342 | (let [len (length tbl) 1343 | stop (if 1344 | all? len 1345 | pad (clamp (+ len step (- n) 1) 1 len) 1346 | :else (+ len (- n) 1))] 1347 | (var i 1) 1348 | (fn [] 1349 | (when (<= i stop) 1350 | (let [ret [(unpack tbl i (+ i (- n 1)))]] 1351 | (when (and pad (= nil (. ret n))) 1352 | (for [i 1 (- n (length ret))] 1353 | (tinsert ret (. pad i)))) 1354 | (set i (+ i step)) 1355 | ret))))) 1356 | 1357 | (fn skip-part! [n it] 1358 | (for [_ 1 n] 1359 | (when (= nil (it)) 1360 | (lua "do return end"))) 1361 | true) 1362 | 1363 | (fn fill-part! [tbl n it] 1364 | (for [i 1 (- n (length tbl))] 1365 | (match (it) 1366 | x (tinsert tbl x) 1367 | _ (lua "do break end"))) 1368 | tbl) 1369 | 1370 | (fn partition-iter [all? n step pad iterable] 1371 | (let [gap (when (< n step) (- step n))] 1372 | (var it (iter iterable)) 1373 | (var first? true) 1374 | (var part []) ; next partition 1375 | (fn [] 1376 | (when (or (not gap) first? (skip-part! gap it)) 1377 | (when first? (set first? false)) 1378 | (let [ret (fill-part! part n it)] 1379 | (when (not= nil (. ret 1)) 1380 | ;; take any overlap for the next iteration 1381 | (set part [(unpack ret (+ step 1))]) 1382 | (if (not= nil (. ret n)) 1383 | ;; normal return 1384 | ret 1385 | ;; otherwise we've exhausted the iterator 1386 | (do 1387 | (set it nil-iter) 1388 | (when pad 1389 | (for [i 1 (math.min (length pad) (- n (length ret)))] 1390 | (tinsert ret (. pad i)))) 1391 | (if 1392 | ;; partition-all includes all non-full iterations 1393 | all? ret 1394 | ;; partition with pad just pads the final non-full iteration 1395 | pad (do (set part []) ret) 1396 | ;; partition without pad skips the final non-full iteration 1397 | nil))))))))) 1398 | 1399 | (fn partition-impl [all? ...] 1400 | (match (select "#" ...) 1401 | 2 (let [(n iterable) ...] 1402 | (partition-impl all? n n nil iterable)) 1403 | 3 (let [(n step iterable) ...] 1404 | (partition-impl all? n step nil iterable)) 1405 | 4 (let [(n step pad iterable) ...] 1406 | (if 1407 | (< n 0) nil-iter 1408 | (array? iterable) (partition-table all? n step pad iterable) 1409 | :else (partition-iter all? n step pad iterable))))) 1410 | 1411 | (defn partition [...] 1412 | "(partition n iterable) 1413 | (partition n step iterable) 1414 | (partition n step pad iterable) 1415 | 1416 | Partitions `iterable` into tables, each containing `n` elements. The start of 1417 | each table is separated by `step` iterations. Without `step`, defaults to 1418 | separating by `n` iterations, i.e. without any overlap or gap. 1419 | 1420 | Without `pad`, skips the final group if it contains < `n` elements. 1421 | 1422 | With `pad` (a table), pads the final group with that table. Does not skip the 1423 | final group even if it contains < `n` elements after padding. 1424 | 1425 | Only supports single-value iterators. For multi-value iterators, you may want 1426 | to use [[catv]] to flatten multivals before calling partition." 1427 | (or (partition-impl false ...) 1428 | (error "partition: expected 2, 3, or 4 args"))) 1429 | 1430 | (defn partition-all [...] 1431 | "(partition-all n iterable) 1432 | (partition-all n step iterable) 1433 | (partition-all n step pad iterable) 1434 | 1435 | Like [[partition]], but includes any final groups with < `n` elements. With 1436 | step < n there may be multiple such final groups." 1437 | (or (partition-impl true ...) 1438 | (error "partition-all: expected 2, 3, or 4 args"))) 1439 | 1440 | (defn partition-when [f iterable] 1441 | "Partitions `iterable` into tables, splitting each time `f` returns truthy. 1442 | Only supports single-value iterators." 1443 | (var it (iter iterable)) 1444 | (var pending []) 1445 | (fn loop [] 1446 | (let [x (it)] 1447 | (if 1448 | ;; we're at the end: return any remaining pending items 1449 | (= nil x) 1450 | (when (not= nil (. pending 1)) 1451 | (let [ret pending] 1452 | (set it nil-iter) 1453 | (set pending []) 1454 | ret)) 1455 | ;; we hit a split (and we have a pending group) 1456 | (and (not= nil (. pending 1)) (f x)) 1457 | (let [ret pending] 1458 | (set pending [x]) ; start the next group 1459 | ret) 1460 | ;; no split, keep accumulating 1461 | (do (tinsert pending x) (loop)))))) 1462 | 1463 | (defn partition-by [f iterable] 1464 | "Partitions `iterable` into tables, splitting each time `f` returns a 1465 | different value. Only supports single-value iterators." 1466 | (var prev {}) ; a unique value to start 1467 | (partition-when (fn [...] 1468 | (let [key (f ...)] 1469 | (if (not= key prev) 1470 | (do (set prev key) true)))) 1471 | iterable)) 1472 | 1473 | (defn cat [iterable] 1474 | "Takes an `iterable` that produces other iterable values, and flattens them 1475 | into the output." 1476 | (let [it (iter iterable)] 1477 | (var pending nil-iter) 1478 | (fn step [...] 1479 | (if (not= nil ...) 1480 | ... 1481 | (match (it) 1482 | xs (do 1483 | (set pending (iter xs)) 1484 | (step (pending)))))) 1485 | #(step (pending)))) 1486 | 1487 | (fn catv-fill-pending [pending fst ...] 1488 | (when (not= nil fst) 1489 | (let [count (select "#" ...)] 1490 | (for [i 1 count] 1491 | (tset pending i (select i ...))) 1492 | ;; we're reusing `pending`, so mark the end with a nil 1493 | (tset pending (+ count 1) nil)) 1494 | ;; the first value is returned immediately instead of being added to 1495 | ;; pending 1496 | fst)) 1497 | 1498 | (defn catv [iterable] 1499 | "Takes an `iterable` that produces multiple values, and flattens them into 1500 | the output (i.e. iterates over one value at a time)." 1501 | (let [it (iter iterable) 1502 | pending []] 1503 | (var i 0) 1504 | (fn [] 1505 | (set i (+ i 1)) 1506 | (match (. pending i) 1507 | x x 1508 | _ (do (set i 0) (catv-fill-pending pending (it))))))) 1509 | 1510 | (defn mapcat [f ...] 1511 | "Maps `f` over any number of iterables. `f` should return another iterable 1512 | (e.g. a table), which will be flattened into the output using [[cat]]. 1513 | 1514 | See also [[mapcatv]] to use multiple return values, which can be 1515 | significantly more efficient than returning a table." 1516 | (cat (map f ...))) 1517 | 1518 | (defn mapcatv [f ...] 1519 | "Maps `f` over any number of iterables. `f` may return multiple values, which 1520 | will be flattened into the output using [[catv]]." 1521 | (catv (map f ...))) 1522 | 1523 | 1524 | ;;; -- Reducing --------------------------------------------------------------- 1525 | 1526 | (fn reduce-step [f acc ...] 1527 | (if (not= nil ...) 1528 | (values true (f acc ...)) 1529 | (values nil acc))) 1530 | 1531 | (defn reduce [f ...] 1532 | "(reduce f init iterable) 1533 | (reduce f iterable) -- uses the first value of `iterable` in place of `init` 1534 | 1535 | Repeatedly calls (f result x) for each value in `iterable`, returning the 1536 | result once `iterable` is exhausted. If `iterable` returns multiple values, 1537 | `f` is passed all of them." 1538 | (match ... 1539 | ;; 3-arg reduce 1540 | (?init iterable) (let [it (iter iterable)] 1541 | (var (continue? acc) (values true ?init)) 1542 | (while continue? 1543 | (set (continue? acc) (reduce-step f acc (it)))) 1544 | acc) 1545 | ;; 2-arg reduce 1546 | (iterable) (let [it (iter iterable)] 1547 | ;; (destructively) take the first item as the initial value 1548 | (reduce f (it) it)))) 1549 | 1550 | (defn reductions [f ...] 1551 | "(reductions f init iterable) 1552 | (reductions f iterable) 1553 | 1554 | Iterates over successive steps of reducing `f` over `init` and `iterable`." 1555 | (match ... 1556 | (?init iterable) (let [it (iter iterable)] 1557 | (var (first? continue? acc) (values true true nil)) 1558 | (fn [] 1559 | (if first? 1560 | (do (set first? false) (set acc ?init) acc) 1561 | (match (reduce-step f acc (it)) 1562 | (true x) (do (set acc x) x))))) 1563 | (iterable) (let [it (iter iterable)] 1564 | (var (first? continue? acc) (values true true nil)) 1565 | (fn [] 1566 | (if first? 1567 | (do (set first? false) (set acc (it)) acc) 1568 | (match (reduce-step f acc (it)) 1569 | (true x) (do (set acc x) x))))))) 1570 | 1571 | (defn reduce-kv [f init tbl] 1572 | "Calls (f result k v) for each key/value pair in `tbl`, returning result once 1573 | `tbl` is exhausted." 1574 | (var ret init) 1575 | (each [k v (pairs tbl)] 1576 | (set ret (f ret k v))) 1577 | ret) 1578 | 1579 | ;; this mimics the syntax of fennel's accumulate 1580 | (macro accumulate* [[accum-var init binding iterable] ...] 1581 | `(do 1582 | (var ,accum-var ,init) 1583 | (if (array? ,iterable) 1584 | (for [i# 1 (length ,iterable)] 1585 | (let [,binding (. ,iterable i#)] 1586 | (set ,accum-var (do ,...)))) 1587 | (each [,binding (iter ,iterable)] 1588 | (set ,accum-var (do ,...)))) 1589 | ,accum-var)) 1590 | 1591 | (defn run! [f iterable] 1592 | "Calls `f` on each item in iterable. 1593 | 1594 | Equivalent to (each [x iterable] (f x)), but handles multiple values." 1595 | (reduce (fn [_ ...] (f ...) nil) nil iterable)) 1596 | 1597 | (defn into! [tbl iterable] 1598 | "Collects values from `iterable`, appending them to the end of `tbl`. Only 1599 | supports single-value iterators. See [[into!+]] to use a multi-value 1600 | iterator." 1601 | (var end (length tbl)) 1602 | (accumulate* [tbl tbl 1603 | x iterable] 1604 | (set end (+ 1 end)) 1605 | (tset tbl end x) 1606 | tbl)) 1607 | 1608 | (defn into!+ [tbl iterable] 1609 | "Collects all values from `iterable`, appending each value to the end of 1610 | `tbl`. Supports multi-value iterators." 1611 | ;; a bit faster than table.insert since it caches the length 1612 | (var end (length tbl)) 1613 | (fn step [tbl ...] 1614 | (for [i 1 (select "#" ...)] 1615 | (set end (+ 1 (or end (length tbl)))) 1616 | (tset tbl end (select i ...))) 1617 | tbl) 1618 | (reduce step tbl iterable)) 1619 | 1620 | (defn into-kv! [tbl iterable] 1621 | "Collects key/value pairs from `iterable` into `tbl`." 1622 | (each [k v (iter iterable)] 1623 | (tset tbl k v)) 1624 | tbl) 1625 | 1626 | (defn totable [iterable] 1627 | "Collects each value returned by `iterable` into an array table. Only 1628 | supports single-value iterators. See [[totable+]] for use with a multi-value 1629 | iterator." 1630 | (into! [] iterable)) 1631 | 1632 | (defn totable+ [iterable] 1633 | "Collects each value returned by `iterable` into an array table. Supports 1634 | multi-value iterators." 1635 | (into!+ [] iterable)) 1636 | 1637 | (defn tomap [iterable] 1638 | "Collects key/value pairs returned by `iterable` into a hash table." 1639 | (into-kv! {} iterable)) 1640 | 1641 | (defn zipmap [keys vals] 1642 | "Zips `keys` and `vals` iterators into a hash table." 1643 | (into-kv! {} (zip keys vals))) 1644 | 1645 | ;; Reducing math functions 1646 | 1647 | (defn sum [iterable] 1648 | "Computes the sum of all values in `iterable`. Only supports single-value 1649 | iterators." 1650 | (accumulate* [total 0 x iterable] (+ total x))) 1651 | 1652 | (defn product [iterable] 1653 | "Computes the product of all values in `iterable`. Only supports single-value 1654 | iterators." 1655 | (accumulate* [total 1 x iterable] (* total x))) 1656 | 1657 | (defn minimum [iterable] 1658 | "Returns the minimum value in `iterable`. Items are compared with `<`. Only 1659 | supports single-value iterators." 1660 | (accumulate* [ret nil x iterable] (if (or (= nil ret) (< x ret)) x ret))) 1661 | 1662 | (defn maximum [iterable] 1663 | "Returns the maximum value in `iterable`. Items are compared with `<`. Only 1664 | supports single-value iterators" 1665 | (accumulate* [ret nil x iterable] (if (and (not= nil ret) (< x ret)) ret x))) 1666 | 1667 | ;; Reducing grouping functions 1668 | 1669 | (defn frequencies [iterable] 1670 | "Returns a table of {item count} for each item in `iterable`. Only supports 1671 | single-value iterators." 1672 | (accumulate* [ret {} 1673 | x iterable] 1674 | (tset ret x (+ 1 (or (. ret x) 0))) 1675 | ret)) 1676 | 1677 | (defn group-by [f iterable] 1678 | "Groups items in `iterable`, keyed by the result of calling `f` on each item. 1679 | Each value is the group (table) of items in `iterable` with the corresponding 1680 | key. In other words {(f x) [x etc...]} 1681 | 1682 | Only supports single-value iterators." 1683 | (accumulate* [ret {} 1684 | x iterable] 1685 | (let [k (f x)] 1686 | (match (. ret k) 1687 | xs (tinsert xs x) 1688 | _ (tset ret k [x])) 1689 | ret))) 1690 | 1691 | (defn index-by [f iterable] 1692 | "Returns a map of the elements in `iterable`, keyed by the result of calling 1693 | `f` on each item. Each value is the last item in `iterable` with the 1694 | corresponding key. In other words, {(f x) x} 1695 | 1696 | Only supports single-value iterators." 1697 | (accumulate* [ret {} 1698 | x iterable] 1699 | (tset ret (f x) x) 1700 | ret)) 1701 | 1702 | ;; Reducing predicates 1703 | 1704 | (defn every? [pred iterable] 1705 | "Returns true if all items in `iterable` satisfy `pred`." 1706 | (not ((remove pred iterable)))) 1707 | 1708 | (defn not-every? [pred iterable] 1709 | "Returns true if any of the items in `iterable` does not satisfy `pred`." 1710 | (not (every? pred iterable))) 1711 | 1712 | (defn any? [pred iterable] 1713 | "Returns true if any of the items in `iterable` satisfy `pred`." 1714 | (if ((filter pred iterable)) true false)) 1715 | 1716 | (defn not-any? [pred iterable] 1717 | "Returns true if none of the items in `iterable` satisfy `pred`." 1718 | (not (any? pred iterable))) 1719 | 1720 | (defn find-first [pred iterable] 1721 | "Returns the first item in `iterable` that satisfies `pred`." 1722 | ((filter pred iterable))) 1723 | 1724 | (defn some [f iterable] 1725 | "Returns the first truthy value of (f item) for items in `iterable`." 1726 | ((keep f iterable))) 1727 | 1728 | 1729 | ;;; -- Iterator caching ------------------------------------------------------- 1730 | 1731 | ;; Unlike Clojure's lazy-seq, which is cached by default, we only have one-shot 1732 | ;; iterators. In particular, stateful iterators (string.gmatch, io.lines) can 1733 | ;; only be one-shot iterators (stateless iterators could, in principle, be 1734 | ;; started from anywhere, but we've chosen to wrap those as stateful iterators 1735 | ;; for simplicity; see the comment at the top of the file). 1736 | 1737 | ;; Explicitly cached iterators bring caching and copying to all iterators, at 1738 | ;; the expense of maintaining history in a table. 1739 | 1740 | (var cached-table-meta nil) 1741 | (var cached-string-meta nil) 1742 | (var cached-fn-meta nil) 1743 | 1744 | (set cached-iter? 1745 | (fn [x] 1746 | (match (getmetatable x) 1747 | nil false 1748 | cached-table-meta true 1749 | cached-string-meta true 1750 | cached-fn-meta true 1751 | _ false))) 1752 | 1753 | (fn cached-table [tbl] 1754 | "Optimization for iterating over tables." 1755 | (setmetatable {:table tbl :i 0} cached-table-meta)) 1756 | 1757 | (set cached-table-meta 1758 | {:__call (fn [self] 1759 | (set self.i (+ self.i 1)) 1760 | (. self.table self.i)) 1761 | :__index {:copy (fn [self] 1762 | (setmetatable {:table self.table :i self.i} 1763 | cached-table-meta))}}) 1764 | 1765 | (fn cached-string [x] 1766 | "Optimization for iterating over strings." 1767 | (setmetatable {:string x :i 0 :end (length x)} cached-string-meta)) 1768 | 1769 | (set cached-string-meta 1770 | {:__call (fn [self] 1771 | (when (< self.i self.end) 1772 | (set self.i (+ self.i 1)) 1773 | (self.string:sub self.i self.i))) 1774 | :__index {:copy (fn [self] 1775 | (setmetatable {:string self.string :i self.i :end self.end} 1776 | cached-string-meta))}}) 1777 | 1778 | (fn cached-fn [iterable] 1779 | "A cache wrapper around a function-based iterator" 1780 | (setmetatable {:it (iter iterable) :head {} :i 0} cached-fn-meta)) 1781 | 1782 | (let [vals-sentinel {}] 1783 | ;; Think of this as a chunked linked list. Instead of `head` being a cons 1784 | ;; cell of a single element, it's an array of up to 1024 elements, and `i` is 1785 | ;; the current index within that chunk. Compared to a single array, this 1786 | ;; allows garbage collection, since once we've moved past a chunk it's 1787 | ;; garbage. Compared to a non-chunked linked list it's reasonably 1788 | ;; performant, since it doesn't have to allocate a new table for each item. 1789 | (fn cached-fn-step [{: head &as self} ...] 1790 | (let [n (select "#" ...)] 1791 | (if 1792 | (= nil ...) (set head.end? true) 1793 | (<= n 1) (tset head self.i ...) 1794 | (do 1795 | ;; pack a multival like so: [vals-sentinel count v1 v2 ... vN] 1796 | (var i self.i) 1797 | (tset head i vals-sentinel) 1798 | (set i (+ i 1)) 1799 | (tset head i n) 1800 | (for [j 1 n] 1801 | (set i (+ i 1)) 1802 | (tset head i (select j ...))) 1803 | (set self.i i)))) 1804 | ...) 1805 | 1806 | (fn cached-fn-call [{: it &as self}] 1807 | ;; 1. Increment 1808 | (var i (+ self.i 1)) 1809 | (var head self.head) 1810 | (when (<= 1024 i) 1811 | ;; next cell if we've hit the end of this chunk 1812 | (when (not head.next) (set head.next {})) 1813 | (set self.head head.next) 1814 | (set head self.head) 1815 | (set i 1)) 1816 | ;; 2. Return 1817 | (let [x (. head i)] 1818 | (if 1819 | ;; a multival packed like so: [vals-sentinel count v1 v2 ... vN] 1820 | (= vals-sentinel x) (let [n (. head (+ i 1)) 1821 | start (+ i 2) 1822 | stop (+ i 1 n)] 1823 | (set self.i stop) 1824 | (values (unpack head start stop))) 1825 | ;; a single value 1826 | (not= nil x) (do (set self.i i) x) 1827 | ;; nil, meaning we've run out of cached values and have to ask the 1828 | ;; iterator for a fresh one 1829 | (not head.end?) (do (set self.i i) (cached-fn-step self (it)))))) 1830 | 1831 | (set cached-fn-meta 1832 | {:__call cached-fn-call 1833 | :__index {:copy (fn [{: it : head : i}] 1834 | (setmetatable {: it : head : i} cached-fn-meta))}})) 1835 | 1836 | (defn iter-cached [iterable] 1837 | "Returns a cached copy of an iterable. 1838 | 1839 | Cached iterators can be used transparently with functions in this module; if 1840 | you want to use them outside this module (e.g. with generic for), you should 1841 | call the `copy` method to get a fresh copy that starts from the beginning. 1842 | 1843 | (let [squares (iter-cached (map #(* $ $) (range 10)))] 1844 | ;; functions from this module work fine: 1845 | (sum squares) ; => 385 1846 | 1847 | ;; generic for requires making a copy: 1848 | (var total 0) 1849 | (each [x (squares:copy)] ; <- must copy! 1850 | (set total (+ total x))) 1851 | total) ; => 385" 1852 | (match (type iterable) 1853 | :function (cached-fn (iter iterable)) 1854 | :string (cached-string iterable) 1855 | :table (if 1856 | (cached-iter? iterable) (iterable:copy) 1857 | (callable? iterable) (cached-fn (iter iterable)) 1858 | :else (cached-table iterable)))) 1859 | 1860 | ) ; end iterators 1861 | 1862 | 1863 | (comment 1864 | (local {: require!} (require :bulb)) 1865 | (local b (require! :bulb)) 1866 | (local bi (require! :bulb.iter)) 1867 | (import-macros {: time-only} :bench) 1868 | (bi.totable (bi.take 23 (bi.cycle (bi.concat [:a :b :c] [1 2])))) 1869 | (->> (bi.range 1 100) 1870 | ; (bi.map b.inc) 1871 | (bi.partition 10) 1872 | (bi.mapcat #(bi.map #(/ $ 100) $)) 1873 | (bi.sum) 1874 | ; (bi.into []) 1875 | ) 1876 | 1877 | (bi.totable (bi.concat (bi.range :a :z) (bi.range :A :Z))) 1878 | 1879 | (bi.totable (bi.concat [:a :b :c] [1 2 3] "hello" (bi.range 10))) 1880 | 1881 | (bi.totable (bi.mapcat #(bi.totable (bi.range $)) (bi.range 10))) 1882 | 1883 | (bi.mapt #(values $ $ $) (bi.range 10)) 1884 | ;; vs 1885 | (bi.totable (bi.mapcat #[$ $ $] (bi.range 10))) 1886 | 1887 | (bi.tomap (bi.map #(values $ $) [:a :b :c])) 1888 | 1889 | (let [rf (fn [m v] 1890 | (tset m v (+ 1 (or (. m v) 0))) 1891 | m) 1892 | xs (bi.into [] (bi.take 100000 (bi.cycle [:a :b :c :d]))) 1893 | reduce-frequencies (fn [xs] 1894 | (bi.reduce rf {} xs)) 1895 | frequencies bi.frequencies] 1896 | (print :frequencies (time-only 1897 | (for [i 1 1000] 1898 | (frequencies xs)))) 1899 | (print :reduce (time-only 1900 | (for [i 1 1000] 1901 | (reduce-frequencies xs)))) 1902 | (print ((. (require :fennel) :view) (frequencies xs))) 1903 | (print ((. (require :fennel) :view) (reduce-frequencies xs))) 1904 | ) 1905 | (let [xs (bi.totable (bi.range 100000))] 1906 | (print :reduce-all 1907 | (time-only 1908 | (for [i 1 1000] 1909 | (bi.reduce-all (fn [_ a b] (+ a b)) nil xs xs)))) 1910 | (print :reduce 1911 | (time-only 1912 | (for [i 1 1000] 1913 | (bi.reduce (fn [_ x] (+ x x)) nil xs xs)))) 1914 | ) 1915 | 1916 | (let [xs (bi.totable (bi.range 10000))] 1917 | (print :iter (time-only 1918 | (for [i 1 1000] 1919 | (each [x (bi.iter xs)] 1920 | x)))) 1921 | (print :ipairs (time-only 1922 | (for [i 1 1000] 1923 | (each [_ x (ipairs xs)] 1924 | x)))) 1925 | ) 1926 | 1927 | (do 1928 | (print :iterate (time-only 1929 | (for [i 1 1000] 1930 | (each [x (bi.take 1000 (bi.iterate #[(+ 1 (. $ 1))] [0]))] 1931 | x)))) 1932 | (print :iterate-vargs (time-only 1933 | (for [i 1 1000] 1934 | (each [x (bi.take 1000 (bi.iterate #(values $2 (+ $1 $2)) 0 1))] 1935 | x)))) 1936 | ) 1937 | ) 1938 | 1939 | 1940 | ;;;; Memory pressure situations 1941 | (comment 1942 | (local I (require :bulb.iter)) 1943 | (length (I.totable (I.range 1e7))) ;; ok 1944 | (length (I.totable (I.range 1e8))) ;; OOM 1945 | (let [r (I.iter-cached (I.range 1e7)) 1946 | t (I.take 12 r) 1947 | d (I.drop 12 r)] 1948 | [(I.reduce #(+ $ 1) 0 t) 1949 | (I.reduce #(+ $ 1) 0 d)]) 1950 | ; [12 9999988] 1951 | 1952 | ;; this actually works! it's ugly and it takes a while, but it works :) 1953 | (do 1954 | (var r (I.iter-cached (I.range 1e10))) 1955 | ;; have to call copy manually since iter doesn't know about cached3 1956 | (var t (I.take 12 (r:copy))) 1957 | (var d (I.drop 12 (r:copy))) 1958 | (set r nil) 1959 | [(let [head-count (I.reduce #(+ $ 1) 0 t)] 1960 | (set t nil) ; locals clearing 1961 | (collectgarbage) 1962 | head-count) 1963 | (I.reduce #(+ $ 1) 0 (I.map-indexed 1964 | (fn [i x] 1965 | ;; seems like we have to force a gc. not sure why 1966 | ;; lua wouldn't do this under memory pressure 1967 | (when (= 0 (% i 1000000)) 1968 | (collectgarbage)) 1969 | x) d))]) 1970 | 1971 | ;; r holds on to the head since it stays in scope 1972 | (let [r (I.iter-cached (I.range 1e8)) 1973 | t (I.take 12 r) 1974 | d (I.drop 12 r)] 1975 | [(I.reduce #(+ $ 1) 0 t) 1976 | (I.reduce #(+ $ 1) 0 d)]) 1977 | ; PANIC: unprotected error in call to Lua API (not enough memory) 1978 | 1979 | ) 1980 | 1981 | B 1982 | -------------------------------------------------------------------------------- /src/ns.fnl: -------------------------------------------------------------------------------- 1 | (fn map-args [f ...] 2 | (unpack (icollect [_ x (ipairs [...])] 3 | (f x)))) 4 | 5 | ;;; require-like macros 6 | 7 | (fn all-defs [mod-name] 8 | (collect [k v (pairs (require mod-name))] 9 | (when (not (string.match k "^_")) 10 | (values k (sym k))))) 11 | 12 | (fn require-all [mod-name ...] 13 | "Requires a module and locally binds all public symbols from the module." 14 | `(values 15 | ,(map-args (fn [mod] `(local ,(all-defs mod) (require ,mod))) 16 | mod-name ...))) 17 | 18 | (fn require* [binding1 module-name1 ...] 19 | "Like require, but also binds the return value to a symbol, similar to 20 | `import-macros`. Supports destructuring." 21 | (assert (= 0 (% (select "#" binding1 module-name1 ...) 2)) 22 | "expected an even number of binding/module-name pairs") 23 | (let [ret []] 24 | (for [i 1 (+ 2 (select "#" ...)) 2] 25 | (let [(name mod) (select i binding1 module-name1 ...)] 26 | (table.insert ret `(local ,name (require ,mod))))) 27 | `(values ,(unpack ret)))) 28 | 29 | 30 | ;;; ns and exporter macros 31 | 32 | (fn ns [name ?doc ...] 33 | "Clojure-like namespace form. Binds *ns* as the module table. 34 | 35 | Supports the following clauses: 36 | 37 | (:require binding :module ...) 38 | (:require-all :module ...) 39 | (:import-macros binding :module ...) 40 | (:require-macros :module ...)" 41 | (let [docstring (when (= :string (type ?doc)) ?doc)] 42 | (fn strip-values [x] 43 | (if (and (list? x) (= `values (. x 1))) 44 | (unpack x 2) 45 | x)) 46 | `(values 47 | ;; define the *ns* local 48 | (local ,(sym :*ns*) {:_NAME ,(tostring name) 49 | :_DOC ,docstring}) 50 | ;; handle all the clauses 51 | ,(map-args 52 | (fn [form] 53 | (match (when (list? form) form) 54 | [:require & args] (strip-values (require* (unpack args))) 55 | [:import-macros & args] `(import-macros ,(unpack args)) 56 | [:require-macros & args] (map-args #`(require-macros ,$) (unpack args)) 57 | [:require-all & args] (strip-values (require-all (unpack args))) 58 | _ (error (.. "Unknown ns clause: " (view form)) 1))) 59 | (if docstring ... (values ?doc ...)))))) 60 | 61 | (fn ns-export [] 62 | "Returns the namespace table. Must be the last form in the file." 63 | (sym :*ns*)) 64 | 65 | (fn ns-export-macros [] 66 | "Returns only functions from the namespace table. Must be the last form in 67 | the file." 68 | `(collect [k# v# (pairs ,(sym :*ns*))] 69 | (when (= :function (type v#)) 70 | (values k# v#)))) 71 | 72 | 73 | ;;; def/defn/declare 74 | 75 | (fn declare [name1 ...] 76 | (let [declares []] 77 | `(values ,(unpack (icollect [_ name (ipairs [name1 ...])] 78 | `(var ,name nil)))))) 79 | 80 | (fn def [name ?doc val] ; ?doc is ignored since fennel only has fn metadata 81 | "Defines a local and adds it to the *ns* table. 82 | 83 | Use [[local]] or [[var]] to define a private variable." 84 | (if (not val) 85 | (def name nil ?doc) 86 | (if (in-scope? name) 87 | `(values (set-forcibly! ,name ,val) 88 | (tset ,(sym :*ns*) ,(tostring name) ,name)) 89 | `(values (local ,name ,val) 90 | (tset ,(sym :*ns*) ,(tostring name) ,name))))) 91 | 92 | (fn defn [name ...] 93 | "Defines a function and adds it to the *ns* table. 94 | 95 | Use [[fn]] to define a private function." 96 | (if (in-scope? name) 97 | `(values (set-forcibly! ,name (fn ,name ,...)) 98 | (tset ,(sym :*ns*) ,(tostring name) ,name)) 99 | `(values (fn ,name ,...) 100 | (tset ,(sym :*ns*) ,(tostring name) ,name)))) 101 | 102 | {: ns 103 | : require* 104 | : require-all 105 | : declare 106 | : def 107 | : defn 108 | : ns-export 109 | : ns-export-macros} 110 | -------------------------------------------------------------------------------- /test/functional.fnl: -------------------------------------------------------------------------------- 1 | (import-macros {: assert= : is} :test.macros) 2 | (local B (require :bulb)) 3 | (local unpack B.unpack) 4 | 5 | (local tests {}) 6 | 7 | (fn std-comp-tests [comp-fn] 8 | (assert= :x ((comp-fn) :x) "0 arg comp is identity") 9 | (is (= B.inc (comp-fn B.inc)) "1 arg comp returns the original function") 10 | (let [;; http://oeis.org/A075427 11 | fns (B.flatten (B.repeat 10 [#(* 2 $) #(+ $ 1)])) 12 | results [1 2 3 6 7 14 15 30 31 62 63 126 127 254 255 510 511 1022 1023 2046]] 13 | (for [n 1 20] 14 | (assert= (. results n) ((comp-fn (unpack fns (- 21 n))) 0) 15 | (.. "composes " n " functions, right to left"))))) 16 | 17 | (fn tests.comp [] 18 | (std-comp-tests B.comp) 19 | (assert= 220 ((B.comp #(B.sum [$...]) 20 | #(unpack (B.totable (B.mapcat B.range [$...])))) 21 | (values 1 2 3 4 5 6 7 8 9 10)) 22 | "passes multiple args between functions")) 23 | 24 | (fn tests.comp1 [] 25 | (std-comp-tests B.comp1) 26 | (assert= 1 ((B.comp1 #(B.sum [$...]) 27 | #(unpack (B.totable (B.mapcat B.range [$...])))) 28 | (values 1 2 3 4 5 6 7 8 9 10)) 29 | "passes only single arg between functions")) 30 | 31 | (fn tests.comp2 [] 32 | (std-comp-tests B.comp2) 33 | (assert= 2 ((B.comp2 #(B.sum [$...]) 34 | #(unpack (B.totable (B.mapcat B.range [$...])))) 35 | (values 1 2 3 4 5 6 7 8 9 10)) 36 | "passes only two args between functions")) 37 | 38 | (fn tests.juxt [] 39 | (assert= [1] [((B.juxt B.first) (B.ranget 10))]) 40 | (assert= [1 2] [((B.juxt B.first B.second) (B.ranget 10))]) 41 | (assert= [1 2 10] [((B.juxt B.first B.second B.last) (B.ranget 10))]) 42 | (assert= [1 2 10 [1 2 3 4 5 6 7 8 9]] 43 | [((B.juxt B.first B.second B.last B.butlast) (B.ranget 10))])) 44 | 45 | (fn tests.complement [] 46 | (assert= false ((B.complement B.empty?) [])) 47 | (assert= true ((B.complement B.pos?) -1)) 48 | (assert= false ((B.complement B.pos?) 1))) 49 | 50 | (fn tests.fnil [] 51 | (assert= {:a 1 :b 10} (-> {:b 9} 52 | (B.update! :a (B.fnil B.inc 0)) 53 | (B.update! :b (B.fnil B.inc 0)))) 54 | (assert= [:x] ((B.fnil B.conj! [] :x)) "can nil-patch 2 args") 55 | (assert= [:x :y] ((B.fnil B.conj! [] :x :y)) "can nil-patch 3 args") 56 | (assert= [:a :b :c :x :y :z 1 2 3] 57 | ((B.fnil B.conj! [] :x :y :z 1 2 3) [:a :b :c]) 58 | "can nil-patch any number of args") 59 | (assert= [:a :b :c 1 2 3 :last] 60 | ((B.fnil B.conj! [] :x :y :z) [:a :b :c] 1 2 3 :last) 61 | "does not overwrite explicit args")) 62 | 63 | tests 64 | -------------------------------------------------------------------------------- /test/init.fnl: -------------------------------------------------------------------------------- 1 | (local lu (require :test.luaunit)) 2 | (local B (require :bulb)) 3 | (import-macros {: icollect*} :bulb) 4 | 5 | (local test-modules 6 | [:test.predicates 7 | :test.math 8 | :test.tables 9 | :test.functional 10 | :test.iterators]) 11 | 12 | (let [runner (doto (lu.LuaUnit.new) 13 | (: :setOutputType :tap)) 14 | tests (icollect* [(_ mod) (ipairs test-modules) 15 | (k v) (pairs (require mod))] 16 | [(.. mod "." k) v])] 17 | (os.exit (runner:runSuiteByInstances tests))) 18 | -------------------------------------------------------------------------------- /test/iterators.fnl: -------------------------------------------------------------------------------- 1 | (import-macros {: assert= : assert-items=} :test.macros) 2 | (local B (require :bulb)) 3 | (local unpack B.unpack) 4 | 5 | (local tests {}) 6 | 7 | (local callable-table 8 | (setmetatable {} {:__call (fn [])})) 9 | 10 | (fn tests.iterable? [] 11 | (assert= false (B.iterable? nil)) 12 | (assert= false (B.iterable? 1)) 13 | (assert= true (B.iterable? [])) 14 | (assert= true (B.iterable? "")) 15 | (assert= true (B.iterable? #nil)) 16 | (assert= true (B.iterable? callable-table))) 17 | 18 | (fn tests.iter [] 19 | (assert= [1 2 3 4] 20 | (icollect [x (B.iter [1 2 3 4])] x) 21 | "table iter") 22 | (assert= ["1" "2" "3" "4"] 23 | (icollect [x (B.iter "1234")] x) 24 | "string iter") 25 | (assert= [1 2 3 4] 26 | (icollect [x (B.iter (B.iter (B.iter [1 2 3 4])))] x) 27 | "iter can be called multiple times") 28 | (assert= [] (icollect [x (B.iter #nil)] x) 29 | "nil function") 30 | (assert= [] (icollect [x (B.iter "")] x) 31 | "empty string") 32 | (assert= [] (icollect [x (B.iter [])] x) 33 | "empty table")) 34 | 35 | (fn tests.builtin-iters [] 36 | (assert= [[1 :a] [2 :b] [3 :c] [4 :d]] 37 | (icollect [i v (B.iter-indexed [:a :b :c :d])] [i v])) 38 | (assert-items= [[:a 1] [:b 2] [:c 3] [:d 4]] 39 | (icollect [k v (B.iter-kv {:a 1 :b 2 :c 3 :d 4})] [k v]))) 40 | 41 | (fn tests.zip-tables [] 42 | (assert= [[1] [2] [3]] 43 | (icollect [x _extra (B.zip [1 2 3])] [x _extra]) 44 | "1-arg") 45 | (assert= [[1 10] [2 20] [3 30]] 46 | (icollect [x y _extra (B.zip [1 2 3 4] [10 20 30])] [x y _extra]) 47 | "2-arg") 48 | (assert= [[1 10 100] [2 20 200] [3 30 300]] 49 | (icollect [x y z _extra (B.zip [1 2 3 4] [10 20 30] [100 200 300])] [x y z _extra]) 50 | "3-arg") 51 | (assert= [[1 10 100 1000 10000 100000 1000000] 52 | [2 20 200 2000 20000 200000 2000000] 53 | [3 30 300 3000 30000 300000 3000000]] 54 | (icollect [a b c d e f g _extra (B.zip [1 2 3 4] [10 20 30] [100 200 300] 55 | [1000 2000 3000] [10000 20000 30000] 56 | [100000 200000 300000] [1000000 2000000 3000000])] 57 | [a b c d e f g _extra]) 58 | "many args") 59 | (let [as [1 2 3 4] 60 | bs [:a :b :c :d] 61 | cs [9 8 7 6]] 62 | (assert= [as bs cs] 63 | (->> (B.zip as bs cs) 64 | (B.mapt #[$...]) 65 | (unpack) 66 | (B.zip) 67 | (B.mapt #[$...])) 68 | "zip twice is a no-op"))) 69 | 70 | (fn tests.zip-iters [] 71 | (assert= [[:h] [:e] [:l] [:l] [:o]] 72 | (icollect [x _extra (B.zip "hello")] [x _extra]) 73 | "1 string") 74 | (assert= [[:h 1] [:e 2] [:l 3]] 75 | (icollect [x y _extra (B.zip "hello" [1 2 3])] [x y _extra]) 76 | "string and table") 77 | (assert= [[:h 1 :x] [:e 2 :x] [:l 3 :x]] 78 | (icollect [x y z _extra (B.zip "hello" [1 2 3] #:x)] [x y z _extra]) 79 | "string, table, and function") 80 | (assert= [[1 "h" "e" "l" "l" "o"] 81 | [2 "e" "l" "l" "o" " "] 82 | [3 "l" "l" "o" " " " "]] 83 | (icollect [a b c d e f _extra (B.zip [1 2 3] "hello" "ello " 84 | "llo " "lo " "o ")] 85 | [a b c d e f _extra]) 86 | "many iterables")) 87 | 88 | 89 | (fn tests.catv [] 90 | (assert= 15 (->> (B.range 5) (B.map #(values $ $ $)) B.sum) 91 | "map retains multivals") 92 | (assert= 45 (->> (B.range 5) (B.map #(values $ $ $)) B.catv B.sum) 93 | "catv flattens multivals") 94 | (assert= 45 (->> (B.range 5) (B.mapcatv #(values $ $ $)) B.sum) 95 | "mapcatv is just (comp catv map)")) 96 | 97 | (fn tests.mapcat [] 98 | (assert= false (pcall #(->> (B.range 5) (B.mapcat #$) B.sum)) 99 | "mapcat throws on numbers (expects an iterable)") 100 | (assert= false (pcall #(->> (B.range 5) (B.mapcat #(values $ $ $)) B.sum)) 101 | "mapcat throws on multiple numbers (expects an iterable)") 102 | (assert= 45 (->> (B.range 5) (B.mapcat #[$ $ $]) B.sum) 103 | "mapcat flattens tables") 104 | (assert= 45 (->> (B.range 5) (B.mapcat #(B.take 3 (fn [] $))) B.sum) 105 | "mapcat flattens other iterables")) 106 | 107 | (fn each-sum [iterable] 108 | (var total 0) 109 | (each [x iterable] 110 | (set total (+ total x))) 111 | total) 112 | 113 | (fn tests.iter-cached [] 114 | ;; example from the docstring 115 | (let [xs-uncached (B.map #(* $ $) (B.range 10)) 116 | xs (B.iter-cached (B.map #(* $ $) (B.range 10)))] 117 | (assert= 385 (B.sum xs-uncached) "sum works the first time") 118 | (assert= 0 (B.sum xs-uncached) "uncached sum does not work the second time") 119 | (assert= 385 (B.sum xs) "sum works the first time") 120 | (assert= 385 (B.sum xs) "cached sum works the second time") 121 | ;; using generic for 122 | (assert= 385 (each-sum (xs:copy)) 123 | "each works the first time, when copied") 124 | (assert= 385 (each-sum (xs:copy)) 125 | "each works the second time, when copied") 126 | (assert= 0 (do (each-sum xs) (each-sum xs)) 127 | "each does not work twice unless copied"))) 128 | 129 | (fn tests.iter-cached-table [] 130 | (let [xs (B.iter-cached [1 2 3 4 5 6 7 8 9 10])] 131 | (assert= 55 (B.sum xs) "sum works the first time") 132 | (assert= 55 (B.sum xs) "sum works the second time") 133 | ;; using generic for 134 | (assert= 55 (each-sum (xs:copy)) 135 | "each works the first time, when copied") 136 | (assert= 55 (each-sum (xs:copy)) 137 | "each works the second time, when copied") 138 | (assert= 0 (do (each-sum xs) (each-sum xs)) 139 | "each does not work twice unless copied"))) 140 | 141 | (fn tests.iter-cached-string [] 142 | (let [xs (B.iter-cached "hello")] 143 | (assert= [:h :e :l :l :o] (B.totable xs) "totable works the first time") 144 | (assert= [:h :e :l :l :o] (B.totable xs) "totable works the second time") 145 | ;; using generic for 146 | (assert= [:h :e :l :l :o] (icollect [x (xs:copy)] x) 147 | "icollect works the first time, when copied") 148 | (assert= [:h :e :l :l :o] (icollect [x (xs:copy)] x) 149 | "icollect works the second time, when copied") 150 | (assert= [] (do (icollect [x xs] x) (icollect [x xs] x)) 151 | "icollect does not work twice unless copied"))) 152 | 153 | (fn tests.iter-cached-values [] 154 | (let [xs (B.iter-cached (B.map #(values $ $ $) "abc"))] 155 | (assert= [:a :a :a :b :b :b :c :c :c] (B.totable+ xs) 156 | "totable+ works the first time") 157 | (assert= [:a :a :a :b :b :b :c :c :c] (B.totable+ xs) 158 | "totable+ works the second time") 159 | ;; using generic for 160 | (assert= [[:a :a :a] [:b :b :b] [:c :c :c]] (icollect [a b c (xs:copy)] [a b c]) 161 | "icollect works the first time, when copied") 162 | (assert= [[:a :a :a] [:b :b :b] [:c :c :c]] (icollect [a b c (xs:copy)] [a b c]) 163 | "icollect works the first time, when copied") 164 | (assert= [] (do (icollect [a b c xs] [a b c]) (icollect [a b c xs] [a b c])) 165 | "icollect does not work twice unless copied"))) 166 | 167 | (fn tests.iter-cached-stops [] 168 | ;; Without the check for `head.end?` the second and third tests fail 169 | (fn strict-iter [end] 170 | (var i 0) 171 | (fn [] 172 | (set i (+ i 1)) 173 | (if 174 | (<= i end) i 175 | (= i (+ 1 end)) nil ; end condition -- iteration should stop here 176 | (error "too far!")))) 177 | (let [xs (B.iter-cached (strict-iter 10))] 178 | (assert= true (pcall #(B.sum (xs:copy))) 179 | "First time through stops at the right place") 180 | (assert= true (pcall #(B.sum (xs:copy))) 181 | "Second time through stops at the right place") 182 | (assert= true (pcall #(B.sum (xs:copy))) 183 | "Third time through stops at the right place"))) 184 | 185 | 186 | (fn tests.partition-table [] 187 | ;; based on clojure tests 188 | (assert= [[1 2]] (B.totable (B.partition 2 [1 2 3]))) 189 | (assert= [[1 2] [3 4]] (B.totable (B.partition 2 [1 2 3 4]))) 190 | (assert= [] (B.totable (B.partition 2 []))) 191 | 192 | (assert= [[1 2] [4 5]] (B.totable (B.partition 2 3 [1 2 3 4 5 6 7]))) 193 | (assert= [[1 2] [4 5] [7 8]] (B.totable (B.partition 2 3 [1 2 3 4 5 6 7 8]))) 194 | (assert= [] (B.totable (B.partition 2 3 []))) 195 | 196 | (assert= [] (B.totable (B.partition 1 []))) 197 | (assert= [[1] [2] [3]] (B.totable (B.partition 1 [1 2 3]))) 198 | 199 | (assert= [] (B.totable (B.partition 5 [1 2 3]))) 200 | 201 | (assert= [] (B.totable (B.partition -1 [1 2 3]))) 202 | (assert= [] (B.totable (B.partition -2 [1 2 3]))) 203 | 204 | ;; additional tests 205 | (assert= [[1 2 3 4] [3 4 5 6] [5 6 7 8]] 206 | (B.totable (B.partition 4 2 [1 2 3 4 5 6 7 8 9])))) 207 | 208 | (fn tests.partition [] 209 | (assert= [[1 2]] (B.totable (B.partition 2 (B.range 3)))) 210 | (assert= [[1 2] [3 4]] (B.totable (B.partition 2 (B.range 4)))) 211 | (assert= [] (B.totable (B.partition 2 []))) 212 | 213 | (assert= [[1 2] [4 5]] (B.totable (B.partition 2 3 (B.range 7)))) 214 | (assert= [[1 2] [4 5] [7 8]] (B.totable (B.partition 2 3 (B.range 8)))) 215 | (assert= [] (B.totable (B.partition 2 3 #nil))) 216 | 217 | (assert= [] (B.totable (B.partition 1 #nil))) 218 | (assert= [[1] [2] [3]] (B.totable (B.partition 1 (B.range 3)))) 219 | 220 | (assert= [] (B.totable (B.partition 5 (B.range 3)))) 221 | 222 | (assert= [] (B.totable (B.partition -1 (B.range 3)))) 223 | (assert= [] (B.totable (B.partition -2 (B.range 3)))) 224 | 225 | ;; additional tests 226 | (assert= [[1 2 3 4] [3 4 5 6] [5 6 7 8]] 227 | (B.totable (B.partition 4 2 (B.range 9)))) 228 | ;; partition is done on a per-iteration basis, not a per value basis 229 | (assert= [[1 2 3 4] [3 4 5 6] [5 6 7 8]] 230 | (B.totable (B.partition 4 2 (B.map #(values $ $) [1 2 3 4 5 6 7 8 9]))))) 231 | 232 | tests 233 | -------------------------------------------------------------------------------- /test/macros.fnl: -------------------------------------------------------------------------------- 1 | (local M {}) 2 | 3 | ;; Like clojure test 4 | 5 | (fn M.is [assertion ?desc] 6 | `((. (require :test.luaunit) :assert_eval_to_true) 7 | ,assertion ,(or ?desc (tostring (view assertion))))) 8 | 9 | ;; Lispify luaunit assertions 10 | 11 | (fn luaunit-assertion [assertion-name] 12 | (fn [expected code ?desc] 13 | `((. (require :test.luaunit) ,assertion-name) 14 | ,code ,expected ; luaunit expects reverse order by default 15 | ,(or ?desc (tostring (view code)))))) 16 | 17 | (comment 18 | (local assertion-fns (collect [k (pairs (require :test.luaunit))] 19 | (when (k:match "^assert_") 20 | (values (-> k (: :gsub "_" "-") (: :gsub "-equals" "=")) 21 | k)))) 22 | ) 23 | 24 | (local assertion-fns 25 | {:assert-almost= "assert_almost_equals" 26 | :assert-boolean "assert_boolean" 27 | :assert-coroutine "assert_coroutine" 28 | :assert-error "assert_error" 29 | :assert-error-msg-contains "assert_error_msg_contains" 30 | :assert-error-msg-content= "assert_error_msg_content_equals" 31 | :assert-error-msg-matches "assert_error_msg_matches" 32 | :assert-error-msg= "assert_error_msg_equals" 33 | :assert-eval-to-false "assert_eval_to_false" 34 | :assert-eval-to-true "assert_eval_to_true" 35 | :assert-false "assert_false" 36 | :assert-function "assert_function" 37 | :assert-inf "assert_inf" 38 | :assert-is "assert_is" 39 | :assert-is-boolean "assert_is_boolean" 40 | :assert-is-coroutine "assert_is_coroutine" 41 | :assert-is-false "assert_is_false" 42 | :assert-is-function "assert_is_function" 43 | :assert-is-inf "assert_is_inf" 44 | :assert-is-minus-inf "assert_is_minus_inf" 45 | :assert-is-minus-zero "assert_is_minus_zero" 46 | :assert-is-nan "assert_is_nan" 47 | :assert-is-nil "assert_is_nil" 48 | :assert-is-number "assert_is_number" 49 | :assert-is-plus-inf "assert_is_plus_inf" 50 | :assert-is-plus-zero "assert_is_plus_zero" 51 | :assert-is-string "assert_is_string" 52 | :assert-is-table "assert_is_table" 53 | :assert-is-thread "assert_is_thread" 54 | :assert-is-true "assert_is_true" 55 | :assert-is-userdata "assert_is_userdata" 56 | :assert-items= "assert_items_equals" 57 | :assert-minus-inf "assert_minus_inf" 58 | :assert-minus-zero "assert_minus_zero" 59 | :assert-nan "assert_nan" 60 | :assert-nil "assert_nil" 61 | :assert-not-almost= "assert_not_almost_equals" 62 | :assert-not-boolean "assert_not_boolean" 63 | :assert-not-coroutine "assert_not_coroutine" 64 | :assert-not-false "assert_not_false" 65 | :assert-not-function "assert_not_function" 66 | :assert-not-inf "assert_not_inf" 67 | :assert-not-is "assert_not_is" 68 | :assert-not-is-boolean "assert_not_is_boolean" 69 | :assert-not-is-coroutine "assert_not_is_coroutine" 70 | :assert-not-is-false "assert_not_is_false" 71 | :assert-not-is-function "assert_not_is_function" 72 | :assert-not-is-inf "assert_not_is_inf" 73 | :assert-not-is-nan "assert_not_is_nan" 74 | :assert-not-is-nil "assert_not_is_nil" 75 | :assert-not-is-number "assert_not_is_number" 76 | :assert-not-is-string "assert_not_is_string" 77 | :assert-not-is-table "assert_not_is_table" 78 | :assert-not-is-thread "assert_not_is_thread" 79 | :assert-not-is-true "assert_not_is_true" 80 | :assert-not-is-userdata "assert_not_is_userdata" 81 | :assert-not-minus-inf "assert_not_minus_inf" 82 | :assert-not-minus-zero "assert_not_minus_zero" 83 | :assert-not-nan "assert_not_nan" 84 | :assert-not-nil "assert_not_nil" 85 | :assert-not-number "assert_not_number" 86 | :assert-not-plus-inf "assert_not_plus_inf" 87 | :assert-not-plus-zero "assert_not_plus_zero" 88 | :assert-not-str-contains "assert_not_str_contains" 89 | :assert-not-str-icontains "assert_not_str_icontains" 90 | :assert-not-string "assert_not_string" 91 | :assert-not-table "assert_not_table" 92 | :assert-not-table-contains "assert_not_table_contains" 93 | :assert-not-thread "assert_not_thread" 94 | :assert-not-true "assert_not_true" 95 | :assert-not-userdata "assert_not_userdata" 96 | :assert-not= "assert_not_equals" 97 | :assert-number "assert_number" 98 | :assert-plus-inf "assert_plus_inf" 99 | :assert-plus-zero "assert_plus_zero" 100 | :assert-str-contains "assert_str_contains" 101 | :assert-str-icontains "assert_str_icontains" 102 | :assert-str-matches "assert_str_matches" 103 | :assert-string "assert_string" 104 | :assert-table "assert_table" 105 | :assert-table-contains "assert_table_contains" 106 | :assert-thread "assert_thread" 107 | :assert-true "assert_true" 108 | :assert-userdata "assert_userdata" 109 | :assert= "assert_equals"}) 110 | 111 | (each [k v (pairs assertion-fns)] 112 | (tset M k (luaunit-assertion v))) 113 | 114 | M 115 | -------------------------------------------------------------------------------- /test/math.fnl: -------------------------------------------------------------------------------- 1 | (import-macros {: assert= : is} :test.macros) 2 | (local B (require :bulb)) 3 | 4 | (local tests {}) 5 | 6 | (fn tests.inc [] 7 | (assert= 1 (B.inc 0)) 8 | (assert= 1.5 (B.inc 0.5)) 9 | (assert= 0 (B.inc -1))) 10 | 11 | (fn tests.dec [] 12 | (assert= -1 (B.dec 0)) 13 | (assert= -0.5 (B.dec 0.5)) 14 | (assert= 0 (B.dec 1))) 15 | 16 | (fn tests.clamp [] 17 | (assert= 0 (B.clamp 5 0 0)) 18 | (assert= 0 (B.clamp -1 0 0)) 19 | (assert= 5 (B.clamp 5 0 5)) 20 | (assert= 5 (B.clamp 5 5 10)) 21 | (assert= 15 (B.clamp 15 15 15))) 22 | 23 | tests 24 | -------------------------------------------------------------------------------- /test/predicates.fnl: -------------------------------------------------------------------------------- 1 | (import-macros {: assert= : is} :test.macros) 2 | (local B (require :bulb)) 3 | 4 | (local tests {}) 5 | 6 | (local callable-table 7 | (setmetatable {} {:__call (fn [])})) 8 | 9 | (fn tests.table? [] 10 | (is (B.table? {})) 11 | (is (B.table? callable-table)) 12 | (is (not (B.table? ""))) 13 | (is (not (B.table? 1))) 14 | (is (not (B.table? (fn [])))) 15 | (is (not (B.table? nil))) 16 | (is (not (B.table? true))) 17 | (is (not (B.table? false)))) 18 | 19 | (fn tests.string? [] 20 | (is (not (B.string? {}))) 21 | (is (not (B.string? callable-table))) 22 | (is (B.string? "")) 23 | (is (not (B.string? 1))) 24 | (is (not (B.string? (fn [])))) 25 | (is (not (B.string? nil))) 26 | (is (not (B.string? true))) 27 | (is (not (B.string? false)))) 28 | 29 | (fn tests.number? [] 30 | (is (not (B.number? {}))) 31 | (is (not (B.number? callable-table))) 32 | (is (not (B.number? ""))) 33 | (is (B.number? 1)) 34 | (is (not (B.number? (fn [])))) 35 | (is (not (B.number? nil))) 36 | (is (not (B.number? true))) 37 | (is (not (B.number? false)))) 38 | 39 | (fn tests.function? [] 40 | (is (not (B.function? {}))) 41 | (is (not (B.function? callable-table))) 42 | (is (not (B.function? ""))) 43 | (is (not (B.function? 1))) 44 | (is (B.function? (fn []))) 45 | (is (not (B.function? nil))) 46 | (is (not (B.function? true))) 47 | (is (not (B.function? false)))) 48 | 49 | (fn tests.nil? [] 50 | (is (not (B.nil? {}))) 51 | (is (not (B.nil? callable-table))) 52 | (is (not (B.nil? ""))) 53 | (is (not (B.nil? 1))) 54 | (is (not (B.nil? (fn [])))) 55 | (is (B.nil? nil)) 56 | (is (not (B.nil? true))) 57 | (is (not (B.nil? false)))) 58 | 59 | (fn tests.boolean? [] 60 | (is (not (B.boolean? {}))) 61 | (is (not (B.boolean? callable-table))) 62 | (is (not (B.boolean? ""))) 63 | (is (not (B.boolean? 1))) 64 | (is (not (B.boolean? (fn [])))) 65 | (is (not (B.boolean? nil))) 66 | (is (B.boolean? true)) 67 | (is (B.boolean? false))) 68 | 69 | (fn tests.true? [] 70 | (is (not (B.true? {}))) 71 | (is (not (B.true? callable-table))) 72 | (is (not (B.true? ""))) 73 | (is (not (B.true? 1))) 74 | (is (not (B.true? (fn [])))) 75 | (is (not (B.true? nil))) 76 | (is (B.true? true)) 77 | (is (not (B.true? false)))) 78 | 79 | (fn tests.false? [] 80 | (is (not (B.false? {}))) 81 | (is (not (B.false? callable-table))) 82 | (is (not (B.false? ""))) 83 | (is (not (B.false? 1))) 84 | (is (not (B.false? (fn [])))) 85 | (is (not (B.false? nil))) 86 | (is (not (B.false? true))) 87 | (is (B.false? false))) 88 | 89 | (fn tests.callable? [] 90 | (is (not (B.callable? {}))) 91 | (is (B.callable? callable-table)) 92 | (is (not (B.callable? ""))) 93 | (is (not (B.callable? 1))) 94 | (is (B.callable? (fn []))) 95 | (is (not (B.callable? nil))) 96 | (is (not (B.callable? true))) 97 | (is (not (B.callable? false)))) 98 | 99 | (fn tests.boolean [] 100 | (assert= true (B.boolean {})) 101 | (assert= true (B.boolean callable-table)) 102 | (assert= true (B.boolean "")) 103 | (assert= true (B.boolean 1)) 104 | (assert= true (B.boolean 0)) 105 | (assert= true (B.boolean (fn []))) 106 | (assert= false (B.boolean nil)) 107 | (assert= true (B.boolean true)) 108 | (assert= false (B.boolean false))) 109 | 110 | (fn tests.empty? [] 111 | (is (B.empty? {})) 112 | (is (B.empty? callable-table)) 113 | (is (B.empty? "")) 114 | (is (not (B.empty? [""]))) 115 | (is (not (B.empty? "1"))) 116 | (is (not (B.empty? 1))) 117 | (is (not (B.empty? 0))) 118 | (is (not (B.empty? (fn [])))) 119 | (is (not (B.empty? nil))) 120 | (is (not (B.empty? true))) 121 | (is (not (B.empty? false)))) 122 | 123 | (fn tests.not-empty [] 124 | (assert= nil (B.not-empty [])) 125 | (assert= nil (B.not-empty callable-table)) 126 | (assert= nil (B.not-empty "")) 127 | (assert= [""] (B.not-empty [""])) 128 | (assert= "1" (B.not-empty "1"))) 129 | 130 | (fn tests.array? [] 131 | (is (B.array? []) "empty is considered an array by default") 132 | (is (B.array? [1 2 3])) 133 | (is (not (B.array? {:a 1}))) 134 | (is (not (B.array? ""))) 135 | (is (not (B.array? callable-table)))) 136 | 137 | (fn tests.hash? [] 138 | (is (not (B.hash? {})) "empty is _not_ considered a hash by default") 139 | (is (not (B.hash? [1 2 3]))) 140 | (is (B.hash? {:a 1})) 141 | (is (not (B.hash? ""))) 142 | (is (not (B.hash? callable-table)))) 143 | 144 | (fn tests.hash-or-empty? [] 145 | (is (B.hash-or-empty? {})) 146 | (is (not (B.hash-or-empty? [1 2 3]))) 147 | (is (B.hash-or-empty? {:a 1})) 148 | (is (not (B.hash-or-empty? ""))) 149 | (is (not (B.hash-or-empty? callable-table)))) 150 | 151 | (fn tests.int? [] 152 | (is (not (B.int? [1]))) 153 | (is (not (B.int? "1"))) 154 | (is (not (B.int? 1.5))) 155 | (is (B.int? 1.0)) 156 | (is (B.int? -1.0)) 157 | (is (B.int? 123456789)) 158 | (is (not (B.int? 1.00000000001)))) 159 | 160 | (fn tests.float? [] 161 | (is (not (B.float? [1]))) 162 | (is (not (B.float? "1"))) 163 | (is (B.float? 1.5)) 164 | (is (not (B.float? 1.0))) 165 | (is (not (B.float? -1.0))) 166 | (is (not (B.float? 123456789))) 167 | (is (B.float? 1.00000000001))) 168 | 169 | (fn tests.zero? [] 170 | (is (not (B.zero? [1]))) 171 | (is (not (B.zero? "1"))) 172 | (is (B.zero? 0)) 173 | (is (B.zero? (- 0))) 174 | (is (B.zero? 0.00000000000)) 175 | (is (not (B.zero? 0.00000000001)))) 176 | 177 | (fn tests.pos? [] 178 | (is (not (pcall #(B.pos? [1])))) 179 | (is (not (pcall #(B.pos? "1")))) 180 | (is (not (B.pos? 0))) 181 | (is (not (B.pos? (- 0)))) 182 | (is (B.pos? 1)) 183 | (is (B.pos? 20)) 184 | (is (B.pos? 0.00000000001)) 185 | (is (not (B.pos? -0.00000000001)))) 186 | 187 | (fn tests.neg? [] 188 | (is (not (pcall #(B.neg? [1])))) 189 | (is (not (pcall #(B.neg? "1")))) 190 | (is (not (B.neg? 0))) 191 | (is (not (B.neg? (- 0)))) 192 | (is (B.neg? -1)) 193 | (is (B.neg? -20)) 194 | (is (B.neg? -0.00000000001)) 195 | (is (not (B.neg? 0.00000000001)))) 196 | 197 | (fn tests.even? [] 198 | (is (not (pcall #(B.even? [1])))) 199 | (is (B.even? "2")) ; apparently % coerces strings to numbers 200 | (is (B.even? 0)) 201 | (is (B.even? (- 0))) 202 | (is (not (B.even? -1))) 203 | (is (B.even? -22)) 204 | (is (not (B.even? 21))) 205 | (is (not (B.even? 1.5)))) 206 | 207 | (fn tests.odd? [] 208 | (is (not (pcall #(B.odd? [1])))) 209 | (is (B.odd? "1")) ; apparently % coerces strings to numbers 210 | (is (not (B.odd? 0))) 211 | (is (not (B.odd? (- 0)))) 212 | (is (B.odd? -1)) 213 | (is (not (B.odd? -22))) 214 | (is (B.odd? 21)) 215 | (is (not (B.odd? 1.5)))) 216 | 217 | (fn tests.deep= [] 218 | ;; different types 219 | (is (not (B.deep= 0 false))) 220 | (is (not (B.deep= 1 true))) 221 | (is (not (B.deep= false nil))) 222 | (is (not (B.deep= {} nil))) 223 | (is (not (B.deep= {} ""))) 224 | ;; same type, not equal 225 | (is (not (B.deep= 1 0))) 226 | (is (not (B.deep= 1.1 1.2))) 227 | (is (not (B.deep= true false))) 228 | (is (not (B.deep= "" "nope"))) 229 | ;; simple values 230 | (is (B.deep= 1 1)) 231 | (is (B.deep= 1.1 1.1)) 232 | (is (B.deep= true true)) 233 | (is (B.deep= false false)) 234 | (is (B.deep= nil nil)) 235 | (is (B.deep= "" "")) 236 | ;; tables 237 | (let [t {}] (is (B.deep= t t) "identity")) 238 | (is (B.deep= {} {})) 239 | (is (B.deep= [1 2 3] [1 2 3])) 240 | (is (B.deep= [[1] [2] [3] []] [[1] [2] [3] []])) 241 | (is (B.deep= {:a 1 :b [2 3]} {:a 1 :b [2 3]})) 242 | (is (B.deep= {:a {:b {:c {:d [1 2 3]}}}} {:a {:b {:c {:d [1 2 3]}}}})) 243 | ;; tables, not equal 244 | (is (not (B.deep= [1] []))) 245 | (is (not (B.deep= {:a 1} {}))) 246 | (is (not (B.deep= {:a {:b {:c {:d [1]}}}} {:a {:b {:c {:d []}}}}))) 247 | (is (not (B.deep= {[1] 1 [2] 2 [3] 3} {[1] 1 [2] 2 [3] 3})) 248 | "table keys are compared by identity, not value") 249 | ;; tables with cycles 250 | (let [x [1 2 3] y [1 2 3]] 251 | (table.insert x x) 252 | (table.insert y y) 253 | (is (B.deep= x y) 254 | "tables with cycles")) 255 | (let [x [1 2 3 4] y [1 2 3]] 256 | (table.insert x x) 257 | (table.insert y y) 258 | (is (not (B.deep= x y)) 259 | "unequal tables with cycles")) 260 | (let [x [1 2 3 {:a {:b {}}}] y [1 2 3 {:a {:b {}}}]] 261 | (tset x 4 :a :b :c x) 262 | (tset y 4 :a :b :c y) 263 | (is (B.deep= x y) 264 | "tables with nested cycles")) 265 | (let [x [1 2 3] y [1 2 3]] 266 | (tset x x x) 267 | (tset y y y) 268 | (is (not (B.deep= x y)) 269 | "deep= requires keys to be identical"))) 270 | 271 | tests 272 | -------------------------------------------------------------------------------- /test/tables.fnl: -------------------------------------------------------------------------------- 1 | (import-macros {: assert= : assert-items= : assert-not= : is} :test.macros) 2 | (local B (require :bulb)) 3 | 4 | (local tests {}) 5 | 6 | ;;; array tables 7 | 8 | (fn tests.conj! [] 9 | (assert= [0] (B.conj! [0]) "adding no items") 10 | (assert= [0 :a] (B.conj! [0] :a) "adding one item") 11 | (assert= [0 :a :b :c :d] (B.conj! [0] :a :b :c :d) "adding several items") 12 | (assert= [0 :a :b :c :d] (B.conj! [0] :a nil :b nil :c nil :d nil nil) 13 | "nils are skipped")) 14 | 15 | (fn tests.repeat [] 16 | (assert= [] (B.repeat 0 :x)) 17 | (assert= [:x :x :x :x :x :x] (B.repeat 6 :x))) 18 | 19 | (fn tests.flatten-ignore [] 20 | (assert= [] (B.flatten 1) "ignores number args") 21 | (assert= [] (B.flatten :a "ignores string args")) 22 | (assert= [] (B.flatten {:a 1} "ignores hash args"))) 23 | 24 | (fn tests.flatten [] 25 | (assert= [] (B.flatten) "always returns a table") 26 | (assert= [1] (B.flatten [[[[1]]]]) "flattens nested tables") 27 | (assert= [5 4 3 2 1] (B.flatten [[[[5] 4] 3 2] 1]) "flattens all items") 28 | (assert= [5 4 {:x [:y :z]} 3 2 1] (B.flatten [[[[5] 4] {:x [:y :z]} 3 2] 1]) 29 | "does not flatten hashes")) 30 | 31 | (fn shuffle-test-impl [shuffle-fn] 32 | (let [orig (B.ranget 100)] 33 | (var loop-count 0) 34 | (for [i 1 10 :until (not (B.deep= orig (shuffle-fn orig)))] 35 | (set loop-count i)) 36 | (assert-not= 10 loop-count "should eventually return a shuffled array")) 37 | (assert= (B.ranget 100) (B.sort! (shuffle-fn (B.ranget 100))) 38 | "always contains the same elements")) 39 | 40 | ;; shuffle and shuffle! use slightly different algorithms 41 | (fn tests.shuffle [] 42 | (shuffle-test-impl B.shuffle)) 43 | 44 | (fn tests.shuffle! [] 45 | (shuffle-test-impl (B.comp B.shuffle! B.copy))) 46 | 47 | (fn tests.rand-nth [] 48 | (let [items [:a :b :c :d 1 2 3 4]] 49 | (for [i 1 10] 50 | (let [selected-item (B.rand-nth items)] 51 | (is (B.any? (partial = selected-item) items) 52 | "rand-nth always returns items from the input table"))))) 53 | 54 | (fn tests.sort! [] 55 | (assert= (B.ranget 10) (B.sort! (B.ranget 10 1 -1)) 56 | "sort works at all") 57 | (assert= (B.ranget 10 1 -1) (B.sort! (B.ranget 10) #(< $2 $1)) 58 | "sort can take a comparison function")) 59 | 60 | (fn tests.sort-by! [] 61 | (assert= (B.ranget 10) (B.sort-by! B.identity (B.ranget 10 1 -1)) 62 | "identity works the same as sort!") 63 | (assert= (B.ranget 10 1 -1) (B.sort-by! #(- $) (B.ranget 10)) 64 | "can reverse with a custom key fn") 65 | (let [unsorted (B.mapt #{:x $} (B.range 10 1 -1)) 66 | expected (B.mapt #{:x $} (B.range 10))] 67 | (assert= expected (B.sort-by! #$.x unsorted) 68 | "can sort by a table lookup")) 69 | (is (not (pcall #(B.sort-by! #[$ $] (B.range 10)))) 70 | "can't sort by a table")) 71 | 72 | 73 | ;;; kv-tables aka maps 74 | 75 | (fn tests.assoc! [] 76 | (assert= {:a 1} (B.assoc! {:a 1})) 77 | (assert= {:a 1 :b 2 :c 3 :d 4} (B.assoc! {:a 1} :b 2 :c 3 :d 4)) 78 | (assert= [:a :b :c] (B.assoc! [:a] 2 :b 3 :c) 79 | "works on arrays") 80 | (assert= {:a 1} (B.assoc! {:a 1} :b nil) 81 | "assoc with a nil value is a no-op") 82 | (is (not (pcall #(B.assoc! {:a 1} nil 2))) 83 | "nil key is an error")) 84 | 85 | (fn tests.assoc-in! [] 86 | (assert= {:a 1} (B.assoc-in! {} :a 1) "one key is the same as assoc!") 87 | (assert= {:a {:b {:c 1}}} (B.assoc-in! {} :a :b :c 1) "multiple keys") 88 | (assert= {:a {:b {:c 1 :y 3} :x 2}} (B.assoc-in! {:a {:x 2 :b {:y 3}}} :a :b :c 1) 89 | "does not clobber existing tables") 90 | (assert= {:a {:b {:c 1}}} (B.assoc-in! {:a {:b {:c {:d 2}}}} :a :b :c 1) 91 | "clobbers the last value if it is a table")) 92 | 93 | (fn tests.dissoc! [] 94 | (assert= {:a 1 :b 2 :c 3} (B.dissoc! {:a 1 :b 2 :c 3})) 95 | (assert= {:a 1} (B.dissoc! {:a 1 :b 2 :c 3} :b :c)) 96 | (assert= {} (B.dissoc! {:a 1} :a)) 97 | (assert= [:a] (B.dissoc! [:a :b :c] 2 3) 98 | "works on arrays") 99 | (assert= {:a 1} (B.dissoc! {:a 1} :b :c) 100 | "missing key is a no-op") 101 | (is (not (pcall #(B.dissoc! {:a 1} nil))) 102 | "nil key is an error")) 103 | 104 | (fn tests.update! [] 105 | (assert= {:a 1} (B.update! {:a 1} :a B.identity)) 106 | (assert= {:a 2} (B.update! {:a 1} :a B.inc)) 107 | (assert= {:a 10} (B.update! {:a 1} :a B.clamp 10 20) 108 | "passes value as first arg to function") 109 | (assert= [10 10 8] (B.update! [10 9 8] 2 B.inc) 110 | "works on arrays") 111 | (assert= {:a 1} (B.update! {} :a #1) 112 | "called with nil with key doesn't exist") 113 | (is (not (pcall #(B.update! {} :a B.inc))))) 114 | 115 | (fn tests.keys [] 116 | (assert-items= [] (B.keys {})) 117 | (assert-items= [:a :b :c] (B.keys {:a 1 :b 2 :c 3})) 118 | (assert-items= [1 2 3] (B.keys [:a :b :c])) 119 | (is (not (pcall #(B.keys 1))))) 120 | 121 | (fn tests.vals [] 122 | (assert-items= [] (B.vals {})) 123 | (assert-items= [1 2 3] (B.vals {:a 1 :b 2 :c 3})) 124 | (assert-items= [:a :b :c] (B.vals [:a :b :c])) 125 | (is (not (pcall #(B.vals 1))))) 126 | 127 | (fn tests.copy [] 128 | (let [orig-a (B.ranget 10)] 129 | (assert= orig-a (B.copy orig-a) "same value") 130 | (is (not= orig-a (B.copy orig-a)) "not identical")) 131 | (let [orig-b [[1] 2 3 4]] 132 | (assert= orig-b (B.copy orig-b)) 133 | (is (= (. orig-b 1) (. (B.copy orig-b) 1)) "shallow copy was made"))) 134 | 135 | (fn tests.deep-copy [] 136 | (let [orig-a (B.ranget 10)] 137 | (assert= orig-a (B.deep-copy orig-a) "same value") 138 | (is (not= orig-a (B.deep-copy orig-a)) "not identical")) 139 | (let [orig-b [[[[1]]] {:a {:b {:c [:xyz]}}} 2 3 4]] 140 | (assert= orig-b (B.deep-copy orig-b)) 141 | (is (not= (. orig-b 1 1 1) (. (B.deep-copy orig-b) 1 1 1)) 142 | "array deep copy") 143 | (is (not= (. orig-b 2 :a :b :c) (. (B.deep-copy orig-b) 2 :a :b :c)) 144 | "hash deep copy")) 145 | ;; array with a cycle 146 | (let [orig-c [1 2 [[3]]]] 147 | (tset orig-c 3 1 2 orig-c) 148 | (assert= orig-c (B.deep-copy orig-c) "array with cycle is equal") 149 | (is (not= orig-c (B.deep-copy orig-c)) "array with cycle is not identical")) 150 | ;; hash with a cycle 151 | (let [orig-d {:a 1 :b {:c {}}}] 152 | (tset orig-d :b :c orig-d orig-d) 153 | (assert= orig-d (B.deep-copy orig-d) "hash with cycle is equal") 154 | (is (not= orig-d (B.deep-copy orig-d)) "hash with cycle is not identical") 155 | (is (= orig-d (next (. (B.deep-copy orig-d) :b :c))) 156 | "key has not been copied"))) 157 | 158 | (fn tests.deep-copy-with-keys [] 159 | (let [orig {:a 1 :b {:c {}}} 160 | ;; cycle wher the key itself creates a cycle 161 | _ (tset orig :b :c orig orig) 162 | ;; cycle where just the value is a cycle 163 | _ (tset orig :z orig) 164 | copy (B.deep-copy-with-keys orig)] 165 | (assert-not= orig copy 166 | "when copying keys, luaunit doesn't detect equality") 167 | ;; remove the key cycle and contents should compare equal 168 | (tset orig :b :c {}) 169 | (tset copy :b :c {}) 170 | (assert= orig copy "other than the copied key, contents are equal"))) 171 | 172 | (fn tests.select-keys [] 173 | (assert= {} (B.select-keys {:a 1}) "no keys") 174 | (assert= {} (B.select-keys {} :a :b) "empty source table") 175 | (assert= {:a 1} (B.select-keys {:a 1} :a :b)) 176 | (assert= {:a 1} (B.select-keys {:a 1 :b 2} :a)) 177 | (assert= [:a :b :c] (B.select-keys [:a :b :c :d :e :f :g] 1 2 3) "array") 178 | (let [orig {:a {:b {:c 1}}} 179 | copy (B.select-keys orig :a)] 180 | (assert= orig copy) 181 | (is (not= orig copy) "returns a copy") 182 | (is (= (. orig :a) (. copy :a)) "shallow copy"))) 183 | 184 | (fn tests.deep-select-keys [] 185 | (assert= {} (B.deep-select-keys {:a 1}) "no keys") 186 | (assert= {} (B.deep-select-keys {} :a :b) "empty source table") 187 | (assert= {:a 1} (B.deep-select-keys {:a 1} :a :b)) 188 | (assert= {:a 1} (B.deep-select-keys {:a 1 :b 2} :a)) 189 | (assert= [:a :b :c] (B.deep-select-keys [:a :b :c :d :e :f :g] 1 2 3) "array") 190 | (let [orig {:a {:b {:c 1}}} 191 | copy (B.deep-select-keys orig :a)] 192 | (assert= orig copy) 193 | (is (not= orig copy) "returns a copy") 194 | (is (not= (. orig :a :b) (. copy :a :b)) "deep copy"))) 195 | 196 | (fn tests.merge! [] 197 | (assert= nil (B.merge! nil) "returns nil unchanged") 198 | (assert= {} (B.merge! {}) "returns table unchanged") 199 | (assert= {:a 1 :b 2 :c 3} (B.merge! {:a 1} {:b 2} {:c 3}) 200 | "merges any number of tables") 201 | (assert= {:a 10 :b 20 :c 3} (B.merge! {:a 1} {:b 2} {:c 3} {:a 10 :b 20}) 202 | "later values take precedence") 203 | (let [x {}] 204 | (is (= x (B.merge! x {:a 1} {:b 2})) 205 | "merges into the original table")) 206 | (assert= [:a 2 3] (B.merge! [1 2 3] [:a]) 207 | "array overwrites original table")) 208 | 209 | (fn tests.merge [] 210 | (assert= {:a 1 :b 2} (B.merge {} {:a 1} {:b 2})) 211 | (let [x {}] 212 | (is (not= x (B.merge x {:a 1} {:b 2})) 213 | "creates a copy"))) 214 | 215 | (fn tests.merge-with! [] 216 | (assert= {:a 1 :b 9} (B.merge-with! #(+ $1 $2) {:a 1 :b 2} {:b 3} {:b 4})) 217 | (assert= {:a [1 2 3] :b [4] :c [5]} 218 | (B.merge-with! B.into! {:a [1] :b [4]} {:a [2 3]} {:c [5]})) 219 | (assert= {:a 1 :b "234" :c 5} 220 | (B.merge-with! #(.. $1 $2) {:a 1 :b 2} {:b 3} {:b 4} {:c 5}) 221 | "merge function only called with key collision")) 222 | 223 | (fn tests.deep-merge! [] 224 | (assert= {:a {:b {:c [1 2 3] :d [:x :y :z] :e {:f "hello"}}}} 225 | (B.deep-merge! {:a {:b {:c [1 2 3]}}} 226 | {:a {:b {:d [:x :y :z] :e {:f "hello"}}}}) 227 | "merges hashes") 228 | (assert= {:a {:b {:c [:x]}}} 229 | (B.deep-merge! {:a {:b {:c [1 2 3]}}} 230 | {:a {:b {:c [:x]}}}) 231 | "overwrites arrays")) 232 | 233 | (fn tests.deep-merge [] 234 | (let [x {:a {:b {:c [1 2 3]}}}] 235 | (assert= {:a {:b {:c [1 2 3] :d [:x :y :z] :e {:f "hello"}}}} 236 | (B.deep-merge x {:a {:b {:d [:x :y :z] :e {:f "hello"}}}}) 237 | "merges hashes") 238 | (assert= {:a {:b {:c [1 2 3]}}} x 239 | "deep copy made"))) 240 | 241 | (fn tests.deep-merge-with! [] 242 | (assert= {:a {:b {:c [1 2 3 :x]}}} 243 | (B.deep-merge-with! B.into! 244 | {:a {:b {:c [1 2 3]}}} 245 | {:a {:b {:c [:x]}}}) 246 | "calls merge function with arrays") 247 | (assert= {:a {:b {:c [:x 2 3]}}} 248 | (B.deep-merge-with! B.merge! 249 | {:a {:b {:c [1 2 3]}}} 250 | {:a {:b {:c [:x]}}}) 251 | "can still use regular merge")) 252 | 253 | (fn tests.deep-merge-with [] 254 | (let [x {:a {:b {:c [1 2 3]}}}] 255 | ;; Note this only works if the merge fn also makes a copy, so e.g. into! 256 | ;; won't work! 257 | (assert= {:a {:b {:c [:x 2 3]}}} 258 | (B.deep-merge-with B.merge x {:a {:b {:c [:x]}}}) 259 | "calls merge function with arrays") 260 | (assert= {:a {:b {:c [1 2 3]}}} x 261 | "deep copy made"))) 262 | 263 | tests 264 | --------------------------------------------------------------------------------